{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Citeproc.Element
  ( pLocale
  , pDate
  , Attributes(..)
  , lookupAttribute
  , ElementParser
  , runElementParser
  , parseFailure
  , getChildren
  , allChildren
  , getAttributes
  , getNameAttributes
  , getFormatting
  , getTextContent
  )
where
import Citeproc.Types
import Data.Maybe (fromMaybe)
import Control.Monad (foldM)
import qualified Data.Map as M
import qualified Text.XML as X
import Data.Text (Text)
import qualified Data.Text as T
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Class (lift)

newtype Attributes = Attributes (M.Map Text Text)
  deriving (Int -> Attributes -> ShowS
[Attributes] -> ShowS
Attributes -> String
(Int -> Attributes -> ShowS)
-> (Attributes -> String)
-> ([Attributes] -> ShowS)
-> Show Attributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attributes] -> ShowS
$cshowList :: [Attributes] -> ShowS
show :: Attributes -> String
$cshow :: Attributes -> String
showsPrec :: Int -> Attributes -> ShowS
$cshowsPrec :: Int -> Attributes -> ShowS
Show, b -> Attributes -> Attributes
NonEmpty Attributes -> Attributes
Attributes -> Attributes -> Attributes
(Attributes -> Attributes -> Attributes)
-> (NonEmpty Attributes -> Attributes)
-> (forall b. Integral b => b -> Attributes -> Attributes)
-> Semigroup Attributes
forall b. Integral b => b -> Attributes -> Attributes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Attributes -> Attributes
$cstimes :: forall b. Integral b => b -> Attributes -> Attributes
sconcat :: NonEmpty Attributes -> Attributes
$csconcat :: NonEmpty Attributes -> Attributes
<> :: Attributes -> Attributes -> Attributes
$c<> :: Attributes -> Attributes -> Attributes
Semigroup, Semigroup Attributes
Attributes
Semigroup Attributes
-> Attributes
-> (Attributes -> Attributes -> Attributes)
-> ([Attributes] -> Attributes)
-> Monoid Attributes
[Attributes] -> Attributes
Attributes -> Attributes -> Attributes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Attributes] -> Attributes
$cmconcat :: [Attributes] -> Attributes
mappend :: Attributes -> Attributes -> Attributes
$cmappend :: Attributes -> Attributes -> Attributes
mempty :: Attributes
$cmempty :: Attributes
$cp1Monoid :: Semigroup Attributes
Monoid, Attributes -> Attributes -> Bool
(Attributes -> Attributes -> Bool)
-> (Attributes -> Attributes -> Bool) -> Eq Attributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attributes -> Attributes -> Bool
$c/= :: Attributes -> Attributes -> Bool
== :: Attributes -> Attributes -> Bool
$c== :: Attributes -> Attributes -> Bool
Eq)

lookupAttribute :: Text -> Attributes -> Maybe Text
lookupAttribute :: Text -> Attributes -> Maybe Text
lookupAttribute Text
key (Attributes Map Text Text
kvs) = Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Map Text Text
kvs

type ElementParser = ReaderT (M.Map X.Name Text) (Except CiteprocError)

runElementParser :: ElementParser a -> Either CiteprocError a
runElementParser :: ElementParser a -> Either CiteprocError a
runElementParser ElementParser a
p = Except CiteprocError a -> Either CiteprocError a
forall e a. Except e a -> Either e a
runExcept (ElementParser a -> Map Name Text -> Except CiteprocError a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ElementParser a
p Map Name Text
forall a. Monoid a => a
mempty)

parseFailure :: String -> ElementParser a
parseFailure :: String -> ElementParser a
parseFailure String
s = ExceptT CiteprocError Identity a -> ElementParser a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT CiteprocError Identity a -> ElementParser a)
-> ExceptT CiteprocError Identity a -> ElementParser a
forall a b. (a -> b) -> a -> b
$ CiteprocError -> ExceptT CiteprocError Identity a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> CiteprocError
CiteprocParseError (Text -> CiteprocError) -> Text -> CiteprocError
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s)

