{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Citeproc.Style
  ( parseStyle
  , mergeLocales
  )
where
import Citeproc.Types
import Citeproc.Locale
import Citeproc.Element
import Data.Text (Text)
import Control.Monad (foldM)
import Control.Applicative ((<|>))
import qualified Text.XML as X
import qualified Data.Text as T
import qualified Data.Map as M
import Data.Maybe (fromMaybe, isNothing)
import Data.Default (def)
import qualified Data.Text.Lazy as TL
import Control.Monad.Trans.Reader (local)

-- | Merge the locale specified by the first parameter, if any,
-- with the default locale of the style and locale definitions
-- in the style.  The locale specified by the first parameter
-- overrides the style's defaults when there is a conflict.
mergeLocales :: Maybe Lang -> Style a -> Locale
mergeLocales :: Maybe Lang -> Style a -> Locale
mergeLocales mblang :: Maybe Lang
mblang style :: Style a
style =
  [Locale] -> Locale
forall a. Monoid a => [a] -> a
mconcat [Locale]
stylelocales Locale -> Locale -> Locale
forall a. Semigroup a => a -> a -> a
<> Locale
deflocale -- left-biased union
 where
  getUSLocale :: Locale
getUSLocale = case Lang -> Either CiteprocError Locale
getLocale (Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang "en" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just"US") [] [] []) of
                  Right l :: Locale
l -> Locale
l
                  Left _  -> Locale
forall a. Monoid a => a
mempty
  lang :: Lang
lang = Lang -> Maybe Lang -> Lang
forall a. a -> Maybe a -> a
fromMaybe (Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang "en" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just"US") [] [] []) (Maybe Lang -> Lang) -> Maybe Lang -> Lang
forall a b. (a -> b) -> a -> b
$
              Maybe Lang
mblang Maybe Lang -> Maybe Lang -> Maybe Lang
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StyleOptions -> Maybe Lang
styleDefaultLocale (Style a -> StyleOptions
forall a. Style a -> StyleOptions
styleOptions Style a
style)
  deflocale :: Locale
deflocale = case Lang -> Either CiteprocError Locale
getLocale Lang
lang of
                 Right l :: Locale
l -> Locale
l
                 Left _  -> Locale
getUSLocale
  primlang :: Maybe Lang
primlang = Lang -> Maybe Lang
getPrimaryDialect Lang
lang
  stylelocales :: [Locale]
stylelocales =  -- exact match to lang gets precedence
                 [Locale
l | Locale
l <- Style a -> [Locale]
forall a. Style a -> [Locale]
styleLocales Style a
style
                    , Locale -> Maybe Lang
localeLanguage Locale
l Maybe Lang -> Maybe Lang -> Bool
forall a. Eq a => a -> a -> Bool
== Lang -> Maybe Lang
forall a. a -> Maybe a
Just Lang
lang] [Locale] -> [Locale] -> [Locale]
forall a. [a] -> [a] -> [a]
++
                 -- then match to primary dialect, if different
                 [Locale
l | Maybe Lang
primlang Maybe Lang -> Maybe Lang -> Bool
forall a. Eq a => a -> a -> Bool
/= Lang -> Maybe Lang
forall a. a -> Maybe a
Just Lang
lang
                    , Locale
l <- Style a -> [Locale]
forall a. Style a -> [Locale]
styleLocales Style a
style
                    , Locale -> Maybe Lang
localeLanguage Locale
l Maybe Lang -> Maybe Lang -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Lang
primlang] [Locale] -> [Locale] -> [Locale]
forall a. [a] -> [a] -> [a]
++
                 -- then match to the two letter language
                 [Locale
l | Locale
l <- Style a -> [Locale]
forall a. Style a -> [Locale]
styleLocales Style a
style
                    , (Lang -> Maybe Text
langRegion (Lang -> Maybe Text) -> Maybe Lang -> Maybe (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Locale -> Maybe Lang
localeLanguage Locale
l) Maybe (Maybe Text) -> Maybe (Maybe Text) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Text -> Maybe (Maybe Text)
forall a. a -> Maybe a
Just Maybe Text
forall a. Maybe a
Nothing
                    , (Lang -> Text
langLanguage (Lang -> Text) -> Maybe Lang -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Locale -> Maybe Lang
localeLanguage Locale
l) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
==
                      Text -> Maybe Text
forall a. a -> Maybe a
Just (Lang -> Text
langLanguage Lang
lang)] [Locale] -> [Locale] -> [Locale]
forall a. [a] -> [a] -> [a]
++
                 -- then locale with no lang
                 [Locale
l | Locale
l <- Style a -> [Locale]
forall a. Style a -> [Locale]
styleLocales Style a
style
                    , Maybe Lang -> Bool
forall a. Maybe a -> Bool
isNothing (Locale -> Maybe Lang
localeLanguage Locale
l)]



-- | Parse an XML stylesheet into a 'Style'.  The first parameter
-- is a function that retrieves the text of the independent parent
-- of a dependent style, given a URL.  (This might make an HTTP
-- request or retrieve the style locally.)  If you aren't using
-- dependent styles, you may use `(\_ -> return mempty)`.
parseStyle :: Monad m
           => (Text -> m Text) -- ^ Function that takes a URL and retrieves
                               -- text of independent parent
           -> Text             -- ^ Contents of XML stylesheet
           -> m (Either CiteprocError (Style a))
parseStyle :: (Text -> m Text) -> Text -> m (Either CiteprocError (Style a))
parseStyle getIndependentParent :: Text -> m Text
getIndependentParent t :: Text
t =
  -- first, see if it's a dependent or independent style
  case ParseSettings -> Text -> Either SomeException Document
X.parseText ParseSettings
forall a. Default a => a
def (Text -> Text
TL.fromStrict Text
t) of
    Left e :: SomeException
e  -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CiteprocError (Style a)
 -> m (Either CiteprocError (Style a)))
-> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a b. (a -> b) -> a -> b
$ CiteprocError -> Either CiteprocError (Style a)
forall a b. a -> Either a b
Left (CiteprocError -> Either CiteprocError (Style a))
-> CiteprocError -> Either CiteprocError (Style a)
forall a b. (a -> b) -> a -> b
$ Text -> CiteprocError
CiteprocXMLError (String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
    Right n :: Document
n -> do
      let attr :: Attributes
attr = Element -> Attributes
getAttributes (Element -> Attributes) -> Element -> Attributes
forall a b. (a -> b) -> a -> b
$ Document -> Element
X.documentRoot Document
n
      let defaultLocale :: Maybe Lang
defaultLocale =
            case Text -> Attributes -> Maybe Text
lookupAttribute "default-locale" Attributes
attr of
              Nothing  -> Maybe Lang
forall a. Maybe a
Nothing
              Just l :: Text
l   -> (String -> Maybe Lang)
-> (Lang -> Maybe Lang) -> Either String Lang -> Maybe Lang
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Lang -> String -> Maybe Lang
forall a b. a -> b -> a
const Maybe Lang
forall a. Maybe a
Nothing) Lang -> Maybe Lang
forall a. a -> Maybe a
Just (Either String Lang -> Maybe Lang)
-> Either String Lang -> Maybe Lang
forall a b. (a -> b) -> a -> b
$ Text -> Either String Lang
parseLang Text
l
      let links :: [Element]
links = (Element -> [Element]) -> [Element] -> [Element]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> Element -> [Element]
getChildren "link") ([Element] -> [Element]) -> [Element] -> [Element]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren "info"
                    (Document -> Element
X.documentRoot Document
n)
      case [Element -> Attributes
getAttributes Element
l
              | Element
l <- [Element]
links
              , Text -> Attributes -> Maybe Text
lookupAttribute "rel" (Element -> Attributes
getAttributes Element
l) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
==
                  Text -> Maybe Text
forall a. a -> Maybe a
Just "independent-parent" ] of
        [] -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CiteprocError (Style a)
 -> m (Either CiteprocError (Style a)))
-> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a b. (a -> b) -> a -> b
$
               ElementParser (Style a) -> Either CiteprocError (Style a)
forall a. ElementParser a -> Either CiteprocError a
runElementParser (ElementParser (Style a) -> Either CiteprocError (Style a))
-> ElementParser (Style a) -> Either CiteprocError (Style a)
forall a b. (a -> b) -> a -> b
$ Maybe Lang -> Element -> ElementParser (Style a)
forall a. Maybe Lang -> Element -> ElementParser (Style a)
pStyle Maybe Lang
defaultLocale (Element -> ElementParser (Style a))
-> Element -> ElementParser (Style a)
forall a b. (a -> b) -> a -> b
$ Document -> Element
X.documentRoot Document
n
        (lattr :: Attributes
lattr:_) ->
          case Text -> Attributes -> Maybe Text
lookupAttribute "href" Attributes
lattr of
            Nothing -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CiteprocError (Style a)
 -> m (Either CiteprocError (Style a)))
-> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a b. (a -> b) -> a -> b
$ CiteprocError -> Either CiteprocError (Style a)
forall a b. a -> Either a b
Left (CiteprocError -> Either CiteprocError (Style a))
-> CiteprocError -> Either CiteprocError (Style a)
forall a b. (a -> b) -> a -> b
$ Text -> CiteprocError
CiteprocXMLError
                          "No href attribute on link to parent style"
            Just url :: Text
url -> do -- get parent style
              Text
parentTxt <- Text -> m Text
getIndependentParent Text
url
              case ParseSettings -> Text -> Either SomeException Document
X.parseText ParseSettings
forall a. Default a => a
def (Text -> Text
TL.fromStrict Text
parentTxt) of
                Left e :: SomeException
e -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CiteprocError (Style a)
 -> m (Either CiteprocError (Style a)))
-> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a b. (a -> b) -> a -> b
$ CiteprocError -> Either CiteprocError (Style a)
forall a b. a -> Either a b
Left (CiteprocError -> Either CiteprocError (Style a))
-> CiteprocError -> Either CiteprocError (Style a)
forall a b. (a -> b) -> a -> b
$ Text -> CiteprocError
CiteprocXMLError (String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
                Right n' :: Document
n' -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CiteprocError (Style a)
 -> m (Either CiteprocError (Style a)))
-> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a b. (a -> b) -> a -> b
$
                 ElementParser (Style a) -> Either CiteprocError (Style a)
forall a. ElementParser a -> Either CiteprocError a
runElementParser (ElementParser (Style a) -> Either CiteprocError (Style a))
-> ElementParser (Style a) -> Either CiteprocError (Style a)
forall a b. (a -> b) -> a -> b
$ Maybe Lang -> Element -> ElementParser (Style a)
forall a. Maybe Lang -> Element -> ElementParser (Style a)
pStyle Maybe Lang
defaultLocale (Element -> ElementParser (Style a))
-> Element -> ElementParser (Style a)
forall a b. (a -> b) -> a -> b
$ Document -> Element
X.documentRoot Document
n'

pStyle :: Maybe Lang -> X.Element -> ElementParser (Style a)
pStyle :: Maybe Lang -> Element -> ElementParser (Style a)
pStyle defaultLocale :: Maybe Lang
defaultLocale node :: Element
node = do
  let attrmap :: Map Name Text
attrmap = Element -> Map Name Text
getInheritableNameAttributes Element
node
  (Map Name Text -> Map Name Text)
-> ElementParser (Style a) -> ElementParser (Style a)
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Map Name Text -> Map Name Text -> Map Name Text
forall a. Semigroup a => a -> a -> a
<> Map Name Text
attrmap) (ElementParser (Style a) -> ElementParser (Style a))
-> ElementParser (Style a) -> ElementParser (Style a)
forall a b. (a -> b) -> a -> b
$ do
    let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
    Map Text [Element]
macroMap <- [(Text, [Element])] -> Map Text [Element]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, [Element])] -> Map Text [Element])
-> ReaderT
     (Map Name Text) (Except CiteprocError) [(Text, [Element])]
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Map Text [Element])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element
 -> ReaderT
      (Map Name Text) (Except CiteprocError) (Text, [Element]))
-> [Element]
-> ReaderT
     (Map Name Text) (Except CiteprocError) [(Text, [Element])]
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) (Text, [Element])
pMacro (Text -> Element -> [Element]
getChildren "macro" Element
node)
    (cattr :: Attributes
cattr, citations :: Layout a
citations)
        <- case Text -> Element -> [Element]
getChildren "citation" Element
node of
                   [n :: Element
n] -> (Element -> Attributes
getAttributes Element
n,) (Layout a -> (Attributes, Layout a))
-> ReaderT (Map Name Text) (Except CiteprocError) (Layout a)
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Attributes, Layout a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text [Element]
-> Element
-> ReaderT (Map Name Text) (Except CiteprocError) (Layout a)
forall a. Map Text [Element] -> Element -> ElementParser (Layout a)
pLayout Map Text [Element]
macroMap Element
n
                   []  -> String
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Attributes, Layout a)
forall a. String -> ElementParser a
parseFailure "No citation element present"
                   _   -> String
-> ReaderT
     (Map Name Text) (Except CiteprocError) (Attributes, Layout a)
forall a. String -> ElementParser a
parseFailure "More than one citation element present"
    (battr :: Attributes
battr, bibliography :: Maybe (Layout a)
bibliography) <- case Text -> Element -> [Element]
getChildren "bibliography" Element
node of
                      [n :: Element
n] -> (\z :: Layout a
z -> (Element -> Attributes
getAttributes Element
n, Layout a -> Maybe (Layout a)
forall a. a -> Maybe a
Just Layout a
z))
                                (Layout a -> (Attributes, Maybe (Layout a)))
