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.Int (Int)
  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)
  16 import System.Console.ANSI
  17 import Text.Show (Show(..))
  18 import qualified Data.List as List
  19 import qualified Data.Text as Text
  20 import qualified Data.Text.Lazy as TL
  21 import qualified Data.Text.Lazy.Builder as TLB
  22
  23 import Language.Symantic.Document.Sym
  24
  25 -- * Type 'Reader'
  26 data Reader
  27  =   Reader
  28  {   reader_indent      :: !(Indent Term) -- ^ Current indentation level, used by 'newline'.
  29  ,   reader_newline     :: Term           -- ^ How to display 'newline'.
  30  ,   reader_wrap_column :: !(Column Term) -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'.
  31  ,   reader_sgr         :: ![SGR]         -- ^ Active ANSI codes.
  32  }
  33
  34 -- | Default 'Reader'.
  35 defReader :: Reader
  36 defReader = Reader
  37  { reader_indent      = 0
  38  , reader_newline     = newlineWithIndent
  39  , reader_wrap_column = 80
  40  , reader_sgr         = []
  41  }
  42
  43 -- * Type 'State'
  44 type State = Column Term
  45
  46 -- | Default 'State'.
  47 defState :: State
  48 defState = 0
  49
  50 -- * Type 'Term'
  51 newtype Term
  52  =      Term
  53  {    unTerm :: Reader ->
  54                 State  ->
  55                 (State -> TLB.Builder -> TLB.Builder) -> -- normal continuation
  56                 (State -> TLB.Builder -> TLB.Builder) -> -- should-wrap continuation
  57                 TLB.Builder }
  58
  59 type instance Column Term = Int
  60 type instance Indent Term = Int
  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 p) = p 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 Term -> TLB.Builder -> Term
  91 writeH len t =
  92         Term $ \ro st ok ko ->
  93                 let newCol = st + len in
  94                 (if newCol <= reader_wrap_column ro then ok else ko)
  95                 newCol t
  96
  97 instance Doc_Text Term where
  98         empty     = Term $ \_ro st ok _ko -> ok st mempty
  99         charH   t = writeH 1 $ TLB.singleton t
 100         stringH t = writeH (List.length t) (fromString t)
 101         textH   t = writeH (Text.length t) (TLB.fromText t)
 102         ltextH  t = writeH (intOfInt64 $ TL.length t) (TLB.fromLazyText t)
 103         int       = stringH . show
 104         integer   = stringH . show
 105         replicate cnt p | cnt <= 0  = empty
 106                         | otherwise = p <> replicate (pred cnt) p
 107         newline = Term $ \ro -> unTerm (reader_newline ro) ro
 108 instance Doc_Align Term where
 109         align p = Term $ \ro st -> unTerm p ro{reader_indent=st} st
 110         withNewline nl  p = Term $ \ro -> unTerm p ro{reader_newline=nl}
 111         withIndent  ind p = Term $ \ro -> unTerm p ro{reader_indent=ind}
 112         incrIndent  ind p = Term $ \ro -> unTerm p ro{reader_indent=reader_indent ro + ind}
 113         column f = Term $ \ro st -> unTerm (f st) ro st
 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 (reader_indent ro) ' ')
 120 instance Doc_Wrap Term where
 121         ifFit x y = Term $ \ro st ok ko ->
 122                 unTerm x ro st ok (\_sx _tx -> unTerm y ro st ok ko)
 123         breakpoint onNoBreak onBreak p = Term $ \ro st ok ko ->
 124                 unTerm (onNoBreak <> p) ro st ok
 125                  (\_sp _tp -> unTerm (onBreak <> p) ro st ok ko)
 126         withWrapColumn col p = Term $ \ro -> unTerm p ro{reader_wrap_column=col}
 127
 128 writeSGR :: SGR -> Term -> Term
 129 writeSGR s p = o <> m <> c
 130         where
 131         o = Term $ \_ro st ok _ko -> ok st $ fromString $ setSGRCode [s]
 132         m = Term $ \ro -> unTerm p ro{reader_sgr=s:reader_sgr ro}
 133         c = Term $ \ro st ok _ko -> ok st $ fromString $ setSGRCode $ Reset:List.reverse (reader_sgr ro)
 134
 135 instance Doc_Color Term where
 136         reverse     = writeSGR $ SetSwapForegroundBackground True
 137         black       = writeSGR $ SetColor Foreground Dull  Black
 138         red         = writeSGR $ SetColor Foreground Dull  Red
 139         green       = writeSGR $ SetColor Foreground Dull  Green
 140         yellow      = writeSGR $ SetColor Foreground Dull  Yellow
 141         blue        = writeSGR $ SetColor Foreground Dull  Blue
 142         magenta     = writeSGR $ SetColor Foreground Dull  Magenta
 143         cyan        = writeSGR $ SetColor Foreground Dull  Cyan
 144         white       = writeSGR $ SetColor Foreground Dull  White
 145         blacker     = writeSGR $ SetColor Foreground Vivid Black
 146         redder      = writeSGR $ SetColor Foreground Vivid Red
 147         greener     = writeSGR $ SetColor Foreground Vivid Green
 148         yellower    = writeSGR $ SetColor Foreground Vivid Yellow
 149         bluer       = writeSGR $ SetColor Foreground Vivid Blue
 150         magentaer   = writeSGR $ SetColor Foreground Vivid Magenta
 151         cyaner      = writeSGR $ SetColor Foreground Vivid Cyan
 152         whiter      = writeSGR $ SetColor Foreground Vivid White
 153         onBlack     = writeSGR $ SetColor Background Dull  Black
 154         onRed       = writeSGR $ SetColor Background Dull  Red
 155         onGreen     = writeSGR $ SetColor Background Dull  Green
 156         onYellow    = writeSGR $ SetColor Background Dull  Yellow
 157         onBlue      = writeSGR $ SetColor Background Dull  Blue
 158         onMagenta   = writeSGR $ SetColor Background Dull  Magenta
 159         onCyan      = writeSGR $ SetColor Background Dull  Cyan
 160         onWhite     = writeSGR $ SetColor Background Dull  White
 161         onBlacker   = writeSGR $ SetColor Background Vivid Black
 162         onRedder    = writeSGR $ SetColor Background Vivid Red
 163         onGreener   = writeSGR $ SetColor Background Vivid Green
 164         onYellower  = writeSGR $ SetColor Background Vivid Yellow
 165         onBluer     = writeSGR $ SetColor Background Vivid Blue
 166         onMagentaer = writeSGR $ SetColor Background Vivid Magenta
 167         onCyaner    = writeSGR $ SetColor Background Vivid Cyan
 168         onWhiter    = writeSGR $ SetColor Background Vivid White
 169 instance Doc_Decoration Term where
 170         bold        = writeSGR $ SetConsoleIntensity BoldIntensity
 171         underline   = writeSGR $ SetUnderlining SingleUnderline
 172         italic      = writeSGR $ SetItalicized True