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         indent f = TermIO $ \ro -> unTermIO (f (reader_indent ro)) ro
 113         newlineWithoutIndent = TermIO $ \ro _st ok _ko ->
 114                 ok 0 $ IO.hPutChar (reader_handle ro) '\n'
 115         newlineWithIndent = TermIO $ \ro@Reader{reader_handle=h} _st ok _ko ->
 116                 ok (reader_indent ro) $ do
 117                         IO.hPutChar h '\n'
 118                         IO.hPutStr h $ List.replicate (fromIntegral $ reader_indent ro) ' '
 119 instance Wrapable TermIO where
 120         ifWrap y x = TermIO $ \ro st ok ko ->
 121                 unTermIO x ro st ok (\_sx _tx -> unTermIO y ro st ok ko)
 122         breakpoint onNoBreak onBreak p = TermIO $ \ro st ok ko ->
 123                 unTermIO (onNoBreak <> p) ro st ok
 124                  (\_sp _tp -> unTermIO (onBreak <> p) ro st ok ko)
 125         withWrapColumn col p = TermIO $ \ro -> unTermIO p ro{reader_wrap_column=col}
 126
 127 writeSGR :: (Reader -> Bool) -> SGR -> TermIO -> TermIO
 128 writeSGR isOn s (TermIO t) =
 129         TermIO $ \ro ->
 130                 if isOn ro
 131                 then unTermIO (o <> m <> c) ro
 132                 else t ro
 133         where
 134         o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]
 135         m = TermIO $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
 136         c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) $ Reset:List.reverse (reader_sgr ro)
 137
 138 instance Colorable TermIO where
 139         colorable f       = TermIO $ \ro -> unTermIO (f (reader_colorable ro)) ro
 140         withColorable b t = TermIO $ \ro -> unTermIO t ro{reader_colorable=b}
 141         reverse     = writeSGR reader_colorable $ SetSwapForegroundBackground True
 142         black       = writeSGR reader_colorable $ SetColor Foreground Dull  Black
 143         red         = writeSGR reader_colorable $ SetColor Foreground Dull  Red
 144         green       = writeSGR reader_colorable $ SetColor Foreground Dull  Green
 145         yellow      = writeSGR reader_colorable $ SetColor Foreground Dull  Yellow
 146         blue        = writeSGR reader_colorable $ SetColor Foreground Dull  Blue
 147         magenta     = writeSGR reader_colorable $ SetColor Foreground Dull  Magenta
 148         cyan        = writeSGR reader_colorable $ SetColor Foreground Dull  Cyan
 149         white       = writeSGR reader_colorable $ SetColor Foreground Dull  White
 150         blacker     = writeSGR reader_colorable $ SetColor Foreground Vivid Black
 151         redder      = writeSGR reader_colorable $ SetColor Foreground Vivid Red
 152         greener     = writeSGR reader_colorable $ SetColor Foreground Vivid Green
 153         yellower    = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow
 154         bluer       = writeSGR reader_colorable $ SetColor Foreground Vivid Blue
 155         magentaer   = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta
 156         cyaner      = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan
 157         whiter      = writeSGR reader_colorable $ SetColor Foreground Vivid White
 158         onBlack     = writeSGR reader_colorable $ SetColor Background Dull  Black
 159         onRed       = writeSGR reader_colorable $ SetColor Background Dull  Red
 160         onGreen     = writeSGR reader_colorable $ SetColor Background Dull  Green
 161         onYellow    = writeSGR reader_colorable $ SetColor Background Dull  Yellow
 162         onBlue      = writeSGR reader_colorable $ SetColor Background Dull  Blue
 163         onMagenta   = writeSGR reader_colorable $ SetColor Background Dull  Magenta
 164         onCyan      = writeSGR reader_colorable $ SetColor Background Dull  Cyan
 165         onWhite     = writeSGR reader_colorable $ SetColor Background Dull  White
 166         onBlacker   = writeSGR reader_colorable $ SetColor Background Vivid Black
 167         onRedder    = writeSGR reader_colorable $ SetColor Background Vivid Red
 168         onGreener   = writeSGR reader_colorable $ SetColor Background Vivid Green
 169         onYellower  = writeSGR reader_colorable $ SetColor Background Vivid Yellow
 170         onBluer     = writeSGR reader_colorable $ SetColor Background Vivid Blue
 171         onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta
 172         onCyaner    = writeSGR reader_colorable $ SetColor Background Vivid Cyan
 173         onWhiter    = writeSGR reader_colorable $ SetColor Background Vivid White
 174 instance Decorable TermIO where
 175         decorable f       = TermIO $ \ro -> unTermIO (f (reader_decorable ro)) ro
 176         withDecorable b t = TermIO $ \ro -> unTermIO t ro{reader_decorable=b}
 177         bold        = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
 178         underline   = writeSGR reader_decorable $ SetUnderlining SingleUnderline
 179         italic      = writeSGR reader_decorable $ SetItalicized True