Writers.Shared: refactored getLang, splitLang...

into `Lang(..)`, `getLang`, `parceBCP47`.

4 files changed, 55 insertions, 36 deletions

diff --git a/src/Text/Pandoc/Writers/Docx.hs b/src/Text/Pandoc/Writers/Docx.hs
index d93b99486..52ababb14 100644
--- a/src/Text/Pandoc/Writers/Docx.hs
+++ b/src/Text/Pandoc/Writers/Docx.hs
@@ -67,7 +67,7 @@ import Text.Pandoc.Shared hiding (Element)
 import qualified Text.Pandoc.UTF8 as UTF8
 import Text.Pandoc.Walk
 import Text.Pandoc.Writers.Math
-import Text.Pandoc.Writers.Shared (fixDisplayMath, getLang)
+import Text.Pandoc.Writers.Shared (fixDisplayMath, getLang, renderLang)
 import Text.Printf (printf)
 import Text.TeXMath
 import Text.XML.Light as XML
@@ -257,9 +257,11 @@ writeDocx opts doc@(Pandoc meta _) = do
                        )
 
   -- styles
-  let lang = getLang opts meta
+  lang <- getLang opts meta
   let addLang :: Element -> Element
-      addLang e = case lang >>= \l -> (return . XMLC.toTree . go l . XMLC.fromElement) e of
+      addLang e = case lang >>= \l ->
+                         (return . XMLC.toTree . go (renderLang l)
+                                 . XMLC.fromElement) e of
                     Just (Elem e') -> e'
                     _              -> e -- return original
         where go :: String -> Cursor -> Cursor
diff --git a/src/Text/Pandoc/Writers/ODT.hs b/src/Text/Pandoc/Writers/ODT.hs
index dff4f8fcf..8573f5719 100644
--- a/src/Text/Pandoc/Writers/ODT.hs
+++ b/src/Text/Pandoc/Writers/ODT.hs
@@ -50,7 +50,8 @@ import Text.Pandoc.Shared (stringify)
 import Text.Pandoc.UTF8 (fromStringLazy, fromTextLazy, toStringLazy)
 import Text.Pandoc.Walk
 import Text.Pandoc.Writers.OpenDocument (writeOpenDocument)
-import Text.Pandoc.Writers.Shared (fixDisplayMath, getLang, splitLang)
+import Text.Pandoc.Writers.Shared (fixDisplayMath, getLang, Lang(..),
+           renderLang)
 import Text.Pandoc.XML
 import Text.TeXMath
 import Text.XML.Light
@@ -79,7 +80,7 @@ pandocToODT :: PandocMonad m
 pandocToODT opts doc@(Pandoc meta _) = do
   let datadir = writerUserDataDir opts
   let title = docTitle meta
-  let lang = getLang opts meta
+  lang <- getLang opts meta
   refArchive <-
        case writerReferenceDoc opts of
              Just f -> liftM toArchive $ lift $ P.readFileLazy f
@@ -140,7 +141,7 @@ pandocToODT opts doc@(Pandoc meta _) = do
                    $$
                    case lang of
                         Just l -> inTagsSimple "dc:language"
-                                    (text (escapeStringForXML l))
+                                    (text (escapeStringForXML (renderLang l)))
                         Nothing -> empty
                  )
              )
@@ -153,10 +154,9 @@ pandocToODT opts doc@(Pandoc meta _) = do
                   $ addEntryToArchive metaEntry archive'
   return $ fromArchive archive''
 
-updateStyleWithLang :: PandocMonad m => Maybe String -> Archive -> O m Archive
+updateStyleWithLang :: PandocMonad m => Maybe Lang -> Archive -> O m Archive
 updateStyleWithLang Nothing arch = return arch
-updateStyleWithLang (Just l) arch = do
-  (mblang, mbcountry) <- splitLang l
+updateStyleWithLang (Just lang) arch = do
   epochtime <- floor `fmap` (lift P.getPOSIXTime)
   return arch{ zEntries = [if eRelativePath e == "styles.xml"
                               then case parseXMLDoc
@@ -166,16 +166,16 @@ updateStyleWithLang (Just l) arch = do
                                         toEntry "styles.xml" epochtime
                                         ( fromStringLazy
                                         . ppTopElement
-                                        . addLang mblang mbcountry $ d )
+                                        . addLang lang $ d )
                               else e
                             | e <- zEntries arch] }
 
-addLang :: Maybe String -> Maybe String -> Element -> Element
-addLang mblang mbcountry = everywhere' (mkT updateLangAttr)
-    where updateLangAttr (Attr n@(QName "language" _ (Just "fo")) l)
-                           = Attr n (maybe l id mblang)
-          updateLangAttr (Attr n@(QName "country" _ (Just "fo")) c)
-                           = Attr n (maybe c id mbcountry)
+addLang :: Lang -> Element -> Element
+addLang (Lang lang country) = everywhere' (mkT updateLangAttr)
+    where updateLangAttr (Attr n@(QName "language" _ (Just "fo")) _)
+                           = Attr n lang
+          updateLangAttr (Attr n@(QName "country" _ (Just "fo")) _)
+                           = Attr n country
           updateLangAttr x = x
 
 -- | transform both Image and Math elements