getChildren :: Text -> X.Element -> [X.Element]
getChildren :: Text -> Element -> [Element]
getChildren Text
name Element
el = [Element
e | X.NodeElement Element
e <- Element -> [Node]
X.elementNodes Element
el
                         , Name -> Text
X.nameLocalName (Element -> Name
X.elementName Element
e) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name]

allChildren :: X.Element -> [X.Element]
allChildren :: Element -> [Element]
allChildren Element
el = [Element
e | X.NodeElement Element
e <- Element -> [Node]
X.elementNodes Element
el]

getAttributes :: X.Element -> Attributes
getAttributes :: Element -> Attributes
getAttributes =
  Map Text Text -> Attributes
Attributes (Map Text Text -> Attributes)
-> (Element -> Map Text Text) -> Element -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Text) -> Map Name Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Name -> Text
X.nameLocalName (Map Name Text -> Map Text Text)
-> (Element -> Map Name Text) -> Element -> Map Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Map Name Text
X.elementAttributes

-- Like getAttributes but incorporates inheritable attributes.
getNameAttributes :: X.Element -> ElementParser Attributes
getNameAttributes :: Element -> ElementParser Attributes
getNameAttributes Element
node = do
  Map Name Text
nameattr <- ReaderT (Map Name Text) (Except CiteprocError) (Map Name Text)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let xattr :: Map Name Text
xattr = Element -> Map Name Text
X.elementAttributes Element
node Map Name Text -> Map Name Text -> Map Name Text
forall a. Semigroup a => a -> a -> a
<> Map Name Text
nameattr
  Attributes -> ElementParser Attributes
forall (m :: * -> *) a. Monad m => a -> m a
return (Attributes -> ElementParser Attributes)
-> Attributes -> ElementParser Attributes
forall a b. (a -> b) -> a -> b
$ Map Text Text -> Attributes
Attributes (Map Text Text -> Attributes) -> Map Text Text -> Attributes
forall a b. (a -> b) -> a -> b
$ (Name -> Text) -> Map Name Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Name -> Text
X.nameLocalName Map Name Text
xattr

getFormatting :: Attributes -> Formatting
getFormatting :: Attributes -> Formatting
getFormatting Attributes
attr =
   Formatting :: Maybe Lang
