{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE UndecidableInstances #-} module Symantic.Document.Plain where import Control.Monad (Monad(..)) import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..)) import Data.Function (($), (.), id) import Data.Functor ((<$>)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..), Ordering(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String, IsString(..)) import Data.Text (Text) import Data.Tuple (snd) import GHC.Natural (minusNatural,minusNaturalMaybe,quotRemNatural) import Numeric.Natural (Natural) import Prelude (fromIntegral, Num(..), pred) import System.Console.ANSI hiding (SGR) import Text.Show (Show(..), showString, showParen) import qualified Data.Foldable as Fold import qualified Data.List as List import qualified Data.Text.Lazy as TL import Symantic.Document.API -- * Type 'Plain' -- | Church encoded for performance concerns. -- Kind like 'ParsecT' in @megaparsec@ but a little bit different -- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly -- when in the left hand side of ('<>'). -- Prepending is done using continuation, like in a difference list. newtype Plain d = Plain { unPlain :: {-curr-}PlainInh d -> {-curr-}PlainState d -> {-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) -> PlainFit d -- NOTE: equivalent to: -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d) } instance (Show d, Spaceable d) => Show (Plain d) where show = show . runPlain runPlain :: Spaceable d => Plain d -> d runPlain x = unPlain x defPlainInh defPlainState {-k-}(\(px,_sx) fits _overflow -> -- NOTE: if px fits, then appending mempty fits fits (px mempty) ) {-fits-}id {-overflow-}id -- ** Type 'PlainState' data PlainState d = PlainState { plainState_buffer :: ![PlainChunk d] , plainState_bufferStart :: !Column -- ^ The 'Column' from which the 'plainState_buffer' -- must be written. , plainState_bufferWidth :: !Width -- ^ The 'Width' of the 'plainState_buffer' so far. , plainState_breakIndent :: !Indent -- ^ The amount of 'Indent' added by 'breakspace' -- that can be reached by breaking the 'space' -- into a 'newlineJustifyingPlain'. } deriving (Show) defPlainState :: PlainState d defPlainState = PlainState { plainState_buffer = mempty , plainState_bufferStart = 0 , plainState_bufferWidth = 0 , plainState_breakIndent = 0 } -- ** Type 'PlainInh' data PlainInh d = PlainInh { plainInh_width :: !(Maybe Column) , plainInh_justify :: !Bool , plainInh_indent :: !Indent , plainInh_indenting :: !(Plain d) , plainInh_sgr :: ![SGR] } defPlainInh :: Spaceable d => PlainInh d defPlainInh = PlainInh { plainInh_width = Nothing , plainInh_justify = False , plainInh_indent = 0 , plainInh_indenting = mempty , plainInh_sgr = [] } -- ** Type 'PlainFit' -- | Double continuation to qualify the returned document -- as fitting or overflowing the given 'plainInh_width'. -- It's like @('Bool',d)@ in a normal style -- (a non continuation-passing-style). type PlainFit d = {-fits-}(d -> d) -> {-overflow-}(d -> d) -> d -- ** Type 'PlainChunk' data PlainChunk d = PlainChunk_Ignored !d -- ^ Ignored by the justification but kept in place. -- Used for instance to put ANSI sequences. | PlainChunk_Word !(Word d) | PlainChunk_Spaces !Width -- ^ 'spaces' preserved to be interleaved -- correctly with 'PlainChunk_Ignored'. instance Show d => Show (PlainChunk d) where showsPrec p x = showParen (p>10) $ case x of PlainChunk_Ignored d -> showString "Z " . showsPrec 11 d PlainChunk_Word (Word d) -> showString "W " . showsPrec 11 d PlainChunk_Spaces s -> showString "S " . showsPrec 11 s instance Lengthable d => Lengthable (PlainChunk d) where width = \case PlainChunk_Ignored{} -> 0 PlainChunk_Word d -> width d PlainChunk_Spaces s -> s nullWidth = \case PlainChunk_Ignored{} -> True PlainChunk_Word d -> nullWidth d PlainChunk_Spaces s -> s == 0 instance From [SGR] d => From [SGR] (PlainChunk d) where from sgr = PlainChunk_Ignored (from sgr) runPlainChunk :: Spaceable d => PlainChunk d -> d runPlainChunk = \case PlainChunk_Ignored d -> d PlainChunk_Word (Word d) -> d PlainChunk_Spaces s -> spaces s instance Semigroup d => Semigroup (Plain d) where Plain x <> Plain y = Plain $ \inh st k -> x inh st $ \(px,sx) -> y inh sx $ \(py,sy) -> k (px.py,sy) instance Monoid d => Monoid (Plain d) where mempty = Plain $ \_inh st k -> k (id,st) mappend = (<>) instance Spaceable d => Spaceable (Plain d) where -- | The default 'newline' does not justify 'plainState_buffer', -- for that use 'newlineJustifyingPlain'. newline = Plain $ \inh st -> unPlain ( newlinePlain <> indentPlain <> propagatePlain (plainState_breakIndent st) <> flushlinePlain ) inh st where indentPlain = Plain $ \inh -> unPlain (plainInh_indenting inh) inh{plainInh_justify=False} newlinePlain = Plain $ \inh st k -> k (\next -> (if plainInh_justify inh then joinLinePlainChunk $ List.reverse $ plainState_buffer st else mempty )<>newline<>next , st { plainState_bufferStart = 0 , plainState_bufferWidth = 0 , plainState_buffer = mempty }) propagatePlain breakIndent = Plain $ \inh st1 k fits overflow -> k (id,st1) fits {-overflow-}( -- NOTE: the text after this newline overflows, -- so propagate the overflow before this 'newline', -- if and only if there is a 'breakspace' before this 'newline' -- whose replacement by a 'newline' indents to a lower indent -- than this 'newline''s indent. -- Otherwise there is no point in propagating the overflow. if breakIndent < plainInh_indent inh then overflow else fits ) space = spaces 1 spaces n = Plain $ \inh st@PlainState{..} k fits overflow -> let newWidth = plainState_bufferStart + plainState_bufferWidth + n in if plainInh_justify inh then let newState = st { plainState_buffer = case plainState_buffer of PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf buf -> PlainChunk_Spaces n:buf , plainState_bufferWidth = plainState_bufferWidth + n } in case plainInh_width inh of Just maxWidth | maxWidth < newWidth -> overflow $ k (id{-(d<>)-}, newState) fits overflow _ -> k (id{-(d<>)-}, newState) fits overflow else let newState = st { plainState_bufferWidth = plainState_bufferWidth + n } in case plainInh_width inh of Just maxWidth | maxWidth < newWidth -> overflow $ k ((spaces n <>), newState) fits fits _ -> k ((spaces n <>), newState) fits overflow instance (From (Word s) d, Semigroup d, Lengthable s) => From (Word s) (Plain d) where from s = Plain $ \inh st@PlainState{..} k fits overflow -> let wordWidth = width s in if wordWidth <= 0 then k (id,st) fits overflow else let newBufferWidth = plainState_bufferWidth + wordWidth in let newWidth = plainState_bufferStart + newBufferWidth in if plainInh_justify inh then let newState = st { plainState_buffer = PlainChunk_Word (Word (from s)) : plainState_buffer , plainState_bufferWidth = newBufferWidth } in case plainInh_width inh of Just maxWidth | maxWidth < newWidth -> overflow $ k (id, newState) fits overflow _ -> k (id, newState) fits overflow else let newState = st { plainState_bufferWidth = newBufferWidth } in case plainInh_width inh of Just maxWidth | maxWidth < newWidth -> overflow $ k ((from s <>), newState) fits fits _ -> k ((from s <>), newState) fits overflow instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) => From (Line s) (Plain d) where from = mconcat . List.intersperse breakspace . (from <$>) . words . unLine instance Spaceable d => Indentable (Plain d) where align p = (flushlinePlain <>) $ Plain $ \inh st -> let col = plainState_bufferStart st + plainState_bufferWidth st in unPlain p inh { plainInh_indent = col , plainInh_indenting = if plainInh_indent inh <= col then plainInh_indenting inh <> spaces (col`minusNatural`plainInh_indent inh) else spaces col } st setIndent d i p = Plain $ \inh -> unPlain p inh { plainInh_indent = i , plainInh_indenting = d } incrIndent d i p = Plain $ \inh -> unPlain p inh { plainInh_indent = plainInh_indent inh + i , plainInh_indenting = plainInh_indenting inh <> d } fill m p = Plain $ \inh0 st0 -> let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in let p1 = Plain $ \inh1 st1 -> let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in unPlain (if col <= maxCol then spaces (maxCol`minusNatural`col) else mempty) inh1 st1 in unPlain (p <> p1) inh0 st0 fillOrBreak m p = Plain $ \inh0 st0 -> let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in let p1 = Plain $ \inh1 st1 -> let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in unPlain (case col`compare`maxCol of LT -> spaces (maxCol`minusNatural`col) EQ -> mempty GT -> incrIndent (spaces m) m newline ) inh1 st1 in unPlain (p <> p1) inh0 st0 instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where ul ds = catV $ (<$> ds) $ \d -> from (Word '-')<>space<>flushlinePlain<>align d{-<>flushlinePlain-} ol ds = catV $ snd $ Fold.foldr (\d (i, acc) -> (pred i, (from i<>from (Word '.')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}) : acc) ) (Fold.length ds, []) ds instance Spaceable d => Justifiable (Plain d) where justify p = (\x -> flushlinePlain <> x <> flushlinePlain) $ Plain $ \inh -> unPlain p inh{plainInh_justify=True} -- | Commit 'plainState_buffer' upto there, so that it won't be justified. flushlinePlain :: Spaceable d => Plain d flushlinePlain = Plain $ \_inh st k -> k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>) , st { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st , plainState_bufferWidth = 0 , plainState_buffer = mempty } ) collapsePlainChunkSpaces :: PlainChunk d -> PlainChunk d collapsePlainChunkSpaces = \case PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0) x -> x instance Spaceable d => Wrappable (Plain d) where setWidth w p = Plain $ \inh -> unPlain p inh{plainInh_width=w} breakpoint = Plain $ \inh st k fits overflow -> k(id, st {plainState_breakIndent = plainInh_indent inh}) fits {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow) breakspace = Plain $ \inh st k fits overflow -> k( if plainInh_justify inh then id else (space <>) , st { plainState_buffer = if plainInh_justify inh then case plainState_buffer st of PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs bs -> PlainChunk_Spaces 1:bs else plainState_buffer st , plainState_bufferWidth = plainState_bufferWidth st + 1 , plainState_breakIndent = plainInh_indent inh } ) fits {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow) breakalt x y = Plain $ \inh st k fits overflow -> -- NOTE: breakalt must be y if and only if x does not fit, -- hence the use of dummyK to limit the test -- to overflows raised within x, and drop those raised after x. unPlain x inh st dummyK {-fits-} (\_r -> unPlain x inh st k fits overflow) {-overflow-}(\_r -> unPlain y inh st k fits overflow) where dummyK (px,_sx) fits _overflow = -- NOTE: if px fits, then appending mempty fits fits (px mempty) endline = Plain $ \inh st k fits _overflow -> let col = plainState_bufferStart st + plainState_bufferWidth st in case plainInh_width inh >>= (`minusNaturalMaybe` col) of Nothing -> k (id, st) fits fits Just w -> let newState = st { plainState_bufferWidth = plainState_bufferWidth st + w } in k (id,newState) fits fits -- | Like 'newline', but justify 'plainState_buffer' before. newlineJustifyingPlain :: Spaceable d => Plain d newlineJustifyingPlain = Plain $ \inh st -> unPlain ( newlinePlain <> indentPlain <> propagatePlain (plainState_breakIndent st) <> flushlinePlain ) inh st where indentPlain = Plain $ \inh -> unPlain (plainInh_indenting inh) inh{plainInh_justify=False} newlinePlain = Plain $ \inh st k -> k (\next -> (if plainInh_justify inh then justifyLinePlain inh st else mempty )<>newline<>next , st { plainState_bufferStart = 0 , plainState_bufferWidth = 0 , plainState_buffer = mempty }) propagatePlain breakIndent = Plain $ \inh st1 k fits overflow -> k (id,st1) fits {-overflow-}( -- NOTE: the text after this newline overflows, -- so propagate the overflow before this 'newline', -- if and only if there is a 'breakspace' before this 'newline' -- whose replacement by a 'newline' indents to a lower indent -- than this 'newline''s indent. -- Otherwise there is no point in propagating the overflow. if breakIndent < plainInh_indent inh then overflow else fits ) -- String instance (From (Word String) d, Spaceable d) => From String (Plain d) where from = mconcat . List.intersperse newline . (from <$>) . lines instance (From (Word String) d, Spaceable d) => IsString (Plain d) where fromString = from -- Text instance (From (Word Text) d, Spaceable d) => From Text (Plain d) where from = mconcat . List.intersperse newline . (from <$>) . lines instance (From (Word TL.Text) d, Spaceable d) => From TL.Text (Plain d) where from = mconcat . List.intersperse newline . (from <$>) . lines -- Char instance (From (Word Char) d, Spaceable d) => From Char (Plain d) where from ' ' = breakspace from '\n' = newline from c = from (Word c) instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where from sgr = Plain $ \inh st k -> if plainInh_justify inh then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st}) else k ((from sgr <>), st) -- * Justifying justifyLinePlain :: Spaceable d => PlainInh d -> PlainState d -> d justifyLinePlain inh PlainState{..} = case plainInh_width inh of Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer Just maxWidth -> if maxWidth < plainState_bufferStart || maxWidth < plainInh_indent inh then joinLinePlainChunk $ List.reverse plainState_buffer else let superfluousSpaces = Fold.foldr (\c acc -> acc + case c of PlainChunk_Ignored{} -> 0 PlainChunk_Word{} -> 0 PlainChunk_Spaces s -> s`minusNatural`(min 1 s)) 0 plainState_buffer in let minBufferWidth = -- NOTE: cap the spaces at 1, -- to let justifyWidth decide where to add spaces. plainState_bufferWidth`minusNatural`superfluousSpaces in let justifyWidth = -- NOTE: when minBufferWidth is not breakable, -- the width of justification can be wider than -- what remains to reach maxWidth. max minBufferWidth $ maxWidth`minusNatural`plainState_bufferStart in let wordCount = countWordsPlain plainState_buffer in unLine $ padLinePlainChunkInits justifyWidth $ (minBufferWidth,wordCount,List.reverse plainState_buffer) -- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@ -- clearly separated by spaces. countWordsPlain :: [PlainChunk d] -> Natural countWordsPlain = go False 0 where go inWord acc = \case [] -> acc PlainChunk_Word{}:xs -> if inWord then go inWord acc xs else go True (acc+1) xs PlainChunk_Spaces s:xs | s == 0 -> go inWord acc xs | otherwise -> go False acc xs PlainChunk_Ignored{}:xs -> go inWord acc xs -- | @('justifyPadding' a b)@ returns the padding lengths -- to reach @(a)@ in @(b)@ pads, -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@ -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@. -- -- A simple implementation of 'justifyPadding' could be: -- @ -- 'justifyPadding' a b = -- 'join' ('List.replicate' m [q,q'+'1]) -- <> ('List.replicate' (r'-'m) (q'+'1) -- <> ('List.replicate' ((b'-'r)'-'m) q -- where -- (q,r) = a`divMod`b -- m = 'min' (b-r) r -- @ justifyPadding :: Natural -> Natural -> [Natural] justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod' where (q,r) = a`quotRemNatural`b go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r go rr 0 = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1) padLinePlainChunkInits :: Spaceable d => Width -> (Natural, Natural, [PlainChunk d]) -> Line d padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $ if maxWidth <= lineWidth -- The gathered line reached or overreached the maxWidth, -- hence no padding id needed. || wordCount <= 1 -- The case maxWidth <= lineWidth && wordCount == 1 -- can happen if first word's length is < maxWidth -- but second word's len is >= maxWidth. then joinLinePlainChunk line else -- Share the missing spaces as evenly as possible -- between the words of the line. padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1) -- | Just concat 'PlainChunk's with no justification. joinLinePlainChunk :: Monoid d => Spaceable d => [PlainChunk d] -> d joinLinePlainChunk = mconcat . (runPlainChunk <$>) -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'. padLinePlainChunk :: Spaceable d => [PlainChunk d] -> [Width] -> d padLinePlainChunk = go where go (w:ws) lls@(l:ls) = case w of PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls _ -> runPlainChunk w <> go ws lls go (w:ws) [] = runPlainChunk w <> go ws [] go [] _ls = mempty -- * Escaping instance (Semigroup d, From [SGR] d) => Colorable16 (Plain d) where reverse = plainSGR $ SetSwapForegroundBackground True black = plainSGR $ SetColor Foreground Dull Black red = plainSGR $ SetColor Foreground Dull Red green = plainSGR $ SetColor Foreground Dull Green yellow = plainSGR $ SetColor Foreground Dull Yellow blue = plainSGR $ SetColor Foreground Dull Blue magenta = plainSGR $ SetColor Foreground Dull Magenta cyan = plainSGR $ SetColor Foreground Dull Cyan white = plainSGR $ SetColor Foreground Dull White blacker = plainSGR $ SetColor Foreground Vivid Black redder = plainSGR $ SetColor Foreground Vivid Red greener = plainSGR $ SetColor Foreground Vivid Green yellower = plainSGR $ SetColor Foreground Vivid Yellow bluer = plainSGR $ SetColor Foreground Vivid Blue magentaer = plainSGR $ SetColor Foreground Vivid Magenta cyaner = plainSGR $ SetColor Foreground Vivid Cyan whiter = plainSGR $ SetColor Foreground Vivid White onBlack = plainSGR $ SetColor Background Dull Black onRed = plainSGR $ SetColor Background Dull Red onGreen = plainSGR $ SetColor Background Dull Green onYellow = plainSGR $ SetColor Background Dull Yellow onBlue = plainSGR $ SetColor Background Dull Blue onMagenta = plainSGR $ SetColor Background Dull Magenta onCyan = plainSGR $ SetColor Background Dull Cyan onWhite = plainSGR $ SetColor Background Dull White onBlacker = plainSGR $ SetColor Background Vivid Black onRedder = plainSGR $ SetColor Background Vivid Red onGreener = plainSGR $ SetColor Background Vivid Green onYellower = plainSGR $ SetColor Background Vivid Yellow onBluer = plainSGR $ SetColor Background Vivid Blue onMagentaer = plainSGR $ SetColor Background Vivid Magenta onCyaner = plainSGR $ SetColor Background Vivid Cyan onWhiter = plainSGR $ SetColor Background Vivid White instance (Semigroup d, From [SGR] d) => Decorable (Plain d) where bold = plainSGR $ SetConsoleIntensity BoldIntensity underline = plainSGR $ SetUnderlining SingleUnderline italic = plainSGR $ SetItalicized True plainSGR :: Semigroup d => From [SGR] d => SGR -> Plain d -> Plain d plainSGR newSGR p = before <> middle <> after where before = Plain $ \inh st k -> let d = from [newSGR] in if plainInh_justify inh then k (id, st { plainState_buffer = PlainChunk_Ignored d : plainState_buffer st }) else k ((d <>), st) middle = Plain $ \inh -> unPlain p inh{plainInh_sgr=newSGR:plainInh_sgr inh} after = Plain $ \inh st k -> let d = from $ Reset : List.reverse (plainInh_sgr inh) in if plainInh_justify inh then k (id, st { plainState_buffer = PlainChunk_Ignored d : plainState_buffer st }) else k ((d <>), st)