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