-> Maybe FontStyle
-> Maybe FontVariant
-> Maybe FontWeight
-> Maybe TextDecoration
-> Maybe VerticalAlign
-> Maybe Text
-> Maybe Text
-> Maybe DisplayStyle
-> Maybe TextCase
-> Maybe Text
-> Bool
-> Bool
-> Bool
-> Formatting
Formatting
     { formatLang :: Maybe Lang
formatLang = Maybe Lang
forall a. Maybe a
Nothing
     , formatFontStyle :: Maybe FontStyle
formatFontStyle =
          case Text -> Attributes -> Maybe Text
lookupAttribute Text
"font-style" Attributes
attr of
            Just Text
"italic"  -> FontStyle -> Maybe FontStyle
forall a. a -> Maybe a
Just FontStyle
ItalicFont
            Just Text
"oblique" -> FontStyle -> Maybe FontStyle
forall a. a -> Maybe a
Just FontStyle
ObliqueFont
            Just Text
"normal"  -> FontStyle -> Maybe FontStyle
forall a. a -> Maybe a
Just FontStyle
NormalFont
            Maybe Text
_              -> Maybe FontStyle
forall a. Maybe a
Nothing
      , formatFontVariant :: Maybe FontVariant
formatFontVariant =
          case Text -> Attributes -> Maybe Text
lookupAttribute Text
"font-variant" Attributes
attr of
            Just Text
"small-caps" -> FontVariant -> Maybe FontVariant
forall a. a -> Maybe a
Just FontVariant
SmallCapsVariant
            Just Text
"normal"     -> FontVariant -> Maybe FontVariant
forall a. a -> Maybe a
Just FontVariant
NormalVariant
            Maybe Text
_                 -> Maybe FontVariant
forall a. Maybe a
Nothing
      , formatFontWeight :: Maybe FontWeight
formatFontWeight =
          case Text -> Attributes -> Maybe Text
lookupAttribute Text
"font-weight" Attributes
attr of
            Just Text
"bold"   -> FontWeight -> Maybe FontWeight
forall a. a -> Maybe a
Just FontWeight
BoldWeight
            Just Text
"light"  -> FontWeight -> Maybe FontWeight
forall a. a -> Maybe a
Just FontWeight
LightWeight
            Just Text
"normal" -> FontWeight -> Maybe FontWeight
forall a. a -> Maybe a
Just FontWeight
NormalWeight
            Maybe Text
_             -> Maybe FontWeight
forall a. Maybe a
Nothing
      , formatTextDecoration :: Maybe TextDecoration
formatTextDecoration =
          case Text -> Attributes -> Maybe Text
lookupAttribute Text
"text-decoration" Attributes
attr of
            Just Text
"underline" -> TextDecoration -> Maybe TextDecoration
forall a. a -> Maybe a
Just TextDecoration
UnderlineDecoration
            Just Text
"none"      -> TextDecoration -> Maybe TextDecoration
forall a. a -> Maybe a
Just TextDecoration
NoDecoration
            Maybe Text
_                -> Maybe TextDecoration
forall a. Maybe a
Nothing
      , formatVerticalAlign :: Maybe VerticalAlign
formatVerticalAlign =
          case Text -> Attributes -> Maybe Text
lookupAttribute Text
"vertical-align" Attributes
attr of
            Just Text
"sup"       -> VerticalAlign -> Maybe VerticalAlign
forall a. a -> Maybe a
Just VerticalAlign
SupAlign
            Just Text
"sub"       -> VerticalAlign -> Maybe VerticalAlign
forall a. a -> Maybe a
Just VerticalAlign
SubAlign
            Just Text
"baseline"  -> VerticalAlign -> Maybe VerticalAlign
forall a. a -> Maybe a
Just VerticalAlign
BaselineAlign
            Maybe Text
_                -> Maybe VerticalAlign
forall a. Maybe a
Nothing
      , formatPrefix :: Maybe Text
formatPrefix = Text -> Attributes -> Maybe Text
lookupAttribute Text
"prefix" Attributes
attr
      , formatSuffix :: Maybe Text
formatSuffix = Text -> Attributes -> Maybe Text
lookupAttribute Text
"suffix" Attributes
attr
      , formatDisplay :: Maybe DisplayStyle
formatDisplay =
          case Text -> Attributes -> Maybe Text
lookupAttribute Text
"display" Attributes
attr of
            Just Text
"block"        -> DisplayStyle -> Maybe DisplayStyle
forall a. a -> Maybe a
Just DisplayStyle
DisplayBlock
            Just Text
"left-margin"  -> DisplayStyle -> Maybe DisplayStyle
forall a. a -> Maybe a
Just DisplayStyle
DisplayLeftMargin
            Just Text
"right-inline" -> DisplayStyle -> Maybe DisplayStyle
forall a. a -> Maybe a
Just DisplayStyle
DisplayRightInline
            Just Text
"indent"       -> DisplayStyle -> Maybe DisplayStyle
forall a. a -> Maybe a
Just DisplayStyle
DisplayIndent
            Maybe Text
_                   -> Maybe DisplayStyle
forall a. Maybe a
Nothing
      , formatTextCase :: Maybe TextCase
formatTextCase =
          case Text -> Attributes -> Maybe Text
lookupAttribute Text
"text-case" Attributes
attr of
            Just Text
"lowercase"        -> TextCase -> Maybe TextCase
forall a. a -> Maybe a
Just TextCase
Lowercase
            Just Text
"uppercase"        -> TextCase -> Maybe TextCase
forall a. a -> Maybe a
Just TextCase
Uppercase
            Just Text
"capitalize-first" -> TextCase -> Maybe TextCase
forall a. a -> Maybe a
Just TextCase
CapitalizeFirst
            Just Text
"capitalize-all"   -> TextCase -> Maybe TextCase
forall a. a -> Maybe a
Just TextCase
CapitalizeAll
            Just Text
"sentence"         -> TextCase -> Maybe TextCase
forall a. a -> Maybe a
Just TextCase
SentenceCase
            Just Text
"title"            -> TextCase -> Maybe TextCase
forall a. a -> Maybe a
Just TextCase
TitleCase
            Maybe Text
_                       -> Maybe TextCase
forall a. Maybe a
Nothing
      , formatDelimiter :: Maybe Text
formatDelimiter = Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter" Attributes
attr
      , formatStripPeriods :: Bool
formatStripPeriods =
          Text -> Attributes -> Maybe Text
lookupAttribute Text
"strip-periods" Attributes
attr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"true"
      , formatQuotes :: Bool
formatQuotes =
          Text -> Attributes -> Maybe Text
lookupAttribute Text
"quotes" Attributes
attr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"true"
      , formatAffixesInside :: Bool
formatAffixesInside = Bool
False -- should be true for layout only
      }


