{-# LANGUAGE OverloadedStrings #-}
{- |
   Module      : Text.Pandoc.Writers.JATS.Table
   Copyright   : © 2020 Albert Krewinkel
   License     : GNU GPL, version 2 or above

   Maintainer  : Albert Krewinkel <tarleb@zeitkraut.de>
   Stability   : alpha
   Portability : portable

Conversion of 'Pandoc' tables to JATS XML.
-}
module Text.Pandoc.Writers.JATS.Table
  ( tableToJATS
  ) where
import Control.Monad.Reader (asks)
import Data.Text (Text)
import Text.Pandoc.Class.PandocMonad (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Options (WriterOptions)
import Text.DocLayout (Doc, empty, vcat, ($$))
import Text.Pandoc.Shared (tshow)
import Text.Pandoc.Writers.JATS.Types
import Text.Pandoc.Writers.Shared (toLegacyTable)
import Text.Pandoc.XML (inTags, inTagsIndented, selfClosingTag)


tableToJATS :: PandocMonad m
            => WriterOptions
            -> Attr -> Caption -> [ColSpec] -> TableHead
            -> [TableBody] -> TableFoot
            -> JATS m (Doc Text)
tableToJATS :: WriterOptions
-> Attr
-> Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> JATS m (Doc Text)
tableToJATS WriterOptions
opts Attr
_attr Caption
blkCapt [ColSpec]
specs TableHead
th [TableBody]
tb TableFoot
tf = do
  WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS <- (JATSEnv m -> WriterOptions -> Block -> JATS m (Doc Text))
-> StateT
     JATSState
     (ReaderT (JATSEnv m) m)
     (WriterOptions -> Block -> JATS m (Doc Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> WriterOptions -> Block -> JATS m (Doc Text)
forall (m :: * -> *).
JATSEnv m -> WriterOptions -> Block -> JATS m (Doc Text)
jatsBlockWriter
  let ([Inline]
caption, [Alignment]
aligns, [Double]
widths, [[Block]]
headers, [[[Block]]]
rows) =
        Caption
-> [ColSpec]
-> TableHead
-> [TableBody]
-> TableFoot
-> ([Inline], [Alignment], [Double], [[Block]], [[[Block]]])
toLegacyTable Caption
blkCapt [ColSpec]
specs TableHead
th [TableBody]
tb TableFoot
tf
  Doc Text
captionDoc <- if [Inline] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Inline]
caption
                then Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Monoid a => a
mempty
                else Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"caption" (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts ([Inline] -> Block
Para [Inline]
caption)
  Doc Text
tbl <- [Alignment]
-> [Double] -> [[Block]] -> [[[Block]]] -> JATS m (Doc Text)
forall (m :: * -> *) a.
(PandocMonad m, RealFrac a) =>
[Alignment]
-> [a]
-> [[Block]]
-> [[[Block]]]
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
captionlessTable [Alignment]
aligns [Double]
widths [[Block]]
headers [[[Block]]]
rows
  Doc Text -> JATS m (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> JATS m (Doc Text)) -> Doc Text -> JATS m (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"table-wrap" [] (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Doc Text
captionDoc Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
tbl
  where
    captionlessTable :: [Alignment]
-> [a]
-> [[Block]]
-> [[[Block]]]
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
captionlessTable [Alignment]
aligns [a]
widths [[Block]]
headers [[[Block]]]
rows = do
      let percent :: a -> Text
percent a
w = Integer -> Text
forall a. Show a => a -> Text
tshow (a -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate (a
100a -> a -> a
forall a. Num a => a -> a -> a
*a
w) :: Integer) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"*"
      let coltags :: Doc Text
coltags = [Doc Text] -> Doc Text
forall a. [Doc a] -> Doc a
vcat ([Doc Text] -> Doc Text) -> [Doc Text] -> Doc Text
forall a b. (a -> b) -> a -> b
$ (a -> Alignment -> Doc Text) -> [a] -> [Alignment] -> [Doc Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\a
w Alignment
al -> Text -> [(Text, Text)] -> Doc Text
forall a.
(HasChars a, IsString a) =>
Text -> [(Text, Text)] -> Doc a
selfClosingTag Text
"col"
                           ([(Text
"width", a -> Text
forall a. RealFrac a => a -> Text
percent a
w) | a
w a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0] [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
forall a. [a] -> [a] -> [a]
++
                            [(Text
"align", Alignment -> Text
alignmentToText Alignment
al)])) [a]
widths [Alignment]
aligns
      Doc Text
thead <- if ([Block] -> Bool) -> [[Block]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all [Block] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Block]]
headers
                  then Doc Text -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Doc Text
forall a. Doc a
empty
                  else Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"thead" (Doc Text -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterOptions
-> Bool
-> [[Block]]
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Bool -> [[Block]] -> JATS m (Doc Text)
tableRowToJATS WriterOptions
opts Bool
True [[Block]]
headers
      Doc Text
tbody <- Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"tbody" (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
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                    ([[Block]] -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text))
-> [[[Block]]]
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions
-> Bool
-> [[Block]]
-> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Bool -> [[Block]] -> JATS m (Doc Text)
tableRowToJATS WriterOptions
opts Bool
False) [[[Block]]]
rows
      Doc Text -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc Text -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text))
-> Doc Text -> StateT JATSState (ReaderT (JATSEnv m) m) (Doc Text)
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
True Text
"table" [] (Doc Text -> Doc Text) -> Doc Text -> Doc Text
forall a b. (a -> b) -> a -> b
$ Doc Text
coltags Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
thead Doc Text -> Doc Text -> Doc Text
forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
tbody

alignmentToText :: Alignment -> Text
alignmentToText :: Alignment -> Text
alignmentToText Alignment
alignment = case Alignment
alignment of
                                 Alignment
AlignLeft    -> Text
"left"
                                 Alignment
AlignRight   -> Text
"right"
                                 Alignment
AlignCenter  -> Text
"center"
                                 Alignment
AlignDefault -> Text
"left"

tableRowToJATS :: PandocMonad m
               => WriterOptions
               -> Bool
               -> [[Block]]
               -> JATS m (Doc Text)
tableRowToJATS :: WriterOptions -> Bool -> [[Block]] -> JATS m (Doc Text)
tableRowToJATS WriterOptions
opts Bool
isHeader [[Block]]
cols =
  Text -> Doc Text -> Doc Text
forall a. (HasChars a, IsString a) => Text -> Doc a -> Doc a
inTagsIndented Text
"tr" (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
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Block] -> JATS m (Doc Text))
-> [[Block]] -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Bool -> [Block] -> JATS m (Doc Text)
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Bool -> [Block] -> JATS m (Doc Text)
tableItemToJATS WriterOptions
opts Bool
isHeader) [[Block]]
cols

tableItemToJATS :: PandocMonad m
                => WriterOptions
                -> Bool
                -> [Block]
                -> JATS m (Doc Text)
tableItemToJATS :: WriterOptions -> Bool -> [Block] -> JATS m (Doc Text)
tableItemToJATS WriterOptions
opts Bool
isHeader [Plain [Inline]
item] = do
  WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS <- (JATSEnv m -> WriterOptions -> [Inline] -> JATS m (Doc Text))
-> StateT
     JATSState
     (ReaderT (JATSEnv m) m)
     (WriterOptions -> [Inline] -> JATS m (Doc Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> WriterOptions -> [Inline] -> JATS m (Doc Text)
forall (m :: * -> *).
JATSEnv m -> WriterOptions -> [Inline] -> JATS m (Doc Text)
jatsInlinesWriter
  Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False (if Bool
isHeader then Text
"th" else Text
"td") [] (Doc Text -> Doc Text) -> JATS m (Doc Text) -> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    WriterOptions -> [Inline] -> JATS m (Doc Text)
inlinesToJATS WriterOptions
opts [Inline]
item
tableItemToJATS WriterOptions
opts Bool
isHeader [Block]
item = do
  WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS <- (JATSEnv m -> WriterOptions -> Block -> JATS m (Doc Text))
-> StateT
     JATSState
     (ReaderT (JATSEnv m) m)
     (WriterOptions -> Block -> JATS m (Doc Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks JATSEnv m -> WriterOptions -> Block -> JATS m (Doc Text)
forall (m :: * -> *).
JATSEnv m -> WriterOptions -> Block -> JATS m (Doc Text)
jatsBlockWriter
  Bool -> Text -> [(Text, Text)] -> Doc Text -> Doc Text
forall a.
(HasChars a, IsString a) =>
Bool -> Text -> [(Text, Text)] -> Doc a -> Doc a
inTags Bool
False (if Bool
isHeader then Text
"th" else Text
"td") [] (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
vcat ([Doc Text] -> Doc Text)
-> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
-> JATS m (Doc Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    (Block -> JATS m (Doc Text))
-> [Block] -> StateT JATSState (ReaderT (JATSEnv m) m) [Doc Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (WriterOptions -> Block -> JATS m (Doc Text)
blockToJATS WriterOptions
opts) [Block]
item