{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{- |
   Module      : Text.Pandoc.Writers.Shared
   Copyright   : Copyright (C) 2013-2024 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
                     , htmlAddStyle
                     , htmlAlignmentToString
                     , htmlAttrs
                     , isDisplayMath
                     , fixDisplayMath
                     , unsmartify
                     , gridTable
                     , lookupMetaBool
                     , lookupMetaBlocks
                     , lookupMetaInlines
                     , lookupMetaString
                     , stripLeadingTrailingSpace
                     , toSubscript
                     , toSuperscript
                     , toSubscriptInline
                     , toSuperscriptInline
                     , toTableOfContents
                     , endsWithPlain
                     , toLegacyTable
                     , splitSentences
                     , ensureValidXmlIdentifiers
                     , setupTranslations
                     , isOrderedListMarker
                     , toTaskListItem
                     , delimited
                     )
where
import Safe (lastMay, maximumMay, atDef)
import qualified Data.ByteString.Lazy as BL
import Control.Monad (MonadPlus, mzero)
import Data.Either (isRight)
import Data.Aeson (ToJSON (..), encode)
import Data.Char (chr, ord, isSpace, isLetter, isUpper)
import Data.List (groupBy, intersperse, foldl', transpose)
import Data.List.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.CSS (cssAttributes)
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Parsing (runParser, eof, defaultParserState,
                            anyOrderedListMarker)
import Text.DocLayout
import Text.Pandoc.Shared (stringify, makeSections, blocksToInlines)
import Text.Pandoc.Walk (Walkable(..))
import qualified Text.Pandoc.UTF8 as UTF8
import Text.Pandoc.XML (escapeStringForXML)
import Text.DocTemplates (Context(..), Val(..), TemplateTarget,
                          ToContext(..), FromContext(..))
import Text.Pandoc.Chunks (tocToList, toTOCTree)
import Text.Collate.Lang (Lang (..))
import Text.Pandoc.Class (PandocMonad, toLang)
import Text.Pandoc.Translations (setTranslations)
import Data.Maybe (fromMaybe)
import qualified Text.Pandoc.Writers.AnnotatedTable as Ann

-- import Debug.Trace

-- | 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 -> Context a -> m (Context a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Context a
forall a. Monoid a => a
mempty
    Just Template Text
_  -> WriterOptions -> Context a -> Context a
forall a.
TemplateTarget a =>
WriterOptions -> Context a -> Context a
addVariablesToContext WriterOptions
opts (Context a -> Context a) -> m (Context a) -> m (Context a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                ([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> Meta -> m (Context a)
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) =
  Map Text (Val a) -> Context a
forall a. Map Text (Val a) -> Context a
Context (Map Text (Val a) -> Context a)
-> m (Map Text (Val a)) -> m (Context a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> m (Val a))
-> Map Text MetaValue -> m (Map Text (Val a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Text a -> m (Map Text b)
mapM (([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> MetaValue -> m (Val a)
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 Context a -> Context a -> Context a
forall a. Semigroup a => a -> a -> a
<> (Text -> a
forall a. FromText a => Text -> a
fromText (Text -> a) -> Context Text -> Context a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> Context Text
writerVariables WriterOptions
opts) Context a -> Context a -> Context a
forall a. Semigroup a => a -> a -> a
<> Context a
c1
 where
   c2 :: Context a
c2 = Map Text (Val a) -> Context a
forall a. Map Text (Val a) -> Context a
Context (Map Text (Val a) -> Context a) -> Map Text (Val a) -> Context a
forall a b. (a -> b) -> a -> b
$
          Text -> Val a -> Map Text (Val a) -> Map Text (Val a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
"meta-json" (Doc a -> Val a
forall a. Doc a -> Val a
SimpleVal (Doc a -> Val a) -> Doc a -> Val a
forall a b. (a -> b) -> a -> b
$ a -> Doc a
forall a. HasChars a => a -> Doc a
literal (a -> Doc a) -> a -> Doc a
forall a b. (a -> b) -> a -> b
$ Text -> a
forall a. FromText a => Text -> a
fromText Text
jsonrep)
                               Map Text (Val a)
forall a. Monoid a => a
mempty
   jsonrep :: Text
jsonrep = ByteString -> Text
UTF8.toText (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ LazyByteString -> ByteString
BL.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
encode (Value -> LazyByteString) -> Value -> LazyByteString
forall a b. (a -> b) -> a -> b
$ Context a -> Value
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) =
  Context a -> Val a
forall a. Context a -> Val a
MapVal (Context a -> Val a)
-> (Map Text (Val a) -> Context a) -> Map Text (Val a) -> Val a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Val a) -> Context a
forall a. Map Text (Val a) -> Context a
Context (Map Text (Val a) -> Val a) -> m (Map Text (Val a)) -> m (Val a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MetaValue -> m (Val a))
-> Map Text MetaValue -> m (Map Text (Val a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Map Text a -> m (Map Text b)
mapM (([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> MetaValue -> m (Val a)
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) = [Val a] -> Val a
forall a. [Val a] -> Val a
ListVal ([Val a] -> Val a) -> m [Val a] -> m (Val a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  (MetaValue -> m (Val a)) -> [MetaValue] -> m [Val a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Block] -> m (Doc a))
-> ([Inline] -> m (Doc a)) -> MetaValue -> m (Val a)
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) = Val a -> m (Val a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Val a -> m (Val a)) -> Val a -> m (Val a)
forall a b. (a -> b) -> a -> b
$ Bool -> Val a
forall a. Bool -> Val a
BoolVal Bool
b
metaValueToVal [Block] -> m (Doc a)
_ [Inline] -> m (Doc a)
inlineWriter (MetaString Text
s) =
   Doc a -> Val a
forall a. Doc a -> Val a
SimpleVal (Doc a -> Val a) -> m (Doc a) -> m (Val a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Inline] -> m (Doc a)
inlineWriter (Many Inline -> [Inline]
forall a. Many a -> [a]
Builder.toList (Text -> Many Inline
Builder.text Text
s))
metaValueToVal [Block] -> m (Doc a)
blockWriter [Inline] -> m (Doc a)
_ (MetaBlocks [Block]
bs) = Doc a -> Val a
forall a. Doc a -> Val a
SimpleVal (Doc a -> Val a) -> m (Doc a) -> m (Val a)
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) = Doc a -> Val a
forall a. Doc a -> Val a
SimpleVal (Doc a -> Val a) -> m (Doc a) -> m (Val a)
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) = Text -> Map Text (Val a) -> Maybe (Val a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
field Map Text (Val a)
m Maybe (Val a) -> (Val a -> Maybe b) -> Maybe b
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val a -> Maybe 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) =
  Map Text (Val a) -> Context a
forall a. Map Text (Val a) -> Context a
Context (Map Text (Val a) -> Context a) -> Map Text (Val a) -> Context a
forall a b. (a -> b) -> a -> b
$ (Val a -> Val a -> Val a)
-> Text -> Val a -> Map Text (Val a) -> Map Text (Val a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Val a -> Val a -> Val a
forall {a}. Val a -> Val a -> Val a
combine Text
field (b -> Val a
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)   = [Val a] -> Val a
forall a. [Val a] -> Val a
ListVal ([Val a]
xs [Val a] -> [Val a] -> [Val a]
forall a. [a] -> [a] -> [a]
++ [Val a
newval])
  combine Val a
newval Val a
x              = [Val a] -> Val a
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) =
  Map Text (Val a) -> Context a
forall a. Map Text (Val a) -> Context a
Context (Text -> Val a -> Map Text (Val a) -> Map Text (Val a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
field (b -> Val a
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) =
  Map Text (Val a) -> Context a
forall a. Map Text (Val a) -> Context a
Context ((Val a -> Val a -> Val a)
-> Text -> Val a -> Map Text (Val a) -> Map Text (Val a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Val a -> Val a -> Val a
forall {p} {p}. p -> p -> p
f Text
field (b -> Val a
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 Text -> Context Text -> Maybe Text
forall a b. FromContext a b => Text -> Context a -> Maybe b
lookupContext Text
"lang" (WriterOptions -> Context Text
writerVariables WriterOptions
opts) of
        Just Text
s -> Text -> Maybe Text
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]])  -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
               Just (MetaBlocks [Plain [Str Text
s]]) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
               Just (MetaInlines [Str Text
s])        -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
               Just (MetaString Text
s)               -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
               Maybe MetaValue
_                                 -> Maybe Text
forall a. Maybe a
Nothing

-- | Produce an HTML tag with the given pandoc attributes.
tagWithAttrs :: HasChars a => a -> Attr -> Doc a
tagWithAttrs :: forall a. HasChars a => a -> Attr -> Doc a
tagWithAttrs a
tag Attr
attr = Doc a
"<" Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> a -> Doc a
forall a. HasChars a => a -> Doc a
literal a
tag Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> (Attr -> Doc a
forall a. HasChars a => Attr -> Doc a
htmlAttrs Attr
attr) Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
">"

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

addSpaceIfNotEmpty :: HasChars a => Doc a -> Doc a
addSpaceIfNotEmpty :: forall a. HasChars a => Doc a -> Doc a
addSpaceIfNotEmpty Doc a
f = if Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
f then Doc a
f else Doc a
" " Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
f

-- | Adds a key-value pair to the @style@ attribute.
htmlAddStyle :: (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
htmlAddStyle :: (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
htmlAddStyle (Text
key, Text
value) [(Text, Text)]
kvs =
  let cssToStyle :: [(Text, Text)] -> Text
cssToStyle = Text -> [Text] -> Text
T.intercalate Text
" " ([Text] -> Text)
-> ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, Text
v) -> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";")
  in case ((Text, Text) -> Bool)
-> [(Text, Text)] -> ([(Text, Text)], [(Text, Text)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"style") (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) [(Text, Text)]
kvs of
    ([(Text, Text)]
_, []) ->
      -- no style attribute yet, add new one
      (Text
"style", [(Text, Text)] -> Text
cssToStyle [(Text
key, Text
value)]) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
kvs
    ([(Text, Text)]
xs, (Text
_,Text
cssStyles):[(Text, Text)]
rest) ->
      -- modify the style attribute
      [(Text, Text)]
xs [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ (Text
"style", [(Text, Text)] -> Text
cssToStyle [(Text, Text)]
modifiedCssStyles) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
rest
      where
        modifiedCssStyles :: [(Text, Text)]
modifiedCssStyles =
          case ((Text, Text) -> Bool)
-> [(Text, Text)] -> ([(Text, Text)], [(Text, Text)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key) (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) ([(Text, Text)] -> ([(Text, Text)], [(Text, Text)]))
-> [(Text, Text)] -> ([(Text, Text)], [(Text, Text)])
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Text)]
cssAttributes Text
cssStyles of
            ([(Text, Text)]
cssAttribs, []) -> (Text
key, Text
value) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
cssAttribs
            ([(Text, Text)]
pre, (Text, Text)
_:[(Text, Text)]
post)    -> [(Text, Text)]
pre [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++ (Text
key, Text
value) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
post

-- | Get the html representation of an alignment key
htmlAlignmentToString :: Alignment -> Maybe Text
htmlAlignmentToString :: Alignment -> Maybe Text
htmlAlignmentToString = \case
  Alignment
AlignLeft    -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"left"
  Alignment
AlignRight   -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"right"
  Alignment
AlignCenter  -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"center"
  Alignment
AlignDefault -> Maybe Text
forall a. Maybe a
Nothing

-- | 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 ([Inline] -> [Inline])
-> ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> [Inline]
forall a. [a] -> [a]
reverse ([Inline] -> [Inline])
-> ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> [Inline]
go ([Inline] -> [Inline])
-> ([Inline] -> [Inline]) -> [Inline] -> [Inline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> [Inline]
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)
  | (Inline -> Bool) -> [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Inline -> Bool
isDisplayMath [Inline]
lst Bool -> Bool -> Bool
&& Bool -> Bool
not ((Inline -> Bool) -> [Inline] -> Bool
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"],[]) ([Block] -> Block) -> [Block] -> Block
forall a b. (a -> b) -> a -> b
$
       ([Inline] -> Block) -> [[Inline]] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Block
Plain ([[Inline]] -> [Block]) -> [[Inline]] -> [Block]
forall a b. (a -> b) -> a -> b
$
       ([Inline] -> Bool) -> [[Inline]] -> [[Inline]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Inline] -> Bool) -> [Inline] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Inline]] -> [[Inline]]) -> [[Inline]] -> [[Inline]]
forall a b. (a -> b) -> a -> b
$
       ([Inline] -> [Inline]) -> [[Inline]] -> [[Inline]]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> [Inline]
stripLeadingTrailingSpace ([[Inline]] -> [[Inline]]) -> [[Inline]] -> [[Inline]]
forall a b. (a -> b) -> a -> b
$
       (Inline -> Inline -> Bool) -> [Inline] -> [[Inline]]
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)
  | (Inline -> Bool) -> [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Inline -> Bool
isDisplayMath [Inline]
lst Bool -> Bool -> Bool
&& Bool -> Bool
not ((Inline -> Bool) -> [Inline] -> Bool
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"],[]) ([Block] -> Block) -> [Block] -> Block
forall a b. (a -> b) -> a -> b
$
       ([Inline] -> Block) -> [[Inline]] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> Block
Para ([[Inline]] -> [Block]) -> [[Inline]] -> [Block]
forall a b. (a -> b) -> a -> b
$
       ([Inline] -> Bool) -> [[Inline]] -> [[Inline]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Inline] -> Bool) -> [Inline] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Inline] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Inline]] -> [[Inline]]) -> [[Inline]] -> [[Inline]]
forall a b. (a -> b) -> a -> b
$
       ([Inline] -> [Inline]) -> [[Inline]] -> [[Inline]]
forall a b. (a -> b) -> [a] -> [b]
map [Inline] -> [Inline]
stripLeadingTrailingSpace ([[Inline]] -> [[Inline]]) -> [[Inline]] -> [[Inline]]
forall a b. (a -> b) -> a -> b
$
       (Inline -> Inline -> Bool) -> [Inline] -> [[Inline]]
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 ((Char -> Text) -> Text -> Text) -> (Char -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ \Char
c -> case Char
c of
  Char
'\8217' -> Text
"'"
  Char
'\8230' -> Text
"..."
  Char
'\8211'
    | Extension -> WriterOptions -> Bool
forall a. HasSyntaxExtensions a => Extension -> a -> Bool
isEnabled Extension
Ext_old_dashes WriterOptions
opts -> Text
"-"
    | Bool
otherwise                     -> Text
"--"
  Char
'\8212'
    | Extension -> WriterOptions -> Bool
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
           => WriterOptions
           -> (WriterOptions -> [Block] -> m (Doc Text)) -- ^ format Doc writer
           -> [ColSpec]
           -> TableHead
           -> [TableBody]
           -> TableFoot
           -> m (Doc Text)
gridTable :: forall (m :: * -> *).
Monad m =>
WriterOptions
-> (WriterOptions -> [Block] -> m (Doc Text))
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> m (Doc Text)
gridTable WriterOptions
opts WriterOptions -> [Block] -> m (Doc Text)
blocksToDoc [ColSpec]
colspecs' TableHead
thead' [TableBody]
tbodies' TableFoot
tfoot' = do
  let Ann.Table Attr
_ Caption
_ [ColSpec]
colspecs TableHead
thead [TableBody]
tbodies TableFoot
tfoot =
        Attr
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> Table
Ann.toTable Attr
forall a. Monoid a => a
mempty (Maybe [Inline] -> [Block] -> Caption
Caption Maybe [Inline]
forall a. Maybe a
Nothing [Block]
forall a. Monoid a => a
mempty)
                    [ColSpec]
colspecs' TableHead
thead' [TableBody]
tbodies' TableFoot
tfoot'
  let widths :: [Int]
widths = (ColSpec -> Int) -> [ColSpec] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (WriterOptions -> Double -> Int
toCharWidth WriterOptions
opts (Double -> Int) -> (ColSpec -> Double) -> ColSpec -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColSpec -> Double
getColWidth) [ColSpec]
colspecs
  let renderRows :: [[Cell]] -> m [[RenderedCell Text]]
renderRows = ([[RenderedCell Text]] -> [[RenderedCell Text]])
-> m [[RenderedCell Text]] -> m [[RenderedCell Text]]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([RenderedCell Text] -> [RenderedCell Text])
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [RenderedCell Text] -> [RenderedCell Text]
addDummies [Int]
widths)) (m [[RenderedCell Text]] -> m [[RenderedCell Text]])
-> ([[Cell]] -> m [[RenderedCell Text]])
-> [[Cell]]
-> m [[RenderedCell Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Cell] -> m [RenderedCell Text])
-> [[Cell]] -> m [[RenderedCell Text]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (WriterOptions
-> (WriterOptions -> [Block] -> m (Doc Text))
-> [Cell]
-> m [RenderedCell Text]
forall (m :: * -> *) a.
(Monad m, HasChars a) =>
WriterOptions
-> (WriterOptions -> [Block] -> m (Doc a))
-> [Cell]
-> m [RenderedCell a]
gridRow WriterOptions
opts WriterOptions -> [Block] -> m (Doc Text)
blocksToDoc)
  let getHeadCells :: HeaderRow -> [Cell]
getHeadCells (Ann.HeaderRow Attr
_ RowNumber
_ [Cell]
cells) = [Cell]
cells
  let getHeadRows :: TableHead -> [[Cell]]
getHeadRows (Ann.TableHead Attr
_ [HeaderRow]
rs) = (HeaderRow -> [Cell]) -> [HeaderRow] -> [[Cell]]
forall a b. (a -> b) -> [a] -> [b]
map HeaderRow -> [Cell]
getHeadCells [HeaderRow]
rs
  [[RenderedCell Text]]
headCells <- [[Cell]] -> m [[RenderedCell Text]]
renderRows (TableHead -> [[Cell]]
getHeadRows TableHead
thead)
  let getFootRows :: TableFoot -> [[Cell]]
getFootRows (Ann.TableFoot Attr
_ [HeaderRow]
xs) = (HeaderRow -> [Cell]) -> [HeaderRow] -> [[Cell]]
forall a b. (a -> b) -> [a] -> [b]
map HeaderRow -> [Cell]
getHeadCells [HeaderRow]
xs
  [[RenderedCell Text]]
footCells <- [[Cell]] -> m [[RenderedCell Text]]
renderRows (TableFoot -> [[Cell]]
getFootRows TableFoot
tfoot)
  let getBodyCells :: BodyRow -> [Cell]
getBodyCells (Ann.BodyRow Attr
_ RowNumber
_ [Cell]
_ [Cell]
cells) = [Cell]
cells
  let getBody :: TableBody -> [[Cell]]
getBody (Ann.TableBody Attr
_ RowHeadColumns
_ [HeaderRow]
hs [BodyRow]
xs) = (HeaderRow -> [Cell]) -> [HeaderRow] -> [[Cell]]
forall a b. (a -> b) -> [a] -> [b]
map HeaderRow -> [Cell]
getHeadCells [HeaderRow]
hs [[Cell]] -> [[Cell]] -> [[Cell]]
forall a. Semigroup a => a -> a -> a
<> (BodyRow -> [Cell]) -> [BodyRow] -> [[Cell]]
forall a b. (a -> b) -> [a] -> [b]
map BodyRow -> [Cell]
getBodyCells [BodyRow]
xs
  [[[RenderedCell Text]]]
bodyCells <- (TableBody -> m [[RenderedCell Text]])
-> [TableBody] -> m [[[RenderedCell Text]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([[Cell]] -> m [[RenderedCell Text]]
renderRows ([[Cell]] -> m [[RenderedCell Text]])
-> (TableBody -> [[Cell]]) -> TableBody -> m [[RenderedCell Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableBody -> [[Cell]]
getBody) [TableBody]
tbodies
  let rows :: [[RenderedCell Text]]
rows = LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setTopBorder LineStyle
SingleLine [[RenderedCell Text]]
headCells [[RenderedCell Text]]
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a. [a] -> [a] -> [a]
++
             (LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setTopBorder (if [[RenderedCell Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[RenderedCell Text]]
headCells then LineStyle
SingleLine else LineStyle
DoubleLine)
              ([[RenderedCell Text]] -> [[RenderedCell Text]])
-> ([[RenderedCell Text]] -> [[RenderedCell Text]])
-> [[RenderedCell Text]]
-> [[RenderedCell Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setBottomBorder LineStyle
SingleLine) ([[[RenderedCell Text]]] -> [[RenderedCell Text]]
forall a. Monoid a => [a] -> a
mconcat [[[RenderedCell Text]]]
bodyCells) [[RenderedCell Text]]
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a. [a] -> [a] -> [a]
++
             (if [[RenderedCell Text]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[RenderedCell Text]]
footCells
                 then [[RenderedCell Text]]
forall a. Monoid a => a
mempty
                 else LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setTopBorder LineStyle
DoubleLine ([[RenderedCell Text]] -> [[RenderedCell Text]])
-> ([[RenderedCell Text]] -> [[RenderedCell Text]])
-> [[RenderedCell Text]]
-> [[RenderedCell Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setBottomBorder LineStyle
DoubleLine ([[RenderedCell Text]] -> [[RenderedCell Text]])
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a b. (a -> b) -> a -> b
$
                       [[RenderedCell Text]]
footCells)
  let cellHasColSpan :: RenderedCell a -> Bool
cellHasColSpan RenderedCell a
c = RenderedCell a -> Int
forall a. RenderedCell a -> Int
cellColSpan RenderedCell a
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
  let hasColSpans :: Bool
hasColSpans = ([RenderedCell Text] -> Bool) -> [[RenderedCell Text]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((RenderedCell Text -> Bool) -> [RenderedCell Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RenderedCell Text -> Bool
forall {a}. RenderedCell a -> Bool
cellHasColSpan) [[RenderedCell Text]]
rows
  let isSimple :: Bool
isSimple = (ColSpec -> Bool) -> [ColSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((ColWidth -> ColWidth -> Bool
forall a. Eq a => a -> a -> Bool
== ColWidth
ColWidthDefault) (ColWidth -> Bool) -> (ColSpec -> ColWidth) -> ColSpec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ColSpec -> ColWidth
forall a b. (a, b) -> b
snd) [ColSpec]
colspecs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hasColSpans
  Doc Text -> m (Doc Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc Text -> m (Doc Text)) -> Doc Text -> m (Doc Text)
forall a b. (a -> b) -> a -> b
$ [[RenderedCell Text]] -> Doc Text
gridRows ([[RenderedCell Text]] -> Doc Text)
-> [[RenderedCell Text]] -> Doc Text
forall a b. (a -> b) -> a -> b
$
    if Bool -> Bool
not Bool
hasColSpans  -- TODO: figure out how to calculate widths with colspans
       then Bool
-> WriterOptions -> [[RenderedCell Text]] -> [[RenderedCell Text]]
redoWidths Bool
isSimple WriterOptions
opts [[RenderedCell Text]]
rows
       else [[RenderedCell Text]]
rows

redoWidths :: Bool -> WriterOptions -> [[RenderedCell Text]] -> [[RenderedCell Text]]
redoWidths :: Bool
-> WriterOptions -> [[RenderedCell Text]] -> [[RenderedCell Text]]
redoWidths Bool
_ WriterOptions
_ [] = []
redoWidths Bool
isSimple WriterOptions
opts rows :: [[RenderedCell Text]]
rows@([RenderedCell Text]
r:[[RenderedCell Text]]
_) =
  ([RenderedCell Text] -> [RenderedCell Text])
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a b. (a -> b) -> [a] -> [b]
map (\[RenderedCell Text]
cs -> (Int -> RenderedCell Text -> RenderedCell Text)
-> [Int] -> [RenderedCell Text] -> [RenderedCell Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> RenderedCell Text -> RenderedCell Text
forall {a}. Int -> RenderedCell a -> RenderedCell a
resetWidth [Int]
newwidths [RenderedCell Text]
cs) [[RenderedCell Text]]
rows
 where
  actualWidths :: [Int]
actualWidths = (RenderedCell Text -> Int) -> [RenderedCell Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map RenderedCell Text -> Int
forall a. RenderedCell a -> Int
cellWidth [RenderedCell Text]
r
  fullwidths :: [Int]
fullwidths = [[RenderedCell Text]] -> [Int]
calculateFullWidths [[RenderedCell Text]]
rows
  minwidths :: [Int]
minwidths = case WriterOptions -> WrapOption
writerWrapText WriterOptions
opts of
                WrapOption
WrapNone -> [Int]
fullwidths
                WrapOption
_ -> [[RenderedCell Text]] -> [Int]
calculateMinWidths [[RenderedCell Text]]
rows
  totwidth :: Int
totwidth = WriterOptions -> Int
writerColumns WriterOptions
opts Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [RenderedCell Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RenderedCell Text]
r) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  evenwidth :: Int
evenwidth = Int
totwidth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` [RenderedCell Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RenderedCell Text]
r
  resetWidth :: Int -> RenderedCell a -> RenderedCell a
resetWidth Int
w RenderedCell a
c = RenderedCell a
c{ cellWidth = w }
  keepwidths :: [Int]
keepwidths = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
evenwidth) [Int]
fullwidths
  evenwidth' :: Int
evenwidth' = (Int
totwidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
keepwidths) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div`
                ([RenderedCell Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RenderedCell Text]
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
keepwidths)
  ensureMinWidths :: [Int] -> [Int]
ensureMinWidths = (Int -> Int -> Int) -> [Int] -> [Int] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> Int
forall a. Ord a => a -> a -> a
max [Int]
minwidths
  newwidths :: [Int]
newwidths = [Int] -> [Int]
ensureMinWidths ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$
              case Bool
isSimple of
                Bool
True | [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
fullwidths Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
totwidth -> [Int]
fullwidths
                     | Bool
otherwise -> (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
w -> if Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
evenwidth
                                                  then Int
w
                                                  else Int
evenwidth') [Int]
fullwidths
                Bool
False -> [Int]
actualWidths

-- Returns for each column a pair (full width, min width)
calculateFullWidths :: [[RenderedCell Text]] -> [Int]
calculateFullWidths :: [[RenderedCell Text]] -> [Int]
calculateFullWidths [[RenderedCell Text]]
rows =
  ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> ([Int] -> Maybe Int) -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Maybe Int
forall a. Ord a => [a] -> Maybe a
maximumMay) ([[Int]] -> [[Int]]
forall a. [[a]] -> [[a]]
transpose (([RenderedCell Text] -> [Int]) -> [[RenderedCell Text]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((RenderedCell Text -> Int) -> [RenderedCell Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\RenderedCell Text
c ->
         Doc Text -> Int
forall a. (IsString a, HasChars a) => Doc a -> Int
offset (RenderedCell Text -> Doc Text
forall a. RenderedCell a -> Doc a
cellContents RenderedCell Text
c))) [[RenderedCell Text]]
rows))

calculateMinWidths :: [[RenderedCell Text]] -> [Int]
calculateMinWidths :: [[RenderedCell Text]] -> [Int]
calculateMinWidths [[RenderedCell Text]]
rows =
  ([Int] -> Int) -> [[Int]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> ([Int] -> Maybe Int) -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Maybe Int
forall a. Ord a => [a] -> Maybe a
maximumMay) ([[Int]] -> [[Int]]
forall a. [[a]] -> [[a]]
transpose (([RenderedCell Text] -> [Int]) -> [[RenderedCell Text]] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map ((RenderedCell Text -> Int) -> [RenderedCell Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\RenderedCell Text
c ->
         Doc Text -> Int
forall a. HasChars a => Doc a -> Int
minOffset (RenderedCell Text -> Doc Text
forall a. RenderedCell a -> Doc a
cellContents RenderedCell Text
c))) [[RenderedCell Text]]
rows))

makeDummy :: [Int] -> Int -> Int -> RenderedCell Text
makeDummy :: [Int] -> Int -> Int -> RenderedCell Text
makeDummy [Int]
widths Int
n Int
len =
 let width :: Int
width = Int -> [Int] -> Int -> Int
forall a. a -> [a] -> Int -> a
atDef Int
0 [Int]
widths Int
n
 in RenderedCell{ cellColNum :: Int
cellColNum = Int
n,
                cellColSpan :: Int
cellColSpan = Int
len,
                cellAlign :: Alignment
cellAlign = Alignment
AlignDefault,
                cellRowSpan :: Int
cellRowSpan = Int
0, -- indicates dummy
                cellWidth :: Int
cellWidth = Int
width,
                cellHeight :: Int
cellHeight = Int
0,
                cellContents :: Doc Text
cellContents = Doc Text
forall a. Monoid a => a
mempty,
                cellBottomBorder :: LineStyle
cellBottomBorder = LineStyle
NoLine,
                cellTopBorder :: LineStyle
cellTopBorder = LineStyle
NoLine }

addDummies :: [Int] -> [RenderedCell Text] -> [RenderedCell Text]
addDummies :: [Int] -> [RenderedCell Text] -> [RenderedCell Text]
addDummies [Int]
widths = [RenderedCell Text] -> [RenderedCell Text]
forall a. [a] -> [a]
reverse ([RenderedCell Text] -> [RenderedCell Text])
-> ([RenderedCell Text] -> [RenderedCell Text])
-> [RenderedCell Text]
-> [RenderedCell Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [RenderedCell Text]) -> [RenderedCell Text]
forall a b. (a, b) -> b
snd ((Int, [RenderedCell Text]) -> [RenderedCell Text])
-> ([RenderedCell Text] -> (Int, [RenderedCell Text]))
-> [RenderedCell Text]
-> [RenderedCell Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, [RenderedCell Text])
 -> RenderedCell Text -> (Int, [RenderedCell Text]))
-> (Int, [RenderedCell Text])
-> [RenderedCell Text]
-> (Int, [RenderedCell Text])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, [RenderedCell Text])
-> RenderedCell Text -> (Int, [RenderedCell Text])
addDummy (Int
0,[])
 where
   addDummy :: (Int, [RenderedCell Text])
-> RenderedCell Text -> (Int, [RenderedCell Text])
addDummy (Int
i,[RenderedCell Text]
cs) RenderedCell Text
c =
     case RenderedCell Text -> Int
forall a. RenderedCell a -> Int
cellColNum RenderedCell Text
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i of
       Int
0 -> (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, RenderedCell Text
cRenderedCell Text -> [RenderedCell Text] -> [RenderedCell Text]
forall a. a -> [a] -> [a]
:[RenderedCell Text]
cs)
       Int
len -> (RenderedCell Text -> Int
forall a. RenderedCell a -> Int
cellColNum RenderedCell Text
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, RenderedCell Text
c RenderedCell Text -> [RenderedCell Text] -> [RenderedCell Text]
forall a. a -> [a] -> [a]
: [Int] -> Int -> Int -> RenderedCell Text
makeDummy [Int]
widths Int
i Int
len RenderedCell Text -> [RenderedCell Text] -> [RenderedCell Text]
forall a. a -> [a] -> [a]
: [RenderedCell Text]
cs)


setTopBorder :: LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setTopBorder :: LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setTopBorder LineStyle
_ [] = []
setTopBorder LineStyle
sty ([RenderedCell Text]
cs:[[RenderedCell Text]]
rest) = ((RenderedCell Text -> RenderedCell Text)
-> [RenderedCell Text] -> [RenderedCell Text]
forall a b. (a -> b) -> [a] -> [b]
map (\RenderedCell Text
c -> RenderedCell Text
c{ cellTopBorder = sty }) [RenderedCell Text]
cs) [RenderedCell Text]
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a. a -> [a] -> [a]
: [[RenderedCell Text]]
rest

setBottomBorder :: LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setBottomBorder :: LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setBottomBorder LineStyle
_ [] = []
setBottomBorder LineStyle
sty [[RenderedCell Text]
cs] = [(RenderedCell Text -> RenderedCell Text)
-> [RenderedCell Text] -> [RenderedCell Text]
forall a b. (a -> b) -> [a] -> [b]
map (\RenderedCell Text
c -> RenderedCell Text
c{ cellBottomBorder = sty }) [RenderedCell Text]
cs]
setBottomBorder LineStyle
sty ([RenderedCell Text]
c:[[RenderedCell Text]]
cs) = [RenderedCell Text]
c [RenderedCell Text]
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a. a -> [a] -> [a]
: LineStyle -> [[RenderedCell Text]] -> [[RenderedCell Text]]
setBottomBorder LineStyle
sty [[RenderedCell Text]]
cs

gridRows :: [[RenderedCell Text]] -> Doc Text
gridRows :: [[RenderedCell Text]] -> Doc Text
gridRows [] = Doc Text
forall a. Monoid a => a
mempty
gridRows ([RenderedCell Text]
x:[[RenderedCell Text]]
xs) =
  ((RenderedCell Text -> LineStyle)
-> Bool -> [RenderedCell Text] -> Doc Text
formatBorder RenderedCell Text -> LineStyle
forall a. RenderedCell a -> LineStyle
cellTopBorder Bool
False ((RenderedCell Text -> RenderedCell Text)
-> [RenderedCell Text] -> [RenderedCell Text]
forall a b. (a -> b) -> [a] -> [b]
map (\RenderedCell Text
z -> RenderedCell Text
z{ cellBottomBorder = NoLine }) [RenderedCell Text]
x))
  Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$
  [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat (([RenderedCell Text] -> [RenderedCell Text] -> Doc Text)
-> [[RenderedCell Text]] -> [[RenderedCell Text]] -> [Doc Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [RenderedCell Text] -> [RenderedCell Text] -> Doc Text
rowAndBottom ([RenderedCell Text]
x[RenderedCell Text]
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a. a -> [a] -> [a]
:[[RenderedCell Text]]
xs) ([[RenderedCell Text]]
xs [[RenderedCell Text]]
-> [[RenderedCell Text]] -> [[RenderedCell Text]]
forall a. [a] -> [a] -> [a]
++ [[]]))
 where
  -- generate wrapped contents. include pipe borders, bottom and left

  renderCellContents :: RenderedCell a -> Doc a
renderCellContents RenderedCell a
c =
    -- we don't use cblock or lblock because the content might
    -- be interpreted as an indented code block...even though it
    -- would look better to right-align right-aligned cells...
    -- (TODO: change this on parsing side?)
    Int -> Doc a -> Doc a
forall a. HasChars a => Int -> Doc a -> Doc a
lblock (case RenderedCell a -> Int
forall a. RenderedCell a -> Int
cellWidth RenderedCell a
c of
                  Int
0 -> Int
16 -- TODO arbitrary
                  Int
w -> Int
w) (RenderedCell a -> Doc a
forall a. RenderedCell a -> Doc a
cellContents RenderedCell a
c)

  formatRow :: [RenderedCell a] -> Doc a
formatRow [RenderedCell a]
cs = a -> Doc a
forall a. HasChars a => a -> Doc a
vfill a
"| " Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<>
   [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
hcat (Doc a -> [Doc a] -> [Doc a]
forall a. a -> [a] -> [a]
intersperse (a -> Doc a
forall a. HasChars a => a -> Doc a
vfill a
" | ") ((RenderedCell a -> Doc a) -> [RenderedCell a] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map RenderedCell a -> Doc a
forall {a}. HasChars a => RenderedCell a -> Doc a
renderCellContents [RenderedCell a]
cs)) Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> a -> Doc a
forall a. HasChars a => a -> Doc a
vfill a
" |"

  rowAndBottom :: [RenderedCell Text] -> [RenderedCell Text] -> Doc Text
rowAndBottom [RenderedCell Text]
thisRow [RenderedCell Text]
nextRow =
    let isLastRow :: Bool
isLastRow = [RenderedCell Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenderedCell Text]
nextRow
        border1 :: Text
border1 = Maybe Int -> Doc Text -> Text
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing ((RenderedCell Text -> LineStyle)
-> Bool -> [RenderedCell Text] -> Doc Text
formatBorder RenderedCell Text -> LineStyle
forall a. RenderedCell a -> LineStyle
cellBottomBorder Bool
False [RenderedCell Text]
thisRow)
        border2 :: Text
border2 = Maybe Int -> Doc Text -> Text
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing ((RenderedCell Text -> LineStyle)
-> Bool -> [RenderedCell Text] -> Doc Text
formatBorder RenderedCell Text -> LineStyle
forall a. RenderedCell a -> LineStyle
cellTopBorder Bool
False [RenderedCell Text]
nextRow)
        go :: Char -> Char -> Char
go Char
'+' Char
_ = Char
'+'
        go Char
_ Char
'+' = Char
'+'
        go Char
'=' Char
_ = Char
'='
        go Char
_ Char
'=' = Char
'='
        go Char
c Char
_   = Char
c
        combinedBorder :: Doc Text
combinedBorder = if Bool
isLastRow
                            then Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal Text
border1
                            else Text -> Doc Text
forall a. HasChars a => a -> Doc a
literal (Text -> Doc Text) -> Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ (Char -> Char -> Char) -> Text -> Text -> Text
T.zipWith Char -> Char -> Char
go Text
border1 Text
border2
    in [RenderedCell Text] -> Doc Text
forall {a}. HasChars a => [RenderedCell a] -> Doc a
formatRow [RenderedCell Text]
thisRow Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
combinedBorder


formatBorder :: (RenderedCell Text -> LineStyle) -> Bool -> [RenderedCell Text]
             -> Doc Text
formatBorder :: (RenderedCell Text -> LineStyle)
-> Bool -> [RenderedCell Text] -> Doc Text
formatBorder RenderedCell Text -> LineStyle
_ Bool
_alignMarkers [] = Doc Text
forall a. Monoid a => a
mempty
formatBorder RenderedCell Text -> LineStyle
borderStyle Bool
alignMarkers (RenderedCell Text
c:[RenderedCell Text]
cs)
  | RenderedCell Text -> LineStyle
borderStyle RenderedCell Text
c LineStyle -> LineStyle -> Bool
forall a. Eq a => a -> a -> Bool
== LineStyle
NoLine
    = Doc Text
openpipe Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> String -> Doc Text
forall a. HasChars a => String -> Doc a
text (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (RenderedCell Text -> Int
forall a. RenderedCell a -> Int
cellWidth RenderedCell Text
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Char
' ') Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
closepipe Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<>
      (RenderedCell Text -> LineStyle)
-> Bool -> [RenderedCell Text] -> Doc Text
formatBorder RenderedCell Text -> LineStyle
borderStyle Bool
alignMarkers [RenderedCell Text]
cs
  | Bool
otherwise
    = Doc Text
openplus Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
leftalign Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
underline Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
rightalign Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
closeplus Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<>
      (RenderedCell Text -> LineStyle)
-> Bool -> [RenderedCell Text] -> Doc Text
formatBorder RenderedCell Text -> LineStyle
borderStyle Bool
alignMarkers [RenderedCell Text]
cs
  where

    openpipe :: Doc Text
openpipe = Doc Text
"|"
    closepipe :: Doc Text
closepipe = if [RenderedCell Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenderedCell Text]
cs then Doc Text
"|" else Doc Text
forall a. Monoid a => a
mempty
    openplus :: Doc Text
openplus = Doc Text
"+"
    closeplus :: Doc Text
closeplus = if [RenderedCell Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RenderedCell Text]
cs
                   then Doc Text
"+"
                   else Doc Text
forall a. Monoid a => a
mempty
    lineChar :: Char
lineChar = case RenderedCell Text -> LineStyle
borderStyle RenderedCell Text
c of
                 LineStyle
NoLine -> Char
' '
                 LineStyle
SingleLine -> Char
'-'
                 LineStyle
DoubleLine -> Char
'='
    (Doc Text
leftalign, Doc Text
rightalign) =
       case RenderedCell Text -> Alignment
forall a. RenderedCell a -> Alignment
cellAlign RenderedCell Text
c of
         Alignment
_ | Bool -> Bool
not Bool
alignMarkers -> (Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
lineChar,Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
lineChar)
         Alignment
AlignLeft -> (Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
':',Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
lineChar)
         Alignment
AlignCenter -> (Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
':',Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
':')
         Alignment
AlignRight -> (Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
lineChar,Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
':')
         Alignment
AlignDefault -> (Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
lineChar,Char -> Doc Text
forall a. HasChars a => Char -> Doc a
char Char
lineChar)
    underline :: Doc Text
underline = String -> Doc Text
forall a. HasChars a => String -> Doc a
text (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (RenderedCell Text -> Int
forall a. RenderedCell a -> Int
cellWidth RenderedCell Text
c) Char
lineChar)

data LineStyle = NoLine | SingleLine | DoubleLine
    deriving (Int -> LineStyle -> ShowS
[LineStyle] -> ShowS
LineStyle -> String
(Int -> LineStyle -> ShowS)
-> (LineStyle -> String)
-> ([LineStyle] -> ShowS)
-> Show LineStyle
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LineStyle -> ShowS
showsPrec :: Int -> LineStyle -> ShowS
$cshow :: LineStyle -> String
show :: LineStyle -> String
$cshowList :: [LineStyle] -> ShowS
showList :: [LineStyle] -> ShowS
Show, Eq LineStyle
Eq LineStyle =>
(LineStyle -> LineStyle -> Ordering)
-> (LineStyle -> LineStyle -> Bool)
-> (LineStyle -> LineStyle -> Bool)
-> (LineStyle -> LineStyle -> Bool)
-> (LineStyle -> LineStyle -> Bool)
-> (LineStyle -> LineStyle -> LineStyle)
-> (LineStyle -> LineStyle -> LineStyle)
-> Ord LineStyle
LineStyle -> LineStyle -> Bool
LineStyle -> LineStyle -> Ordering
LineStyle -> LineStyle -> LineStyle
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LineStyle -> LineStyle -> Ordering
compare :: LineStyle -> LineStyle -> Ordering
$c< :: LineStyle -> LineStyle -> Bool
< :: LineStyle -> LineStyle -> Bool
$c<= :: LineStyle -> LineStyle -> Bool
<= :: LineStyle -> LineStyle -> Bool
$c> :: LineStyle -> LineStyle -> Bool
> :: LineStyle -> LineStyle -> Bool
$c>= :: LineStyle -> LineStyle -> Bool
>= :: LineStyle -> LineStyle -> Bool
$cmax :: LineStyle -> LineStyle -> LineStyle
max :: LineStyle -> LineStyle -> LineStyle
$cmin :: LineStyle -> LineStyle -> LineStyle
min :: LineStyle -> LineStyle -> LineStyle
Ord, LineStyle -> LineStyle -> Bool
(LineStyle -> LineStyle -> Bool)
-> (LineStyle -> LineStyle -> Bool) -> Eq LineStyle
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LineStyle -> LineStyle -> Bool
== :: LineStyle -> LineStyle -> Bool
$c/= :: LineStyle -> LineStyle -> Bool
/= :: LineStyle -> LineStyle -> Bool
Eq)

data RenderedCell a =
  RenderedCell{ forall a. RenderedCell a -> Int
cellColNum :: Int
              , forall a. RenderedCell a -> Int
cellColSpan :: Int
              , forall a. RenderedCell a -> Alignment
cellAlign :: Alignment
              , forall a. RenderedCell a -> Int
cellRowSpan :: Int
              , forall a. RenderedCell a -> Int
cellWidth :: Int
              , forall a. RenderedCell a -> Int
cellHeight :: Int
              , forall a. RenderedCell a -> Doc a
cellContents :: Doc a
              , forall a. RenderedCell a -> LineStyle
cellBottomBorder :: LineStyle
              , forall a. RenderedCell a -> LineStyle
cellTopBorder :: LineStyle
              }
  deriving (Int -> RenderedCell a -> ShowS
[RenderedCell a] -> ShowS
RenderedCell a -> String
(Int -> RenderedCell a -> ShowS)
-> (RenderedCell a -> String)
-> ([RenderedCell a] -> ShowS)
-> Show (RenderedCell a)
forall a. Show a => Int -> RenderedCell a -> ShowS
forall a. Show a => [RenderedCell a] -> ShowS
forall a. Show a => RenderedCell a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> RenderedCell a -> ShowS
showsPrec :: Int -> RenderedCell a -> ShowS
$cshow :: forall a. Show a => RenderedCell a -> String
show :: RenderedCell a -> String
$cshowList :: forall a. Show a => [RenderedCell a] -> ShowS
showList :: [RenderedCell a] -> ShowS
Show)

getColWidth :: ColSpec -> Double
getColWidth :: ColSpec -> Double
getColWidth (Alignment
_, ColWidth Double
n) = Double
n
getColWidth (Alignment
_, ColWidth
ColWidthDefault) = Double
0 -- TODO?

toCharWidth :: WriterOptions -> Double -> Int
toCharWidth :: WriterOptions -> Double -> Int
toCharWidth WriterOptions
opts Double
width =
  Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
width Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WriterOptions -> Int
writerColumns WriterOptions
opts)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3)

gridRow :: (Monad m, HasChars a)
        => WriterOptions
        -> (WriterOptions -> [Block] -> m (Doc a)) -- ^ format Doc writer
        -> [Ann.Cell]
        -> m [RenderedCell a]
gridRow :: forall (m :: * -> *) a.
(Monad m, HasChars a) =>
WriterOptions
-> (WriterOptions -> [Block] -> m (Doc a))
-> [Cell]
-> m [RenderedCell a]
gridRow WriterOptions
opts WriterOptions -> [Block] -> m (Doc a)
blocksToDoc = (Cell -> m (RenderedCell a)) -> [Cell] -> m [RenderedCell a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Cell -> m (RenderedCell a)
renderCell
 where
  renderer :: [Block] -> m (Doc a)
renderer = WriterOptions -> [Block] -> m (Doc a)
blocksToDoc WriterOptions
opts
  renderCell :: Cell -> m (RenderedCell a)
renderCell (Ann.Cell NonEmpty ColSpec
cellcolspecs (Ann.ColNumber Int
colnum)
               (Cell Attr
_ Alignment
_ (RowSpan Int
rowspan) ColSpan
_ [Block]
blocks)) = do
    let ((Alignment
align,ColWidth
_):|[ColSpec]
_) = NonEmpty ColSpec
cellcolspecs
    let width :: Int
width = WriterOptions -> Double -> Int
toCharWidth WriterOptions
opts (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ NonEmpty Double -> Double
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((ColSpec -> Double) -> NonEmpty ColSpec -> NonEmpty Double
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ColSpec -> Double
getColWidth NonEmpty ColSpec
cellcolspecs)
    Doc a
rendered <- [Block] -> m (Doc a)
renderer [Block]
blocks
    RenderedCell a -> m (RenderedCell a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenderedCell a -> m (RenderedCell a))
-> RenderedCell a -> m (RenderedCell a)
forall a b. (a -> b) -> a -> b
$ RenderedCell{ cellColNum :: Int
cellColNum = Int
colnum,
                         cellColSpan :: Int
cellColSpan = NonEmpty ColSpec -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty ColSpec
cellcolspecs,
                         cellAlign :: Alignment
cellAlign = Alignment
align,
                         cellRowSpan :: Int
cellRowSpan = Int
rowspan,
                         cellWidth :: Int
cellWidth = Int
width,
                         cellHeight :: Int
cellHeight = Doc a -> Int
forall a. HasChars a => Doc a -> Int
height Doc a
rendered,
                         cellContents :: Doc a
cellContents = Doc a
rendered,
                         cellBottomBorder :: LineStyle
cellBottomBorder = if Int
rowspan Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
                                               then LineStyle
SingleLine
                                               else LineStyle
NoLine,
                         cellTopBorder :: LineStyle
cellTopBorder = LineStyle
SingleLine }


-- | 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) -> [Inline] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Inline]
ils
         Just (MetaBlocks [Block]
bs)   -> [Block] -> Text
forall a. Walkable Inline a => a -> Text
stringify [Block]
bs
         Just (MetaBool Bool
b)      -> String -> Text
T.pack (Bool -> String
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' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x00B9'
toSuperscript Char
'2' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x00B2'
toSuperscript Char
'3' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x00B3'
toSuperscript Char
'+' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x207A'
toSuperscript Char
'-' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x207B'
toSuperscript Char
'\x2212' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x207B' -- unicode minus
toSuperscript Char
'=' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x207C'
toSuperscript Char
'(' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x207D'
toSuperscript Char
')' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x207E'
toSuperscript Char
c
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' =
                 Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> Maybe Char) -> Char -> Maybe Char
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr (Int
0x2070 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
48))
  | Char -> Bool
isSpace Char
c = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
  | Bool
otherwise = Maybe Char
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
'+' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x208A'
toSubscript Char
'-' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x208B'
toSubscript Char
'=' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x208C'
toSubscript Char
'(' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x208D'
toSubscript Char
')' = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\x208E'
toSubscript Char
c
  | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' =
                 Char -> Maybe Char
forall a. a -> Maybe a
Just (Char -> Maybe Char) -> Char -> Maybe Char
forall a b. (a -> b) -> a -> b
$ Int -> Char
chr (Int
0x2080 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
48))
  | Char -> Bool
isSpace Char
c = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c
  | Bool
otherwise = Maybe Char
forall a. Maybe a
Nothing

toSubscriptInline :: Inline -> Maybe Inline
toSubscriptInline :: Inline -> Maybe Inline
toSubscriptInline Inline
Space = Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
Space
toSubscriptInline (Span Attr
attr [Inline]
ils) = Attr -> [Inline] -> Inline
Span Attr
attr ([Inline] -> Inline) -> Maybe [Inline] -> Maybe Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inline -> Maybe Inline) -> [Inline] -> Maybe [Inline]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Inline -> Maybe Inline
toSubscriptInline [Inline]
ils
toSubscriptInline (Str Text
s) = Text -> Inline
Str (Text -> Inline) -> (String -> Text) -> String -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Inline) -> Maybe String -> Maybe Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Maybe Char) -> String -> Maybe String
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Char -> Maybe Char
toSubscript (Text -> String
T.unpack Text
s)
toSubscriptInline Inline
LineBreak = Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
LineBreak
toSubscriptInline Inline
SoftBreak = Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
SoftBreak
toSubscriptInline Inline
_ = Maybe Inline
forall a. Maybe a
Nothing

toSuperscriptInline :: Inline -> Maybe Inline
toSuperscriptInline :: Inline -> Maybe Inline
toSuperscriptInline Inline
Space = Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
Space
toSuperscriptInline (Span Attr
attr [Inline]
ils) = Attr -> [Inline] -> Inline
Span Attr
attr ([Inline] -> Inline) -> Maybe [Inline] -> Maybe Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Inline -> Maybe Inline) -> [Inline] -> Maybe [Inline]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Inline -> Maybe Inline
toSuperscriptInline [Inline]
ils
toSuperscriptInline (Str Text
s) = Text -> Inline
Str (Text -> Inline) -> (String -> Text) -> String -> Inline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Inline) -> Maybe String -> Maybe Inline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Maybe Char) -> String -> Maybe String
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Char -> Maybe Char
toSuperscript (Text -> String
T.unpack Text
s)
toSuperscriptInline Inline
LineBreak = Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
LineBreak
toSuperscriptInline Inline
SoftBreak = Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
SoftBreak
toSuperscriptInline Inline
_ = Maybe Inline
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 =
  Bool -> Int -> Tree SecInfo -> Block
tocToList (WriterOptions -> Bool
writerNumberSections WriterOptions
opts) (WriterOptions -> Int
writerTOCDepth WriterOptions
opts)
  (Tree SecInfo -> Block)
-> ([Block] -> Tree SecInfo) -> [Block] -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Block] -> Tree SecInfo
toTOCTree
  ([Block] -> Tree SecInfo)
-> ([Block] -> [Block]) -> [Block] -> Tree SecInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe Int -> [Block] -> [Block]
makeSections (WriterOptions -> Bool
writerNumberSections WriterOptions
opts) Maybe Int
forall a. Maybe a
Nothing

-- | Returns 'True' iff the list of blocks has a @'Plain'@ as its last
-- element.
endsWithPlain :: [Block] -> Bool
endsWithPlain :: [Block] -> Bool
endsWithPlain [Block]
xs =
  case [Block] -> Maybe Block
forall a. [a] -> Maybe a
lastMay [Block]
xs of
    Just Plain{} -> Bool
True
    Just (BulletList [[Block]]
is) -> Bool -> ([Block] -> Bool) -> Maybe [Block] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False [Block] -> Bool
endsWithPlain ([[Block]] -> Maybe [Block]
forall a. [a] -> Maybe a
lastMay [[Block]]
is)
    Just (OrderedList ListAttributes
_ [[Block]]
is) -> Bool -> ([Block] -> Bool) -> Maybe [Block] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False [Block] -> Bool
endsWithPlain ([[Block]] -> Maybe [Block]
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 = [ColSpec] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ColSpec]
specs
    ([Alignment]
aligns, [ColWidth]
mwidths) = [ColSpec] -> ([Alignment], [ColWidth])
forall a b. [(a, b)] -> ([a], [b])
unzip [ColSpec]
specs
    fromWidth :: ColWidth -> Double
fromWidth (ColWidth Double
w) | Double
w Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 = Double
w
    fromWidth ColWidth
_                    = Double
0
    widths :: [Double]
widths = (ColWidth -> Double) -> [ColWidth] -> [Double]
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 [Row] -> [Row] -> [Row]
forall a. Semigroup a => a -> a -> a
<> [Row]
bd
    unBodies :: [TableBody] -> [Row]
unBodies = (TableBody -> [Row]) -> [TableBody] -> [Row]
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 = (TableBody -> TableBody) -> [TableBody] -> [TableBody]
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 [] ([Cell] -> ([[[Block]]], [[Block]]))
-> [Cell] -> ([[[Block]]], [[Block]])
forall a b. (a -> b) -> a -> b
$ Row -> [Cell]
unRow Row
r
                  rs' :: [[[Block]]]
rs' = [[[Block]]] -> [Row] -> [[[Block]]]
cutRows [[[Block]]]
pendingPieces ([Row] -> [[[Block]]]) -> [Row] -> [[[Block]]]
forall a b. (a -> b) -> a -> b
$ [Row]
rs [Row] -> [Row] -> [Row]
forall a. Semigroup a => a -> a -> a
<> [TableBody] -> [Row]
unBodies [TableBody]
tb [Row] -> [Row] -> [Row]
forall a. Semigroup a => a -> a -> a
<> [Row]
tf
              in ([[Block]]
r', [[[Block]]]
rs')
      []    -> ([], [[[Block]]] -> [Row] -> [[[Block]]]
cutRows [] ([Row] -> [[[Block]]]) -> [Row] -> [[[Block]]]
forall a b. (a -> b) -> a -> b
$ [TableBody] -> [Row]
unBodies [TableBody]
tb [Row] -> [Row] -> [Row]
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 [[Block]] -> [[[Block]]] -> [[[Block]]]
forall a. a -> [a] -> [a]
: [[[Block]]]
pendingPieces'', [Block]
p [Block] -> [[Block]] -> [[Block]]
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 [Block] -> [[Block]] -> [[Block]]
forall a. a -> [a] -> [a]
: Int -> [Block] -> [[Block]]
forall a. Int -> a -> [a]
replicate (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Block]
forall a. Monoid a => a
mempty
            cPendingPieces :: [[[Block]]]
cPendingPieces = Int -> [[Block]] -> [[[Block]]]
forall a. Int -> a -> [a]
replicate Int
w ([[Block]] -> [[[Block]]]) -> [[Block]] -> [[[Block]]]
forall a b. (a -> b) -> a -> b
$ Int -> [Block] -> [[Block]]
forall a. Int -> a -> [a]
replicate (Int
h Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Block]
forall a. Monoid a => a
mempty
            pendingPieces' :: [[[Block]]]
pendingPieces' = Int -> [[[Block]]] -> [[[Block]]]
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 [[[Block]]] -> [[[Block]]] -> [[[Block]]]
forall a. Semigroup a => a -> a -> a
<> [[[Block]]]
pendingPieces'', [[Block]]
cRowPieces [[Block]] -> [[Block]] -> [[Block]]
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 ([Cell] -> ([[[Block]]], [[Block]]))
-> [Cell] -> ([[[Block]]], [[Block]])
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' [[Block]] -> [[[Block]]] -> [[[Block]]]
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 ([Doc Text] -> Doc Text)
-> (Doc Text -> [Doc Text]) -> Doc Text -> Doc Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Text -> [Doc Text]
forall {a}. Doc a -> [Doc a]
toList
 where
  go :: [Doc Text] -> Doc Text
go [] = Doc Text
forall a. Monoid a => a
mempty
  go (Text Int
len Text
t : AfterBreak Text
_ : Doc Text
BreakingSpace : [Doc Text]
xs)
    | Text -> Bool
isSentenceEnding Text
t = Int -> Text -> Doc Text
forall a. Int -> a -> Doc a
Text Int
len Text
t Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
NewLine Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> [Doc Text] -> Doc Text
go [Doc Text]
xs
  go (Text Int
len Text
t : Doc Text
BreakingSpace : [Doc Text]
xs)
    | Text -> Bool
isSentenceEnding Text
t = Int -> Text -> Doc Text
forall a. Int -> a -> Doc a
Text Int
len Text
t Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
forall a. Doc a
NewLine Doc Text -> Doc Text -> Doc Text
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 Doc Text -> Doc Text -> Doc Text
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 (Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
Concat Doc a
a (Doc a -> Doc a -> Doc 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 Doc a -> [Doc a] -> [Doc 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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?'
        , Bool -> Bool
not (Text -> Bool
isInitial Text
t') -> Bool
True
        | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
']' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\x201D' ->
           case Text -> Maybe (Text, Char)
T.unsnoc Text
t' of
             Just (Text
t'',Char
d) -> Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!' Bool -> Bool -> Bool
|| Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?' Bool -> Bool -> Bool
&&
                             Bool -> Bool
not (Text -> Bool
isInitial Text
t'')
             Maybe (Text, Char)
_ -> Bool
False
      Maybe (Text, Char)
_ -> Bool
False
   where
    isInitial :: Text -> Bool
isInitial Text
x = Text -> Int
T.length Text
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isUpper Text
x

-- | 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 = (Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
fixLinks (Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Attr -> Attr) -> Pandoc -> Pandoc
walkAttr Attr -> Attr
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_" Text -> Text -> Text
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) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"#id_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t)
          Maybe (Char, Text)
_ -> Maybe Text
forall a. Maybe a
Nothing
      Maybe (Char, Text)
_ -> Maybe 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 = (Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk Inline -> Inline
goInline (Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> Block) -> Pandoc -> Pandoc
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

-- | Set translations based on the `lang` in metadata.
setupTranslations :: PandocMonad m => Meta -> m ()
setupTranslations :: forall (m :: * -> *). PandocMonad m => Meta -> m ()
setupTranslations Meta
meta = do
  let defLang :: Lang
defLang = Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang Text
"en" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"US") Maybe Text
forall a. Maybe a
Nothing [] [] []
  Lang
lang <- case Text -> Meta -> Text
lookupMetaString Text
"lang" Meta
meta of
            Text
"" -> Lang -> m Lang
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lang
defLang
            Text
s  -> Lang -> Maybe Lang -> Lang
forall a. a -> Maybe a -> a
fromMaybe Lang
defLang (Maybe Lang -> Lang) -> m (Maybe Lang) -> m Lang
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text -> m (Maybe Lang)
forall (m :: * -> *). PandocMonad m => Maybe Text -> m (Maybe Lang)
toLang (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s)
  Lang -> m ()
forall (m :: * -> *). PandocMonad m => Lang -> m ()
setTranslations Lang
lang

-- True if the string would count as a Markdown ordered list marker.
isOrderedListMarker :: Text -> Bool
isOrderedListMarker :: Text -> Bool
isOrderedListMarker Text
xs = Bool -> Bool
not (Text -> Bool
T.null Text
xs) Bool -> Bool -> Bool
&& (HasCallStack => Text -> Char
Text -> Char
T.last Text
xs Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'.',Char
')']) Bool -> Bool -> Bool
&&
              Either ParseError () -> Bool
forall a b. Either a b -> Bool
isRight (Parsec Text ParserState ()
-> ParserState -> String -> Text -> Either ParseError ()
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser (ParsecT Text ParserState Identity ListAttributes
forall s (m :: * -> *).
(Stream s m Char, UpdateSourcePos s Char) =>
ParsecT s ParserState m ListAttributes
anyOrderedListMarker ParsecT Text ParserState Identity ListAttributes
-> Parsec Text ParserState () -> Parsec Text ParserState ()
forall a b.
ParsecT Text ParserState Identity a
-> ParsecT Text ParserState Identity b
-> ParsecT Text ParserState Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parsec Text ParserState ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof)
                       ParserState
defaultParserState String
"" Text
xs)

toTaskListItem :: MonadPlus m => [Block] -> m (Bool, [Block])
toTaskListItem :: forall (m :: * -> *). MonadPlus m => [Block] -> m (Bool, [Block])
toTaskListItem (Plain (Str Text
"☐":Inline
Space:[Inline]
ils):[Block]
xs) = (Bool, [Block]) -> m (Bool, [Block])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [Inline] -> Block
Plain [Inline]
ilsBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[Block]
xs)
toTaskListItem (Plain (Str Text
"☒":Inline
Space:[Inline]
ils):[Block]
xs) = (Bool, [Block]) -> m (Bool, [Block])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, [Inline] -> Block
Plain [Inline]
ilsBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[Block]
xs)
toTaskListItem (Para  (Str Text
"☐":Inline
Space:[Inline]
ils):[Block]
xs) = (Bool, [Block]) -> m (Bool, [Block])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, [Inline] -> Block
Para [Inline]
ilsBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[Block]
xs)
toTaskListItem (Para  (Str Text
"☒":Inline
Space:[Inline]
ils):[Block]
xs) = (Bool, [Block]) -> m (Bool, [Block])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, [Inline] -> Block
Para [Inline]
ilsBlock -> [Block] -> [Block]
forall a. a -> [a] -> [a]
:[Block]
xs)
toTaskListItem [Block]
_                              = m (Bool, [Block])
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- | Add an opener and closer to a Doc. If the Doc begins or ends
-- with whitespace, export this outside the opener or closer.
-- This is used for formats, like Markdown, which don't allow spaces
-- after opening or before closing delimiters.
delimited :: Doc Text -> Doc Text -> Doc Text -> Doc Text
delimited :: Doc Text -> Doc Text -> Doc Text -> Doc Text
delimited Doc Text
opener Doc Text
closer Doc Text
content =
  [Doc Text] -> Doc Text
forall a. Monoid a => [a] -> a
mconcat [Doc Text]
initialWS Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
opener Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> [Doc Text] -> Doc Text
forall a. Monoid a => [a] -> a
mconcat [Doc Text]
middle Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> Doc Text
closer Doc Text -> Doc Text -> Doc Text
forall a. Semigroup a => a -> a -> a
<> [Doc Text] -> Doc Text
forall a. Monoid a => [a] -> a
mconcat [Doc Text]
finalWS
 where
  contents :: [Doc Text]
contents = Doc Text -> [Doc Text]
forall {a}. Doc a -> [Doc a]
toList Doc Text
content
  ([Doc Text]
initialWS, [Doc Text]
rest) = (Doc Text -> Bool) -> [Doc Text] -> ([Doc Text], [Doc Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Doc Text -> Bool
forall a. Doc a -> Bool
isWS [Doc Text]
contents
  ([Doc Text]
reverseFinalWS, [Doc Text]
reverseMiddle) = (Doc Text -> Bool) -> [Doc Text] -> ([Doc Text], [Doc Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Doc Text -> Bool
forall a. Doc a -> Bool
isWS ([Doc Text] -> [Doc Text]
forall a. [a] -> [a]
reverse [Doc Text]
rest)
  finalWS :: [Doc Text]
finalWS = [Doc Text] -> [Doc Text]
forall a. [a] -> [a]
reverse [Doc Text]
reverseFinalWS
  middle :: [Doc Text]
middle = [Doc Text] -> [Doc Text]
forall a. [a] -> [a]
reverse [Doc Text]
reverseMiddle
  isWS :: Doc a -> Bool
isWS Doc a
NewLine = Bool
True
  isWS Doc a
CarriageReturn = Bool
True
  isWS Doc a
BreakingSpace = Bool
True
  isWS BlankLines{} = Bool
True
  isWS Doc a
_ = Bool
False
  toList :: Doc a -> [Doc a]
toList (Concat (Concat Doc a
a Doc a
b) Doc a
c) = Doc a -> [Doc a]
toList (Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
Concat Doc a
a (Doc a -> Doc a -> Doc 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 Doc a -> [Doc a] -> [Doc a]
forall a. a -> [a] -> [a]
: Doc a -> [Doc a]
toList Doc a
b
  toList Doc a
x = [Doc a
x]