{-# 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)
mergeLocales :: Maybe Lang -> Style a -> Locale
mergeLocales :: forall a. Maybe Lang -> Style a -> Locale
mergeLocales Maybe Lang
mblang Style a
style =
forall a. Monoid a => [a] -> a
mconcat [Locale]
stylelocales forall a. Semigroup a => a -> a -> a
<> Locale
deflocale
where
getUSLocale :: Locale
getUSLocale = case Lang -> Either CiteprocError Locale
getLocale (Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang Text
"en" forall a. Maybe a
Nothing (forall a. a -> Maybe a
JustText
"US") [] [] []) of
Right Locale
l -> Locale
l
Left CiteprocError
_ -> forall a. Monoid a => a
mempty
lang :: Lang
lang = forall a. a -> Maybe a -> a
fromMaybe (Text
-> Maybe Text
-> Maybe Text
-> [Text]
-> [(Text, [(Text, Text)])]
-> [Text]
-> Lang
Lang Text
"en" forall a. Maybe a
Nothing (forall a. a -> Maybe a
JustText
"US") [] [] []) forall a b. (a -> b) -> a -> b
$
Maybe Lang
mblang forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StyleOptions -> Maybe Lang
styleDefaultLocale (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 =
[Locale
l | Locale
l <- forall a. Style a -> [Locale]
styleLocales Style a
style
, Locale -> Maybe Lang
localeLanguage Locale
l forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Lang
lang] forall a. [a] -> [a] -> [a]
++
[Locale
l | Maybe Lang
primlang forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Lang
lang
, Locale
l <- forall a. Style a -> [Locale]
styleLocales Style a
style
, Locale -> Maybe Lang
localeLanguage Locale
l forall a. Eq a => a -> a -> Bool
== Maybe Lang
primlang] forall a. [a] -> [a] -> [a]
++
[Locale
l | Locale
l <- forall a. Style a -> [Locale]
styleLocales Style a
style
, (Lang -> Maybe Text
langRegion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Locale -> Maybe Lang
localeLanguage Locale
l) forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
, (Lang -> Text
langLanguage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Locale -> Maybe Lang
localeLanguage Locale
l) forall a. Eq a => a -> a -> Bool
==
forall a. a -> Maybe a
Just (Lang -> Text
langLanguage Lang
lang)] forall a. [a] -> [a] -> [a]
++
[Locale
l | Locale
l <- forall a. Style a -> [Locale]
styleLocales Style a
style
, forall a. Maybe a -> Bool
isNothing (Locale -> Maybe Lang
localeLanguage Locale
l)]
parseStyle :: Monad m
=> (Text -> m Text)
-> Text
-> 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 =
case ParseSettings -> Text -> Either SomeException Document
X.parseText forall a. Default a => a
def (Text -> Text
TL.fromStrict Text
t) of
Left SomeException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> CiteprocError
CiteprocXMLError (String -> Text
T.pack (forall a. Show a => a -> String
show SomeException
e))
Right Document
n -> do
let attr :: Attributes
attr = Element -> Attributes
getAttributes 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 -> forall a. Maybe a
Nothing
Just Text
l -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Either String Lang
parseLang Text
l
let links :: [Element]
links = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> Element -> [Element]
getChildren Text
"link") 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) forall a. Eq a => a -> a -> Bool
==
forall a. a -> Maybe a
Just Text
"independent-parent" ] of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a. ElementParser a -> Either CiteprocError a
runElementParser forall a b. (a -> b) -> a -> b
$ forall a. Maybe Lang -> Element -> ElementParser (Style a)
pStyle Maybe Lang
defaultLocale 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> CiteprocError
CiteprocXMLError
Text
"No href attribute on link to parent style"
Just Text
url -> do
Text
parentTxt <- Text -> m Text
getIndependentParent Text
url
case ParseSettings -> Text -> Either SomeException Document
X.parseText forall a. Default a => a
def (Text -> Text
TL.fromStrict Text
parentTxt) of
Left SomeException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> CiteprocError
CiteprocXMLError (String -> Text
T.pack (forall a. Show a => a -> String
show SomeException
e))
Right Document
n' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall a. ElementParser a -> Either CiteprocError a
runElementParser forall a b. (a -> b) -> a -> b
$ forall a. Maybe Lang -> Element -> ElementParser (Style a)
pStyle Maybe Lang
defaultLocale 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 attrmap :: Map Name Text
attrmap = Element -> Map Name Text
getInheritableNameAttributes Element
node
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall a. Semigroup a => a -> a -> a
<> Map Name Text
attrmap) forall a b. (a -> b) -> a -> b
$ do
let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
Map Text [Element]
macroMap <- forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> ElementParser (Text, [Element])
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,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Map Text [Element] -> Element -> ElementParser (Layout a)
pLayout Map Text [Element]
macroMap Element
n
[] -> forall a. String -> ElementParser a
parseFailure String
"No citation element present"
[Element]
_ -> 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, forall a. a -> Maybe a
Just Layout a
z))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Map Text [Element] -> Element -> ElementParser (Layout a)
pLayout Map Text [Element]
macroMap Element
n
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty, forall a. Maybe a
Nothing)
[Element]
_ -> 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 forall a. Eq a => a -> a -> Bool
== 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" -> forall a. a -> Maybe a
Just GivenNameDisambiguationRule
disambiguateGivenNameRule
Maybe Text
_ -> forall a. Maybe a
Nothing
, disambiguateAddYearSuffix :: Bool
disambiguateAddYearSuffix =
Text -> Attributes -> Maybe Text
lookupAttribute Text
"disambiguate-add-year-suffix" Attributes
cattr forall a. Eq a => a -> a -> Bool
==
forall a. a -> Maybe a
Just Text
"true"
}
let hasYearSuffixVariable :: Element a -> Bool
hasYearSuffixVariable
(Element (EText (TextVariable VariableForm
_ Variable
"year-suffix")) Formatting
_) = Bool
True
hasYearSuffixVariable
(Element (EGroup Bool
_ [Element a]
es) Formatting
_) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Element a -> Bool
hasYearSuffixVariable [Element a]
es
hasYearSuffixVariable
(Element (EChoose []) Formatting
_) = Bool
False
hasYearSuffixVariable
(Element (EChoose ((Match
_,[Condition]
_,[Element a]
es):[(Match, [Condition], [Element a])]
conds)) Formatting
f) =
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 (forall a. ElementType a -> Formatting -> Element a
Element (forall a. [(Match, [Condition], [Element a])] -> ElementType a
EChoose [(Match, [Condition], [Element a])]
conds) Formatting
f)
hasYearSuffixVariable Element a
_ = Bool
False
let usesYearSuffixVariable :: Bool
usesYearSuffixVariable =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {a}. Element a -> Bool
hasYearSuffixVariable forall a b. (a -> b) -> a -> b
$
forall a. Layout a -> [Element a]
layoutElements Layout a
citations forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] 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 =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== Text
"true") 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" -> forall a. a -> Maybe a
Just PageRangeFormat
PageRangeChicago15
Just Text
"chicago-15" -> forall a. a -> Maybe a
Just PageRangeFormat
PageRangeChicago15
Just Text
"chicago-16" -> forall a. a -> Maybe a
Just PageRangeFormat
PageRangeChicago16
Just Text
"expanded" -> forall a. a -> Maybe a
Just PageRangeFormat
PageRangeExpanded
Just Text
"minimal" -> forall a. a -> Maybe a
Just PageRangeFormat
PageRangeMinimal
Just Text
"minimal-two" -> forall a. a -> Maybe a
Just PageRangeFormat
PageRangeMinimalTwo
Maybe Text
_ -> 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 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(Text
", " 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 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 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 forall a. Eq a => a -> a -> Bool
== 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" -> forall a. a -> Maybe a
Just SecondFieldAlign
SecondFieldAlignFlush
Just Text
"margin" -> forall a. a -> Maybe a
Just SecondFieldAlign
SecondFieldAlignMargin
Maybe Text
_ -> 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 -> forall a. Maybe a
Nothing
Just Text
t -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
Text
-> SubsequentAuthorSubstituteRule -> SubsequentAuthorSubstitute
SubsequentAuthorSubstitute Text
t
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
}
[Locale]
locales <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> ElementParser 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 forall a b. (a -> b) -> [a] -> [b]
map Text -> Maybe Int
readAsInt (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)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. Maybe a
Nothing
}
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" -> forall a. Element -> ElementParser (Element a)
pDate Element
node
Text
"text" -> forall a. Element -> ElementParser (Element a)
pText Element
node
Text
"group" -> forall a. Element -> ElementParser (Element a)
pGroup Element
node
Text
"choose" -> forall a. Element -> ElementParser (Element a)
pChoose Element
node
Text
"number" -> forall a. Element -> ElementParser (Element a)
pNumber Element
node
Text
"label" -> forall a. Element -> ElementParser (Element a)
pLabel Element
node
Text
"names" -> forall a. Element -> ElementParser (Element a)
pNames Element
node
Text
name -> forall a. String -> ElementParser a
parseFailure forall a b. (a -> b) -> a -> b
$ String
"unknown element " forall a. Semigroup a => a -> a -> a
<> 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"if" Element
node
[(Match, [Condition], [Element a])]
elseIfNodes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"else-if" Element
node
[(Match, [Condition], [Element a])]
elseNodes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a.
Element -> ElementParser (Match, [Condition], [Element a])
parseIf 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 forall a. [a] -> [a] -> [a]
++ [(Match, [Condition], [Element a])]
elseIfNodes forall a. [a] -> [a] -> [a]
++ [(Match, [Condition], [Element a])]
elseNodes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ElementType a -> Formatting -> Element a
Element (forall a. [(Match, [Condition], [Element a])] -> ElementType a
EChoose [(Match, [Condition], [Element a])]
parts) 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 forall a. a -> [a] -> [a]
:)
Maybe Text
_ -> forall a. a -> a
id) 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 -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Condition
IsNumeric) [Condition]
xs (Text -> [Variable]
splitVars Text
t)
Maybe Text
_ -> forall a. a -> a
id) 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 -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Condition
IsUncertainDate) [Condition]
xs (Text -> [Variable]
splitVars Text
t)
Maybe Text
_ -> forall a. a -> a
id) 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 -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Condition
HasLocatorType) [Condition]
xs (Text -> [Variable]
splitVars Text
t)
Maybe Text
_ -> forall a. a -> a
id) 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 ->
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\case
Variable
"first" -> (Position -> Condition
HasPosition Position
FirstPosition forall a. a -> [a] -> [a]
:)
Variable
"ibid" -> (Position -> Condition
HasPosition Position
Ibid forall a. a -> [a] -> [a]
:)
Variable
"ibid-with-locator"
-> (Position -> Condition
HasPosition Position
IbidWithLocator forall a. a -> [a] -> [a]
:)
Variable
"subsequent" -> (Position -> Condition
HasPosition Position
Subsequent forall a. a -> [a] -> [a]
:)
Variable
"near-note" -> (Position -> Condition
HasPosition Position
NearNote forall a. a -> [a] -> [a]
:)
Variable
_ -> forall a. a -> a
id)
[Condition]
xs (Text -> [Variable]
splitVars Text
t)
Maybe Text
_ -> forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(case Text -> Attributes -> Maybe Text
lookupAttribute Text
"type" Attributes
attr of
Just Text
t -> \[Condition]
xs -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Condition
HasType) [Condition]
xs (Text -> [Text]
T.words forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
t)
Maybe Text
_ -> forall a. a -> a
id) 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 -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variable -> Condition
HasVariable) [Condition]
xs (Text -> [Variable]
splitVars Text
t)
Maybe Text
_ -> forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ []
[Element a]
elts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Element -> ElementParser (Element a)
pElement forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
node
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 -> forall a. String -> ElementParser a
parseFailure String
"number element without required variable attribute"
Just Text
var -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ElementType a -> Formatting -> Element a
Element (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 forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ElementType a -> Formatting -> Element a
Element (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
Attributes
attr <- Element -> ElementParser Attributes
getNameAttributes Element
node
let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
let variables :: [Variable]
variables = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Text -> [Variable]
splitVars forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"variable" Attributes
attr
let pChild :: (NamesFormat, [Element a])
-> Element
-> ReaderT
(Map Name Text) (Except CiteprocError) (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 <- forall a. Element -> ElementParser (Element a)
pLabel Element
n
case Element Any
e of
Element (ELabel Variable
_ TermForm
labelform Pluralize
pluralize) Formatting
f ->
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesLabel :: Maybe (TermForm, Pluralize, Formatting)
namesLabel = forall a. a -> Maybe a
Just (TermForm
labelform, Pluralize
pluralize, Formatting
f)
, namesLabelBeforeName :: Bool
namesLabelBeforeName =
forall a. Maybe a -> Bool
isNothing (NamesFormat -> Maybe (NameFormat, Formatting)
namesName NamesFormat
nf) }
, [Element a]
subst )
Element Any
_ -> forall a. String -> ElementParser a
parseFailure String
"pLabel returned something other than ELabel"
Text
"substitute" -> do
[Element a]
els <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Element -> ElementParser (Element a)
pElement forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
n
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
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesEtAl :: Maybe (Text, Formatting)
namesEtAl = forall a. a -> Maybe a
Just (Text, Formatting)
res }, [Element a]
subst )
Text
"name" -> do
(NameFormat, Formatting)
res <- Element -> ElementParser (NameFormat, Formatting)
pName Element
n
forall (m :: * -> *) a. Monad m => a -> m a
return ( NamesFormat
nf{ namesName :: Maybe (NameFormat, Formatting)
namesName = forall a. a -> Maybe a
Just (NameFormat, Formatting)
res }, [Element a]
subst )
Text
name -> forall a. String -> ElementParser a
parseFailure forall a b. (a -> b) -> a -> b
$ String
"element " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
name forall a. Semigroup a => a -> a -> a
<>
String
" not a valid child of names"
(NamesFormat
nameformat, [Element a]
subst) <-
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing Bool
False, [])
(Element -> [Element]
allChildren Element
node)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ElementType a -> Formatting -> Element a
Element (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 = forall a. a -> Maybe a -> a
fromMaybe Text
"et-al" forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"term" Attributes
attr
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
Attributes
attr <- Element -> ElementParser Attributes
getNameAttributes Element
node
let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
let nameParts :: [Attributes]
nameParts = forall a b. (a -> b) -> [a] -> [b]
map Element -> Attributes
getAttributes 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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"given" ] of
(Attributes
nattr:[Attributes]
_) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Attributes -> Formatting
getFormatting Attributes
nattr
[Attributes]
_ -> 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 forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"family" ] of
(Attributes
nattr:[Attributes]
_) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Attributes -> Formatting
getFormatting Attributes
nattr
[Attributes]
_ -> forall a. Maybe a
Nothing
, nameAndStyle :: Maybe TermForm
nameAndStyle =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"and" Attributes
attr of
Just Text
"text" -> forall a. a -> Maybe a
Just TermForm
Long
Just Text
"symbol" -> forall a. a -> Maybe a
Just TermForm
Symbol
Maybe Text
_ -> forall a. Maybe a
Nothing
, nameDelimiter :: Text
nameDelimiter =
forall a. a -> Maybe a -> a
fromMaybe Text
", " forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter" Attributes
attr
, nameDelimiterPrecedesEtAl :: DelimiterPrecedes
nameDelimiterPrecedesEtAl =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter-precedes-et-al" Attributes
attr of
Just Text
"after-inverted-name" -> DelimiterPrecedes
PrecedesAfterInvertedName
Just Text
"always" -> DelimiterPrecedes
PrecedesAlways
Just Text
"never" -> DelimiterPrecedes
PrecedesNever
Maybe Text
_ -> DelimiterPrecedes
PrecedesContextual
, nameDelimiterPrecedesLast :: DelimiterPrecedes
nameDelimiterPrecedesLast =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter-precedes-last" Attributes
attr of
Just Text
"after-inverted-name" -> DelimiterPrecedes
PrecedesAfterInvertedName
Just Text
"always" -> DelimiterPrecedes
PrecedesAlways
Just Text
"never" -> DelimiterPrecedes
PrecedesNever
Maybe Text
_ -> DelimiterPrecedes
PrecedesContextual
, nameEtAlMin :: Maybe Int
nameEtAlMin =
(Text -> Attributes -> Maybe Text
lookupAttribute Text
"names-min" Attributes
attr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
Text -> Attributes -> Maybe Text
lookupAttribute Text
"et-al-min" Attributes
attr) 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
"names-use-first" Attributes
attr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
Text -> Attributes -> Maybe Text
lookupAttribute Text
"et-al-use-first" Attributes
attr) 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 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 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 Text
"names-use-last" Attributes
attr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
Text -> Attributes -> Maybe Text
lookupAttribute Text
"et-al-use-last" Attributes
attr of
Just Text
"true" -> Bool
True
Maybe Text
_ -> Bool
False
, nameForm :: NameForm
nameForm =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr of
Just Text
"short" -> NameForm
ShortName
Just Text
"count" -> NameForm
CountName
Maybe Text
_ -> NameForm
LongName
, nameInitialize :: Bool
nameInitialize =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"initialize" Attributes
attr of
Just Text
"false" -> Bool
False
Maybe Text
_ -> Bool
True
, 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" -> forall a. a -> Maybe a
Just NameAsSortOrder
NameAsSortOrderAll
Just Text
"first" -> forall a. a -> Maybe a
Just NameAsSortOrder
NameAsSortOrderFirst
Maybe Text
_ -> forall a. Maybe a
Nothing
, nameSortSeparator :: Text
nameSortSeparator =
forall a. a -> Maybe a -> a
fromMaybe Text
", " forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"sort-separator" Attributes
attr
}
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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Element -> ElementParser (Element a)
pElement forall a b. (a -> b) -> a -> b
$ Element -> [Element]
allChildren Element
node
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ElementType a -> Formatting -> Element a
Element (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" -> forall a. a -> Maybe a
Just TermNumber
Plural
Just Text
"false" -> forall a. a -> Maybe a
Just TermNumber
Singular
Maybe Text
_ -> forall a. Maybe a
Nothing
ElementType a
elt <- case Text -> Attributes -> Maybe Text
lookupAttribute Text
"variable" Attributes
attr of
Just Text
var -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
_ -> do
[Element a]
elements <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Element -> ElementParser (Element a)
pElement (Element -> [Element]
allChildren Element
node)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Bool -> [Element a] -> ElementType a
EGroup Bool
True [Element a]
elements
Maybe Text
Nothing ->
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"term" Attributes
attr of
Just Text
termname ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall a. Maybe a
Nothing
, termGenderForm :: Maybe TermGender
termGenderForm = forall a. Maybe a
Nothing
, termMatch :: Maybe TermMatch
termMatch = forall a. Maybe a
Nothing
})
Maybe Text
Nothing ->
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"value" Attributes
attr of
Just Text
val ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. TextType -> ElementType a
EText (Text -> TextType
TextValue Text
val)
Maybe Text
Nothing ->
forall a. String -> ElementParser a
parseFailure String
"text element lacks needed attribute"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. ElementType a -> Formatting -> Element a
Element ElementType a
elt Formatting
formatting
pMacro :: X.Element -> ElementParser (Text, [X.Element])
pMacro :: Element -> ElementParser (Text, [Element])
pMacro Element
node = do
Text
name <- case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name" (Element -> Attributes
getAttributes Element
node) of
Just Text
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
Maybe Text
Nothing -> forall a. String -> ElementParser a
parseFailure String
"macro element missing name attribute"
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, Element -> [Element]
allChildren Element
node)
inheritableNameAttributes :: M.Map X.Name X.Name
inheritableNameAttributes :: Map Name Name
inheritableNameAttributes = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
x,Text
y) -> (Text -> Name
attname Text
x, Text -> Name
attname Text
y))
[ (Text
"and", Text
"and")
, (Text
"delimiter-precedes-et-al", Text
"delimiter-precedes-et-al")
, (Text
"delimiter-precedes-last", Text
"delimiter-precedes-last")
, (Text
"et-al-min", Text
"et-al-min")
, (Text
"et-al-use-first", Text
"et-al-use-first")
, (Text
"et-al-use-last", Text
"et-al-use-last")
, (Text
"et-al-subsequent-min", Text
"et-al-subsequent-min")
, (Text
"et-al-subsequent-use-first", Text
"et-al-subsequent-use-first")
, (Text
"initialize", Text
"initialize")
, (Text
"initialize-with", Text
"initialize-with")
, (Text
"name-as-sort-order", Text
"name-as-sort-order")
, (Text
"sort-separator", Text
"sort-separator")
, (Text
"name-form", Text
"form")
, (Text
"name-delimiter", Text
"delimiter")
, (Text
"names-delimiter", Text
"delimiter")
, (Text
"names-min", Text
"names-min")
, (Text
"names-use-first", Text
"names-use-first")
, (Text
"names-use-last", Text
"names-use-last")
]
getInheritableNameAttributes :: X.Element -> M.Map X.Name Text
getInheritableNameAttributes :: Element -> Map Name Text
getInheritableNameAttributes Element
elt =
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey
(\Name
k Text
v Map Name Text
m -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
k Map Name Name
inheritableNameAttributes of
Just Name
k' -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
k' Text
v Map Name Text
m
Maybe Name
Nothing -> Map Name Text
m) 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 :: forall a. Map Text [Element] -> Element -> ElementParser (Layout a)
pLayout Map Text [Element]
macroMap 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
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall a. Semigroup a => a -> a -> a
<> Map Name Text
attrmap) 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 Text
"layout" Element
node'
let elname :: String
elname = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Name -> Text
X.nameLocalName forall a b. (a -> b) -> a -> b
$ Element -> Name
X.elementName Element
node
Element
layout <- case [Element]
layouts of
[] -> forall a. String -> ElementParser a
parseFailure forall a b. (a -> b) -> a -> b
$ String
"No layout element present in " forall a. Semigroup a => a -> a -> a
<> String
elname
[Element
l] -> forall (m :: * -> *) a. Monad m => a -> m a
return Element
l
(Element
_:[Element]
_) -> forall a. String -> ElementParser a
parseFailure forall a b. (a -> b) -> a -> b
$ String
"Multiple layout elements present in " forall a. Semigroup a => a -> a -> a
<> String
elname
let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Attributes
getAttributes forall a b. (a -> b) -> a -> b
$ Element
layout
let sorts :: [Element]
sorts = Text -> Element -> [Element]
getChildren Text
"sort" Element
node'
[Element a]
elements <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Element -> ElementParser (Element a)
pElement 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" -> forall a. a -> Maybe a
Just Collapsing
CollapseCitationNumber
Just Text
"year" -> forall a. a -> Maybe a
Just Collapsing
CollapseYear
Just Text
"year-suffix" -> forall a. a -> Maybe a
Just Collapsing
CollapseYearSuffix
Just Text
"year-suffix-ranged"
-> forall a. a -> Maybe a
Just Collapsing
CollapseYearSuffixRanged
Maybe Text
_ -> forall a. Maybe a
Nothing
, layoutYearSuffixDelimiter :: Maybe Text
layoutYearSuffixDelimiter =
Text -> Attributes -> Maybe Text
lookupAttribute Text
"year-suffix-delimiter" Attributes
attr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
Text -> Attributes -> Maybe Text
lookupAttribute Text
"cite-group-delimiter" Attributes
attr 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
Formatting -> Maybe Text
formatDelimiter Formatting
formatting
}
[SortKey a]
sortKeys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Element -> ElementParser (SortKey a)
pSortKey (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> Element -> [Element]
getChildren Text
"key") [Element]
sorts)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 :: forall a. Element -> ElementParser (SortKey a)
pSortKey Element
node = do
let attrmap :: Map Name Text
attrmap = Element -> Map Name Text
getInheritableNameAttributes Element
node
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local (forall a. Semigroup a => a -> a -> a
<> Map Name Text
attrmap) 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 Text
"sort" Attributes
attr of
Just Text
"descending" -> SortDirection
Descending
Maybe Text
_ -> SortDirection
Ascending
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"macro" Attributes
attr of
Just Text
_ ->
forall a. SortDirection -> [Element a] -> SortKey a
SortKeyMacro SortDirection
direction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Element -> ElementParser (Element a)
pElement (Element -> [Element]
allChildren Element
node)
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. SortDirection -> Variable -> SortKey a
SortKeyVariable SortDirection
direction
(Text -> Variable
toVariable forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$
Text -> Attributes -> Maybe Text
lookupAttribute Text
"variable" Attributes
attr)
attname :: Text -> X.Name
attname :: Text -> Name
attname Text
t = Text -> Maybe Text -> Maybe Text -> Name
X.Name Text
t forall a. Maybe a
Nothing forall a. Maybe a
Nothing
expandMacros :: M.Map Text [X.Element]
-> X.Element
-> ElementParser X.Element
expandMacros :: Map Text [Element] -> Element -> ElementParser Element
expandMacros Map Text [Element]
macroMap Element
el =
case Name -> Text
X.nameLocalName (Element -> Name
X.elementName Element
el) of
Text
n | Text
n forall a. Eq a => a -> a -> Bool
== Text
"text" Bool -> Bool -> Bool
||
Text
n forall a. Eq a => a -> a -> Bool
== Text
"key" ->
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Text -> Name
attname Text
"macro") (Element -> Map Name Text
X.elementAttributes Element
el) of
Maybe Text
Nothing -> do
[Node]
els' <- 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)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Element
el{ elementNodes :: [Node]
X.elementNodes = [Node]
els' }
Just Text
macroName ->
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
macroName Map Text [Element]
macroMap of
Maybe [Element]
Nothing ->
forall a. String -> ElementParser a
parseFailure forall a b. (a -> b) -> a -> b
$ String
"macro " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
macroName forall a. Semigroup a => a -> a -> a
<> String
" not found"
Just [Element]
els -> do
[Node]
els' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Element -> Node
X.NodeElement forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text [Element] -> Element -> ElementParser Element
expandMacros Map Text [Element]
macroMap) [Element]
els
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Element
el{ elementNodes :: [Node]
X.elementNodes = [Node]
els' }
Text
_ -> do
[Node]
els' <- 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)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 Element
el') = Element -> Node
X.NodeElement 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 Node
x = forall (m :: * -> *) a. Monad m => a -> m a
return Node
x
splitVars :: Text -> [Variable]
splitVars :: Text -> [Variable]
splitVars = forall a b. (a -> b) -> [a] -> [b]
map Text -> Variable
toVariable forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip