    {-# LANGUAGE PatternGuards #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.CSL.Parser
    -- Copyright   :  (c) Andrea Rossato
    -- License     :  BSD-style (see LICENSE)
    --
    -- Maintainer  :  Andrea Rossato <andrea.rossato@unitn.it>
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- The CS Language parsers
    --
    -----------------------------------------------------------------------------

    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

    -- | For mandatory attributes.
    xpAttrText :: String -> PU String
    xpAttrText n = xpAttr n xpText

    -- | For optional attributes.
    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

    -- | A pickler for interleaved elements.
    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

    -- | Read and parse a CSL style file into the internal style
    -- representation, the 'Style'.
    readCSLFile :: FilePath -> 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}