-> ReaderT (Map Name Text) (Except CiteprocError) (Layout a)
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     (Attributes, Maybe (Layout a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text [Element]
-> Element
-> ReaderT (Map Name Text) (Except CiteprocError) (Layout a)
forall a. Map Text [Element] -> Element -> ElementParser (Layout a)
pLayout Map Text [Element]
macroMap Element
n
                      []  -> (Attributes, Maybe (Layout a))
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     (Attributes, Maybe (Layout a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Attributes
forall a. Monoid a => a
mempty, Maybe (Layout a)
forall a. Maybe a
Nothing)
                      _   -> String
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     (Attributes, Maybe (Layout a))
forall a. String -> ElementParser a
parseFailure
                               "More than one bibliography element present"

    let disambiguateGivenNameRule :: GivenNameDisambiguationRule
disambiguateGivenNameRule =
          case Text -> Attributes -> Maybe Text
lookupAttribute "givenname-disambiguation-rule" Attributes
cattr of
            Just "all-names" -> GivenNameDisambiguationRule
AllNames
            Just "all-names-with-initials" -> GivenNameDisambiguationRule
AllNamesWithInitials
            Just "primary-name" -> GivenNameDisambiguationRule
PrimaryName
            Just "primary-name-with-initials" -> GivenNameDisambiguationRule
PrimaryNameWithInitials
            _ -> GivenNameDisambiguationRule
ByCite

    let disambigStrategy :: DisambiguationStrategy
disambigStrategy =
          $WDisambiguationStrategy :: Bool
-> Maybe GivenNameDisambiguationRule
-> Bool
-> DisambiguationStrategy
DisambiguationStrategy
          { disambiguateAddNames :: Bool
disambiguateAddNames =
              Text -> Attributes -> Maybe Text
lookupAttribute "disambiguate-add-names" Attributes
cattr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "true"
          , disambiguateAddGivenNames :: Maybe GivenNameDisambiguationRule
disambiguateAddGivenNames =
              case Text -> Attributes -> Maybe Text
lookupAttribute "disambiguate-add-givenname" Attributes
cattr of
                Just "true" -> GivenNameDisambiguationRule -> Maybe GivenNameDisambiguationRule
forall a. a -> Maybe a
Just GivenNameDisambiguationRule
disambiguateGivenNameRule
                _           -> Maybe GivenNameDisambiguationRule
forall a. Maybe a
Nothing
          , disambiguateAddYearSuffix :: Bool
disambiguateAddYearSuffix =
             Text -> Attributes -> Maybe Text
lookupAttribute "disambiguate-add-year-suffix" Attributes
cattr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
==
               Text -> Maybe Text
forall a. a -> Maybe a
Just "true"
          }

    let hasYearSuffixVariable :: Element a -> Bool
hasYearSuffixVariable
          (Element (EText (TextVariable _ "year-suffix")) _) = Bool
True
        hasYearSuffixVariable
          (Element (EGroup _ es :: [Element a]
es) _) = (Element a -> Bool) -> [Element a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Element a -> Bool
hasYearSuffixVariable [Element a]
es
        hasYearSuffixVariable
          (Element (EChoose []) _) = Bool
False
        hasYearSuffixVariable
          (Element (EChoose ((_,_,es :: [Element a]
es):conds :: [(Match, [Condition], [Element a])]
conds)) f :: Formatting
f) =
            (Element a -> Bool) -> [Element a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Element a -> Bool
hasYearSuffixVariable [Element a]
es Bool -> Bool -> Bool
||
              Element a -> Bool
hasYearSuffixVariable (ElementType a -> Formatting -> Element a
forall a. ElementType a -> Formatting -> Element a
Element ([(Match, [Condition], [Element a])] -> ElementType a
forall a. [(Match, [Condition], [Element a])] -> ElementType a
EChoose [(Match, [Condition], [Element a])]
conds) Formatting
f)
        hasYearSuffixVariable _ = Bool
False
    let usesYearSuffixVariable :: Bool
usesYearSuffixVariable =
          (Element a -> Bool) -> [Element a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Element a -> Bool
forall a. Element a -> Bool
hasYearSuffixVariable ([Element a] -> Bool) -> [Element a] -> Bool
forall a b. (a -> b) -> a -> b
$
            Layout a -> [Element a]
forall a. Layout a -> [Element a]
layoutElements Layout a
citations [Element a] -> [Element a] -> [Element a]
forall a. [a] -> [a] -> [a]
++ [Element a]
-> (Layout a -> [Element a]) -> Maybe (Layout a) -> [Element a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Layout a -> [Element a]
forall a. Layout a -> [Element a]
layoutElements Maybe (Layout a)
bibliography

    let sOpts :: StyleOptions
sOpts = $WStyleOptions :: Bool
-> Maybe Lang
-> DemoteNonDroppingParticle
-> Bool
-> Maybe PageRangeFormat
-> Maybe Text
-> DisambiguationStrategy
-> Maybe Int
-> Maybe Text
-> Maybe Int
-> Maybe Int
-> Bool
-> Maybe SecondFieldAlign
-> Maybe SubsequentAuthorSubstitute
-> Bool
-> StyleOptions
StyleOptions
                 { styleIsNoteStyle :: Bool
styleIsNoteStyle =
                     case Text -> Attributes -> Maybe Text
lookupAttribute "class" Attributes
attr of
                       Just "note" -> Bool
True
                       Nothing     -> Bool
True
                       _           -> Bool
False
                 , styleDefaultLocale :: Maybe Lang
styleDefaultLocale = Maybe Lang
defaultLocale
                 , styleDemoteNonDroppingParticle :: DemoteNonDroppingParticle
styleDemoteNonDroppingParticle =
                     case Text -> Attributes -> Maybe Text
lookupAttribute "demote-non-dropping-particle" Attributes
attr of
                       Just "never"     -> DemoteNonDroppingParticle
DemoteNever
                       Just "sort-only" -> DemoteNonDroppingParticle
DemoteSortOnly
                       _                -> DemoteNonDroppingParticle
DemoteDisplayAndSort
                 , styleInitializeWithHyphen :: Bool
styleInitializeWithHyphen =
                   Bool -> (Text -> Bool) -> Maybe Text -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "true") (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$
                     Text -> Attributes -> Maybe Text
lookupAttribute "initialize-with-hyphen" Attributes
attr
                 , stylePageRangeFormat :: Maybe PageRangeFormat
stylePageRangeFormat =
                     case Text -> Attributes -> Maybe Text
lookupAttribute "page-range-format" Attributes
attr of
                       Just "chicago"     -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeChicago
                       Just "expanded"    -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeExpanded
                       Just "minimal"     -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeMinimal
                       Just "minimal-two" -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeMinimalTwo
                       _                  -> Maybe PageRangeFormat
forall a. Maybe a
Nothing
                 , stylePageRangeDelimiter :: Maybe Text
stylePageRangeDelimiter =
                     Text -> Attributes -> Maybe Text
lookupAttribute "page-range-delimiter" Attributes
attr
                 , styleDisambiguation :: DisambiguationStrategy
styleDisambiguation = DisambiguationStrategy
disambigStrategy
                 , styleNearNoteDistance :: Maybe Int
styleNearNoteDistance =
                     Text -> Attributes -> Maybe Text
lookupAttribute "near-note-distance" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
                 , styleCiteGroupDelimiter :: Maybe Text
styleCiteGroupDelimiter =
                     Text -> Attributes -> Maybe Text
lookupAttribute "cite-group-delimiter" Attributes
cattr Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                     (", " Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Attributes -> Maybe Text
lookupAttribute "collapse" Attributes
cattr)
                 , styleLineSpacing :: Maybe Int
styleLineSpacing =
                     Text -> Attributes -> Maybe Text
lookupAttribute "line-spacing" Attributes
battr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
                 , styleEntrySpacing :: Maybe Int
styleEntrySpacing =
                     Text -> Attributes -> Maybe Text
lookupAttribute "entry-spacing" Attributes
battr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
                 , styleHangingIndent :: Bool
styleHangingIndent =
                     Text -> Attributes -> Maybe Text
lookupAttribute "hanging-indent" Attributes
battr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "true"
                 , styleSecondFieldAlign :: Maybe SecondFieldAlign
styleSecondFieldAlign =
                     case Text -> Attributes -> Maybe Text
lookupAttribute "second-field-align" Attributes
battr of
                       Just "flush" -> SecondFieldAlign -> Maybe SecondFieldAlign
forall a. a -> Maybe a
Just SecondFieldAlign
SecondFieldAlignFlush
                       Just "margin" -> SecondFieldAlign -> Maybe SecondFieldAlign
forall a. a -> Maybe a
Just SecondFieldAlign
SecondFieldAlignMargin
                       _ -> Maybe SecondFieldAlign
forall a. Maybe a
Nothing
                 , styleSubsequentAuthorSubstitute :: Maybe SubsequentAuthorSubstitute
styleSubsequentAuthorSubstitute =
                     case Text -> Attributes -> Maybe Text
lookupAttribute "subsequent-author-substitute"
                          Attributes
battr of
                       Nothing -> Maybe SubsequentAuthorSubstitute
forall a. Maybe a
Nothing
                       Just t :: Text
t  -> SubsequentAuthorSubstitute -> Maybe SubsequentAuthorSubstitute
forall a. a -> Maybe a
Just (SubsequentAuthorSubstitute -> Maybe SubsequentAuthorSubstitute)
-> SubsequentAuthorSubstitute -> Maybe SubsequentAuthorSubstitute
forall a b. (a -> b) -> a -> b
$
                         Text
-> SubsequentAuthorSubstituteRule -> SubsequentAuthorSubstitute
SubsequentAuthorSubstitute Text
t
                         (SubsequentAuthorSubstituteRule -> SubsequentAuthorSubstitute)
-> SubsequentAuthorSubstituteRule -> SubsequentAuthorSubstitute
forall a b. (a -> b) -> a -> b
$ case Text -> Attributes -> Maybe Text
lookupAttribute
                             "subsequent-author-substitute-rule" Attributes
battr of
                               Just "complete-each" -> SubsequentAuthorSubstituteRule
CompleteEach
                               Just "partial-each" -> SubsequentAuthorSubstituteRule
PartialEach
                               Just "partial-first" -> SubsequentAuthorSubstituteRule
PartialFirst
                               _  -> SubsequentAuthorSubstituteRule
CompleteAll
                 , styleUsesYearSuffixVariable :: Bool
styleUsesYearSuffixVariable = Bool
usesYearSuffixVariable
                 }
    [Locale]
locales <- (Element -> ReaderT (Map Name Text) (Except CiteprocError) Locale)
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Locale]
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) Locale
pLocale (Text -> Element -> [Element]
getChildren "locale" Element
node)
    let cslVersion :: (Int, Int, Int)
cslVersion = case Text -> Attributes -> Maybe Text
lookupAttribute "version" Attributes
attr of
                       Nothing -> (0,0,0)
                       Just t :: Text
t  ->
                         case (Text -> Maybe Int) -> [Text] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Maybe Int
readAsInt (Text -> Text -> [Text]
T.splitOn "." Text
t) of
                           (Just x :: Int
x : Just y :: Int
y : Just z :: Int
z :_) -> (Int
x,Int
y,Int
z)
                           (Just x :: Int
x : Just y :: Int
y : _)         -> (Int
x,Int
y,0)
                           (Just x :: Int
x : _)                  -> (Int
x,0,0)
                           _                             -> (0,0,0)
    Style a -> ElementParser (Style a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Style a -> ElementParser (Style a))
-> Style a -> ElementParser (Style a)
forall a b. (a -> b) -> a -> b
$ $WStyle :: forall a.
(Int, Int, Int)
-> StyleOptions
-> Layout a
-> Maybe (Layout a)
-> [Locale]
-> Maybe Abbreviations
-> Style a
Style
             { styleCslVersion :: (Int, Int, Int)
styleCslVersion     = (Int, Int, Int)
cslVersion
             , styleOptions :: StyleOptions
styleOptions        = StyleOptions
sOpts
             , styleCitation :: Layout a
styleCitation       = Layout a
citations
             , styleBibliography :: Maybe (Layout a)
styleBibliography   = Maybe (Layout a)
bibliography
             , styleLocales :: [Locale]
styleLocales        = [Locale]
locales
             , styleAbbreviations :: Maybe Abbreviations
styleAbbreviations  = Maybe Abbreviations
forall a. Maybe a
Nothing
             }



pElement :: X.Element -> ElementParser (Element a)
pElement :: Element -> ElementParser (Element a)
pElement node :: Element
node =
  case Name -> Text
X.nameLocalName (Element -> Name
X.elementName Element
node) of
    "date"   -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pDate Element
node
    "text"   -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pText Element
node
    "group"  -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pGroup Element
node
    "choose" -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pChoose Element
node
    "number" -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pNumber Element
node
    "label"  -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pLabel Element
node
    "names"  -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pNames Element
node
    name :: Text
name     -> String -> ElementParser (Element a)
forall a. String -> ElementParser a
parseFailure (String -> ElementParser (Element a))
-> String -> ElementParser (Element a)
forall a b. (a -> b) -> a -> b
$ "unknown element " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
name

pChoose :: X.Element -> ElementParser (Element a)
pChoose :: Element -> ElementParser (Element a)
pChoose node :: Element
node = do
  [(Match, [Condition], [Element a])]
ifNodes <- (Element
 -> ReaderT
      (Map Name Text)
      (Except CiteprocError)
      (Match, [Condition], [Element a]))
-> [Element]
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     [(Match, [Condition], [Element a])]
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)
     (Match, [Condition], [Element a])
forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf ([Element]
 -> ReaderT
      (Map Name Text)
      (Except CiteprocError)
      [(Match, [Condition], [Element a])])
-> [Element]
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     [(Match, [Condition], [Element a])]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren "if" Element
node
  [(Match, [Condition], [Element a])]
elseIfNodes <- (Element
 -> ReaderT
      (Map Name Text)
      (Except CiteprocError)
      (Match, [Condition], [Element a]))
-> [Element]
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     [(Match, [Condition], [Element a])]
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)
     (Match, [Condition], [Element a])
forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf ([Element]
 -> ReaderT
      (Map Name Text)
      (Except CiteprocError)
      [(Match, [Condition], [Element a])])
-> [Element]
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     [(Match, [Condition], [Element a])]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren "else-if" Element
node
  [(Match, [Condition], [Element a])]
elseNodes <- (Element
 -> ReaderT
      (Map Name Text)
      (Except CiteprocError)
      (Match, [Condition], [Element a]))
-> [Element]
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     [(Match, [Condition], [Element a])]
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)
     (Match, [Condition], [Element a])
forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf ([Element]
 -> ReaderT
      (Map Name Text)
      (Except CiteprocError)
      [(Match, [Condition], [Element a])])
-> [Element]
-> ReaderT
     (Map Name Text)
     (Except CiteprocError)
     [(Match, [Condition], [Element a])]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren "else" Element
node
  let parts :: [(Match, [Condition], [Element a])]
parts = [(Match, [Condition], [Element a])]
ifNodes [(Match, [Condition], [Element a])]
-> [(Match, [Condition], [Element a])]
-> [(Match, [Condition], [Element a])]
forall a. [a] -> [a] -> [a]
++ [(Match, [Condition], [Element a])]
elseIfNodes [(Match, [Condition], [Element a])]
-> [(Match, [Condition], [Element a])]
-> [(Match, [Condition], [Element a])]
forall a. [a] -> [a] -> [a]
++ [(Match, [Condition], [Element a])]
elseNodes
  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 ([(Match, [Condition], [Element a])] -> ElementType a
forall a. [(Match, [Condition], [Element a])] -> ElementType a
EChoose [(Match, [Condition], [Element a])]
parts) Formatting
forall a. Monoid a => a
mempty

parseIf :: X.Element -> ElementParser (Match, [Condition], [Element a])
parseIf :: Element -> ElementParser (Match, [Condition], [Element a])
parseIf node :: Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let match :: Match
match = case Text -> Attributes -> Maybe Text
lookupAttribute "match" Attributes
attr of
                Just "any"   -> Match
MatchAny
                Just "none"  -> Match
MatchNone
                _            -> Match
MatchAll
  let conditions :: [Condition]
conditions =
        (case Text -> Attributes -> Maybe Text
lookupAttribute "disambiguate" Attributes
attr of
           Just "true" -> (Condition
WouldDisambiguate Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
           _           -> [Condition] -> [Condition]
forall a. a -> a
id) ([Condition] -> [Condition])
-> ([Condition] -> [Condition]) -> [Condition] -> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (case Text -> Attributes -> Maybe Text
lookupAttribute "is-numeric" Attributes
attr of
           Just t :: Text
t  -> \xs :: [Condition]
xs -> (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Condition -> [Condition] -> [Condition])
-> (Variable -> Condition)
-> Variable
-> [Condition]
-> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Condition
IsNumeric) [Condition]
xs (Text -> [Variable]
splitVars Text
t)
           _       -> [Condition] -> [Condition]
forall a. a -> a
id) ([Condition] -> [Condition])
-> ([Condition] -> [Condition]) -> [Condition] -> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (case Text -> Attributes -> Maybe Text
lookupAttribute "is-uncertain-date" Attributes
attr of
           Just t :: Text
t  -> \xs :: [Condition]
xs -> (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Condition -> [Condition] -> [Condition])
-> (Variable -> Condition)
-> Variable
-> [Condition]
-> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Condition
IsUncertainDate) [Condition]
xs (Text -> [Variable]
splitVars Text
t)
           _       -> [Condition] -> [Condition]
forall a. a -> a
id) ([Condition] -> [Condition])
-> ([Condition] -> [Condition]) -> [Condition] -> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (case Text -> Attributes -> Maybe Text
lookupAttribute "locator" Attributes
attr of
           Just t :: Text
t  -> \xs :: [Condition]
xs -> (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Condition -> [Condition] -> [Condition])
-> (Variable -> Condition)
-> Variable
-> [Condition]
-> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Condition
HasLocatorType) [Condition]
xs (Text -> [Variable]
splitVars Text
t)
           _       -> [Condition] -> [Condition]
forall a. a -> a
id) ([Condition] -> [Condition])
-> ([Condition] -> [Condition]) -> [Condition] -> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (case Text -> Attributes -> Maybe Text
lookupAttribute "position" Attributes
attr of
           Just t :: Text
t  -> \xs :: [Condition]
xs ->
             (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\case
                       "first"      -> (Position -> Condition
HasPosition Position
FirstPosition Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       "ibid"       -> (Position -> Condition
HasPosition Position
Ibid Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       "ibid-with-locator"
                                    -> (Position -> Condition
HasPosition Position
IbidWithLocator Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       "subsequent" -> (Position -> Condition
HasPosition Position
Subsequent Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       "near-note"  -> (Position -> Condition
HasPosition Position
NearNote Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       _            -> [Condition] -> [Condition]
forall a. a -> a
id)
             [Condition]
xs (Text -> [Variable]
splitVars Text
t)
           _       -> [Condition] -> [Condition]
forall a. a -> a
id) ([Condition] -> [Condition])
-> ([Condition] -> [Condition]) -> [Condition] -> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (case Text -> Attributes -> Maybe Text
lookupAttribute "type" Attributes
attr of
           Just t :: Text
t  -> \xs :: [Condition]
xs -> (Text -> [Condition] -> [Condition])
-> [Condition] -> [Text] -> [Condition]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Condition -> [Condition] -> [Condition])
-> (Text -> Condition) -> Text -> [Condition] -> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Condition
HasType) [Condition]
xs (Text -> [Text]
T.words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
t)
           _       -> [Condition] -> [Condition]
forall a. a -> a
id) ([Condition] -> [Condition])
-> ([Condition] -> [Condition]) -> [Condition] -> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        (case Text -> Attributes -> Maybe Text
lookupAttribute "variable" Attributes
attr of
           Just t :: Text
t  -> \xs :: [Condition]
xs -> (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Condition -> [Condition] -> [Condition])
-> (Variable -> Condition)
-> Variable
-> [Condition]
-> [Condition]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Condition
HasVariable) [Condition]
xs (Text -> [Variable]
splitVars Text
t)
           _       -> [Condition] -> [Condition]
forall a. a -> a
id) ([Condition] -> [Condition]) -> [Condition] -> [Condition]
forall a b. (a -> b) -> a -> b
$ []
  [Element a]
elts <- (Element
 -> ReaderT (Map Name Text) (Except CiteprocError) (Element a))
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
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 a)
forall a. Element -> ElementParser (Element a)
pElement ([Element]
 -> ReaderT (Map Name Text) (Except CiteprocError) [Element a])
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
node
  (Match, [Condition], [Element a])
-> ElementParser (Match, [Condition], [Element a])
forall (m :: * -> *) a. Monad m => a -> m a
return (Match
match, [Condition]
conditions, [Element a]
elts)

pNumber :: X.Element -> ElementParser (Element a)
pNumber :: Element -> ElementParser (Element a)
pNumber node :: Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  let variable :: Maybe Text
variable = Text -> Attributes -> Maybe Text
lookupAttribute "variable" Attributes
attr
  let numform :: NumberForm
numform = case Text -> Attributes -> Maybe Text
lookupAttribute "form" Attributes
attr of
                  Just "ordinal"      -> NumberForm
NumberOrdinal
                  Just "long-ordinal" -> NumberForm
NumberLongOrdinal
                  Just "roman"        -> NumberForm
NumberRoman
                  _                   -> NumberForm
NumberNumeric
  case Maybe Text
variable of
    Nothing  -> String -> ElementParser (Element a)
forall a. String -> ElementParser a
parseFailure "number element without required variable attribute"
    Just var :: Text
var -> 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 -> NumberForm -> ElementType a
forall a. Variable -> NumberForm -> ElementType a
ENumber (Text -> Variable
toVariable Text
var) NumberForm
numform)
                         Formatting
