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