content: -- ------------------------------------------------------------
  
  {- |
     Module     : Text.XML.HXT.XSLT.XsltArrows
     Copyright  : Copyright (C) 2006 Tim Walkenhorst, Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : experimental
     Portability: portable
  
     The HXT arrow interface for the XSLT module
  
     The application programming interface to the arrow modules of the Haskell XML Toolbox.
     This module exports all important arrows for input, output, parsing, validating and transforming XML.
     It also exports all basic datatypes and functions of the toolbox.
  
  -}
  
  -- ------------------------------------------------------------
  
  
  module Text.XML.HXT.XSLT.XsltArrows
      ( xsltCompileStylesheet
      , xsltCompileStylesheetFromURI
      , xsltApplyStylesheet
      , xsltApplyStylesheetFromURI
      , CompiledStylesheet
      )
  where
  
  import Control.Exception
      ( evaluate )
  
  import Text.XML.HXT.Core
  
  import Text.XML.HXT.XSLT.Names
  
  import Text.XML.HXT.XSLT.CompiledStylesheet
      ( CompiledStylesheet )
  
  import Text.XML.HXT.XSLT.Compilation
      ( prepareXSLTDocument
      , assembleStylesheet
      )
  
  import Text.XML.HXT.XSLT.Application
      ( applyStylesheet )
  
  -- ------------------------------------------------------------
  
  -- | arrow for applying a pure partial function, catch the error case and issue the error
  
  arrWithCatch    :: (a -> b) -> IOSArrow a b
  arrWithCatch f
      = arrIO (evaluate . f)
        `catchA`
        issueExc "arrWithCatch"
  
  -- ------------------------------------------------------------
  
  -- | lift prepareXSLTDocument
  
  prepareXSLTDoc  :: IOSArrow XmlTree XmlTree
  prepareXSLTDoc
      = ( arrWithCatch prepareXSLTDocument
          >>>
          traceDoc "prepareXSLTDocument"
        )
        `when`
        documentStatusOk
  
  -- | read an XSLT stylesheet
  
  readXSLTDoc     :: SysConfigList -> IOSArrow String XmlTree
  readXSLTDoc options
      = readFromDocument (options ++ defaultOptions)
      where
      defaultOptions
          = [ withCheckNamespaces yes
            , withValidate        no
            , withPreserveComment no
            ]
  
  -- | Normalize stylesheet, expand includes, select imports and assemble the rules
  
  compileSSTWithIncludeStack :: [String] -> IOSArrow XmlTree CompiledStylesheet
  compileSSTWithIncludeStack incStack
      = traceMsg 2 "compile stylesheet"
        >>>
        getChildren                                       -- remove document root
        >>>
        isElem                                            -- select XSLT root element
        >>>
        choiceA
        [ isXsltLREstylesheet                             -- simplified syntax
          :-> ( xsltlre2stylesheet
                >>>
                assStylesheet []
              )
        , isXsltStylesheetElem                            -- xsl:stylesheet or xsl:transform
          :-> ( expStylesheet
                $< ( listA ( getChildren                  -- take contents and expand includes
                             >>>
                             expandIncludes incStack
                           )
                     >>>
                     partitionA isXsltImport              -- separate imports from normal rules
                   )
              )
        , this
          :-> ( issueErr "XSLT: Either xsl:stylesheet/xsl:transform or simplified syntax expected"
                >>>
                none
              )
        ]
        >>>
        traceValue 3 (("compiled stylesheet:\n" ++) . show)
      where
      assStylesheet imports                               -- do the assembly, the compilation
          = arrWithCatch (flip assembleStylesheet $ imports)
  
      expStylesheet (imports, rest)
          = traceMsg 2 "expand stylesheet"
            >>>
            setChildren rest                              -- remove import rules from stylesheet
            >>>
            assStylesheet $< listA ( constL imports       -- read the imports and assemble the stylesheet
                                     >>>
                                     getXsltAttrValue xsltHRef
                                     >>>
                                     compileSSTFromUriWithIncludeStack incStack
                                   )
  
  -- | read an include and check for recursive includes
  
  readSSTWithIncludeStack :: [String] -> IOSArrow String XmlTree
  readSSTWithIncludeStack incStack
      = ifP (`elem` incStack)
        ( (issueErr $< arr recursiveInclude) >>> none )
        ( readXSLTDoc []
          >>>
          prepareXSLTDoc
        )
      where
      recursiveInclude uri
          = "XSLT error: "
            ++ show uri ++ " is recursively imported/included."
            ++ concatMap (("\n  imported/included from: " ++) . show) incStack
  
  compileSSTFromUriWithIncludeStack       :: [String] -> IOSArrow String CompiledStylesheet
  compileSSTFromUriWithIncludeStack incStack
      = comp $< this
      where
      comp uri
          = readSSTWithIncludeStack incStack
            >>>
            compileSSTWithIncludeStack (uri:incStack)
  
  expandIncludes  :: [String] -> IOSArrow XmlTree XmlTree
  expandIncludes incStack
      = isElem
        >>>
        ( ( expandInclude $< getXsltAttrValue xsltHRef )
          `when`
          isXsltInclude
        )
      where
      expandInclude href
          = ( constA href
              >>>
              readSSTWithIncludeStack incStack
              >>>
              getChildren
              >>>
              isElem
              >>>
              choiceA
              [ isXsltLREstylesheet
                :-> xsltlre2template
  
              , isXsltStylesheetElem
                :-> ( getChildren
                      >>>
                      expandIncludes (href:incStack)
                    )
  
              , this
                :-> issueFatal ("XSLT error: Included file " ++ show href ++ " is not a stylesheet")
              ]
            )
  
  isXsltElem              :: ArrowXml a => QName -> a XmlTree XmlTree
  isXsltElem qn           = isElem >>> hasNameWith (equivQName qn)
  
  isXsltAttr              :: ArrowXml a => QName -> a XmlTree XmlTree
  isXsltAttr qn           = isAttr >>> hasNameWith (equivQName qn)
  
  hasXsltAttr             :: ArrowXml a => QName -> a XmlTree XmlTree
  hasXsltAttr qn          = ( getAttrl >>> isXsltAttr qn )
                            `guards`
                            this
  
  isXsltInclude           :: ArrowXml a => a XmlTree XmlTree
  isXsltInclude           = isXsltElem xsltInclude
  
  isXsltImport            :: ArrowXml a => a XmlTree XmlTree
  isXsltImport            = isXsltElem xsltImport
  
  isXsltLREstylesheet     :: ArrowXml a => a XmlTree XmlTree
  isXsltLREstylesheet     = hasXsltAttr xsltVersionLRE
  
  isXsltStylesheetElem    :: ArrowXml a => a XmlTree XmlTree
  isXsltStylesheetElem    =  ( isXsltElem xsltTransform
                               <+>
                               isXsltElem xsltStylesheet
                             )
                             >>>
                             hasXsltAttr xsltVersion
  
  getXsltAttrValue        :: ArrowXml a => QName -> a XmlTree String
  getXsltAttrValue qn     = getAttrl >>> isXsltAttr qn >>> xshow getChildren
  
  xsltlre2template        :: ArrowXml a => a XmlTree XmlTree
  xsltlre2template        = mkqelem xsltTemplate [sqattr xsltMatch "/"] [this]
  
  xsltlre2stylesheet      :: ArrowXml a => a XmlTree XmlTree
  xsltlre2stylesheet      = mkqelem xsltTransform [] [ this >>> xsltlre2template ]
  
  --
  
  checkApplySST   ::  IOSArrow XmlTree XmlTree -> IOSArrow XmlTree XmlTree
  checkApplySST appl
      = ( isRoot
          >>>
          replaceChildren appl
          >>>
          traceDoc "XSLT stylesheet applied"
          >>>
          setDocumentStatusFromSystemState "applying XSLT stylesheet"
        )
        `orElse`
        issueErr "XSLT: complete document with root node required for stylesheet application"
  
  -- | Compile a document representing an XSLT stylesheet into an internal representation
  --
  -- The internal representation is an abstract syntax tree for the XSLT rules.
  -- XSLT imports and includes are evaluated and the rules are normalized and prepared
  -- for easy application.
  
  xsltCompileStylesheet           :: IOSArrow XmlTree CompiledStylesheet
  xsltCompileStylesheet
      = prepareXSLTDoc
        >>>
        compileSSTWithIncludeStack []
  
  -- | A convinient function for combining reading a stylesheet and compilation.
  --
  -- Reading an XSLT stylesheet is always done without validation but with
  -- namespace propagation. Comments are removed from the stylesheet.
  
  xsltCompileStylesheetFromURI    :: IOSArrow String CompiledStylesheet
  xsltCompileStylesheetFromURI    = compileSSTFromUriWithIncludeStack []
  
  -- | apply a compiled XSLT stylesheet to a whole document tree
  --
  -- The compiled stylesheet must have been created with 'xsltCompileStylesheet'
  -- or 'xsltCompileStylesheetFromURI'
  
  xsltApplyStylesheet             :: CompiledStylesheet -> IOSArrow XmlTree XmlTree
  xsltApplyStylesheet css
      = checkApplySST (arrWithCatch (applyStylesheet css) >>. concat)
  
  -- | apply an XSLT stylesheet given by an URI to a whole document tree
  --
  -- The string parameter is the URI of the XSLT stylesheet.
  -- In case of an error during stylesheet compilation or stylesheet application
  -- all children of the root node are removed and
  -- the error status is set in the attribute list of the root node of the input document.
  
  xsltApplyStylesheetFromURI      :: String -> IOSArrow XmlTree XmlTree
  xsltApplyStylesheetFromURI uri
      = xsltApplyStylesheet $< (constA uri >>> xsltCompileStylesheetFromURI)
  
  {-
  xsltApplyStylesheetWParams      :: Map ExName Expr -> CompiledStylesheet -> IOSArrow XmlTree XmlTree
  xsltApplyStylesheetWParams wp css       = arrL (applyStylesheetWParams wp css)
  -}
  