getTextContent :: X.Element -> Text
getTextContent :: Element -> Text
getTextContent Element
e = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
t | X.NodeContent Text
t <- Element -> [Node]
X.elementNodes Element
e]

pLocale :: X.Element -> ElementParser Locale
pLocale :: Element -> ElementParser Locale
pLocale Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  Maybe Lang
lang <- case Text -> Attributes -> Maybe Text
lookupAttribute Text
"lang" Attributes
attr of
            Maybe Text
Nothing -> Maybe Lang
-> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Lang
forall a. Maybe a
Nothing
            Just Text
l  -> (String
 -> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang))
-> (Lang
    -> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang))
-> Either String Lang
-> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String
-> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang)
forall a. String -> ElementParser a
parseFailure (Maybe Lang
-> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Lang
 -> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang))
-> (Lang -> Maybe Lang)
-> Lang
-> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lang -> Maybe Lang
forall a. a -> Maybe a
Just) (Either String Lang
 -> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang))
-> Either String Lang
-> ReaderT (Map Name Text) (Except CiteprocError) (Maybe Lang)
forall a b. (a -> b) -> a -> b
$ Text -> Either String Lang
parseLang Text
l
  let styleOpts :: Attributes
styleOpts = [Attributes] -> Attributes
forall a. Monoid a => [a] -> a
mconcat ([Attributes] -> Attributes)
-> ([Element] -> [Attributes]) -> [Element] -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element -> Attributes) -> [Element] -> [Attributes]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Attributes
getAttributes ([Element] -> Attributes) -> [Element] -> Attributes
forall a b. (a -> b) -> a -> b
$
                      Text -> Element -> [Element]
getChildren Text
"style-options" Element
node
  let addDateElt :: Element a -> Map DateType (Element a) -> Map DateType (Element a)
addDateElt Element a
e Map DateType (Element a)
m =
        case Element a
e of
          Element (EDate Variable
_ DateType
dateType Maybe ShowDateParts
_ [DP]
_) Formatting
_ -> DateType
-> Element a
-> Map DateType (Element a)
-> Map DateType (Element a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert DateType
dateType Element a
e Map DateType (Element a)
m
          Element a
_ -> String -> Map DateType (Element a)
forall a. HasCallStack => String -> a
error String
"pDate returned an element other than EDate"
  Map DateType (Element Text)
dateElts <- (Element Text
 -> Map DateType (Element Text) -> Map DateType (Element Text))
-> Map DateType (Element Text)
-> [Element Text]
-> Map DateType (Element Text)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Element Text
-> Map DateType (Element Text) -> Map DateType (Element Text)
forall a.
Element a -> Map DateType (Element a) -> Map DateType (Element a)
addDateElt Map DateType (Element Text)
forall a. Monoid a => a
mempty ([Element Text] -> Map DateType (Element Text))
-> ReaderT (Map Name Text) (Except CiteprocError) [Element Text]
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     (Map DateType (Element Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element
 -> ReaderT (Map Name Text) (Except CiteprocError) (Element Text))
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element
-> ReaderT (Map Name Text) (Except CiteprocError) (Element Text)
forall a. Element -> ElementParser (Element a)
pDate (Text -> Element -> [Element]
getChildren Text
"date" Element
node)
  let termNodes :: [Element]
termNodes = (Element -> [Element]) -> [Element] -> [Element]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> Element -> [Element]
getChildren Text
"term") (Text -> Element -> [Element]
getChildren Text
"terms" Element
node)
  Map Text [(Term, Text)]
terms <- (Map Text [(Term, Text)]
 -> Element
 -> ReaderT
      (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)]))
