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 data State
  43  =   State
  44  {   state_column     :: !(Column Plain)
  45  ,   state_column_max :: !(Column Plain)
  46  }
  47
  48 defState :: State
  49 defState = State
  50  { state_column     = 0
  51  , state_column_max = 0
  52  }
  53
  54 -- * Type 'Plain'
  55 newtype Plain
  56  =      Plain
  57  {    unPlain :: Inh -> State
  58               -> (State -> TLB.Builder -> TLB.Builder) -- normal   continuation
  59               -> (State -> TLB.Builder -> TLB.Builder) -- wrapping continuation
  60               -> TLB.Builder }
  61
  62 buildPlain :: Plain -> TLB.Builder
  63 buildPlain (Plain p) = p defInh defState oko oko
  64         where oko _st = id
  65
  66 textPlain :: Plain -> TL.Text
  67 textPlain = TLB.toLazyText . buildPlain
  68
  69 instance IsList Plain where
  70         type Item Plain = Plain
  71         fromList = mconcat
  72         toList   = pure
  73 instance Semigroup Plain where
  74         x <> y = Plain $ \inh st ok ko ->
  75                 unPlain x inh st
  76                  (\sx tx -> unPlain y inh sx
  77                          (\sy ty -> ok sy (tx<>ty))
  78                          (\sy ty -> ko sy (tx<>ty)))
  79                  (\sx tx -> unPlain y inh sx
  80                          (\sy ty -> ko sy (tx<>ty))
  81                          (\sy ty -> ko sy (tx<>ty)))
  82 instance Monoid Plain where
  83         mempty  = empty
  84         mappend = (<>)
  85 instance IsString Plain where
  86         fromString = string
  87
  88 plainWrite :: Column Plain -> TLB.Builder -> Plain
  89 plainWrite len t =
  90         Plain $ \inh st ok ko ->
  91                 let newCol = state_column st + len in
  92                 (if newCol <= inh_wrap_column inh then ok else ko)
  93                 st{ state_column     = newCol
  94                   , state_column_max = max (state_column_max st) newCol
  95                   } t
  96
  97 instance Doc_Text Plain where
  98         empty     = Plain $ \_inh st ok _ko -> ok st ""
  99         charH   t = plainWrite 1 $ TLB.singleton t
 100         stringH t = plainWrite (List.length t) (fromString t)
 101         textH   t = plainWrite (Text.length t) (TLB.fromText t)
 102         ltextH  t = plainWrite (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 = Plain $ \inh -> unPlain (inh_newline inh) inh
 108
 109 newlineWithoutIndent :: Plain
 110 newlineWithoutIndent = Plain $ \_inh st ok _ko ->
 111         ok st{state_column=0} $ TLB.singleton '\n'
 112
 113 newlineWithIndent :: Plain
 114 newlineWithIndent = Plain $ \inh st ok _ko ->
 115         ok st
 116          { state_column     = inh_indent inh
 117          , state_column_max = max (state_column_max st) (inh_indent inh)
 118          } $
 119                 TLB.singleton '\n' <>
 120                 fromString (List.replicate (inh_indent inh) ' ')
 121
 122 instance Doc_Align Plain where
 123         type Column Plain = Int
 124         type Indent Plain = Int
 125         align p = Plain $ \inh st -> unPlain p inh{inh_indent=state_column st} st
 126         withNewline nl  p = Plain $ \inh -> unPlain p inh{inh_newline=nl}
 127         withIndent  ind p = Plain $ \inh -> unPlain p inh{inh_indent=ind}
 128         incrIndent  ind p = Plain $ \inh -> unPlain p inh{inh_indent=inh_indent inh + ind}
 129 instance Doc_Wrap Plain where
 130         ifFit x y = Plain $ \inh st ok ko ->
 131                 unPlain x inh st ok (\_sx _tx -> unPlain y inh st ok ko)
 132         breakpoint onNoBreak onBreak p = Plain $ \inh st ok ko ->
 133                 unPlain (onNoBreak <> p) inh st ok
 134                  (\_sp _tp -> unPlain (onBreak <> p) inh st ok ko)
 135         withWrapColumn col p = Plain $ \inh -> unPlain p inh{inh_wrap_column=col}
 136
 137 writeSGR :: SGR -> Plain -> Plain
 138 writeSGR s p = Plain $ \inh@Inh{inh_sgr=ss} st ok ko ->
 139         let o = Plain $ \_inh st' ok' _ko -> ok' st' $ fromString $ setSGRCode [s] in
 140         let c :: TLB.Builder = fromString $ setSGRCode $ Reset:List.reverse ss in
 141         unPlain (o<>p) inh{inh_sgr=s:ss} st
 142          (\_st t -> ok st $ t<>c)
 143          (\_st t -> ko st $ t<>c)
 144
 145 instance Doc_Color Plain where
 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 Plain where
 180         bold        = writeSGR $ SetConsoleIntensity BoldIntensity
 181         underline   = writeSGR $ SetUnderlining SingleUnderline
 182         italic      = writeSGR $ SetItalicized True
 183
 184
 185
 186
 187 {-
 188 -- * Type 'PlainIO'
 189 newtype PlainIO
 190  =      PlainIO { unPlainIO :: IO.Handle -> IO () }
 191 instance IsString PlainIO where
 192         fromString s = PlainIO $ \h -> IO.hPutStr h s
 193
 194 plainIO :: PlainIO -> IO.Handle -> IO ()
 195 plainIO (PlainIO d) = d
 196
 197 instance Semigroup PlainIO where
 198         PlainIO x <> PlainIO y = PlainIO $ \h -> do {x h; y h}
 199 instance Monoid PlainIO where
 200         mempty  = empty
 201         mappend = (<>)
 202 instance Doc_Text PlainIO where
 203         empty         = PlainIO $ \_ -> return ()
 204         int     i     = PlainIO $ \h -> IO.hPutStr  h (show i)
 205         integer i     = PlainIO $ \h -> IO.hPutStr  h (show i)
 206         replicate i d = PlainIO $ replicateM_ i . plainIO d
 207         charH   x     = PlainIO $ \h -> IO.hPutChar h x
 208         stringH x     = PlainIO $ \h -> IO.hPutStr  h x
 209         textH   x     = PlainIO $ \h -> Text.hPutStr h x
 210         ltextH  x     = PlainIO $ \h -> TL.hPutStr  h x
 211         -- NOTE: PlainIO has no support for indentation, hence char = charH, etc.
 212         char          = charH
 213         string        = stringH
 214         text          = textH
 215         ltext         = ltextH
 216 instance Doc_Color PlainIO where
 217         reverse       = id
 218         black         = id
 219         red           = id
 220         green         = id
 221         yellow        = id
 222         blue          = id
 223         magenta       = id
 224         cyan          = id
 225         white         = id
 226         blacker       = id
 227         redder        = id
 228         greener       = id
 229         yellower      = id
 230         bluer         = id
 231         magentaer     = id
 232         cyaner        = id
 233         whiter        = id
 234         onBlack       = id
 235         onRed         = id
 236         onGreen       = id
 237         onYellow      = id
 238         onBlue        = id
 239         onMagenta     = id
 240         onCyan        = id
 241         onWhite       = id
 242         onBlacker     = id
 243         onRedder      = id
 244         onGreener     = id
 245         onYellower    = id
 246         onBluer       = id
 247         onMagentaer   = id
 248         onCyaner      = id
 249         onWhiter      = id
 250 instance Doc_Decoration PlainIO where
 251         bold          = id
 252         underline     = id
 253         italic        = id
 254 -}