2013-08-18 14:36:40 -07:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2013-07-01 20:49:22 -07:00
|
|
|
{-
|
2017-05-13 23:30:13 +02:00
|
|
|
Copyright (C) 2013-2017 John MacFarlane <jgm@berkeley.edu>
|
2013-07-01 20:49:22 -07:00
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
|
|
it under the terms of the GNU General Public License as published by
|
|
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
|
|
(at your option) any later version.
|
|
|
|
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
GNU General Public License for more details.
|
|
|
|
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
|
|
along with this program; if not, write to the Free Software
|
|
|
|
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
|
|
|
-}
|
|
|
|
|
|
|
|
{- |
|
|
|
|
Module : Text.Pandoc.Writers.Shared
|
2017-05-13 23:30:13 +02:00
|
|
|
Copyright : Copyright (C) 2013-2017 John MacFarlane
|
2013-07-01 20:49:22 -07:00
|
|
|
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 (
|
2017-06-25 21:00:35 +02:00
|
|
|
metaToJSON
|
2017-02-25 23:13:23 +01:00
|
|
|
, metaToJSON'
|
|
|
|
, addVariablesToJSON
|
2013-07-01 20:49:22 -07:00
|
|
|
, getField
|
|
|
|
, setField
|
2017-02-25 22:59:16 +01:00
|
|
|
, resetField
|
2013-07-01 20:49:22 -07:00
|
|
|
, defField
|
2013-08-18 14:36:40 -07:00
|
|
|
, tagWithAttrs
|
2014-01-02 15:22:50 -08:00
|
|
|
, fixDisplayMath
|
2017-02-04 12:52:08 +01:00
|
|
|
, unsmartify
|
2017-03-21 10:02:30 +01:00
|
|
|
, gridTable
|
2013-07-01 20:49:22 -07:00
|
|
|
)
|
|
|
|
where
|
2017-06-25 21:00:35 +02:00
|
|
|
import Control.Monad (liftM, zipWithM)
|
2017-03-04 13:03:41 +01:00
|
|
|
import Data.Aeson (FromJSON (..), Result (..), ToJSON (..), Value (Object),
|
|
|
|
encode, fromJSON)
|
2013-07-01 20:49:22 -07:00
|
|
|
import qualified Data.HashMap.Strict as H
|
2017-06-25 21:00:35 +02:00
|
|
|
import Data.List (groupBy, intersperse, transpose)
|
2013-07-01 20:49:22 -07:00
|
|
|
import qualified Data.Map as M
|
2017-03-04 13:03:41 +01:00
|
|
|
import Data.Maybe (isJust)
|
2013-07-01 20:49:22 -07:00
|
|
|
import qualified Data.Text as T
|
|
|
|
import qualified Data.Traversable as Traversable
|
2017-03-04 13:03:41 +01:00
|
|
|
import Text.Pandoc.Definition
|
|
|
|
import Text.Pandoc.Options
|
|
|
|
import Text.Pandoc.Pretty
|
|
|
|
import Text.Pandoc.UTF8 (toStringLazy)
|
|
|
|
import Text.Pandoc.XML (escapeStringForXML)
|
2017-06-25 12:45:25 +02:00
|
|
|
|
2013-07-01 20:49:22 -07:00
|
|
|
-- | Create JSON value for template 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
|
2017-02-25 23:13:23 +01:00
|
|
|
-- assigned. Does nothing if 'writerTemplate' is Nothing.
|
2017-06-10 23:09:53 +02:00
|
|
|
metaToJSON :: (Functor m, Monad m, ToJSON a)
|
2013-07-01 20:49:22 -07:00
|
|
|
=> WriterOptions
|
2017-06-10 23:09:53 +02:00
|
|
|
-> ([Block] -> m a)
|
|
|
|
-> ([Inline] -> m a)
|
2013-07-01 20:49:22 -07:00
|
|
|
-> Meta
|
|
|
|
-> m Value
|
2017-02-25 23:13:23 +01:00
|
|
|
metaToJSON opts blockWriter inlineWriter meta
|
|
|
|
| isJust (writerTemplate opts) =
|
|
|
|
addVariablesToJSON opts <$> metaToJSON' blockWriter inlineWriter meta
|
2013-07-01 20:49:22 -07:00
|
|
|
| otherwise = return (Object H.empty)
|
|
|
|
|
2017-02-25 23:13:23 +01:00
|
|
|
-- | Like 'metaToJSON', but does not include variables and is
|
|
|
|
-- not sensitive to 'writerTemplate'.
|
2017-06-10 23:09:53 +02:00
|
|
|
metaToJSON' :: (Monad m, ToJSON a)
|
|
|
|
=> ([Block] -> m a)
|
|
|
|
-> ([Inline] -> m a)
|
2017-02-25 23:13:23 +01:00
|
|
|
-> Meta
|
|
|
|
-> m Value
|
|
|
|
metaToJSON' blockWriter inlineWriter (Meta metamap) = do
|
|
|
|
renderedMap <- Traversable.mapM
|
|
|
|
(metaValueToJSON blockWriter inlineWriter)
|
|
|
|
metamap
|
2017-07-13 23:37:21 +02:00
|
|
|
return $ M.foldrWithKey defField (Object H.empty) renderedMap
|
2017-02-25 23:13:23 +01:00
|
|
|
|
|
|
|
-- | Add variables to JSON object, replacing any existing values.
|
|
|
|
-- Also include @meta-json@, a field containing a string representation
|
|
|
|
-- of the original JSON object itself, prior to addition of variables.
|
|
|
|
addVariablesToJSON :: WriterOptions -> Value -> Value
|
|
|
|
addVariablesToJSON opts metadata =
|
2017-02-25 23:42:56 +01:00
|
|
|
foldl (\acc (x,y) -> setField x y acc)
|
|
|
|
(defField "meta-json" (toStringLazy $ encode metadata) (Object mempty))
|
2017-02-25 23:13:23 +01:00
|
|
|
(writerVariables opts)
|
2017-02-25 23:42:56 +01:00
|
|
|
`combineMetadata` metadata
|
|
|
|
where combineMetadata (Object o1) (Object o2) = Object $ H.union o1 o2
|
2017-03-04 13:03:41 +01:00
|
|
|
combineMetadata x _ = x
|
2017-02-25 23:13:23 +01:00
|
|
|
|
2017-06-10 23:09:53 +02:00
|
|
|
metaValueToJSON :: (Monad m, ToJSON a)
|
|
|
|
=> ([Block] -> m a)
|
|
|
|
-> ([Inline] -> m a)
|
2013-07-01 20:49:22 -07:00
|
|
|
-> MetaValue
|
|
|
|
-> m Value
|
|
|
|
metaValueToJSON blockWriter inlineWriter (MetaMap metamap) = liftM toJSON $
|
|
|
|
Traversable.mapM (metaValueToJSON blockWriter inlineWriter) metamap
|
|
|
|
metaValueToJSON blockWriter inlineWriter (MetaList xs) = liftM toJSON $
|
|
|
|
Traversable.mapM (metaValueToJSON blockWriter inlineWriter) xs
|
2013-08-06 23:31:01 -07:00
|
|
|
metaValueToJSON _ _ (MetaBool b) = return $ toJSON b
|
2013-07-01 20:49:22 -07:00
|
|
|
metaValueToJSON _ _ (MetaString s) = return $ toJSON s
|
|
|
|
metaValueToJSON blockWriter _ (MetaBlocks bs) = liftM toJSON $ blockWriter bs
|
|
|
|
metaValueToJSON _ inlineWriter (MetaInlines bs) = liftM toJSON $ inlineWriter bs
|
|
|
|
|
|
|
|
-- | Retrieve a field value from a JSON object.
|
|
|
|
getField :: FromJSON a
|
|
|
|
=> String
|
|
|
|
-> Value
|
|
|
|
-> Maybe a
|
|
|
|
getField field (Object hashmap) = do
|
|
|
|
result <- H.lookup (T.pack field) hashmap
|
|
|
|
case fromJSON result of
|
|
|
|
Success x -> return x
|
|
|
|
_ -> fail "Could not convert from JSON"
|
|
|
|
getField _ _ = fail "Not a JSON object"
|
|
|
|
|
|
|
|
setField :: ToJSON a
|
|
|
|
=> String
|
|
|
|
-> a
|
|
|
|
-> Value
|
|
|
|
-> Value
|
|
|
|
-- | Set a field of a JSON object. 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 field val (Object hashmap) =
|
|
|
|
Object $ H.insertWith combine (T.pack field) (toJSON val) hashmap
|
|
|
|
where combine newval oldval =
|
|
|
|
case fromJSON oldval of
|
2017-03-04 13:03:41 +01:00
|
|
|
Success xs -> toJSON $ xs ++ [newval]
|
|
|
|
_ -> toJSON [oldval, newval]
|
2013-07-01 20:49:22 -07:00
|
|
|
setField _ _ x = x
|
|
|
|
|
2017-02-25 22:59:16 +01:00
|
|
|
resetField :: ToJSON a
|
|
|
|
=> String
|
|
|
|
-> a
|
|
|
|
-> Value
|
|
|
|
-> Value
|
|
|
|
-- | Reset a field of a JSON object. 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 field val (Object hashmap) =
|
|
|
|
Object $ H.insert (T.pack field) (toJSON val) hashmap
|
|
|
|
resetField _ _ x = x
|
|
|
|
|
2013-07-01 20:49:22 -07:00
|
|
|
defField :: ToJSON a
|
|
|
|
=> String
|
|
|
|
-> a
|
|
|
|
-> Value
|
|
|
|
-> Value
|
|
|
|
-- | Set a field of a JSON object 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 field val (Object hashmap) =
|
|
|
|
Object $ H.insertWith f (T.pack field) (toJSON val) hashmap
|
|
|
|
where f _newval oldval = oldval
|
|
|
|
defField _ _ x = x
|
|
|
|
|
2013-08-18 14:36:40 -07:00
|
|
|
-- Produce an HTML tag with the given pandoc attributes.
|
|
|
|
tagWithAttrs :: String -> Attr -> Doc
|
|
|
|
tagWithAttrs tag (ident,classes,kvs) = hsep
|
|
|
|
["<" <> text tag
|
|
|
|
,if null ident
|
|
|
|
then empty
|
|
|
|
else "id=" <> doubleQuotes (text ident)
|
|
|
|
,if null classes
|
|
|
|
then empty
|
|
|
|
else "class=" <> doubleQuotes (text (unwords classes))
|
2013-10-26 18:22:59 -07:00
|
|
|
,hsep (map (\(k,v) -> text k <> "=" <>
|
2013-08-18 14:36:40 -07:00
|
|
|
doubleQuotes (text (escapeStringForXML v))) kvs)
|
2013-10-26 18:22:59 -07:00
|
|
|
] <> ">"
|
2014-01-02 15:22:50 -08:00
|
|
|
|
|
|
|
isDisplayMath :: Inline -> Bool
|
|
|
|
isDisplayMath (Math DisplayMath _) = True
|
|
|
|
isDisplayMath _ = False
|
|
|
|
|
|
|
|
stripLeadingTrailingSpace :: [Inline] -> [Inline]
|
|
|
|
stripLeadingTrailingSpace = go . reverse . go . reverse
|
2017-03-04 13:03:41 +01:00
|
|
|
where go (Space:xs) = xs
|
2016-07-01 00:52:52 -04:00
|
|
|
go (SoftBreak:xs) = xs
|
2017-03-04 13:03:41 +01:00
|
|
|
go xs = xs
|
2014-01-02 15:22:50 -08:00
|
|
|
|
|
|
|
-- Put display math in its own block (for ODT/DOCX).
|
|
|
|
fixDisplayMath :: Block -> Block
|
|
|
|
fixDisplayMath (Plain lst)
|
|
|
|
| any isDisplayMath lst && not (all isDisplayMath lst) =
|
|
|
|
-- chop into several paragraphs so each displaymath is its own
|
|
|
|
Div ("",["math"],[]) $ map (Plain . stripLeadingTrailingSpace) $
|
|
|
|
groupBy (\x y -> (isDisplayMath x && isDisplayMath y) ||
|
|
|
|
not (isDisplayMath x || isDisplayMath y)) lst
|
|
|
|
fixDisplayMath (Para lst)
|
|
|
|
| any isDisplayMath lst && not (all isDisplayMath lst) =
|
|
|
|
-- chop into several paragraphs so each displaymath is its own
|
|
|
|
Div ("",["math"],[]) $ map (Para . stripLeadingTrailingSpace) $
|
|
|
|
groupBy (\x y -> (isDisplayMath x && isDisplayMath y) ||
|
|
|
|
not (isDisplayMath x || isDisplayMath y)) lst
|
|
|
|
fixDisplayMath x = x
|
2017-02-04 12:52:08 +01:00
|
|
|
|
|
|
|
unsmartify :: WriterOptions -> String -> String
|
|
|
|
unsmartify opts ('\8217':xs) = '\'' : unsmartify opts xs
|
|
|
|
unsmartify opts ('\8230':xs) = "..." ++ unsmartify opts xs
|
|
|
|
unsmartify opts ('\8211':xs)
|
|
|
|
| isEnabled Ext_old_dashes opts = '-' : unsmartify opts xs
|
|
|
|
| otherwise = "--" ++ unsmartify opts xs
|
|
|
|
unsmartify opts ('\8212':xs)
|
|
|
|
| isEnabled Ext_old_dashes opts = "--" ++ unsmartify opts xs
|
|
|
|
| otherwise = "---" ++ unsmartify opts xs
|
2017-08-08 13:16:45 -07:00
|
|
|
unsmartify opts ('\8220':xs) = '"' : unsmartify opts xs
|
|
|
|
unsmartify opts ('\8221':xs) = '"' : unsmartify opts xs
|
|
|
|
unsmartify opts ('\8216':xs) = '\'' : unsmartify opts xs
|
2017-02-04 12:52:08 +01:00
|
|
|
unsmartify opts (x:xs) = x : unsmartify opts xs
|
|
|
|
unsmartify _ [] = []
|
|
|
|
|
2017-03-21 10:16:11 +01:00
|
|
|
gridTable :: Monad m
|
|
|
|
=> WriterOptions
|
|
|
|
-> (WriterOptions -> [Block] -> m Doc)
|
|
|
|
-> Bool -- ^ headless
|
|
|
|
-> [Alignment]
|
|
|
|
-> [Double]
|
|
|
|
-> [[Block]]
|
|
|
|
-> [[[Block]]]
|
|
|
|
-> m Doc
|
|
|
|
gridTable opts blocksToDoc headless aligns widths headers rows = do
|
|
|
|
let numcols = maximum (length aligns : length widths :
|
|
|
|
map length (headers:rows))
|
2017-03-21 14:16:46 +01:00
|
|
|
let handleGivenWidths widths' = do
|
2017-03-23 16:54:24 +01:00
|
|
|
let widthsInChars' = map (
|
|
|
|
(\x -> if x < 1 then 1 else x) .
|
|
|
|
(\x -> x - 3) . floor .
|
|
|
|
(fromIntegral (writerColumns opts) *)
|
|
|
|
) widths'
|
2017-03-21 14:16:46 +01:00
|
|
|
rawHeaders' <- zipWithM blocksToDoc
|
|
|
|
(map (\w -> opts{writerColumns =
|
|
|
|
min (w - 2) (writerColumns opts)}) widthsInChars')
|
|
|
|
headers
|
|
|
|
rawRows' <- mapM
|
|
|
|
(\cs -> zipWithM blocksToDoc
|
|
|
|
(map (\w -> opts{writerColumns =
|
|
|
|
min (w - 2) (writerColumns opts)}) widthsInChars')
|
|
|
|
cs)
|
|
|
|
rows
|
|
|
|
return (widthsInChars', rawHeaders', rawRows')
|
|
|
|
let handleZeroWidths = do
|
|
|
|
rawHeaders' <- mapM (blocksToDoc opts) headers
|
|
|
|
rawRows' <- mapM (mapM (blocksToDoc opts)) rows
|
2017-03-23 14:33:39 +01:00
|
|
|
let numChars [] = 0
|
|
|
|
numChars xs = maximum . map offset $ xs
|
2017-03-21 14:16:46 +01:00
|
|
|
let widthsInChars' =
|
2017-03-23 14:59:51 +01:00
|
|
|
map numChars $ transpose (rawHeaders' : rawRows')
|
2017-03-21 14:16:46 +01:00
|
|
|
if sum widthsInChars' > writerColumns opts
|
|
|
|
then -- use even widths
|
|
|
|
handleGivenWidths
|
|
|
|
(replicate numcols (1.0 / fromIntegral numcols) :: [Double])
|
|
|
|
else return (widthsInChars', rawHeaders', rawRows')
|
|
|
|
(widthsInChars, rawHeaders, rawRows) <- if all (== 0) widths
|
|
|
|
then handleZeroWidths
|
|
|
|
else handleGivenWidths widths
|
2017-03-21 10:02:30 +01:00
|
|
|
let hpipeBlocks blocks = hcat [beg, middle, end]
|
|
|
|
where h = maximum (1 : map height blocks)
|
|
|
|
sep' = lblock 3 $ vcat (map text $ replicate h " | ")
|
|
|
|
beg = lblock 2 $ vcat (map text $ replicate h "| ")
|
|
|
|
end = lblock 2 $ vcat (map text $ replicate h " |")
|
|
|
|
middle = chomp $ hcat $ intersperse sep' blocks
|
|
|
|
let makeRow = hpipeBlocks . zipWith lblock widthsInChars
|
2017-03-21 10:16:11 +01:00
|
|
|
let head' = makeRow rawHeaders
|
2017-03-21 10:02:30 +01:00
|
|
|
let rows' = map (makeRow . map chomp) rawRows
|
|
|
|
let borderpart ch align widthInChars =
|
2017-03-23 16:54:24 +01:00
|
|
|
(if (align == AlignLeft || align == AlignCenter)
|
2017-03-21 10:02:30 +01:00
|
|
|
then char ':'
|
|
|
|
else char ch) <>
|
2017-03-23 16:54:24 +01:00
|
|
|
text (replicate widthInChars ch) <>
|
2017-03-21 10:02:30 +01:00
|
|
|
(if (align == AlignRight || align == AlignCenter)
|
|
|
|
then char ':'
|
|
|
|
else char ch)
|
|
|
|
let border ch aligns' widthsInChars' =
|
|
|
|
char '+' <>
|
|
|
|
hcat (intersperse (char '+') (zipWith (borderpart ch)
|
|
|
|
aligns' widthsInChars')) <> char '+'
|
|
|
|
let body = vcat $ intersperse (border '-' (repeat AlignDefault) widthsInChars)
|
|
|
|
rows'
|
|
|
|
let head'' = if headless
|
|
|
|
then empty
|
|
|
|
else head' $$ border '=' aligns widthsInChars
|
|
|
|
if headless
|
|
|
|
then return $
|
|
|
|
border '-' aligns widthsInChars $$
|
|
|
|
body $$
|
|
|
|
border '-' (repeat AlignDefault) widthsInChars
|
|
|
|
else return $
|
|
|
|
border '-' (repeat AlignDefault) widthsInChars $$
|
|
|
|
head'' $$
|
|
|
|
body $$
|
|
|
|
border '-' (repeat AlignDefault) widthsInChars
|