-> Map Text [(Term, Text)]
-> [Element]
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map Text [(Term, Text)]
-> Element
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)])
parseTerm Map Text [(Term, Text)]
forall a. Monoid a => a
mempty [Element]
termNodes
  Locale -> ElementParser Locale
forall (m :: * -> *) a. Monad m => a -> m a
return (Locale -> ElementParser Locale) -> Locale -> ElementParser Locale
forall a b. (a -> b) -> a -> b
$
    Locale :: Maybe Lang
-> Maybe Bool
-> Maybe Bool
-> Map DateType (Element Text)
-> Map Text [(Term, Text)]
-> Locale
Locale
    { localeLanguage :: Maybe Lang
localeLanguage               = Maybe Lang
lang
    , localePunctuationInQuote :: Maybe Bool
localePunctuationInQuote     = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"true") (Text -> Bool) -> Maybe Text -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               Text -> Attributes -> Maybe Text
lookupAttribute Text
"punctuation-in-quote" Attributes
styleOpts
    , localeLimitDayOrdinalsToDay1 :: Maybe Bool
localeLimitDayOrdinalsToDay1 = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"true") (Text -> Bool) -> Maybe Text -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
               Text -> Attributes -> Maybe Text
lookupAttribute Text
"limit-day-ordinals-to-day-1" Attributes
styleOpts
    , localeDate :: Map DateType (Element Text)
localeDate                   = Map DateType (Element Text)
dateElts
    , localeTerms :: Map Text [(Term, Text)]
localeTerms                  = Map Text [(Term, Text)]
terms
    }

parseTerm :: M.Map Text [(Term, Text)]
          -> X.Element
          -> ElementParser (M.Map Text [(Term, Text)])
parseTerm :: Map Text [(Term, Text)]
-> Element
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)])
parseTerm Map Text [(Term, Text)]
m Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  Text
name <- case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name" Attributes
attr of
                Just Text
n   -> Text -> ReaderT (Map Name Text) (Except CiteprocError) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
n
                Maybe Text
Nothing  -> String -> ReaderT (Map Name Text) (Except CiteprocError) Text
forall a. String -> ElementParser a
parseFailure String
"Text node has no name attribute"
  let single :: Text
single = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Element -> Text) -> [Element] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Text
getTextContent ([Element] -> [Text]) -> [Element] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"single" Element
node
  let multiple :: Text
multiple = [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Element -> Text) -> [Element] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Text
getTextContent ([Element] -> [Text]) -> [Element] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"multiple" Element
node
  let txt :: Text
txt = Element -> Text
getTextContent Element
node
  let form :: TermForm
form = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr of
               Just Text
"short"      -> TermForm
Short
               Just Text
"verb"       -> TermForm
Verb
               Just Text
"verb-short" -> TermForm
VerbShort
               Just Text
"symbol"     -> TermForm
Symbol
               Maybe Text
_                 -> TermForm
Long
  let gender :: Maybe TermGender
gender = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"gender" Attributes
attr of
                 Just Text
"masculine"  -> TermGender -> Maybe TermGender
forall a. a -> Maybe a
Just TermGender
Masculine
                 Just Text
"feminine"   -> TermGender -> Maybe TermGender
forall a. a -> Maybe a
Just TermGender
Feminine
                 Maybe Text
_                 -> Maybe TermGender
forall a. Maybe a
Nothing
  let genderForm :: Maybe TermGender
genderForm = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"gender-form" Attributes
attr of
                     Just Text
