content: {- |
  Module      :  ./Common/XPath.hs
  Description :  XPath utilities
  Copyright   :  (c) Christian Maeder, DFKI GmbH 2010
  License     :  GPLv2 or higher, see LICENSE.txt
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  XPath utilities independent of xml package.
  references:
  <http://www.w3.org/TR/xpath/>
  <http://www.galiel.net/el/study/XPath_Overview.html>
  <http://www.fh-wedel.de/~si/HXmlToolbox/hxpath/diplomarbeit.pdf>
  <http://hackage.haskell.org/package/hxt-xpath>
  (modules XPathParser, XPathDataTypes)
  <http://hackage.haskell.org/package/hxt-8.5.0>
  (modules Text.XML.HXT.DOM.Unicode, Text.XML.HXT.Parser.XmlCharParser)
  <http://www.w3.org/TR/REC-xml/#NT-Name>
  
  Unicode is not
  fully supported. A qualified name is an ncName or two ncNames
  separated by a colon (different from OWL uris).
  -}
  
  module Common.XPath where
  
  import Text.ParserCombinators.Parsec
  import Common.Parsec
  import Data.Char
  import Data.List
  import qualified Control.Monad.Fail as Fail
  
  -- * data types and pretty printing (via show)
  
  -- | axis specifier
  data Axis
    = Ancestor Bool -- ^ or self?
    | Attribute
    | Child
    | Descendant Bool -- ^ or self?
    | Following Bool -- ^ sibling?
    | Namespace
    | Parent
    | Preceding Bool -- ^ sibling?
    | Self
      deriving Show
  
  -- | all possible values
  allAxis :: [Axis]
  allAxis = let bl = [True, False] in
    [ Attribute
    , Child
    , Namespace
    , Parent
    , Self ]
    ++ [ Ancestor b | b <- bl ]
    ++ [ Descendant b | b <- bl ]
    ++ [ Following b | b <- bl ]
    ++ [ Preceding b | b <- bl ]
  
  -- | utility to show (constant) constructors as lower case strings
  lowerShow :: Show a => a -> String
  lowerShow = map toLower . show
  
  -- | proper string representation (do not use show)
  showAxis :: Axis -> String
  showAxis a =
    let s = takeWhile isAlpha $ lowerShow a
        orSelf b = if b then s ++ "-or-self" else s
        sibl b = if b then s ++ "-sibling" else s
    in case a of
    Ancestor c -> orSelf c
    Descendant c -> orSelf c
    Following c -> sibl c
    Preceding c -> sibl c
    _ -> s
  
  -- | testing attribute, namespace or element nodes (usually) by name
  data NodeTest
    = NameTest String -- ^ optional prefix and local part (possibly a * wildcard)
    | PI String       -- ^ processing-instruction node type with optional literal
    | Node            -- ^ true for any node (therefore rarely used)
    | Comment         -- ^ true for comment nodes
    | Text            -- ^ true for text nodes
      deriving Show
  
  -- | all node types without processing-instruction
  nodeTypes :: [NodeTest]
  nodeTypes = [Node, Comment, Text]
  
  -- | the processing-instruction string
  pIS :: String
  pIS = "processing-instruction"
  
  -- | put parens arount a string
  paren :: String -> String
  paren = ('(' :) . (++ ")")
  
  -- | proper string representation (do not use show)
  showNodeTest :: NodeTest -> String
  showNodeTest t = case t of
    NameTest q -> q
    PI s -> pIS ++ paren s
    _ -> lowerShow t ++ paren ""
  
  -- | the stuff of a path between the slashes
  data Step = Step Axis NodeTest [Expr] -- ^ with predicate list
  
  -- | string representation considering abbreviations
  showStep :: Step -> String
  showStep (Step a n ps) =
    let t = showNodeTest n in
    case (a, n) of
       (Attribute, _) -> '@' : t
       (Child, _) -> t
       (Self, Node) -> "."
       (Parent, Node) -> ".."
       _ -> showAxis a ++ "::" ++ t
    ++ concatMap showPred ps
  
  instance Show Step where
    show = showStep
  
  -- | test for @descendant-or-self::node()@ step
  isDescOrSelfNode :: Step -> Bool
  isDescOrSelfNode (Step a n _) = case (a, n) of
    (Descendant True, Node) -> True
    _ -> False
  
  -- | only absolute paths may be empty
  data Path = Path Bool [Step] -- ^ absolute?
  
  -- | show a path abbreviating @\/descendant-or-self::node()\/@
  showSteps :: Bool -> [Step] -> String
  showSteps abso sts = let h = if abso then "/" else "" in case sts of
    [] -> h
    s : r -> let f = h ++ showStep s in case r of
      [] -> f
      _ -> if abso && isDescOrSelfNode s then "//" ++ showSteps False r
           else f ++ showSteps True r
  
  instance Show Path where
    show (Path abso sts) = showSteps abso sts
  
  -- | indicator for primary expressions
  data PrimKind
    = Var -- ^ leading dollar
    | Literal -- ^ single or double quotes
    | Number -- ^ digits possibly with decimal point
  
  -- | expressions where function calls, unary and infix expressions are generic
  data Expr
    = GenExpr Bool String [Expr] -- ^ infix?, op or fct, and arguments
    | PathExpr (Maybe Expr) Path -- ^ optional filter and path
    | FilterExpr Expr [Expr] -- ^ primary expression with predicates
    | PrimExpr PrimKind String
  
  instance Show Expr where
    show = showExpr
  
  -- | put square brackets around an expression
  showPred :: Expr -> String
  showPred e = '[' : showExpr e ++ "]"
  
  -- | show expression with minimal parens
  showExpr :: Expr -> String
  showExpr e = case e of
    GenExpr infx op args ->
      if infx then
          showInfixExpr op args
      else op ++ paren (intercalate "," $ map showExpr args)
    PathExpr m p -> case m of
        Nothing -> ""
        Just f -> showExpr f
      ++ show p
    FilterExpr pe ps ->
      (if isPrimExpr pe then id else paren) (showExpr pe)
      ++ concatMap showPred ps
    PrimExpr k s -> case k of
       Literal -> show $ filter (/= '"') s
       _ -> s
  
  {- | show arguments with minimal parens interspersed with the infix operator.
  Also treat the unary minus where the argument list is a singleton.
  Alphanumeric operators are shown with spaces, which looks bad for @mod@ and
  @div@ in conjunction with additive, relational, or equality operators.  The
  unary minus gets a leading blank if the preceding character is a
  'ncNameChar'. -}
  showInfixExpr :: String -> [Expr] -> String
  showInfixExpr op args = case args of
    [] -> op -- cannot happen
    [arg] -> -- unary minus
      let s = showExpr arg
      in op ++ case arg of
         GenExpr True aOp _ -> case aOp of
           "|" -> s
           _ -> paren s
         _ -> s
    arg : rargs ->
      let mi = findIndex (elem op) inOps
          f = parenExpr False mi arg
          padOp
            | any isAlpha op = ' ' : op ++ " "
            | elem op addOps && not (null f) && ncNameChar (last f) = ' ' : op
            | otherwise = op
      in f ++ concatMap ((padOp ++) . parenExpr True mi) rargs
  
  {- | put parens around arguments that have a lower precedence or
       equal precendence if they are a right argument. -}
  parenExpr :: Bool -> Maybe Int -> Expr -> String
  parenExpr rst mi e =
    let s = showExpr e
    in case e of
    GenExpr True op (_ : _ : _) ->
      let mj = findIndex (elem op) inOps
          putPar = case (mi, mj) of
             (Just i, Just j) -> i > j || rst && i == j
             _ -> True
      in if putPar then paren s else s
    _ -> s
  
  -- | test if expression is primary
  isPrimExpr :: Expr -> Bool
  isPrimExpr e = case e of
    PrimExpr _ _ -> True
    GenExpr False _ _ -> True
    _ -> False
  
  -- * infix operators
  
  -- | unequal (@!=@) and equal (@=@)
  eqOps :: [String]
  eqOps = ["!=", "="]
  
  -- | the four other comparisons
  relOps :: [String]
  relOps = ["<=", ">=", "<", ">"]
  
  -- | @+@ and @-@, where @-@ is allowed within names and as unary operator
  addOps :: [String]
  addOps = ["+", "-"]
  
  -- | @*@, div and mod, where @*@ is also used as wildcard for node names
  multOps :: [String]
  multOps = ["*", "div", "mod"]
  
  {- | all infix operators. Lowest precedence for @or@ followed by @and@,
  highest is union(@|@).  Only these three operators may get more than two
  arguments. -}
  inOps :: [[String]]
  inOps =
    [ ["or"]
    , ["and"]
    , eqOps
    , relOps
    , addOps
    , multOps
    , ["|"]]
  
  -- * parsers
  
  -- | skip trailing spaces
  skips :: Parser a -> Parser a
  skips = (<< spaces)
  
  -- | parse keyword and skip spaces
  symbol :: String -> Parser String
  symbol = skips . tryString
  
  -- | skip left paren
  lpar :: Parser ()
  lpar = forget (symbol "(")
  
  -- | skip right paren
  rpar :: Parser ()
  rpar = forget (symbol ")")
  
  -- | non-abbreviated axis parser
  axis :: Parser Axis
  axis = choice (map (\ a -> symbol (showAxis a) >> return a) allAxis)
    <?> "axis"
  
  -- | the axis specifier parser
  abbrAxis :: Parser Axis
  abbrAxis =
    (symbol "@" >> return Attribute)
    <|> try (axis << symbol "::")
    <|> return Child
    <?> "abbrAxis"
  
  -- | starting name character (no unicode)
  ncNameStart :: Char -> Bool
  ncNameStart c = isAlpha c || c == '_'
  
  -- | name character (without @+@) including centered dot (and no other unicode)
  ncNameChar :: Char -> Bool
  ncNameChar c = isAlphaNum c || elem c ".-_\183"
  
  -- | non-colon xml names (non-skipping)
  ncName :: Parser String
  ncName = satisfy ncNameStart <:> many (satisfy ncNameChar) <?> "ncName"
  
  -- | literal string within single or double quotes (skipping)
  literal :: Parser String
  literal = skips $
    (char '"' >> many (satisfy (/= '"')) << string "\"")
    <|> (char '\'' >> many (satisfy (/= '\'')) << string "'")
  
  -- | ncName or wild-card (@*@) (skipping)
  localName :: Parser String
  localName = symbol "*" <|> skips ncName <?> "localName"
  
  -- | the node test parser
  nodeTest :: Parser NodeTest
  nodeTest = fmap PI (symbol pIS >> lpar >> literal << rpar)
    <|> choice (map (\ t -> symbol (lowerShow t)
                     >> lpar >> rpar >> return t) nodeTypes)
    <|> do
      p <- try (ncName <++> string ":")
      l <- localName
      return $ NameTest $ p ++ l
    <|> do
      l <- localName
      return $ NameTest l
    <?> "nodeTest"
  
  -- | parent or self abbreviated steps
  abbrStep :: Parser Step
  abbrStep =
    (symbol ".." >> return (Step Parent Node []))
    <|> (symbol "." >> return (Step Self Node []))
    <?> "abbrStep"
  
  -- | the predicate (expression in square brackets) parser
  predicate :: Parser Expr
  predicate = symbol "[" >> expr << symbol "]" <?> "predicate"
  
  -- | the step (stuff between slashes) parser
  step :: Parser Step
  step = abbrStep <|> do
    a <- abbrAxis
    t <- nodeTest
    ps <- many predicate
    return (Step a t ps)
    <?> "step"
  
  -- | the implicit @descendant-or-self::node()@ step constant
  descOrSelfStep :: Step
  descOrSelfStep = Step (Descendant True) Node []
  
  -- | a double or single slash
  doubleSlash :: Parser Bool
  doubleSlash = (symbol "//" >> return True) <|> (symbol "/" >> return False)
  
  {- | a step starting with a single or double slash,
       the latter yielding two steps. -}
  slashStep :: Parser [Step]
  slashStep = do
    b <- doubleSlash
    s <- step
    return (if b then [descOrSelfStep, s] else [s])
    <?> "slashStep"
  
  -- | parse the steps of a relative path
  relPath :: Parser [Step]
  relPath = do
    s <- step
    sl <- many slashStep
    return (s : concat sl)
    <?> "relPath"
  
  -- | a (possibly empty) absolute or (non-empty) relative path
  path :: Parser Path
  path = do
      m <- optionMaybe doubleSlash
      s <- (case m of
        Just False -> optionL
        _ -> id) relPath
      return (case m of
        Nothing -> Path False s
        Just b -> Path True $ if b then descOrSelfStep : s else s)
      <?> "path"
  
  -- | at least one digit and at most one decimal point (skipping)
  number :: Parser String
  number = skips $ many1 digit <++> optionL (char '.' <:> many digit)
    <|> try (char '.' <:> many1 digit)
  
  -- | a qualified name (prefixed or unprefixed)
  qualName :: Parser String
  qualName = skips $ ncName <++> optionL (char ':' <:> ncName)
  
  -- | parse a primary expression (including 'fct' or 'expr' in parens)
  primExpr :: Parser Expr
  primExpr = fmap (PrimExpr Var) (char '$' <:> qualName)
    <|> (lpar >> expr << rpar)
    <|> fmap (PrimExpr Literal) literal
    <|> fmap (PrimExpr Number) number
    <|> fct
  
  -- | parse a function call by checking the qname and the left paren
  fct :: Parser Expr
  fct = do
    q <- try $ do
      n <- qualName
      if elem n $ pIS : map lowerShow nodeTypes
        then Fail.fail $ n ++ " not allowed as function name"
        else lpar >> return n
    args <- sepBy expr (symbol ",")
    rpar
    return $ GenExpr False q args
  
  -- | parse a filter expresssion as primary expression followed by predicates
  filterExpr :: Parser Expr
  filterExpr = do
    e <- primExpr
    ps <- many predicate
    return $ if null ps then e else FilterExpr e ps
  
  {- | a path expression is either a filter expression followed by a (non-empty)
       absoulte path or an ordinary 'path'. -}
  pathExpr :: Parser Expr
  pathExpr = do
      f <- filterExpr
      s <- optionL $ do
        b <- doubleSlash
        r <- relPath
        return $ if b then descOrSelfStep : r else r
      return $ if null s then f else PathExpr (Just f) $ Path True s
    <|> fmap (PathExpr Nothing) path
  
  -- | parse multiple argument expressions separated by an infix symbol
  singleInfixExpr :: Parser Expr -> String -> Parser Expr
  singleInfixExpr p s = do
    l <- sepBy1 p $ symbol s
    return $ case l of
      [e] -> e
      _ -> GenExpr True s l
  
  -- | 'pathExpr' are arguments of union expression
  unionExpr :: Parser Expr
  unionExpr = singleInfixExpr pathExpr "|"
  
  -- | 'unionExpr' can be prefixed by the unary minus
  unaryExpr :: Parser Expr
  unaryExpr = fmap (GenExpr True "-" . (: [])) (symbol "-" >> unaryExpr)
    <|> unionExpr
  
  {- | parse as many arguments separated by any infix symbol as possible
       but construct left-associative binary application trees. -}
  leftAssocExpr :: Parser Expr -> [String] -> Parser Expr
  leftAssocExpr p ops =
    chainl1 p $ do
      op <- choice $ map symbol ops
      return $ \ a b -> GenExpr True op [a, b]
  
  -- * all final infix parsers using 'leftAssocExpr' or 'singleInfixExpr'
  
  multExpr :: Parser Expr
  multExpr = leftAssocExpr unaryExpr multOps
  
  addExpr :: Parser Expr
  addExpr = leftAssocExpr multExpr addOps
  
  relExpr :: Parser Expr
  relExpr = leftAssocExpr addExpr relOps
  
  eqExpr :: Parser Expr
  eqExpr = leftAssocExpr relExpr eqOps
  
  andExpr :: Parser Expr
  andExpr = singleInfixExpr eqExpr "and"
  
  -- | the top-level expressions interspersed by @or@.
  expr :: Parser Expr
  expr = singleInfixExpr andExpr "or"
  
  -- * checking sanity of paths
  
  data PrincipalNodeType
    = TAttribute
    | TNamespace
    | TElement
      deriving Eq
  
  principalNodeType :: Axis -> PrincipalNodeType
  principalNodeType a = case a of
    Attribute -> TAttribute
    Namespace -> TNamespace
    _ -> TElement
  
  -- | may this step have further steps
  isElementNode :: Step -> Bool
  isElementNode (Step a t _) =
    principalNodeType a == TElement && case t of
    Node -> True
    NameTest _ -> True
    _ -> False
  
  isLegalPath :: [Step] -> Bool
  isLegalPath l = case l of
    [] -> True
    [_] -> True
    s : r -> isElementNode s && isLegalPath r
  
  finalStep :: Path -> Maybe Step
  finalStep (Path _ l) = case l of
    [] -> Nothing
    _ -> Just $ last l
  
  finalPrincipalNodeType :: Path -> PrincipalNodeType
  finalPrincipalNodeType p = case finalStep p of
    Nothing -> TElement
    Just (Step a _ _) -> principalNodeType a
  
  data BasicType
    = NodeSet
    | Boolean
    | Numeral
    | String
    | Object
  
  type FctEnv = [(String, (BasicType, [BasicType]))]
  
  type VarEnv = [(String, BasicType)]
  
  coreFcts :: FctEnv
  coreFcts =
    [ ("last", (Numeral, []))
    , ("position", (Numeral, []))
    , ("count", (Numeral, [NodeSet]))
    , ("id", (NodeSet, [Object]))
    , ("local-name", (String, [NodeSet]))
    , ("namespace-uri", (String, [NodeSet]))
    , ("name", (String, [NodeSet]))
    , ("string", (String, [Object]))
    , ("concat", (String, [String, String]))
    , ("substring-before", (String, [String, String]))
    , ("substring-after", (String, [String, String]))
    , ("substring", (String, [String, Numeral, Numeral]))
    , ("starts-with", (Boolean, [String, String]))
    , ("contains", (Boolean, [String, String]))
    , ("string-length", (Numeral, [String]))
    , ("normalize-space", (String, [String]))
    , ("translate", (String, [String, String, String]))
    , ("boolean", (Boolean, [Object]))
    , ("not", (Boolean, [Boolean]))
    , ("true", (Boolean, []))
    , ("false", (Boolean, []))
    , ("lang", (Boolean, [String]))
    , ("number", (Numeral, [Object]))
    , ("sum", (Numeral, [NodeSet]))
    , ("floor", (Numeral, [Numeral]))
    , ("ceiling", (Numeral, [Numeral]))
    , ("round", (Numeral, [Numeral]))
    ]
  
  basicType :: Expr -> BasicType
  basicType e = case e of
    GenExpr infx op _ ->
      if infx then case op of
         "|" -> NodeSet
         _ | elem op $ ["or", "and"] ++ eqOps ++ relOps -> Boolean
           | elem op $ addOps ++ multOps -> Numeral
         _ -> Object
      else case lookup op coreFcts of
             Just (t, _) -> t
             Nothing -> Object
    PrimExpr k _ -> case k of
      Number -> Numeral
      Literal -> String
      Var -> Object
    _ -> NodeSet
  
  isPathExpr :: Expr -> Bool
  isPathExpr e = case e of
    GenExpr True "|" args -> all isPathExpr args
    GenExpr False "id" [_] -> True
    PrimExpr Var _ -> True
    PathExpr m (Path _ s) -> isLegalPath s && maybe True isPathExpr m
    FilterExpr p _ -> isPathExpr p
    _ -> False
  
  -- | parse string
  parseExpr :: String -> Either String Expr
  parseExpr s = case parse (expr << eof) "" s of
    Right e | isPathExpr e -> Right e
    Left e -> Left $ show e
    _ -> Left "not a legal path expression"
  
  getPaths :: Expr -> [Path]
  getPaths e = case e of
    GenExpr True "|" args -> concatMap getPaths args
    PathExpr m p@(Path _ s) -> case m of
      Nothing -> [p]
      Just fe -> map (\ (Path r f) -> Path r $ f ++ s) $ getPaths fe
    FilterExpr p _ -> getPaths p
    _ -> []
  