formatting

pLabel :: X.Element -> ElementParser (Element a)
pLabel :: Element -> ElementParser (Element a)
pLabel node :: Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  let variable :: Variable
variable = 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 "" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute "variable" Attributes
attr
  let labelform :: TermForm
labelform = case Text -> Attributes -> Maybe Text
lookupAttribute "form" Attributes
attr of
                    Just "short"      -> TermForm
Short
                    Just "verb"       -> TermForm
Verb
                    Just "verb-short" -> TermForm
VerbShort
                    Just "symbol"     -> TermForm
Symbol
                    _                 -> TermForm
Long
  let pluralize :: Pluralize
pluralize = case Text -> Attributes -> Maybe Text
lookupAttribute "plural" Attributes
attr of
                    Just "always" -> Pluralize
AlwaysPluralize
                    Just "never"  -> Pluralize
NeverPluralize
                    _             -> Pluralize
ContextualPluralize
  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 -> TermForm -> Pluralize -> ElementType a
forall a. Variable -> TermForm -> Pluralize -> ElementType a
ELabel Variable
variable TermForm
labelform Pluralize
pluralize) Formatting
formatting

pNames :: X.Element -> ElementParser (Element a)
pNames :: Element -> ElementParser (Element a)
pNames node :: Element
node = do
  Attributes
