content: {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable,
      GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric,
      DeriveTraversable, OverloadedStrings, PatternGuards #-}
  
  {-
  Copyright (C) 2010-2023 John MacFarlane
  
  All rights reserved.
  
  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions are met:
  
      * Redistributions of source code must retain the above copyright
        notice, this list of conditions and the following disclaimer.
  
      * Redistributions in binary form must reproduce the above
        copyright notice, this list of conditions and the following
        disclaimer in the documentation and/or other materials provided
        with the distribution.
  
      * Neither the name of John MacFarlane nor the names of other
        contributors may be used to endorse or promote products derived
        from this software without specific prior written permission.
  
  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
  THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  -}
  
  {- |
     Module      : Text.Pandoc.Builder
     Copyright   : Copyright (C) 2010-2023 John MacFarlane
     License     : BSD3
  
     Maintainer  : John MacFarlane <jgm@berkeley.edu>
     Stability   : alpha
     Portability : portable
  
  Convenience functions for building pandoc documents programmatically.
  
  Example of use (with @OverloadedStrings@ pragma):
  
  > import Text.Pandoc.Builder
  >
  > myDoc :: Pandoc
  > myDoc = setTitle "My title" $ doc $
  >   para "This is the first paragraph" <>
  >   para ("And " <> emph "another" <> ".") <>
  >   bulletList [ para "item one" <> para "continuation"
  >              , plain ("item two and a " <>
  >                  link "/url" "go to url" "link")
  >              ]
  
  Isn't that nicer than writing the following?
  
  > import Text.Pandoc.Definition
  > import Data.Map (fromList)
  >
  > myDoc :: Pandoc
  > myDoc = Pandoc (Meta {unMeta = fromList [("title",
  >           MetaInlines [Str "My",Space,Str "title"])]})
  >         [Para [Str "This",Space,Str "is",Space,Str "the",Space,Str "first",
  >          Space,Str "paragraph"],Para [Str "And",Space,Emph [Str "another"],
  >          Str "."]
  >         ,BulletList [
  >           [Para [Str "item",Space,Str "one"]
  >           ,Para [Str "continuation"]]
  >          ,[Plain [Str "item",Space,Str "two",Space,Str "and",Space,
  >                   Str "a",Space,Link nullAttr [Str "link"] ("/url","go to url")]]]]
  
  And of course, you can use Haskell to define your own builders:
  
  > import Text.Pandoc.Builder
  > import Text.JSON
  > import Control.Arrow ((***))
  > import Data.Monoid (mempty)
  >
  > -- | Converts a JSON document into 'Blocks'.
  > json :: String -> Blocks
  > json x =
  >   case decode x of
  >        Ok y    -> jsValueToBlocks y
  >        Error y -> error y
  >    where jsValueToBlocks x =
  >           case x of
  >            JSNull         -> mempty
  >            JSBool x       -> plain $ text $ show x
  >            JSRational _ x -> plain $ text $ show x
  >            JSString x     -> plain $ text $ fromJSString x
  >            JSArray xs     -> bulletList $ map jsValueToBlocks xs
  >            JSObject x     -> definitionList $
  >                               map (text *** (:[]) . jsValueToBlocks) $
  >                               fromJSObject x
  
  -}
  
  module Text.Pandoc.Builder ( module Text.Pandoc.Definition
                             , Many(..)
                             , Inlines
                             , Blocks
                             , (<>)
                             , singleton
                             , toList
                             , fromList
                             , isNull
                             -- * Document builders
                             , doc
                             , ToMetaValue(..)
                             , HasMeta(..)
                             , setTitle
                             , setAuthors
                             , setDate
                             -- * Inline list builders
                             , text
                             , str
                             , emph
                             , underline
                             , strong
                             , strikeout
                             , superscript
                             , subscript
                             , smallcaps
                             , singleQuoted
                             , doubleQuoted
                             , cite
                             , codeWith
                             , code
                             , space
                             , softbreak
                             , linebreak
                             , math
                             , displayMath
                             , rawInline
                             , link
                             , linkWith
                             , image
                             , imageWith
                             , note
                             , spanWith
                             , trimInlines
                             -- * Block list builders
                             , para
                             , plain
                             , lineBlock
                             , codeBlockWith
                             , codeBlock
                             , rawBlock
                             , blockQuote
                             , bulletList
                             , orderedListWith
                             , orderedList
                             , definitionList
                             , header
                             , headerWith
                             , horizontalRule
                             , cell
                             , simpleCell
                             , emptyCell
                             , cellWith
                             , table
                             , simpleTable
                             , tableWith
                             , figure
                             , figureWith
                             , caption
                             , simpleCaption
                             , emptyCaption
                             , simpleFigureWith
                             , simpleFigure
                             , divWith
                             -- * Table processing
                             , normalizeTableHead
                             , normalizeTableBody
                             , normalizeTableFoot
                             , placeRowSection
                             , clipRows
                             )
  where
  import Text.Pandoc.Definition
  import Data.String
  import qualified Data.Map as M
  import Data.Text (Text)
  import qualified Data.Text as T
  import Data.Sequence (Seq, (|>), viewr, viewl, ViewR(..), ViewL(..))
  import qualified Data.Sequence as Seq
  import Data.Traversable (Traversable)
  import Data.Foldable (Foldable)
  import qualified Data.Foldable as F
  import Data.Data
  import Control.Arrow ((***))
  import GHC.Generics (Generic)
  import Data.Semigroup (Semigroup(..))
  
  newtype Many a = Many { unMany :: Seq a }
                   deriving (Data, Ord, Eq, Typeable, Foldable, Traversable, Functor, Show, Read)
  
  deriving instance Generic (Many a)
  
  toList :: Many a -> [a]
  toList = F.toList
  
  singleton :: a -> Many a
  singleton = Many . Seq.singleton
  
  fromList :: [a] -> Many a
  fromList = Many . Seq.fromList
  
  {-# DEPRECATED isNull "Use null instead" #-}
  isNull :: Many a -> Bool
  isNull = Seq.null . unMany
  
  type Inlines = Many Inline
  type Blocks  = Many Block
  
  deriving instance Semigroup Blocks
  deriving instance Monoid Blocks
  
  instance Semigroup Inlines where
    (Many xs) <> (Many ys) =
      case (viewr xs, viewl ys) of
        (EmptyR, _) -> Many ys
        (_, EmptyL) -> Many xs
        (xs' :> x, y :< ys') -> Many (meld <> ys')
          where meld = case (x, y) of
                            (Space, Space)     -> xs' |> Space
                            (Space, SoftBreak) -> xs' |> SoftBreak
                            (SoftBreak, Space) -> xs' |> SoftBreak
                            (Str t1, Str t2)   -> xs' |> Str (t1 <> t2)
                            (Emph i1, Emph i2) -> xs' |> Emph (i1 <> i2)
                            (Underline i1, Underline i2) -> xs' |> Underline (i1 <> i2)
                            (Strong i1, Strong i2) -> xs' |> Strong (i1 <> i2)
                            (Subscript i1, Subscript i2) -> xs' |> Subscript (i1 <> i2)
                            (Superscript i1, Superscript i2) -> xs' |> Superscript (i1 <> i2)
                            (Strikeout i1, Strikeout i2) -> xs' |> Strikeout (i1 <> i2)
                            (Space, LineBreak) -> xs' |> LineBreak
                            (LineBreak, Space) -> xs' |> LineBreak
                            (SoftBreak, LineBreak) -> xs' |> LineBreak
                            (LineBreak, SoftBreak) -> xs' |> LineBreak
                            (SoftBreak, SoftBreak) -> xs' |> SoftBreak
                            _                  -> xs' |> x |> y
  instance Monoid Inlines where
    mempty = Many mempty
    mappend = (<>)
  
  instance IsString Inlines where
     fromString = text . T.pack
  
  -- | Trim leading and trailing spaces and softbreaks from an Inlines.
  trimInlines :: Inlines -> Inlines
  #if MIN_VERSION_containers(0,4,0)
  trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $
                              Seq.dropWhileR isSp $ ils
  #else
  -- for GHC 6.12, we need to workaround a bug in dropWhileR
  -- see http://hackage.haskell.org/trac/ghc/ticket/4157
  trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $
                              Seq.reverse $ Seq.dropWhileL isSp $
                              Seq.reverse ils
  #endif
    where isSp Space = True
          isSp SoftBreak = True
          isSp _ = False
  
  -- Document builders
  
  doc :: Blocks -> Pandoc
  doc = Pandoc nullMeta . toList
  
  class ToMetaValue a where
    toMetaValue :: a -> MetaValue
  
  instance ToMetaValue MetaValue where
    toMetaValue = id
  
  instance ToMetaValue Blocks where
    toMetaValue = MetaBlocks . toList
  
  instance ToMetaValue Inlines where
    toMetaValue = MetaInlines . toList
  
  instance ToMetaValue Bool where
    toMetaValue = MetaBool
  
  instance ToMetaValue Text where
    toMetaValue = MetaString
  
  instance {-# OVERLAPPING #-} ToMetaValue String where
    toMetaValue = MetaString . T.pack
  
  instance ToMetaValue a => ToMetaValue [a] where
    toMetaValue = MetaList . map toMetaValue
  
  instance ToMetaValue a => ToMetaValue (M.Map Text a) where
    toMetaValue = MetaMap . M.map toMetaValue
  
  instance ToMetaValue a => ToMetaValue (M.Map String a) where
    toMetaValue = MetaMap . M.map toMetaValue . M.mapKeys T.pack
  
  class HasMeta a where
    setMeta :: ToMetaValue b => Text -> b -> a -> a
    deleteMeta :: Text -> a -> a
  
  instance HasMeta Meta where
    setMeta key val (Meta ms) = Meta $ M.insert key (toMetaValue val) ms
    deleteMeta key (Meta ms) = Meta $ M.delete key ms
  
  instance HasMeta Pandoc where
    setMeta key val (Pandoc (Meta ms) bs) =
      Pandoc (Meta $ M.insert key (toMetaValue val) ms) bs
    deleteMeta key (Pandoc (Meta ms) bs) =
      Pandoc (Meta $ M.delete key ms) bs
  
  setTitle :: Inlines -> Pandoc -> Pandoc
  setTitle = setMeta "title"
  
  setAuthors :: [Inlines] -> Pandoc -> Pandoc
  setAuthors = setMeta "author"
  
  setDate :: Inlines -> Pandoc -> Pandoc
  setDate = setMeta "date"
  
  -- Inline list builders
  
  -- | Convert a 'Text' to 'Inlines', treating interword spaces as 'Space's
  -- or 'SoftBreak's.  If you want a 'Str' with literal spaces, use 'str'.
  text :: Text -> Inlines
  text = fromList . map conv . breakBySpaces
    where breakBySpaces = T.groupBy sameCategory
          sameCategory x y = is_space x == is_space y
          conv xs | T.all is_space xs =
             if T.any is_newline xs
                then SoftBreak
                else Space
          conv xs = Str xs
          is_space ' '    = True
          is_space '\r'   = True
          is_space '\n'   = True
          is_space '\t'   = True
          is_space _      = False
          is_newline '\r' = True
          is_newline '\n' = True
          is_newline _    = False
  
  str :: Text -> Inlines
  str = singleton . Str
  
  emph :: Inlines -> Inlines
  emph = singleton . Emph . toList
  
  underline :: Inlines -> Inlines
  underline = singleton . Underline . toList
  
  strong :: Inlines -> Inlines
  strong = singleton . Strong . toList
  
  strikeout :: Inlines -> Inlines
  strikeout = singleton . Strikeout . toList
  
  superscript :: Inlines -> Inlines
  superscript = singleton . Superscript . toList
  
  subscript :: Inlines -> Inlines
  subscript = singleton . Subscript . toList
  
  smallcaps :: Inlines -> Inlines
  smallcaps = singleton . SmallCaps . toList
  
  singleQuoted :: Inlines -> Inlines
  singleQuoted = quoted SingleQuote
  
  doubleQuoted :: Inlines -> Inlines
  doubleQuoted = quoted DoubleQuote
  
  quoted :: QuoteType -> Inlines -> Inlines
  quoted qt = singleton . Quoted qt . toList
  
  cite :: [Citation] -> Inlines -> Inlines
  cite cts = singleton . Cite cts . toList
  
  -- | Inline code with attributes.
  codeWith :: Attr -> Text -> Inlines
  codeWith attrs = singleton . Code attrs
  
  -- | Plain inline code.
  code :: Text -> Inlines
  code = codeWith nullAttr
  
  space :: Inlines
  space = singleton Space
  
  softbreak :: Inlines
  softbreak = singleton SoftBreak
  
  linebreak :: Inlines
  linebreak = singleton LineBreak
  
  -- | Inline math
  math :: Text -> Inlines
  math = singleton . Math InlineMath
  
  -- | Display math
  displayMath :: Text -> Inlines
  displayMath = singleton . Math DisplayMath
  
  rawInline :: Text -> Text -> Inlines
  rawInline format = singleton . RawInline (Format format)
  
  link :: Text  -- ^ URL
       -> Text  -- ^ Title
       -> Inlines -- ^ Label
       -> Inlines
  link = linkWith nullAttr
  
  linkWith :: Attr    -- ^ Attributes
           -> Text  -- ^ URL
           -> Text  -- ^ Title
           -> Inlines -- ^ Label
           -> Inlines
  linkWith attr url title x = singleton $ Link attr (toList x) (url, title)
  
  image :: Text  -- ^ URL
        -> Text  -- ^ Title
        -> Inlines -- ^ Alt text
        -> Inlines
  image = imageWith nullAttr
  
  imageWith :: Attr -- ^ Attributes
            -> Text  -- ^ URL
            -> Text  -- ^ Title
            -> Inlines -- ^ Alt text
            -> Inlines
  imageWith attr url title x = singleton $ Image attr (toList x) (url, title)
  
  note :: Blocks -> Inlines
  note = singleton . Note . toList
  
  spanWith :: Attr -> Inlines -> Inlines
  spanWith attr = singleton . Span attr . toList
  
  -- Block list builders
  
  para :: Inlines -> Blocks
  para = singleton . Para . toList
  
  plain :: Inlines -> Blocks
  plain ils = if isNull ils
                 then mempty
                 else singleton . Plain . toList $ ils
  
  lineBlock :: [Inlines] -> Blocks
  lineBlock = singleton . LineBlock . map toList
  
  -- | A code block with attributes.
  codeBlockWith :: Attr -> Text -> Blocks
  codeBlockWith attrs = singleton . CodeBlock attrs
  
  -- | A plain code block.
  codeBlock :: Text -> Blocks
  codeBlock = codeBlockWith nullAttr
  
  rawBlock :: Text -> Text -> Blocks
  rawBlock format = singleton . RawBlock (Format format)
  
  blockQuote :: Blocks -> Blocks
  blockQuote = singleton . BlockQuote . toList
  
  -- | Ordered list with attributes.
  orderedListWith :: ListAttributes -> [Blocks] -> Blocks
  orderedListWith attrs = singleton . OrderedList attrs .  map toList
  
  -- | Ordered list with default attributes.
  orderedList :: [Blocks] -> Blocks
  orderedList = orderedListWith (1, DefaultStyle, DefaultDelim)
  
  bulletList :: [Blocks] -> Blocks
  bulletList = singleton . BulletList . map toList
  
  definitionList :: [(Inlines, [Blocks])] -> Blocks
  definitionList = singleton . DefinitionList .  map (toList *** map toList)
  
  header :: Int  -- ^ Level
         -> Inlines
         -> Blocks
  header = headerWith nullAttr
  
  headerWith :: Attr -> Int -> Inlines -> Blocks
  headerWith attr level = singleton . Header level attr . toList
  
  horizontalRule :: Blocks
  horizontalRule = singleton HorizontalRule
  
  cellWith :: Attr
           -> Alignment
           -> RowSpan
           -> ColSpan
           -> Blocks
           -> Cell
  cellWith at a r c = Cell at a r c . toList
  
  cell :: Alignment
       -> RowSpan
       -> ColSpan
       -> Blocks
       -> Cell
  cell = cellWith nullAttr
  
  -- | A 1×1 cell with default alignment.
  simpleCell :: Blocks -> Cell
  simpleCell = cell AlignDefault 1 1
  
  -- | A 1×1 empty cell.
  emptyCell :: Cell
  emptyCell = simpleCell mempty
  
  -- | Table builder. Performs normalization with 'normalizeTableHead',
  -- 'normalizeTableBody', and 'normalizeTableFoot'. The number of table
  -- columns is given by the length of @['ColSpec']@.
  table :: Caption
        -> [ColSpec]
        -> TableHead
        -> [TableBody]
        -> TableFoot
        -> Blocks
  table = tableWith nullAttr
  
  tableWith :: Attr
            -> Caption
            -> [ColSpec]
            -> TableHead
            -> [TableBody]
            -> TableFoot
            -> Blocks
  tableWith attr capt specs th tbs tf
    = singleton $ Table attr capt specs th' tbs' tf'
    where
      twidth = length specs
      th'  = normalizeTableHead twidth th
      tbs' = map (normalizeTableBody twidth) tbs
      tf'  = normalizeTableFoot twidth tf
  
  -- | A simple table without a caption.
  simpleTable :: [Blocks]   -- ^ Headers
              -> [[Blocks]] -- ^ Rows
              -> Blocks
  simpleTable headers rows =
    table emptyCaption (replicate numcols defaults) th [tb] tf
    where defaults = (AlignDefault, ColWidthDefault)
          numcols  = maximum (map length (headers:rows))
          toRow = Row nullAttr . map simpleCell
          toHeaderRow l
            | null l    = []
            | otherwise = [toRow headers]
          th = TableHead nullAttr (toHeaderRow headers)
          tb = TableBody nullAttr 0 [] $ map toRow rows
          tf = TableFoot nullAttr []
  
  figure :: Caption -> Blocks -> Blocks
  figure = figureWith nullAttr
  
  figureWith :: Attr -> Caption -> Blocks -> Blocks
  figureWith attr capt = singleton . Figure attr capt . toList
  
  caption :: Maybe ShortCaption -> Blocks -> Caption
  caption x = Caption x . toList
  
  simpleCaption :: Blocks -> Caption
  simpleCaption = caption Nothing
  
  emptyCaption :: Caption
  emptyCaption = simpleCaption mempty
  
  -- | Creates a simple figure from attributes, a figure caption, an image
  -- path and image title. The attributes are used as the image
  -- attributes.
  simpleFigureWith :: Attr -> Inlines -> Text -> Text -> Blocks
  simpleFigureWith attr figureCaption url title =
    figure (simpleCaption (plain figureCaption)) . plain $
       imageWith attr url title mempty
  
  simpleFigure :: Inlines -> Text -> Text -> Blocks
  simpleFigure = simpleFigureWith nullAttr
  
  divWith :: Attr -> Blocks -> Blocks
  divWith attr = singleton . Div attr . toList
  
  -- | Normalize the 'TableHead' with 'clipRows' and 'placeRowSection'
  -- so that when placed on a grid with the given width and a height
  -- equal to the number of rows in the initial 'TableHead', there will
  -- be no empty spaces or overlapping cells, and the cells will not
  -- protrude beyond the grid.
  normalizeTableHead :: Int -> TableHead -> TableHead
  normalizeTableHead twidth (TableHead attr rows)
    = TableHead attr $ normalizeHeaderSection twidth rows
  
  -- | Normalize the intermediate head and body section of a
  -- 'TableBody', as in 'normalizeTableHead', but additionally ensure
  -- that row head cells do not go beyond the row head inside the
  -- intermediate body.
  normalizeTableBody :: Int -> TableBody -> TableBody
  normalizeTableBody twidth (TableBody attr rhc th tb)
    = TableBody attr
                rhc'
                (normalizeHeaderSection twidth th)
                (normalizeBodySection twidth rhc' tb)
    where
      rhc' = max 0 $ min (RowHeadColumns twidth) rhc
  
  -- | Normalize the 'TableFoot', as in 'normalizeTableHead'.
  normalizeTableFoot :: Int -> TableFoot -> TableFoot
  normalizeTableFoot twidth (TableFoot attr rows)
    = TableFoot attr $ normalizeHeaderSection twidth rows
  
  normalizeHeaderSection :: Int -- ^ The desired width of the table
                         -> [Row]
                         -> [Row]
  normalizeHeaderSection twidth rows
    = normalizeRows' (replicate twidth 1) $ clipRows rows
    where
      normalizeRows' oldHang (Row attr cells:rs)
        = let (newHang, cells', _) = placeRowSection oldHang $ cells <> repeat emptyCell
              rs' = normalizeRows' newHang rs
          in Row attr cells' : rs'
      normalizeRows' _ [] = []
  
  normalizeBodySection :: Int -- ^ The desired width of the table
                       -> RowHeadColumns -- ^ The width of the row head,
                                         -- between 0 and the table
                                         -- width
                       -> [Row]
                       -> [Row]
  normalizeBodySection twidth (RowHeadColumns rhc) rows
    = normalizeRows' (replicate rhc 1) (replicate rbc 1) $ clipRows rows
    where
      rbc = twidth - rhc
  
      normalizeRows' headHang bodyHang (Row attr cells:rs)
        = let (headHang', rowHead, cells') = placeRowSection headHang $ cells <> repeat emptyCell
              (bodyHang', rowBody, _)      = placeRowSection bodyHang cells'
              rs' = normalizeRows' headHang' bodyHang' rs
          in Row attr (rowHead <> rowBody) : rs'
      normalizeRows' _ _ [] = []
  
  -- | Normalize the given list of cells so that they fit on a single
  -- grid row. The 'RowSpan' values of the cells are assumed to be valid
  -- (clamped to lie between 1 and the remaining grid height). The cells
  -- in the list are also assumed to be able to fill the entire grid
  -- row. These conditions can be met by appending @repeat 'emptyCell'@
  -- to the @['Cell']@ list and using 'clipRows' on the entire table
  -- section beforehand.
  --
  -- Normalization follows the principle that cells are placed on a grid
  -- row in order, each at the first available grid position from the
  -- left, having their 'ColSpan' reduced if they would overlap with a
  -- previous cell, stopping once the row is filled. Only the dimensions
  -- of cells are changed, and only of those cells that fit on the row.
  --
  -- Possible overlap is detected using the given @['RowSpan']@, which
  -- is the "overhang" of the previous grid row, a list of the heights
  -- of cells that descend through the previous row, reckoned
  -- /only from the previous row/.
  -- Its length should be the width (number of columns) of the current
  -- grid row.
  --
  -- For example, the numbers in the following headerless grid table
  -- represent the overhang at each grid position for that table:
  --
  -- @
  --     1   1   1   1
  --   +---+---+---+---+
  --   | 1 | 2   2 | 3 |
  --   +---+       +   +
  --   | 1 | 1   1 | 2 |
  --   +---+---+---+   +
  --   | 1   1 | 1 | 1 |
  --   +---+---+---+---+
  -- @
  --
  -- In any table, the row before the first has an overhang of
  -- @replicate tableWidth 1@, since there are no cells to descend into
  -- the table from there.  The overhang of the first row in the example
  -- is @[1, 2, 2, 3]@.
  --
  -- So if after 'clipRows' the unnormalized second row of that example
  -- table were
  --
  -- > r = [("a", 1, 2),("b", 2, 3)] -- the cells displayed as (label, RowSpan, ColSpan) only
  --
  -- a correct invocation of 'placeRowSection' to normalize it would be
  --
  -- >>> placeRowSection [1, 2, 2, 3] $ r ++ repeat emptyCell
  -- ([1, 1, 1, 2], [("a", 1, 1)], [("b", 2, 3)] ++ repeat emptyCell) -- wouldn't stop printing, of course
  --
  -- and if the third row were only @[("c", 1, 2)]@, then the expression
  -- would be
  --
  -- >>> placeRowSection [1, 1, 1, 2] $ [("c", 1, 2)] ++ repeat emptyCell
  -- ([1, 1, 1, 1], [("c", 1, 2), emptyCell], repeat emptyCell)
  placeRowSection :: [RowSpan] -- ^ The overhang of the previous grid
                               -- row
                  -> [Cell]    -- ^ The cells to lay on the grid row
                  -> ([RowSpan], [Cell], [Cell]) -- ^ The overhang of
                                                 -- the current grid
                                                 -- row, the normalized
                                                 -- cells that fit on
                                                 -- the current row, and
                                                 -- the remaining
                                                 -- unmodified cells
  placeRowSection oldHang cellStream
    -- If the grid has overhang at our position, try to re-lay in
    -- the next position.
    | o:os <- oldHang
    , o > 1 = let (newHang, newCell, cellStream') = placeRowSection os cellStream
              in (o - 1 : newHang, newCell, cellStream')
    -- Otherwise if there is any available width, place the cell and
    -- continue.
    | c:cellStream' <- cellStream
    , (h, w) <- getDim c
    , w' <- max 1 w
    , (n, oldHang') <- dropAtMostWhile (== 1) (getColSpan w') oldHang
    , n > 0
    = let w'' = min (ColSpan n) w'
          c' = setW w'' c
          (newHang, newCell, remainCell) = placeRowSection oldHang' cellStream'
      in (replicate (getColSpan w'') h <> newHang, c' : newCell, remainCell)
    -- Otherwise there is no room in the section, or not enough cells
    -- were given.
    | otherwise = ([], [], cellStream)
    where
      getColSpan (ColSpan w) = w
      getDim (Cell _ _ h w _) = (h, w)
      setW w (Cell a ma h _ b) = Cell a ma h w b
  
      dropAtMostWhile :: (a -> Bool) -> Int -> [a] -> (Int, [a])
      dropAtMostWhile p n = go 0
        where
          go acc (l:ls) | p l && acc < n = go (acc+1) ls
          go acc l = (acc, l)
  
  -- | Ensure that the height of each cell in a table section lies
  -- between 1 and the distance from its row to the end of the
  -- section. So if there were four rows in the input list, the cells in
  -- the second row would have their height clamped between 1 and 3.
  clipRows :: [Row] -> [Row]
  clipRows rows
    = let totalHeight = RowSpan $ length rows
      in zipWith clipRowH [totalHeight, totalHeight - 1..1] rows
    where
      getH (Cell _ _ h _ _) = h
      setH h (Cell a ma _ w body) = Cell a ma h w body
      clipH low high c = let h = getH c in setH (min high $ max low h) c
      clipRowH high (Row attr cells) = Row attr $ map (clipH 1 high) cells
  