-- ------------------------------------------------------------

{- |
   Module     : Text.XML.HXT.XSLT.Application
   Copyright  : Copyright (C) 2006 Tim Walkenhorst, Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
   Stability  : experimental
   Portability: portable

   The compilation functions for XSLT stylesheets

-}

-- ------------------------------------------------------------

module Text.XML.HXT.XSLT.Compilation 
    ( prepareXSLTDocument        -- :: XmlTree -> XmlTree
    , assembleStylesheet         -- :: XmlTree -> [CompiledStylesheet] -> CompiledStylesheet
    )
where

import           Control.Monad

import           Data.Maybe
import           Data.Either
import           Data.List
import qualified Data.Map as Map hiding (Map)
import           Data.Map(Map)

import           Text.ParserCombinators.Parsec.Prim	( runParser )

import           Text.XML.HXT.XSLT.Common
import           Text.XML.HXT.XSLT.Names
import           Text.XML.HXT.XSLT.CompiledStylesheet

-- No deep meaning just a shortcut notation for a *very* common expression...

infixl 9 ><

(><)	:: XmlNode n => (UriMapping -> a ) -> n -> a
f >< node
    = f $ getUriMap node

-- --------------------------

parseExpr :: UriMapping -> String -> Expr
parseExpr uris selectStr
    = either (error.show) id parseResult                               
    where
    parseResult = runParser parseXPath (toNsEnv . Map.toList $ uris) ("select-expr:"++selectStr) selectStr 

parseSelect :: UriMapping -> String -> SelectExpr
parseSelect uris
    = SelectExpr . parseExpr uris

parseTest :: UriMapping -> String -> TestExpr
parseTest uris
    = TestExpr . mkBoolExpr . parseExpr uris

parseStringExpr :: UriMapping -> String -> StringExpr
parseStringExpr uris
    = StringExpr . mkStringExpr . parseExpr uris

parseMatch :: UriMapping -> String -> MatchExpr
parseMatch uris str
    = if isMatchExpr expr
      then MatchExpr expr
      else error $ str ++ " is not a legal match-expression"
    where 
    expr = parseExpr uris str

-- --------------------------

parseAVT :: UriMapping -> String -> StringExpr
parseAVT uris str = 
    StringExpr $ concatExpr $ splitAVT str ""
  where

    splitAVT :: String -> String -> [Expr]
    splitAVT ""           acc = acc2lit acc
    splitAVT ('{':'{':xs) acc = splitAVT xs $ '{':acc
    splitAVT ('}':'}':xs) acc = splitAVT xs $ '}':acc
    splitAVT ('{':xs)     acc = let (body, rest) = span (`notElem` "{}") xs in
                                  if not (null rest) && head rest == '}'
                                    then acc2lit acc ++ parseExpr uris body : splitAVT (tail rest) ""
                                    else error $ "Unterminated expression " ++ xs ++ " in AVT."
    splitAVT ('}':_)      _   = error $ "deserted '}' in AVT."
    splitAVT (x:xs)       acc = splitAVT xs $ x:acc

    acc2lit :: String -> [Expr] 
    acc2lit ""  = []
    acc2lit acc = [mkLiteralExpr $ reverse acc]

-- --------------------------

-- extract ComputedQName from "name" and "namespace" AVTs of an xsl:element- or xsl-attribute-node
compileComputedQName :: XmlTree -> ComputedQName
compileComputedQName node =
    (CompQName><node) nameAVT nsAVT
  where 
    nameAVT  = parseAVT><node $ fetchAttribute node xsltName
    nsAVT    = parseAVT><node $ fetchAttributeWDefault node xsltNamespace ""

-- --------------------------

compileComposite :: [XmlTree] -> Template
compileComposite = TemplComposite . map (compileTemplate . return)

compileMessage :: XmlTree -> Template
compileMessage node = TemplMessage halt content
  where halt     = termAttr == "yes"
        termAttr = fetchAttributeWDefault node xsltTerminate "no"
        content  = compileTemplate (getChildren node)

compileForEach :: XmlTree -> Template
compileForEach node = TemplForEach expr sorting template
  where expr       = parseSelect><node $ fetchAttribute node xsltSelect
        sorting    = map compileSortKey srt
        template   = compileTemplate cnt
        (srt, cnt) = partition (isElemType xsltSort) $ getChildren node

