module XsltParserFunctions
where

import Data.List

import HdomParser
import Text.ParserCombinators.Parsec
    ( parse )

import XPath

import XsltDataTypes
import XsltParser
-- -----------------------------------------------------------------------------
patternParser  :: String -> [XsltStepList]
patternParser pString
    | pString == "" = []
    | otherwise     = case (parse xsltParser "" pString) of
        Left parseError -> [StepList [XsltError (pString ++ "  : parse error at " ++ (show parseError) ) ]]
        Right sl -> sl

-- |
-- filters all parse errors out of an list of rules
getMRParseErrors :: XsltMatchRules -> String
getMRParseErrors (MRules [])      = ""
getMRParseErrors (MRules rules)   = foldl getMRParseErrors' "" rules

getMRParseErrors' :: String -> (XsltStep, XsltRuleDescr) -> String
getMRParseErrors' str (step,_) = getPEFromStep str step

-- |
-- filters all parse errors out of an StepList
getSLParseError :: XsltStepList -> String
getSLParseError (StepList [])       = ""
getSLParseError (StepList steps)  = foldl getPEFromStep "" steps

-- |
-- extract the error msg out of an step
getPEFromStep :: String -> XsltStep -> String
getPEFromStep str (XsltError errstr)  = str ++ errstr ++ "\n"
getPEFromStep str _                   = str


-- |
-- calls the parser for foating point numbers
floatParser :: String -> Float
floatParser = parseFloat

-- |
-- calls the parser for a list of QNames
qnamesParser :: String -> [(String, String)]
qnamesParser = parseQNames

-- |
-- calls the parser for QName
qNameParser :: String -> (String, String)
qNameParser = parseQName

-- |
-- calls the parser for a list of nameTests
nameTestsParser :: String -> [XsltStepList]
nameTestsParser = parseNameTests

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

-- |
-- creates the rules
mkRule :: XmlTrees -> QName -> [XsltStepList] -> String -> Float -> Float -> XsltTLFct
mkRule template theMode sl nameAtt importPriority priorityAtt xsltStat envres
    | nameAtt == ""
    = mkMatchRule template theMode sl importPriority priorityAtt xsltStat envres

    | otherwise
    = mkMatchRule template theMode sl importPriority priorityAtt xsltStat
                  $ mkNameRule template (mkName nameAtt) xsltStat envres

mkMatchRule :: XmlTrees -> QName -> [XsltStepList] -> Float -> Float -> XsltTLFct
mkMatchRule template theMode sl importPriority priorityAtt _ (xsltEnv, xsltRes)
    = (xsltEnv
        {matchRules
         =
         mergeRules $ addRules (matchRules xsltEnv)
                     $ mkRuleDescrs template sl theMode importPriority priorityAtt
         }
        ,xsltRes
       )

mkNameRule :: XmlTrees -> QName -> XsltTLFct
mkNameRule template ruleName _ (xsltEnv, xsltRes)
    = (xsltEnv
        {nameRules
        =
        addNameRule (nameRules xsltEnv)
                    (ruleName, 0, [ntree (mkXTagTree "RuleDescr" [] template)])
        }
        ,xsltRes
      )

addNameRule :: XsltNameRules -> (QName, Float, [NavXmlTree]) -> XsltNameRules
addNameRule (NRules rules) newRule
    = NRules (newRule:rules)


-- |
--
mkRuleDescrs :: XmlTrees -> [XsltStepList] -> QName -> Float -> Float -> XsltMatchRules
mkRuleDescrs template spl m importPriority pri  = concRules $ map (mkRuleDescr template m importPriority pri) spl

mkRuleDescr :: XmlTrees -> QName -> Float -> Float -> XsltStepList -> XsltMatchRules
mkRuleDescr template m importPriority pri (StepList (step:xs))
    = mkRuleDescr' step (StepList(xs)) template m importPriority pri
mkRuleDescr _ _ _ _ (StepList [])
    = MRules [((XsltError "leer?"), emptyRD)]

mkRuleDescr' :: XsltStep -> XsltStepList -> XmlTrees -> QName -> Float -> Float -> XsltMatchRules
mkRuleDescr' sp (StepList []) template m importPriority pri
    = MRules [
              (
              sp
              ,emptyRD
                {body = (RulePriList
                        [
                         (
                          (Pri {priority = pri, importPri = importPriority, defPri = defPriority sp})
                          ,[ntree (mkXTagTree "RuleDescr" [] template)]
                          ,m
                          )
                         ])
                 }
              )
             ]
mkRuleDescr' sp (StepList(XsltParent : xs)) template m importPriority pri
    = MRules [
              (
              sp
              ,emptyRD
                {parentRules = (mkRuleDescr template m importPriority pri (StepList(xs)) )}
              )
             ]
