symantic-document/Language/Symantic/Document/Term.hs

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