BCP47: split toLang from getLang, rearranged types.

4 files changed, 55 insertions, 48 deletions

diff --git a/src/Text/Pandoc/BCP47.hs b/src/Text/Pandoc/BCP47.hs
index 956130fb7..16dd3a032 100644
--- a/src/Text/Pandoc/BCP47.hs
+++ b/src/Text/Pandoc/BCP47.hs
@@ -29,6 +29,7 @@ Functions for parsing and rendering BCP47 language identifiers.
 -}
 module Text.Pandoc.BCP47 (
                        getLang
+                     , toLang
                      , parseBCP47
                      , Lang(..)
                      , renderLang
@@ -56,21 +57,26 @@ renderLang lang = intercalate "-" (langLanguage lang : filter (not . null)
                     ([langScript lang, langRegion lang] ++ langVariants lang))
 
 -- | Get the contents of the `lang` metadata field or variable.
-getLang :: PandocMonad m => WriterOptions -> Meta -> m (Maybe Lang)
-getLang opts meta = case
-  (case lookup "lang" (writerVariables opts) of
+getLang :: WriterOptions -> Meta -> Maybe String
+getLang opts meta =
+  case lookup "lang" (writerVariables opts) of
         Just s -> Just s
         _      ->
           case lookupMeta "lang" meta of
                Just (MetaInlines [Str s]) -> Just s
                Just (MetaString s)        -> Just s
-               _                          -> Nothing) of
-       Nothing -> return Nothing
-       Just s  -> case parseBCP47 s of
-                       Left _ -> do
-                         report $ InvalidLang s
-                         return Nothing
-                       Right l -> return (Just l)
+               _                          -> Nothing
+
+-- | Convert BCP47 string to a Lang, issuing warning
+-- if there are problems.
+toLang :: PandocMonad m => Maybe String -> m (Maybe Lang)
+toLang Nothing = return Nothing
+toLang (Just s) =
+  case parseBCP47 s of
+       Left _ -> do
+         report $ InvalidLang s
+         return Nothing
+       Right l -> return (Just l)
 
 -- | Parse a BCP 47 string as a Lang.
 parseBCP47 :: String -> Either String Lang
diff --git a/src/Text/Pandoc/Writers/ConTeXt.hs b/src/Text/Pandoc/Writers/ConTeXt.hs
index ae6cb482f..7886bc052 100644
--- a/src/Text/Pandoc/Writers/ConTeXt.hs
+++ b/src/Text/Pandoc/Writers/ConTeXt.hs
@@ -89,7 +89,7 @@ pandocToConTeXt options (Pandoc meta blocks) = do
                               ,("top","margin-top")
                               ,("bottom","margin-bottom")
                               ]
