{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Citeproc.Element
( pLocale
, pDate
, Attributes(..)
, lookupAttribute
, ElementParser
, runElementParser
, parseFailure
, getChildren
, allChildren
, getAttributes
, getNameAttributes
, getFormatting
, getTextContent
)
where
import Citeproc.Types
import Data.Maybe (fromMaybe)
import Control.Monad (foldM)
import qualified Data.Map as M
import qualified Text.XML as X
import Data.Text (Text)
import qualified Data.Text as T
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Class (lift)
newtype Attributes = Attributes (M.Map Text Text)
deriving (Int -> Attributes -> ShowS
[Attributes] -> ShowS
Attributes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attributes] -> ShowS
$cshowList :: [Attributes] -> ShowS
show :: Attributes -> String
$cshow :: Attributes -> String
showsPrec :: Int -> Attributes -> ShowS
$cshowsPrec :: Int -> Attributes -> ShowS
Show, NonEmpty Attributes -> Attributes
Attributes -> Attributes -> Attributes
forall b. Integral b => b -> Attributes -> Attributes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Attributes -> Attributes
$cstimes :: forall b. Integral b => b -> Attributes -> Attributes
sconcat :: NonEmpty Attributes -> Attributes
$csconcat :: NonEmpty Attributes -> Attributes
<> :: Attributes -> Attributes -> Attributes
$c<> :: Attributes -> Attributes -> Attributes
Semigroup, Semigroup Attributes
Attributes
[Attributes] -> Attributes
Attributes -> Attributes -> Attributes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Attributes] -> Attributes
$cmconcat :: [Attributes] -> Attributes
mappend :: Attributes -> Attributes -> Attributes
$cmappend :: Attributes -> Attributes -> Attributes
mempty :: Attributes
$cmempty :: Attributes
Monoid, Attributes -> Attributes -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attributes -> Attributes -> Bool
$c/= :: Attributes -> Attributes -> Bool
== :: Attributes -> Attributes -> Bool
$c== :: Attributes -> Attributes -> Bool
Eq)
lookupAttribute :: Text -> Attributes -> Maybe Text
lookupAttribute :: Text -> Attributes -> Maybe Text
lookupAttribute Text
key (Attributes Map Text Text
kvs) = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Map Text Text
kvs
type ElementParser = ReaderT (M.Map X.Name Text) (Except CiteprocError)
runElementParser :: ElementParser a -> Either CiteprocError a
runElementParser :: forall a. ElementParser a -> Either CiteprocError a
runElementParser ElementParser a
p = forall e a. Except e a -> Either e a
runExcept (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ElementParser a
p forall a. Monoid a => a
mempty)
parseFailure :: String -> ElementParser a
parseFailure :: forall a. String -> ElementParser a
parseFailure String
s = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (Text -> CiteprocError
CiteprocParseError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s)
getChildren :: Text -> X.Element -> [X.Element]
getChildren :: Text -> Element -> [Element]
getChildren Text
name Element
el = [Element
e | X.NodeElement Element
e <- Element -> [Node]
X.elementNodes Element
el
, Name -> Text
X.nameLocalName (Element -> Name
X.elementName Element
e) forall a. Eq a => a -> a -> Bool
== Text
name]
allChildren :: X.Element -> [X.Element]
allChildren :: Element -> [Element]
allChildren Element
el = [Element
e | X.NodeElement Element
e <- Element -> [Node]
X.elementNodes Element
el]
getAttributes :: X.Element -> Attributes
getAttributes :: Element -> Attributes
getAttributes =
Map Text Text -> Attributes
Attributes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Name -> Text
X.nameLocalName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Map Name Text
X.elementAttributes
getNameAttributes :: X.Element -> ElementParser Attributes
getNameAttributes :: Element -> ElementParser Attributes
getNameAttributes Element
node = do
Map Name Text
nameattr <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let xattr :: Map Name Text
xattr = Element -> Map Name Text
X.elementAttributes Element
node forall a. Semigroup a => a -> a -> a
<> Map Name Text
nameattr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Map Text Text -> Attributes
Attributes forall a b. (a -> b) -> a -> b
$ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Name -> Text
X.nameLocalName Map Name Text
xattr
getFormatting :: Attributes -> Formatting
getFormatting :: Attributes -> Formatting
getFormatting Attributes
attr =
Formatting
{ formatLang :: Maybe Lang
formatLang = forall a. Maybe a
Nothing
, formatFontStyle :: Maybe FontStyle
formatFontStyle =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"font-style" Attributes
attr of
Just Text
"italic" -> forall a. a -> Maybe a
Just FontStyle
ItalicFont
Just Text
"oblique" -> forall a. a -> Maybe a
Just FontStyle
ObliqueFont
Just Text
"normal" -> forall a. a -> Maybe a
Just FontStyle
NormalFont
Maybe Text
_ -> forall a. Maybe a
Nothing
, formatFontVariant :: Maybe FontVariant
formatFontVariant =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"font-variant" Attributes
attr of
Just Text
"small-caps" -> forall a. a -> Maybe a
Just FontVariant
SmallCapsVariant
Just Text
"normal" -> forall a. a -> Maybe a
Just FontVariant
NormalVariant
Maybe Text
_ -> forall a. Maybe a
Nothing
, formatFontWeight :: Maybe FontWeight
formatFontWeight =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"font-weight" Attributes
attr of
Just Text
"bold" -> forall a. a -> Maybe a
Just FontWeight
BoldWeight
Just Text
"light" -> forall a. a -> Maybe a
Just FontWeight
LightWeight
Just Text
"normal" -> forall a. a -> Maybe a
Just FontWeight
NormalWeight
Maybe Text
_ -> forall a. Maybe a
Nothing
, formatTextDecoration :: Maybe TextDecoration
formatTextDecoration =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"text-decoration" Attributes
attr of
Just Text
"underline" -> forall a. a -> Maybe a
Just TextDecoration
UnderlineDecoration
Just Text
"none" -> forall a. a -> Maybe a
Just TextDecoration
NoDecoration
Maybe Text
_ -> forall a. Maybe a
Nothing
, formatVerticalAlign :: Maybe VerticalAlign
formatVerticalAlign =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"vertical-align" Attributes
attr of
Just Text
"sup" -> forall a. a -> Maybe a
Just VerticalAlign
SupAlign
Just Text
"sub" -> forall a. a -> Maybe a
Just VerticalAlign
SubAlign
Just Text
"baseline" -> forall a. a -> Maybe a
Just VerticalAlign
BaselineAlign
Maybe Text
_ -> forall a. Maybe a
Nothing
, formatPrefix :: Maybe Text
formatPrefix = Text -> Attributes -> Maybe Text
lookupAttribute Text
"prefix" Attributes
attr
, formatSuffix :: Maybe Text
formatSuffix = Text -> Attributes -> Maybe Text
lookupAttribute Text
"suffix" Attributes
attr
, formatDisplay :: Maybe DisplayStyle
formatDisplay =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"display" Attributes
attr of
Just Text
"block" -> forall a. a -> Maybe a
Just DisplayStyle
DisplayBlock
Just Text
"left-margin" -> forall a. a -> Maybe a
Just DisplayStyle
DisplayLeftMargin
Just Text
"right-inline" -> forall a. a -> Maybe a
Just DisplayStyle
DisplayRightInline
Just Text
"indent" -> forall a. a -> Maybe a
Just DisplayStyle
DisplayIndent
Maybe Text
_ -> forall a. Maybe a
Nothing
, formatTextCase :: Maybe TextCase
formatTextCase =
case Text -> Attributes -> Maybe Text
lookupAttribute Text
"text-case" Attributes
attr of
Just Text
"lowercase" -> forall a. a -> Maybe a
Just TextCase
Lowercase
Just Text
"uppercase" -> forall a. a -> Maybe a
Just TextCase
Uppercase
Just Text
"capitalize-first" -> forall a. a -> Maybe a
Just TextCase
CapitalizeFirst
Just Text
"capitalize-all" -> forall a. a -> Maybe a
Just TextCase
CapitalizeAll
Just Text
"sentence" -> forall a. a -> Maybe a
Just TextCase
SentenceCase
Just Text
"title" -> forall a. a -> Maybe a
Just TextCase
TitleCase
Maybe Text
_ -> forall a. Maybe a
Nothing
, formatDelimiter :: Maybe Text
formatDelimiter = Text -> Attributes -> Maybe Text
lookupAttribute Text
"delimiter" Attributes
attr
, formatStripPeriods :: Bool
formatStripPeriods =
Text -> Attributes -> Maybe Text
lookupAttribute Text
"strip-periods" Attributes
attr forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"true"
, formatQuotes :: Bool
formatQuotes =
Text -> Attributes -> Maybe Text
lookupAttribute Text
"quotes" Attributes
attr forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Text
"true"
, formatAffixesInside :: Bool
formatAffixesInside = Bool
False
}
getTextContent :: X.Element -> Text
getTextContent :: Element -> Text
getTextContent Element
e = forall a. Monoid a => [a] -> a
mconcat [Text
t | X.NodeContent Text
t <- Element -> [Node]
X.elementNodes Element
e]
pLocale :: X.Element -> ElementParser Locale
pLocale :: Element -> ElementParser Locale
pLocale Element
node = do
let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
Maybe Lang
lang <- case Text -> Attributes -> Maybe Text
lookupAttribute Text
"lang" Attributes
attr of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Text
l -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. String -> ElementParser a
parseFailure (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ Text -> Either String Lang
parseLang Text
l
let styleOpts :: Attributes
styleOpts = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Element -> Attributes
getAttributes forall a b. (a -> b) -> a -> b
$
Text -> Element -> [Element]
getChildren Text
"style-options" Element
node
let addDateElt :: Element a -> Map DateType (Element a) -> Map DateType (Element a)
addDateElt Element a
e Map DateType (Element a)
m =
case Element a
e of
Element (EDate Variable
_ DateType
dateType Maybe ShowDateParts
_ [DP]
_) Formatting
_ -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert DateType
dateType Element a
e Map DateType (Element a)
m
Element a
_ -> forall a. HasCallStack => String -> a
error String
"pDate returned an element other than EDate"
Map DateType (Element Text)
dateElts <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
Element a -> Map DateType (Element a) -> Map DateType (Element a)
addDateElt forall a. Monoid a => a
mempty 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)
pDate (Text -> Element -> [Element]
getChildren Text
"date" Element
node)
let termNodes :: [Element]
termNodes = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> Element -> [Element]
getChildren Text
"term") (Text -> Element -> [Element]
getChildren Text
"terms" Element
node)
Map Text [(Term, Text)]
terms <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map Text [(Term, Text)]
-> Element -> ElementParser (Map Text [(Term, Text)])
parseTerm forall a. Monoid a => a
mempty [Element]
termNodes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Locale
{ localeLanguage :: Maybe Lang
localeLanguage = Maybe Lang
lang
, localePunctuationInQuote :: Maybe Bool
localePunctuationInQuote = (forall a. Eq a => a -> a -> Bool
== Text
"true") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Text -> Attributes -> Maybe Text
lookupAttribute Text
"punctuation-in-quote" Attributes
styleOpts
, localeLimitDayOrdinalsToDay1 :: Maybe Bool
localeLimitDayOrdinalsToDay1 = (forall a. Eq a => a -> a -> Bool
== Text
"true") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Text -> Attributes -> Maybe Text
lookupAttribute Text
"limit-day-ordinals-to-day-1" Attributes
styleOpts
, localeDate :: Map DateType (Element Text)
localeDate = Map DateType (Element Text)
dateElts
, localeTerms :: Map Text [(Term, Text)]
localeTerms = Map Text [(Term, Text)]
terms
}
parseTerm :: M.Map Text [(Term, Text)]
-> X.Element
-> ElementParser (M.Map Text [(Term, Text)])
parseTerm :: Map Text [(Term, Text)]
-> Element -> ElementParser (Map Text [(Term, Text)])
parseTerm Map Text [(Term, Text)]
m Element
node = do
let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
Text
name <- case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name" Attributes
attr of
Just Text
n -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
n
Maybe Text
Nothing -> forall a. String -> ElementParser a
parseFailure String
"Text node has no name attribute"
let single :: Text
single = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Element -> Text
getTextContent forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"single" Element
node
let multiple :: Text
multiple = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Element -> Text
getTextContent forall a b. (a -> b) -> a -> b
$ Text -> Element -> [Element]
getChildren Text
"multiple" Element
node
let txt :: Text
txt = Element -> Text
getTextContent Element
node
let form :: TermForm
form = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr of
Just Text
"short" -> TermForm
Short
Just Text
"verb" -> TermForm
Verb
Just Text
"verb-short" -> TermForm
VerbShort
Just Text
"symbol" -> TermForm
Symbol
Maybe Text
_ -> TermForm
Long
let gender :: Maybe TermGender
gender = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"gender" Attributes
attr of
Just Text
"masculine" -> forall a. a -> Maybe a
Just TermGender
Masculine
Just Text
"feminine" -> forall a. a -> Maybe a
Just TermGender
Feminine
Maybe Text
_ -> forall a. Maybe a
Nothing
let genderForm :: Maybe TermGender
genderForm = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"gender-form" Attributes
attr of
Just Text
"masculine" -> forall a. a -> Maybe a
Just TermGender
Masculine
Just Text
"feminine" -> forall a. a -> Maybe a
Just TermGender
Feminine
Maybe Text
_ -> forall a. Maybe a
Nothing
let match :: Maybe TermMatch
match = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"match" Attributes
attr of
Just Text
"last-digit" -> forall a. a -> Maybe a
Just TermMatch
LastDigit
Just Text
"last-two-digits" -> forall a. a -> Maybe a
Just TermMatch
LastTwoDigits
Just Text
"whole-number" -> forall a. a -> Maybe a
Just TermMatch
WholeNumber
Maybe Text
_ -> forall a. Maybe a
Nothing
let term :: Term
term = Term
{ termName :: Text
termName = Text
name
, termForm :: TermForm
termForm = TermForm
form
, termNumber :: Maybe TermNumber
termNumber = forall a. Maybe a
Nothing
, termGender :: Maybe TermGender
termGender = Maybe TermGender
gender
, termGenderForm :: Maybe TermGender
termGenderForm = Maybe TermGender
genderForm
, termMatch :: Maybe TermMatch
termMatch = Maybe TermMatch
match
}
let addToList :: a -> Maybe [a] -> Maybe [a]
addToList a
x Maybe [a]
Nothing = forall a. a -> Maybe a
Just [a
x]
addToList a
x (Just [a]
xs) = forall a. a -> Maybe a
Just (a
xforall a. a -> [a] -> [a]
:[a]
xs)
if Text -> Bool
T.null Text
single
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (forall {a}. a -> Maybe [a] -> Maybe [a]
addToList (Term
term, Text
txt)) (Term -> Text
termName Term
term) Map Text [(Term, Text)]
m
else do
let term_single :: Term
term_single = Term
term{ termNumber :: Maybe TermNumber
termNumber = forall a. a -> Maybe a
Just TermNumber
Singular }
let term_plural :: Term
term_plural = Term
term{ termNumber :: Maybe TermNumber
termNumber = forall a. a -> Maybe a
Just TermNumber
Plural }
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter
(forall {a}. a -> Maybe [a] -> Maybe [a]
addToList (Term
term_single, Text
single) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall {a}. a -> Maybe [a] -> Maybe [a]
addToList (Term
term_plural, Text
multiple)) (Term -> Text
termName Term
term) Map Text [(Term, Text)]
m
pDate :: X.Element -> ElementParser (Element a)
pDate :: forall a. Element -> ElementParser (Element a)
pDate Element
node = do
let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
let form :: Maybe Text
form = Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr
let var :: Variable
var = Text -> Variable
toVariable 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
let showDateParts :: Maybe ShowDateParts
showDateParts = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"date-parts" Attributes
attr of
Just Text
"year-month-day" -> forall a. a -> Maybe a
Just ShowDateParts
YearMonthDay
Just Text
"year-month" -> forall a. a -> Maybe a
Just ShowDateParts
YearMonth
Just Text
"year" -> forall a. a -> Maybe a
Just ShowDateParts
Year
Maybe Text
_ -> forall a. Maybe a
Nothing
[DP]
dps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> ElementParser DP
parseDatePartElement (Text -> Element -> [Element]
getChildren Text
"date-part" Element
node)
let dateType :: DateType
dateType = case Maybe Text
form of
Just Text
"numeric" -> DateType
LocalizedNumeric
Just Text
"text" -> DateType
LocalizedText
Maybe Text
_ -> DateType
NonLocalized
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
-> DateType -> Maybe ShowDateParts -> [DP] -> ElementType a
EDate Variable
var DateType
dateType Maybe ShowDateParts
showDateParts [DP]
dps) Formatting
formatting
parseDatePartElement :: X.Element -> ElementParser DP
parseDatePartElement :: Element -> ElementParser DP
parseDatePartElement Element
node = do
let attr :: Attributes
attr = Element -> Attributes
getAttributes Element
node
let formatting :: Formatting
formatting = Attributes -> Formatting
getFormatting Attributes
attr
let name :: DPName
name = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"name" Attributes
attr of
Just Text
"day" -> DPName
DPDay
Just Text
"month" -> DPName
DPMonth
Maybe Text
_ -> DPName
DPYear
let form :: DPForm
form = case Text -> Attributes -> Maybe Text
lookupAttribute Text
"form" Attributes
attr of
Just Text
"numeric" -> DPForm
DPNumeric
Just Text
"numeric-leading-zeros" -> DPForm
DPNumericLeadingZeros
Just Text
"ordinal" -> DPForm
DPOrdinal
Just Text
"long" -> DPForm
DPLong
Just Text
"short" -> DPForm
DPShort
Maybe Text
_ | DPName
name forall a. Eq a => a -> a -> Bool
== DPName
DPDay -> DPForm
DPNumeric
| Bool
otherwise -> DPForm
DPLong
let rangeDelim :: Text
rangeDelim = forall a. a -> Maybe a -> a
fromMaybe Text
"–" forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
lookupAttribute Text
"range-delimiter" Attributes
attr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DPName -> DPForm -> Text -> Formatting -> DP
DP DPName
name DPForm
form Text
rangeDelim Formatting
formatting