symantic-document/Language/Symantic/Document/Term/IO.hs

   1 module Language.Symantic.Document.Term.IO
   2  ( module Language.Symantic.Document.Sym
   3  , module Language.Symantic.Document.Term.IO
   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 System.IO (IO)
  18 import Text.Show (Show(..))
  19 import qualified Data.List as List
  20 import qualified Data.Text as Text
  21 import qualified Data.Text.IO as Text
  22 import qualified Data.Text.Lazy as TL
  23 import qualified Data.Text.Lazy.IO as TL
  24 import qualified System.IO as IO
  25
  26 import Language.Symantic.Document.Sym
  27
  28 -- * Type 'Reader'
  29 data Reader
  30  =   Reader
  31  {   reader_indent      :: !(Indent TermIO) -- ^ Current indentation level, used by 'newline'.
  32  ,   reader_newline     :: TermIO           -- ^ How to display 'newline'.
  33  ,   reader_wrap_column :: !(Column TermIO) -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'.
  34  ,   reader_sgr         :: ![SGR]           -- ^ Active ANSI codes.
  35  ,   reader_handle      :: !IO.Handle       -- ^ Where to write.
  36  }
  37
  38 -- | Default 'Reader'.
  39 defReader :: Reader
  40 defReader = Reader
  41  { reader_indent      = 0
  42  , reader_newline     = newlineWithIndent
  43  , reader_wrap_column = 80
  44  , reader_sgr         = []
  45  , reader_handle      = IO.stdout
  46  }
  47
  48 -- * Type 'State'
  49 type State = Column TermIO
  50
  51 -- | Default 'State'.
  52 defState :: State
  53 defState = 0
  54
  55 -- * Type 'TermIO'
  56 newtype TermIO
  57  =      TermIO
  58  {    unTermIO :: Reader -> State ->
  59                   (State -> IO () -> IO ()) -> -- normal continuation
  60                   (State -> IO () -> IO ()) -> -- should-wrap continuation
  61                   IO () }
  62
  63 type instance Column TermIO = Int
  64 type instance Indent TermIO = Int
  65
  66 -- | Write a 'TermIO'.
  67 runTermIO :: IO.Handle -> TermIO -> IO ()
  68 runTermIO h (TermIO p) = p defReader{reader_handle=h} defState oko oko
  69         where oko _st = id
  70
  71 instance IsList TermIO where
  72         type Item TermIO = TermIO
  73         fromList = mconcat
  74         toList   = pure
  75 instance Semigroup TermIO where
  76         x <> y = TermIO $ \ro st ok ko ->
  77                 unTermIO x ro st
  78                  (\sx tx -> unTermIO y ro sx
  79                          (\sy ty -> ok sy (tx<>ty))
  80                          (\sy ty -> ko sy (tx<>ty)))
  81                  (\sx tx -> unTermIO y ro sx
  82                          (\sy ty -> ko sy (tx<>ty))
  83                          (\sy ty -> ko sy (tx<>ty)))
  84 instance Monoid TermIO where
  85         mempty  = empty
  86         mappend = (<>)
  87 instance IsString TermIO where
  88         fromString = string
  89
  90 writeH :: Column TermIO -> (IO.Handle -> IO ()) -> TermIO
  91 writeH len t =
  92         TermIO $ \ro st ok ko ->
  93                 let newCol = st + len in
  94                 (if newCol <= reader_wrap_column ro then ok else ko)
  95                 newCol (t (reader_handle ro))
  96
  97 instance Doc_Text TermIO where
  98         empty     = TermIO $ \_ro st ok _ko -> ok st mempty
  99         charH   t = writeH 1 (`IO.hPutChar` t)
 100         stringH t = writeH (List.length t) (`IO.hPutStr` t)
 101         textH   t = writeH (Text.length t) (`Text.hPutStr` t)
 102         ltextH  t = writeH (intOfInt64 $ TL.length t) (`TL.hPutStr` 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 = TermIO $ \ro -> unTermIO (reader_newline ro) ro
 108 instance Doc_Align TermIO where
 109         align p = TermIO $ \ro st -> unTermIO p ro{reader_indent=st} st
 110         withNewline nl  p = TermIO $ \ro -> unTermIO p ro{reader_newline=nl}
 111         withIndent  ind p = TermIO $ \ro -> unTermIO p ro{reader_indent=ind}
 112         incrIndent  ind p = TermIO $ \ro -> unTermIO p ro{reader_indent=reader_indent ro + ind}
 113         column f = TermIO $ \ro st -> unTermIO (f st) ro st
 114         newlineWithoutIndent = TermIO $ \ro _st ok _ko ->
 115                 ok 0 $ IO.hPutChar (reader_handle ro) '\n'
 116         newlineWithIndent = TermIO $ \ro@Reader{reader_handle=h} _st ok _ko ->
 117                 ok (reader_indent ro) $ do
 118                         IO.hPutChar h '\n'
 119                         IO.hPutStr h $ List.replicate (reader_indent ro) ' '
 120 instance Doc_Wrap TermIO where
 121         ifFit x y = TermIO $ \ro st ok ko ->
 122                 unTermIO x ro st ok (\_sx _tx -> unTermIO y ro st ok ko)
 123         breakpoint onNoBreak onBreak p = TermIO $ \ro st ok ko ->
 124                 unTermIO (onNoBreak <> p) ro st ok
 125                  (\_sp _tp -> unTermIO (onBreak <> p) ro st ok ko)
 126         withWrapColumn col p = TermIO $ \ro -> unTermIO p ro{reader_wrap_column=col}
 127
 128 writeSGR :: SGR -> TermIO -> TermIO
 129 writeSGR s p = o <> m <> c
 130         where
 131         o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]
 132         m = TermIO $ \ro -> unTermIO p ro{reader_sgr=s:reader_sgr ro}
 133         c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) $ Reset:List.reverse (reader_sgr ro)
 134
 135 instance Doc_Color TermIO 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 TermIO where
 170         bold        = writeSGR $ SetConsoleIntensity BoldIntensity
 171         underline   = writeSGR $ SetUnderlining SingleUnderline
 172         italic      = writeSGR $ SetItalicized True