Add lookupMeta* functions to Text.Pandoc.Writers.Shared (#4907)

Remove exported functions `metaValueToInlines`, `metaValueToString`. Add new exported functions `lookupMetaBool`, `lookupMetaBlocks`, `lookupMetaInlines`, `lookupMetaString`. Use these whenever possible for uniformity in writers. API change (major, because of removed function `metaValueToInlines`. `metaValueToString` wasn't in any released version.)
2018-10-04 18:45:59 +02:00 · 2018-10-04 18:45:59 +02:00 · 600034d7ff
commit 600034d7ff
parent 1a6e6a3a03
6 changed files with 68 additions and 65 deletions
--- a/src/Text/Pandoc/Readers/Org/DocumentTree.hs
+++ b/src/Text/Pandoc/Readers/Org/DocumentTree.hs
@ -43,7 +43,6 @@ import Text.Pandoc.Readers.Org.BlockStarts
 import Text.Pandoc.Readers.Org.ParserState
 import Text.Pandoc.Readers.Org.Parsing

-import qualified Data.Map as Map
 import qualified Text.Pandoc.Builder as B

 --
@ -58,7 +57,7 @@ documentTree :: PandocMonad m
 documentTree blocks inline = do
  initialBlocks <- blocks
  headlines <- sequence <$> manyTill (headline blocks inline 1) eof
-  title <- fmap (getTitle . unMeta) . orgStateMeta <$> getState
+  title <- fmap docTitle . orgStateMeta <$> getState
  return $ do
    headlines' <- headlines
    initialBlocks' <- initialBlocks
@ -73,12 +72,6 @@ documentTree blocks inline = do
      , headlineContents = initialBlocks'
      , headlineChildren = headlines'
      }
- where
-  getTitle :: Map.Map String MetaValue -> [Inline]
-  getTitle metamap =
-    case Map.lookup "title" metamap of
-      Just (MetaInlines inlns) -> inlns
-      _                        -> []

 newtype Tag = Tag { fromTag :: String }
  deriving (Show, Eq)
--- a/src/Text/Pandoc/Writers/Docx.hs
+++ b/src/Text/Pandoc/Writers/Docx.hs
@ -66,8 +66,7 @@ import Text.Pandoc.Readers.Docx.StyleMap
 import Text.Pandoc.Shared hiding (Element)
 import Text.Pandoc.Walk
 import Text.Pandoc.Writers.Math
-import Text.Pandoc.Writers.Shared (isDisplayMath, fixDisplayMath,
-                                   metaValueToInlines)
+import Text.Pandoc.Writers.Shared
 import Text.Printf (printf)
 import Text.TeXMath
 import Text.XML.Light as XML
@ -267,8 +266,9 @@ writeDocx opts doc@(Pandoc meta _) = do
  -- parse styledoc for heading styles
  let styleMaps = getStyleMaps styledoc

-  let tocTitle = fromMaybe (stTocTitle defaultWriterState) $
-                    metaValueToInlines <$> lookupMeta "toc-title" meta
+  let tocTitle = case lookupMetaInlines "toc-title" meta of
+                   [] -> stTocTitle defaultWriterState
+                   ls -> ls

  let initialSt = defaultWriterState {
          stStyleMaps  = styleMaps
@ -760,24 +760,9 @@ writeOpenXML opts (Pandoc meta blocks) = do
  let tit = docTitle meta
  let auths = docAuthors meta
  let dat = docDate meta
-  let abstract' = case lookupMeta "abstract" meta of
-                       Just (MetaBlocks bs)   -> bs
-                       Just (MetaInlines ils) -> [Plain ils]
-                       Just (MetaString s)    -> [Plain [Str s]]
-                       _                      -> []
-  let subtitle' = case lookupMeta "subtitle" meta of
-                       Just (MetaBlocks [Plain xs]) -> xs
-                       Just (MetaBlocks [Para  xs]) -> xs
-                       Just (MetaInlines xs)        -> xs
-                       Just (MetaString s)          -> [Str s]
-                       _                            -> []
-  let includeTOC = writerTableOfContents opts ||
-                   case lookupMeta "toc" meta of
-                       Just (MetaBlocks _)     -> True
-                       Just (MetaInlines _)    -> True
-                       Just (MetaString (_:_)) -> True
-                       Just (MetaBool True)    -> True
-                       _                       -> False
+  let abstract' = lookupMetaBlocks "abstract" meta
+  let subtitle' = lookupMetaInlines "subtitle" meta
+  let includeTOC = writerTableOfContents opts || lookupMetaBool "toc" meta
  title <- withParaPropM (pStyleM "Title") $ blocksToOpenXML opts [Para tit | not (null tit)]
  subtitle <- withParaPropM (pStyleM "Subtitle") $ blocksToOpenXML opts [Para subtitle' | not (null subtitle')]
  authors <- withParaProp (pCustomStyle "Author") $ blocksToOpenXML opts $
--- a/src/Text/Pandoc/Writers/OpenDocument.hs
+++ b/src/Text/Pandoc/Writers/OpenDocument.hs
@ -226,8 +226,10 @@ handleSpaces s
 -- | Convert Pandoc document to string in OpenDocument format.
 writeOpenDocument :: PandocMonad m => WriterOptions -> Pandoc -> m Text
 writeOpenDocument opts (Pandoc meta blocks) = do
-  lang <- fromMaybe (Lang "en" "US" "" []) <$>
-                toLang (metaValueToString <$> lookupMeta "lang" meta)
+  let defLang = Lang "en" "US" "" []
+  lang <- case lookupMetaString "lang" meta of
+            "" -> pure defLang
+            s  -> fromMaybe defLang <$> toLang (Just s)
  setTranslations lang
  let colwidth = if writerWrapText opts == WrapAuto
                    then Just $ writerColumns opts
--- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
+++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs
@ -72,7 +72,7 @@ import Text.Pandoc.Logging
 import Text.Pandoc.Walk
 import Data.Time (UTCTime)
 import qualified Text.Pandoc.Shared as Shared -- so we don't overlap "Element"
-import Text.Pandoc.Writers.Shared (metaValueToInlines)
+import Text.Pandoc.Writers.Shared (lookupMetaInlines)
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Maybe (maybeToList, fromMaybe)
@ -731,9 +731,9 @@ makeEndNotesSlideBlocks = do
  anchorSet <- M.keysSet <$> gets stAnchorMap
  if M.null noteIds
    then return []
-    else let title = case lookupMeta "notes-title" meta of
-                       Just val -> metaValueToInlines val
-                       Nothing  -> [Str "Notes"]
+    else let title = case lookupMetaInlines "notes-title" meta of
+                       [] -> [Str "Notes"]
+                       ls -> ls
             ident = Shared.uniqueIdent title anchorSet
             hdr = Header slideLevel (ident, [], []) title
             blks = concatMap (\(n, bs) -> makeNoteEntry n bs) $
@ -744,13 +744,7 @@ getMetaSlide :: Pres (Maybe Slide)
 getMetaSlide  = do
  meta <- asks envMetadata
  title <- inlinesToParElems $ docTitle meta
-  subtitle <- inlinesToParElems $
-    case lookupMeta "subtitle" meta of
-      Just (MetaString s)           -> [Str s]
-      Just (MetaInlines ils)        -> ils
-      Just (MetaBlocks [Plain ils]) -> ils
-      Just (MetaBlocks [Para ils])  -> ils
-      _                             -> []
+  subtitle <- inlinesToParElems $ lookupMetaInlines "subtitle" meta
  authors <- mapM inlinesToParElems $ docAuthors meta
  date <- inlinesToParElems $ docDate meta
  if null title && null subtitle && null authors && null date
@ -785,9 +779,9 @@ makeTOCSlide blks = local (\env -> env{envCurSlideId = tocSlideId}) $ do
  contents <- BulletList <$> mapM elementToListItem (Shared.hierarchicalize blks)
  meta <- asks envMetadata
  slideLevel <- asks envSlideLevel
-  let tocTitle = case lookupMeta "toc-title" meta of
-                   Just val -> metaValueToInlines val
-                   Nothing  -> [Str "Table of Contents"]
+  let tocTitle = case lookupMetaInlines "toc-title" meta of
+                   [] -> [Str "Table of Contents"]
+                   ls -> ls
      hdr = Header slideLevel nullAttr tocTitle
  blocksToSlide [hdr, contents]

--- a/src/Text/Pandoc/Writers/RST.hs
+++ b/src/Text/Pandoc/Writers/RST.hs
@ -82,10 +82,7 @@ pandocToRST (Pandoc meta blocks) = do
                    else Nothing
  let render' :: Doc -> Text
      render' = render colwidth
-  let subtit = case lookupMeta "subtitle" meta of
-                    Just (MetaBlocks [Plain xs])  -> xs
-                    Just (MetaInlines xs)         -> xs
-                    _                             -> []
+  let subtit = lookupMetaInlines "subtitle" meta
  title <- titleToRST (docTitle meta) subtit
  metadata <- metaToJSON opts
                (fmap render' . blockListToRST)
--- a/src/Text/Pandoc/Writers/Shared.hs
+++ b/src/Text/Pandoc/Writers/Shared.hs
@ -42,8 +42,10 @@ module Text.Pandoc.Writers.Shared (
                     , fixDisplayMath
                     , unsmartify
                     , gridTable
-                     , metaValueToInlines
-                     , metaValueToString
+                     , lookupMetaBool
+                     , lookupMetaBlocks
+                     , lookupMetaInlines
+                     , lookupMetaString
                     , stripLeadingTrailingSpace
                     , groffEscape
                     )
@ -63,7 +65,6 @@ import Text.Pandoc.Definition
 import Text.Pandoc.Options
 import Text.Pandoc.Pretty
 import Text.Pandoc.Shared (stringify)
-import Text.Pandoc.Walk (query)
 import Text.Pandoc.UTF8 (toStringLazy)
 import Text.Pandoc.XML (escapeStringForXML)
 import Text.Printf (printf)
@ -339,19 +340,50 @@ gridTable opts blocksToDoc headless aligns widths headers rows = do
           body $$
           border '-' (repeat AlignDefault) widthsInChars

-metaValueToInlines :: MetaValue -> [Inline]
-metaValueToInlines (MetaString s)    = [Str s]
-metaValueToInlines (MetaInlines ils) = ils
-metaValueToInlines (MetaBlocks bs)   = query return bs
-metaValueToInlines (MetaBool b)      = [Str $ show b]
-metaValueToInlines _                 = []

-metaValueToString :: MetaValue -> String
-metaValueToString (MetaString s)    = s
-metaValueToString (MetaInlines ils) = stringify ils
-metaValueToString (MetaBlocks bs)   = stringify bs
-metaValueToString (MetaBool b)      = show b
-metaValueToString _                 = ""
+
+-- | Retrieve the metadata value for a given @key@
+-- and convert to Bool.
+lookupMetaBool :: String -> Meta -> Bool
+lookupMetaBool key meta =
+  case lookupMeta key meta of
+      Just (MetaBlocks _)     -> True
+      Just (MetaInlines _)    -> True
+      Just (MetaString (_:_)) -> True
+      Just (MetaBool True)    -> True
+      _                       -> False
+
+-- | Retrieve the metadata value for a given @key@
+-- and extract blocks.
+lookupMetaBlocks :: String -> Meta -> [Block]
+lookupMetaBlocks key meta =
+  case lookupMeta key meta of
+         Just (MetaBlocks bs)   -> bs
+         Just (MetaInlines ils) -> [Plain ils]
+         Just (MetaString s)    -> [Plain [Str s]]
+         _                      -> []
+
+-- | Retrieve the metadata value for a given @key@
+-- and extract inlines.
+lookupMetaInlines :: String -> Meta -> [Inline]
+lookupMetaInlines key meta =
+  case lookupMeta key meta of
+         Just (MetaString s)           -> [Str s]
+         Just (MetaInlines ils)        -> ils
+         Just (MetaBlocks [Plain ils]) -> ils
+         Just (MetaBlocks [Para ils])  -> ils
+         _                             -> []
+
+-- | Retrieve the metadata value for a given @key@
+-- and convert to String.
+lookupMetaString :: String -> Meta -> String
+lookupMetaString key meta =
+  case lookupMeta key meta of
+         Just (MetaString s)    -> s
+         Just (MetaInlines ils) -> stringify ils
+         Just (MetaBlocks bs)   -> stringify bs
+         Just (MetaBool b)      -> show b
+         _                      -> ""

 -- | Escape non-ASCII characters using groff \u[..] sequences.
 groffEscape :: T.Text -> T.Text