{-# 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
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
newtype Plain d = Plain
{ unPlain ::
PlainInh d ->
PlainState d ->
( ((d->d), PlainState d) -> PlainFit d) ->
PlainFit 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
(\(px,_sx) fits _overflow ->
fits (px mempty) )
id
id
data PlainState d = PlainState
{ plainState_buffer :: ![PlainChunk d]
, plainState_bufferStart :: !Column
, plainState_bufferWidth :: !Width
, plainState_breakIndent :: !Indent
} deriving (Show)
defPlainState :: PlainState d
defPlainState = PlainState
{ plainState_buffer = mempty
, plainState_bufferStart = 0
, plainState_bufferWidth = 0
, plainState_breakIndent = 0
}
data PlainInh d = PlainInh
{ plainInh_width :: !(Maybe Column)
, plainInh_justify :: !Bool
, plainInh_indent :: !Indent
, plainInh_indenting :: !(Plain d)
}
defPlainInh :: Spaceable d => PlainInh d
defPlainInh = PlainInh
{ plainInh_width = Nothing
, plainInh_justify = False
, plainInh_indent = 0
, plainInh_indenting = mempty
}
type PlainFit d = (d -> d) ->
(d -> d) ->
d
data PlainChunk d
= PlainChunk_Ignored !d
| PlainChunk_Word !(Word d)
| PlainChunk_Spaces !Width
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
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
(
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, newState) fits overflow
_ -> k (id, 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}
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
(\_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
(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
breakalt x y = Plain $ \inh st k fits overflow ->
unPlain x inh st dummyK
(\_r -> unPlain x inh st k fits overflow)
(\_r -> unPlain y inh st k fits overflow)
where
dummyK (px,_sx) fits _overflow =
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
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
(
if breakIndent < plainInh_indent inh
then overflow
else fits
)
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
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
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)
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 =
plainState_bufferWidth`minusNatural`superfluousSpaces in
let justifyWidth =
max minBufferWidth $
maxWidth`minusNatural`plainState_bufferStart
in
let wordCount = countWordsPlain plainState_buffer in
unLine $ padLinePlainChunkInits justifyWidth $
(minBufferWidth,wordCount,List.reverse plainState_buffer)
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 :: Natural -> Natural -> [Natural]
justifyPadding a b = go r (b-r)
where
(q,r) = a`quotRemNatural`b
go 0 bmr = List.replicate (fromIntegral bmr) q
go rr 0 = List.replicate (fromIntegral rr) (q+1)
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
|| wordCount <= 1
then joinLinePlainChunk line
else
padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
joinLinePlainChunk :: Monoid d => Spaceable d => [PlainChunk d] -> d
joinLinePlainChunk = mconcat . (runPlainChunk <$>)
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