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