attr <- Element -> ElementParser Attributes
getNameAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  let variables :: [Variable]
variables = [Variable] -> (Text -> [Variable]) -> Maybe Text -> [Variable]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [Variable]
splitVars (Maybe Text -> [Variable]) -> Maybe Text -> [Variable]
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute "variable" Attributes
attr
  let pChild :: (NamesFormat, [Element a])
-> Element
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
pChild (nf :: NamesFormat
nf,subst :: [Element a]
subst) n :: Element
n =
       case Name -> Text
X.nameLocalName (Element -> Name
X.elementName Element
n) of
         "label"      -> do
           Element Any
e <- Element -> ElementParser (Element Any)
forall a. Element -> ElementParser (Element a)
pLabel Element
n
           case Element Any
e of
             Element (ELabel _ labelform :: TermForm
labelform pluralize :: Pluralize
pluralize) f :: Formatting
f ->
               (NamesFormat, [Element a])
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesLabel :: Maybe (TermForm, Pluralize, Formatting)
namesLabel = (TermForm, Pluralize, Formatting)
-> Maybe (TermForm, Pluralize, Formatting)
forall a. a -> Maybe a
Just (TermForm
labelform, Pluralize
pluralize, Formatting
f)
                          , namesLabelBeforeName :: Bool
namesLabelBeforeName =
                              Maybe (NameFormat, Formatting) -> Bool
forall a. Maybe a -> Bool
isNothing (NamesFormat -> Maybe (NameFormat, Formatting)
namesName NamesFormat
nf) }
                      , [Element a]
subst )
             _ -> String
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall a. String -> ElementParser a
parseFailure "pLabel returned something other than ELabel"
         "substitute" -> do
           [Element a]
els <- (Element
 -> ReaderT (Map Name Text) (Except CiteprocError) (Element a))
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
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 a)
forall a. Element -> ElementParser (Element a)
pElement ([Element]
 -> ReaderT (Map Name Text) (Except CiteprocError) [Element a])
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
n
           (NamesFormat, [Element a])
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf, [Element a]
els )
         "et-al"      -> do
           (Text, Formatting)
res <- Element -> ElementParser (Text, Formatting)
pEtAl Element
n
           (NamesFormat, [Element a])
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesEtAl :: Maybe (Text, Formatting)
namesEtAl = (Text, Formatting) -> Maybe (Text, Formatting)
forall a. a -> Maybe a
Just (Text, Formatting)
res }, [Element a]
subst )
         "name"       -> do
           (NameFormat, Formatting)
res <- Element -> ElementParser (NameFormat, Formatting)
pName Element
n
           (NamesFormat, [Element a])
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesName :: Maybe (NameFormat, Formatting)
namesName = (NameFormat, Formatting) -> Maybe (NameFormat, Formatting)
forall a. a -> Maybe a
Just (NameFormat, Formatting)
res }, [Element a]
subst )
         name :: Text
name -> String
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall a. String -> ElementParser a
parseFailure (String
 -> ReaderT
      (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a]))
-> String
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall a b. (a -> b) -> a -> b
$ "element " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
                        " not a valid child of names"
  (nameformat :: NamesFormat
nameformat, subst :: [Element a]
subst) <-
      ((NamesFormat, [Element a])
 -> Element
 -> ReaderT
      (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a]))
-> (NamesFormat, [Element a])
-> [Element]
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (NamesFormat, [Element a])
-> Element
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
forall a.
(NamesFormat, [Element a])
-> Element
-> ReaderT
     (Map Name Text) (Except CiteprocError) (NamesFormat, [Element a])
pChild (Maybe (TermForm, Pluralize, Formatting)
-> Maybe (Text, Formatting)
-> Maybe (NameFormat, Formatting)
-> Bool
-> NamesFormat
NamesFormat Maybe (TermForm, Pluralize, Formatting)
forall a. Maybe a
Nothing Maybe (Text, Formatting)
forall a. Maybe a
Nothing Maybe (NameFormat, Formatting)
forall a. Maybe a
Nothing Bool
False, [])
                   (Element -> [Element]
allChildren Element
node)
  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] -> NamesFormat -> [Element a] -> ElementType a
forall a. [Variable] -> NamesFormat -> [Element a] -> ElementType a
ENames [Variable]
variables NamesFormat
nameformat [Element a]
subst) Formatting
formatting

pEtAl :: X.Element -> ElementParser (Text, Formatting)
pEtAl :: Element -> ElementParser (Text, Formatting)
pEtAl node :: Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  let term :: Text
term = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "et-al" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute "term" Attributes
attr
  (Text, Formatting) -> ElementParser (Text, Formatting)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
term, Formatting
formatting)


pName :: X.Element -> ElementParser (NameFormat, Formatting)
pName :: Element -> ElementParser (NameFormat, Formatting)
pName node :: Element
node = do
  Attributes
