content: -- ------------------------------------------------------------
  
  {- |
     Module     : Text.XML.HXT.XSLT.Application
     Copyright  : Copyright (C) 2006-2008 Tim Walkenhorst, Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
     Stability  : experimental
     Portability: portable
  
     Common imports and functions for HXSLT
  
  -}
  
  -- ------------------------------------------------------------
  
  module Text.XML.HXT.XSLT.Common
      ( module Control.Arrow
      , module Text.XML.HXT.DOM.XmlNode
      , module Text.XML.HXT.DOM.XmlKeywords
      , module Text.XML.HXT.DOM.TypeDefs
      , module Text.XML.HXT.DOM.FormatXmlTree
      , module Text.XML.HXT.XPath.XPathDataTypes
      , module Text.XML.HXT.XPath.XPathParser
      , module Text.XML.HXT.XPath.XPathEval
      , module Text.XML.HXT.XPath.XPathFct
      , module Text.XML.HXT.XPath.XPathToString
      , module Data.Tree.Class
  
      -- Tree Functions
      , filterTree                 -- Tree t => (a -> Bool) -> t a -> Maybe (t a)
      , mapTreeCtx                 -- Tree t => (c -> a -> (c, b)) -> c -> t a -> t b
      , filterTreeCtx              -- Tree t => (c -> a -> (c, Bool)) -> c -> t a -> Maybe (t a)
      , zipTreeWith                -- Tree t => (a -> b -> c) -> t a -> t b -> t c
      , zipTree                    -- Tree t => t a -> t b -> t (a,b)           (zipTreeWith (,))
      , unzipTree                  -- Tree t => t (a,b) -> (t a, t b)           (mapTree fst &&& mapTree snd)
      , showTrees
  
      -- XML functions
      , isElemType                 -- XmlNode n => QName -> n -> Bool
      , isAttrType                 -- XmlNode n => QName -> n -> Bool
      , isWhitespaceNode           -- XmlTree -> Bool
      , collectTextnodes           -- [XmlTree] -> String
      , tryFetchAttribute          -- XmlNode n => n -> QName -> Maybe String
      , fetchAttributeWDefault     -- XmlNode n => n -> QName -> String -> String
      , fetchAttribute             -- XmlNode n => n -> QName -> String
      , hasAttribute               -- XmlNode n => n -> QName -> Bool
      , setAttribute               -- XmlNode n => QName -> String -> n -> n
  
      -- Namespace functions
      , ExName(ExName)             -- String (local) -> String (uri) -> ExName
      , mkExName                   -- QName -> ExName
      , exLocal                    -- ExName -> String
      , exUri                      -- ExName -> String
      , parseExName                -- UriMapping -> String -> ExName
      , UriMapping                 -- Map String String
      , getUriMap                  -- XmlNode n => n -> UriMapping (extract an Ns-Uri Map from an Element node)
      , setUriMap                  -- XmlNode n => UriMap -> n -> n
      , uriMap2Attrs               -- UriMapping -> [XmlTree]      (create xmlns:* Attribute nodes for Uri-Mapping)
      , expandNSDecls              -- XmlTree -> XmlTree
      , lookupPrefix               -- UriMapping -> String -> String
      , isNsAttr                   -- XmlTree -> Bool
  
      -- additions to XPATH:
      , mkLiteralExpr              -- String -> Expr
      , mkStringExpr               -- Expr -> Expr
      , mkBoolExpr                 -- Expr -> Expr
      , mkTrueExpr                 -- Expr
      , concatExpr                 -- [Expr] -> Expr
      , splitExpr                  -- Expr -> [Expr]
      , unionExpr                  -- [Expr] -> Expr
      , splitMatchByPrio           -- Expr -> [(Float, Expr)]
      , computePriority            -- Expr -> Float
      , computeNTestPriority       -- NodeTest -> Float
      , isMatchExpr                -- Expr -> Bool
  
      -- Misc.:
      , fromJustErr                -- String -> Maybe a -> a, fromJust with error message
      , readWDefault               -- Read a => a -> String -> a
      )
  where
  
  import Control.Arrow
  import Control.Arrow.ListArrow
  import Control.Arrow.ArrowList
  
  import Text.XML.HXT.Arrow.XmlArrow      ( xshow
                                          )
  import Text.XML.HXT.DOM.XmlKeywords
  import Text.XML.HXT.DOM.XmlNode         ( XmlNode (..)
                                          , mkElement
                                          , mkRoot
                                          , mkAttr
                                          , mergeAttrl
                                          )
  
  import Text.XML.HXT.DOM.TypeDefs        ( XmlTree
                                          , XNode(XTag, XAttr)
                                          , QName
                                          , toNsEnv
                                          , namePrefix
                                          , localPart
                                          , namespaceUri
                                          , equivQName
                                          , mkName
                                          , mkQName
                                          )
  import Text.XML.HXT.DOM.FormatXmlTree   ( formatXmlTree
                                          )
  
  import Text.XML.HXT.XPath.XPathDataTypes( NavTree
                                          , ntree
                                          , subtreeNT
                                          , upNT
                                          , downNT
                                          , rightNT
                                          , leftNT
                                          , getChildrenNT
  
                                          , Expr          ( LiteralExpr
                                                          , FctExpr
                                                          , GenExpr
                                                          , PathExpr
                                                          )
                                          , Op            ( Union )
                                          , LocationPath  ( LocPath )
                                          , Path          ( Rel )
                                          , XStep         ( Step )
                                          , NodeTest      ( NameTest
                                                          , PI
                                                          , TypeTest
                                                          )
                                          , NodeSet       (..)
                                          , NavXmlTree
                                          , XPathValue    ( XPVNode
                                                          , XPVBool
                                                          , XPVString
                                                          , XPVError
                                                          )
                                          , emptyNodeSet
                                          , singletonNodeSet
                                          , nullNodeSet
                                          , cardNodeSet
                                          , deleteNodeSet
                                          , insertNodeSet
                                          , unionNodeSet
                                          , elemsNodeSet
                                          , fromNodeSet
                                          , toNodeSet
                                          , headNodeSet
                                          , withNodeSet
                                          )
  import Text.XML.HXT.XPath.XPathParser   ( parseXPath
                                          )
  import Text.XML.HXT.XPath.XPathEval     ( evalExpr
                                          )
  import Text.XML.HXT.XPath.XPathFct      ( isNotInNodeList
                                          )
  import Text.XML.HXT.XPath.XPathToString ( xPValue2XmlTrees
                                          )
  
  import           Data.Map (Map)
  import qualified Data.Map as Map hiding (Map)
  
  import Data.Tree.Class
  
  import Data.Maybe
  import Data.List
  import Data.Char
  
  ---------------------------
  -- Tree functions
  
  -- mapTree :: Functor t => (a -> b) -> t a -> t b
  -- mapTree = fmap
  
  -- "map" on a tree with a context.
  -- Contextual information from the ancestors of the current node can be collected in the context
  
  mapTreeCtx :: Tree t => (c -> a -> (c, b)) -> c -> t a -> t b
  mapTreeCtx f c tree =
      mkTree b $ map (mapTreeCtx f cN) $ getChildren tree
    where
      (cN, b) = f c $ getNode tree
  
  filterTree :: Tree t => (a -> Bool) -> t a -> Maybe (t a)
  filterTree p tree = if p node
                        then Just $ mkTree node $ mapMaybe (filterTree p) $ getChildren tree
                        else Nothing
                      where node = getNode tree
  
  -- "filter" on a tree with a context.
  -- Contextual information from the ancestors of the current node can be collected in the context
  filterTreeCtx :: Tree t => (c -> a -> (c, Bool)) -> c -> t a -> Maybe (t a)
  filterTreeCtx p c tree =
    if b
      then Just $ mkTree node $ mapMaybe (filterTreeCtx p cN) $ getChildren tree
      else Nothing
    where
      (cN, b) = p c node
      node    = getNode tree
  
  zipTreeWith   :: Tree t => (a -> b -> c) -> t a -> t b -> t c
  zipTreeWith f a b = mkTree (f (getNode a) (getNode b))
                         $ zipWith (zipTreeWith f) (getChildren a) $ getChildren b
  
  zipTree     :: Tree t => t a -> t b -> t (a,b)
  zipTree      = zipTreeWith (,)
  
  unzipTree  :: Functor t => t (a,b) -> (t a, t b)
  unzipTree   = fmap fst &&& fmap snd
  
  showTrees       :: [XmlTree] -> String
  showTrees ts
      = concat
        (runLA (xshow (constL ts)) $ undefined)
  
  ---------------------------
  -- Xml Functions
  
  collectTextnodes :: [XmlTree] -> String
  collectTextnodes
      = concat . mapMaybe getText
  
  isElemType :: XmlNode n => QName -> n -> Bool
  isElemType qn node
      = isElem node
        &&
        equivQName qn (fromJust $ getElemName node)
  
  isAttrType :: XmlNode n => QName -> n -> Bool
  isAttrType qname node
      = isAttr node
        &&
        equivQName qname (fromJust $ getAttrName node)
  
  tryFetchAttribute :: XmlNode n => n -> QName -> Maybe String
  tryFetchAttribute node qn
    | isElem node =
  
        if null candidates
        then Nothing
  
        else if length candidates > 1
        then error ("More than one attribute " ++ show qn)
  
        else Just $ collectTextnodes $ getChildren $ head candidates
  
    | otherwise = Nothing
    where
      candidates = filter (isAttrType qn) $ fromJust $ getAttrl node
  
  fetchAttributeWDefault ::  XmlNode n => n -> QName -> String -> String
  fetchAttributeWDefault node name def = maybe def id (tryFetchAttribute node name)
  
  fetchAttribute ::  XmlNode n => n -> QName -> String
  fetchAttribute node name = fetchAttributeWDefault node name $ error ("Element " ++ show (getElemName node) ++ " has no attribute: " ++ show name)
  
  hasAttribute ::  XmlNode n => n -> QName -> Bool
  hasAttribute node = isJust . tryFetchAttribute node
  
  setAttribute :: XmlNode n => QName -> String -> n -> n
  setAttribute qn val node
    | isElem node = setElemAttrl (newA : attrs) node
    | otherwise   = error $ "setAttribute on none-element node"             -- how print an XmlNode...
    where
      attrs = filter (not . isAttrType qn) $ fromJust $ getAttrl node
      newA  = mkTree (XAttr qn) [mkText val]
  
  isWhitespaceNode :: (XmlNode n) => n -> Bool
  isWhitespaceNode = maybe False (all isSpace) . getText
  
  ---------------------------
  -- Namespace Functions
  
  -- Expanded name, is unique can therefore be used as a key (unlike QName)
  
  data ExName = ExName String String
    deriving (Show, Eq, Ord)
  
  mkExName :: QName -> ExName
  mkExName qn = ExName (localPart qn) (namespaceUri qn)
  
  exLocal, exUri :: ExName -> String
  exLocal (ExName l _) = l
  exUri   (ExName _ u) = u
  
  parseExName :: UriMapping -> String -> ExName
  parseExName uris str
      | noPrefix  = ExName str ""
      | otherwise = ExName loc $ lookupPrefix uris prefix
      where
      noPrefix       = null loc
      loc            = drop 1 loc'
      (prefix, loc') = span (/= ':') str
  
  -- Mapping from namespace-Prefixes to namespace-URIs
  
  type UriMapping = Map String String
  
  getUriMap :: XmlNode n => n -> UriMapping
  getUriMap
      = uriMappingsFromNsAttrs . filter isNsAttr . maybe err id . getAttrl
        where
        err = error "Internal error: getUriMap on none-element node"
  
  setUriMap :: XmlNode n => UriMapping -> n -> n
  setUriMap nsMap node
      = setElemAttrl (mergeAttrl (maybe [] id $ getAttrl node) $ uriMap2Attrs nsMap) node
  
  uriMap2Attrs :: UriMapping -> [XmlTree]
  uriMap2Attrs
      = map joinNsAttr . Map.toAscList
  
  lookupPrefix :: UriMapping -> String -> String
  lookupPrefix uris prefix
      = fromJustErr ("No namespace-Uri bound to prefix: "++prefix) $ Map.lookup prefix uris
  
  expandNSDecls :: XmlTree -> XmlTree
  expandNSDecls
      = mapTreeCtx (expandNSElem) $ Map.fromAscList [("xml", xmlNamespace), ("xmlns", xmlnsNamespace)]
  
  expandNSElem :: UriMapping -> XNode -> (UriMapping, XNode)
  expandNSElem umap node
    | isElem node = (umapNew, nodeNew)
    | otherwise   = (umap, node)
    where
      nodeNew          = XTag (fromJust $ getElemName node) attrNew
      attrNew          = attrs ++ map joinNsAttr (Map.toAscList umapNew)
      umapNew          = uriMappingsFromNsAttrs nsAttrs `Map.union` umap
      (nsAttrs, attrs) = partition isNsAttr $ fromJust $ getAttrl node
  
  uriMappingsFromNsAttrs :: [XmlTree] -> UriMapping
  uriMappingsFromNsAttrs
      = Map.fromList . map splitNsAttr
  
  isNsAttr :: XmlTree -> Bool
  isNsAttr
      = maybe False ((==) xmlnsNamespace . namespaceUri) . getAttrName
  
  splitNsAttr :: XmlTree -> (String, String)
  splitNsAttr node
      = (localPart $ fromJust $ getAttrName node, collectTextnodes $ getChildren node)
  
  joinNsAttr :: (String, String) -> XmlTree
  joinNsAttr (prefix, uri)
      = mkAttr (mkQName "xmlns" prefix xmlnsNamespace) [mkText uri]
  
  -------------------------
  -- additions to XPATH:
  
  mkLiteralExpr :: String -> Expr
  mkLiteralExpr = LiteralExpr
  
  mkStringExpr :: Expr -> Expr
  mkStringExpr = FctExpr "string" . return
  
  mkBoolExpr :: Expr -> Expr
  mkBoolExpr = FctExpr "boolean" . return
  
  mkTrueExpr :: Expr
  mkTrueExpr = FctExpr "true" []
  
  concatExpr :: [Expr] -> Expr
  concatExpr []                    = LiteralExpr ""
  concatExpr [lit@(LiteralExpr _)] = lit
  concatExpr xs1@[_]               = FctExpr "string" xs1
  concatExpr xs                    = FctExpr "concat" xs
  
  splitExpr :: Expr -> [Expr]
  splitExpr (GenExpr Union expr) = expr
  splitExpr rest                 = [rest]
  
  unionExpr :: [Expr] -> Expr
  unionExpr [e] = e
  unionExpr es  = GenExpr Union es
  
  -- Intelligent splitting: Split an expression into subexpressions with equal priority
  -- for example: "a|c/d|e|f/g"  => [(0.0, "a|e"), (0.5, "c/d|f/g")]
  splitMatchByPrio :: Expr -> [(Float, Expr)]
  splitMatchByPrio =
      map compress . groupBy eq . sortBy cmp . map (computePriority &&& id) . splitExpr
    where
      eq  x y  = fst x == fst y
      cmp x y  = compare (fst x) (fst y)
      compress = (head *** unionExpr) . unzip
  
  computePriority :: Expr -> Float
  computePriority (PathExpr Nothing (Just (LocPath Rel [Step _ ntest []]))) = computeNTestPriority ntest
  computePriority _ = 0.5
  
  computeNTestPriority :: NodeTest -> Float
  computeNTestPriority (PI _)        =  0.0
  computeNTestPriority (TypeTest _)  = -0.5
  computeNTestPriority (NameTest nt)
    | namePrefix nt /= ""
      && localPart nt == "*"        = -0.25
    | localPart nt == "*"           = -0.5
    | otherwise                     =  0.0
  
  isMatchExpr :: Expr -> Bool
  isMatchExpr (GenExpr Union exprs)                          = all isMatchExpr exprs
  isMatchExpr (PathExpr _ _)                                 = True
  isMatchExpr (FctExpr "id" [LiteralExpr _])                 = True
  isMatchExpr (FctExpr "key" [LiteralExpr _, LiteralExpr _]) = True
  isMatchExpr _                                              = False
  
  ---------------------------
  -- Misc:
  
  fromJustErr :: String -> Maybe a -> a
  fromJustErr msg = maybe (error msg) id
  
  readWDefault :: Read a => a -> String -> a
  readWDefault a str = fst $ head $ reads str ++ [(a, "")]
  
  ---------------------------
  