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