{-# 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

-- | 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 :: forall a. Maybe Lang -> Style a -> Locale
mergeLocales Maybe Lang
mblang 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 Text
"en" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
JustText
"US") [] [] []) of
                  Right Locale
l -> Locale
l
                  Left CiteprocError
_  -> 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 Text
"en" Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
JustText
"US") [] [] []) (Maybe Lang -> Lang) -> Maybe Lang -> Lang
forall a b. (a -> b) -> a -> b
$
              Maybe Lang
mblang Maybe Lang -> Maybe Lang -> Maybe Lang
forall a. Maybe a -> Maybe a -> Maybe a
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 Locale
l -> Locale
l
                 Left CiteprocError
_  -> 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 :: forall (m :: * -> *) a.
Monad m =>
(Text -> m Text) -> Text -> m (Either CiteprocError (Style a))
parseStyle Text -> m Text
getIndependentParent 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 SomeException
e  -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a. a -> m 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 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 Text
"default-locale" Attributes
attr of
              Maybe Text
Nothing  -> Maybe Lang
forall a. Maybe a
Nothing
              Just 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 Text
"link") ([Element] -> [Element]) -> [Element] -> [Element]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"info"
                    (Document -> Element
X.documentRoot Document
n)
      case [Element -> Attributes
getAttributes Element
l
              | Element
l <- [Element]
links
              , Text -> Attributes -> Maybe Text
lookupAttribute Text
"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 Text
"independent-parent" ] of
        [] -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a. a -> m 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
        (Attributes
lattr:[Attributes]
_) ->
          case Text -> Attributes -> Maybe Text
lookupAttribute Text
"href" Attributes
lattr of
            Maybe Text
Nothing -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a. a -> m 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
                          Text
"No href attribute on link to parent style"
            Just 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 SomeException
e -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a. a -> m 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 Document
n' -> Either CiteprocError (Style a)
-> m (Either CiteprocError (Style a))
forall a. a -> m 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 :: forall a. Maybe Lang -> Element -> ElementParser (Style a)
pStyle Maybe Lang
defaultLocale Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let nameformat :: NameFormat
nameformat = Attributes -> NameFormat
getInheritableNameFormat Attributes
attr
  Map Text [Element a]