mkRuleDescr' sp (StepList(XsltAncestor : xs)) template m importPriority pri
    = MRules [
              (
              sp
              ,emptyRD {ancestorRules = (mkRuleDescr template m importPriority pri (StepList(xs)) )}
              )
             ]
mkRuleDescr' _ _ _ _ _ _ = emptyMRule



defPriority :: XsltStep -> Float
defPriority (XsltTagName _ (NameTest qn) _)
    | (localPart qn) == "*"             = (-0.25)
    | otherwise                         = 0
defPriority (XsltTagName _ (PI _) _)    = 0
defPriority (XsltTagName _ _ _)         = (-0.5)
defPriority _                           = 0.5



-- |
-- 
mergeRules :: XsltMatchRules -> XsltMatchRules
mergeRules (MRules rules@(_:_))
    = (MRules (mergeRules' rules))
mergeRules (MRules [])
    = (MRules [])

mergeRules' :: [(XsltStep, XsltRuleDescr)] -> [(XsltStep, XsltRuleDescr)]
mergeRules' sourceRules
    = foldl mergRul [] sourceRules

mergRul :: [(XsltStep, XsltRuleDescr)] -> (XsltStep, XsltRuleDescr) -> [(XsltStep, XsltRuleDescr)]
mergRul rListe rule
    = (mergRul'
        (fst (partRules rListe rule))   -- alle gleichen aus der liste
        rule
      )
      ++
      (snd (partRules rListe rule)) -- der rest der liste

mergRul' :: [(XsltStep, XsltRuleDescr)] -> (XsltStep, XsltRuleDescr) -> [(XsltStep, XsltRuleDescr)]
mergRul' [] rule
    = [rule]
mergRul' [(step1, rd1)] (_, rd2)
    = [(step1, (mergeRD rd1 rd2))]
mergRul' _ _
    = []


-- |
-- zusammenfassen zweier XsltRuleDescr zu einer, fuer rules mit dem
-- gleichen "Anfangs-Step"
mergeRD :: XsltRuleDescr -> XsltRuleDescr -> XsltRuleDescr
mergeRD a b
    = (RD {
           body           = ((body a) +.+ (body b))
           ,parentRules   = (mergeRules (addRules (parentRules a) (parentRules b)))
           ,ancestorRules = (mergeRules (addRules (ancestorRules a) (ancestorRules b)))
           }
      ) 

-- |
-- koppeln von mehreren RulePriList-Elemente zu einem
(+.+) :: XsltRulePriList -> XsltRulePriList -> XsltRulePriList
(RulePriList a) +.+ (RulePriList b) = (RulePriList (a ++ b))

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


concRules :: [XsltMatchRules] -> XsltMatchRules
concRules []                = (MRules [])
concRules (x:xs)            = (MRules (concat ((splitRules x) : (map splitRules xs))))

addRules :: XsltMatchRules -> XsltMatchRules -> XsltMatchRules
addRules (MRules rules1) (MRules rules2) = (MRules (rules1 ++ rules2))

splitRules :: XsltMatchRules -> [(XsltStep, XsltRuleDescr)]
splitRules (MRules [])      = []
splitRules (MRules a)       = a

-- |
-- teilt eine Liste von Rules in ein Tupel auf.
-- das erste Element des Tupels enthaelt Rules mit gleichem Anfang wie Argument2
-- das zweite Element enthaelt alle anderen
partRules :: [(XsltStep, XsltRuleDescr)] -> (XsltStep, XsltRuleDescr) -> ([(XsltStep, XsltRuleDescr)],[(XsltStep, XsltRuleDescr)])
partRules rList rule = (partition (rulesForSameStep rule) rList)


-- |
-- testet, ob zwei rules zum gleichen Element passen (gleicher "Anfangs-Step")
rulesForSameStep :: (XsltStep, XsltRuleDescr) ->  (XsltStep, XsltRuleDescr) -> Bool
rulesForSameStep (step1, _) (step2, _)  = (step1 == step2)
--rulesForSameStep (_,_) (_,_)            = False



-- -----------------------------------------------------------------------------
-- einige XMLFilter

-- |
-- alle template-tags mit match-attribut herausfiltern
getMatchTemplateTags :: XmlFilter
getMatchTemplateTags = multi (isTag "xsl:template" .> (hasAttr "match"))

-- |
-- alle template-tags mit name-attribut herausfiltern
getNameTemplateTags :: XmlFilter
getNameTemplateTags = multi (isTag "xsl:template" .> (hasAttr "name"))

-- |
-- alles Bodys der template-tags herausfiltern
getTemplateBodys :: XmlFilter
getTemplateBodys = getChildren

-- -----