"masculine"  -> TermGender -> Maybe TermGender
forall a. a -> Maybe a
Just TermGender
Masculine
                     Just Text
"feminine"   -> TermGender -> Maybe TermGender
forall a. a -> Maybe a
Just TermGender
Feminine
                     Maybe Text
_                 -> Maybe TermGender
forall a. Maybe a
Nothing
  let match :: Maybe TermMatch
match = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"match" Attributes
attr of
                     Just Text
"last-digit"      -> TermMatch -> Maybe TermMatch
forall a. a -> Maybe a
Just TermMatch
LastDigit
                     Just Text
"last-two-digits" -> TermMatch -> Maybe TermMatch
forall a. a -> Maybe a
Just TermMatch
LastTwoDigits
                     Just Text
"whole-number"    -> TermMatch -> Maybe TermMatch
forall a. a -> Maybe a
Just TermMatch
WholeNumber
                     Maybe Text
_                      -> Maybe TermMatch
forall a. Maybe a
Nothing
  let term :: Term
term = Term :: Text
-> TermForm
-> Maybe TermNumber
-> Maybe TermGender
-> Maybe TermGender
-> Maybe TermMatch
-> Term
Term
        { termName :: Text
termName          = Text
name
        , termForm :: TermForm
termForm          = TermForm
form
        , termNumber :: Maybe TermNumber
termNumber        = Maybe TermNumber
forall a. Maybe a
Nothing
        , termGender :: Maybe TermGender
termGender        = Maybe TermGender
gender
        , termGenderForm :: Maybe TermGender
termGenderForm    = Maybe TermGender
genderForm
        , termMatch :: Maybe TermMatch
termMatch         = Maybe TermMatch
match
        }
  let addToList :: a -> Maybe [a] -> Maybe [a]
addToList a
x Maybe [a]
Nothing   = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
x]
      addToList a
x (Just [a]
xs) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
  if Text -> Bool
T.null Text
single
     then Map Text [(Term, Text)]
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Text [(Term, Text)]
 -> ReaderT
      (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)]))
-> Map Text [(Term, Text)]
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)])
forall a b. (a -> b) -> a -> b
$ (Maybe [(Term, Text)] -> Maybe [(Term, Text)])
-> Text -> Map Text [(Term, Text)] -> Map Text [(Term, Text)]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter ((Term, Text) -> Maybe [(Term, Text)] -> Maybe [(Term, Text)]
forall a. a -> Maybe [a] -> Maybe [a]
addToList (Term
term, Text
txt)) (Term -> Text
termName Term
term) Map Text [(Term, Text)]
m
     else do
       let term_single :: Term
term_single = Term
term{ termNumber :: Maybe TermNumber
termNumber = TermNumber -> Maybe TermNumber
forall a. a -> Maybe a
Just TermNumber
Singular }
       let term_plural :: Term
term_plural = Term
term{ termNumber :: Maybe TermNumber
termNumber = TermNumber -> Maybe TermNumber
forall a. a -> Maybe a
Just TermNumber
Plural }
       Map Text [(Term, Text)]
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Text [(Term, Text)]
 -> ReaderT
      (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)]))
