{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2013 John MacFarlane <jgm@berkeley.edu> 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 Copyright : Copyright (C) 2013 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 ( metaToJSON , getField , setField , defField , tagWithAttrs ) 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 -- | 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 -- assigned. 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 (\key val obj -> defField key val obj) 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 -- | 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 Success xs -> toJSON $ xs ++ [newval] _ -> toJSON [oldval, newval] setField _ _ x = x 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 -- 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)) ] <> hsep (map (\(k,v) -> text k <> "=" <> doubleQuotes (text (escapeStringForXML v))) kvs) <> ">"