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