macros <- [(Text, [Element a])] -> Map Text [Element a]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, [Element a])] -> Map Text [Element a])
-> ExceptT CiteprocError Identity [(Text, [Element a])]
-> ExceptT CiteprocError Identity (Map Text [Element a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element -> ExceptT CiteprocError Identity (Text, [Element a]))
-> [Element]
-> ExceptT CiteprocError Identity [(Text, [Element a])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ExceptT CiteprocError Identity (Text, [Element a])
forall a. Element -> ElementParser (Text, [Element a])
pMacro (Text -> Element -> [Element]
getChildren Text
"macro" Element
node)
  (Attributes
cattr, Layout a
citations)
      <- case Text -> Element -> [Element]
getChildren Text
"citation" Element
node of
                 [Element
n] -> (Element -> Attributes
getAttributes Element
n,) (Layout a -> (Attributes, Layout a))
-> ExceptT CiteprocError Identity (Layout a)
-> ExceptT CiteprocError Identity (Attributes, Layout a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> ExceptT CiteprocError Identity (Layout a)
forall a. Element -> ElementParser (Layout a)
pLayout Element
n
                 []  -> String -> ExceptT CiteprocError Identity (Attributes, Layout a)
forall a. String -> ElementParser a
parseFailure String
"No citation element present"
                 [Element]
_   -> String -> ExceptT CiteprocError Identity (Attributes, Layout a)
forall a. String -> ElementParser a
parseFailure String
"More than one citation element present"
  (Attributes
battr, Maybe (Layout a)
bibliography) <- case Text -> Element -> [Element]
getChildren Text
"bibliography" Element
node of
                    [Element
n] -> (\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)))
-> ExceptT CiteprocError Identity (Layout a)
-> ExceptT CiteprocError Identity (Attributes, Maybe (Layout a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> ExceptT CiteprocError Identity (Layout a)
forall a. Element -> ElementParser (Layout a)
pLayout Element
n
                    []  -> (Attributes, Maybe (Layout a))
-> ExceptT CiteprocError Identity (Attributes, Maybe (Layout a))
forall a. a -> ExceptT CiteprocError Identity 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)
                    [Element]
_   -> String
-> ExceptT CiteprocError Identity (Attributes, Maybe (Layout a))
forall a. String -> ElementParser a
parseFailure
                             String
"More than one bibliography element present"

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

  let disambigStrategy :: DisambiguationStrategy
disambigStrategy =
        DisambiguationStrategy
        { disambiguateAddNames :: Bool
disambiguateAddNames =
            Text -> Attributes -> Maybe Text
lookupAttribute Text
"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 Text
"true"
        , disambiguateAddGivenNames :: Maybe GivenNameDisambiguationRule
disambiguateAddGivenNames =
            case Text -> Attributes -> Maybe Text
lookupAttribute Text
"disambiguate-add-givenname" Attributes
cattr of
              Just Text
"true" -> GivenNameDisambiguationRule -> Maybe GivenNameDisambiguationRule
forall a. a -> Maybe a
Just GivenNameDisambiguationRule
disambiguateGivenNameRule
              Maybe Text
_           -> Maybe GivenNameDisambiguationRule
forall a. Maybe a
Nothing
        , disambiguateAddYearSuffix :: Bool
disambiguateAddYearSuffix =
           Text -> Attributes -> Maybe Text
lookupAttribute Text
"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 Text
"true"
        }

  let hasYearSuffixVariable :: Element a -> Bool
hasYearSuffixVariable (Element ElementType a
e Formatting
f) =
        case ElementType a
e of
          EText (TextVariable VariableForm
_ Variable
"year-suffix") -> Bool
True
          EText (TextMacro Text
macroname)
            | Just [Element a]
es' <- Text -> Map Text [Element a] -> Maybe [Element a]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
macroname Map Text [Element a]
macros ->
                 (Element a -> Bool) -> [Element a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Element a -> Bool
hasYearSuffixVariable [Element a]
es'
          EGroup Bool
_ [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
          EChoose [] -> Bool
False
          EChoose ((Match
_,[Condition]
_,[Element a]
es):[(Match, [Condition], [Element a])]
conds) -> (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)
          ElementType a
_ -> 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
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 = StyleOptions
               { styleIsNoteStyle :: Bool
styleIsNoteStyle =
                   case Text -> Attributes -> Maybe Text
lookupAttribute Text
"class" Attributes
attr of
                     Just Text
"note" -> Bool
True
                     Maybe Text
Nothing     -> Bool
True
                     Maybe Text
_           -> Bool
False
               , styleDefaultLocale :: Maybe Lang
styleDefaultLocale = Maybe Lang
defaultLocale
               , styleDemoteNonDroppingParticle :: DemoteNonDroppingParticle
styleDemoteNonDroppingParticle =
                   case Text -> Attributes -> Maybe Text
lookupAttribute Text
"demote-non-dropping-particle" Attributes
attr of
                     Just Text
"never"     -> DemoteNonDroppingParticle
DemoteNever
                     Just Text
"sort-only" -> DemoteNonDroppingParticle
DemoteSortOnly
                     Maybe Text
_                -> 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
== Text
"true") (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$
                   Text -> Attributes -> Maybe Text
lookupAttribute Text
"initialize-with-hyphen" Attributes
attr
               , stylePageRangeFormat :: Maybe PageRangeFormat
stylePageRangeFormat =
                   case Text -> Attributes -> Maybe Text
lookupAttribute Text
"page-range-format" Attributes
attr of
                     Just Text
"chicago"     -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeChicago15
                     -- chicago is an alias for chicago-15, but this
                     -- will change to chicago-16 in v1.1
                     Just Text
"chicago-15"  -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeChicago15
                     Just Text
"chicago-16"  -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeChicago16
                     Just Text
"expanded"    -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeExpanded
                     Just Text
"minimal"     -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeMinimal
                     Just Text
"minimal-two" -> PageRangeFormat -> Maybe PageRangeFormat
forall a. a -> Maybe a
Just PageRangeFormat
PageRangeMinimalTwo
                     Maybe Text
_                  -> Maybe PageRangeFormat
forall a. Maybe a
Nothing
               , stylePageRangeDelimiter :: Maybe Text
stylePageRangeDelimiter =
                   Text -> Attributes -> Maybe Text
lookupAttribute Text
"page-range-delimiter" Attributes
attr
               , styleDisambiguation :: DisambiguationStrategy
styleDisambiguation = DisambiguationStrategy
disambigStrategy
               , styleNearNoteDistance :: Maybe Int
styleNearNoteDistance =
                   Text -> Attributes -> Maybe Text
lookupAttribute Text
"near-note-distance" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"cite-group-delimiter" Attributes
cattr Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                   (Text
", " Text -> Maybe Text -> Maybe Text
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"collapse" Attributes
cattr)
               , styleLineSpacing :: Maybe Int
styleLineSpacing =
                   Text -> Attributes -> Maybe Text
lookupAttribute Text
"line-spacing" Attributes
battr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"entry-spacing" Attributes
battr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"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 Text
"true"
               , styleSecondFieldAlign :: Maybe SecondFieldAlign
styleSecondFieldAlign =
                   case Text -> Attributes -> Maybe Text
lookupAttribute Text
"second-field-align" Attributes
battr of
                     Just Text
"flush" -> SecondFieldAlign -> Maybe SecondFieldAlign
forall a. a -> Maybe a
Just SecondFieldAlign
SecondFieldAlignFlush
                     Just Text
"margin" -> SecondFieldAlign -> Maybe SecondFieldAlign
forall a. a -> Maybe a
Just SecondFieldAlign
SecondFieldAlignMargin
                     Maybe Text
_ -> Maybe SecondFieldAlign
forall a. Maybe a
Nothing
               , styleSubsequentAuthorSubstitute :: Maybe SubsequentAuthorSubstitute
styleSubsequentAuthorSubstitute =
                   case Text -> Attributes -> Maybe Text
lookupAttribute Text
"subsequent-author-substitute"
                        Attributes
battr of
                     Maybe Text
Nothing -> Maybe SubsequentAuthorSubstitute
forall a. Maybe a
Nothing
                     Just 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
                           Text
"subsequent-author-substitute-rule" Attributes
battr of
                             Just Text
"complete-each" -> SubsequentAuthorSubstituteRule
CompleteEach
                             Just Text
"partial-each" -> SubsequentAuthorSubstituteRule
PartialEach
                             Just Text
"partial-first" -> SubsequentAuthorSubstituteRule
PartialFirst
                             Maybe Text
_  -> SubsequentAuthorSubstituteRule
CompleteAll
               , styleUsesYearSuffixVariable :: Bool
styleUsesYearSuffixVariable = Bool
usesYearSuffixVariable
               , styleNameFormat :: NameFormat
styleNameFormat = NameFormat
nameformat -- TODO
               }
  [Locale]
locales <- (Element -> ExceptT CiteprocError Identity Locale)
-> [Element] -> ExceptT CiteprocError Identity [Locale]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ExceptT CiteprocError Identity Locale
pLocale (Text -> Element -> [Element]
getChildren Text
"locale" Element
node)
  let cslVersion :: (Int, Int, Int)
cslVersion = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"version" Attributes
attr of
                     Maybe Text
Nothing -> (Int
0,Int
0,Int
0)
                     Just Text
t  ->
                       case (Text -> Maybe Int) -> [Text] -> [Maybe Int]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Maybe Int
readAsInt (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
t) of
                         (Just Int
x : Just Int
y : Just Int
z :[Maybe Int]
_) -> (Int
x,Int
y,Int
z)
                         (Just Int
x : Just Int
y : [Maybe Int]
_)         -> (Int
x,Int
y,Int
0)
                         (Just Int
x : [Maybe Int]
_)                  -> (Int
x,Int
0,Int
0)
                         [Maybe Int]
_                             -> (Int
0,Int
0,Int
0)
  Style a -> ElementParser (Style a)
forall a. a -> ExceptT CiteprocError Identity 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
$ 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
           , styleMacros :: Map Text [Element a]
styleMacros         = Map Text [Element a]
macros
           }

pElement :: X.Element -> ElementParser (Element a)
pElement :: forall a. Element -> ElementParser (Element a)
pElement Element
node =
  case Name -> Text
X.nameLocalName (Element -> Name
X.elementName Element
node) of
    Text
"date"   -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pDate Element
node
    Text
"text"   -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pText Element
node
    Text
"group"  -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pGroup Element
node
    Text
"choose" -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pChoose Element
node
    Text
"number" -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pNumber Element
node
    Text
"label"  -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pLabel Element
node
    Text
"names"  -> Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pNames Element
node
    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
$ String
"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 :: forall a. Element -> ElementParser (Element a)
pChoose Element
node = do
  [(Match, [Condition], [Element a])]
ifNodes <- (Element
 -> ExceptT
      CiteprocError Identity (Match, [Condition], [Element a]))
-> [Element]
-> ExceptT
     CiteprocError Identity [(Match, [Condition], [Element a])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element
-> ExceptT CiteprocError Identity (Match, [Condition], [Element a])
forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf ([Element]
 -> ExceptT
      CiteprocError Identity [(Match, [Condition], [Element a])])
-> [Element]
-> ExceptT
     CiteprocError Identity [(Match, [Condition], [Element a])]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"if" Element
node
  [(Match, [Condition], [Element a])]
elseIfNodes <- (Element
 -> ExceptT
      CiteprocError Identity (Match, [Condition], [Element a]))
-> [Element]
-> ExceptT
     CiteprocError Identity [(Match, [Condition], [Element a])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element
-> ExceptT CiteprocError Identity (Match, [Condition], [Element a])
forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf ([Element]
 -> ExceptT
      CiteprocError Identity [(Match, [Condition], [Element a])])
-> [Element]
-> ExceptT
     CiteprocError Identity [(Match, [Condition], [Element a])]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"else-if" Element
node
  [(Match, [Condition], [Element a])]
elseNodes <- (Element
 -> ExceptT
      CiteprocError Identity (Match, [Condition], [Element a]))
-> [Element]
-> ExceptT
     CiteprocError Identity [(Match, [Condition], [Element a])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element
-> ExceptT CiteprocError Identity (Match, [Condition], [Element a])
forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf ([Element]
 -> ExceptT
      CiteprocError Identity [(Match, [Condition], [Element a])])
-> [Element]
-> ExceptT
     CiteprocError Identity [(Match, [Condition], [Element a])]
forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"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 a. a -> ExceptT CiteprocError Identity 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 :: forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let match :: Match
match = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"match" Attributes
attr of
                Just Text
"any"   -> Match
MatchAny
                Just Text
"none"  -> Match
MatchNone
                Maybe Text
_            -> Match
MatchAll
  let conditions :: [Condition]
conditions =
        (case Text -> Attributes -> Maybe Text
lookupAttribute Text
"disambiguate" Attributes
attr of
           Just Text
"true" -> (Condition
WouldDisambiguate Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
           Maybe Text
_           -> [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 Text
"is-numeric" Attributes
attr of
           Just Text
t  -> \[Condition]
xs -> (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall a b. (a -> b -> b) -> b -> [a] -> b
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)
           Maybe Text
_       -> [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 Text
"is-uncertain-date" Attributes
attr of
           Just Text
t  -> \[Condition]
xs -> (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall a b. (a -> b -> b) -> b -> [a] -> b
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)
           Maybe Text
_       -> [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 Text
"locator" Attributes
attr of
           Just Text
t  -> \[Condition]
xs -> (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall a b. (a -> b -> b) -> b -> [a] -> b
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)
           Maybe Text
_       -> [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 Text
"position" Attributes
attr of
           Just Text
t  -> \[Condition]
xs ->
             (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\case
                       Variable
"first"      -> (Position -> Condition
HasPosition Position
FirstPosition Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       Variable
"ibid"       -> (Position -> Condition
HasPosition Position
Ibid Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       Variable
"ibid-with-locator"
                                    -> (Position -> Condition
HasPosition Position
IbidWithLocator Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       Variable
"subsequent" -> (Position -> Condition
HasPosition Position
Subsequent Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       Variable
"near-note"  -> (Position -> Condition
HasPosition Position
NearNote Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
                       Variable
_            -> [Condition] -> [Condition]
forall a. a -> a
id)
             [Condition]
xs (Text -> [Variable]
splitVars Text
t)
           Maybe Text
_       -> [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 Text
"type" Attributes
attr of
           Just Text
t  -> ([Text] -> Condition
HasType (Text -> [Text]
T.words (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
t) Condition -> [Condition] -> [Condition]
forall a. a -> [a] -> [a]
:)
           Maybe Text
_       -> [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 Text
"variable" Attributes
attr of
           Just Text
t  -> \[Condition]
xs -> (Variable -> [Condition] -> [Condition])
-> [Condition] -> [Variable] -> [Condition]
forall a b. (a -> b -> b) -> b -> [a] -> b
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)
           Maybe Text
_       -> [Condition] -> [Condition]
forall a. a -> a
id) ([Condition] -> [Condition]) -> [Condition] -> [Condition]
forall a b. (a -> b) -> a -> b
$ []
  [Element a]
elts <- (Element -> ExceptT CiteprocError Identity (Element a))
-> [Element] -> ExceptT CiteprocError Identity [Element a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ExceptT CiteprocError Identity (Element a)
forall a. Element -> ElementParser (Element a)
pElement ([Element] -> ExceptT CiteprocError Identity [Element a])
-> [Element] -> ExceptT CiteprocError Identity [Element a]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
node
  (Match, [Condition], [Element a])
-> ElementParser (Match, [Condition], [Element a])
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match
match, [Condition]
conditions, [Element a]
elts)

pNumber :: X.Element -> ElementParser (Element a)
pNumber :: forall a. Element -> ElementParser (Element a)
pNumber 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 Text
"variable" Attributes
attr
  let numform :: NumberForm
numform = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr of
                  Just Text
"ordinal"      -> NumberForm
NumberOrdinal
                  Just Text
"long-ordinal" -> NumberForm
NumberLongOrdinal
                  Just Text
"roman"        -> NumberForm
NumberRoman
                  Maybe Text
_                   -> NumberForm
NumberNumeric
  case Maybe Text
variable of
    Maybe Text
Nothing  -> String -> ElementParser (Element a)
forall a. String -> ElementParser a
parseFailure String
"number element without required variable attribute"
    Just Text
var -> Element a -> ElementParser (Element a)
forall a. a -> ExceptT CiteprocError Identity 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 :: forall a. Element -> ElementParser (Element a)
pLabel 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 Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"variable" Attributes
attr
  let labelform :: TermForm
labelform = 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 pluralize :: Pluralize
pluralize = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"plural" Attributes
attr of
                    Just Text
"always" -> Pluralize
AlwaysPluralize
                    Just Text
"never"  -> Pluralize
NeverPluralize
                    Maybe Text
_             -> Pluralize
ContextualPluralize
  Element a -> ElementParser (Element a)
forall a. a -> ExceptT CiteprocError Identity 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 :: forall a. Element -> ElementParser (Element a)
pNames Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes 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 Text
"variable" Attributes
attr
  let pChild :: (NamesFormat, [Element a])
-> Element
-> ExceptT CiteprocError Identity (NamesFormat, [Element a])
pChild (NamesFormat
nf,[Element a]
subst) Element
n =
       case Name -> Text
X.nameLocalName (Element -> Name
X.elementName Element
n) of
         Text
"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 Variable
_ TermForm
labelform Pluralize
pluralize) Formatting
f ->
               (NamesFormat, [Element a])
-> ExceptT CiteprocError Identity (NamesFormat, [Element a])
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesLabel = Just (labelform, pluralize, f)
                          , namesLabelBeforeName =
                              isNothing (namesName nf) }
                      , [Element a]
subst )
             Element Any
_ -> String -> ExceptT CiteprocError Identity (NamesFormat, [Element a])
forall a. String -> ElementParser a
parseFailure String
"pLabel returned something other than ELabel"
         Text
"substitute" -> do
           [Element a]
els <- (Element -> ExceptT CiteprocError Identity (Element a))
-> [Element] -> ExceptT CiteprocError Identity [Element a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ExceptT CiteprocError Identity (Element a)
forall a. Element -> ElementParser (Element a)
pElement ([Element] -> ExceptT CiteprocError Identity [Element a])
-> [Element] -> ExceptT CiteprocError Identity [Element a]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
n
           (NamesFormat, [Element a])
-> ExceptT CiteprocError Identity (NamesFormat, [Element a])
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf, [Element a]
els )
         Text
"et-al"      -> do
           (Text, Formatting)
res <- Element -> ElementParser (Text, Formatting)
pEtAl Element
n
           (NamesFormat, [Element a])
-> ExceptT CiteprocError Identity (NamesFormat, [Element a])
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesEtAl = Just res }, [Element a]
subst )
         Text
"name"       -> do
           (NameFormat, Formatting)
res <- Element -> ElementParser (NameFormat, Formatting)
pName Element
n
           (NamesFormat, [Element a])
-> ExceptT CiteprocError Identity (NamesFormat, [Element a])
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesName = Just res }, [Element a]
subst )
         Text
name -> String -> ExceptT CiteprocError Identity (NamesFormat, [Element a])
forall a. String -> ElementParser a
parseFailure (String
 -> ExceptT CiteprocError Identity (NamesFormat, [Element a]))
-> String
-> ExceptT CiteprocError Identity (NamesFormat, [Element a])
forall a b. (a -> b) -> a -> b
$ String
"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
<>
                        String
" not a valid child of names"
  (NamesFormat
nameformat, [Element a]
subst) <-
      ((NamesFormat, [Element a])
 -> Element
 -> ExceptT CiteprocError Identity (NamesFormat, [Element a]))
-> (NamesFormat, [Element a])
-> [Element]
-> ExceptT CiteprocError Identity (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
-> ExceptT CiteprocError Identity (NamesFormat, [Element a])
forall {a}.
(NamesFormat, [Element a])
-> Element
-> ExceptT CiteprocError Identity (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 a. a -> ExceptT CiteprocError Identity 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 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 Text
"et-al" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"term" Attributes
attr
  (Text, Formatting) -> ElementParser (Text, Formatting)
forall a. a -> ExceptT CiteprocError Identity a
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 Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes 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 Text
"name-part" Element
node
  let nameformat :: NameFormat
nameformat = NameFormat
         { nameGivenFormatting :: Maybe Formatting
nameGivenFormatting        =
             case [Attributes
nattr
                   | Attributes
nattr <- [Attributes]
nameParts
                   , Text -> Attributes -> Maybe Text
lookupAttribute Text
"name" Attributes
nattr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"given" ] of
                (Attributes
nattr:[Attributes]
_) -> 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
                [Attributes]
_     -> Maybe Formatting
forall a. Maybe a
Nothing
         , nameFamilyFormatting :: Maybe Formatting
nameFamilyFormatting       =
             case [Attributes
nattr
                   | Attributes
nattr <- [Attributes]
nameParts
                   , Text -> Attributes -> Maybe Text
lookupAttribute Text
"name" Attributes
nattr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"family" ] of
                (Attributes
nattr:[Attributes]
_) -> 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
                [Attributes]
_     -> Maybe Formatting
forall a. Maybe a
Nothing
         , nameAndStyle :: Maybe TermForm
nameAndStyle           =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"and" Attributes
attr of
               Just Text
"text"   -> TermForm -> Maybe TermForm
forall a. a -> Maybe a
Just TermForm
Long
               Just Text
"symbol" -> TermForm -> Maybe TermForm
forall a. a -> Maybe a
Just TermForm
Symbol
               Maybe Text
_             -> Maybe TermForm
forall a. Maybe a
Nothing
         , nameDelimiter :: Maybe Text
nameDelimiter              =
             Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter" Attributes
attr
         , nameDelimiterPrecedesEtAl :: Maybe DelimiterPrecedes
nameDelimiterPrecedesEtAl  =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter-precedes-et-al" Attributes
attr of
               Just Text
"after-inverted-name" -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesAfterInvertedName
               Just Text
"always"              -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesAlways
               Just Text
"never"               -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesNever
               Just Text
"contextual"          -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesContextual
               Maybe Text
_                          -> Maybe DelimiterPrecedes
forall a. Maybe a
Nothing
         , nameDelimiterPrecedesLast :: Maybe DelimiterPrecedes
nameDelimiterPrecedesLast  =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter-precedes-last" Attributes
attr of
               Just Text
"after-inverted-name" -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesAfterInvertedName
               Just Text
"always"              -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesAlways
               Just Text
"never"               -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesNever
               Just Text
"contextual"          -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesContextual
               Maybe Text
_                          -> Maybe DelimiterPrecedes
forall a. Maybe a
Nothing
         , nameEtAlMin :: Maybe Int
nameEtAlMin                =
            Text -> Attributes -> Maybe Text
lookupAttribute Text
"et-al-min" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"et-al-use-first" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"et-al-subsequent-use-first" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"et-al-subsequent-min" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
         , nameEtAlUseLast :: Maybe Bool
nameEtAlUseLast            =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"et-al-use-last" Attributes
attr of
               Just Text
"true" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
               Just Text
"false" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
               Maybe Text
_           -> Maybe Bool
forall a. Maybe a
Nothing
         , nameForm :: Maybe NameForm
nameForm                   =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr of
               Just Text
"short"  -> NameForm -> Maybe NameForm
forall a. a -> Maybe a
Just NameForm
ShortName
               Just Text
"count"  -> NameForm -> Maybe NameForm
forall a. a -> Maybe a
Just NameForm
CountName
               Just Text
"long"   -> NameForm -> Maybe NameForm
forall a. a -> Maybe a
Just NameForm
LongName
               Maybe Text
_             -> Maybe NameForm
forall a. Maybe a
Nothing
         , nameInitialize :: Maybe Bool
nameInitialize             =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"initialize" Attributes
attr of
               Just Text
"false" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
               Just Text
"true" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
               Maybe Text
_            -> Maybe Bool
forall a. Maybe a
Nothing
         , nameInitializeWith :: Maybe Text
nameInitializeWith         =
             Text -> Attributes -> Maybe Text
lookupAttribute Text
"initialize-with" Attributes
attr
         , nameAsSortOrder :: Maybe NameAsSortOrder
nameAsSortOrder            =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name-as-sort-order" Attributes
attr of
               Just Text
"all"   -> NameAsSortOrder -> Maybe NameAsSortOrder
forall a. a -> Maybe a
Just NameAsSortOrder
NameAsSortOrderAll
               Just Text
"first" -> NameAsSortOrder -> Maybe NameAsSortOrder
forall a. a -> Maybe a
Just NameAsSortOrder
NameAsSortOrderFirst
               Maybe Text
_            -> Maybe NameAsSortOrder
forall a. Maybe a
Nothing
         , nameSortSeparator :: Maybe Text
nameSortSeparator          =
             Text -> Attributes -> Maybe Text
lookupAttribute Text
"sort-separator" Attributes
attr
         }
  (NameFormat, Formatting) -> ElementParser (NameFormat, Formatting)
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (NameFormat
nameformat, Formatting
formatting)

pGroup :: X.Element -> ElementParser (Element a)
pGroup :: forall a. Element -> ElementParser (Element a)
pGroup 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] -> ExceptT CiteprocError Identity [Element a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ElementParser (Element a)
forall a. Element -> ElementParser (Element a)
pElement ([Element] -> ExceptT CiteprocError Identity [Element a])
-> [Element] -> ExceptT CiteprocError Identity [Element a]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
node
  Element a -> ElementParser (Element a)
forall a. a -> ExceptT CiteprocError Identity 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 :: forall a. Element -> ElementParser (Element a)
pText 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 Text
"form" Attributes
attr of
                  Just Text
"short" -> VariableForm
ShortForm
                  Maybe Text
_            -> VariableForm
LongForm
  let termform :: TermForm
termform = 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 termnumber :: Maybe TermNumber
termnumber = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"plural" Attributes
attr of
                     Just Text
"true"   -> TermNumber -> Maybe TermNumber
forall a. a -> Maybe a
Just TermNumber
Plural
                     Just Text
"false"  -> TermNumber -> Maybe TermNumber
forall a. a -> Maybe a
Just TermNumber
Singular
                     Maybe Text
_             -> Maybe TermNumber
forall a. Maybe a
Nothing
  ElementType a
elt <- case Text -> Attributes -> Maybe Text
lookupAttribute Text
"variable" Attributes
attr of
           Just Text
var -> ElementType a -> ExceptT CiteprocError Identity (ElementType a)
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementType a -> ExceptT CiteprocError Identity (ElementType a))
-> ElementType a -> ExceptT CiteprocError Identity (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))
           Maybe Text
Nothing ->
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"macro" Attributes
attr of
               Just Text
macroname -> ElementType a -> ExceptT CiteprocError Identity (ElementType a)
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementType a -> ExceptT CiteprocError Identity (ElementType a))
-> ElementType a -> ExceptT CiteprocError Identity (ElementType a)
forall a b. (a -> b) -> a -> b
$ TextType -> ElementType a
forall a. TextType -> ElementType a
EText (Text -> TextType
TextMacro Text
macroname)
               Maybe Text
Nothing ->
                 case Text -> Attributes -> Maybe Text
lookupAttribute Text
"term" Attributes
attr of
                   Just Text
termname ->
                     ElementType a -> ExceptT CiteprocError Identity (ElementType a)
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementType a -> ExceptT CiteprocError Identity (ElementType a))
-> ElementType a -> ExceptT CiteprocError Identity (ElementType a)
forall a b. (a -> b) -> a -> b
$ TextType -> ElementType a
forall a. TextType -> ElementType a
EText (Term -> TextType
TextTerm
                       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
                            })
                   Maybe Text
Nothing ->
                     case Text -> Attributes -> Maybe Text
lookupAttribute Text
"value" Attributes
attr of
                       Just Text
val ->
                         ElementType a -> ExceptT CiteprocError Identity (ElementType a)
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElementType a -> ExceptT CiteprocError Identity (ElementType a))
-> ElementType a -> ExceptT CiteprocError Identity (ElementType a)
forall a b. (a -> b) -> a -> b
$ TextType -> ElementType a
forall a. TextType -> ElementType a
EText (Text -> TextType
TextValue Text
val)
                       Maybe Text
Nothing ->
                         String -> ExceptT CiteprocError Identity (ElementType a)
forall a. String -> ElementParser a
parseFailure String
"text element lacks needed attribute"
  Element a -> ElementParser (Element a)
forall a. a -> ExceptT CiteprocError Identity 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, [Element a])
pMacro :: forall a. Element -> ElementParser (Text, [Element a])
pMacro Element
node = do
  Text
name <- case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name" (Element -> Attributes
getAttributes Element
node) of
            Just Text
t  -> Text -> ExceptT CiteprocError Identity Text
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
            Maybe Text
Nothing -> String -> ExceptT CiteprocError Identity Text
forall a. String -> ElementParser a
parseFailure String
"macro element missing name attribute"
  [Element a]
elts <- (Element -> ExceptT CiteprocError Identity (Element a))
-> [Element] -> ExceptT CiteprocError Identity [Element a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ExceptT CiteprocError Identity (Element a)
forall a. Element -> ElementParser (Element a)
pElement (Element -> [Element]
allChildren Element
node)
  (Text, [Element a]) -> ElementParser (Text, [Element a])
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, [Element a]
elts)

getInheritableNameFormat :: Attributes -> NameFormat
getInheritableNameFormat :: Attributes -> NameFormat
getInheritableNameFormat Attributes
attr =
  NameFormat
         { nameGivenFormatting :: Maybe Formatting
nameGivenFormatting = Maybe Formatting
forall a. Maybe a
Nothing
         , nameFamilyFormatting :: Maybe Formatting
nameFamilyFormatting = Maybe Formatting
forall a. Maybe a
Nothing
         , nameAndStyle :: Maybe TermForm
nameAndStyle =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"and" Attributes
attr of
               Just Text
"text"   -> TermForm -> Maybe TermForm
forall a. a -> Maybe a
Just TermForm
Long
               Just Text
"symbol" -> TermForm -> Maybe TermForm
forall a. a -> Maybe a
Just TermForm
Symbol
               Maybe Text
_             -> Maybe TermForm
forall a. Maybe a
Nothing
         , nameDelimiter :: Maybe Text
nameDelimiter =
             Text -> Attributes -> Maybe Text
lookupAttribute Text
"name-delimiter" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
             Text -> Attributes -> Maybe Text
lookupAttribute Text
"names-delimiter" Attributes
attr
         , nameDelimiterPrecedesEtAl :: Maybe DelimiterPrecedes
nameDelimiterPrecedesEtAl  =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter-precedes-et-al" Attributes
attr of
               Just Text
"after-inverted-name" -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesAfterInvertedName
               Just Text
"always"              -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesAlways
               Just Text
"never"               -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesNever
               Just Text
"contextual"          -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesContextual
               Maybe Text
_                          -> Maybe DelimiterPrecedes
forall a. Maybe a
Nothing
         , nameDelimiterPrecedesLast :: Maybe DelimiterPrecedes
nameDelimiterPrecedesLast  =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter-precedes-last" Attributes
attr of
               Just Text
"after-inverted-name" -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesAfterInvertedName
               Just Text
"always"              -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesAlways
               Just Text
"never"               -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesNever
               Just Text
"contextual"          -> DelimiterPrecedes -> Maybe DelimiterPrecedes
forall a. a -> Maybe a
Just DelimiterPrecedes
PrecedesContextual
               Maybe Text
_                          -> Maybe DelimiterPrecedes
forall a. Maybe a
Nothing
         , nameEtAlMin :: Maybe Int
nameEtAlMin                =
           Text -> Attributes -> Maybe Text
lookupAttribute Text
"et-al-min" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"et-al-use-first" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"et-al-subsequent-use-first" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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 Text
"et-al-subsequent-min" Attributes
attr Maybe Text -> (Text -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Int
readAsInt
         , nameEtAlUseLast :: Maybe Bool
nameEtAlUseLast            =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"et-al-use-last" Attributes
attr of
               Just Text
"true" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
               Just Text
"false" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
               Maybe Text
_           -> Maybe Bool
forall a. Maybe a
Nothing
         , nameForm :: Maybe NameForm
nameForm                   =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name-form" Attributes
attr of
               Just Text
"short"  -> NameForm -> Maybe NameForm
forall a. a -> Maybe a
Just NameForm
ShortName
               Just Text
"count"  -> NameForm -> Maybe NameForm
forall a. a -> Maybe a
Just NameForm
CountName
               Just Text
"long"   -> NameForm -> Maybe NameForm
forall a. a -> Maybe a
Just NameForm
LongName
               Maybe Text
_             -> Maybe NameForm
forall a. Maybe a
Nothing
         , nameInitialize :: Maybe Bool
nameInitialize             =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"initialize" Attributes
attr of
               Just Text
"false" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
               Just Text
"true" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
               Maybe Text
_            -> Maybe Bool
forall a. Maybe a
Nothing
         , nameInitializeWith :: Maybe Text
nameInitializeWith         =
             Text -> Attributes -> Maybe Text
lookupAttribute Text
"initialize-with" Attributes
attr
         , nameAsSortOrder :: Maybe NameAsSortOrder
nameAsSortOrder            =
             case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name-as-sort-order" Attributes
attr of
               Just Text
"all"   -> NameAsSortOrder -> Maybe NameAsSortOrder
forall a. a -> Maybe a
Just NameAsSortOrder
NameAsSortOrderAll
               Just Text
"first" -> NameAsSortOrder -> Maybe NameAsSortOrder
forall a. a -> Maybe a
Just NameAsSortOrder
NameAsSortOrderFirst
               Maybe Text
_            -> Maybe NameAsSortOrder
forall a. Maybe a
Nothing
         , nameSortSeparator :: Maybe Text
nameSortSeparator          =
             Text -> Attributes -> Maybe Text
lookupAttribute Text
"sort-separator" Attributes
attr
         }

pLayout :: X.Element -> ElementParser (Layout a)
pLayout :: forall a. Element -> ElementParser (Layout a)
pLayout Element
node = do
  let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
  let nameformat :: NameFormat
nameformat = Attributes -> NameFormat
getInheritableNameFormat Attributes
attr
  let layouts :: [Element]
layouts = Text -> Element -> [Element]
getChildren Text
"layout" Element
node
  -- In case there are multiple layouts (as CSL-M allows), we raise an error
  let elname :: String
elname = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Name -> Text
X.nameLocalName (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Element -> Name
X.elementName Element
node
  Element
layout <- case [Element]
layouts of
              [] -> String -> ExceptT CiteprocError Identity Element
forall a. String -> ElementParser a
parseFailure (String -> ExceptT CiteprocError Identity Element)
-> String -> ExceptT CiteprocError Identity Element
forall a b. (a -> b) -> a -> b
$ String
"No layout element present in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
elname
              [Element
l] -> Element -> ExceptT CiteprocError Identity Element
forall a. a -> ExceptT CiteprocError Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Element
l
              (Element
_:[Element]
_) -> String -> ExceptT CiteprocError Identity Element
forall a. String -> ElementParser a
parseFailure (String -> ExceptT CiteprocError Identity Element)
-> String -> ExceptT CiteprocError Identity Element
forall a b. (a -> b) -> a -> b
$ String
"Multiple layout elements present in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
elname
  let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting (Attributes -> Formatting)
-> (Element -> Attributes) -> Element -> Formatting
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Attributes
getAttributes (Element -> Formatting) -> Element -> Formatting
forall a b. (a -> b) -> a -> b
$ Element
layout
  let sorts :: [Element]
sorts   = Text -> Element -> [Element]
getChildren Text
"sort" Element
node
  [Element a]
elements <- (Element -> ExceptT CiteprocError Identity (Element a))
-> [Element] -> ExceptT CiteprocError Identity [Element a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ExceptT CiteprocError Identity (Element a)
forall a. Element -> ElementParser (Element a)
pElement ([Element] -> ExceptT CiteprocError Identity [Element a])
-> [Element] -> ExceptT CiteprocError Identity [Element a]
forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
layout
  let opts :: LayoutOptions
opts = LayoutOptions
             { layoutCollapse :: Maybe Collapsing
layoutCollapse =
                 case Text -> Attributes -> Maybe Text
lookupAttribute Text
"collapse" Attributes
attr of
                   Just Text
"citation-number" -> Collapsing -> Maybe Collapsing
forall a. a -> Maybe a
Just Collapsing
CollapseCitationNumber
                   Just Text
"year"            -> Collapsing -> Maybe Collapsing
forall a. a -> Maybe a
Just Collapsing
CollapseYear
                   Just Text
"year-suffix"     -> Collapsing -> Maybe Collapsing
forall a. a -> Maybe a
Just Collapsing
CollapseYearSuffix
                   Just Text
"year-suffix-ranged"
                                          -> Collapsing -> Maybe Collapsing
forall a. a -> Maybe a
Just Collapsing
CollapseYearSuffixRanged
                   Maybe Text
_                      -> Maybe Collapsing
forall a. Maybe a
Nothing
             , layoutYearSuffixDelimiter :: Maybe Text
layoutYearSuffixDelimiter =
                 Text -> Attributes -> Maybe Text
lookupAttribute Text
"year-suffix-delimiter" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
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 Text
"cite-group-delimiter" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
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 Text
"after-collapse-delimiter" Attributes
attr Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                   Formatting -> Maybe Text
formatDelimiter Formatting
formatting
             , layoutNameFormat :: NameFormat
layoutNameFormat = NameFormat
nameformat
             }
  [SortKey a]
sortKeys <- (Element -> ExceptT CiteprocError Identity (SortKey a))
-> [Element] -> ExceptT CiteprocError Identity [SortKey a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Element -> ExceptT CiteprocError Identity (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 Text
"key") [Element]
sorts)
  Layout a -> ElementParser (Layout a)
forall a. a -> ExceptT CiteprocError Identity 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
$ Layout { layoutOptions :: LayoutOptions
layoutOptions  = LayoutOptions
opts
                  , layoutFormatting :: Formatting
layoutFormatting = Formatting
formatting{
                                         formatAffixesInside = True }
                  , layoutElements :: [Element a]
layoutElements = [Element a]
elements
                  , layoutSortKeys :: [SortKey a]
layoutSortKeys = [SortKey a]
sortKeys
                  }

pSortKey :: X.Element -> ElementParser (SortKey a)
pSortKey :: forall a. Element -> ElementParser (SortKey a)
pSortKey Element
node = do
  let attr :: Attributes
attr@(Attributes Map Text Text
attr') = Element -> Attributes
getAttributes Element
node
  let direction :: SortDirection
direction = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"sort" Attributes
attr of
                    Just Text
"descending" -> SortDirection
Descending
                    Maybe Text
_                 -> SortDirection
Ascending
  -- The attributes names-min, names-use-first, and names-use-last may
  -- be used to override the values of the corresponding
  -- et-al-min/et-al-subsequent-min,
  -- et-al-use-first/et-al-subsequent-use-first and et-al-use-last
  -- attributes, and affect all names generated via macros called by
  -- cs:key.
  let keyChange :: a -> a
keyChange a
"names-min" = a
"et-al-min"
      keyChange a
"names-use-first" = a
"et-al-use-first"
      keyChange a
"names-use-last" = a
"et-al-use-last"
      keyChange a
"names-subsequent-min" = a
"et-al-subsequent-min"
      keyChange a
"names-subsequent-use-first" = a
"et-al-subsequent-use-first"
      keyChange a
x = a
x
  let nameformat :: NameFormat
nameformat = Attributes -> NameFormat
getInheritableNameFormat
                     (Map Text Text -> Attributes
Attributes ((Text -> Text) -> Map Text Text -> Map Text Text
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Text -> Text
forall {a}. (Eq a, IsString a) => a -> a
keyChange Map Text Text
attr'))
  case Text -> Attributes -> Maybe Text
lookupAttribute Text
"macro" Attributes
attr of
      Just Text
macroname -> SortKey a -> ElementParser (SortKey a)
forall a. a -> ExceptT CiteprocError Identity 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 -> NameFormat -> Text -> SortKey a
forall a. SortDirection -> NameFormat -> Text -> SortKey a
SortKeyMacro SortDirection
direction NameFormat
nameformat Text
macroname
      Maybe Text
Nothing   -> SortKey a -> ElementParser (SortKey a)
forall a. a -> ExceptT CiteprocError Identity 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 Text
"variable" Attributes
attr)

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