module Language.Symantic.Document.Term
( module Language.Symantic.Document.Sym
, module Language.Symantic.Document.Term
) 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 (pred, fromIntegral, Num(..))
import System.Console.ANSI
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Language.Symantic.Document.Sym
data Reader
= Reader
{ reader_indent :: !Indent
, reader_newline :: Term
, reader_sgr :: ![SGR]
, reader_breakable :: !(Maybe Column)
, reader_colorable :: !Bool
, reader_decorable :: !Bool
}
defReader :: Reader
defReader = Reader
{ reader_indent = 0
, reader_newline = newlineWithIndent
, reader_sgr = []
, reader_breakable = Nothing
, reader_colorable = True
, reader_decorable = True
}
type State = Column
defState :: State
defState = 0
newtype Term
= Term
{ unTerm :: Reader ->
State ->
(State -> TLB.Builder -> TLB.Builder) ->
(State -> TLB.Builder -> TLB.Builder) ->
TLB.Builder }
textTerm :: Term -> TL.Text
textTerm = TLB.toLazyText . runTerm
runTerm :: Term -> TLB.Builder
runTerm (Term t) = t defReader defState oko oko
where oko _st = id
instance IsList Term where
type Item Term = Term
fromList = mconcat
toList = pure
instance Semigroup Term where
x <> y = Term $ \ro st ok ko ->
unTerm x ro st
(\sx tx -> unTerm y ro sx
(\sy ty -> ok sy (tx<>ty))
(\sy ty -> ko sy (tx<>ty)))
(\sx tx -> unTerm y ro sx
(\sy ty -> ko sy (tx<>ty))
(\sy ty -> ko sy (tx<>ty)))
instance Monoid Term where
mempty = empty
mappend = (<>)
instance IsString Term where
fromString = string
writeH :: Column -> TLB.Builder -> Term
writeH len t =
Term $ \ro st ok ko ->
let newCol = st + len in
(case reader_breakable ro of
Just breakCol | breakCol < newCol -> ko
_ -> ok)
newCol t
instance Textable Term where
empty = Term $ \_ro st ok _ko -> ok st mempty
charH t = writeH (Nat 1) (TLB.singleton t)
stringH t = writeH (length t) (fromString t)
textH t = writeH (length t) (TLB.fromText t)
ltextH t = writeH (length t) (TLB.fromLazyText t)
replicate cnt t | cnt <= 0 = empty
| otherwise = t <> replicate (pred cnt) t
newline = Term $ \ro -> unTerm (reader_newline ro) ro
instance Indentable Term where
align t = Term $ \ro st -> unTerm t ro{reader_indent=st} st
withNewline nl t = Term $ \ro -> unTerm t ro{reader_newline=nl}
withIndent ind t = Term $ \ro -> unTerm t ro{reader_indent=ind}
incrIndent ind t = Term $ \ro -> unTerm t ro{reader_indent=reader_indent ro + ind}
column f = Term $ \ro st -> unTerm (f st) ro st
indent f = Term $ \ro -> unTerm (f (reader_indent ro)) ro
newlineWithoutIndent = Term $ \_ro _st ok _ko ->
ok 0 $ TLB.singleton '\n'
newlineWithIndent = Term $ \ro _st ok _ko ->
ok (reader_indent ro) $
TLB.singleton '\n' <>
fromString (List.replicate (fromIntegral $ reader_indent ro) ' ')
instance Breakable Term where
breakable f = Term $ \ro -> unTerm (f (reader_breakable ro)) ro
withBreakable b t = Term $ \ro -> unTerm t ro{reader_breakable=b}
ifBreak y x = Term $ \ro st ok ko ->
unTerm x ro st ok $
case reader_breakable ro of
Nothing -> ko
Just{} -> (\_sx _tx -> unTerm y ro st ok ko)
breakpoint onNoBreak onBreak t = Term $ \ro st ok ko ->
unTerm (onNoBreak <> t) ro st ok $
case reader_breakable ro of
Nothing -> ko
Just{} -> (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)
writeSGR :: (Reader -> Bool) -> SGR -> Term -> Term
writeSGR isOn s (Term t) =
Term $ \ro ->
if isOn ro
then unTerm (o <> m <> c) ro
else t ro
where
o = Term $ \_ro st ok _ko -> ok st $ fromString $ setSGRCode [s]
m = Term $ \ro -> t ro{reader_sgr=s:reader_sgr ro}
c = Term $ \ro st ok _ko -> ok st $ fromString $ setSGRCode $ Reset:List.reverse (reader_sgr ro)
instance Colorable Term where
colorable f = Term $ \ro -> unTerm (f (reader_colorable ro)) ro
withColorable b t = Term $ \ro -> unTerm 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 Term where
decorable f = Term $ \ro -> unTerm (f (reader_decorable ro)) ro
withDecorable b t = Term $ \ro -> unTerm t ro{reader_decorable=b}
bold = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity
underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline
italic = writeSGR reader_decorable $ SetItalicized True