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

   1 module Language.Symantic.Document.Plain where
   2
   3 import Control.Applicative (Applicative(..))
   4 import Data.Bool
   5 import Data.Int (Int)
   6 import Data.Function (($), (.), id)
   7 import Data.Monoid (Monoid(..))
   8 import Data.Ord (Ord(..))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.String (IsString(..))
  11 import Prelude ((+), pred)
  12 import GHC.Exts (IsList(..))
  13 import System.Console.ANSI
  14 import Text.Show (Show(..))
  15 import qualified Data.List as List
  16 import qualified Data.Text as Text
  17 import qualified Data.Text.Lazy as TL
  18 import qualified Data.Text.Lazy.Builder as TLB
  19 -- import qualified Data.Text.Lazy.IO as TL
  20 -- import qualified System.IO as IO
  21
  22 import Language.Symantic.Document.Sym
  23
  24 -- * Type 'Inh'
  25 data Inh
  26  =   Inh
  27  {   inh_indent      :: !(Indent Plain) -- ^ Current indentation level, used by 'newline'.
  28  ,   inh_newline     :: Plain           -- ^ How to display 'newline'.
  29  ,   inh_wrap_column :: !(Column Plain) -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'.
  30  ,   inh_sgr         :: ![SGR]          -- ^ Active ANSI codes.
  31  }
  32
  33 defInh :: Inh
  34 defInh = Inh
  35  { inh_indent      = 0
  36  , inh_newline     = newlineWithIndent
  37  , inh_wrap_column = 80
  38  , inh_sgr         = []
  39  }
  40
  41 -- * Type 'State'
  42 type State = Column Plain
  43
  44 defState :: State
  45 defState = 0
  46
  47 -- * Type 'Plain'
  48 newtype Plain
  49  =      Plain
  50  {    unPlain :: Inh -> State
  51               -> (State -> TLB.Builder -> TLB.Builder) -- normal   continuation
  52               -> (State -> TLB.Builder -> TLB.Builder) -- wrapping continuation
  53               -> TLB.Builder }
  54
  55 buildPlain :: Plain -> TLB.Builder
  56 buildPlain (Plain p) = p defInh defState oko oko
  57         where oko _st = id
  58
  59 textPlain :: Plain -> TL.Text
  60 textPlain = TLB.toLazyText . buildPlain
  61
  62 instance IsList Plain where
  63         type Item Plain = Plain
  64         fromList = mconcat
  65         toList   = pure
  66 instance Semigroup Plain where
  67         x <> y = Plain $ \inh st ok ko ->
  68                 unPlain x inh st
  69                  (\sx tx -> unPlain y inh sx
  70                          (\sy ty -> ok sy (tx<>ty))
  71                          (\sy ty -> ko sy (tx<>ty)))
  72                  (\sx tx -> unPlain y inh sx
  73                          (\sy ty -> ko sy (tx<>ty))
  74                          (\sy ty -> ko sy (tx<>ty)))
  75 instance Monoid Plain where
  76         mempty  = empty
  77         mappend = (<>)
  78 instance IsString Plain where
  79         fromString = string
  80
  81 writeText :: Column Plain -> TLB.Builder -> Plain
  82 writeText len t =
  83         Plain $ \inh st ok ko ->
  84                 let newCol = st + len in
  85                 (if newCol <= inh_wrap_column inh then ok else ko)
  86                 newCol t
  87
  88 instance Doc_Text Plain where
  89         empty     = Plain $ \_inh st ok _ko -> ok st ""
  90         charH   t = writeText 1 $ TLB.singleton t
  91         stringH t = writeText (List.length t) (fromString t)
  92         textH   t = writeText (Text.length t) (TLB.fromText t)
  93         ltextH  t = writeText (intOfInt64 $ TL.length t) (TLB.fromLazyText t)
  94         int       = stringH . show
  95         integer   = stringH . show
  96         replicate cnt p | cnt <= 0  = empty
  97                         | otherwise = p <> replicate (pred cnt) p
  98         newline = Plain $ \inh -> unPlain (inh_newline inh) inh
  99
 100 newlineWithoutIndent :: Plain
 101 newlineWithoutIndent = Plain $ \_inh _st ok _ko ->
 102         ok 0 $ TLB.singleton '\n'
 103
 104 newlineWithIndent :: Plain
 105 newlineWithIndent = Plain $ \inh _st ok _ko ->
 106         ok (inh_indent inh) $
 107                 TLB.singleton '\n' <>
 108                 fromString (List.replicate (inh_indent inh) ' ')
 109
 110 instance Doc_Align Plain where
 111         type Column Plain = Int
 112         type Indent Plain = Int
 113         align p = Plain $ \inh st -> unPlain p inh{inh_indent=st} st
 114         withNewline nl  p = Plain $ \inh -> unPlain p inh{inh_newline=nl}
 115         withIndent  ind p = Plain $ \inh -> unPlain p inh{inh_indent=ind}
 116         incrIndent  ind p = Plain $ \inh -> unPlain p inh{inh_indent=inh_indent inh + ind}
 117         column f = Plain $ \inh st -> unPlain (f st) inh st
 118 instance Doc_Wrap Plain where
 119         ifFit x y = Plain $ \inh st ok ko ->
 120                 unPlain x inh st ok (\_sx _tx -> unPlain y inh st ok ko)
 121         breakpoint onNoBreak onBreak p = Plain $ \inh st ok ko ->
 122                 unPlain (onNoBreak <> p) inh st ok
 123                  (\_sp _tp -> unPlain (onBreak <> p) inh st ok ko)
 124         withWrapColumn col p = Plain $ \inh -> unPlain p inh{inh_wrap_column=col}
 125
 126 writeSGR :: SGR -> Plain -> Plain
 127 writeSGR s p = Plain $ \inh@Inh{inh_sgr=ss} st ok ko ->
 128         let o = Plain $ \_inh st' ok' _ko -> ok' st' $ fromString $ setSGRCode [s] in
 129         let c :: TLB.Builder = fromString $ setSGRCode $ Reset:List.reverse ss in
 130         unPlain (o<>p) inh{inh_sgr=s:ss} st
 131          (\_st t -> ok st $ t<>c)
 132          (\_st t -> ko st $ t<>c)
 133
 134 instance Doc_Color Plain where
 135         reverse     = writeSGR $ SetSwapForegroundBackground True
 136         black       = writeSGR $ SetColor Foreground Dull  Black
 137         red         = writeSGR $ SetColor Foreground Dull  Red
 138         green       = writeSGR $ SetColor Foreground Dull  Green
 139         yellow      = writeSGR $ SetColor Foreground Dull  Yellow
 140         blue        = writeSGR $ SetColor Foreground Dull  Blue
 141         magenta     = writeSGR $ SetColor Foreground Dull  Magenta
 142         cyan        = writeSGR $ SetColor Foreground Dull  Cyan
 143         white       = writeSGR $ SetColor Foreground Dull  White
 144         blacker     = writeSGR $ SetColor Foreground Vivid Black
 145         redder      = writeSGR $ SetColor Foreground Vivid Red
 146         greener     = writeSGR $ SetColor Foreground Vivid Green
 147         yellower    = writeSGR $ SetColor Foreground Vivid Yellow
 148         bluer       = writeSGR $ SetColor Foreground Vivid Blue
 149         magentaer   = writeSGR $ SetColor Foreground Vivid Magenta
 150         cyaner      = writeSGR $ SetColor Foreground Vivid Cyan
 151         whiter      = writeSGR $ SetColor Foreground Vivid White
 152         onBlack     = writeSGR $ SetColor Background Dull  Black
 153         onRed       = writeSGR $ SetColor Background Dull  Red
 154         onGreen     = writeSGR $ SetColor Background Dull  Green
 155         onYellow    = writeSGR $ SetColor Background Dull  Yellow
 156         onBlue      = writeSGR $ SetColor Background Dull  Blue
 157         onMagenta   = writeSGR $ SetColor Background Dull  Magenta
 158         onCyan      = writeSGR $ SetColor Background Dull  Cyan
 159         onWhite     = writeSGR $ SetColor Background Dull  White
 160         onBlacker   = writeSGR $ SetColor Background Vivid Black
 161         onRedder    = writeSGR $ SetColor Background Vivid Red
 162         onGreener   = writeSGR $ SetColor Background Vivid Green
 163         onYellower  = writeSGR $ SetColor Background Vivid Yellow
 164         onBluer     = writeSGR $ SetColor Background Vivid Blue
 165         onMagentaer = writeSGR $ SetColor Background Vivid Magenta
 166         onCyaner    = writeSGR $ SetColor Background Vivid Cyan
 167         onWhiter    = writeSGR $ SetColor Background Vivid White
 168 instance Doc_Decoration Plain where
 169         bold        = writeSGR $ SetConsoleIntensity BoldIntensity
 170         underline   = writeSGR $ SetUnderlining SingleUnderline
 171         italic      = writeSGR $ SetItalicized True
 172
 173
 174
 175
 176 {-
 177 -- * Type 'PlainIO'
 178 newtype PlainIO
 179  =      PlainIO { unPlainIO :: IO.Handle -> IO () }
 180 instance IsString PlainIO where
 181         fromString s = PlainIO $ \h -> IO.hPutStr h s
 182
 183 plainIO :: PlainIO -> IO.Handle -> IO ()
 184 plainIO (PlainIO d) = d
 185
 186 instance Semigroup PlainIO where
 187         PlainIO x <> PlainIO y = PlainIO $ \h -> do {x h; y h}
 188 instance Monoid PlainIO where
 189         mempty  = empty
 190         mappend = (<>)
 191 instance Doc_Text PlainIO where
 192         empty         = PlainIO $ \_ -> return ()
 193         int     i     = PlainIO $ \h -> IO.hPutStr  h (show i)
 194         integer i     = PlainIO $ \h -> IO.hPutStr  h (show i)
 195         replicate i d = PlainIO $ replicateM_ i . plainIO d
 196         charH   x     = PlainIO $ \h -> IO.hPutChar h x
 197         stringH x     = PlainIO $ \h -> IO.hPutStr  h x
 198         textH   x     = PlainIO $ \h -> Text.hPutStr h x
 199         ltextH  x     = PlainIO $ \h -> TL.hPutStr  h x
 200         -- NOTE: PlainIO has no support for indentation, hence char = charH, etc.
 201         char          = charH
 202         string        = stringH
 203         text          = textH
 204         ltext         = ltextH
 205 instance Doc_Color PlainIO where
 206         reverse       = id
 207         black         = id
 208         red           = id
 209         green         = id
 210         yellow        = id
 211         blue          = id
 212         magenta       = id
 213         cyan          = id
 214         white         = id
 215         blacker       = id
 216         redder        = id
 217         greener       = id
 218         yellower      = id
 219         bluer         = id
 220         magentaer     = id
 221         cyaner        = id
 222         whiter        = id
 223         onBlack       = id
 224         onRed         = id
 225         onGreen       = id
 226         onYellow      = id
 227         onBlue        = id
 228         onMagenta     = id
 229         onCyan        = id
 230         onWhite       = id
 231         onBlacker     = id
 232         onRedder      = id
 233         onGreener     = id
 234         onYellower    = id
 235         onBluer       = id
 236         onMagentaer   = id
 237         onCyaner      = id
 238         onWhiter      = id
 239 instance Doc_Decoration PlainIO where
 240         bold          = id
 241         underline     = id
 242         italic        = id
 243 -}