module Language.Symantic.Document.Plain where import Control.Applicative (Applicative(..)) import Data.Bool import Data.Int (Int) import Data.Function (($), (.), id) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..)) import Prelude ((+), pred) import GHC.Exts (IsList(..)) import System.Console.ANSI import Text.Show (Show(..)) import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB -- import qualified Data.Text.Lazy.IO as TL -- import qualified System.IO as IO import Language.Symantic.Document.Sym -- * Type 'Inh' data Inh = Inh { inh_indent :: !(Indent Plain) -- ^ Current indentation level, used by 'newline'. , inh_newline :: Plain -- ^ How to display 'newline'. , inh_wrap_column :: !(Column Plain) -- ^ 'Column' after which 'wrap' breaks on a 'breakpoint' or 'breakspace'. , inh_sgr :: ![SGR] -- ^ Active ANSI codes. } defInh :: Inh defInh = Inh { inh_indent = 0 , inh_newline = newlineWithIndent , inh_wrap_column = 80 , inh_sgr = [] } -- * Type 'State' type State = Column Plain defState :: State defState = 0 -- * Type 'Plain' newtype Plain = Plain { unPlain :: Inh -> State -> (State -> TLB.Builder -> TLB.Builder) -- normal continuation -> (State -> TLB.Builder -> TLB.Builder) -- wrapping continuation -> TLB.Builder } buildPlain :: Plain -> TLB.Builder buildPlain (Plain p) = p defInh defState oko oko where oko _st = id textPlain :: Plain -> TL.Text textPlain = TLB.toLazyText . buildPlain instance IsList Plain where type Item Plain = Plain fromList = mconcat toList = pure instance Semigroup Plain where x <> y = Plain $ \inh st ok ko -> unPlain x inh st (\sx tx -> unPlain y inh sx (\sy ty -> ok sy (tx<>ty)) (\sy ty -> ko sy (tx<>ty))) (\sx tx -> unPlain y inh sx (\sy ty -> ko sy (tx<>ty)) (\sy ty -> ko sy (tx<>ty))) instance Monoid Plain where mempty = empty mappend = (<>) instance IsString Plain where fromString = string plainWrite :: Column Plain -> TLB.Builder -> Plain plainWrite len t = Plain $ \inh st ok ko -> let newCol = st + len in (if newCol <= inh_wrap_column inh then ok else ko) newCol t instance Doc_Text Plain where empty = Plain $ \_inh st ok _ko -> ok st "" charH t = plainWrite 1 $ TLB.singleton t stringH t = plainWrite (List.length t) (fromString t) textH t = plainWrite (Text.length t) (TLB.fromText t) ltextH t = plainWrite (intOfInt64 $ TL.length t) (TLB.fromLazyText t) int = stringH . show integer = stringH . show replicate cnt p | cnt <= 0 = empty | otherwise = p <> replicate (pred cnt) p newline = Plain $ \inh -> unPlain (inh_newline inh) inh newlineWithoutIndent :: Plain newlineWithoutIndent = Plain $ \_inh _st ok _ko -> ok 0 $ TLB.singleton '\n' newlineWithIndent :: Plain newlineWithIndent = Plain $ \inh _st ok _ko -> ok (inh_indent inh) $ TLB.singleton '\n' <> fromString (List.replicate (inh_indent inh) ' ') instance Doc_Align Plain where type Column Plain = Int type Indent Plain = Int align p = Plain $ \inh st -> unPlain p inh{inh_indent=st} st withNewline nl p = Plain $ \inh -> unPlain p inh{inh_newline=nl} withIndent ind p = Plain $ \inh -> unPlain p inh{inh_indent=ind} incrIndent ind p = Plain $ \inh -> unPlain p inh{inh_indent=inh_indent inh + ind} column f = Plain $ \inh st -> unPlain (f st) inh st instance Doc_Wrap Plain where ifFit x y = Plain $ \inh st ok ko -> unPlain x inh st ok (\_sx _tx -> unPlain y inh st ok ko) breakpoint onNoBreak onBreak p = Plain $ \inh st ok ko -> unPlain (onNoBreak <> p) inh st ok (\_sp _tp -> unPlain (onBreak <> p) inh st ok ko) withWrapColumn col p = Plain $ \inh -> unPlain p inh{inh_wrap_column=col} writeSGR :: SGR -> Plain -> Plain writeSGR s p = Plain $ \inh@Inh{inh_sgr=ss} st ok ko -> let o = Plain $ \_inh st' ok' _ko -> ok' st' $ fromString $ setSGRCode [s] in let c :: TLB.Builder = fromString $ setSGRCode $ Reset:List.reverse ss in unPlain (o<>p) inh{inh_sgr=s:ss} st (\_st t -> ok st $ t<>c) (\_st t -> ko st $ t<>c) instance Doc_Color Plain where reverse = writeSGR $ SetSwapForegroundBackground True black = writeSGR $ SetColor Foreground Dull Black red = writeSGR $ SetColor Foreground Dull Red green = writeSGR $ SetColor Foreground Dull Green yellow = writeSGR $ SetColor Foreground Dull Yellow blue = writeSGR $ SetColor Foreground Dull Blue magenta = writeSGR $ SetColor Foreground Dull Magenta cyan = writeSGR $ SetColor Foreground Dull Cyan white = writeSGR $ SetColor Foreground Dull White blacker = writeSGR $ SetColor Foreground Vivid Black redder = writeSGR $ SetColor Foreground Vivid Red greener = writeSGR $ SetColor Foreground Vivid Green yellower = writeSGR $ SetColor Foreground Vivid Yellow bluer = writeSGR $ SetColor Foreground Vivid Blue magentaer = writeSGR $ SetColor Foreground Vivid Magenta cyaner = writeSGR $ SetColor Foreground Vivid Cyan whiter = writeSGR $ SetColor Foreground Vivid White onBlack = writeSGR $ SetColor Background Dull Black onRed = writeSGR $ SetColor Background Dull Red onGreen = writeSGR $ SetColor Background Dull Green onYellow = writeSGR $ SetColor Background Dull Yellow onBlue = writeSGR $ SetColor Background Dull Blue onMagenta = writeSGR $ SetColor Background Dull Magenta onCyan = writeSGR $ SetColor Background Dull Cyan onWhite = writeSGR $ SetColor Background Dull White onBlacker = writeSGR $ SetColor Background Vivid Black onRedder = writeSGR $ SetColor Background Vivid Red onGreener = writeSGR $ SetColor Background Vivid Green onYellower = writeSGR $ SetColor Background Vivid Yellow onBluer = writeSGR $ SetColor Background Vivid Blue onMagentaer = writeSGR $ SetColor Background Vivid Magenta onCyaner = writeSGR $ SetColor Background Vivid Cyan onWhiter = writeSGR $ SetColor Background Vivid White instance Doc_Decoration Plain where bold = writeSGR $ SetConsoleIntensity BoldIntensity underline = writeSGR $ SetUnderlining SingleUnderline italic = writeSGR $ SetItalicized True {- -- * Type 'PlainIO' newtype PlainIO = PlainIO { unPlainIO :: IO.Handle -> IO () } instance IsString PlainIO where fromString s = PlainIO $ \h -> IO.hPutStr h s plainIO :: PlainIO -> IO.Handle -> IO () plainIO (PlainIO d) = d instance Semigroup PlainIO where PlainIO x <> PlainIO y = PlainIO $ \h -> do {x h; y h} instance Monoid PlainIO where mempty = empty mappend = (<>) instance Doc_Text PlainIO where empty = PlainIO $ \_ -> return () int i = PlainIO $ \h -> IO.hPutStr h (show i) integer i = PlainIO $ \h -> IO.hPutStr h (show i) replicate i d = PlainIO $ replicateM_ i . plainIO d charH x = PlainIO $ \h -> IO.hPutChar h x stringH x = PlainIO $ \h -> IO.hPutStr h x textH x = PlainIO $ \h -> Text.hPutStr h x ltextH x = PlainIO $ \h -> TL.hPutStr h x -- NOTE: PlainIO has no support for indentation, hence char = charH, etc. char = charH string = stringH text = textH ltext = ltextH instance Doc_Color PlainIO where reverse = id black = id red = id green = id yellow = id blue = id magenta = id cyan = id white = id blacker = id redder = id greener = id yellower = id bluer = id magentaer = id cyaner = id whiter = id onBlack = id onRed = id onGreen = id onYellow = id onBlue = id onMagenta = id onCyan = id onWhite = id onBlacker = id onRedder = id onGreener = id onYellower = id onBluer = id onMagentaer = id onCyaner = id onWhiter = id instance Doc_Decoration PlainIO where bold = id underline = id italic = id -}