compileChoose :: XmlTree -> Template
compileChoose node = TemplChoose whenParts
  where whenParts  = map compl children
        children   = filter isElem (getChildren node)
        compl node' = let elemName = fromJust $ getElemName node' in
                        if      equivQName elemName xsltWhen      then compileWhen node'
                        else if equivQName elemName xsltOtherwise then compileOtherwise node'
                        else error ("No elements of type " ++ show elemName ++ " allowed within xsl-choose template!")

compileWhen :: XmlTree -> When
compileWhen node = WhenPart expr $ compileTemplate $ getChildren node
  where expr     = parseTest><node $ fetchAttribute node xsltTest

-- Otherwise is treated as a when-Part with node-test "true()"
compileOtherwise :: XmlTree -> When
compileOtherwise node = WhenPart (TestExpr mkTrueExpr) $ compileTemplate $ getChildren node

-- "if" is treated as a convenience-form of choose with exactly one "when"-Part
compileIf :: XmlTree -> Template
compileIf = TemplChoose . return . compileWhen

-- -----------------------------------

parseExNames :: UriMapping -> String -> [ExName]
parseExNames urm = map (parseExName urm) . words

compileElement :: XmlTree -> Template
compileElement node = 
    TemplElement compQName Map.empty attribSets template
  where 
    compQName   = compileComputedQName node
    attribSets  = UsedAttribSets $ parseExNames><node
                  $ fetchAttributeWDefault node xsltUseAttributeSets ""
    template    = compileTemplate (getChildren node)

compileAttribute :: XmlTree -> Template
compileAttribute node = 
    TemplAttribute (compileComputedQName node) $ compileTemplate (getChildren node)

-- compiles xsl:text
compileText :: XmlTree -> Template
compileText = TemplText . collectTextnodes . getChildren

-- compiles textNode 
compileTextnode :: XmlTree -> Template
compileTextnode = TemplText . fromJust . getText

compileValueOf :: XmlTree -> Template
compileValueOf node = 
    TemplValueOf $ parseStringExpr><node $ fetchAttribute node xsltSelect

compileComment :: XmlTree -> Template
compileComment = TemplComment . compileTemplate . getChildren

compileProcInstr :: XmlTree -> Template
compileProcInstr node = 
   TemplProcInstr name content
  where
    name    = parseAVT><node  $ fetchAttribute node xsltName
    content = compileTemplate $ getChildren node

-- -----------------------------------

compileLiteralResultElement :: XmlTree -> Template
compileLiteralResultElement node =
    TemplElement compQName nsUris attribSets content
  where 
    nsUris             = extractAddUris node
    compQName          = LiteralQName   $ fromJust $ getElemName node
    attribSets         = UsedAttribSets $ parseExNames><node $ attrSetsStr
    attrSetsStr        = fetchAttributeWDefault node xsltUseAttributeSetsLRE ""
    content            = TemplComposite $ attributes ++ [template]
    attributes         = mapMaybe (compileLREAttribute><node) $ fromJust $ getAttrl node
    template           = compileTemplate (getChildren node)

compileLREAttribute :: UriMapping -> XmlTree -> Maybe Template
compileLREAttribute uris node = 
    if isSpecial 
      then Nothing
      else Just $ TemplAttribute (LiteralQName name) val  
  where 
    isSpecial = namespaceUri name `elem` [xsltUri, xmlnsNamespace]
    name      = fromJust $ getAttrName node
    val       = TemplValueOf $ parseAVT uris $ collectTextnodes $ getChildren node

-- -----------------------------------

compileApplyTempl :: XmlTree -> Template
compileApplyTempl node =
    TemplApply expr mode args sorting
  where
    expr    = liftM (parseSelect><node) $ tryFetchAttribute node xsltSelect
    mode    = liftM (parseExName><node) $ tryFetchAttribute node xsltMode
    args    = compileVariables          $ filter (isElemType xsltWithParam) $ par
    sorting =  map compileSortKey srt
    (srt,par) =  partition (isElemType xsltSort) $ getChildren node