attr <- Element -> ElementParser Attributes
getNameAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  let nameParts :: [Attributes]
nameParts = (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 "name-part" Element
node
  let nameformat :: NameFormat
nameformat = $WNameFormat :: Maybe Formatting
-> Maybe Formatting
-> Maybe TermForm
-> Text
-> DelimiterPrecedes
-> DelimiterPrecedes
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Maybe Int
-> Bool
-> NameForm
-> Bool
-> Maybe Text
-> Maybe NameAsSortOrder
-> Text
-> NameFormat
NameFormat
         { nameGivenFormatting :: Maybe Formatting
nameGivenFormatting        =
             case [Attributes
nattr
                   | Attributes
nattr <- [Attributes]
nameParts
                   , Text -> Attributes -> Maybe Text
lookupAttribute "name" Attributes
nattr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "given" ] of
                (nattr :: Attributes
nattr:_) -> Formatting -> Maybe Formatting
forall a. a -> Maybe a
Just (Formatting -> Maybe Formatting) -> Formatting -> Maybe Formatting
forall a b. (a -> b) -> a -> b
$ Attributes -> Formatting
getFormatting Attributes
nattr
                _     -> Maybe Formatting
forall a. Maybe a
Nothing
         , nameFamilyFormatting :: Maybe Formatting
nameFamilyFormatting       =
             case [Attributes
nattr
                   | Attributes
nattr <- [Attributes]
nameParts
                   , Text -> Attributes -> Maybe Text
lookupAttribute "name" Attributes
nattr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just "family" ] of
                (nattr :: Attributes
nattr:_) -> Formatting -> Maybe Formatting
forall a. a -> Maybe a
Just (Formatting -> Maybe Formatting) -> Formatting -> Maybe Formatting
forall a b. (a -> b) -> a -> b
$ Attributes -> Formatting
getFormatting Attributes
nattr
                _     -> Maybe Formatting
forall a. Maybe a
Nothing
         , nameAndStyle :: Maybe TermForm
nameAndStyle           =
             case Text -> Attributes -> Maybe Text
lookupAttribute "and" Attributes
attr of
               Just "text"   -> TermForm -> Maybe TermForm
forall a. a -> Maybe a
Just TermForm
Long
               Just "symbol" -> TermForm -> Maybe TermForm
forall a. a -> Maybe a
Just TermForm
Symbol
               _             -> Maybe TermForm
forall a. Maybe a
Nothing
         , nameDelimiter :: Text
nameDelimiter              =
             Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe ", " (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute "delimiter" Attributes
attr
         , nameDelimiterPrecedesEtAl :: DelimiterPrecedes
nameDelimiterPrecedesEtAl  =
             case Text -> Attributes -> Maybe Text
lookupAttribute "delimiter-precedes-et-al" Attributes
attr of
               Just "after-inverted-name" -> DelimiterPrecedes
PrecedesAfterInvertedName
               Just "always"              -> DelimiterPrecedes
PrecedesAlways
               Just "never"               -> DelimiterPrecedes
PrecedesNever
               _                          -> DelimiterPrecedes
PrecedesContextual
         , nameDelimiterPrecedesLast :: DelimiterPrecedes
nameDelimiterPrecedesLast  =
             case Text -> Attributes -> Maybe Text
lookupAttribute "delimiter-precedes-last" Attributes
attr of
               Just "after-inverted-name" -> DelimiterPrecedes
PrecedesAfterInvertedName
               Just "always"              -> DelimiterPrecedes
PrecedesAlways
               Just "never"               -> DelimiterPrecedes
PrecedesNever
               _                          -> DelimiterPrecedes
PrecedesContextual
         , nameEtAlMin :: Maybe Int
nameEtAlMin                =
           (Text -> Attributes -> Maybe Text
lookupAttribute "names-min" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
            Text -> Attributes -> Maybe Text
lookupAttribute "et-al-min" Attributes
attr) Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
         , nameEtAlUseFirst :: Maybe Int
nameEtAlUseFirst           =
           (Text -> Attributes -> Maybe Text
lookupAttribute "names-use-first" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
            Text -> Attributes -> Maybe Text
lookupAttribute "et-al-use-first" Attributes
attr) Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
         , nameEtAlSubsequentUseFirst :: Maybe Int
nameEtAlSubsequentUseFirst =
             Text -> Attributes -> Maybe Text
lookupAttribute "et-al-subsequent-use-first" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
         , nameEtAlSubsequentMin :: Maybe Int
nameEtAlSubsequentMin      =
             Text -> Attributes -> Maybe Text
lookupAttribute "et-al-subsequent-min" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
         , nameEtAlUseLast :: Bool
nameEtAlUseLast            =
             case Text -> Attributes -> Maybe Text
lookupAttribute "names-use-last" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                  Text -> Attributes -> Maybe Text
lookupAttribute "et-al-use-last" Attributes
attr of
               Just "true" -> Bool
True
               _           -> Bool
False
         , nameForm :: NameForm
nameForm                   =
             case Text -> Attributes -> Maybe Text
lookupAttribute "form" Attributes
attr of
               Just "short"  -> NameForm
ShortName
               Just "count"  -> NameForm
CountName
               _             -> NameForm
LongName
         , nameInitialize :: Bool
nameInitialize             =
             case Text -> Attributes -> Maybe Text
lookupAttribute "initialize" Attributes
attr of
               Just "false" -> Bool
False
               _            -> Bool
True
         , nameInitializeWith :: Maybe Text
nameInitializeWith         =
             Text -> Attributes -> Maybe Text
lookupAttribute "initialize-with" Attributes
attr
         , nameAsSortOrder :: Maybe NameAsSortOrder
nameAsSortOrder            =
             case Text -> Attributes -> Maybe Text
lookupAttribute "name-as-sort-order" Attributes
attr of
               Just "all"   -> NameAsSortOrder -> Maybe NameAsSortOrder
forall a. a -> Maybe a
Just NameAsSortOrder
NameAsSortOrderAll
               Just "first" -> NameAsSortOrder -> Maybe NameAsSortOrder
forall a. a -> Maybe a
Just NameAsSortOrder
NameAsSortOrderFirst
               _            -> Maybe NameAsSortOrder
forall a. Maybe a
Nothing
         , nameSortSeparator :: Text
nameSortSeparator          =
             Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe ", " (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute "sort-separator" Attributes
attr
         }
  (NameFormat, Formatting) -> ElementParser (NameFormat, Formatting)
forall (m :: * -> *) a. Monad m => a -> m a
return (NameFormat
nameformat, Formatting
formatting)

pGroup :: X.Element -> ElementParser (Element a)
pGroup :: Element -> ElementParser (Element a)
pGroup node :: Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  [Element a]
es <- (Element -> ElementParser (Element a))
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pElement ([Element]
 -> ReaderT (Map Name Text) (Except CiteprocError) [Element a])
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
node
  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 (Bool -> [Element a] -> ElementType a
forall a. Bool -> [Element a] -> ElementType a
EGroup Bool
False [Element a]
es) Formatting
formatting

pText :: X.Element -> ElementParser (Element a)
pText :: Element -> ElementParser (Element a)
pText node :: Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
  let varform :: VariableForm
varform = case Text -> Attributes -> Maybe Text
lookupAttribute "form" Attributes
attr of
                  Just "short" -> VariableForm
ShortForm
                  _            -> VariableForm
LongForm
  let termform :: TermForm
termform = case Text -> Attributes -> Maybe Text
lookupAttribute "form" Attributes
attr of
                   Just "short"      -> TermForm
Short
                   Just "verb"       -> TermForm
Verb
                   Just "verb-short" -> TermForm
VerbShort
                   Just "symbol"     -> TermForm
Symbol
                   _                 -> TermForm
Long
  let termnumber :: Maybe TermNumber
termnumber = case Text -> Attributes -> Maybe Text
lookupAttribute "plural" Attributes
attr of
                     Just "true"   -> TermNumber -> Maybe TermNumber
forall a. a -> Maybe a
Just TermNumber
Plural
                     Just "false"  -> TermNumber -> Maybe TermNumber
forall a. a -> Maybe a
Just TermNumber
Singular
                     _             -> Maybe TermNumber
forall a. Maybe a
Nothing
  ElementType a
elt <- case Text -> Attributes -> Maybe Text
lookupAttribute "variable" Attributes
attr of
           Just var :: Text
var -> ElementType a
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementType a
 -> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a))
-> ElementType a
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall a b. (a -> b) -> a -> b
$ TextType -> ElementType a
forall a. TextType -> ElementType a
EText (VariableForm -> Variable -> TextType
TextVariable VariableForm
varform (Text -> Variable
toVariable Text
var))
           Nothing ->
             case Text -> Attributes -> Maybe Text
lookupAttribute "macro" Attributes
attr of
               Just _ -> do
                 [Element a]
elements <- (Element -> ElementParser (Element a))
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pElement (Element -> [Element]
allChildren Element
node)
                 ElementType a
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementType a
 -> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a))
