module Language.Symantic.Document.Term.IO
( module Language.Symantic.Document.Sym
, module Language.Symantic.Document.Term.IO
) where
import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Function (($), id)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import GHC.Exts (IsList(..))
import Prelude (fromIntegral, Num(..))
import System.Console.ANSI
import System.IO (IO)
import qualified Data.List as List
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy.IO as TL
import qualified System.IO as IO
import Language.Symantic.Document.Sym
data Reader
= Reader
{ reader_indent :: !Indent
, reader_newline :: TermIO
, reader_sgr :: ![SGR]
, reader_handle :: !IO.Handle
, reader_breakable :: !(Maybe Column)
, reader_colorable :: !Bool
, reader_decorable :: !Bool
}
defReader :: Reader
defReader = Reader
{ reader_indent = 0
, reader_newline = newlineWithIndent
, reader_sgr = []
, reader_handle = IO.stdout
, reader_breakable = Nothing
, reader_colorable = True
, reader_decorable = True
}
type State = Column
defState :: State
defState = 0
newtype TermIO
= TermIO
{ unTermIO :: Reader -> State ->
(State -> IO () -> IO ()) ->
(State -> IO () -> IO ()) ->
IO () }
runTermIO :: IO.Handle -> TermIO -> IO ()
runTermIO h (TermIO t) = t defReader{reader_handle=h} defState oko oko
where oko _st = id
instance IsList TermIO where
type Item TermIO = TermIO
fromList = mconcat
toList = pure
instance Semigroup TermIO where
x <> y = TermIO $ \ro st ok ko ->
unTermIO x ro st
(\sx tx -> unTermIO y ro sx
(\sy ty -> ok sy (tx<>ty))
(\sy ty -> ko sy (tx<>ty)))
(\sx tx -> unTermIO y ro sx
(\sy ty -> ko sy (tx<>ty))
(\sy ty -> ko sy (tx<>ty)))
instance Monoid TermIO where
mempty = empty
mappend = (<>)
instance IsString TermIO where
fromString = string
writeH :: Column -> (IO.Handle -> IO ()) -> TermIO
writeH len t =
TermIO $ \ro st ok ko ->
let newCol = st + len in
(case reader_breakable ro of
Just breakCol | breakCol < newCol -> ko
_ -> ok)
newCol (t (reader_handle ro))
instance Textable TermIO where
empty = TermIO $ \_ro st ok _ko -> ok st mempty
charH t = writeH 1 (`IO.hPutChar` t)
stringH t = writeH (length t) (`IO.hPutStr` t)
textH t = writeH (length t) (`Text.hPutStr` t)
ltextH t = writeH (length t) (`TL.hPutStr` t)
newline = TermIO $ \ro -> unTermIO (reader_newline ro) ro
instance Indentable TermIO where
align t = TermIO $ \ro st -> unTermIO t ro{reader_indent=st} st
withNewline nl t = TermIO $ \ro -> unTermIO t ro{reader_newline=nl}
withIndent ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=ind}
incrIndent ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=reader_indent ro + ind}
column f = TermIO $ \ro st -> unTermIO (f st) ro st
indent f = TermIO $ \ro -> unTermIO (f (reader_indent ro)) ro
newlineWithoutIndent = TermIO $ \ro _st ok _ko ->
ok 0 $ IO.hPutChar (reader_handle ro) '\n'
newlineWithIndent = TermIO $ \ro@Reader{reader_handle=h} _st ok _ko ->
ok (reader_indent ro) $ do
IO.hPutChar h '\n'
IO.hPutStr h $ List.replicate (fromIntegral $ reader_indent ro) ' '
instance Breakable TermIO where
breakable f = TermIO $ \ro -> unTermIO (f (reader_breakable ro)) ro
withBreakable b t = TermIO $ \ro -> unTermIO t ro{reader_breakable=b}
ifBreak y x = TermIO $ \ro st ok ko ->
unTermIO x ro st ok $
case reader_breakable ro of
Nothing -> ko
Just{} -> (\_sx _tx -> unTermIO y ro st ok ko)
breakpoint onNoBreak onBreak t = TermIO $ \ro st ok ko ->
unTermIO (onNoBreak <> t) ro st ok $
case reader_breakable ro of
Nothing -> ko
Just{} -> (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)
writeSGR :: (Reader -> Bool) -> SGR -> TermIO -> TermIO
writeSGR isOn s (TermIO t) =
TermIO $ \ro ->
if isOn ro
then unTermIO (o <> m <> c) ro
else t ro
where
o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]
m = TermIO $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) $ Reset:List.reverse (reader_sgr ro)
instance Colorable TermIO where
colorable f = TermIO $ \ro -> unTermIO (f (reader_colorable ro)) ro
withColorable b t = TermIO $ \ro -> unTermIO t ro{reader_colorable=b}
reverse = writeSGR reader_colorable $ SetSwapForegroundBackground True
black = writeSGR reader_colorable $ SetColor Foreground Dull Black
red = writeSGR reader_colorable $ SetColor Foreground Dull Red
green = writeSGR reader_colorable $ SetColor Foreground Dull Green
yellow = writeSGR reader_colorable $ SetColor Foreground Dull Yellow
blue = writeSGR reader_colorable $ SetColor Foreground Dull Blue
magenta = writeSGR reader_colorable $ SetColor Foreground Dull Magenta
cyan = writeSGR reader_colorable $ SetColor Foreground Dull Cyan
white = writeSGR reader_colorable $ SetColor Foreground Dull White
blacker = writeSGR reader_colorable $ SetColor Foreground Vivid Black
redder = writeSGR reader_colorable $ SetColor Foreground Vivid Red
greener = writeSGR reader_colorable $ SetColor Foreground Vivid Green
yellower = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow
bluer = writeSGR reader_colorable $ SetColor Foreground Vivid Blue
magentaer = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta
cyaner = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan
whiter = writeSGR reader_colorable $ SetColor Foreground Vivid White
onBlack = writeSGR reader_colorable $ SetColor Background Dull Black
onRed = writeSGR reader_colorable $ SetColor Background Dull Red
onGreen = writeSGR reader_colorable $ SetColor Background Dull Green
onYellow = writeSGR reader_colorable $ SetColor Background Dull Yellow
onBlue = writeSGR reader_colorable $ SetColor Background Dull Blue
onMagenta = writeSGR reader_colorable $ SetColor Background Dull Magenta
onCyan = writeSGR reader_colorable $ SetColor Background Dull Cyan
onWhite = writeSGR reader_colorable $ SetColor Background Dull White
onBlacker = writeSGR reader_colorable $ SetColor Background Vivid Black
onRedder = writeSGR reader_colorable $ SetColor Background Vivid Red
onGreener = writeSGR reader_colorable $ SetColor Background Vivid Green
onYellower = writeSGR reader_colorable $ SetColor Background Vivid Yellow
onBluer = writeSGR reader_colorable $ SetColor Background Vivid Blue
onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta
onCyaner = writeSGR reader_colorable $ SetColor Background Vivid Cyan
onWhiter = writeSGR reader_colorable $ SetColor Background Vivid White
instance Decorable TermIO where
decorable f = TermIO $ \ro -> unTermIO (f (reader_decorable ro)) ro
withDecorable b t = TermIO $ \ro -> unTermIO t ro{reader_decorable=b}
bold = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
italic = writeSGR reader_decorable $ SetItalicized True