compileApplyImports :: XmlTree -> Template
compileApplyImports _node
    = TemplApplyImports

compileCallTempl :: XmlTree -> Template
compileCallTempl node =
    TemplCall name args
  where
    name = parseExName><node $ fetchAttribute node xsltName
    args = compileVariables  $ filter (isElemType xsltWithParam) $ getChildren node

compileTemplVariable :: XmlTree -> Template
compileTemplVariable = TemplVariable . compileVariable

-- -----------------------------------

compileCopy :: XmlTree -> Template
compileCopy node =
    TemplCopy attribSets $ compileTemplate (getChildren node)
  where
    attribSets  = UsedAttribSets $ parseExNames><node $ fetchAttributeWDefault node xsltUseAttributeSets ""

compileCopyOf :: XmlTree -> Template
compileCopyOf node = TemplCopyOf $ parseExpr><node $ fetchAttribute node xsltSelect

-- -----------------------------------

compileTemplate :: [XmlTree] -> Template
compileTemplate [node]       = 
   if isElem node
   then let elemName = fromJust $ getElemName node in        
        if      equivQName elemName xsltMessage        then compileMessage       node
        else if equivQName elemName xsltForEach        then compileForEach       node
        else if equivQName elemName xsltChoose         then compileChoose        node   
        else if equivQName elemName xsltIf             then compileIf            node
        else if equivQName elemName xsltElement        then compileElement       node
        else if equivQName elemName xsltAttribute      then compileAttribute     node
        else if equivQName elemName xsltText           then compileText          node
        else if equivQName elemName xsltValueOf        then compileValueOf       node
        else if equivQName elemName xsltComment        then compileComment       node
        else if equivQName elemName xsltProcInstr      then compileProcInstr     node
        else if equivQName elemName xsltApplyTemplates then compileApplyTempl    node
        else if equivQName elemName xsltApplyImports   then compileApplyImports  node
        else if equivQName elemName xsltCallTemplate   then compileCallTempl     node
        else if equivQName elemName xsltVariable       then compileTemplVariable node
        else if equivQName elemName xsltCopy           then compileCopy          node
        else if equivQName elemName xsltCopyOf         then compileCopyOf        node

        -- no other xslt elements allowed here:
        else if namespaceUri elemName == xsltUri
        then error $ "xslt-element " ++ localPart elemName ++ " not allowed within this context."

        -- for now all other elements will be considered as Literal Result Elements
        else compileLiteralResultElement node

   else if isText node then compileTextnode node

   else
       error $ "Unsupported node-type in xslt sheet: " ++ show (getNode node)
compileTemplate list = compileComposite list


-- -----------------------------------
-- Assembling of the entire stylesheet

assembleStylesheet :: XmlTree -> [CompiledStylesheet] -> CompiledStylesheet
assembleStylesheet xslNode imports =
    CompStylesheet matchRules namedRules variables attsets strips aliases
  where 
    -- entire contents:
    (namedRules,    
     matchRules)          = assembleRules ruleElems importedMatchRules importedNamedRules
    variables             = assembleVariables varElems importedVariables
    attsets               = assembleAttrSets attsetElems importedAttribSets
    strips                = assembleStrips stripElems preserveElems importedStrips
    aliases               = assembleAliases nsAliasElems importedAliases

    -- element content:
    (nsAliasElems, _r5)   = partition (isElemType xsltNamespaceAlias) r4
    (ruleElems, r4)       = partition (isElemType xsltTemplate) r3
    (varElems, r3)        = partition (\node -> isElemType xsltVariable node || isElemType xsltParam node) r2
    (attsetElems, r2)     = partition (isElemType xsltAttributeSet) r1
    (preserveElems, r1)   = partition (isElemType xsltPreserveSpace) r0
    (stripElems, r0)      = partition (isElemType xsltStripSpace) $ getChildren xslNode

    -- imported stuff:
    importedAttribSets    = map getAttributeSets imports
    importedVariables     = map getVariables revImports
    importedNamedRules    = map getNamedRules revImports
    importedMatchRules    = concatMap getMatchRules revImports
    importedStrips        = concatMap getStrips revImports
    importedAliases       = map getAliases revImports
    revImports            = reverse imports

