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