content: -- ------------------------------------------------------------
  
  {- |
     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.List
  import qualified Data.Map               as Map hiding   ( Map )
  import           Data.Map                               ( Map )
  
  import           Text.ParserCombinators.Parsec.Prim     ( runParser )
  
  import           Text.XML.HXT.Parser.XmlCharParser      ( withNormNewline )
  
  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
                              (withNormNewline (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 ""
  
  -- -----------------------------------
  