Symantic/Document/Plain.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE UndecidableInstances #-}
   4 module Symantic.Document.Plain where
   5
   6 import Data.Bool
   7 import Data.Char (Char)
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($), (.), id)
  10 import Data.Functor ((<$>))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Monoid (Monoid(..))
  13 import Data.Ord (Ord(..), Ordering(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.String (String, IsString(..))
  16 import Data.Text (Text)
  17 import Data.Tuple (snd)
  18 import GHC.Natural (minusNatural,quotRemNatural)
  19 import Numeric.Natural (Natural)
  20 import Prelude (fromIntegral, Num(..), pred)
  21 import System.Console.ANSI
  22 import Text.Show (Show(..), showString, showParen)
  23 import qualified Data.Foldable as Fold
  24 import qualified Data.List as List
  25 import qualified Data.Text.Lazy as TL
  26
  27 import Symantic.Document.API
  28
  29 -- * Type 'Plain'
  30 -- | Church encoded for performance concerns.
  31 -- Kind like 'ParsecT' in @megaparsec@ but a little bit different
  32 -- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly
  33 -- when in the left hand side of ('<>').
  34 -- Prepending is done using continuation, like in a difference list.
  35 newtype Plain d = Plain
  36  { unPlain ::
  37      {-curr-}PlainInh ->
  38      {-curr-}PlainState d ->
  39      {-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) ->
  40      PlainFit d
  41      -- NOTE: equivalent to:
  42      -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
  43  }
  44 instance (Show d, Monoid d) => Show (Plain d) where
  45         show = show . runPlain
  46
  47 runPlain :: Monoid d => Plain d -> d
  48 runPlain x =
  49         unPlain x
  50          defPlainInh
  51          defPlainState
  52          {-k-}(\(px,_sx) fits _overflow ->
  53                 -- NOTE: if px fits, then appending mempty fits
  54                 fits (px mempty) )
  55          {-fits-}id
  56          {-overflow-}id
  57
  58 -- ** Type 'PlainState'
  59 data PlainState d = PlainState
  60  { plainState_buffer          :: ![PlainChunk d]
  61  , plainState_bufferStart     :: !Column
  62    -- ^ The 'Column' from which the 'plainState_buffer'
  63    -- must be written.
  64  , plainState_bufferWidth     :: !Width
  65    -- ^ The 'Width' of the 'plainState_buffer' so far.
  66  , plainState_removableIndent :: !Indent
  67    -- ^ The amount of 'Indent' added by 'breakspace'
  68    -- that can be removed by breaking the 'space' into a 'newline'.
  69  } deriving (Show)
  70
  71 defPlainState :: PlainState d
  72 defPlainState = PlainState
  73  { plainState_buffer          = mempty
  74  , plainState_bufferStart     = 0
  75  , plainState_bufferWidth     = 0
  76  , plainState_removableIndent = 0
  77  }
  78
  79 -- ** Type 'PlainInh'
  80 data PlainInh = PlainInh
  81  { plainInh_width   :: !(Maybe Column)
  82  , plainInh_justify :: !Bool
  83  , plainInh_indent  :: !Width
  84  } deriving (Show)
  85
  86 defPlainInh :: PlainInh
  87 defPlainInh = PlainInh
  88  { plainInh_width   = Nothing
  89  , plainInh_justify = False
  90  , plainInh_indent  = 0
  91  }
  92
  93 -- ** Type 'PlainFit'
  94 -- | Double continuation to qualify the returned document
  95 -- as fitting or overflowing the given 'plainInh_width'.
  96 -- It's like @('Bool',d)@ in a normal style
  97 -- (a non continuation-passing-style).
  98 type PlainFit d = {-fits-}(d -> d) ->
  99                   {-overflow-}(d -> d) ->
 100                   d
 101
 102 -- ** Type 'PlainChunk'
 103 data PlainChunk d
 104  =   PlainChunk_Ignored d
 105      -- ^ Ignored by the justification but kept in place.
 106      -- Used for instance to put ANSI sequences.
 107  |   PlainChunk_Word (Word d)
 108  |   PlainChunk_Spaces Width
 109      -- ^ 'spaces' preserved to be interleaved
 110      -- correctly with 'PlainChunk_Ignored'.
 111 instance Show d => Show (PlainChunk d) where
 112         showsPrec p x =
 113                 showParen (p>10) $
 114                 case x of
 115                  PlainChunk_Ignored d ->
 116                         showString "Z " .
 117                         showsPrec 11 d
 118                  PlainChunk_Word (Word d) ->
 119                         showString "W " .
 120                         showsPrec 11 d
 121                  PlainChunk_Spaces s ->
 122                         showString "S " .
 123                         showsPrec 11 s
 124 instance Lengthable d => Lengthable (PlainChunk d) where
 125         width = \case
 126          PlainChunk_Ignored{} -> 0
 127          PlainChunk_Word d -> width d
 128          PlainChunk_Spaces s -> s
 129         nullWidth = \case
 130          PlainChunk_Ignored{} -> True
 131          PlainChunk_Word d -> nullWidth d
 132          PlainChunk_Spaces s -> s == 0
 133 instance From [SGR] d => From [SGR] (PlainChunk d) where
 134         from sgr = PlainChunk_Ignored (from sgr)
 135
 136 runPlainChunk :: Spaceable d => PlainChunk d -> d
 137 runPlainChunk = \case
 138  PlainChunk_Ignored d -> d
 139  PlainChunk_Word (Word d) -> d
 140  PlainChunk_Spaces s -> spaces s
 141
 142 instance Semigroup d => Semigroup (Plain d) where
 143         Plain x <> Plain y = Plain $ \inh st k ->
 144                 x inh st $ \(px,sx) ->
 145                         y inh sx $ \(py,sy) ->
 146                                 k (px.py,sy)
 147 instance Monoid d => Monoid (Plain d) where
 148         mempty = Plain $ \_inh st k -> k (id,st)
 149         mappend = (<>)
 150 instance Spaceable d => Spaceable (Plain d) where
 151         newline = Plain $ \inh st k ->
 152                 k(\next ->
 153                         (if plainInh_justify inh then joinLine inh st else mempty) <>
 154                         newline<>spaces (plainInh_indent inh)<>next
 155                  , st
 156                          { plainState_bufferStart      = plainInh_indent inh
 157                          , plainState_bufferWidth      = 0
 158                          , plainState_buffer           = mempty
 159                          }
 160                  )
 161         space = spaces 1
 162         spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
 163                 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
 164                 if plainInh_justify inh
 165                 then
 166                         let newState =
 167                                 case plainState_buffer of
 168                                  PlainChunk_Spaces s:bs -> st
 169                                          { plainState_buffer      = PlainChunk_Spaces (s+n):bs
 170                                          }
 171                                  _ -> st
 172                                          { plainState_buffer      = PlainChunk_Spaces n:plainState_buffer
 173                                          , plainState_bufferWidth = plainState_bufferWidth + 1
 174                                          }
 175                         in
 176                         case plainInh_width inh of
 177                          Just maxWidth | maxWidth < newWidth ->
 178                                 overflow $ k (id{-(d<>)-}, newState) fits overflow
 179                          _ -> k (id{-(d<>)-}, newState) fits overflow
 180                 else
 181                         let newState = st
 182                                  { plainState_bufferWidth = plainState_bufferWidth + n
 183                                  } in
 184                         case plainInh_width inh of
 185                          Just maxWidth | maxWidth < newWidth ->
 186                                 overflow $ k ((spaces n <>), newState) fits fits
 187                          _ -> k ((spaces n <>), newState) fits overflow
 188 instance (From (Word s) d, Semigroup d, Lengthable s) =>
 189          From (Word s) (Plain d) where
 190         from s = Plain $ \inh st@PlainState{..} k fits overflow ->
 191                 let wordWidth = width s in
 192                 if wordWidth <= 0
 193                 then k (id,st) fits overflow
 194                 else
 195                         let newBufferWidth = plainState_bufferWidth + wordWidth in
 196                         let newWidth = plainState_bufferStart + newBufferWidth in
 197                         if plainInh_justify inh
 198                         then
 199                                 let newState = st
 200                                          { plainState_buffer =
 201                                                 PlainChunk_Word (Word (from s)) :
 202                                                 plainState_buffer
 203                                          , plainState_bufferWidth = newBufferWidth
 204                                          } in
 205                                 case plainInh_width inh of
 206                                  Just maxWidth | maxWidth < newWidth ->
 207                                         overflow $ k (id, newState) fits overflow
 208                                  _ -> k (id, newState) fits overflow
 209                         else
 210                                 let newState = st
 211                                          { plainState_bufferWidth = newBufferWidth
 212                                          } in
 213                                 case plainInh_width inh of
 214                                  Just maxWidth | maxWidth < newWidth ->
 215                                         overflow $ k ((from s <>), newState) fits fits
 216                                  _ -> k ((from s <>), newState) fits overflow
 217 instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
 218          From (Line s) (Plain d) where
 219         from =
 220                 mconcat .
 221                 List.intersperse breakspace .
 222                 (from <$>) .
 223                 words .
 224                 unLine
 225 instance Spaceable d => Indentable (Plain d) where
 226         align p = (flushLine <>) $ Plain $ \inh st ->
 227                 let currInd = plainState_bufferStart st + plainState_bufferWidth st in
 228                 unPlain p inh{plainInh_indent=currInd} st
 229         incrIndent i p = Plain $ \inh ->
 230                 unPlain p inh{plainInh_indent = plainInh_indent inh + i}
 231         setIndent i p = Plain $ \inh ->
 232                 unPlain p inh{plainInh_indent=i}
 233         fill m p = Plain $ \inh0 st0 ->
 234                 let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
 235                 let p1 = Plain $ \inh1 st1 ->
 236                         let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
 237                         let w | col0 <= col1 = col1`minusNatural`col0
 238                               | otherwise    = col0`minusNatural`col1 in
 239                         unPlain
 240                          (if w<=m
 241                                 then spaces (m`minusNatural`w)
 242                                 else mempty)
 243                          inh1 st1
 244                 in
 245                 unPlain (p <> p1) inh0 st0
 246         breakfill m p = Plain $ \inh0 st0 ->
 247                 let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
 248                 let p1 = Plain $ \inh1 st1 ->
 249                         let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
 250                         let w | col0 <= col1 = col1`minusNatural`col0
 251                               | otherwise    = col0`minusNatural`col1 in
 252                         unPlain
 253                          (case w`compare`m of
 254                                  LT -> spaces (m`minusNatural`w)
 255                                  EQ -> mempty
 256                                  GT -> setIndent (col0 + m) newline)
 257                          inh1 st1
 258                 in
 259                 unPlain (p <> p1) inh0 st0
 260 instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
 261         ul ds =
 262                 catV $
 263                         (<$> ds) $ \d ->
 264                                 from (Word '-')<>space<>flushLine<>align d<>flushLine
 265         ol ds =
 266                 catV $ snd $
 267                         Fold.foldr
 268                          (\d (i, acc) ->
 269                                 (pred i, (from i<>from (Word '.')<>space<>flushLine<>align d<>flushLine) : acc)
 270                          ) (Fold.length ds, []) ds
 271 instance Spaceable d => Justifiable (Plain d) where
 272         justify p = (\x -> flushLine <> x <> flushLine) $ Plain $ \inh ->
 273                 unPlain p inh{plainInh_justify=True}
 274
 275 -- | Commit 'plainState_buffer' upto there, so that it won't be justified.
 276 flushLine :: Spaceable d => Plain d
 277 flushLine = Plain $ \_inh st ok ->
 278         ok
 279          ( (joinPlainLine (collapseSpaces <$> List.reverse (plainState_buffer st)) <>)
 280          , st
 281                  { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
 282                  , plainState_bufferWidth = 0
 283                  , plainState_buffer      = mempty
 284                  }
 285          )
 286
 287 collapseSpaces :: PlainChunk d -> PlainChunk d
 288 collapseSpaces = \case
 289  PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
 290  x -> x
 291
 292 instance Spaceable d => Wrappable (Plain d) where
 293         setWidth w p = Plain $ \inh ->
 294                 unPlain p inh{plainInh_width=w}
 295         breakpoint = Plain $ \inh st k fits overflow ->
 296                 let newlineInd = plainInh_indent inh in
 297                 k
 298                  ( id
 299                  , st
 300                          { plainState_removableIndent = newlineInd
 301                          }
 302                  )
 303                  fits
 304                  {-overflow-}(\_r ->
 305                         unPlain newline inh st k
 306                          fits
 307                          {-overflow-}(
 308                                 if plainState_removableIndent st < newlineInd
 309                                 then overflow
 310                                 else fits
 311                          )
 312                  )
 313         breakspace = Plain $ \inh st k fits overflow ->
 314                 let newlineInd = plainInh_indent inh in
 315                 k
 316                  ( if plainInh_justify inh then id else (space <>)
 317                  , st
 318                          { plainState_buffer =
 319                                 if plainInh_justify inh
 320                                 then case plainState_buffer st of
 321                                          PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
 322                                          bs -> PlainChunk_Spaces 1:bs
 323                                 else plainState_buffer st
 324                          , plainState_bufferWidth      = plainState_bufferWidth st + 1
 325                          , plainState_removableIndent  = newlineInd
 326                          }
 327                  )
 328                  fits
 329                  {-overflow-}(\_r ->
 330                         unPlain newline inh st k
 331                          fits
 332                          {-overflow-}(
 333                                 if plainState_removableIndent st < newlineInd
 334                                 then overflow
 335                                 else fits
 336                          )
 337                  )
 338         breakalt x y = Plain $ \inh st k fits overflow ->
 339                 unPlain x inh st k fits
 340                  {-overflow-}(\_r ->
 341                         unPlain y inh st k fits overflow
 342                  )
 343 -- String
 344 instance (From (Word String) d, Spaceable d) =>
 345          From String (Plain d) where
 346         from =
 347                 mconcat .
 348                 List.intersperse newline .
 349                 (from <$>) .
 350                 lines
 351 instance (From (Word String) d, Spaceable d) =>
 352          IsString (Plain d) where
 353         fromString = from
 354 -- Text
 355 instance (From (Word Text) d, Spaceable d) =>
 356          From Text (Plain d) where
 357         from =
 358                 mconcat .
 359                 List.intersperse newline .
 360                 (from <$>) .
 361                 lines
 362 instance (From (Word TL.Text) d, Spaceable d) =>
 363          From TL.Text (Plain d) where
 364         from =
 365                 mconcat .
 366                 List.intersperse newline .
 367                 (from <$>) .
 368                 lines
 369 -- Char
 370 instance (From (Word Char) d, Spaceable d) =>
 371          From Char (Plain d) where
 372         from ' '  = breakspace
 373         from '\n' = newline
 374         from c    = from (Word c)
 375
 376
 377 instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
 378         from sgr = Plain $ \inh st k ->
 379                 if plainInh_justify inh
 380                 then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
 381                 else k ((from sgr <>), st)
 382
 383 joinLine ::
 384  Spaceable d =>
 385  PlainInh -> PlainState d -> d
 386 joinLine PlainInh{..} PlainState{..} =
 387         case plainInh_width of
 388          Nothing -> joinPlainLine $ List.reverse plainState_buffer
 389          Just maxWidth ->
 390                 if maxWidth < plainState_bufferStart
 391                 || maxWidth < plainInh_indent
 392                 then joinPlainLine $ List.reverse plainState_buffer
 393                 else
 394                         let superfluousSpaces = Fold.foldr
 395                                  (\c acc ->
 396                                         acc + case c of
 397                                          PlainChunk_Ignored{} -> 0
 398                                          PlainChunk_Word{} -> 0
 399                                          PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
 400                                  0 plainState_buffer in
 401                         let minBufferWidth =
 402                                 -- NOTE: cap the spaces at 1,
 403                                 -- to let justifyWidth decide where to add spaces.
 404                                 plainState_bufferWidth`minusNatural`superfluousSpaces in
 405                         let justifyWidth =
 406                                 -- NOTE: when minBufferWidth is not breakable,
 407                                 -- the width of justification can be wider than
 408                                 -- what remains to reach maxWidth.
 409                                 max minBufferWidth $
 410                                         maxWidth`minusNatural`plainState_bufferStart
 411                         in
 412                         let wordCount = countWords plainState_buffer in
 413                         unLine $ padPlainLineInits justifyWidth $
 414                          (minBufferWidth,wordCount,List.reverse plainState_buffer)
 415
 416 -- | @('countWords' ps)@ returns the number of words in @(ps)@
 417 -- clearly separated by spaces.
 418 countWords :: [PlainChunk d] -> Natural
 419 countWords = go False 0
 420  where
 421         go inWord acc = \case
 422          [] -> acc
 423          PlainChunk_Word{}:xs ->
 424                 if inWord
 425                 then go inWord acc xs
 426                 else go True (acc+1) xs
 427          PlainChunk_Spaces s:xs
 428           | s == 0    -> go inWord acc xs
 429           | otherwise -> go False acc xs
 430          PlainChunk_Ignored{}:xs -> go inWord acc xs
 431
 432 -- | @('justifyPadding' a b)@ returns the padding lengths
 433 -- to reach @(a)@ in @(b)@ pads,
 434 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
 435 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
 436 --
 437 -- A simple implementation of 'justifyPadding' could be:
 438 -- @
 439 -- 'justifyPadding' a b =
 440 --   'join' ('List.replicate' m [q,q'+'1])
 441 --   <> ('List.replicate' (r'-'m) (q'+'1)
 442 --   <> ('List.replicate' ((b'-'r)'-'m) q
 443 --   where
 444 --   (q,r) = a`divMod`b
 445 --   m = 'min' (b-r) r
 446 -- @
 447 justifyPadding :: Natural -> Natural -> [Natural]
 448 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
 449         where
 450         (q,r) = a`quotRemNatural`b
 451
 452         go 0  bmr = List.replicate (fromIntegral bmr) q    -- when min (b-r) r == b-r
 453         go rr 0   = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
 454         go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
 455
 456 padPlainLineInits ::
 457  Spaceable d =>
 458  Width -> (Natural, Natural, [PlainChunk d]) -> Line d
 459 padPlainLineInits maxWidth (lineWidth,wordCount,line) = Line $
 460         if maxWidth <= lineWidth
 461                 -- The gathered line reached or overreached the maxWidth,
 462                 -- hence no padding id needed.
 463         || wordCount <= 1
 464                 -- The case maxWidth <= lineWidth && wordCount == 1
 465                 -- can happen if first word's length is < maxWidth
 466                 -- but second word's len is >= maxWidth.
 467         then joinPlainLine line
 468         else
 469                 -- Share the missing spaces as evenly as possible
 470                 -- between the words of the line.
 471                 padPlainLine line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
 472
 473 -- | Just concat 'PlainChunk's with no justification.
 474 joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
 475 joinPlainLine = mconcat . (runPlainChunk <$>)
 476
 477 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
 478 padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
 479 padPlainLine = go
 480         where
 481         go (w:ws) lls@(l:ls) =
 482                 case w of
 483                  PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls
 484                  _ -> runPlainChunk w <> go ws lls
 485         go (w:ws) [] = runPlainChunk w <> go ws []
 486         go [] _ls = mempty