module Text.Pandoc.Writers.Shared (
metaToJSON
, getField
, setField
, defField
, tagWithAttrs
, fixDisplayMath
)
where
import Text.Pandoc.Definition
import Text.Pandoc.Pretty
import Text.Pandoc.XML (escapeStringForXML)
import Control.Monad (liftM)
import Text.Pandoc.Options (WriterOptions(..))
import qualified Data.HashMap.Strict as H
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Aeson (FromJSON(..), fromJSON, ToJSON (..), Value(Object), Result(..))
import qualified Data.Traversable as Traversable
import Data.List ( groupBy )
metaToJSON :: Monad m
=> WriterOptions
-> ([Block] -> m String)
-> ([Inline] -> m String)
-> Meta
-> m Value
metaToJSON opts blockWriter inlineWriter (Meta metamap)
| writerStandalone opts = do
let baseContext = foldl (\acc (x,y) -> setField x y acc) (Object H.empty)
$ writerVariables opts
renderedMap <- Traversable.mapM
(metaValueToJSON blockWriter inlineWriter)
metamap
return $ M.foldWithKey defField baseContext renderedMap
| otherwise = return (Object H.empty)
metaValueToJSON :: Monad m
=> ([Block] -> m String)
-> ([Inline] -> m String)
-> 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
metaValueToJSON _ _ (MetaBool b) = return $ toJSON b
metaValueToJSON _ _ (MetaString s) = return $ toJSON s
metaValueToJSON blockWriter _ (MetaBlocks bs) = liftM toJSON $ blockWriter bs
metaValueToJSON _ inlineWriter (MetaInlines bs) = liftM toJSON $ inlineWriter bs
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
setField field val (Object hashmap) =
Object $ H.insertWith combine (T.pack field) (toJSON val) hashmap
where combine newval oldval =
case fromJSON oldval of
Success xs -> toJSON $ xs ++ [newval]
_ -> toJSON [oldval, newval]
setField _ _ x = x
defField :: ToJSON a
=> String
-> a
-> Value
-> Value
defField field val (Object hashmap) =
Object $ H.insertWith f (T.pack field) (toJSON val) hashmap
where f _newval oldval = oldval
defField _ _ x = x
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))
,hsep (map (\(k,v) -> text k <> "=" <>
doubleQuotes (text (escapeStringForXML v))) kvs)
] <> ">"
isDisplayMath :: Inline -> Bool
isDisplayMath (Math DisplayMath _) = True
isDisplayMath _ = False
stripLeadingTrailingSpace :: [Inline] -> [Inline]
stripLeadingTrailingSpace = go . reverse . go . reverse
where go (Space:xs) = xs
go xs = xs
fixDisplayMath :: Block -> Block
fixDisplayMath (Plain lst)
| any isDisplayMath lst && not (all isDisplayMath lst) =
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) =
Div ("",["math"],[]) $ map (Para . stripLeadingTrailingSpace) $
groupBy (\x y -> (isDisplayMath x && isDisplayMath y) ||
not (isDisplayMath x || isDisplayMath y)) lst
fixDisplayMath x = x