-> Map Text [(Term, Text)]
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Map Text [(Term, Text)])
forall a b. (a -> b) -> a -> b
$ (Maybe [(Term, Text)] -> Maybe [(Term, Text)])
-> Text -> Map Text [(Term, Text)] -> Map Text [(Term, Text)]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter
          ((Term, Text) -> Maybe [(Term, Text)] -> Maybe [(Term, Text)]
forall a. a -> Maybe [a] -> Maybe [a]
addToList (Term
term_single, Text
single) (Maybe [(Term, Text)] -> Maybe [(Term, Text)])
-> (Maybe [(Term, Text)] -> Maybe [(Term, Text)])
-> Maybe [(Term, Text)]
-> Maybe [(Term, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           (Term, Text) -> Maybe [(Term, Text)] -> Maybe [(Term, Text)]
forall a. a -> Maybe [a] -> Maybe [a]
addToList (Term
term_plural, Text
multiple)) (Term -> Text
termName Term
term) Map Text [(Term, Text)]
m

pDate :: X.Element -> ElementParser (Element a)
pDate :: Element -> ElementParser (Element a)
pDate Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  let form :: Maybe Text
form = Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr
  let var :: Variable
var = Text -> Variable
toVariable (Text -> Variable) -> Text -> Variable
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
forall a. Monoid a => a
mempty (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"variable" Attributes
attr
  let showDateParts :: Maybe ShowDateParts
showDateParts = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"date-parts" Attributes
attr of
                        Just Text
"year-month-day" -> ShowDateParts -> Maybe ShowDateParts
forall a. a -> Maybe a
Just ShowDateParts
YearMonthDay
                        Just Text
"year-month"     -> ShowDateParts -> Maybe ShowDateParts
forall a. a -> Maybe a
Just ShowDateParts
YearMonth
                        Just Text
"year"           -> ShowDateParts -> Maybe ShowDateParts
forall a. a -> Maybe a
Just ShowDateParts
Year
                        Maybe Text
_                     -> Maybe ShowDateParts
forall a. Maybe a
Nothing

  [DP]
dps <- (Element -> ReaderT (Map Name Text) (Except CiteprocError) DP)
-> [Element] -> ReaderT (Map Name Text) (Except CiteprocError) [DP]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> ReaderT (Map Name Text) (Except CiteprocError) DP
parseDatePartElement (Text -> Element -> [Element]
getChildren Text
"date-part" Element
node)
  let dateType :: DateType
dateType = case Maybe Text
form of
                      Just Text
"numeric" -> DateType
LocalizedNumeric
                      Just Text
"text"    -> DateType
LocalizedText
                      Maybe Text
_              -> DateType
NonLocalized
  Element a -> ElementParser (Element a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Element a -> ElementParser (Element a))
-> Element a -> ElementParser (Element a)
forall a b. (a -> b) -> a -> b
$ ElementType a -> Formatting -> Element a
forall a. ElementType a -> Formatting -> Element a
Element (Variable
-> DateType -> Maybe ShowDateParts -> [DP] -> ElementType a
forall a.
Variable
-> DateType -> Maybe ShowDateParts -> [DP] -> ElementType a
EDate Variable
var DateType
dateType Maybe ShowDateParts
showDateParts [DP]
dps) Formatting
formatting

parseDatePartElement :: X.Element -> ElementParser DP
parseDatePartElement :: Element -> ReaderT (Map Name Text) (Except CiteprocError) DP
parseDatePartElement Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  let name :: DPName
name = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name" Attributes
attr of
               Just Text
"day"   -> DPName
DPDay
               Just Text
"month" -> DPName
DPMonth
               Maybe Text
_            -> DPName
DPYear
  let form :: DPForm
form = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr of
               Just Text
"numeric"                -> DPForm
DPNumeric
               Just Text
"numeric-leading-zeros"  -> DPForm
DPNumericLeadingZeros
               Just Text
"ordinal"                -> DPForm
DPOrdinal
               Just Text
"long"                   -> DPForm
DPLong
               Just Text
"short"                  -> DPForm
DPShort
               Maybe Text
_ | DPName
name DPName -> DPName -> Bool
forall a. Eq a => a -> a -> Bool
== DPName
DPDay             -> DPForm
DPNumeric
                 | Bool
otherwise                 -> DPForm
DPLong
  let rangeDelim :: Text
rangeDelim = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"–" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"range-delimiter" Attributes
attr
  DP -> ReaderT (Map Name Text) (Except CiteprocError) DP
forall (m :: * -> *) a. Monad m => a -> m a
return (DP -> ReaderT (Map Name Text) (Except CiteprocError) DP)
-> DP -> ReaderT (Map Name Text) (Except CiteprocError) DP
forall a b. (a -> b) -> a -> b
$ DPName -> DPForm -> Text -> Formatting -> DP
DP DPName
name DPForm
form Text
rangeDelim Formatting
formatting