-> ElementType a
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall a b. (a -> b) -> a -> b
$ Bool -> [Element a] -> ElementType a
forall a. Bool -> [Element a] -> ElementType a
EGroup Bool
True [Element a]
elements
               Nothing ->
                 case Text -> Attributes -> Maybe Text
lookupAttribute "term" Attributes
attr of
                   Just termname :: Text
termname ->
                     ElementType a
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementType a
 -> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a))
-> ElementType a
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall a b. (a -> b) -> a -> b
$ TextType -> ElementType a
forall a. TextType -> ElementType a
EText (Term -> TextType
TextTerm
                       $WTerm :: Text
-> TermForm
-> Maybe TermNumber
-> Maybe TermGender
-> Maybe TermGender
-> Maybe TermMatch
-> Term
Term { termName :: Text
termName = Text
termname
                            , termForm :: TermForm
termForm = TermForm
termform
                            , termNumber :: Maybe TermNumber
termNumber = Maybe TermNumber
termnumber
                            , termGender :: Maybe TermGender
termGender = Maybe TermGender
forall a. Maybe a
Nothing
                            , termGenderForm :: Maybe TermGender
termGenderForm = Maybe TermGender
forall a. Maybe a
Nothing
                            , termMatch :: Maybe TermMatch
termMatch = Maybe TermMatch
forall a. Maybe a
Nothing
                            })
                   Nothing ->
                     case Text -> Attributes -> Maybe Text
lookupAttribute "value" Attributes
attr of
                       Just val :: Text
val ->
                         ElementType a
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementType a
 -> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a))
-> ElementType a
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall a b. (a -> b) -> a -> b
$ TextType -> ElementType a
forall a. TextType -> ElementType a
EText (Text -> TextType
TextValue Text
val)
                       Nothing ->
                         String
-> ReaderT (Map Name Text) (Except CiteprocError) (ElementType a)
forall a. String -> ElementParser a
parseFailure "text element lacks needed attribute"
  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 ElementType a
elt Formatting
formatting

pMacro :: X.Element -> ElementParser (Text, [X.Element])
pMacro :: Element
-> ReaderT (Map Name Text) (Except CiteprocError) (Text, [Element])
pMacro node :: Element
node = do
  Text
name <- case Text -> Attributes -> Maybe Text
lookupAttribute "name" (Element -> Attributes
getAttributes Element
node) of
            Just t :: Text
t  -> Text -> ReaderT (Map Name Text) (Except CiteprocError) Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
            Nothing -> String -> ReaderT (Map Name Text) (Except CiteprocError) Text
forall a. String -> ElementParser a
parseFailure "macro element missing name attribute"
  (Text, [Element])
-> ReaderT (Map Name Text) (Except CiteprocError) (Text, [Element])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, Element -> [Element]
allChildren Element
node)

-- these name and names attributes are inheritable from a parent style
-- citation or bibliography element.  We use a map because
-- sometimes the name is different (e.g. name-form and form).
inheritableNameAttributes :: M.Map X.Name X.Name
inheritableNameAttributes :: Map Name Name
inheritableNameAttributes = [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Name)] -> Map Name Name)
-> [(Name, Name)] -> Map Name Name
forall a b. (a -> b) -> a -> b
$
  ((Text, Text) -> (Name, Name)) -> [(Text, Text)] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: Text
x,y :: Text
y) -> (Text -> Name
attname Text
x, Text -> Name
attname Text
y))
  [ ("and", "and")
  , ("delimiter-precedes-et-al", "delimiter-precedes-et-al")
  , ("delimiter-precedes-last", "delimiter-precedes-last")
  , ("et-al-min", "et-al-min")
  , ("et-al-use-first", "et-al-use-first")
  , ("et-al-use-last", "et-al-use-last")
  , ("et-al-subsequent-min", "et-al-subsequent-min")
  , ("et-al-subsequent-use-first", "et-al-subsequent-use-first")
  , ("initialize", "initialize")
  , ("initialize-with", "initialize-with")
  , ("name-as-sort-order", "name-as-sort-order")
  , ("sort-separator", "sort-separator")
  , ("name-form", "form")
  , ("name-delimiter", "delimiter")
  , ("names-delimiter", "delimiter")
  , ("names-min", "names-min")
  , ("names-use-first", "names-use-first")
  , ("names-use-last", "names-use-last")
  ]

getInheritableNameAttributes :: X.Element -> M.Map X.Name Text
getInheritableNameAttributes :: Element -> Map Name Text
getInheritableNameAttributes elt :: Element
elt =
  (Name -> Text -> Map Name Text -> Map Name Text)
-> Map Name Text -> Map Name Text -> Map Name Text
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey
    (\k :: Name
k v :: Text
v m :: Map Name Text
m -> case Name -> Map Name Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
k Map Name Name
inheritableNameAttributes of
                   Just k' :: Name
k' -> Name -> Text -> Map Name Text -> Map Name Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
k' Text
v Map Name Text
m
                   Nothing -> Map Name Text
m) Map Name Text
forall k a. Map k a
M.empty (Element -> Map Name Text
X.elementAttributes Element
elt)

pLayout :: M.Map Text [X.Element] -> X.Element -> ElementParser (Layout a)
pLayout :: Map Text [Element] -> Element -> ElementParser (Layout a)
pLayout macroMap :: Map Text [Element]
macroMap node :: Element
node = do
  let attrmap :: Map Name Text
attrmap = Element -> Map Name Text
getInheritableNameAttributes Element
node
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  (Map Name Text -> Map Name Text)
-> ElementParser (Layout a) -> ElementParser (Layout a)
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Map Name Text -> Map Name Text -> Map Name Text
forall a. Semigroup a => a -> a -> a
<> Map Name Text
attrmap) (ElementParser (Layout a) -> ElementParser (Layout a))
-> ElementParser (Layout a) -> ElementParser (Layout a)
forall a b. (a -> b) -> a -> b
$ do
    Element
node' <- Map Text [Element] -> Element -> ElementParser Element
expandMacros Map Text [Element]
macroMap Element
node
    let layouts :: [Element]
layouts = Text -> Element -> [Element]
getChildren "layout" Element
node'
    let formatting :: Formatting
formatting = [Formatting] -> Formatting
forall a. Monoid a => [a] -> a
mconcat ([Formatting] -> Formatting) -> [Formatting] -> Formatting
forall a b. (a -> b) -> a -> b
$ (Element -> Formatting) -> [Element] -> [Formatting]
forall a b. (a -> b) -> [a] -> [b]
map (Attributes -> Formatting
getFormatting (Attributes -> Formatting)
-> (Element -> Attributes) -> Element -> Formatting
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Attributes
getAttributes) [Element]
layouts
    let sorts :: [Element]
sorts   = Text -> Element -> [Element]
getChildren "sort" Element
node'
    [Element a]
elements <- (Element
 -> ReaderT (Map Name Text) (Except CiteprocError) (Element a))
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
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 a)
forall a. Element -> ElementParser (Element a)
pElement ((Element -> [Element]) -> [Element] -> [Element]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Element -> [Element]
allChildren [Element]
layouts)
    let opts :: LayoutOptions
