{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.Shared
   Copyright   : Copyright (C) 2013-2022 John MacFarlane
   License     : GNU GPL, version 2 or above

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

Shared utility functions for pandoc writers.
-}
module Text.Pandoc.Writers.Shared (
                       metaToContext
                     , metaToContext'
                     , addVariablesToContext
                     , getField
                     , setField
                     , resetField
                     , defField
                     , getLang
                     , tagWithAttrs
                     , isDisplayMath
                     , fixDisplayMath
                     , unsmartify
                     , gridTable
                     , lookupMetaBool
                     , lookupMetaBlocks
                     , lookupMetaInlines
                     , lookupMetaString
                     , stripLeadingTrailingSpace
                     , toSubscript
                     , toSuperscript
                     , toTableOfContents
                     , endsWithPlain
                     , toLegacyTable
                     , splitSentences
                     , ensureValidXmlIdentifiers
                     )
where
import Safe (lastMay)
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (fromMaybe, isNothing)
import Control.Monad (zipWithM)
import Data.Aeson (ToJSON (..), encode)
import Data.Char (chr, ord, isSpace, isLetter)
import Data.List (groupBy, intersperse, transpose, foldl')
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
import Data.Text.Conversions (FromText(..))
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text (Text)
import qualified Text.Pandoc.Builder as Builder
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.DocLayout
import Text.Pandoc.Shared (stringify, makeSections, blocksToInlines)
import Text.Pandoc.Walk (walk)
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.XML (escapeStringForXML)
import Text.DocTemplates (Context(..), Val(..), TemplateTarget,
                          ToContext(..), FromContext(..))

-- | Create template Context from a 'Meta' and an association list
-- of variables, specified at the command line or in the writer.
-- Variables overwrite metadata fields with the same names.
-- If multiple variables are set with the same name, a list is
-- assigned.  Does nothing if 'writerTemplate' is Nothing.
metaToContext :: (Monad m, TemplateTarget a)
              => WriterOptions
              -> ([Block] -> m (Doc a))
              -> ([Inline] -> m (Doc a))
              -> Meta
              -> m (Context a)
metaToContext :: forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
WriterOptions
-> ([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a))
-> Meta
-> m (Context a)
metaToContext WriterOptions
opts [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
inlineWriter Meta
meta =
  case WriterOptions -> Maybe (Template Text)
writerTemplate WriterOptions
opts of
    Maybe (Template Text)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
    Just Template Text
_  -> forall a.
TemplateTarget a =>
WriterOptions -> Context a -> Context a
addVariablesToContext WriterOptions
opts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> Meta -> m (Context a)
metaToContext' [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
inlineWriter Meta
meta

-- | Like 'metaToContext, but does not include variables and is
-- not sensitive to 'writerTemplate'.
metaToContext' :: (Monad m, TemplateTarget a)
           => ([Block] -> m (Doc a))     -- ^ block writer
           -> ([Inline] -> m (Doc a))    -- ^ inline writer
           -> Meta
           -> m (Context a)
metaToContext' :: forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> Meta -> m (Context a)
metaToContext' [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
inlineWriter (Meta Map Text MetaValue
metamap) =
  forall a. Map Text (Val a) -> Context a
Context forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> MetaValue -> m (Val a)
metaValueToVal [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
inlineWriter) Map Text MetaValue
metamap

-- | Add variables to a template Context, using monoidal append.
-- Also add `meta-json`.  Note that metadata values are used
-- in template contexts only when like-named variables aren't set.
addVariablesToContext :: TemplateTarget a
                      => WriterOptions -> Context a -> Context a
addVariablesToContext :: forall a.
TemplateTarget a =>
WriterOptions -> Context a -> Context a
addVariablesToContext WriterOptions
opts Context a
c1 =
  Context a
c2 forall a. Semigroup a => a -> a -> a
<> (forall a. FromText a => Text -> a
fromText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> Context Text
writerVariables WriterOptions
opts) forall a. Semigroup a => a -> a -> a
<> Context a
c1
 where
   c2 :: Context a
c2 = forall a. Map Text (Val a) -> Context a
Context forall a b. (a -> b) -> a -> b
$
          forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
"meta-json" (forall a. Doc a -> Val a
SimpleVal forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ forall a. FromText a => Text -> a
fromText Text
jsonrep)
                               forall a. Monoid a => a
mempty
   jsonrep :: Text
jsonrep = ByteString -> Text
UTF8.toText forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON Context a
c1

-- | Converts a 'MetaValue' into a doctemplate 'Val', using the given
-- converter functions.
metaValueToVal :: (Monad m, TemplateTarget a)
               => ([Block] -> m (Doc a))    -- ^ block writer
               -> ([Inline] -> m (Doc a))   -- ^ inline writer
               -> MetaValue
               -> m (Val a)
metaValueToVal :: forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> MetaValue -> m (Val a)
metaValueToVal [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
inlineWriter (MetaMap Map Text MetaValue
metamap) =
  forall a. Context a -> Val a
MapVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Map Text (Val a) -> Context a
Context forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> MetaValue -> m (Val a)
metaValueToVal [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
inlineWriter) Map Text MetaValue
metamap
metaValueToVal [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
inlineWriter (MetaList [MetaValue]
xs) = forall a. [Val a] -> Val a
ListVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(Monad m, TemplateTarget a) =>
([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> MetaValue -> m (Val a)
metaValueToVal [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
inlineWriter) [MetaValue]
xs
metaValueToVal [Block] -> m (Doc a)
_ [Inline] -> m (Doc a)
_ (MetaBool Bool
b) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Bool -> Val a
BoolVal Bool
b
metaValueToVal [Block] -> m (Doc a)
_ [Inline] -> m (Doc a)
inlineWriter (MetaString Text
s) =
   forall a. Doc a -> Val a
SimpleVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inline] -> m (Doc a)
inlineWriter (forall a. Many a -> [a]
Builder.toList (Text -> Inlines
Builder.text Text
s))
metaValueToVal [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
_ (MetaBlocks [Block]
bs) = forall a. Doc a -> Val a
SimpleVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Block] -> m (Doc a)
blockWriter [Block]
bs
metaValueToVal [Block] -> m (Doc a)
_ [Inline] -> m (Doc a)
inlineWriter (MetaInlines [Inline]
is) = forall a. Doc a -> Val a
SimpleVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inline] -> m (Doc a)
inlineWriter [Inline]
is


-- | Retrieve a field value from a template context.
getField   :: FromContext a b => Text -> Context a -> Maybe b
getField :: forall a b. FromContext a b => Text -> Context a -> Maybe b
getField Text
field (Context Map Text (Val a)
m) = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
field Map Text (Val a)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b. FromContext a b => Val a -> Maybe b
fromVal

-- | Set a field of a template context.  If the field already has a value,
-- convert it into a list with the new value appended to the old value(s).
-- This is a utility function to be used in preparing template contexts.
setField   :: ToContext a b => Text -> b -> Context a -> Context a
setField :: forall a b. ToContext a b => Text -> b -> Context a -> Context a
setField Text
field b
val (Context Map Text (Val a)
m) =
  forall a. Map Text (Val a) -> Context a
Context forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall {a}. Val a -> Val a -> Val a
combine Text
field (forall a b. ToContext a b => b -> Val a
toVal b
val) Map Text (Val a)
m
 where
  combine :: Val a -> Val a -> Val a
combine Val a
newval (ListVal [Val a]
xs)   = forall a. [Val a] -> Val a
ListVal ([Val a]
xs forall a. [a] -> [a] -> [a]
++ [Val a
newval])
  combine Val a
newval Val a
x              = forall a. [Val a] -> Val a
ListVal [Val a
x, Val a
newval]

-- | Reset a field of a template context.  If the field already has a
-- value, the new value replaces it.
-- This is a utility function to be used in preparing template contexts.
resetField :: ToContext a b => Text -> b -> Context a -> Context a
resetField :: forall a b. ToContext a b => Text -> b -> Context a -> Context a
resetField Text
field b
val (Context Map Text (Val a)
m) =
  forall a. Map Text (Val a) -> Context a
Context (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
field (forall a b. ToContext a b => b -> Val a
toVal b
val) Map Text (Val a)
m)

-- | Set a field of a template context if it currently has no value.
-- If it has a value, do nothing.
-- This is a utility function to be used in preparing template contexts.
defField   :: ToContext a b => Text -> b -> Context a -> Context a
defField :: forall a b. ToContext a b => Text -> b -> Context a -> Context a
defField Text
field b
val (Context Map Text (Val a)
m) =
  forall a. Map Text (Val a) -> Context a
Context (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall {p} {p}. p -> p -> p
f Text
field (forall a b. ToContext a b => b -> Val a
toVal b
val) Map Text (Val a)
m)
  where
    f :: p -> p -> p
f p
_newval p
oldval = p
oldval

-- | Get the contents of the `lang` metadata field or variable.
getLang :: WriterOptions -> Meta -> Maybe Text
getLang :: WriterOptions -> Meta -> Maybe Text
getLang WriterOptions
opts Meta
meta =
  case forall a b. FromContext a b => Text -> Context a -> Maybe b
lookupContext Text
"lang" (WriterOptions -> Context Text
writerVariables WriterOptions
opts) of
        Just Text
s -> forall a. a -> Maybe a
Just Text
s
        Maybe Text
_      ->
          case Text -> Meta -> Maybe MetaValue
lookupMeta Text
"lang" Meta
meta of
               Just (MetaBlocks [Para [Str Text
s]])  -> forall a. a -> Maybe a
Just Text
s
               Just (MetaBlocks [Plain [Str Text
s]]) -> forall a. a -> Maybe a
Just Text
s
               Just (MetaInlines [Str Text
s])        -> forall a. a -> Maybe a
Just Text
s
               Just (MetaString Text
s)               -> forall a. a -> Maybe a
Just Text
s
               Maybe MetaValue
_                                 -> forall a. Maybe a
Nothing

-- | Produce an HTML tag with the given pandoc attributes.
tagWithAttrs :: HasChars a => Text -> Attr -> Doc a
tagWithAttrs :: forall a. HasChars a => Text -> Attr -> Doc a
tagWithAttrs Text
tag (Text
ident,[Text]
classes,[(Text, Text)]
kvs) = forall a. [Doc a] -> Doc a
hsep
  [Doc a
"<" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => String -> Doc a
text (Text -> String
T.unpack Text
tag)
  ,if Text -> Bool
T.null Text
ident
      then forall a. Doc a
empty
      else Doc a
"id=" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Doc a -> Doc a
doubleQuotes (forall a. HasChars a => String -> Doc a
text forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
ident)
  ,if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
classes
      then forall a. Doc a
empty
      else Doc a
"class=" forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Doc a -> Doc a
doubleQuotes (forall a. HasChars a => String -> Doc a
text forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack ([Text] -> Text
T.unwords [Text]
classes))
  ,forall a. [Doc a] -> Doc a
hsep (forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k,Text
v) -> forall a. HasChars a => String -> Doc a
text (Text -> String
T.unpack Text
k) forall a. Semigroup a => a -> a -> a
<> Doc a
"=" forall a. Semigroup a => a -> a -> a
<>
                forall a. HasChars a => Doc a -> Doc a
doubleQuotes (forall a. HasChars a => String -> Doc a
text forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> Text
escapeStringForXML Text
v))) [(Text, Text)]
kvs)
  ] forall a. Semigroup a => a -> a -> a
<> Doc a
">"

-- | Returns 'True' iff the argument is an inline 'Math' element of type
-- 'DisplayMath'.
isDisplayMath :: Inline -> Bool
isDisplayMath :: Inline -> Bool
isDisplayMath (Math MathType
DisplayMath Text
_)          = Bool
True
isDisplayMath (Span Attr
_ [Math MathType
DisplayMath Text
_]) = Bool
True
isDisplayMath Inline
_                             = Bool
False

-- | Remove leading and trailing 'Space' and 'SoftBreak' elements.
stripLeadingTrailingSpace :: [Inline] -> [Inline]
stripLeadingTrailingSpace :: [Inline] -> [Inline]
stripLeadingTrailingSpace = [Inline] -> [Inline]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> [Inline]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where go :: [Inline] -> [Inline]
go (Inline
Space:[Inline]
xs)     = [Inline]
xs
        go (Inline
SoftBreak:[Inline]
xs) = [Inline]
xs
        go [Inline]
xs             = [Inline]
xs

-- | Put display math in its own block (for ODT/DOCX).
fixDisplayMath :: Block -> Block
fixDisplayMath :: Block -> Block
fixDisplayMath (Plain [Inline]
lst)
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Inline -> Bool
isDisplayMath [Inline]
lst Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Inline -> Bool
isDisplayMath [Inline]
lst) =
    -- chop into several paragraphs so each displaymath is its own
    Attr -> [Block] -> Block
Div (Text
"",[Text
"math"],[]) forall a b. (a -> b) -> a -> b
$
       forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Block
Plain forall a b. (a -> b) -> a -> b
$
       forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$
       forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> [Inline]
stripLeadingTrailingSpace forall a b. (a -> b) -> a -> b
$
       forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Inline
x Inline
y -> (Inline -> Bool
isDisplayMath Inline
x Bool -> Bool -> Bool
&& Inline -> Bool
isDisplayMath Inline
y) Bool -> Bool -> Bool
||
                         Bool -> Bool
not (Inline -> Bool
isDisplayMath Inline
x Bool -> Bool -> Bool
|| Inline -> Bool
isDisplayMath Inline
y)) [Inline]
lst
fixDisplayMath (Para [Inline]
lst)
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Inline -> Bool
isDisplayMath [Inline]
lst Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Inline -> Bool
isDisplayMath [Inline]
lst) =
    -- chop into several paragraphs so each displaymath is its own
    Attr -> [Block] -> Block
Div (Text
"",[Text
"math"],[]) forall a b. (a -> b) -> a -> b
$
       forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Block
Para forall a b. (a -> b) -> a -> b
$
       forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$
       forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> [Inline]
stripLeadingTrailingSpace forall a b. (a -> b) -> a -> b
$
       forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\Inline
x Inline
y -> (Inline -> Bool
isDisplayMath Inline
x Bool -> Bool -> Bool
&& Inline -> Bool
isDisplayMath Inline
y) Bool -> Bool -> Bool
||
                         Bool -> Bool
not (Inline -> Bool
isDisplayMath Inline
x Bool -> Bool -> Bool
|| Inline -> Bool
isDisplayMath Inline
y)) [Inline]
lst
fixDisplayMath Block
x = Block
x

-- | Converts a Unicode character into the ASCII sequence used to
-- represent the character in "smart" Markdown.
unsmartify :: WriterOptions -> Text -> Text
unsmartify :: WriterOptions -> Text -> Text
unsmartify WriterOptions
opts = (Char -> Text) -> Text -> Text
T.concatMap forall a b. (a -> b) -> a -> b
$ \Char
c -> case Char
c of
  Char
'\8217' -> Text
"'"
  Char
'\8230' -> Text
"..."
  Char
'\8211'
    | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_old_dashes WriterOptions
opts -> Text
"-"
    | Bool
otherwise                     -> Text
"--"
  Char
'\8212'
    | forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_old_dashes WriterOptions
opts -> Text
"--"
    | Bool
otherwise                     -> Text
"---"
  Char
'\8220' -> Text
"\""
  Char
'\8221' -> Text
"\""
  Char
'\8216' -> Text
"'"
  Char
_       -> Char -> Text
T.singleton Char
c

-- | Writes a grid table.
gridTable :: (Monad m, HasChars a)
          => WriterOptions
          -> (WriterOptions -> [Block] -> m (Doc a)) -- ^ format Doc writer
          -> Bool             -- ^ headless
          -> [Alignment]      -- ^ column alignments
          -> [Double]         -- ^ column widths
          -> [[Block]]        -- ^ table header row
          -> [[[Block]]]      -- ^ table body rows
          -> m (Doc a)
gridTable :: forall (m :: * -> *) a.
(Monad m, HasChars a) =>
WriterOptions
-> (WriterOptions -> [Block] -> m (Doc a))
-> Bool
-> [Alignment]
-> [Double]
-> [[Block]]
-> [[[Block]]]
-> m (Doc a)
gridTable WriterOptions
opts WriterOptions -> [Block] -> m (Doc a)
blocksToDoc Bool
headless [Alignment]
aligns [Double]
widths [[Block]]
headers [[[Block]]]
rows = do
  -- the number of columns will be used in case of even widths
  let numcols :: Int
numcols = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Alignment]
aligns forall a. a -> [a] -> NonEmpty a
:| forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
widths forall a. a -> [a] -> [a]
:
                           forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Block]]
headersforall a. a -> [a] -> [a]
:[[[Block]]]
rows))
  let officialWidthsInChars :: [b] -> [b]
officialWidthsInChars [b]
widths' = forall a b. (a -> b) -> [a] -> [b]
map (
                        (\b
x -> if b
x forall a. Ord a => a -> a -> Bool
< b
1 then b
1 else b
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        (\b
x -> b
x forall a. Num a => a -> a -> a
- b
3) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                        (forall a b. (Integral a, Num b) => a -> b
fromIntegral (WriterOptions -> Int
writerColumns WriterOptions
opts) forall a. Num a => a -> a -> a
*)
                        ) [b]
widths'
  -- handleGivenWidths wraps the given blocks in order for them to fit
  -- in cells with given widths. the returned content can be
  -- concatenated with borders and frames
  let handleGivenWidthsInChars :: [Int] -> m ([Int], [Doc a], [[Doc a]])
handleGivenWidthsInChars [Int]
widthsInChars' = do
        -- replace page width (in columns) in the options with a
        -- given width if smaller (adjusting by two)
        let useWidth :: Int -> WriterOptions
useWidth Int
w = WriterOptions
opts{writerColumns :: Int
writerColumns = forall a. Ord a => a -> a -> a
min (Int
w forall a. Num a => a -> a -> a
- Int
2) (WriterOptions -> Int
writerColumns WriterOptions
opts)}
        -- prepare options to use with header and row cells
        let columnOptions :: [WriterOptions]
columnOptions = forall a b. (a -> b) -> [a] -> [b]
map Int -> WriterOptions
useWidth [Int]
widthsInChars'
        [Doc a]
rawHeaders' <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM WriterOptions -> [Block] -> m (Doc a)
blocksToDoc [WriterOptions]
columnOptions [[Block]]
headers
        [[Doc a]]
rawRows' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
             (\[[Block]]
cs -> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM WriterOptions -> [Block] -> m (Doc a)
blocksToDoc [WriterOptions]
columnOptions [[Block]]
cs)
             [[[Block]]]
rows
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Int]
widthsInChars', [Doc a]
rawHeaders', [[Doc a]]
rawRows')
  let handleGivenWidths :: [b] -> m ([Int], [Doc a], [[Doc a]])
handleGivenWidths [b]
widths' = [Int] -> m ([Int], [Doc a], [[Doc a]])
handleGivenWidthsInChars
                                     (forall {b} {b}. (RealFrac b, Integral b) => [b] -> [b]
officialWidthsInChars [b]
widths')
  -- handleFullWidths tries to wrap cells to the page width or even
  -- more in cases where `--wrap=none`. thus the content here is left
  -- as wide as possible
  let handleFullWidths :: [b] -> m ([Int], [Doc a], [[Doc a]])
handleFullWidths [b]
widths' = do
        [Doc a]
rawHeaders' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> [Block] -> m (Doc a)
blocksToDoc WriterOptions
opts) [[Block]]
headers
        [[Doc a]]
rawRows' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> [Block] -> m (Doc a)
blocksToDoc WriterOptions
opts)) [[[Block]]]
rows
        let numChars :: [Doc a] -> Int
numChars = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. (IsString a, HasChars a) => Doc a -> Int
offset
        let minWidthsInChars :: [Int]
minWidthsInChars =
                forall a b. (a -> b) -> [a] -> [b]
map [Doc a] -> Int
numChars forall a b. (a -> b) -> a -> b
$ forall a. [[a]] -> [[a]]
transpose ([Doc a]
rawHeaders' forall a. a -> [a] -> [a]
: [[Doc a]]
rawRows')
        let widthsInChars' :: [Int]
widthsInChars' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> a
max
                              [Int]
minWidthsInChars
                              (forall {b} {b}. (RealFrac b, Integral b) => [b] -> [b]
officialWidthsInChars [b]
widths')
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Int]
widthsInChars', [Doc a]
rawHeaders', [[Doc a]]
rawRows')
  -- handleZeroWidths calls handleFullWidths to check whether a wide
  -- table would fit in the page. if the produced table is too wide,
  -- it calculates even widths and passes the content to
  -- handleGivenWidths
  let handleZeroWidths :: [b] -> m ([Int], [Doc a], [[Doc a]])
handleZeroWidths [b]
widths' = do
        ([Int]
widthsInChars', [Doc a]
rawHeaders', [[Doc a]]
rawRows') <- forall {b}. RealFrac b => [b] -> m ([Int], [Doc a], [[Doc a]])
handleFullWidths [b]
widths'
        if forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) Int
0 [Int]
widthsInChars' forall a. Ord a => a -> a -> Bool
> WriterOptions -> Int
writerColumns WriterOptions
opts
           then do -- use even widths except for thin columns
             let evenCols :: Int
evenCols  = forall a. Ord a => a -> a -> a
max Int
5
                              (((WriterOptions -> Int
writerColumns WriterOptions
opts forall a. Num a => a -> a -> a
- Int
1) forall a. Integral a => a -> a -> a
`div` Int
numcols) forall a. Num a => a -> a -> a
- Int
3)
             let (Int
numToExpand, Int
colsToExpand) =
                   forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
w (Int
n, Int
tot) -> if Int
w forall a. Ord a => a -> a -> Bool
< Int
evenCols
                                            then (Int
n, Int
tot forall a. Num a => a -> a -> a
+ (Int
evenCols forall a. Num a => a -> a -> a
- Int
w))
                                            else (Int
n forall a. Num a => a -> a -> a
+ Int
1, Int
tot))
                                   (Int
0,Int
0) [Int]
widthsInChars'
             let expandAllowance :: Int
expandAllowance = Int
colsToExpand forall a. Integral a => a -> a -> a
`div` Int
numToExpand
             let newWidthsInChars :: [Int]
newWidthsInChars = forall a b. (a -> b) -> [a] -> [b]
map (\Int
w -> if Int
w forall a. Ord a => a -> a -> Bool
< Int
evenCols
                                                  then Int
w
                                                  else forall a. Ord a => a -> a -> a
min
                                                       (Int
evenCols forall a. Num a => a -> a -> a
+ Int
expandAllowance)
                                                       Int
w)
                                        [Int]
widthsInChars'
             [Int] -> m ([Int], [Doc a], [[Doc a]])
handleGivenWidthsInChars [Int]
newWidthsInChars
           else forall (m :: * -> *) a. Monad m => a -> m a
return ([Int]
widthsInChars', [Doc a]
rawHeaders', [[Doc a]]
rawRows')
  -- render the contents of header and row cells differently depending
  -- on command line options, widths given in this specific table, and
  -- cells' contents
  let handleWidths :: m ([Int], [Doc a], [[Doc a]])
handleWidths
        | WriterOptions -> WrapOption
writerWrapText WriterOptions
opts forall a. Eq a => a -> a -> Bool
== WrapOption
WrapNone    = forall {b}. RealFrac b => [b] -> m ([Int], [Doc a], [[Doc a]])
handleFullWidths [Double]
widths
        | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Double
0) [Double]
widths                  = forall {b}. RealFrac b => [b] -> m ([Int], [Doc a], [[Doc a]])
handleZeroWidths [Double]
widths
        | Bool
otherwise                          = forall {b}. RealFrac b => [b] -> m ([Int], [Doc a], [[Doc a]])
handleGivenWidths [Double]
widths
  ([Int]
widthsInChars, [Doc a]
rawHeaders, [[Doc a]]
rawRows) <- m ([Int], [Doc a], [[Doc a]])
handleWidths
  let hpipeBlocks :: [Doc a] -> Doc a
hpipeBlocks [Doc a]
blocks = forall a. [Doc a] -> Doc a
hcat [Doc a
beg, Doc a
middle, Doc a
end]
        where sep' :: Doc a
sep'    = forall a. HasChars a => a -> Doc a
vfill a
" | "
              beg :: Doc a
beg     = forall a. HasChars a => a -> Doc a
vfill a
"| "
              end :: Doc a
end     = forall a. HasChars a => a -> Doc a
vfill a
" |"
              middle :: Doc a
middle  = forall a. Doc a -> Doc a
chomp forall a b. (a -> b) -> a -> b
$ forall a. [Doc a] -> Doc a
hcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Doc a
sep' [Doc a]
blocks
  let makeRow :: [Doc a] -> Doc a
makeRow = forall {a}. HasChars a => [Doc a] -> Doc a
hpipeBlocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. HasChars a => Int -> Doc a -> Doc a
lblock [Int]
widthsInChars
  let head' :: Doc a
head' = [Doc a] -> Doc a
makeRow [Doc a]
rawHeaders
  let rows' :: [Doc a]
rows' = forall a b. (a -> b) -> [a] -> [b]
map ([Doc a] -> Doc a
makeRow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Doc a -> Doc a
chomp) [[Doc a]]
rawRows
  let borderpart :: Char -> Alignment -> Int -> Doc a
borderpart Char
ch Alignment
align Int
widthInChars =
           (if Alignment
align forall a. Eq a => a -> a -> Bool
== Alignment
AlignLeft Bool -> Bool -> Bool
|| Alignment
align forall a. Eq a => a -> a -> Bool
== Alignment
AlignCenter
               then forall a. HasChars a => Char -> Doc a
char Char
':'
               else forall a. HasChars a => Char -> Doc a
char Char
ch) forall a. Semigroup a => a -> a -> a
<>
           forall a. HasChars a => String -> Doc a
text (forall a. Int -> a -> [a]
replicate Int
widthInChars Char
ch) forall a. Semigroup a => a -> a -> a
<>
           (if Alignment
align forall a. Eq a => a -> a -> Bool
== Alignment
AlignRight Bool -> Bool -> Bool
|| Alignment
align forall a. Eq a => a -> a -> Bool
== Alignment
AlignCenter
               then forall a. HasChars a => Char -> Doc a
char Char
':'
               else forall a. HasChars a => Char -> Doc a
char Char
ch)
  let border :: Char -> [Alignment] -> [Int] -> Doc a
border Char
ch [Alignment]
aligns' [Int]
widthsInChars' =
        forall a. HasChars a => Char -> Doc a
char Char
'+' forall a. Semigroup a => a -> a -> a
<>
        forall a. [Doc a] -> Doc a
hcat (forall a. a -> [a] -> [a]
intersperse (forall a. HasChars a => Char -> Doc a
char Char
'+') (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall {a}. HasChars a => Char -> Alignment -> Int -> Doc a
borderpart Char
ch)
                [Alignment]
aligns' [Int]
widthsInChars')) forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Char -> Doc a
char Char
'+'
  let body :: Doc a
body = forall a. [Doc a] -> Doc a
vcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (forall {a}. HasChars a => Char -> [Alignment] -> [Int] -> Doc a
border Char
'-' (forall a. a -> [a]
repeat Alignment
AlignDefault) [Int]
widthsInChars)
                    [Doc a]
rows'
  let head'' :: Doc a
head'' = if Bool
headless
                  then forall a. Doc a
empty
                  else Doc a
head' forall a. Doc a -> Doc a -> Doc a
$$ forall {a}. HasChars a => Char -> [Alignment] -> [Int] -> Doc a
border Char
'=' [Alignment]
aligns [Int]
widthsInChars
  if Bool
headless
     then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
           forall {a}. HasChars a => Char -> [Alignment] -> [Int] -> Doc a
border Char
'-' [Alignment]
aligns [Int]
widthsInChars forall a. Doc a -> Doc a -> Doc a
$$
           Doc a
body forall a. Doc a -> Doc a -> Doc a
$$
           forall {a}. HasChars a => Char -> [Alignment] -> [Int] -> Doc a
border Char
'-' (forall a. a -> [a]
repeat Alignment
AlignDefault) [Int]
widthsInChars
     else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
           forall {a}. HasChars a => Char -> [Alignment] -> [Int] -> Doc a
border Char
'-' (forall a. a -> [a]
repeat Alignment
AlignDefault) [Int]
widthsInChars forall a. Doc a -> Doc a -> Doc a
$$
           Doc a
head'' forall a. Doc a -> Doc a -> Doc a
$$
           Doc a
body forall a. Doc a -> Doc a -> Doc a
$$
           forall {a}. HasChars a => Char -> [Alignment] -> [Int] -> Doc a
border Char
'-' (forall a. a -> [a]
repeat Alignment
AlignDefault) [Int]
widthsInChars

-- | Retrieve the metadata value for a given @key@
-- and convert to Bool.
lookupMetaBool :: Text -> Meta -> Bool
lookupMetaBool :: Text -> Meta -> Bool
lookupMetaBool Text
key Meta
meta =
  case Text -> Meta -> Maybe MetaValue
lookupMeta Text
key Meta
meta of
      Just (MetaBlocks [Block]
_)  -> Bool
True
      Just (MetaInlines [Inline]
_) -> Bool
True
      Just (MetaString Text
x)  -> Bool -> Bool
not (Text -> Bool
T.null Text
x)
      Just (MetaBool Bool
True) -> Bool
True
      Maybe MetaValue
_                    -> Bool
False

-- | Retrieve the metadata value for a given @key@
-- and extract blocks.
lookupMetaBlocks :: Text -> Meta -> [Block]
lookupMetaBlocks :: Text -> Meta -> [Block]
lookupMetaBlocks Text
key Meta
meta =
  case Text -> Meta -> Maybe MetaValue
lookupMeta Text
key Meta
meta of
         Just (MetaBlocks [Block]
bs)   -> [Block]
bs
         Just (MetaInlines [Inline]
ils) -> [[Inline] -> Block
Plain [Inline]
ils]
         Just (MetaString Text
s)    -> [[Inline] -> Block
Plain [Text -> Inline
Str Text
s]]
         Maybe MetaValue
_                      -> []

-- | Retrieve the metadata value for a given @key@
-- and extract inlines.
lookupMetaInlines :: Text -> Meta -> [Inline]
lookupMetaInlines :: Text -> Meta -> [Inline]
lookupMetaInlines Text
key Meta
meta =
  case Text -> Meta -> Maybe MetaValue
lookupMeta Text
key Meta
meta of
         Just (MetaString Text
s)           -> [Text -> Inline
Str Text
s]
         Just (MetaInlines [Inline]
ils)        -> [Inline]
ils
         Just (MetaBlocks [Plain [Inline]
ils]) -> [Inline]
ils
         Just (MetaBlocks [Para [Inline]
ils])  -> [Inline]
ils
         Maybe MetaValue
_                             -> []

-- | Retrieve the metadata value for a given @key@
-- and convert to String.
lookupMetaString :: Text -> Meta -> Text
lookupMetaString :: Text -> Meta -> Text
lookupMetaString Text
key Meta
meta =
  case Text -> Meta -> Maybe MetaValue
lookupMeta Text
key Meta
meta of
         Just (MetaString Text
s)    -> Text
s
         Just (MetaInlines [Inline]
ils) -> forall a. Walkable Inline a => a -> Text
stringify [Inline]
ils
         Just (MetaBlocks [Block]
bs)   -> forall a. Walkable Inline a => a -> Text
stringify [Block]
bs
         Just (MetaBool Bool
b)      -> String -> Text
T.pack (forall a. Show a => a -> String
show Bool
b)
         Maybe MetaValue
_                      -> Text
""

-- | Tries to convert a character into a unicode superscript version of
-- the character.
toSuperscript :: Char -> Maybe Char
toSuperscript :: Char -> Maybe Char
toSuperscript Char
'1' = forall a. a -> Maybe a
Just Char
'\x00B9'
toSuperscript Char
'2' = forall a. a -> Maybe a
Just Char
'\x00B2'
toSuperscript Char
'3' = forall a. a -> Maybe a
Just Char
'\x00B3'
toSuperscript Char
'+' = forall a. a -> Maybe a
Just Char
'\x207A'
toSuperscript Char
'-' = forall a. a -> Maybe a
Just Char
'\x207B'
toSuperscript Char
'\x2212' = forall a. a -> Maybe a
Just Char
'\x207B' -- unicode minus
toSuperscript Char
'=' = forall a. a -> Maybe a
Just Char
'\x207C'
toSuperscript Char
'(' = forall a. a -> Maybe a
Just Char
'\x207D'
toSuperscript Char
')' = forall a. a -> Maybe a
Just Char
'\x207E'
toSuperscript Char
c
  | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' =
                 forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Char
chr (Int
0x2070 forall a. Num a => a -> a -> a
+ (Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Int
48))
  | Char -> Bool
isSpace Char
c = forall a. a -> Maybe a
Just Char
c
  | Bool
otherwise = forall a. Maybe a
Nothing

-- | Tries to convert a character into a unicode subscript version of
-- the character.
toSubscript :: Char -> Maybe Char
toSubscript :: Char -> Maybe Char
toSubscript Char
'+' = forall a. a -> Maybe a
Just Char
'\x208A'
toSubscript Char
'-' = forall a. a -> Maybe a
Just Char
'\x208B'
toSubscript Char
'=' = forall a. a -> Maybe a
Just Char
'\x208C'
toSubscript Char
'(' = forall a. a -> Maybe a
Just Char
'\x208D'
toSubscript Char
')' = forall a. a -> Maybe a
Just Char
'\x208E'
toSubscript Char
c
  | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' =
                 forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> Char
chr (Int
0x2080 forall a. Num a => a -> a -> a
+ (Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Int
48))
  | Char -> Bool
isSpace Char
c = forall a. a -> Maybe a
Just Char
c
  | Bool
otherwise = forall a. Maybe a
Nothing

-- | Construct table of contents (as a bullet list) from document body.
toTableOfContents :: WriterOptions
                  -> [Block]
                  -> Block
toTableOfContents :: WriterOptions -> [Block] -> Block
toTableOfContents WriterOptions
opts [Block]
bs =
  [[Block]] -> Block
BulletList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
             forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (WriterOptions -> Block -> [Block]
sectionToListItem WriterOptions
opts)
             forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Int -> [Block] -> [Block]
makeSections (WriterOptions -> Bool
writerNumberSections WriterOptions
opts) forall a. Maybe a
Nothing [Block]
bs

-- | Converts a section Div to a list item for a table of contents;
-- returns an empty list if the given block is not a section Div.
sectionToListItem :: WriterOptions -> Block -> [Block]
sectionToListItem :: WriterOptions -> Block -> [Block]
sectionToListItem WriterOptions
opts (Div (Text
ident,[Text]
_,[(Text, Text)]
_)
                         (Header Int
lev (Text
_,[Text]
classes,[(Text, Text)]
kvs) [Inline]
ils : [Block]
subsecs))
  | Int
lev forall a. Ord a => a -> a -> Bool
<= WriterOptions -> Int
writerTOCDepth WriterOptions
opts
  , Bool -> Bool
not (forall a. Maybe a -> Bool
isNothing (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"number" [(Text, Text)]
kvs) Bool -> Bool -> Bool
&& Text
"unlisted" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes)
  = [Inline] -> Block
Plain [Inline]
headerLink forall a. a -> [a] -> [a]
: [[[Block]] -> Block
BulletList [[Block]]
listContents | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Block]]
listContents)]
 where
   num :: Text
num = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"number" [(Text, Text)]
kvs
   addNumber :: [Inline] -> [Inline]
addNumber  = if Text -> Bool
T.null Text
num
                   then forall a. a -> a
id
                   else (Attr -> [Inline] -> Inline
Span (Text
"",[Text
"toc-section-number"],[])
                           [Text -> Inline
Str Text
num] forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline
Space forall a. a -> [a] -> [a]
:)
   clean :: Inline -> [Inline]
clean (Link Attr
_ [Inline]
xs (Text, Text)
_) = [Inline]
xs
   clean (Note [Block]
_) = []
   clean Inline
x = [Inline
x]
   headerText' :: [Inline]
headerText' = [Inline] -> [Inline]
addNumber forall a b. (a -> b) -> a -> b
$ forall a b. Walkable a b => (a -> a) -> b -> b
walk (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Inline -> [Inline]
clean) [Inline]
ils
   headerLink :: [Inline]
headerLink = if Text -> Bool
T.null Text
ident
                   then [Inline]
headerText'
                   else [Attr -> [Inline] -> (Text, Text) -> Inline
Link (Text
"toc-" forall a. Semigroup a => a -> a -> a
<> Text
ident, [], []) [Inline]
headerText' (Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
ident, Text
"")]
   listContents :: [[Block]]
listContents = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (WriterOptions -> Block -> [Block]
sectionToListItem WriterOptions
opts) [Block]
subsecs
sectionToListItem WriterOptions
_ Block
_ = []

-- | Returns 'True' iff the list of blocks has a @'Plain'@ as its last
-- element.
endsWithPlain :: [Block] -> Bool
endsWithPlain :: [Block] -> Bool
endsWithPlain [Block]
xs =
  case forall a. [a] -> Maybe a
lastMay [Block]
xs of
    Just Plain{} -> Bool
True
    Just (BulletList [[Block]]
is) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False [Block] -> Bool
endsWithPlain (forall a. [a] -> Maybe a
lastMay [[Block]]
is)
    Just (OrderedList ListAttributes
_ [[Block]]
is) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False [Block] -> Bool
endsWithPlain (forall a. [a] -> Maybe a
lastMay [[Block]]
is)
    Maybe Block
_ -> Bool
False

-- | Convert the relevant components of a new-style table (with block
-- caption, row headers, row and column spans, and so on) to those of
-- an old-style table (inline caption, table head with one row, no
-- foot, and so on). Cells with a 'RowSpan' and 'ColSpan' of @(h, w)@
-- will be cut up into @h * w@ cells of dimension @(1, 1)@, with the
-- content placed in the upper-left corner.
toLegacyTable :: Caption
              -> [ColSpec]
              -> TableHead
              -> [TableBody]
              -> TableFoot
              -> ([Inline], [Alignment], [Double], [[Block]], [[[Block]]])
toLegacyTable :: Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> ([Inline], [Alignment], [Double], [[Block]], [[[Block]]])
toLegacyTable (Caption Maybe [Inline]
_ [Block]
cbody) [ColSpec]
specs TableHead
thead [TableBody]
tbodies TableFoot
tfoot
  = ([Inline]
cbody', [Alignment]
aligns, [Double]
widths, [[Block]]
th', [[[Block]]]
tb')
  where
    numcols :: Int
numcols = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ColSpec]
specs
    ([Alignment]
aligns, [ColWidth]
mwidths) = forall a b. [(a, b)] -> ([a], [b])
unzip [ColSpec]
specs
    fromWidth :: ColWidth -> Double
fromWidth (ColWidth Double
w) | Double
w forall a. Ord a => a -> a -> Bool
> Double
0 = Double
w
    fromWidth ColWidth
_                    = Double
0
    widths :: [Double]
widths = forall a b. (a -> b) -> [a] -> [b]
map ColWidth -> Double
fromWidth [ColWidth]
mwidths
    unRow :: Row -> [Cell]
unRow (Row Attr
_ [Cell]
x) = [Cell]
x
    unBody :: TableBody -> [Row]
unBody (TableBody Attr
_ RowHeadColumns
_ [Row]
hd [Row]
bd) = [Row]
hd forall a. Semigroup a => a -> a -> a
<> [Row]
bd
    unBodies :: [TableBody] -> [Row]
unBodies = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TableBody -> [Row]
unBody

    TableHead Attr
_ [Row]
th = Int -> TableHead -> TableHead
Builder.normalizeTableHead Int
numcols TableHead
thead
    tb :: [TableBody]
tb = forall a b. (a -> b) -> [a] -> [b]
map (Int -> TableBody -> TableBody
Builder.normalizeTableBody Int
numcols) [TableBody]
tbodies
    TableFoot Attr
_ [Row]
tf = Int -> TableFoot -> TableFoot
Builder.normalizeTableFoot Int
numcols TableFoot
tfoot

    cbody' :: [Inline]
cbody' = [Block] -> [Inline]
blocksToInlines [Block]
cbody

    ([[Block]]
th', [[[Block]]]
tb') = case [Row]
th of
      Row
r:[Row]
rs -> let ([[[Block]]]
pendingPieces, [[Block]]
r') = [[[Block]]] -> [Cell] -> ([[[Block]]], [[Block]])
placeCutCells [] forall a b. (a -> b) -> a -> b
$ Row -> [Cell]
unRow Row
r
                  rs' :: [[[Block]]]
rs' = [[[Block]]] -> [Row] -> [[[Block]]]
cutRows [[[Block]]]
pendingPieces forall a b. (a -> b) -> a -> b
$ [Row]
rs forall a. Semigroup a => a -> a -> a
<> [TableBody] -> [Row]
unBodies [TableBody]
tb forall a. Semigroup a => a -> a -> a
<> [Row]
tf
              in ([[Block]]
r', [[[Block]]]
rs')
      []    -> ([], [[[Block]]] -> [Row] -> [[[Block]]]
cutRows [] forall a b. (a -> b) -> a -> b
$ [TableBody] -> [Row]
unBodies [TableBody]
tb forall a. Semigroup a => a -> a -> a
<> [Row]
tf)

    -- Adapted from placeRowSection in Builders. There is probably a
    -- more abstract foldRowSection that unifies them both.
    placeCutCells :: [[[Block]]] -> [Cell] -> ([[[Block]]], [[Block]])
placeCutCells [[[Block]]]
pendingPieces [Cell]
cells
      -- If there are any pending pieces for a column, add
      -- them. Pending pieces have preference over cells due to grid
      -- layout rules.
      | ([Block]
p:[[Block]]
ps):[[[Block]]]
pendingPieces' <- [[[Block]]]
pendingPieces
      = let ([[[Block]]]
pendingPieces'', [[Block]]
rowPieces) = [[[Block]]] -> [Cell] -> ([[[Block]]], [[Block]])
placeCutCells [[[Block]]]
pendingPieces' [Cell]
cells
        in ([[Block]]
ps forall a. a -> [a] -> [a]
: [[[Block]]]
pendingPieces'', [Block]
p forall a. a -> [a] -> [a]
: [[Block]]
rowPieces)
      -- Otherwise cut up a cell on the row and deal with its pieces.
      | Cell
c:[Cell]
cells' <- [Cell]
cells
      = let (Int
h, Int
w, [Block]
cBody) = Cell -> (Int, Int, [Block])
getComponents Cell
c
            cRowPieces :: [[Block]]
cRowPieces = [Block]
cBody forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a]
replicate (Int
w forall a. Num a => a -> a -> a
- Int
1) forall a. Monoid a => a
mempty
            cPendingPieces :: [[[Block]]]
cPendingPieces = forall a. Int -> a -> [a]
replicate Int
w forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Int
h forall a. Num a => a -> a -> a
- Int
1) forall a. Monoid a => a
mempty
            pendingPieces' :: [[[Block]]]
pendingPieces' = forall a. Int -> [a] -> [a]
drop Int
w [[[Block]]]
pendingPieces
            ([[[Block]]]
pendingPieces'', [[Block]]
rowPieces) = [[[Block]]] -> [Cell] -> ([[[Block]]], [[Block]])
placeCutCells [[[Block]]]
pendingPieces' [Cell]
cells'
        in ([[[Block]]]
cPendingPieces forall a. Semigroup a => a -> a -> a
<> [[[Block]]]
pendingPieces'', [[Block]]
cRowPieces forall a. Semigroup a => a -> a -> a
<> [[Block]]
rowPieces)
      | Bool
otherwise = ([], [])

    cutRows :: [[[Block]]] -> [Row] -> [[[Block]]]
cutRows [[[Block]]]
pendingPieces (Row
r:[Row]
rs)
      = let ([[[Block]]]
pendingPieces', [[Block]]
r') = [[[Block]]] -> [Cell] -> ([[[Block]]], [[Block]])
placeCutCells [[[Block]]]
pendingPieces forall a b. (a -> b) -> a -> b
$ Row -> [Cell]
unRow Row
r
            rs' :: [[[Block]]]
rs' = [[[Block]]] -> [Row] -> [[[Block]]]
cutRows [[[Block]]]
pendingPieces' [Row]
rs
        in [[Block]]
r' forall a. a -> [a] -> [a]
: [[[Block]]]
rs'
    cutRows [[[Block]]]
_ [] = []

    getComponents :: Cell -> (Int, Int, [Block])
getComponents (Cell Attr
_ Alignment
_ (RowSpan Int
h) (ColSpan Int
w) [Block]
body)
      = (Int
h, Int
w, [Block]
body)

splitSentences :: Doc Text -> Doc Text
splitSentences :: Doc Text -> Doc Text
splitSentences = [Doc Text] -> Doc Text
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Doc a -> [Doc a]
toList
 where
  go :: [Doc Text] -> Doc Text
go [] = forall a. Monoid a => a
mempty
  go (Text Int
len Text
t : Doc Text
BreakingSpace : [Doc Text]
xs) =
     if Text -> Bool
isSentenceEnding Text
t
        then forall a. Int -> a -> Doc a
Text Int
len Text
t forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
NewLine forall a. Semigroup a => a -> a -> a
<> [Doc Text] -> Doc Text
go [Doc Text]
xs
        else forall a. Int -> a -> Doc a
Text Int
len Text
t forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
BreakingSpace forall a. Semigroup a => a -> a -> a
<> [Doc Text] -> Doc Text
go [Doc Text]
xs
  go (Doc Text
x:[Doc Text]
xs) = Doc Text
x forall a. Semigroup a => a -> a -> a
<> [Doc Text] -> Doc Text
go [Doc Text]
xs

  toList :: Doc a -> [Doc a]
toList (Concat (Concat Doc a
a Doc a
b) Doc a
c) = Doc a -> [Doc a]
toList (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
a (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
b Doc a
c))
  toList (Concat Doc a
a Doc a
b) = Doc a
a forall a. a -> [a] -> [a]
: Doc a -> [Doc a]
toList Doc a
b
  toList Doc a
x = [Doc a
x]

  isSentenceEnding :: Text -> Bool
isSentenceEnding Text
t =
    case Text -> Maybe (Text, Char)
T.unsnoc Text
t of
      Just (Text
t',Char
c)
        | Char
c forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'!' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'?' -> Bool
True
        | Char
c forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
']' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x201D' ->
           case Text -> Maybe (Text, Char)
T.unsnoc Text
t' of
             Just (Text
_,Char
d) -> Char
d forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
d forall a. Eq a => a -> a -> Bool
== Char
'!' Bool -> Bool -> Bool
|| Char
d forall a. Eq a => a -> a -> Bool
== Char
'?'
             Maybe (Text, Char)
_ -> Bool
False
      Maybe (Text, Char)
_ -> Bool
False

-- | Ensure that all identifiers start with a letter,
-- and modify internal links accordingly. (Yes, XML allows an
-- underscore, but HTML 4 doesn't, so we are more conservative.)
ensureValidXmlIdentifiers :: Pandoc -> Pandoc
ensureValidXmlIdentifiers :: Pandoc -> Pandoc
ensureValidXmlIdentifiers = forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
fixLinks forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attr -> Attr) -> Pandoc -> Pandoc
walkAttr forall {b} {c}. (Text, b, c) -> (Text, b, c)
fixIdentifiers
 where
  fixIdentifiers :: (Text, b, c) -> (Text, b, c)
fixIdentifiers (Text
ident, b
classes, c
kvs) =
    (case Text -> Maybe (Char, Text)
T.uncons Text
ident of
      Maybe (Char, Text)
Nothing -> Text
ident
      Just (Char
c, Text
_) | Char -> Bool
isLetter Char
c -> Text
ident
      Maybe (Char, Text)
_ -> Text
"id_" forall a. Semigroup a => a -> a -> a
<> Text
ident,
     b
classes, c
kvs)
  needsFixing :: Text -> Maybe Text
needsFixing Text
src =
    case Text -> Maybe (Char, Text)
T.uncons Text
src of
      Just (Char
'#',Text
t) ->
        case Text -> Maybe (Char, Text)
T.uncons Text
t of
          Just (Char
c,Text
_) | Bool -> Bool
not (Char -> Bool
isLetter Char
c) -> forall a. a -> Maybe a
Just (Text
"#id_" forall a. Semigroup a => a -> a -> a
<> Text
t)
          Maybe (Char, Text)
_ -> forall a. Maybe a
Nothing
      Maybe (Char, Text)
_ -> forall a. Maybe a
Nothing
  fixLinks :: Inline -> Inline
fixLinks (Link Attr
attr [Inline]
ils (Text
src, Text
tit))
    | Just Text
src' <- Text -> Maybe Text
needsFixing Text
src = Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attr [Inline]
ils (Text
src', Text
tit)
  fixLinks (Image Attr
attr [Inline]
ils (Text
src, Text
tit))
    | Just Text
src' <- Text -> Maybe Text
needsFixing Text
src = Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
ils (Text
src', Text
tit)
  fixLinks Inline
x = Inline
x

-- | Walk Pandoc document, modifying attributes.
walkAttr :: (Attr -> Attr) -> Pandoc -> Pandoc
walkAttr :: (Attr -> Attr) -> Pandoc -> Pandoc
walkAttr Attr -> Attr
f = forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
goInline forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Walkable a b => (a -> a) -> b -> b
walk Block -> Block
goBlock
 where
  goInline :: Inline -> Inline
goInline (Span Attr
attr [Inline]
ils) = Attr -> [Inline] -> Inline
Span (Attr -> Attr
f Attr
attr) [Inline]
ils
  goInline (Link Attr
attr [Inline]
ils (Text, Text)
target) = Attr -> [Inline] -> (Text, Text) -> Inline
Link (Attr -> Attr
f Attr
attr) [Inline]
ils (Text, Text)
target
  goInline (Image Attr
attr [Inline]
ils (Text, Text)
target) = Attr -> [Inline] -> (Text, Text) -> Inline
Image (Attr -> Attr
f Attr
attr) [Inline]
ils (Text, Text)
target
  goInline (Code Attr
attr Text
txt) = Attr -> Text -> Inline
Code (Attr -> Attr
f Attr
attr) Text
txt
  goInline Inline
x = Inline
x

  goBlock :: Block -> Block
goBlock (Header Int
lev Attr
attr [Inline]
ils) = Int -> Attr -> [Inline] -> Block
Header Int
lev (Attr -> Attr
f Attr
attr) [Inline]
ils
  goBlock (CodeBlock Attr
attr Text
txt) = Attr -> Text -> Block
CodeBlock (Attr -> Attr
f Attr
attr) Text
txt
  goBlock (Table Attr
attr Caption
cap [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot) =
    Attr
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> Block
Table (Attr -> Attr
f Attr
attr) Caption
cap [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot
  goBlock (Div Attr
attr [Block]
bs) = Attr -> [Block] -> Block
Div (Attr -> Attr
f Attr
attr) [Block]
bs
  goBlock Block
x = Block
x