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