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

   1 module Symantic.Document.Term.IO
   2  ( module Symantic.Document.Sym
   3  , module Symantic.Document.Term.IO
   4  ) where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Data.Bool
   8 import Data.Function (($), id)
   9 import Data.Maybe (Maybe(..))
  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 (fromIntegral, Num(..))
  16 import System.Console.ANSI
  17 import System.IO (IO)
  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 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_sgr       :: ![SGR]          -- ^ Active ANSI codes.
  31  ,   reader_handle    :: !IO.Handle      -- ^ Where to write.
  32  ,   reader_breakable :: !(Maybe Column) -- ^ 'Column' after which to break.
  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_sgr         = []
  43  , reader_handle      = IO.stdout
  44  , reader_breakable   = Nothing
  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-break continuation
  62                   IO () }
  63
  64 -- | Write a 'TermIO'.
  65 runTermIO :: IO.Handle -> TermIO -> IO ()
  66 runTermIO h (TermIO t) = t 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                 (case reader_breakable ro of
  93                  Just breakCol | breakCol < newCol -> ko
  94                  _ -> ok)
  95                 newCol (t (reader_handle ro))
  96
  97 instance Textable TermIO where
  98         empty     = TermIO $ \_ro st ok _ko -> ok st mempty
  99         charH   t = writeH 1 (`IO.hPutChar` t)
 100         stringH t = writeH (length t) (`IO.hPutStr` t)
 101         textH   t = writeH (length t) (`Text.hPutStr` t)
 102         ltextH  t = writeH (length t) (`TL.hPutStr` t)
 103         newline   = TermIO $ \ro -> unTermIO (reader_newline ro) ro
 104 instance Indentable TermIO where
 105         align t = TermIO $ \ro st -> unTermIO t ro{reader_indent=st} st
 106         withNewline nl  t = TermIO $ \ro -> unTermIO t ro{reader_newline=nl}
 107         withIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=ind}
 108         incrIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=reader_indent ro + ind}
 109         column f = TermIO $ \ro st -> unTermIO (f st) ro st
 110         indent f = TermIO $ \ro -> unTermIO (f (reader_indent ro)) ro
 111         newlineWithoutIndent = TermIO $ \ro _st ok _ko ->
 112                 ok 0 $ IO.hPutChar (reader_handle ro) '\n'
 113         newlineWithIndent = TermIO $ \ro@Reader{reader_handle=h} _st ok _ko ->
 114                 ok (reader_indent ro) $ do
 115                         IO.hPutChar h '\n'
 116                         IO.hPutStr h $ List.replicate (fromIntegral $ reader_indent ro) ' '
 117 instance Breakable TermIO where
 118         breakable f       = TermIO $ \ro -> unTermIO (f (reader_breakable ro)) ro
 119         withBreakable b t = TermIO $ \ro -> unTermIO t ro{reader_breakable=b}
 120         ifBreak y x = TermIO $ \ro st ok ko ->
 121                 unTermIO x ro st ok $
 122                 case reader_breakable ro of
 123                  Nothing -> ko
 124                  Just{} -> (\_sx _tx -> unTermIO y ro st ok ko)
 125         breakpoint onNoBreak onBreak t = TermIO $ \ro st ok ko ->
 126                 unTermIO (onNoBreak <> t) ro st ok $
 127                 case reader_breakable ro of
 128                  Nothing -> ko
 129                  Just{} -> (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)
 130
 131 writeSGR :: (Reader -> Bool) -> SGR -> TermIO -> TermIO
 132 writeSGR isOn s (TermIO t) =
 133         TermIO $ \ro ->
 134                 if isOn ro
 135                 then unTermIO (o <> m <> c) ro
 136                 else t ro
 137         where
 138         o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]
 139         m = TermIO $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
 140         c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) $ Reset:List.reverse (reader_sgr ro)
 141
 142 instance Colorable TermIO where
 143         colorable f       = TermIO $ \ro -> unTermIO (f (reader_colorable ro)) ro
 144         withColorable b t = TermIO $ \ro -> unTermIO t ro{reader_colorable=b}
 145         reverse     = writeSGR reader_colorable $ SetSwapForegroundBackground True
 146         black       = writeSGR reader_colorable $ SetColor Foreground Dull  Black
 147         red         = writeSGR reader_colorable $ SetColor Foreground Dull  Red
 148         green       = writeSGR reader_colorable $ SetColor Foreground Dull  Green
 149         yellow      = writeSGR reader_colorable $ SetColor Foreground Dull  Yellow
 150         blue        = writeSGR reader_colorable $ SetColor Foreground Dull  Blue
 151         magenta     = writeSGR reader_colorable $ SetColor Foreground Dull  Magenta
 152         cyan        = writeSGR reader_colorable $ SetColor Foreground Dull  Cyan
 153         white       = writeSGR reader_colorable $ SetColor Foreground Dull  White
 154         blacker     = writeSGR reader_colorable $ SetColor Foreground Vivid Black
 155         redder      = writeSGR reader_colorable $ SetColor Foreground Vivid Red
 156         greener     = writeSGR reader_colorable $ SetColor Foreground Vivid Green
 157         yellower    = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow
 158         bluer       = writeSGR reader_colorable $ SetColor Foreground Vivid Blue
 159         magentaer   = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta
 160         cyaner      = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan
 161         whiter      = writeSGR reader_colorable $ SetColor Foreground Vivid White
 162         onBlack     = writeSGR reader_colorable $ SetColor Background Dull  Black
 163         onRed       = writeSGR reader_colorable $ SetColor Background Dull  Red
 164         onGreen     = writeSGR reader_colorable $ SetColor Background Dull  Green
 165         onYellow    = writeSGR reader_colorable $ SetColor Background Dull  Yellow
 166         onBlue      = writeSGR reader_colorable $ SetColor Background Dull  Blue
 167         onMagenta   = writeSGR reader_colorable $ SetColor Background Dull  Magenta
 168         onCyan      = writeSGR reader_colorable $ SetColor Background Dull  Cyan
 169         onWhite     = writeSGR reader_colorable $ SetColor Background Dull  White
 170         onBlacker   = writeSGR reader_colorable $ SetColor Background Vivid Black
 171         onRedder    = writeSGR reader_colorable $ SetColor Background Vivid Red
 172         onGreener   = writeSGR reader_colorable $ SetColor Background Vivid Green
 173         onYellower  = writeSGR reader_colorable $ SetColor Background Vivid Yellow
 174         onBluer     = writeSGR reader_colorable $ SetColor Background Vivid Blue
 175         onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta
 176         onCyaner    = writeSGR reader_colorable $ SetColor Background Vivid Cyan
 177         onWhiter    = writeSGR reader_colorable $ SetColor Background Vivid White
 178 instance Decorable TermIO where
 179         decorable f       = TermIO $ \ro -> unTermIO (f (reader_decorable ro)) ro
 180         withDecorable b t = TermIO $ \ro -> unTermIO t ro{reader_decorable=b}
 181         bold      = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
 182         underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
 183         italic    = writeSGR reader_decorable $ SetItalicized True