Symantic/Document/Plain.hs

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