module Text.CSL.Parser where
import Paths_citeproc_hs ( getDataFileName )
import Text.CSL.Style
import Control.Monad ( unless )
import Data.Char ( isUpper, toUpper, toLower )
import Data.List ( elemIndex )
import Data.Maybe ( fromMaybe )
import System.Directory ( doesFileExist )
import Text.XML.HXT.Arrow hiding ( IfThen, when )
import Text.XML.HXT.Arrow.Pickle.Schema hiding ( Name )
import Text.XML.HXT.Arrow.Pickle.Xml
import qualified Text.XML.HXT.DOM.XmlNode as XN
import qualified Text.XML.HXT.RelaxNG as RNG
instance XmlPickler Layout where
xpickle = xpWrap (uncurry3 Layout, \(Layout f d e) -> (f,d,e)) $
xpIElem "layout" $
xpTriple xpickle xpDelimiter xpickle
instance XmlPickler Element where
xpickle = xpAlt tag ps
where
tag (Choose {}) = 0
tag (Macro {}) = 1
tag (Const {}) = 2
tag (PointLocator {}) = 3
tag (Variable {}) = 4
tag (Term {}) = 5
tag (Label {}) = 6
tag (Names {}) = 7
tag (ShortNames {}) = 8
tag (Substitute {}) = 9
tag (Group {}) = 10
tag (Number {}) = 11
tag (Date {}) = 12
ps = [ xpChoose
, xpMacro
, xpConst
, xpPointLocator
, xpVariable
, xpTerm
, xpLabel
, xpNames
, xpShortNames
, xpSubStitute
, xpGroup
, xpNumber
, xpDate
]
instance XmlPickler IfThen where
xpickle = xpWrap (uncurry3 IfThen, \(IfThen c m e) -> (c,m,e)) $
xpTriple xpickle xpickle xpickle
instance XmlPickler Condition where
xpickle = xpWrap ( \ ((t,v,n),(d,p,a,l)) ->
Condition (words t) (words v) (words n)
(words d) (words p) (words a) (words l),
\ (Condition t v n d p a l) ->
((unwords t,unwords v,unwords n)
,(unwords d,unwords p,unwords a,unwords l))) $
xpPair (xpTriple (xpAttrText' "type" )
(xpAttrText' "variable" )
(xpAttrText' "is-numeric" ))
(xp4Tuple (xpAttrText' "is-dates" )
(xpAttrText' "position" )
(xpAttrText' "disambiguate" )
(xpAttrText' "locator" ))
instance XmlPickler Formatting where
xpickle = xpWrap ( \(((p,s,ff),(fs,fv,fw)),(td,va,tc,d,q))
-> Formatting p s ff fs fv fw td va tc d q
, \(Formatting p s ff fs fv fw td va tc d q)
-> (((p,s,ff),(fs,fv,fw)),(td,va,tc,d,q))) $
xpPair (xpPair (xpTriple (xpAttrText' "prefix" )
(xpAttrText' "suffix" )
(xpAttrText' "font-family" ))
(xpTriple (xpAttrText' "font-style" )
(xpAttrText' "font-variant")
(xpAttrText' "font-weight" )))
(xp5Tuple (xpAttrText' "text-decoration")
(xpAttrText' "vertical-align" )
(xpAttrText' "text-case" )
(xpAttrText' "display" )
(xpAttrWithDefault False "quotes" xpickle))
instance XmlPickler Sort where
xpickle = xpAlt tag ps
where
readSort = read . flip (++) " \"\"" . toRead
tag (SortVariable {}) = 0
tag (SortMacro {}) = 1
ps = [ xpWrap ( \(v,s) -> SortVariable v (readSort s)
, \(SortVariable v s) -> (v,toShow $ show s)) $
xpElem "key" $
xpPair (xpAttrText "variable")
(xpAttrWithDefault "ascending" "sort" xpText)
, xpWrap ( \(v,s) -> SortMacro v (readSort s)
, \(SortMacro v s) -> (v,toShow $ show s)) $
xpElem "key" $
xpPair (xpAttrText "macro")
(xpAttrWithDefault "ascending" "sort" xpText)
]
instance XmlPickler Bool where
xpickle = xpWrap readable xpText
instance XmlPickler Form where
xpickle = xpWrap readable
(xpAttrWithDefault "long" "form" xpText)
instance XmlPickler NumericForm where
xpickle = xpWrap readable
(xpAttrWithDefault "numeric" "form" xpText)
instance XmlPickler Match where
xpickle = xpWrap readable
(xpAttrWithDefault "all" "match" xpText)
instance XmlPickler DatePart where
xpickle = xpWrap (uncurry3 DatePart, \(DatePart s f fm) -> (s,f,fm)) $
xpElem "date-part" $
xpTriple (xpAttrText "name")
(xpAttrWithDefault "long" "form" xpText)
xpickle
instance XmlPickler Name where
xpickle = xpAlt tag ps
where
tag (Name {}) = 0
tag (NameLabel {}) = 1
ps = [ xpWrap (uncurry4 Name, \(Name f fm nf d) -> (f,fm,nf,d)) $
xpElem "name" $ xp4Tuple xpickle xpickle xpickle xpDelimiter
, xpWrap (uncurry4 NameLabel, \(NameLabel f fm i p) -> (f,fm,i,p)) $
xpElem "label" $ xp4Tuple xpickle xpickle xpIncludePeriod xpPlural
]
instance XmlPickler NameFormatting where
xpickle = xpWrap ( \(a,d,ns,s,i) -> NameFormatting a d ns s i
, \(NameFormatting a d ns s i) -> (a,d,ns,s,i)) $
xp5Tuple (xpAttrText' "and" )
(xpAttrText' "delimiter-precedes-last")
(xpAttrText' "name-as-sort-order" )
(xpAttrText' "sort-separator" )
(xpAttrText' "initialize-with" )
instance XmlPickler CSInfo where
xpickle = xpWrap ( \ ((t,i,u),(a,c)) -> CSInfo t a c i u
, \ s -> ((csiTitle s, csiId s, csiUpdated s)
,(csiAuthor s, csiCategories s))) $
xpPair (xpTriple (get "title" )
(get "id" )
(get "updated"))
(xpPair (xpIElemWithDefault (CSAuthor "" "" "") "author" xpickle)
(xpDefault [] $ xpList $ xpIElem "category" xpickle))
where
get = flip xpIElem xpText
instance XmlPickler CSAuthor where
xpickle = xpWrap (uncurry3 CSAuthor, \(CSAuthor a b c) -> (a, b, c)) $
xpTriple (xpIElemWithDefault [] "name" xpText)
(xpIElemWithDefault [] "email" xpText)
(xpIElemWithDefault [] "uri" xpText)
instance XmlPickler CSCategory where
xpickle = xpWrap (uncurry3 CSCategory, \(CSCategory a b c) -> (a, b, c)) $
xpTriple (xpAttrText "term" )
(xpAttrText' "schema")
(xpAttrText' "label" )
xpStyle :: PU Style
xpStyle
= xpWrap ( \ ((sc,si,sl,l),(t,m,c,b)) -> Style sc si sl l t m c b
, \ (Style sc si sl l t m c b) -> ((sc,si,sl,l),(t,m,c,b))) $
xpIElem "style" $
xpPair (xp4Tuple (xpAttrText "class")
xpInfo
(xpAttrWithDefault "en" "xml:lang" xpText)
(xpAttrWithDefault "en-US" "default-locale" xpText))
(xp4Tuple (xpDefault [] xpTerms)
xpMacros
xpCitation
(xpOption xpBibliography))
xpInfo :: PU (Maybe CSInfo)
xpInfo = xpOption . xpIElem "info" $ xpickle
xpTerms :: PU [TermMap]
xpTerms
= xpIElem "terms" $ xpIElem "locale" $ xpList $ xpElem "term" $
xpPair (xpPair (xpAttrText "name") xpickle)
(xpChoice (xpWrap (\s -> (s,s), fst) xpText0)
(xpPair (xpIElem "single" $ xpText0)
(xpIElem "multiple" $ xpText0))
xpLift)
xpMacros :: PU [MacroMap]
xpMacros
= xpList $ xpIElem "macro" $
xpPair (xpAttrText "name") xpickle
xpCitation :: PU Citation
xpCitation
= xpWrap (uncurry3 Citation, \(Citation o s l) -> (o,s,l)) $
xpIElem "citation" $
xpTriple xpOptions xpSort xpickle
xpBibliography :: PU Bibliography
xpBibliography
= xpWrap (uncurry3 Bibliography, \(Bibliography o s l) -> (o,s,l)) $
xpIElem "bibliography" $
xpTriple xpOptions xpSort xpickle
xpOptions :: PU [Option]
xpOptions
= xpList $ xpIElem "option" $
xpPair (xpAttrText "name") (xpAttrText "value")
xpSort :: PU [Sort]
xpSort
= xpDefault [] $ xpElem "sort" $ xpList xpickle
xpChoose :: PU Element
xpChoose
= xpWrap (uncurry3 Choose, \(Choose b t e) -> (b,t,e)) $
xpElem "choose" $
xpTriple ( xpElem "if" xpickle)
(xpDefault [] $ xpList $ xpElem "else-if" xpickle)
(xpDefault [] $ xpElem "else" xpickle)
xpMacro :: PU Element
xpMacro
= xpWrap (uncurry3 Macro, \(Macro s f fm) -> (s,f,fm)) $
xpTextElem $ xpCommon "macro"
xpConst :: PU Element
xpConst
= xpWrap (uncurry Const, \(Const s fm) -> (s,fm)) $
xpTextElem $ xpPair (xpAttrText "value") xpickle
xpPointLocator :: PU Element
xpPointLocator
= xpWrap (uncurry3 PointLocator, \(PointLocator s f fm) -> (s,f,fm)) $
xpTextElem $ xpCommon "point-locator"
xpVariable :: PU Element
xpVariable
= xpWrap ( \((v,f,fm),d) -> Variable (words v) f fm d
, \(Variable v f fm d) -> ((unwords v,f,fm),d)) $
xpTextElem $ xpPair (xpCommon "variable") xpDelimiter
xpTerm :: PU Element
xpTerm
= xpWrap ( \((t,f,fm),i,p) -> Term t f fm i p
, \(Term t f fm i p) -> ((t,f,fm),i,p)) $
xpTextElem $ xpTriple (xpCommon "term") xpIncludePeriod xpPlural
xpNames :: PU Element
xpNames
= xpWrap ( \((a,n,fm),d,sb) -> Names (words a) n fm d sb
, \(Names a n fm d sb) -> ((unwords a,n,fm),d,sb)) $
xpElem "names" $ xpTriple names xpDelimiter xpickle
where names = xpTriple (xpAttrText "variable") xpName xpickle
xpName = xpChoice xpZero xpickle check
check l = if or $ map isName l then xpLift l else xpZero
xpShortNames :: PU Element
xpShortNames
= xpWrap ( \((a,fm),d) -> ShortNames (words a) fm d
, \(ShortNames a fm d) -> ((unwords a,fm),d)) $
xpElem "names" $ xpPair content xpDelimiter
where content = xpPair (xpAttrText "variable") xpickle
xpLabel :: PU Element
xpLabel
= xpWrap ( \(t,f,fm,i,p) -> Label t f fm i p
, \(Label s f fm i p) -> (s,f,fm,i,p)) $
xpElem "label" $
xp5Tuple (xpAttrText' "variable")
xpickle xpickle xpIncludePeriod xpPlural
xpSubStitute :: PU Element
xpSubStitute
= xpWrap (Substitute, \(Substitute es) -> es) $
xpElem "substitute" xpickle
xpGroup :: PU Element
xpGroup
= xpWrap ( \(fm,d,c,e) -> Group fm d c e
, \(Group fm d c e) -> (fm,d,c,e)) $
xpElem "group" $
xp4Tuple xpickle xpDelimiter (xpAttrText' "class") xpickle
xpNumber :: PU Element
xpNumber
= xpWrap (uncurry3 Number, \(Number s f fm) -> (s,f,fm)) $
xpElem "number" $ xpCommon "variable"
xpDate :: PU Element
xpDate
= xpWrap ( \((s,fm,dp),d) -> Date (words s) fm d dp
, \(Date s fm d dp) -> ((unwords s,fm,dp),d)) $
xpElem "date" $ xpPair (xpCommon "variable") xpDelimiter
xpTextElem :: PU a -> PU a
xpTextElem = xpElem "text"
xpDelimiter :: PU String
xpDelimiter = xpAttrText' "delimiter"
xpPlural :: PU Bool
xpPlural = xpAttrWithDefault True "plural" xpickle
xpIncludePeriod :: PU Bool
xpIncludePeriod = xpAttrWithDefault False "include-period" xpickle
xpCommon :: (XmlPickler b, XmlPickler c) => String -> PU (String,b,c)
xpCommon s = xpTriple (xpAttrText s) xpickle xpickle
xpAttrText :: String -> PU String
xpAttrText n = xpAttr n xpText
xpAttrText' :: String -> PU String
xpAttrText' n = xpAttrWithDefault [] n xpText
xpAttrWithDefault :: Eq a => a -> String -> PU a -> PU a
xpAttrWithDefault d n = xpDefault d . xpAttr n
xpIElemWithDefault :: Eq a => a -> String -> PU a -> PU a
xpIElemWithDefault d n = xpDefault d . xpIElem n
xpIElem :: String -> PU a -> PU a
xpIElem n pa
= PU { appPickle = ( \ (a, st) ->
let
st' = appPickle pa (a, emptySt)
in
addCont (XN.mkElement (mkName n) (attributes st') (contents st')) st
)
, appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)
, theSchema = scElem n (theSchema pa)
}
where
unpickleElement st
= do
let t = contents st
ns <- mapM XN.getElemName t
case elemIndex n (map qualifiedName ns) of
Nothing -> fail "element name does not match"
Just i -> do
let cs = XN.getChildren (t !! i)
al <- XN.getAttrl (t !! i)
res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}
return (Just res, st {contents = take i t ++ drop (i + 1) t})
readable :: (Read a, Show b) => (String -> a, b -> String)
readable = (read . toRead, toShow . show)
toShow :: String -> String
toShow = foldr g [] . f
where g x xs = if isUpper x then '-' : toLower x : xs else x : xs
f ( x:xs) = toLower x : xs
f [] = []
toRead :: String -> String
toRead [] = []
toRead (s:ss) = toUpper s : camel ss
where
camel x
| '-':y:ys <- x = toUpper y : camel ys
| '_':y:ys <- x = toUpper y : camel ys
| y:ys <- x = y : camel ys
| otherwise = []
readXmlFile :: PU a -> String -> IO a
readXmlFile xp f
= do
flip unless (error $ f ++ " file does not exist") =<< doesFileExist f
res <- runX ( readDocument [ (a_validate , v_0)
, (a_remove_whitespace, v_1)
, (a_trace , v_0)
, (a_preserve_comment , v_0)
] f
>>>
RNG.normalizeForRelaxValidation
>>>
xunpickleVal xp
)
case res of
[x] -> return x
_ -> error $ "error while reading file " ++ f
readCSLFile :: String -> IO Style
readCSLFile f = do
s <- readXmlFile xpStyle f
l <- getDataFileName ("locales/locales-" ++ styleLocale s ++ ".xml")
t <- readXmlFile xpTerms l
return s {csTerms = csTerms s ++ t}