{- |
Module      :  $Header$
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

-- * 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 $ 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
  _ -> []
