module XsltFunctions
where

import HdomParser
import Data.List
import Data.Maybe

import Text.ParserCombinators.Parsec
    ( parse )

import XPath
import XPathFct
    ( xstring, xnumber )

import XsltDataTypes
import XsltParserFunctions
-- -----------------------------------------------------------------------------

-- |
-- Vorbereiten eines Stylesheets
prepareXslFile :: XmlTrees -> XmlTrees
prepareXslFile ts
    = propagateNamespaces $$ getChildren $$ canonicalizeAllNodes $$ ts

-- --------------------------------------------------------------------------
-- |
-- read and replace xsl:import elements
replaceImp :: Int -> [String] -> String -> XmlStateFilter state
replaceImp impStep impT baseUri t
    = (processChildrenM (replImp impStep impT baseUri)) t

replImp :: Int -> [String] -> String -> XmlStateFilter state
replImp impStep impT baseUri t
    = do
      res <- (
                (replImp' impStep impT baseUri)
                `whenM`
                (isTag "xsl:stylesheet")
            ) t
      return res

replImp' :: Int -> [String] -> String -> XmlStateFilter state
replImp' impStep impT baseUri t
    = (processChildrenM (replaceImport impStep impT baseUri)
      `whenM`
      (getChildren .> isTag "xsl:import")
      ) t

replaceImport :: Int -> [String] -> String -> XmlStateFilter state
replaceImport importStep impT baseUri f
    = do
      res <- (
                (addImport importStep baseUri)
                `whenM`
                (isTag "xsl:import")
            ) f
      return res

      where
      addImport :: Int -> String -> XmlStateFilter state
      addImport impStep base ft
        = do
          t2 <- getWellformedDoc (makeNewRoot baseUri (valueOf "href" ft))
          t3 <- replaceInc (impStep + 1) ( impT ++ [(valueOf "href" ft)]) base $$< t2
          t4 <- replaceImp (impStep + 1) ( impT ++ [(valueOf "href" ft)]) base $$< t3

          return [ mkXTagTree
                    ("xsl:import_XSLT")
                    [ mkXAttrTree "source" [mkXTextTree ( head $ reverse impT) ]
                     ,mkXAttrTree "impStep" [mkXTextTree (show impStep)]
                    ]
                    ((getChildren .> isTag "xsl:stylesheet" .> getChildren) $$ t4)
                 ]

      makeNewRoot base src = (newRoot (xattr "source" (base ++ src)))
-- --------------------------------------------------------------------------
-- |
-- read and replace xsl:include elements
replaceInc :: Int -> [String] -> String -> XmlStateFilter state
replaceInc impStep impT baseUri t
    = (processChildrenM (replInc impStep impT baseUri)) t

replInc :: Int -> [String] -> String -> XmlStateFilter state
replInc impStep impT baseUri t
    = do
      res <- (
                (replInc' impStep impT baseUri)
                `whenM`
                (isTag "xsl:stylesheet")
            ) t
      return res

replInc' :: Int -> [String] -> String -> XmlStateFilter state
replInc' impStep impT baseUri t
    = (processChildrenM (replaceInclude impStep impT baseUri)
      `whenM`
      (getChildren .> isTag "xsl:include")
      ) t

replaceInclude :: Int -> [String] -> String -> XmlStateFilter state
replaceInclude importStep impT baseUri f
    = do
      res <- (
                (addIncl importStep baseUri)
                `whenM`
                (isTag "xsl:include")
            ) f
      return res

      where
      addIncl :: Int -> String -> XmlStateFilter state
      addIncl impStep base ft
        = do
          t2 <- getWellformedDoc (makeNewRoot baseUri (valueOf "href" ft))
          t3 <- replaceInc (impStep + 1) ( impT ++ [(valueOf "href" ft)]) base $$< t2
          t4 <- replaceImp (impStep + 1) ( impT ++ [(valueOf "href" ft)]) base $$< t3

          return ((getChildren .> isTag "xsl:stylesheet" .> getChildren) $$ t4)

      makeNewRoot base src = (newRoot (xattr "source" (base ++ src)))

-- --------------------------------------------------------------------------
-- |
-- adds import precedence to all read parts in xsl:import
makeImportPriorities :: XmlStateFilter state
makeImportPriorities t
    = liftMf ( mIP ) t

mIP :: XmlFilter
mIP t
    = (processChildren (gs `when` (isTag "xsl:stylesheet"))) t

gs :: XmlFilter
gs t@(NTree n _)
    = [mkNode n (concat $ addPriAtts 0 $ getSortedChildList t)]

addPriAtts :: Int -> [XmlTrees] -> [XmlTrees]
addPriAtts _ []         = []
addPriAtts pri (h:t)    = [addPriAtt pri $$ h] ++ addPriAtts (pri + 1) t
      
addPriAtt :: Int -> XmlFilter
addPriAtt pri t
    = (
        (addAttr "xsl:pri" (show pri))
        `when`
        (isXTag)
      ) t

getSortedChildList :: XmlTree -> [XmlTrees]
getSortedChildList t
    | null imports  = [notImports]
    | otherwise     = (getSortedChildList $$ imports) ++ [notImports]
      where
        imports     = (getChildren .> isImport) t
        notImports  = (getChildren .> neg isImport) t

isImport :: XmlFilter
isImport t
    = (isTag "xsl:import_XSLT") t
    
deleteIncludeTags :: XmlStateFilter state
deleteIncludeTags t
    = liftMf (delIncludeTags) t

delIncludeTags :: XmlFilter
delIncludeTags t
    = (processChildren (getChildren `when` isInclude)) t

isInclude :: XmlFilter
isInclude t
    = (isTag "xsl:include_AE") t

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




-- -----------------------------------------------------------------------------
-- built-in Rule for root node and other element nodes
-- defined in XSLT section 5.8, Built-in Template Rules
builtInRule :: XsltMatchRules
builtInRule         = (MRules [(XsltWildcard Child [], builtInRuleDscr), (XsltRoot, builtInRuleDscr)])
builtInRuleDscr :: XsltRuleDescr
builtInRuleDscr
    = RD {
         body           = (RulePriList 
                              [
                               (initialPriority
                               ,[NT (NTree (XTag QN{namePrefix="",localPart="RuleDescr",namespaceUri=""} []) [NTree (XTag QN{namePrefix="xsl",localPart="apply-templates",namespaceUri="http://www.w3.org/1999/XSL/Transform"} []) []]) [] [] []], (mkNSName "" ""))]
                               )
         ,parentRules   = emptyMRule
         ,ancestorRules = emptyMRule
         }

-- built-in Rule for text nodes and attribute nodes
-- defined in XSLT section 5.8, Built-in Template Rules
builtInRuleTxt :: XsltMatchRules
builtInRuleTxt      = (MRules [((XsltWildcard Child []), builtInRuleDscrTxt)])
builtInRuleDscrTxt :: XsltRuleDescr
builtInRuleDscrTxt
    = RD {
         body            = (RulePriList [(initialPriority, [NT (NTree (XTag QN{namePrefix="",localPart="RuleDescr",namespaceUri=""} []) [NTree (XTag QN{namePrefix="xsl",localPart="value-of",namespaceUri="http://www.w3.org/1999/XSL/Transform"} [NTree (XAttr QN{namePrefix="",localPart="select",namespaceUri=""}) [NTree (XText ".") []]]) []]) [] [] []], (mkNSName "" ""))])
         ,parentRules     = emptyMRule
         ,ancestorRules   = emptyMRule
         }

-- -----------------------------------------------------------------------------
getXslAttribute :: String -> XsltStat -> String
getXslAttribute an xsltStat
    = valueOf an $ subtreeNT $ currRuleNode xsltStat


-- -----------------------------------------------------------------------------
-- |
-- adds variable to list of variables
-- if first argument is true existing variables in list with same name
-- are replaced
addVars :: Bool ->  XsltVarTab -> String -> XPathValue -> XsltVarTab
addVars replaceV vars varName varValue
    = addVar replaceV (mkNSName "" varName , varValue) vars

addVar :: Bool -> XsltVar -> XsltVarTab -> XsltVarTab
addVar replaceV newVar@(varName,_) vars
    | replaceV
        = case (lookup varName vars) of
            Nothing -> vars ++ [newVar]
            Just value -> (delete (varName,value) vars) ++ [newVar]
    | otherwise
        = case (lookup varName vars) of
            Nothing -> vars ++ [newVar]
            Just _ -> vars


-- |
-- filters nodes with a specific namePrefix and localPart
-- in a navigable tree
-- by now only for xslt-elements
getExprNodes :: XsltData -> NavXmlTree -> String -> [String] -> NavXmlTrees
getExprNodes xsltData nt lp npl = concat $ map (getExprNodes' xsltData nt lp) npl

getExprNodes' :: XsltData -> NavXmlTree -> String -> String -> NavXmlTrees
getExprNodes' xsltData nt lp np
    = xPValue2NavXmlTrees
        $ evalExpr
            (convertXsltDataToXPathEnv xsltData)
            (1, 1, nt)
            (PathExpr Nothing (Just (LocPath Rel [Step Child (NameTest QN
                                {namePrefix=np
                                ,localPart=lp
                                ,namespaceUri="http://www.w3.org/1999/XSL/Transform"
                                }
                              ) []])))
            (XPVNode [nt])


-- --------------------------
-- Functions for procElement
-- |
-- test if attribute-value is an Attribute Value Template
isAVT :: String -> Bool
isAVT avt = ((head avt) == '{' && (last avt) == '}')

mkElemName :: XsltData -> XsltStat -> String -> String
mkElemName xsltData xsltStat elName
    | isAVT elName
        = xPathVal2String $ evalXPExpr xsltData (tail $ init elName) (1,1, (currNode xsltStat))
    | otherwise
        = elName
-- --------------------------

-- |
-- filter for navigable trees
-- gets a list of navtrees and list of steppatterns
-- returns navtrees where root fits patterns
filterPatternNT :: [XsltStepList] -> [NavXmlTree] -> [NavXmlTree]
filterPatternNT stepLists ntl = filter (isNodeOfMatch stepLists) ntl

-- returns true if node fits match
isNodeOfMatch :: [XsltStepList] -> NavXmlTree -> Bool
isNodeOfMatch stepLists nt = or $ map (isNodeOfStep nt) stepLists

-- returns true if node fits patternlist
isNodeOfStep :: NavXmlTree -> XsltStepList -> Bool
isNodeOfStep nt (StepList(firstStep:[]))
    = isRightStep' (dataNT nt) firstStep

isNodeOfStep nt (StepList(XsltParent:nextSteps))
    = not $ null $ filterPatternNT [StepList nextSteps] (parentAxis nt)

isNodeOfStep nt (StepList(XsltAncestor:nextSteps))
    = not $ null $ filterPatternNT [StepList nextSteps] (ancestorAxis nt)

isNodeOfStep nt (StepList(firstStep:nextSteps))
    | (isRightStep' (dataNT nt) firstStep)
        = not $ null $ filterPatternNT [StepList nextSteps] [nt]
    | otherwise
        = False

isNodeOfStep _ _
    = False

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


getNavTree :: String -> XmlTree -> [NavXmlTree]
getNavTree expr t = map ntree (getXPath expr t)

-- |
-- call to xpath funktion evalExpr
-- with prior replacement of variables in expression
evalXPValExpr :: XsltData -> String -> (Int, Int, NavTree XNode) -> XPathValue
evalXPValExpr xsltData exprStr cont
    | (head exprStr) == '$'
    = evalXPExpr xsltData
                 (xPValue2String $ evalXPExpr xsltData exprStr cont) 
                 cont
    | otherwise
    = evalXPExpr xsltData exprStr cont

-- |
-- call to xpath funktion evalExpr
evalXPExpr :: XsltData -> String -> (Int, Int, NavTree XNode) -> XPathValue
evalXPExpr xsltData exprStr cont@(_,_,ns)
        = case (parse parseXPath "" exprStr) of
          Left parseError
	      -> XPVError ("Syntax error in XPath expression " ++ show exprStr ++ ": " ++ show parseError)
          Right xpExpr -> evalXP xpExprNS
            where
              vars        = convertXsltDataToXPathEnv xsltData
              xpExprNS    = propagatExpr xpExpr
              evalXP xpe  = evalExpr vars cont xpe (XPVNode [ns])
            
getXsltData ::  XsltStat -> XsltEnv -> XsltDataType -> XsltData
getXsltData xsltStat xsltEnv XsltVar
    = (
      (localVars xsltStat) ++ (globalVars xsltEnv)
      ,(keyTable xsltEnv)
      )
getXsltData _ xsltEnv XsltGlobVar
    = (
      (globalVars xsltEnv)
      ,(keyTable xsltEnv)
      )
getXsltData xsltStat xsltEnv XsltPara
    = (
      (localParam xsltStat) ++ (globalParam xsltEnv)
      ,(keyTable xsltEnv)
      )
getXsltData _ xsltEnv XsltGlobPara
    = (
      (globalParam xsltEnv)
      ,(keyTable xsltEnv)
      )
getXsltData xsltStat xsltEnv XsltAll
    = (
      (localVars xsltStat)
         ++ (globalVars xsltEnv)
         ++ (localParam xsltStat)
         ++ (globalParam xsltEnv)
      ,(keyTable xsltEnv)
      )

getXsltVars ::  XsltStat -> XsltEnv -> XsltDataType -> XsltVarTab
getXsltVars xsltStat xsltEnv _
    = (localParam xsltStat)
        ++ (globalParam xsltEnv)
        ++ (localVars xsltStat)
        ++ (globalVars xsltEnv)

-- bis in XPath die Env auf QName umgestellt ist wird diese Fkt zum konvertiren genutzt
convertXsltDataToXPathEnv :: XsltData -> Env
convertXsltDataToXPathEnv dat
    = (
      concat $ map mkVarFromXsltVar $ fst dat
      ,snd dat
      )

mkVarFromXsltVar :: XsltVar -> VarTab
mkVarFromXsltVar (qn, val)
    = [(((namePrefix qn) ,(localPart qn)),val)]


-- |
-- main function to find the right named rules
findNameRule :: XsltNameRules -> QName -> NavXmlTree
findNameRule (NRules rl) qn
    = getNRuleNavTree $ filter (isRightNameRule qn) rl

isRightNameRule :: QName -> (QName, Float, [NavXmlTree]) -> Bool
isRightNameRule qn (qnr, _, _)
    = (localPart qn) == (localPart qnr)

-- |
-- main function to find the right rules (match)
findMatchRule :: XsltEnv -> XsltStat -> XsltResult -> NavXmlTree
findMatchRule xsltEnv xsltStat xsltRes
    | isEmptyRulePriList foundRules
    = getBuildInRule (dataNT $ currNode xsltStat) (mode xsltStat)
    | otherwise
    = selectRightRuleBody xsltStat foundRules
      where
        foundRules = findRules xsltEnv xsltStat xsltRes

isEmptyRulePriList :: XsltRulePriList -> Bool
isEmptyRulePriList (RulePriList []) = True
isEmptyRulePriList _                = False

-- |
-- selects the right rule by priority and import precedence
selectRightRuleBody :: XsltStat -> XsltRulePriList -> NavXmlTree
selectRightRuleBody _ (RulePriList [])
    = ntree emptyRoot
selectRightRuleBody xsltStat (RulePriList rpl)
    = rplNavTree $ sortRulePriList $ selMode (mode xsltStat) rpl

-- |
-- sort rules by priority
sortRulePriList :: XsltRulePriList -> XsltRulePriList
sortRulePriList (RulePriList [])    = (RulePriList [])
sortRulePriList (RulePriList [rp])  = (RulePriList [rp])
sortRulePriList (RulePriList rpl)   = (RulePriList (sortBy cmpRulePriList rpl))

-- |
-- compares the import precedence
cmpRulePriList :: (Priority, [NavXmlTree], Mode) -> (Priority, [NavXmlTree], Mode) -> Ordering
cmpRulePriList (p1,_,_) (p2,_,_)
    | (importPri p1) == (importPri p2)  = cmpRulePriList' p1 p2
    | (importPri p1) < (importPri p2)   = GT
    | (importPri p1) > (importPri p2)   = LT
cmpRulePriList _ _                      = LT

-- |
-- compares the priority
cmpRulePriList' :: Priority -> Priority -> Ordering
cmpRulePriList' p1 p2
    | (priority p1) == (priority p2)    = cmpRulePriList'' p1 p2
    | (priority p1) < (priority p2)     = GT
    | (priority p1) > (priority p2)     = LT
cmpRulePriList' _ _                     = LT

-- |
-- compares the default priority
cmpRulePriList'' :: Priority -> Priority -> Ordering
cmpRulePriList'' p1 p2
    | (defPri p1) == (defPri p2)        = EQ
    | (defPri p1) < (defPri p2)         = GT
    | (defPri p1) > (defPri p2)         = LT
cmpRulePriList'' _ _                    = LT

selMode :: QName -> [(Priority, [NavXmlTree], QName)] -> XsltRulePriList
selMode m rules  = RulePriList (filter (isOfMode m) rules)

isOfMode :: QName -> (Priority, [NavXmlTree], QName) -> Bool
isOfMode m (_, (_:_), rm)   = (localPart m) == (localPart rm)
isOfMode _ (_,[],_)         = False

getBuildInRule :: XNode -> QName -> NavXmlTree
getBuildInRule (XText _) _
    = getMRuleNavTree builtInRuleTxt
getBuildInRule (XAttr _) _
    = getMRuleNavTree builtInRuleTxt
getBuildInRule (XTag _ _) m
    | localPart m == ""
    = getMRuleNavTree builtInRule
    | otherwise
    = getMRuleNavTree $ getBuiltInRuleMode m
getBuildInRule _ _
    = ntree emptyRoot

-- built-in Rule for root node and other element nodes with mode-attribute
-- defined in XSLT section 5.8, Built-in Template Rules
getBuiltInRuleMode :: QName -> XsltMatchRules
getBuiltInRuleMode m
    | localPart m == ""     = builtInRule
    | otherwise             = (MRules [(XsltWildcard Child [], rd),(XsltRoot, rd)])
      where
        rd = RD {
                body          = (RulePriList [(initialPriority
                                               , [ntree $ head $ propagateNamespaces $ head appTag]
                                               , m)])
                ,parentRules  = emptyMRule
                ,ancestorRules= emptyMRule
                }
        appTag = addAttr "mode" (localPart m) $ mkXTagTree "xsl:apply-templates" [] []



findRules :: XsltEnv -> XsltStat -> XsltResult -> XsltRulePriList
findRules xsltEnv xsltStat xsltRes
    | null a    = getRules rulesForStep
    | otherwise =   (checkParents xsltEnv xsltStat xsltRes rulesForStep)
                    +.+ (checkAncestors xsltEnv xsltStat xsltRes rulesForStep)
                    +.+ (getRules rulesForStep)
      where
        (NT (NTree _ _) a _ _) = currNode xsltStat
        rulesForStep = checkStep (matchRules xsltEnv) xsltStat

checkParents :: XsltEnv -> XsltStat -> XsltResult -> [(XsltStep, XsltRuleDescr)] -> XsltRulePriList
checkParents xsltEnv xsltStat xsltRes rules
    = findRules
        (xsltEnv {matchRules = (parentsOf rules)})
        (xsltStat {currNode = head $ parentAxis $ currNode xsltStat})
        xsltRes

checkAncestors :: XsltEnv -> XsltStat -> XsltResult -> [(XsltStep, XsltRuleDescr)] -> XsltRulePriList
checkAncestors xsltEnv xsltStat xsltRes rules
    = findRules
        (xsltEnv {matchRules = (ancestorOf rules)})
        (xsltStat {currNode = head $ parentAxis $ currNode xsltStat})
        xsltRes

getRules :: [(XsltStep, XsltRuleDescr)] -> XsltRulePriList
getRules [] = (RulePriList [])
getRules rl = foldl1 (+.+) (map getBody rl)

parentsOf :: [(XsltStep, XsltRuleDescr)] -> XsltMatchRules
parentsOf [] = (MRules [])
parentsOf rl = concRules (map getParentRules rl)

ancestorOf :: [(XsltStep, XsltRuleDescr)] -> XsltMatchRules
ancestorOf [] = (MRules [])
ancestorOf rl = concRules (map getAncestorRules rl)


checkStep :: XsltMatchRules -> XsltStat -> [(XsltStep, XsltRuleDescr)]
checkStep (MRules rules) xsltStat
    | null rules = []
    | otherwise  = checkPredExpr xsltStat $ isRightStep (dataNT $ currNode xsltStat) rules

checkPredExpr :: XsltStat -> [(XsltStep, XsltRuleDescr)] -> [(XsltStep, XsltRuleDescr)]
checkPredExpr xsltStat rl@(_:_) = filter (checkPredExpr' xsltStat) rl
checkPredExpr _ []              = []


checkPredExpr' :: XsltStat -> (XsltStep, XsltRuleDescr) -> Bool
checkPredExpr' _        ((XsltTagName _ _ []),_)
    = True
checkPredExpr' _        ((XsltWildcard _ []),_)
    = True
checkPredExpr' xsltStat ((XsltWildcard coa (predExpr:_)),_)
    = isInList (currNode xsltStat) (PathExpr Nothing (Just (LocPath Rel [Step coa (NameTest QN{namePrefix="",localPart="*",namespaceUri=""}) [predExpr]])))
checkPredExpr' xsltStat ((XsltTagName coa nTest (predExpr:_)),_)
    = isInList (currNode xsltStat) (PathExpr Nothing (Just (LocPath Rel [Step coa nTest [predExpr]])))
checkPredExpr' _        _                           = False

isInList :: NavXmlTree -> Expr -> Bool
isInList currentNode pathExpr
    | null parentList   = False
    | otherwise         = elem currentNode
                               $ xPValue2NavXmlTrees
                               $ evalExpr ([],[]) (1, 1, nt) pathExpr (XPVNode [nt])
      where
        nt          = head parentList 
        parentList  = parentAxis currentNode


isRightStep :: XNode -> [(XsltStep, XsltRuleDescr)] -> [(XsltStep, XsltRuleDescr)]
isRightStep _ []    = []
isRightStep xn rl   = filter (isRightStep2 xn) rl

isRightStep2 :: XNode -> (XsltStep, XsltRuleDescr) -> Bool
isRightStep2 xn (step,_)    = isRightStep' xn step

isRightStep'      :: XNode -> XsltStep -> Bool
isRightStep' (XText _) step     = stepIsOfText step
isRightStep' (XTag qn _) step   = stepIsOfTag step (localPart qn)
isRightStep' (XPi _ _) step     = stepIsOfPi step
isRightStep' (XCmt _) step      = stepIsOfCmt step
isRightStep' (XAttr qn) step    = stepIsOfAttr step (localPart qn)
isRightStep' _ _                = False

stepIsOfText :: XsltStep -> Bool
stepIsOfText (XsltTagName _ (TypeTest XPTextNode) _)    = True
stepIsOfText _                                          = False

stepIsOfTag :: XsltStep -> String -> Bool
stepIsOfTag (XsltTagName _ (NameTest qn) _) n           = (localPart qn) == n
stepIsOfTag (XsltTagName _ (TypeTest XPNode) _) _       = True
stepIsOfTag (XsltWildcard Child _) _                    = True
stepIsOfTag _ _                                         = False

stepIsOfPi :: XsltStep -> Bool
stepIsOfPi (XsltTagName _ (PI _) _)                     = True
stepIsOfPi (XsltTagName _ (TypeTest XPPINode) _)        = True
stepIsOfPi _                                            = False

stepIsOfCmt :: XsltStep -> Bool
stepIsOfCmt (XsltTagName _ (TypeTest XPCommentNode) _)  = True
stepIsOfCmt _                                           = False

stepIsOfAttr :: XsltStep -> String  -> Bool
stepIsOfAttr (XsltTagName Attribute (NameTest qn) _) n  = (localPart qn) == n
stepIsOfAttr (XsltWildcard Attribute _) _               = True
stepIsOfAttr _ _                                        = False

findRuleForRoot :: XNode -> XsltMatchRules -> XsltMatchRules
findRuleForRoot _ e@(MRules [])
    = e
findRuleForRoot xn (MRules rules)
    = (MRules (
        (filter (isXsltRoot) rules)
         ++
        isRightRootStep xn rules
         ++
        [(XsltRoot, builtInRuleDscr)]
      ))

isRightRootStep :: XNode -> [(XsltStep, XsltRuleDescr)] -> [(XsltStep, XsltRuleDescr)]
isRightRootStep _ []
    = []
isRightRootStep (XTag qn _) rl
    = filter (stepIsRootTag (localPart qn)) rl
isRightRootStep _ _
    = []

stepIsRootTag :: String -> (XsltStep, XsltRuleDescr) -> Bool
stepIsRootTag rootName ((XsltTagName _ (NameTest qn) _), _)
    = (localPart qn) == rootName
stepIsRootTag _ _
    = False




-- |
-- Sortierung einer Knotenliste durch xsl:sort
-- Attribute:   [XsltSortKey] = Sortierkriterien
--              NavXmlTrees   = zu sortierende Knotenliste
sortNodeList :: XsltStat -> XsltEnv -> [XsltSortKey] -> NavXmlTrees -> NavXmlTrees
sortNodeList _ _ [] nts    
    = nts
sortNodeList _ _ _ []      
    = []
sortNodeList xsltStat xsltEnv [sk] nts
    = sortNodes xsltStat xsltEnv sk nts
sortNodeList xsltStat xsltEnv (sk:skl) nts
    = sortNodeList xsltStat xsltEnv skl $ sortNodes xsltStat xsltEnv sk nts


sortNodes :: XsltStat -> XsltEnv -> XsltSortKey -> NavXmlTrees -> NavXmlTrees
sortNodes xsltStat xsltEnv xsltSK ntl
    | (order xsltSK) == "descending"
        = reverse $ sortNodes' xsltStat xsltEnv xsltSK ntl
    | otherwise
        = sortNodes' xsltStat xsltEnv xsltSK ntl

sortNodes' :: XsltStat -> XsltEnv -> XsltSortKey -> NavXmlTrees -> NavXmlTrees
sortNodes' xsltStat xsltEnv xsltSK ntl
    | (dataType xsltSK) == "number"
        = snd $ unzip $ sortBy cmpNodesNmb $ map (getSortKeyNmb (sortKey xsltSK) vars ntl) ntl
    | otherwise
        = snd $ unzip $ sortBy cmpNodesTxt $ map (getSortKeyTxt (sortKey xsltSK) vars ntl) ntl
      where
        vars = ((localVars xsltStat) ++ (globalVars xsltEnv)
                ++ (localParam xsltStat) ++ (globalParam xsltEnv)
                , []
                )
        
cmpNodesTxt  :: (String, NavXmlTree) -> (String, NavXmlTree) -> Ordering
cmpNodesTxt (str1,_) (str2,_)
    | str1 == str2 = EQ
    | str1 >  str2 = GT
    | str1 <  str2 = LT
cmpNodesTxt _ _ = LT
cmpNodesNmb  :: (Int, NavXmlTree) -> (Int, NavXmlTree) -> Ordering
cmpNodesNmb (i1,_) (i2,_)
    | i1 == i2 = EQ
    | i1 >  i2 = GT
    | i1 <  i2 = LT
cmpNodesNmb _ _
    = LT

getSortKeyTxt :: String -> XsltData -> [NavXmlTree] -> NavXmlTree -> (String, NavXmlTree)
getSortKeyTxt expr xsltData ntl nt
    = (xPathVal2String
         $ evalXPExpr xsltData
                      expr (fromJust $ findIndex (== nt) ntl
                            ,length ntl
                            ,nt)
       ,nt)

getSortKeyNmb :: String -> XsltData -> [NavXmlTree] -> NavXmlTree -> (Int, NavXmlTree)
getSortKeyNmb expr xsltData ntl nt
    = (xPValue2Int
         $ xnumber (0 ,0, ntree emptyRoot)
                   (convertXsltDataToXPathEnv xsltData)
                   [evalXPExpr xsltData
                               expr (fromJust $ findIndex (== nt) ntl
                                     ,length ntl
                                     ,nt)]
        ,nt)
-- -----------------------------------------------------------------------------

-- |
-- generates an QName out of a qualifiedName
-- see also qualifiedName in XmlTreeTypes
getQName :: String -> QName
getQName str
    = case (elemIndex ':' str) of
      Nothing -> mkName str
      Just n  -> mkNSName (take (n-1) str) (drop n str)


-- |
-- Filter und Funktionen fuer Match-Rueles
-- --------------------------------------------------------
getMRuleNavTree :: XsltMatchRules -> NavXmlTree
getMRuleNavTree (MRules [])          = ntree emptyRoot
getMRuleNavTree (MRules ((_, rd):_)) = rplNavTree (body rd)

rplNavTree  :: XsltRulePriList -> NavXmlTree
rplNavTree (RulePriList [])                  = ntree emptyRoot
rplNavTree (RulePriList ((_, [], _):_) )     = ntree emptyRoot
rplNavTree (RulePriList ((_, (nt:_) ,_):_) ) = nt

getBody :: (XsltStep, XsltRuleDescr) -> XsltRulePriList
getBody (_,rd) = (body rd)
--getBody _      = (RulePriList [])

getParentRules :: (XsltStep, XsltRuleDescr) -> XsltMatchRules
getParentRules (_, rd) = (parentRules rd)
--getParentRules (_,_)   = (MRules [])

getAncestorRules :: (XsltStep, XsltRuleDescr) -> XsltMatchRules
getAncestorRules (_,rd) = (ancestorRules rd)
--getAncestorRules (_,_)  = (MRules [])


isXsltRoot :: (XsltStep, XsltRuleDescr) -> Bool
isXsltRoot (XsltRoot, _)    = True
isXsltRoot _                = False



-- |
-- Filter und Funktionen fuer Name-Rueles
-- --------------------------------------------------------
getNRuleNavTree :: [(QName, Float, [NavXmlTree])] -> NavXmlTree
getNRuleNavTree []                 = ntree emptyRoot
getNRuleNavTree ((_,_,[]):_)       = ntree emptyRoot
getNRuleNavTree ((_,_, (nt:_)):_)  = nt


-- |
-- Convert a XPath-value
--
xPValue2NavXmlTrees         :: XPathValue -> [NavXmlTree]
xPValue2NavXmlTrees (XPVNode ns)    = ns
xPValue2NavXmlTrees _               = []

xPValue2Bool                :: XPathValue -> Bool
xPValue2Bool (XPVBool b)            = b
xPValue2Bool _                      = False

xPValue2Int :: XPathValue -> Int
xPValue2Int (XPVNumber (Float f))   = round f
xPValue2Int _                       = 0

xPathVal2String :: XPathValue -> String
xPathVal2String elemExpr
    = xPValue2String $ xstring (0 ,0, ntree emptyRoot) varEnv [elemExpr]


-- -----------------------------------------------------------------------------
-- aus XPathEval.hs kopiert:

-- |
-- Convert list of ID attributes from DTD into a space separated 'XPVString'
--
idAttributesToXPathValue	:: XmlTrees -> XPathValue
idAttributesToXPathValue ts
    = XPVString (foldr (\ n -> ( (valueOfDTD "value" n ++ " ") ++)) [] ts)

-- |
-- Extracts all ID-attributes from the document type definition (DTD).
--
getIdAttributes	:: XmlFilter
getIdAttributes
    = getChildren
       .>
      isXDTD
       .>
      deep (isIdAttrType)
-- -----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
-- neue Funktionen von Torben fuer die Namespaces in XPath
-- gehoeren eigentlich in XPath (derzeit noch in XPathExample.hs)
nsList :: NamespaceTable
nsList = [("xsl","http://www.w3.org/1999/XSL/Transform"), ("q","http:://q"),("w","http:://w")]

propagatExpr  :: Expr -> Expr
propagatExpr (GenExpr op ex)	= GenExpr op (map propagatExpr ex)
propagatExpr (FctExpr n arg)	= FctExpr n (map propagatExpr arg)
propagatExpr (FilterExpr (primary:predi))
    = FilterExpr ((propagatExpr primary) : (map propagatExpr predi))
propagatExpr (PathExpr Nothing lp@(Just _)) = PathExpr Nothing (propagatLocpath lp)
propagatExpr (PathExpr (Just fe) lp@(Just _))
    = PathExpr (Just (propagatExpr fe)) (propagatLocpath lp)
propagatExpr q 	= q

propagatLocpath		:: Maybe LocationPath -> Maybe LocationPath
propagatLocpath (Just (LocPath rel steps))
    = Just (LocPath rel (map propagatStep steps))
propagatLocpath a = a

propagatStep :: XStep -> XStep
propagatStep (Step axis nt [])
    = Step axis (propagatNt nt) []
propagatStep (Step axis nt expr)
    = Step axis (propagatNt nt) (map propagatExpr expr)

propagatNt          :: NodeTest -> NodeTest
propagatNt (NameTest qn)     = NameTest (setNamespace nsList qn)
propagatNt a    = a
-- -----------------------------------------------------------------------------


stripSpaceCond :: NavXmlTreeFilter
stripSpaceCond (QNameFV qn) nt
    = (BoolFV ( ((selName $ dataNT nt) == qn) ))
      where
        selName (XTag  n _)	= n
        selName (XAttr n  )	= n
        selName (XPi   n _)	= n
        selName _           = mkNSName "" ""
stripSpaceCond _ _
    = (BoolFV False)

preserveSpaceCond :: NavXmlTreeFilter
preserveSpaceCond (QNameFV qn) nt
    = (BoolFV ( not ((selName $ dataNT nt) == qn) ))
      where
        selName (XTag  n _)	= n
        selName (XAttr n  )	= n
        selName (XPi   n _)	= n
        selName _           = mkNSName "" ""
preserveSpaceCond _ _
    = (BoolFV True)


isNotEmptyXPVNode :: XPathValue -> Bool
isNotEmptyXPVNode (XPVNode [])  = False
isNotEmptyXPVNode (XPVNode _)   =  True
isNotEmptyXPVNode _             = False
-- ---------


-- ---------------------------------------------------------------------------------
-- ---------------------------------------------------------------------------------
-- ---------------------------------------------------------------------------------
stripAll :: [QName] -> Bool -> XmlFilter             -- for xsl-files
stripAll stripPreserveList preserveSp ts
    | hasToBePreserved  = [ts]
    | otherwise         = removeWhiteSpace ts
      where
        hasToBePreserved = preserveSp || (satisfies (isInQNames stripPreserveList) ts)

preservAll :: [QName] -> Bool -> XmlFilter           -- for xml-files
preservAll stripPreserveList _ ts
    | hasToBeStripped   = removeWhiteSpace ts
    | otherwise         = [ts]
      where
        hasToBeStripped = (satisfies (isInQNames stripPreserveList) ts)



isInPreserveSpace :: [QName] -> [QName] -> XmlTree -> Bool
isInPreserveSpace _ preserve t = isInListOfQNames preserve t

isInStripSpace :: [QName] -> [QName] -> XmlTree -> Bool
isInStripSpace strip _ t = isInListOfQNames strip t

isInQNames :: [QName] -> XmlFilter
isInQNames = isOfList isInListOfQNames

isInStripSpace' :: [QName] -> XmlFilter
isInStripSpace' = isOfList isInListOfQNames

isInPreserveSpace' :: [QName] -> XmlFilter
isInPreserveSpace' = isOfList isInListOfQNames

isInListOfQNames :: [QName] -> XmlTree -> Bool
isInListOfQNames [] _   = False
isInListOfQNames qns t  = or $ map (isOfQName t) qns

isOfQName :: XmlTree -> QName -> Bool
isOfQName t qn = qn == qNameOf t

qNameOf :: XmlTree -> QName
qNameOf 
    = selQName . getNode
      where
      selQName (XTag  qn _) = qn
      selQName (XAttr qn  )	= qn
      selQName (XPi   qn _)	= qn
      selQName _			= mkNSName "" ""


isOfList :: ([b] -> a -> Bool) -> [b] -> (a -> [a])
isOfList p l t = if p l t then [t] else []


-- |
-- entfernen der Whitespaces unter Beruecksichtigung
-- von xsl:strip-space bzw. xsl:preserve-space
removeWS :: ([QName] -> Bool -> XmlFilter) -> [QName] -> Bool -> XmlSFilter
removeWS stripOrPreserveAll stripPreserveList preserveSp ts
    = (processChildren processRootElement `when` isXTag) $$ ts
      where
        processRootElement :: XmlFilter
        processRootElement = removeText .> processChild
          where
            removeText = none `when` isWhiteSpace
            processChild = choice [ isXDTD
               :-> none
             , this
               :-> modifyChildren
                   (remWS stripOrPreserveAll stripPreserveList preserveSp)
             ]
      
remWS :: ([QName] -> Bool -> XmlFilter) -> [QName] -> Bool -> XmlSFilter
remWS _ _ _ [] = []
remWS stripOrPreserveAll stripPreserveList preserveSp ts
    = (stripOrPreserveAll stripPreserveList preserveSp $$ ls) ++ procRest rs
      where  
        (ls, rs) = break (satisfies isXTag) ts
        procRest	:: XmlSFilter
        procRest [] = []
        procRest (t':ts')
          = ((
            (stripOrPreserveAll stripPreserveList preserveSp)
            `o`
             modifyChildren procChildren
            )
            `when`
             (isXTag `o` neg (isInQNames stripPreserveList))
             $ t'
            )
            ++
            ( if null ts'
             then procRest ts'
             else remWS stripOrPreserveAll stripPreserveList preserveSp ts'
            )
          where
        
            xmlSpaceAttrName  = "xml:space"
            xmlSpaceAttrValue = valueOf xmlSpaceAttrName t'
            preserveSpace'
                = fromMaybe preserveSp
                  .
                  lookup xmlSpaceAttrValue
                          $ [ ("preserve", True)
                            , ("default",  False)
                            ]
            procChildren
                | all (satisfies isWhiteSpace) $ getChildren t'
                    = (none $$)
                | otherwise
                    = remWS stripOrPreserveAll stripPreserveList preserveSpace'