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 'newlineJustifying'.
  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         -- | The default 'newline' does not justify
 152         -- 'plainState_buffer', for that use 'newlineJustifying'.
 153         newline = Plain $ \inh st k ->
 154                 k(\next ->
 155                         (if plainInh_justify inh
 156                                 then joinPlainLine $ List.reverse $ plainState_buffer st
 157                                 else mempty) <>
 158                         newline<>spaces (plainInh_indent inh)<>next
 159                  , st
 160                          { plainState_bufferStart = plainInh_indent inh
 161                          , plainState_bufferWidth = 0
 162                          , plainState_buffer      = mempty
 163                          }
 164                  )
 165         space = spaces 1
 166         spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
 167                 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
 168                 if plainInh_justify inh
 169                 then
 170                         let newState =
 171                                 case plainState_buffer of
 172                                  PlainChunk_Spaces s:bs -> st
 173                                          { plainState_buffer      = PlainChunk_Spaces (s+n):bs
 174                                          }
 175                                  _ -> st
 176                                          { plainState_buffer      = PlainChunk_Spaces n:plainState_buffer
 177                                          , plainState_bufferWidth = plainState_bufferWidth + 1
 178                                          }
 179                         in
 180                         case plainInh_width inh of
 181                          Just maxWidth | maxWidth < newWidth ->
 182                                 overflow $ k (id{-(d<>)-}, newState) fits overflow
 183                          _ -> k (id{-(d<>)-}, newState) fits overflow
 184                 else
 185                         let newState = st
 186                                  { plainState_bufferWidth = plainState_bufferWidth + n
 187                                  } in
 188                         case plainInh_width inh of
 189                          Just maxWidth | maxWidth < newWidth ->
 190                                 overflow $ k ((spaces n <>), newState) fits fits
 191                          _ -> k ((spaces n <>), newState) fits overflow
 192 instance (From (Word s) d, Semigroup d, Lengthable s) =>
 193          From (Word s) (Plain d) where
 194         from s = Plain $ \inh st@PlainState{..} k fits overflow ->
 195                 let wordWidth = width s in
 196                 if wordWidth <= 0
 197                 then k (id,st) fits overflow
 198                 else
 199                         let newBufferWidth = plainState_bufferWidth + wordWidth in
 200                         let newWidth = plainState_bufferStart + newBufferWidth in
 201                         if plainInh_justify inh
 202                         then
 203                                 let newState = st
 204                                          { plainState_buffer =
 205                                                 PlainChunk_Word (Word (from s)) :
 206                                                 plainState_buffer
 207                                          , plainState_bufferWidth = newBufferWidth
 208                                          } in
 209                                 case plainInh_width inh of
 210                                  Just maxWidth | maxWidth < newWidth ->
 211                                         overflow $ k (id, newState) fits overflow
 212                                  _ -> k (id, newState) fits overflow
 213                         else
 214                                 let newState = st
 215                                          { plainState_bufferWidth = newBufferWidth
 216                                          } in
 217                                 case plainInh_width inh of
 218                                  Just maxWidth | maxWidth < newWidth ->
 219                                         overflow $ k ((from s <>), newState) fits fits
 220                                  _ -> k ((from s <>), newState) fits overflow
 221 instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
 222          From (Line s) (Plain d) where
 223         from =
 224                 mconcat .
 225                 List.intersperse breakspace .
 226                 (from <$>) .
 227                 words .
 228                 unLine
 229 instance Spaceable d => Indentable (Plain d) where
 230         align p = (flushLine <>) $ Plain $ \inh st ->
 231                 let currInd = plainState_bufferStart st + plainState_bufferWidth st in
 232                 unPlain p inh{plainInh_indent=currInd} st
 233         incrIndent i p = Plain $ \inh ->
 234                 unPlain p inh{plainInh_indent = plainInh_indent inh + i}
 235         setIndent i p = Plain $ \inh ->
 236                 unPlain p inh{plainInh_indent=i}
 237         fill m p = Plain $ \inh0 st0 ->
 238                 let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
 239                 let p1 = Plain $ \inh1 st1 ->
 240                         let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
 241                         let w | col0 <= col1 = col1`minusNatural`col0
 242                               | otherwise    = col0`minusNatural`col1 in
 243                         unPlain
 244                          (if w<=m
 245                                 then spaces (m`minusNatural`w)
 246                                 else mempty)
 247                          inh1 st1
 248                 in
 249                 unPlain (p <> p1) inh0 st0
 250         breakfill m p = Plain $ \inh0 st0 ->
 251                 let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
 252                 let p1 = Plain $ \inh1 st1 ->
 253                         let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
 254                         let w | col0 <= col1 = col1`minusNatural`col0
 255                               | otherwise    = col0`minusNatural`col1 in
 256                         unPlain
 257                          (case w`compare`m of
 258                                  LT -> spaces (m`minusNatural`w)
 259                                  EQ -> mempty
 260                                  GT -> setIndent (col0 + m) newline)
 261                          inh1 st1
 262                 in
 263                 unPlain (p <> p1) inh0 st0
 264 instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
 265         ul ds =
 266                 catV $
 267                         (<$> ds) $ \d ->
 268                                 from (Word '-')<>space<>flushLine<>align d<>flushLine
 269         ol ds =
 270                 catV $ snd $
 271                         Fold.foldr
 272                          (\d (i, acc) ->
 273                                 (pred i, (from i<>from (Word '.')<>space<>flushLine<>align d<>flushLine) : acc)
 274                          ) (Fold.length ds, []) ds
 275 instance Spaceable d => Justifiable (Plain d) where
 276         justify p = (\x -> flushLine <> x <> flushLine) $ Plain $ \inh ->
 277                 unPlain p inh{plainInh_justify=True}
 278
 279 -- | Commit 'plainState_buffer' upto there, so that it won't be justified.
 280 flushLine :: Spaceable d => Plain d
 281 flushLine = Plain $ \_inh st k ->
 282         k( (joinPlainLine (collapseSpaces <$> List.reverse (plainState_buffer st)) <>)
 283          , st
 284                  { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
 285                  , plainState_bufferWidth = 0
 286                  , plainState_buffer      = mempty
 287                  }
 288          )
 289
 290 collapseSpaces :: PlainChunk d -> PlainChunk d
 291 collapseSpaces = \case
 292  PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
 293  x -> x
 294
 295 instance Spaceable d => Wrappable (Plain d) where
 296         setWidth w p = Plain $ \inh ->
 297                 unPlain p inh{plainInh_width=w}
 298         breakpoint = Plain $ \inh st k fits overflow ->
 299                 let newlineInd = plainInh_indent inh in
 300                 k
 301                  ( id
 302                  , st
 303                          { plainState_removableIndent = newlineInd
 304                          }
 305                  )
 306                  fits
 307                  {-overflow-}(\_r ->
 308                         unPlain newlineJustifying inh st k
 309                          fits
 310                          {-overflow-}(
 311                                 if plainState_removableIndent st < newlineInd
 312                                 then overflow
 313                                 else fits
 314                          )
 315                  )
 316         breakspace = Plain $ \inh st k fits overflow ->
 317                 let newlineInd = plainInh_indent inh in
 318                 k
 319                  ( if plainInh_justify inh then id else (space <>)
 320                  , st
 321                          { plainState_buffer =
 322                                 if plainInh_justify inh
 323                                 then case plainState_buffer st of
 324                                          PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
 325                                          bs -> PlainChunk_Spaces 1:bs
 326                                 else plainState_buffer st
 327                          , plainState_bufferWidth      = plainState_bufferWidth st + 1
 328                          , plainState_removableIndent  = newlineInd
 329                          }
 330                  )
 331                  fits
 332                  {-overflow-}(\_r ->
 333                         unPlain newlineJustifying inh st k
 334                          fits
 335                          {-overflow-}(
 336                                 if plainState_removableIndent st < newlineInd
 337                                 then overflow
 338                                 else fits
 339                          )
 340                  )
 341         breakalt x y = Plain $ \inh st k fits overflow ->
 342                 unPlain x inh st k fits
 343                  {-overflow-}(\_r ->
 344                         unPlain y inh st k fits overflow
 345                  )
 346
 347 -- | Like 'newline', but justify 'plainState_buffer' before.
 348 newlineJustifying :: Spaceable d => Plain d
 349 newlineJustifying = Plain $ \inh st k ->
 350         k(\next ->
 351                 (if plainInh_justify inh then joinLine inh st else mempty) <>
 352                 newline<>spaces (plainInh_indent inh)<>next
 353          , st
 354                  { plainState_bufferStart = plainInh_indent inh
 355                  , plainState_bufferWidth = 0
 356                  , plainState_buffer      = mempty
 357                  }
 358          )
 359
 360 -- String
 361 instance (From (Word String) d, Spaceable d) =>
 362          From String (Plain d) where
 363         from =
 364                 mconcat .
 365                 List.intersperse newline .
 366                 (from <$>) .
 367                 lines
 368 instance (From (Word String) d, Spaceable d) =>
 369          IsString (Plain d) where
 370         fromString = from
 371 -- Text
 372 instance (From (Word Text) d, Spaceable d) =>
 373          From Text (Plain d) where
 374         from =
 375                 mconcat .
 376                 List.intersperse newline .
 377                 (from <$>) .
 378                 lines
 379 instance (From (Word TL.Text) d, Spaceable d) =>
 380          From TL.Text (Plain d) where
 381         from =
 382                 mconcat .
 383                 List.intersperse newline .
 384                 (from <$>) .
 385                 lines
 386 -- Char
 387 instance (From (Word Char) d, Spaceable d) =>
 388          From Char (Plain d) where
 389         from ' '  = breakspace
 390         from '\n' = newline
 391         from c    = from (Word c)
 392
 393
 394 instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
 395         from sgr = Plain $ \inh st k ->
 396                 if plainInh_justify inh
 397                 then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
 398                 else k ((from sgr <>), st)
 399
 400 joinLine ::
 401  Spaceable d =>
 402  PlainInh -> PlainState d -> d
 403 joinLine PlainInh{..} PlainState{..} =
 404         case plainInh_width of
 405          Nothing -> joinPlainLine $ List.reverse plainState_buffer
 406          Just maxWidth ->
 407                 if maxWidth < plainState_bufferStart
 408                 || maxWidth < plainInh_indent
 409                 then joinPlainLine $ List.reverse plainState_buffer
 410                 else
 411                         let superfluousSpaces = Fold.foldr
 412                                  (\c acc ->
 413                                         acc + case c of
 414                                          PlainChunk_Ignored{} -> 0
 415                                          PlainChunk_Word{} -> 0
 416                                          PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
 417                                  0 plainState_buffer in
 418                         let minBufferWidth =
 419                                 -- NOTE: cap the spaces at 1,
 420                                 -- to let justifyWidth decide where to add spaces.
 421                                 plainState_bufferWidth`minusNatural`superfluousSpaces in
 422                         let justifyWidth =
 423                                 -- NOTE: when minBufferWidth is not breakable,
 424                                 -- the width of justification can be wider than
 425                                 -- what remains to reach maxWidth.
 426                                 max minBufferWidth $
 427                                         maxWidth`minusNatural`plainState_bufferStart
 428                         in
 429                         let wordCount = countWords plainState_buffer in
 430                         unLine $ padPlainLineInits justifyWidth $
 431                          (minBufferWidth,wordCount,List.reverse plainState_buffer)
 432
 433 -- | @('countWords' ps)@ returns the number of words in @(ps)@
 434 -- clearly separated by spaces.
 435 countWords :: [PlainChunk d] -> Natural
 436 countWords = go False 0
 437  where
 438         go inWord acc = \case
 439          [] -> acc
 440          PlainChunk_Word{}:xs ->
 441                 if inWord
 442                 then go inWord acc xs
 443                 else go True (acc+1) xs
 444          PlainChunk_Spaces s:xs
 445           | s == 0    -> go inWord acc xs
 446           | otherwise -> go False acc xs
 447          PlainChunk_Ignored{}:xs -> go inWord acc xs
 448
 449 -- | @('justifyPadding' a b)@ returns the padding lengths
 450 -- to reach @(a)@ in @(b)@ pads,
 451 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
 452 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
 453 --
 454 -- A simple implementation of 'justifyPadding' could be:
 455 -- @
 456 -- 'justifyPadding' a b =
 457 --   'join' ('List.replicate' m [q,q'+'1])
 458 --   <> ('List.replicate' (r'-'m) (q'+'1)
 459 --   <> ('List.replicate' ((b'-'r)'-'m) q
 460 --   where
 461 --   (q,r) = a`divMod`b
 462 --   m = 'min' (b-r) r
 463 -- @
 464 justifyPadding :: Natural -> Natural -> [Natural]
 465 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
 466         where
 467         (q,r) = a`quotRemNatural`b
 468
 469         go 0  bmr = List.replicate (fromIntegral bmr) q    -- when min (b-r) r == b-r
 470         go rr 0   = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
 471         go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
 472
 473 padPlainLineInits ::
 474  Spaceable d =>
 475  Width -> (Natural, Natural, [PlainChunk d]) -> Line d
 476 padPlainLineInits maxWidth (lineWidth,wordCount,line) = Line $
 477         if maxWidth <= lineWidth
 478                 -- The gathered line reached or overreached the maxWidth,
 479                 -- hence no padding id needed.
 480         || wordCount <= 1
 481                 -- The case maxWidth <= lineWidth && wordCount == 1
 482                 -- can happen if first word's length is < maxWidth
 483                 -- but second word's len is >= maxWidth.
 484         then joinPlainLine line
 485         else
 486                 -- Share the missing spaces as evenly as possible
 487                 -- between the words of the line.
 488                 padPlainLine line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
 489
 490 -- | Just concat 'PlainChunk's with no justification.
 491 joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
 492 joinPlainLine = mconcat . (runPlainChunk <$>)
 493
 494 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
 495 padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
 496 padPlainLine = go
 497         where
 498         go (w:ws) lls@(l:ls) =
 499                 case w of
 500                  PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls
 501                  _ -> runPlainChunk w <> go ws lls
 502         go (w:ws) [] = runPlainChunk w <> go ws []
 503         go [] _ls = mempty