opts = $WLayoutOptions :: Maybe Collapsing -> Maybe Text -> Maybe Text -> LayoutOptions
LayoutOptions
               { layoutCollapse :: Maybe Collapsing
layoutCollapse =
                   case Text -> Attributes -> Maybe Text
lookupAttribute "collapse" Attributes
attr of
                     Just "citation-number" -> Collapsing -> Maybe Collapsing
forall a. a -> Maybe a
Just Collapsing
CollapseCitationNumber
                     Just "year"            -> Collapsing -> Maybe Collapsing
forall a. a -> Maybe a
Just Collapsing
CollapseYear
                     Just "year-suffix"     -> Collapsing -> Maybe Collapsing
forall a. a -> Maybe a
Just Collapsing
CollapseYearSuffix
                     Just "year-suffix-ranged"
                                            -> Collapsing -> Maybe Collapsing
forall a. a -> Maybe a
Just Collapsing
CollapseYearSuffixRanged
                     _                      -> Maybe Collapsing
forall a. Maybe a
Nothing
               , layoutYearSuffixDelimiter :: Maybe Text
layoutYearSuffixDelimiter =
                   Text -> Attributes -> Maybe Text
lookupAttribute "year-suffix-delimiter" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                     -- technically the spec doesn't say this, but
                     -- this seems to be what the test suites want?:
                     Text -> Attributes -> Maybe Text
lookupAttribute "cite-group-delimiter" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                     Formatting -> Maybe Text
formatDelimiter Formatting
formatting
               , layoutAfterCollapseDelimiter :: Maybe Text
layoutAfterCollapseDelimiter =
                   Text -> Attributes -> Maybe Text
lookupAttribute "after-collapse-delimiter" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                     Formatting -> Maybe Text
formatDelimiter Formatting
formatting
               }
    [SortKey a]
sortKeys <- (Element
 -> ReaderT (Map Name Text) (Except CiteprocError) (SortKey a))
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [SortKey a]
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) (SortKey a)
forall a. Element -> ElementParser (SortKey a)
pSortKey ((Element -> [Element]) -> [Element] -> [Element]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> Element -> [Element]
getChildren "key") [Element]
sorts)
    Layout a -> ElementParser (Layout a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Layout a -> ElementParser (Layout a))
-> Layout a -> ElementParser (Layout a)
forall a b. (a -> b) -> a -> b
$ $WLayout :: forall a.
LayoutOptions
-> Formatting -> [Element a] -> [SortKey a] -> Layout a
Layout { layoutOptions :: LayoutOptions
layoutOptions  = LayoutOptions
opts
                    , layoutFormatting :: Formatting
layoutFormatting = Formatting
formatting{
                                           formatAffixesInside :: Bool
formatAffixesInside = Bool
True }
                    , layoutElements :: [Element a]
layoutElements = [Element a]
elements
                    , layoutSortKeys :: [SortKey a]
layoutSortKeys = [SortKey a]
sortKeys
                    }

pSortKey :: X.Element -> ElementParser (SortKey a)
pSortKey :: Element -> ElementParser (SortKey a)
pSortKey node :: Element
node = do
  let attrmap :: Map Name Text
attrmap = Element -> Map Name Text
getInheritableNameAttributes Element
node
  (Map Name Text -> Map Name Text)
-> ElementParser (SortKey a) -> ElementParser (SortKey a)
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (Map Name Text -> Map Name Text -> Map Name Text
forall a. Semigroup a => a -> a -> a
<> Map Name Text
attrmap) (ElementParser (SortKey a) -> ElementParser (SortKey a))
-> ElementParser (SortKey a) -> ElementParser (SortKey a)
forall a b. (a -> b) -> a -> b
$ do
    let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
    let direction :: SortDirection
direction = case Text -> Attributes -> Maybe Text
lookupAttribute "sort" Attributes
attr of
                      Just "descending" -> SortDirection
Descending
                      _                 -> SortDirection
Ascending
    case Text -> Attributes -> Maybe Text
lookupAttribute "macro" Attributes
attr of
        Just _ -> -- should already be expanded
          SortDirection -> [Element a] -> SortKey a
forall a. SortDirection -> [Element a] -> SortKey a
SortKeyMacro SortDirection
direction ([Element a] -> SortKey a)
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
-> ElementParser (SortKey a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element
 -> ReaderT (Map Name Text) (Except CiteprocError) (Element a))
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Element a]
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 a)
forall a. Element -> ElementParser (Element a)
pElement (Element -> [Element]
allChildren Element
node)
        Nothing   -> SortKey a -> ElementParser (SortKey a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SortKey a -> ElementParser (SortKey a))
-> SortKey a -> ElementParser (SortKey a)
forall a b. (a -> b) -> a -> b
$ SortDirection -> Variable -> SortKey a
forall a. SortDirection -> Variable -> SortKey a
SortKeyVariable SortDirection
direction
                       (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 "variable" Attributes
attr)

attname :: Text -> X.Name
attname :: Text -> Name
attname t :: Text
t = Text -> Maybe Text -> Maybe Text -> Name
X.Name Text
t Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing

expandMacros :: M.Map Text [X.Element]
             -> X.Element
             -> ElementParser X.Element
expandMacros :: Map Text [Element] -> Element -> ElementParser Element
expandMacros macroMap :: Map Text [Element]
macroMap el :: Element
el =
  case Name -> Text
X.nameLocalName (Element -> Name
X.elementName Element
el) of
    n :: Text
n | Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "text" Bool -> Bool -> Bool
||
        Text
n Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "key" ->
      case Name -> Map Name Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> Name
attname "macro") (Element -> Map Name Text
X.elementAttributes Element
el) of
        Nothing -> do
           [Node]
els' <- (Node -> ReaderT (Map Name Text) (Except CiteprocError) Node)
-> [Node] -> ReaderT (Map Name Text) (Except CiteprocError) [Node]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Node -> ReaderT (Map Name Text) (Except CiteprocError) Node
expandNode (Element -> [Node]
X.elementNodes Element
el)
           Element -> ElementParser Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> ElementParser Element)
-> Element -> ElementParser Element
forall a b. (a -> b) -> a -> b
$ Element
el{ elementNodes :: [Node]
X.elementNodes = [Node]
els' }
        Just macroName :: Text
macroName ->
          case Text -> Map Text [Element] -> Maybe [Element]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
macroName Map Text [Element]
macroMap of
            Nothing ->
              String -> ElementParser Element
forall a. String -> ElementParser a
parseFailure (String -> ElementParser Element)
-> String -> ElementParser Element
forall a b. (a -> b) -> a -> b
$ "macro " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
macroName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " not found"
            Just els :: [Element]
els -> do
              -- the expansion may contain further macros:
              [Node]
els' <- (Element -> ReaderT (Map Name Text) (Except CiteprocError) Node)
-> [Element]
-> ReaderT (Map Name Text) (Except CiteprocError) [Node]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Element -> Node)
-> ElementParser Element
-> ReaderT (Map Name Text) (Except CiteprocError) Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Node
X.NodeElement (ElementParser Element
 -> ReaderT (Map Name Text) (Except CiteprocError) Node)
-> (Element -> ElementParser Element)
-> Element
-> ReaderT (Map Name Text) (Except CiteprocError) Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text [Element] -> Element -> ElementParser Element
expandMacros Map Text [Element]
macroMap) [Element]
els
              Element -> ElementParser Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> ElementParser Element)
-> Element -> ElementParser Element
forall a b. (a -> b) -> a -> b
$ Element
el{ elementNodes :: [Node]
X.elementNodes = [Node]
els' }
    _ -> do
      [Node]
els' <- (Node -> ReaderT (Map Name Text) (Except CiteprocError) Node)
-> [Node] -> ReaderT (Map Name Text) (Except CiteprocError) [Node]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Node -> ReaderT (Map Name Text) (Except CiteprocError) Node
expandNode (Element -> [Node]
X.elementNodes Element
el)
      Element -> ElementParser Element
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> ElementParser Element)
-> Element -> ElementParser Element
forall a b. (a -> b) -> a -> b
$ Element
el{ elementNodes :: [Node]
X.elementNodes = [Node]
els' }
 where
  expandNode :: Node -> ReaderT (Map Name Text) (Except CiteprocError) Node
expandNode (X.NodeElement el' :: Element
el') = Element -> Node
X.NodeElement (Element -> Node)
-> ElementParser Element
-> ReaderT (Map Name Text) (Except CiteprocError) Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Text [Element] -> Element -> ElementParser Element
expandMacros Map Text [Element]
macroMap Element
el'
  expandNode x :: Node
x                   = Node -> ReaderT (Map Name Text) (Except CiteprocError) Node
forall (m :: * -> *) a. Monad m => a -> m a
return Node
x

splitVars :: Text -> [Variable]
splitVars :: Text -> [Variable]
splitVars = (Text -> Variable) -> [Text] -> [Variable]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Variable
toVariable ([Text] -> [Variable]) -> (Text -> [Text]) -> Text -> [Variable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip