symantic-document/Symantic/Document/Term.hs

   1 module Symantic.Document.Term
   2  ( module Symantic.Document.Sym
   3  , module Symantic.Document.Term
   4  ) where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.Bool
   8 import Data.Function (($), (.), id)
   9 import Data.Maybe (Maybe(..))
  10 import Data.Monoid (Monoid(..))
  11 import Data.Ord (Ord(..))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.String (IsString(..))
  14 import GHC.Exts (IsList(..))
  15 import Prelude (pred, fromIntegral, Num(..))
  16 import System.Console.ANSI
  17 import qualified Data.List as List
  18 import qualified Data.Text.Lazy as TL
  19 import qualified Data.Text.Lazy.Builder as TLB
  20
  21 import Symantic.Document.Sym
  22
  23 -- * Type 'TermInh'
  24 data TermInh = TermInh
  25  {   termInh_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.
  26  ,   termInh_newline   :: Term            -- ^ How to display 'newline'.
  27  ,   termInh_sgr       :: ![SGR]          -- ^ Active ANSI codes.
  28  ,   termInh_breakable :: !(Maybe Column) -- ^ 'Column' after which to break, or 'Nothing'
  29  ,   termInh_colorable :: !Bool           -- ^ Whether colors are activated or not.
  30  ,   termInh_decorable :: !Bool           -- ^ Whether decorations are activated or not.
  31  }
  32
  33 -- | Default 'TermInh'.
  34 defTermInh :: TermInh
  35 defTermInh = TermInh
  36  { termInh_indent    = 0
  37  , termInh_newline   = newlineWithIndent
  38  , termInh_sgr       = []
  39  , termInh_breakable = Nothing
  40  , termInh_colorable = True
  41  , termInh_decorable = True
  42  }
  43
  44 -- * Type 'TermState'
  45 type TermState = Column
  46
  47 -- | Default 'TermState'.
  48 defTermState :: TermState
  49 defTermState = 0
  50
  51 -- * Type 'Term'
  52 newtype Term = Term
  53  { unTerm :: TermInh -> TermState ->
  54              (TermState -> TLB.Builder -> TLB.Builder) -> -- normal continuation
  55              (TermState -> TLB.Builder -> TLB.Builder) -> -- should-break continuation
  56              TLB.Builder }
  57
  58 -- | Render a 'Term' into a 'TL.Text'.
  59 textTerm :: Term -> TL.Text
  60 textTerm = TLB.toLazyText . runTerm
  61
  62 -- | Render a 'Term' into a 'TLB.Builder'.
  63 runTerm :: Term -> TLB.Builder
  64 runTerm (Term t) = t defTermInh defTermState oko oko
  65         where oko _st = id
  66
  67 instance IsList Term where
  68         type Item Term = Term
  69         fromList = mconcat
  70         toList   = pure
  71 instance Semigroup Term where
  72         x <> y = Term $ \ro st ok ko ->
  73                 unTerm x ro st
  74                  (\sx tx -> unTerm y ro sx
  75                          (\sy ty -> ok sy (tx<>ty))
  76                          (\sy ty -> ko sy (tx<>ty)))
  77                  (\sx tx -> unTerm y ro sx
  78                          (\sy ty -> ko sy (tx<>ty))
  79                          (\sy ty -> ko sy (tx<>ty)))
  80 instance Monoid Term where
  81         mempty  = empty
  82         mappend = (<>)
  83 instance IsString Term where
  84         fromString = string
  85
  86 writeH :: Column -> TLB.Builder -> Term
  87 writeH len t =
  88         Term $ \ro currCol ok ko ->
  89                 let newCol = currCol + len in
  90                 (case termInh_breakable ro of
  91                  Just breakCol | breakCol < newCol -> ko
  92                  _ -> ok)
  93                 newCol t
  94
  95 instance Textable Term where
  96         empty     = Term $ \_ro st ok _ko -> ok st mempty
  97         charH   t = writeH (Nat 1) (TLB.singleton t)
  98         stringH t = writeH (length t) (fromString t)
  99         textH   t = writeH (length t) (TLB.fromText t)
 100         ltextH  t = writeH (length t) (TLB.fromLazyText t)
 101         replicate cnt t | cnt <= 0  = empty
 102                         | otherwise = t <> replicate (pred cnt) t
 103         newline = Term $ \ro -> unTerm (termInh_newline ro) ro
 104 instance Indentable Term where
 105         align t = Term $ \ro st -> unTerm t ro{termInh_indent=st} st
 106         withNewline nl  t = Term $ \ro -> unTerm t ro{termInh_newline=nl}
 107         withIndent  ind t = Term $ \ro -> unTerm t ro{termInh_indent=ind}
 108         incrIndent  ind t = Term $ \ro -> unTerm t ro{termInh_indent=termInh_indent ro + ind}
 109         column f = Term $ \ro st -> unTerm (f st) ro st
 110         indent f = Term $ \ro -> unTerm (f (termInh_indent ro)) ro
 111         newlineWithoutIndent = Term $ \_ro _st ok _ko ->
 112                 ok 0 $ TLB.singleton '\n'
 113         newlineWithIndent = Term $ \ro _st ok _ko ->
 114                 ok (termInh_indent ro) $
 115                         TLB.singleton '\n' <>
 116                         fromString (List.replicate (fromIntegral $ termInh_indent ro) ' ')
 117 instance Breakable Term where
 118         breakable f       = Term $ \ro -> unTerm (f (termInh_breakable ro)) ro
 119         withBreakable b t = Term $ \ro -> unTerm t ro{termInh_breakable=b}
 120         ifBreak y x = Term $ \ro st ok ko ->
 121                 unTerm x ro st ok $
 122                 case termInh_breakable ro of
 123                  Nothing -> ko
 124                  Just{} -> (\_sx _tx -> unTerm y ro st ok ko)
 125         breakpoint onNoBreak onBreak t = Term $ \ro st ok ko ->
 126                 unTerm (onNoBreak <> t) ro st ok $
 127                 case termInh_breakable ro of
 128                  Nothing -> ko
 129                  Just{}  -> (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)
 130
 131 writeSGR :: (TermInh -> Bool) -> SGR -> Term -> Term
 132 writeSGR isOn s (Term t) =
 133         Term $ \ro ->
 134                 if isOn ro
 135                 then unTerm (o <> m <> c) ro
 136                 else t ro
 137         where
 138         o = Term $ \_ro st ok _ko -> ok st $ fromString $ setSGRCode [s]
 139         m = Term $ \ro -> t ro{termInh_sgr=s:termInh_sgr ro}
 140         c = Term $ \ro st ok _ko -> ok st $ fromString $ setSGRCode $ Reset:List.reverse (termInh_sgr ro)
 141
 142 instance Colorable Term where
 143         colorable f       = Term $ \ro -> unTerm (f (termInh_colorable ro)) ro
 144         withColorable b t = Term $ \ro -> unTerm t ro{termInh_colorable=b}
 145         reverse     = writeSGR termInh_colorable $ SetSwapForegroundBackground True
 146         black       = writeSGR termInh_colorable $ SetColor Foreground Dull  Black
 147         red         = writeSGR termInh_colorable $ SetColor Foreground Dull  Red
 148         green       = writeSGR termInh_colorable $ SetColor Foreground Dull  Green
 149         yellow      = writeSGR termInh_colorable $ SetColor Foreground Dull  Yellow
 150         blue        = writeSGR termInh_colorable $ SetColor Foreground Dull  Blue
 151         magenta     = writeSGR termInh_colorable $ SetColor Foreground Dull  Magenta
 152         cyan        = writeSGR termInh_colorable $ SetColor Foreground Dull  Cyan
 153         white       = writeSGR termInh_colorable $ SetColor Foreground Dull  White
 154         blacker     = writeSGR termInh_colorable $ SetColor Foreground Vivid Black
 155         redder      = writeSGR termInh_colorable $ SetColor Foreground Vivid Red
 156         greener     = writeSGR termInh_colorable $ SetColor Foreground Vivid Green
 157         yellower    = writeSGR termInh_colorable $ SetColor Foreground Vivid Yellow
 158         bluer       = writeSGR termInh_colorable $ SetColor Foreground Vivid Blue
 159         magentaer   = writeSGR termInh_colorable $ SetColor Foreground Vivid Magenta
 160         cyaner      = writeSGR termInh_colorable $ SetColor Foreground Vivid Cyan
 161         whiter      = writeSGR termInh_colorable $ SetColor Foreground Vivid White
 162         onBlack     = writeSGR termInh_colorable $ SetColor Background Dull  Black
 163         onRed       = writeSGR termInh_colorable $ SetColor Background Dull  Red
 164         onGreen     = writeSGR termInh_colorable $ SetColor Background Dull  Green
 165         onYellow    = writeSGR termInh_colorable $ SetColor Background Dull  Yellow
 166         onBlue      = writeSGR termInh_colorable $ SetColor Background Dull  Blue
 167         onMagenta   = writeSGR termInh_colorable $ SetColor Background Dull  Magenta
 168         onCyan      = writeSGR termInh_colorable $ SetColor Background Dull  Cyan
 169         onWhite     = writeSGR termInh_colorable $ SetColor Background Dull  White
 170         onBlacker   = writeSGR termInh_colorable $ SetColor Background Vivid Black
 171         onRedder    = writeSGR termInh_colorable $ SetColor Background Vivid Red
 172         onGreener   = writeSGR termInh_colorable $ SetColor Background Vivid Green
 173         onYellower  = writeSGR termInh_colorable $ SetColor Background Vivid Yellow
 174         onBluer     = writeSGR termInh_colorable $ SetColor Background Vivid Blue
 175         onMagentaer = writeSGR termInh_colorable $ SetColor Background Vivid Magenta
 176         onCyaner    = writeSGR termInh_colorable $ SetColor Background Vivid Cyan
 177         onWhiter    = writeSGR termInh_colorable $ SetColor Background Vivid White
 178 instance Decorable Term where
 179         decorable f       = Term $ \ro -> unTerm (f (termInh_decorable ro)) ro
 180         withDecorable b t = Term $ \ro -> unTerm t ro{termInh_decorable=b}
 181         bold      = writeSGR termInh_decorable $ SetConsoleIntensity BoldIntensity
 182         underline = writeSGR termInh_decorable $ SetUnderlining SingleUnderline
 183         italic    = writeSGR termInh_decorable $ SetItalicized True