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.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 (pred, fromIntegral, Num(..))
  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.IO as Text
  21 import qualified Data.Text.Lazy.IO as TL
  22 import qualified System.IO as IO
  23
  24 import Language.Symantic.Document.Sym
  25
  26 -- * Type 'Reader'
  27 data Reader
  28  =   Reader
  29  {   reader_indent    :: !Indent              -- ^ Current indentation level, used by 'newline'.
  30  ,   reader_newline   :: TermIO               -- ^ How to display 'newline'.
  31  ,   reader_sgr       :: ![SGR]               -- ^ Active ANSI codes.
  32  ,   reader_handle    :: !IO.Handle           -- ^ Where to write.
  33  ,   reader_breakable :: !(Maybe Column)      -- ^ 'Column' after which to break.
  34  ,   reader_colorable :: {-# UNPACK #-} !Bool -- ^ Whether colors are activated or not.
  35  ,   reader_decorable :: {-# UNPACK #-} !Bool -- ^ Whether decorations are activated or not.
  36  }
  37
  38 -- | Default 'Reader'.
  39 defReader :: Reader
  40 defReader = Reader
  41  { reader_indent      = 0
  42  , reader_newline     = newlineWithIndent
  43  , reader_sgr         = []
  44  , reader_handle      = IO.stdout
  45  , reader_breakable   = Just $ Nat 80
  46  , reader_colorable   = True
  47  , reader_decorable   = True
  48  }
  49
  50 -- * Type 'State'
  51 type State = Column
  52
  53 -- | Default 'State'.
  54 defState :: State
  55 defState = 0
  56
  57 -- * Type 'TermIO'
  58 newtype TermIO
  59  =      TermIO
  60  {    unTermIO :: Reader -> State ->
  61                   (State -> IO () -> IO ()) -> -- normal continuation
  62                   (State -> IO () -> IO ()) -> -- should-break continuation
  63                   IO () }
  64
  65 -- | Write a 'TermIO'.
  66 runTermIO :: IO.Handle -> TermIO -> IO ()
  67 runTermIO h (TermIO t) = t defReader{reader_handle=h} defState oko oko
  68         where oko _st = id
  69
  70 instance IsList TermIO where
  71         type Item TermIO = TermIO
  72         fromList = mconcat
  73         toList   = pure
  74 instance Semigroup TermIO where
  75         x <> y = TermIO $ \ro st ok ko ->
  76                 unTermIO x ro st
  77                  (\sx tx -> unTermIO y ro sx
  78                          (\sy ty -> ok sy (tx<>ty))
  79                          (\sy ty -> ko sy (tx<>ty)))
  80                  (\sx tx -> unTermIO y ro sx
  81                          (\sy ty -> ko sy (tx<>ty))
  82                          (\sy ty -> ko sy (tx<>ty)))
  83 instance Monoid TermIO where
  84         mempty  = empty
  85         mappend = (<>)
  86 instance IsString TermIO where
  87         fromString = string
  88
  89 writeH :: Column -> (IO.Handle -> IO ()) -> TermIO
  90 writeH len t =
  91         TermIO $ \ro st ok ko ->
  92                 let newCol = st + len in
  93                 (case reader_breakable ro of
  94                  Just breakCol | breakCol < newCol -> ko
  95                  _ -> ok)
  96                 newCol (t (reader_handle ro))
  97
  98 instance Textable TermIO where
  99         empty     = TermIO $ \_ro st ok _ko -> ok st mempty
 100         charH   t = writeH 1 (`IO.hPutChar` t)
 101         stringH t = writeH (length t) (`IO.hPutStr` t)
 102         textH   t = writeH (length t) (`Text.hPutStr` t)
 103         ltextH  t = writeH (length t) (`TL.hPutStr` t)
 104         int       = stringH . show
 105         integer   = stringH . show
 106         replicate cnt t | cnt <= 0  = empty
 107                         | otherwise = t <> replicate (pred cnt) t
 108         newline = TermIO $ \ro -> unTermIO (reader_newline ro) ro
 109 instance Indentable TermIO where
 110         align t = TermIO $ \ro st -> unTermIO t ro{reader_indent=st} st
 111         withNewline nl  t = TermIO $ \ro -> unTermIO t ro{reader_newline=nl}
 112         withIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=ind}
 113         incrIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=reader_indent ro + ind}
 114         column f = TermIO $ \ro st -> unTermIO (f st) ro st
 115         indent f = TermIO $ \ro -> unTermIO (f (reader_indent ro)) ro
 116         newlineWithoutIndent = TermIO $ \ro _st ok _ko ->
 117                 ok 0 $ IO.hPutChar (reader_handle ro) '\n'
 118         newlineWithIndent = TermIO $ \ro@Reader{reader_handle=h} _st ok _ko ->
 119                 ok (reader_indent ro) $ do
 120                         IO.hPutChar h '\n'
 121                         IO.hPutStr h $ List.replicate (fromIntegral $ reader_indent ro) ' '
 122 instance Breakable TermIO where
 123         breakable f       = TermIO $ \ro -> unTermIO (f (reader_breakable ro)) ro
 124         withBreakable b t = TermIO $ \ro -> unTermIO t ro{reader_breakable=b}
 125         ifBreak y x = TermIO $ \ro st ok ko ->
 126                 unTermIO x ro st ok $
 127                 case reader_breakable ro of
 128                  Nothing -> ko
 129                  Just{} -> (\_sx _tx -> unTermIO y ro st ok ko)
 130         breakpoint onNoBreak onBreak t = TermIO $ \ro st ok ko ->
 131                 case reader_breakable ro of
 132                  Nothing -> unTermIO t ro st ok ko
 133                  Just{} ->
 134                         unTermIO (onNoBreak <> t) ro st ok
 135                                  (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)
 136
 137 writeSGR :: (Reader -> Bool) -> SGR -> TermIO -> TermIO
 138 writeSGR isOn s (TermIO t) =
 139         TermIO $ \ro ->
 140                 if isOn ro
 141                 then unTermIO (o <> m <> c) ro
 142                 else t ro
 143         where
 144         o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]
 145         m = TermIO $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
 146         c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) $ Reset:List.reverse (reader_sgr ro)
 147
 148 instance Colorable TermIO where
 149         colorable f       = TermIO $ \ro -> unTermIO (f (reader_colorable ro)) ro
 150         withColorable b t = TermIO $ \ro -> unTermIO t ro{reader_colorable=b}
 151         reverse     = writeSGR reader_colorable $ SetSwapForegroundBackground True
 152         black       = writeSGR reader_colorable $ SetColor Foreground Dull  Black
 153         red         = writeSGR reader_colorable $ SetColor Foreground Dull  Red
 154         green       = writeSGR reader_colorable $ SetColor Foreground Dull  Green
 155         yellow      = writeSGR reader_colorable $ SetColor Foreground Dull  Yellow
 156         blue        = writeSGR reader_colorable $ SetColor Foreground Dull  Blue
 157         magenta     = writeSGR reader_colorable $ SetColor Foreground Dull  Magenta
 158         cyan        = writeSGR reader_colorable $ SetColor Foreground Dull  Cyan
 159         white       = writeSGR reader_colorable $ SetColor Foreground Dull  White
 160         blacker     = writeSGR reader_colorable $ SetColor Foreground Vivid Black
 161         redder      = writeSGR reader_colorable $ SetColor Foreground Vivid Red
 162         greener     = writeSGR reader_colorable $ SetColor Foreground Vivid Green
 163         yellower    = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow
 164         bluer       = writeSGR reader_colorable $ SetColor Foreground Vivid Blue
 165         magentaer   = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta
 166         cyaner      = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan
 167         whiter      = writeSGR reader_colorable $ SetColor Foreground Vivid White
 168         onBlack     = writeSGR reader_colorable $ SetColor Background Dull  Black
 169         onRed       = writeSGR reader_colorable $ SetColor Background Dull  Red
 170         onGreen     = writeSGR reader_colorable $ SetColor Background Dull  Green
 171         onYellow    = writeSGR reader_colorable $ SetColor Background Dull  Yellow
 172         onBlue      = writeSGR reader_colorable $ SetColor Background Dull  Blue
 173         onMagenta   = writeSGR reader_colorable $ SetColor Background Dull  Magenta
 174         onCyan      = writeSGR reader_colorable $ SetColor Background Dull  Cyan
 175         onWhite     = writeSGR reader_colorable $ SetColor Background Dull  White
 176         onBlacker   = writeSGR reader_colorable $ SetColor Background Vivid Black
 177         onRedder    = writeSGR reader_colorable $ SetColor Background Vivid Red
 178         onGreener   = writeSGR reader_colorable $ SetColor Background Vivid Green
 179         onYellower  = writeSGR reader_colorable $ SetColor Background Vivid Yellow
 180         onBluer     = writeSGR reader_colorable $ SetColor Background Vivid Blue
 181         onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta
 182         onCyaner    = writeSGR reader_colorable $ SetColor Background Vivid Cyan
 183         onWhiter    = writeSGR reader_colorable $ SetColor Background Vivid White
 184 instance Decorable TermIO where
 185         decorable f       = TermIO $ \ro -> unTermIO (f (reader_decorable ro)) ro
 186         withDecorable b t = TermIO $ \ro -> unTermIO t ro{reader_decorable=b}
 187         bold        = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
 188         underline   = writeSGR reader_decorable $ SetUnderlining SingleUnderline
 189         italic      = writeSGR reader_decorable $ SetItalicized True