Symantic/Document/Plain.hs

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