diff --git a/src/Text/Pandoc/Writers/OpenDocument.hs b/src/Text/Pandoc/Writers/OpenDocument.hs
index 3a720acdc..57f3c1194 100644
--- a/src/Text/Pandoc/Writers/OpenDocument.hs
+++ b/src/Text/Pandoc/Writers/OpenDocument.hs
@@ -36,7 +36,6 @@ import Control.Arrow ((***), (>>>))
 import Control.Monad.State.Strict hiding (when)
 import Data.Char (chr)
 import Data.List (sortBy)
-import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Map as Map
 import Data.Ord (comparing)
@@ -608,8 +607,14 @@ paraTableStyles t s (a:xs)
                      [ ("fo:text-align", x)
                      , ("style:justify-single-word", "false")]
 
-data TextStyle = Italic | Bold | Strike | Sub | Sup | SmallC | Pre
-                 | Lang String String
+data TextStyle = Italic
+               | Bold
+               | Strike
+               | Sub
+               | Sup
+               | SmallC
+               | Pre
+               | Language String String
                deriving ( Eq,Ord )
 
 textStyleAttr :: TextStyle -> [(String,String)]
@@ -627,7 +632,7 @@ textStyleAttr s
     | Pre    <- s = [("style:font-name"              ,"Courier New")
                     ,("style:font-name-asian"        ,"Courier New")
                     ,("style:font-name-complex"      ,"Courier New")]
-    | Lang lang country <- s
+    | Language lang country <- s
                   = [("fo:language"                  ,lang)
                     ,("fo:country"                   ,country)]
     | otherwise   = []
@@ -637,9 +642,8 @@ withLangFromAttr (_,_,kvs) action =
   case lookup "lang" kvs of
        Nothing -> action
        Just l  -> do
-         (mblang, mbcountry) <- splitLang l
-         case (mblang, mbcountry) of
-              (Just lang, _) -> withTextStyle
-                                (Lang lang (fromMaybe "" mbcountry))
-                                action
+         mblang <- parseBCP47 l
+         case mblang of
+              Just (Lang lang country) -> withTextStyle
+                                (Language lang country) action
               _ -> action
diff --git a/src/Text/Pandoc/Writers/Shared.hs b/src/Text/Pandoc/Writers/Shared.hs
index 0b35d27f6..efb553ac2 100644
--- a/src/Text/Pandoc/Writers/Shared.hs
+++ b/src/Text/Pandoc/Writers/Shared.hs
@@ -30,7 +30,9 @@ Shared utility functions for pandoc writers.
 -}
 module Text.Pandoc.Writers.Shared (
                        getLang
-                     , splitLang
+                     , parseBCP47
+                     , Lang(..)
+                     , renderLang
                      , metaToJSON
                      , metaToJSON'
                      , addVariablesToJSON
@@ -62,30 +64,41 @@ import Text.Pandoc.Shared (splitBy)
 import Text.Pandoc.UTF8 (toStringLazy)
 import Text.Pandoc.XML (escapeStringForXML)
 
+-- | Represents BCP 47 language/country code.
+data Lang = Lang String String
+
+-- | Render a Lang as BCP 47.
+renderLang :: Lang -> String
+renderLang (Lang la co) = la ++ if null co
+                                   then ""
+                                   else '-':co
+
 -- | Get the contents of the `lang` metadata field or variable.
-getLang :: WriterOptions -> Meta -> Maybe String
-getLang opts meta =
-  lookup "lang" (writerVariables opts)
+getLang :: PandocMonad m => WriterOptions -> Meta -> m (Maybe Lang)
+getLang opts meta = maybe (return Nothing) parseBCP47 $
+  case lookup "lang" (writerVariables opts) of
+       Just s -> Just s
+       _      -> Nothing
   `mplus`
   case lookupMeta "lang" meta of
        Just (MetaInlines [Str s]) -> Just s
        Just (MetaString s)        -> Just s
        _                          -> Nothing
 
--- | Split `lang` field into lang and country, issuing warning
--- if it doesn't look valid.
-splitLang :: PandocMonad m => String -> m (Maybe String, Maybe String)
-splitLang lang =
+-- | Parse a BCP 47 string as a Lang, issuing a warning if there
+-- are issues.
+parseBCP47 :: PandocMonad m => String -> m (Maybe Lang)
+parseBCP47 lang =
   case splitBy (== '-') lang of
         [la,co]
           | length la == 2 && length co == 2
-                     -> return (Just la, Just co)
+                     -> return $ Just $ Lang la co
         [la]
           | length la == 2
-                     -> return (Just la, Nothing)
+                     -> return $ Just $ Lang la ""
         _       -> do
           report $ InvalidLang lang
-          return (Nothing, Nothing)
+          return Nothing
 
 -- | Create JSON value for template from a 'Meta' and an association list
 -- of variables, specified at the command line or in the writer.