assembleRules :: [XmlTree] -> [MatchRule] -> [Map ExName NamedRule] -> (Map ExName NamedRule, [MatchRule])
assembleRules nodes importedMatches importedProcs =
    (resProcs, resMatches)
  where
  
  -- matches:  
    resMatches       = localMatches ++ importedMatches
    localMatches     = reverse $ sortBy cmp matches
    cmp rulA rulB    = compare (getRulePrio rulA) (getRulePrio rulB)

  -- procedures:
    resProcs         = Map.unions (localProcs:importedProcs)
    localProcs       = foldl ins Map.empty procs
    ins map' rule    = Map.insertWith (error $ "named-rule "++ show (getRuleName rule) ++" is already defined on this level")
                                     (getRuleName rule) rule map'

  -- compile all xsl:template's:
    (procs, matches) = catMaybes *** concat $ unzip $ map (compileRule importedMatches) nodes

assembleVariables :: [XmlTree] -> [(Map ExName Variable)] -> (Map ExName Variable)       
assembleVariables varElems = Map.unions . (compileVariables varElems:)

assembleAttrSets :: [XmlTree] -> [Map ExName [AttributeSet]] -> Map ExName [AttributeSet]
assembleAttrSets attsetElems =
    foldr (Map.unionWith (++)) localAttribSets
  where
    localAttribSets       = foldr insertAs Map.empty
                            $ map compileAttributeSet attsetElems
    insertAs as@(AttribSet name _ _) = Map.insertWith (++) name [as]

assembleStrips :: [XmlTree] -> [XmlTree]-> [Strips] -> [Strips]
assembleStrips stripElems preserveElems =
    (localStrips :)
  where
    localStrips = feedStrips (concatMap compileStrips stripElems)
                  $ feedPreserves (concatMap compilePreserves preserveElems)
                  $ Map.empty

assembleAliases :: [XmlTree] -> [NSAliasing] -> NSAliasing
assembleAliases nsAliasElems =
    Map.unions . (localAliases:)
  where
    localAliases          = foldr addAlias' Map.empty nsAliasElems
    addAlias' node        = uncurry (addAlias><node) $ compileAlias node

-- -----------------------------------

-- compile a rule from an xsl:template element.
-- The resulting rule can either be a one or more match rule or a named rule, or both.
-- The first argument is needed for xsl:apply-imports and contains
-- a list of all subsequently imported rules
compileRule :: [MatchRule] -> XmlTree -> (Maybe NamedRule, [MatchRule])
compileRule imports node =

    if isNothing match && isNothing name 
    then error "Error: Bogus rule (xsl:template) with neither match nor name attribute is illegal"

    else if isJust mode && isNothing match 
    then error "Error: Bogus mode attribute on none-match rule is illegal"

    else if isJust priority && isNothing match 
    then error "Error: Bogus priority attribute on none-match rule is illegal"

    else 
      (
        liftM (\n -> NamRule n params template) name
      , concat $ maybeToList $ liftM (assembleMatchRule priority mode imports params template) match
      ) 

  where
    match      = liftM (parseMatch><node)  $ tryFetchAttribute node xsltMatch
    name       = liftM (parseExName><node) $ tryFetchAttribute node xsltName
    priority   = liftM read                $ tryFetchAttribute node xsltPriority
    mode       = liftM (parseExName><node) $ tryFetchAttribute node xsltMode
    template   = compileTemplate content
    params     = map compileVariable paramsXml
    (paramsXml, content) =
                  partition (isElemType xsltParam) $ getChildren node

assembleMatchRule :: Maybe Float -> Maybe ExName -> [MatchRule] -> [Variable] -> Template ->  MatchExpr -> [MatchRule]
assembleMatchRule pri m imp par tmpl mtch@(MatchExpr expr) =
    if isJust pri
    then return $ MatRule mtch (fromJust pri) m imp par tmpl
    else map expand $ splitMatchByPrio expr
  where 
    expand (pri', mtch') = MatRule (MatchExpr mtch') pri' m imp par tmpl

-- -----------------------------------

compileVariables :: [XmlTree] -> Map ExName Variable
compileVariables nodes =
    foldl insertVar Map.empty $ varList
  where
    varList               = map compileVariable $ nodes
    insertVar map' var    = Map.insertWith (error $ "parameter or variable "++ show (getVarName var) ++" is already defined on this level")
                                           (getVarName var) var map'

compileVariable :: XmlTree -> Variable
compileVariable node =
    MkVar modus name exprOrRtf
  where 
    modus     = isElemType xsltParam node
    name      = parseExName><node $ fetchAttribute node xsltName
    exprOrRtf = if hasAttribute node xsltSelect || null (getChildren node)
                then Left $ parseExpr><node $ fetchAttributeWDefault node xsltSelect "''"
                else Right $ compileTemplate $ getChildren node

-- -----------------------------------

compileAttributeSet :: XmlTree -> AttributeSet
compileAttributeSet node =
    AttribSet name usedsets template
  where
    name     = parseExName><node $ fetchAttribute node xsltName
    usedsets = UsedAttribSets    $ parseExNames><node $ fetchAttributeWDefault node xsltUseAttributeSets ""
    template = compileTemplate   $ filter (isElemType xsltAttribute) $ getChildren node

-- -----------------------------------

compileSortKey :: XmlTree -> SortKey
compileSortKey node =
    SortK expr dataType order
  where
    expr     = parseStringExpr><node $ fetchAttributeWDefault node xsltSelect "."
    dataType = parseAVT><node        $ fetchAttributeWDefault node xsltDataType "text"
    order    = parseAVT><node        $ fetchAttributeWDefault node xsltOrder "ascending"

-- -----------------------------------

parseNTests :: UriMapping -> String -> [NTest]
parseNTests uris = map (parseNTest uris) . words

compileStrips,compilePreserves :: XmlTree -> [NTest]
compileStrips node = parseNTests><node $ fetchAttribute node xsltElements
compilePreserves = compileStrips

-- -----------------------------------

compileAlias :: XmlTree -> (String, String)
compileAlias node = 
  (fetchAttribute node xsltStylesheetPrefix, fetchAttribute node xsltResultPrefix)

-- -----------------------------------
-- Document level preprocessing

prepareXSLTDocument	:: XmlTree -> XmlTree
prepareXSLTDocument	= expandExEx . expandNSDecls . stripStylesheet . removePiCmt

removePiCmt :: XmlTree -> XmlTree
removePiCmt = fromJustErr "XSLT: No root element" . filterTree (\n -> not (isPi n) && not (isCmt n))

-- Expand exclude-result-prefixes AND extension-element-prefixes

expandExEx :: XmlTree -> XmlTree
expandExEx = mapTreeCtx expandExExElem ([xsltUri,xmlNamespace,xmlnsNamespace],[])

expandExExElem :: ([String], [String]) -> XNode -> (([String], [String]), XNode)
expandExExElem c@(excl, ext) node
  | isElem node = ((exclAcc, extAcc), nodeNew)
  | otherwise   = (c, node)
  where
    nodeNew    = setAttribute nameExcl (unwords exclAcc) $ setAttribute nameExt (unwords extAcc) node
    exclAcc    = exclNew ++ excl
    extAcc     = extNew  ++ ext
    exclNew    = extNew  ++ (parsePreList><node $ fetchAttributeWDefault node nameExcl "")
    extNew     =             parsePreList><node $ fetchAttributeWDefault node nameExt  ""
    (nameExcl,
     nameExt)  = if (namespaceUri $ fromJust $ getElemName node) == xsltUri
                   then (xsltExlcudeResultPrefixes   , xsltExtensionElementPrefixes   )
                   else (xsltExlcudeResultPrefixesLRE, xsltExtensionElementPrefixesLRE)

-- parse a prefix list, create a list of uris: 
-- "pre1 pre2 pre3" -> ["pre1.uri","pre2.uri","pre3.uri"]

parsePreList :: UriMapping -> String -> [String]
parsePreList uris = map (lookupPrefix uris) . words

-- -----------------------------------
-- Extraction of contextual Information from an XML-Node

extractAddUris :: XmlTree -> UriMapping
extractAddUris node = 
    (Map.filter (`notElem` exclUris))><node
  where
    exclUris = words $ fetchAttributeWDefault node xsltExlcudeResultPrefixesLRE ""

-- -----------------------------------