-  lang <- maybe "" fromBCP47 <$> getLang options meta
+  mblang <- fromBCP47 (getLang options meta)
   let context =   defField "toc" (writerTableOfContents options)
                 $ defField "placelist" (intercalate ("," :: String) $
                      take (writerTOCDepth options +
@@ -102,7 +102,7 @@ pandocToConTeXt options (Pandoc meta blocks) = do
                 $ defField "body" main
                 $ defField "layout" layoutFromMargins
                 $ defField "number-sections" (writerNumberSections options)
-                $ defField "context-lang" lang
+                $ maybe id (defField "context-lang") mblang
                 $ metadata
   let context' = defField "context-dir" (toContextDir
                                          $ getField "dir" context) context
@@ -187,6 +187,7 @@ blockToConTeXt b@(RawBlock _ _ ) = do
   return empty
 blockToConTeXt (Div (ident,_,kvs) bs) = do
   let align dir txt = "\\startalignment[" <> dir <> "]" $$ txt $$ "\\stopalignment"
+  mblang <- fromBCP47 (lookup "lang" kvs)
   let wrapRef txt = if null ident
                        then txt
                        else ("\\reference" <> brackets (text $ toLabel ident) <>
@@ -195,9 +196,9 @@ blockToConTeXt (Div (ident,_,kvs) bs) = do
                   Just "rtl" -> align "righttoleft"
                   Just "ltr" -> align "lefttoright"
                   _          -> id
-      wrapLang txt = case lookup "lang" kvs of
+      wrapLang txt = case mblang of
                        Just lng -> "\\start\\language["
-                                     <> text (fromBCP47' lng) <> "]" $$ txt $$ "\\stop"
+                                     <> text lng <> "]" $$ txt $$ "\\stop"
                        Nothing  -> txt
       wrapBlank txt = blankline <> txt <> blankline
   fmap (wrapBlank . wrapLang . wrapDir . wrapRef) $ blockListToConTeXt bs
@@ -417,12 +418,13 @@ inlineToConTeXt (Note contents) = do
               else text "\\startbuffer " <> nest 2 contents' <>
                    text "\\stopbuffer\\footnote{\\getbuffer}"
 inlineToConTeXt (Span (_,_,kvs) ils) = do
+  mblang <- fromBCP47 (lookup "lang" kvs)
   let wrapDir txt = case lookup "dir" kvs of
                       Just "rtl" -> braces $ "\\righttoleft " <> txt
                       Just "ltr" -> braces $ "\\lefttoright " <> txt
                       _          -> txt
-      wrapLang txt = case lookup "lang" kvs of
-                       Just lng -> "\\start\\language[" <> text (fromBCP47' lng)
+      wrapLang txt = case mblang of
+                       Just lng -> "\\start\\language[" <> text lng
                                       <> "]" <> txt <> "\\stop "
                        Nothing -> txt
   fmap (wrapLang . wrapDir) $ inlineListToConTeXt ils
@@ -459,35 +461,34 @@ sectionHeader (ident,classes,_) hdrLevel lst = do
                                      <> blankline
              _                    -> contents <> blankline
 
-fromBCP47' :: String -> String
-fromBCP47' s = case parseBCP47 s of
-                    Right r -> fromBCP47 r
-                    Left _  -> ""
+fromBCP47 :: PandocMonad m => Maybe String -> WM m (Maybe String)
+fromBCP47 mbs = fromBCP47' <$> toLang mbs
 
 -- Takes a list of the constituents of a BCP 47 language code
 -- and irons out ConTeXt's exceptions
 -- https://tools.ietf.org/html/bcp47#section-2.1
 -- http://wiki.contextgarden.net/Language_Codes
-fromBCP47 :: Lang -> String
-fromBCP47 (Lang "ar" _ "SY" _)     = "ar-sy"
-fromBCP47 (Lang "ar" _ "IQ" _)     = "ar-iq"
-fromBCP47 (Lang "ar" _ "JO" _)     = "ar-jo"
-fromBCP47 (Lang "ar" _ "LB" _)     = "ar-lb"
-fromBCP47 (Lang "ar" _ "DZ" _)     = "ar-dz"
-fromBCP47 (Lang "ar" _ "MA" _)     = "ar-ma"
-fromBCP47 (Lang "de" _ _ ["1901"]) = "deo"
-fromBCP47 (Lang "de" _ "DE" _)     = "de-de"
-fromBCP47 (Lang "de" _ "AT" _)     = "de-at"
-fromBCP47 (Lang "de" _ "CH" _)     = "de-ch"
-fromBCP47 (Lang "el" _ _ ["poly"]) = "agr"
-fromBCP47 (Lang "en" _ "US" _)     = "en-us"
-fromBCP47 (Lang "en" _ "GB" _)     = "en-gb"
-fromBCP47 (Lang "grc"_  _ _)       = "agr"
-fromBCP47 (Lang "el" _ _ _)        = "gr"
-fromBCP47 (Lang "eu" _ _ _)        = "ba"
-fromBCP47 (Lang "he" _ _ _)        = "il"
-fromBCP47 (Lang "jp" _ _ _)        = "ja"
-fromBCP47 (Lang "uk" _ _ _)        = "ua"
-fromBCP47 (Lang "vi" _ _ _)        = "vn"
-fromBCP47 (Lang "zh" _ _ _)        = "cn"
-fromBCP47 (Lang l _ _ _)           = l
+fromBCP47' :: Maybe Lang -> Maybe String
+fromBCP47' (Just (Lang "ar" _ "SY" _)     )  = Just "ar-sy"
+fromBCP47' (Just (Lang "ar" _ "IQ" _)     )  = Just "ar-iq"
+fromBCP47' (Just (Lang "ar" _ "JO" _)     )  = Just "ar-jo"
+fromBCP47' (Just (Lang "ar" _ "LB" _)     )  = Just "ar-lb"
+fromBCP47' (Just (Lang "ar" _ "DZ" _)     )  = Just "ar-dz"
+fromBCP47' (Just (Lang "ar" _ "MA" _)     )  = Just "ar-ma"
+fromBCP47' (Just (Lang "de" _ _ ["1901"]) )  = Just "deo"
+fromBCP47' (Just (Lang "de" _ "DE" _)     )  = Just "de-de"
+fromBCP47' (Just (Lang "de" _ "AT" _)     )  = Just "de-at"
+fromBCP47' (Just (Lang "de" _ "CH" _)     )  = Just "de-ch"
+fromBCP47' (Just (Lang "el" _ _ ["poly"]) )  = Just "agr"
+fromBCP47' (Just (Lang "en" _ "US" _)     )  = Just "en-us"
+fromBCP47' (Just (Lang "en" _ "GB" _)     )  = Just "en-gb"
+fromBCP47' (Just (Lang "grc"_  _ _)       )  = Just "agr"
+fromBCP47' (Just (Lang "el" _ _ _)        )  = Just "gr"
+fromBCP47' (Just (Lang "eu" _ _ _)        )  = Just "ba"
+fromBCP47' (Just (Lang "he" _ _ _)        )  = Just "il"
+fromBCP47' (Just (Lang "jp" _ _ _)        )  = Just "ja"
+fromBCP47' (Just (Lang "uk" _ _ _)        )  = Just "ua"
+fromBCP47' (Just (Lang "vi" _ _ _)        )  = Just "vn"
+fromBCP47' (Just (Lang "zh" _ _ _)        )  = Just "cn"
+fromBCP47' (Just (Lang l _ _ _)           )  = Just l
+fromBCP47' Nothing                           = Nothing
diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs
index bc8568cd1..06318b20c 100644
--- a/src/Text/Pandoc/Writers/Docx.hs
+++ b/src/Text/Pandoc/Writers/Docx.hs
@@ -68,7 +68,7 @@ import qualified Text.Pandoc.UTF8 as UTF8
 import Text.Pandoc.Walk
 import Text.Pandoc.Writers.Math
 import Text.Pandoc.Writers.Shared (fixDisplayMath)
-import Text.Pandoc.BCP47 (getLang, renderLang)
+import Text.Pandoc.BCP47 (getLang, renderLang, toLang)
 import Text.Printf (printf)
 import Text.TeXMath
 import Text.XML.Light as XML
@@ -258,9 +258,9 @@ writeDocx opts doc@(Pandoc meta _) = do
                        )
 
   -- styles
-  lang <- getLang opts meta
+  mblang <- toLang $ getLang opts meta
   let addLang :: Element -> Element
-      addLang e = case lang >>= \l ->
+      addLang e = case mblang >>= \l ->
                          (return . XMLC.toTree . go (renderLang l)
                                  . XMLC.fromElement) e of
                     Just (Elem e') -> e'
diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs
index 98aa3b30b..785891a9f 100644
--- a/src/Text/Pandoc/Writers/ODT.hs
+++ b/src/Text/Pandoc/Writers/ODT.hs
@@ -51,7 +51,7 @@ import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toStringLazy)
 import Text.Pandoc.Walk
 import Text.Pandoc.Writers.OpenDocument (writeOpenDocument)
 import Text.Pandoc.Writers.Shared (fixDisplayMath)
-import Text.Pandoc.BCP47 (getLang, Lang(..), renderLang)
+import Text.Pandoc.BCP47 (getLang, toLang, Lang(..), renderLang)
 import Text.Pandoc.XML
 import Text.TeXMath
 import Text.XML.Light
@@ -80,7 +80,7 @@ pandocToODT :: PandocMonad m
 pandocToODT opts doc@(Pandoc meta _) = do
   let datadir = writerUserDataDir opts
   let title = docTitle meta
-  lang <- getLang opts meta
+  lang <- toLang (getLang opts meta)
   refArchive <-
        case writerReferenceDoc opts of
              Just f -> liftM toArchive $ lift $ P.readFileLazy f