{- |
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 Int -> Axis -> ShowS
[Axis] -> ShowS
Axis -> String
(Int -> Axis -> ShowS)
-> (Axis -> String) -> ([Axis] -> ShowS) -> Show Axis
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Axis] -> ShowS
$cshowList :: [Axis] -> ShowS
show :: Axis -> String
$cshow :: Axis -> String
showsPrec :: Int -> Axis -> ShowS
$cshowsPrec :: Int -> Axis -> ShowS
Show

-- | all possible values
allAxis :: [Axis]
allAxis :: [Axis]
allAxis = let bl :: [Bool]
bl = [Bool
True, Bool
False] in
  [ Axis
Attribute
  , Axis
Child
  , Axis
Namespace
  , Axis
Parent
  , Axis
Self ]
  [Axis] -> [Axis] -> [Axis]
forall a. [a] -> [a] -> [a]
++ [ Bool -> Axis
Ancestor Bool
b | Bool
b <- [Bool]
bl ]
  [Axis] -> [Axis] -> [Axis]
forall a. [a] -> [a] -> [a]
++ [ Bool -> Axis
Descendant Bool
b | Bool
b <- [Bool]
bl ]
  [Axis] -> [Axis] -> [Axis]
forall a. [a] -> [a] -> [a]
++ [ Bool -> Axis
Following Bool
b | Bool
b <- [Bool]
bl ]
  [Axis] -> [Axis] -> [Axis]
forall a. [a] -> [a] -> [a]
++ [ Bool -> Axis
Preceding Bool
b | Bool
b <- [Bool]
bl ]

-- | utility to show (constant) constructors as lower case strings
lowerShow :: Show a => a -> String
lowerShow :: a -> String
lowerShow = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | proper string representation (do not use show)
showAxis :: Axis -> String
showAxis :: Axis -> String
showAxis a :: Axis
a =
  let s :: String
s = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlpha ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Axis -> String
forall a. Show a => a -> String
lowerShow Axis
a
      orSelf :: Bool -> String
orSelf b :: Bool
b = if Bool
b then String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "-or-self" else String
s
      sibl :: Bool -> String
sibl b :: Bool
b = if Bool
b then String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "-sibling" else String
s
  in case Axis
a of
  Ancestor c :: Bool
c -> Bool -> String
orSelf Bool
c
  Descendant c :: Bool
c -> Bool -> String
orSelf Bool
c
  Following c :: Bool
c -> Bool -> String
sibl Bool
c
  Preceding c :: Bool
c -> Bool -> String
sibl Bool
c
  _ -> String
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 Int -> NodeTest -> ShowS
[NodeTest] -> ShowS
NodeTest -> String
(Int -> NodeTest -> ShowS)
-> (NodeTest -> String) -> ([NodeTest] -> ShowS) -> Show NodeTest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeTest] -> ShowS
$cshowList :: [NodeTest] -> ShowS
show :: NodeTest -> String
$cshow :: NodeTest -> String
showsPrec :: Int -> NodeTest -> ShowS
$cshowsPrec :: Int -> NodeTest -> ShowS
Show

-- | all node types without processing-instruction
nodeTypes :: [NodeTest]
nodeTypes :: [NodeTest]
nodeTypes = [NodeTest
Node, NodeTest
Comment, NodeTest
Text]

-- | the processing-instruction string
pIS :: String
pIS :: String
pIS = "processing-instruction"

-- | put parens arount a string
paren :: String -> String
paren :: ShowS
paren = ('(' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")")

-- | proper string representation (do not use show)
showNodeTest :: NodeTest -> String
showNodeTest :: NodeTest -> String
showNodeTest t :: NodeTest
t = case NodeTest
t of
  NameTest q :: String
q -> String
q
  PI s :: String
s -> String
pIS String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
paren String
s
  _ -> NodeTest -> String
forall a. Show a => a -> String
lowerShow NodeTest
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
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 -> String
showStep (Step a :: Axis
a n :: NodeTest
n ps :: [Expr]
ps) =
  let t :: String
t = NodeTest -> String
showNodeTest NodeTest
n in
  case (Axis
a, NodeTest
n) of
     (Attribute, _) -> '@' Char -> ShowS
forall a. a -> [a] -> [a]
: String
t
     (Child, _) -> String
t
     (Self, Node) -> "."
     (Parent, Node) -> ".."
     _ -> Axis -> String
showAxis Axis
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ "::" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Expr -> String) -> [Expr] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr -> String
showPred [Expr]
ps

instance Show Step where
  show :: Step -> String
show = Step -> String
showStep

-- | test for @descendant-or-self::node()@ step
isDescOrSelfNode :: Step -> Bool
isDescOrSelfNode :: Step -> Bool
isDescOrSelfNode (Step a :: Axis
a n :: NodeTest
n _) = case (Axis
a, NodeTest
n) of
  (Descendant True, Node) -> Bool
True
  _ -> Bool
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 :: Bool -> [Step] -> String
showSteps abso :: Bool
abso sts :: [Step]
sts = let h :: String
h = if Bool
abso then "/" else "" in case [Step]
sts of
  [] -> String
h
  s :: Step
s : r :: [Step]
r -> let f :: String
f = String
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ Step -> String
showStep Step
s in case [Step]
r of
    [] -> String
f
    _ -> if Bool
abso Bool -> Bool -> Bool
&& Step -> Bool
isDescOrSelfNode Step
s then "//" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> [Step] -> String
showSteps Bool
False [Step]
r
         else String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ Bool -> [Step] -> String
showSteps Bool
True [Step]
r

instance Show Path where
  show :: Path -> String
show (Path abso :: Bool
abso sts :: [Step]
sts) = Bool -> [Step] -> String
showSteps Bool
abso [Step]
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 :: Expr -> String
show = Expr -> String
showExpr

-- | put square brackets around an expression
showPred :: Expr -> String
showPred :: Expr -> String
showPred e :: Expr
e = '[' Char -> ShowS
forall a. a -> [a] -> [a]
: Expr -> String
showExpr Expr
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ "]"

-- | show expression with minimal parens
showExpr :: Expr -> String
showExpr :: Expr -> String
showExpr e :: Expr
e = case Expr
e of
  GenExpr infx :: Bool
infx op :: String
op args :: [Expr]
args ->
    if Bool
infx then
        String -> [Expr] -> String
showInfixExpr String
op [Expr]
args
    else String
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
paren (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Expr -> String) -> [Expr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> String
showExpr [Expr]
args)
  PathExpr m :: Maybe Expr
m p :: Path
p -> case Maybe Expr
m of
      Nothing -> ""
      Just f :: Expr
f -> Expr -> String
showExpr Expr
f
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path -> String
forall a. Show a => a -> String
show Path
p
  FilterExpr pe :: Expr
pe ps :: [Expr]
ps ->
    (if Expr -> Bool
isPrimExpr Expr
pe then ShowS
forall a. a -> a
id else ShowS
paren) (Expr -> String
showExpr Expr
pe)
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Expr -> String) -> [Expr] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr -> String
showPred [Expr]
ps
  PrimExpr k :: PrimKind
k s :: String
s -> case PrimKind
k of
     Literal -> ShowS
forall a. Show a => a -> String
show ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '"') String
s
     _ -> String
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 :: String -> [Expr] -> String
showInfixExpr op :: String
op args :: [Expr]
args = case [Expr]
args of
  [] -> String
op -- cannot happen
  [arg :: Expr
arg] -> -- unary minus
    let s :: String
s = Expr -> String
showExpr Expr
arg
    in String
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ case Expr
arg of
       GenExpr True aOp :: String
aOp _ -> case String
aOp of
         "|" -> String
s
         _ -> ShowS
paren String
s
       _ -> String
s
  arg :: Expr
arg : rargs :: [Expr]
rargs ->
    let mi :: Maybe Int
mi = ([String] -> Bool) -> [[String]] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
op) [[String]]
inOps
        f :: String
f = Bool -> Maybe Int -> Expr -> String
parenExpr Bool
False Maybe Int
mi Expr
arg
        padOp :: String
padOp
          | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isAlpha String
op = ' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
op String -> ShowS
forall a. [a] -> [a] -> [a]
++ " "
          | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
op [String]
addOps Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
f) Bool -> Bool -> Bool
&& Char -> Bool
ncNameChar (String -> Char
forall a. [a] -> a
last String
f) = ' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
op
          | Bool
otherwise = String
op
    in String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Expr -> String) -> [Expr] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String
padOp String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Expr -> String) -> Expr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Maybe Int -> Expr -> String
parenExpr Bool
True Maybe Int
mi) [Expr]
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 :: Bool -> Maybe Int -> Expr -> String
parenExpr rst :: Bool
rst mi :: Maybe Int
mi e :: Expr
e =
  let s :: String
s = Expr -> String
showExpr Expr
e
  in case Expr
e of
  GenExpr True op :: String
op (_ : _ : _) ->
    let mj :: Maybe Int
mj = ([String] -> Bool) -> [[String]] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
op) [[String]]
inOps
        putPar :: Bool
putPar = case (Maybe Int
mi, Maybe Int
mj) of
           (Just i :: Int
i, Just j :: Int
j) -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
j Bool -> Bool -> Bool
|| Bool
rst Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j
           _ -> Bool
True
    in if Bool
putPar then ShowS
paren String
s else String
s
  _ -> String
s

-- | test if expression is primary
isPrimExpr :: Expr -> Bool
isPrimExpr :: Expr -> Bool
isPrimExpr e :: Expr
e = case Expr
e of
  PrimExpr _ _ -> Bool
True
  GenExpr False _ _ -> Bool
True
  _ -> Bool
False

-- * infix operators

-- | unequal (@!=@) and equal (@=@)
eqOps :: [String]
eqOps :: [String]
eqOps = ["!=", "="]

-- | the four other comparisons
relOps :: [String]
relOps :: [String]
relOps = ["<=", ">=", "<", ">"]

-- | @+@ and @-@, where @-@ is allowed within names and as unary operator
addOps :: [String]
addOps :: [String]
addOps = ["+", "-"]

-- | @*@, div and mod, where @*@ is also used as wildcard for node names
multOps :: [String]
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 :: [[String]]
inOps =
  [ ["or"]
  , ["and"]
  , [String]
eqOps
  , [String]
relOps
  , [String]
addOps
  , [String]
multOps
  , ["|"]]

-- * parsers

-- | skip trailing spaces
skips :: Parser a -> Parser a
skips :: Parser a -> Parser a
skips = (Parser a -> ParsecT String () Identity () -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces)

-- | parse keyword and skip spaces
symbol :: String -> Parser String
symbol :: String -> Parser String
symbol = Parser String -> Parser String
forall a. Parser a -> Parser a
skips (Parser String -> Parser String)
-> (String -> Parser String) -> String -> Parser String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Parser String
forall st. String -> CharParser st String
tryString

-- | skip left paren
lpar :: Parser ()
lpar :: ParsecT String () Identity ()
lpar = Parser String -> ParsecT String () Identity ()
forall (m :: * -> *) a. Monad m => m a -> m ()
forget (String -> Parser String
symbol "(")

-- | skip right paren
rpar :: Parser ()
rpar :: ParsecT String () Identity ()
rpar = Parser String -> ParsecT String () Identity ()
forall (m :: * -> *) a. Monad m => m a -> m ()
forget (String -> Parser String
symbol ")")

-- | non-abbreviated axis parser
axis :: Parser Axis
axis :: Parser Axis
axis = [Parser Axis] -> Parser Axis
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ((Axis -> Parser Axis) -> [Axis] -> [Parser Axis]
forall a b. (a -> b) -> [a] -> [b]
map (\ a :: Axis
a -> String -> Parser String
symbol (Axis -> String
showAxis Axis
a) Parser String -> Parser Axis -> Parser Axis
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Axis -> Parser Axis
forall (m :: * -> *) a. Monad m => a -> m a
return Axis
a) [Axis]
allAxis)
  Parser Axis -> String -> Parser Axis
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "axis"

-- | the axis specifier parser
abbrAxis :: Parser Axis
abbrAxis :: Parser Axis
abbrAxis =
  (String -> Parser String
symbol "@" Parser String -> Parser Axis -> Parser Axis
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Axis -> Parser Axis
forall (m :: * -> *) a. Monad m => a -> m a
return Axis
Attribute)
  Parser Axis -> Parser Axis -> Parser Axis
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Axis -> Parser Axis
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser Axis
axis Parser Axis -> Parser String -> Parser Axis
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< String -> Parser String
symbol "::")
  Parser Axis -> Parser Axis -> Parser Axis
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Axis -> Parser Axis
forall (m :: * -> *) a. Monad m => a -> m a
return Axis
Child
  Parser Axis -> String -> Parser Axis
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "abbrAxis"

-- | starting name character (no unicode)
ncNameStart :: Char -> Bool
ncNameStart :: Char -> Bool
ncNameStart c :: Char
c = Char -> Bool
isAlpha Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'

-- | name character (without @+@) including centered dot (and no other unicode)
ncNameChar :: Char -> Bool
ncNameChar :: Char -> Bool
ncNameChar c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c ".-_\183"

-- | non-colon xml names (non-skipping)
ncName :: Parser String
ncName :: Parser String
ncName = (Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
ncNameStart ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a. Monad m => m a -> m [a] -> m [a]
<:> ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
ncNameChar) Parser String -> String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "ncName"

-- | literal string within single or double quotes (skipping)
literal :: Parser String
literal :: Parser String
literal = Parser String -> Parser String
forall a. Parser a -> Parser a
skips (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$
  (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '"' ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '"')) Parser String -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string "\"")
  Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '\'' ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\'')) Parser String -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string "'")

-- | ncName or wild-card (@*@) (skipping)
localName :: Parser String
localName :: Parser String
localName = String -> Parser String
symbol "*" Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser String -> Parser String
forall a. Parser a -> Parser a
skips Parser String
ncName Parser String -> String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "localName"

-- | the node test parser
nodeTest :: Parser NodeTest
nodeTest :: Parser NodeTest
nodeTest = (String -> NodeTest) -> Parser String -> Parser NodeTest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> NodeTest
PI (String -> Parser String
symbol String
pIS Parser String
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity ()
lpar ParsecT String () Identity () -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
literal Parser String -> ParsecT String () Identity () -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< ParsecT String () Identity ()
rpar)
  Parser NodeTest -> Parser NodeTest -> Parser NodeTest
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Parser NodeTest] -> Parser NodeTest
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ((NodeTest -> Parser NodeTest) -> [NodeTest] -> [Parser NodeTest]
forall a b. (a -> b) -> [a] -> [b]
map (\ t :: NodeTest
t -> String -> Parser String
symbol (NodeTest -> String
forall a. Show a => a -> String
lowerShow NodeTest
t)
                   Parser String
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity ()
lpar ParsecT String () Identity ()
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity ()
rpar ParsecT String () Identity () -> Parser NodeTest -> Parser NodeTest
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> NodeTest -> Parser NodeTest
forall (m :: * -> *) a. Monad m => a -> m a
return NodeTest
t) [NodeTest]
nodeTypes)
  Parser NodeTest -> Parser NodeTest -> Parser NodeTest
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do
    String
p <- Parser String -> Parser String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser String
ncName Parser String -> Parser String -> Parser String
forall (m :: * -> *) a. Monad m => m [a] -> m [a] -> m [a]
<++> String -> Parser String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string ":")
    String
l <- Parser String
localName
    NodeTest -> Parser NodeTest
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeTest -> Parser NodeTest) -> NodeTest -> Parser NodeTest
forall a b. (a -> b) -> a -> b
$ String -> NodeTest
NameTest (String -> NodeTest) -> String -> NodeTest
forall a b. (a -> b) -> a -> b
$ String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
l
  Parser NodeTest -> Parser NodeTest -> Parser NodeTest
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do
    String
l <- Parser String
localName
    NodeTest -> Parser NodeTest
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeTest -> Parser NodeTest) -> NodeTest -> Parser NodeTest
forall a b. (a -> b) -> a -> b
$ String -> NodeTest
NameTest String
l
  Parser NodeTest -> String -> Parser NodeTest
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "nodeTest"

-- | parent or self abbreviated steps
abbrStep :: Parser Step
abbrStep :: Parser Step
abbrStep =
  (String -> Parser String
symbol ".." Parser String -> Parser Step -> Parser Step
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Step -> Parser Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Axis -> NodeTest -> [Expr] -> Step
Step Axis
Parent NodeTest
Node []))
  Parser Step -> Parser Step -> Parser Step
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Parser String
symbol "." Parser String -> Parser Step -> Parser Step
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Step -> Parser Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Axis -> NodeTest -> [Expr] -> Step
Step Axis
Self NodeTest
Node []))
  Parser Step -> String -> Parser Step
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "abbrStep"

-- | the predicate (expression in square brackets) parser
predicate :: Parser Expr
predicate :: Parser Expr
predicate = String -> Parser String
symbol "[" Parser String -> Parser Expr -> Parser Expr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Expr
expr Parser Expr -> Parser String -> Parser Expr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< String -> Parser String
symbol "]" Parser Expr -> String -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "predicate"

-- | the step (stuff between slashes) parser
step :: Parser Step
step :: Parser Step
step = Parser Step
abbrStep Parser Step -> Parser Step -> Parser Step
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> do
  Axis
a <- Parser Axis
abbrAxis
  NodeTest
t <- Parser NodeTest
nodeTest
  [Expr]
ps <- Parser Expr -> ParsecT String () Identity [Expr]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser Expr
predicate
  Step -> Parser Step
forall (m :: * -> *) a. Monad m => a -> m a
return (Axis -> NodeTest -> [Expr] -> Step
Step Axis
a NodeTest
t [Expr]
ps)
  Parser Step -> String -> Parser Step
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "step"

-- | the implicit @descendant-or-self::node()@ step constant
descOrSelfStep :: Step
descOrSelfStep :: Step
descOrSelfStep = Axis -> NodeTest -> [Expr] -> Step
Step (Bool -> Axis
Descendant Bool
True) NodeTest
Node []

-- | a double or single slash
doubleSlash :: Parser Bool
doubleSlash :: Parser Bool
doubleSlash = (String -> Parser String
symbol "//" Parser String -> Parser Bool -> Parser Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) Parser Bool -> Parser Bool -> Parser Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Parser String
symbol "/" Parser String -> Parser Bool -> Parser Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

{- | a step starting with a single or double slash,
     the latter yielding two steps. -}
slashStep :: Parser [Step]
slashStep :: Parser [Step]
slashStep = do
  Bool
b <- Parser Bool
doubleSlash
  Step
s <- Parser Step
step
  [Step] -> Parser [Step]
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
b then [Step
descOrSelfStep, Step
s] else [Step
s])
  Parser [Step] -> String -> Parser [Step]
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "slashStep"

-- | parse the steps of a relative path
relPath :: Parser [Step]
relPath :: Parser [Step]
relPath = do
  Step
s <- Parser Step
step
  [[Step]]
sl <- Parser [Step] -> ParsecT String () Identity [[Step]]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser [Step]
slashStep
  [Step] -> Parser [Step]
forall (m :: * -> *) a. Monad m => a -> m a
return (Step
s Step -> [Step] -> [Step]
forall a. a -> [a] -> [a]
: [[Step]] -> [Step]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Step]]
sl)
  Parser [Step] -> String -> Parser [Step]
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "relPath"

-- | a (possibly empty) absolute or (non-empty) relative path
path :: Parser Path
path :: Parser Path
path = do
    Maybe Bool
m <- Parser Bool -> ParsecT String () Identity (Maybe Bool)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe Parser Bool
doubleSlash
    [Step]
s <- (case Maybe Bool
m of
      Just False -> Parser [Step] -> Parser [Step]
forall tok st a. GenParser tok st [a] -> GenParser tok st [a]
optionL
      _ -> Parser [Step] -> Parser [Step]
forall a. a -> a
id) Parser [Step]
relPath
    Path -> Parser Path
forall (m :: * -> *) a. Monad m => a -> m a
return (case Maybe Bool
m of
      Nothing -> Bool -> [Step] -> Path
Path Bool
False [Step]
s
      Just b :: Bool
b -> Bool -> [Step] -> Path
Path Bool
True ([Step] -> Path) -> [Step] -> Path
forall a b. (a -> b) -> a -> b
$ if Bool
b then Step
descOrSelfStep Step -> [Step] -> [Step]
forall a. a -> [a] -> [a]
: [Step]
s else [Step]
s)
    Parser Path -> String -> Parser Path
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> "path"

-- | at least one digit and at most one decimal point (skipping)
number :: Parser String
number :: Parser String
number = Parser String -> Parser String
forall a. Parser a -> Parser a
skips (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit Parser String -> Parser String -> Parser String
forall (m :: * -> *) a. Monad m => m [a] -> m [a] -> m [a]
<++> Parser String -> Parser String
forall tok st a. GenParser tok st [a] -> GenParser tok st [a]
optionL (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '.' ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a. Monad m => m a -> m [a] -> m [a]
<:> ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)
  Parser String -> Parser String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser String -> Parser String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '.' ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a. Monad m => m a -> m [a] -> m [a]
<:> ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)

-- | a qualified name (prefixed or unprefixed)
qualName :: Parser String
qualName :: Parser String
qualName = Parser String -> Parser String
forall a. Parser a -> Parser a
skips (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser String
ncName Parser String -> Parser String -> Parser String
forall (m :: * -> *) a. Monad m => m [a] -> m [a] -> m [a]
<++> Parser String -> Parser String
forall tok st a. GenParser tok st [a] -> GenParser tok st [a]
optionL (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char ':' ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a. Monad m => m a -> m [a] -> m [a]
<:> Parser String
ncName)

-- | parse a primary expression (including 'fct' or 'expr' in parens)
primExpr :: Parser Expr
primExpr :: Parser Expr
primExpr = (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrimKind -> String -> Expr
PrimExpr PrimKind
Var) (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '$' ParsecT String () Identity Char -> Parser String -> Parser String
forall (m :: * -> *) a. Monad m => m a -> m [a] -> m [a]
<:> Parser String
qualName)
  Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (ParsecT String () Identity ()
lpar ParsecT String () Identity () -> Parser Expr -> Parser Expr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Expr
expr Parser Expr -> ParsecT String () Identity () -> Parser Expr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< ParsecT String () Identity ()
rpar)
  Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrimKind -> String -> Expr
PrimExpr PrimKind
Literal) Parser String
literal
  Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PrimKind -> String -> Expr
PrimExpr PrimKind
Number) Parser String
number
  Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
fct

-- | parse a function call by checking the qname and the left paren
fct :: Parser Expr
fct :: Parser Expr
fct = do
  String
q <- Parser String -> Parser String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ do
    String
n <- Parser String
qualName
    if String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
n ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ String
pIS String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (NodeTest -> String) -> [NodeTest] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NodeTest -> String
forall a. Show a => a -> String
lowerShow [NodeTest]
nodeTypes
      then String -> Parser String
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ " not allowed as function name"
      else ParsecT String () Identity ()
lpar ParsecT String () Identity () -> Parser String -> Parser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
n
  [Expr]
args <- Parser Expr -> Parser String -> ParsecT String () Identity [Expr]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy Parser Expr
expr (String -> Parser String
symbol ",")
  ParsecT String () Identity ()
rpar
  Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Bool -> String -> [Expr] -> Expr
GenExpr Bool
False String
q [Expr]
args

-- | parse a filter expresssion as primary expression followed by predicates
filterExpr :: Parser Expr
filterExpr :: Parser Expr
filterExpr = do
  Expr
e <- Parser Expr
primExpr
  [Expr]
ps <- Parser Expr -> ParsecT String () Identity [Expr]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many Parser Expr
predicate
  Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ if [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr]
ps then Expr
e else Expr -> [Expr] -> Expr
FilterExpr Expr
e [Expr]
ps

{- | a path expression is either a filter expression followed by a (non-empty)
     absoulte path or an ordinary 'path'. -}
pathExpr :: Parser Expr
pathExpr :: Parser Expr
pathExpr = do
    Expr
f <- Parser Expr
filterExpr
    [Step]
s <- Parser [Step] -> Parser [Step]
forall tok st a. GenParser tok st [a] -> GenParser tok st [a]
optionL (Parser [Step] -> Parser [Step]) -> Parser [Step] -> Parser [Step]
forall a b. (a -> b) -> a -> b
$ do
      Bool
b <- Parser Bool
doubleSlash
      [Step]
r <- Parser [Step]
relPath
      [Step] -> Parser [Step]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Step] -> Parser [Step]) -> [Step] -> Parser [Step]
forall a b. (a -> b) -> a -> b
$ if Bool
b then Step
descOrSelfStep Step -> [Step] -> [Step]
forall a. a -> [a] -> [a]
: [Step]
r else [Step]
r
    Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ if [Step] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Step]
s then Expr
f else Maybe Expr -> Path -> Expr
PathExpr (Expr -> Maybe Expr
forall a. a -> Maybe a
Just Expr
f) (Path -> Expr) -> Path -> Expr
forall a b. (a -> b) -> a -> b
$ Bool -> [Step] -> Path
Path Bool
True [Step]
s
  Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Path -> Expr) -> Parser Path -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Expr -> Path -> Expr
PathExpr Maybe Expr
forall a. Maybe a
Nothing) Parser Path
path

-- | parse multiple argument expressions separated by an infix symbol
singleInfixExpr :: Parser Expr -> String -> Parser Expr
singleInfixExpr :: Parser Expr -> String -> Parser Expr
singleInfixExpr p :: Parser Expr
p s :: String
s = do
  [Expr]
l <- Parser Expr -> Parser String -> ParsecT String () Identity [Expr]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy1 Parser Expr
p (Parser String -> ParsecT String () Identity [Expr])
-> Parser String -> ParsecT String () Identity [Expr]
forall a b. (a -> b) -> a -> b
$ String -> Parser String
symbol String
s
  Expr -> Parser Expr
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ case [Expr]
l of
    [e :: Expr
e] -> Expr
e
    _ -> Bool -> String -> [Expr] -> Expr
GenExpr Bool
True String
s [Expr]
l

-- | 'pathExpr' are arguments of union expression
unionExpr :: Parser Expr
unionExpr :: Parser Expr
unionExpr = Parser Expr -> String -> Parser Expr
singleInfixExpr Parser Expr
pathExpr "|"

-- | 'unionExpr' can be prefixed by the unary minus
unaryExpr :: Parser Expr
unaryExpr :: Parser Expr
unaryExpr = (Expr -> Expr) -> Parser Expr -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> String -> [Expr] -> Expr
GenExpr Bool
True "-" ([Expr] -> Expr) -> (Expr -> [Expr]) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: [])) (String -> Parser String
symbol "-" Parser String -> Parser Expr -> Parser Expr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Expr
unaryExpr)
  Parser Expr -> Parser Expr -> Parser Expr
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parser Expr
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 :: Parser Expr -> [String] -> Parser Expr
leftAssocExpr p :: Parser Expr
p ops :: [String]
ops =
  Parser Expr
-> ParsecT String () Identity (Expr -> Expr -> Expr) -> Parser Expr
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
chainl1 Parser Expr
p (ParsecT String () Identity (Expr -> Expr -> Expr) -> Parser Expr)
-> ParsecT String () Identity (Expr -> Expr -> Expr) -> Parser Expr
forall a b. (a -> b) -> a -> b
$ do
    String
op <- [Parser String] -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice ([Parser String] -> Parser String)
-> [Parser String] -> Parser String
forall a b. (a -> b) -> a -> b
$ (String -> Parser String) -> [String] -> [Parser String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Parser String
symbol [String]
ops
    (Expr -> Expr -> Expr)
-> ParsecT String () Identity (Expr -> Expr -> Expr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expr -> Expr -> Expr)
 -> ParsecT String () Identity (Expr -> Expr -> Expr))
-> (Expr -> Expr -> Expr)
-> ParsecT String () Identity (Expr -> Expr -> Expr)
forall a b. (a -> b) -> a -> b
$ \ a :: Expr
a b :: Expr
b -> Bool -> String -> [Expr] -> Expr
GenExpr Bool
True String
op [Expr
a, Expr
b]

-- * all final infix parsers using 'leftAssocExpr' or 'singleInfixExpr'

multExpr :: Parser Expr
multExpr :: Parser Expr
multExpr = Parser Expr -> [String] -> Parser Expr
leftAssocExpr Parser Expr
unaryExpr [String]
multOps

addExpr :: Parser Expr
addExpr :: Parser Expr
addExpr = Parser Expr -> [String] -> Parser Expr
leftAssocExpr Parser Expr
multExpr [String]
addOps

relExpr :: Parser Expr
relExpr :: Parser Expr
relExpr = Parser Expr -> [String] -> Parser Expr
leftAssocExpr Parser Expr
addExpr [String]
relOps

eqExpr :: Parser Expr
eqExpr :: Parser Expr
eqExpr = Parser Expr -> [String] -> Parser Expr
leftAssocExpr Parser Expr
relExpr [String]
eqOps

andExpr :: Parser Expr
andExpr :: Parser Expr
andExpr = Parser Expr -> String -> Parser Expr
singleInfixExpr Parser Expr
eqExpr "and"

-- | the top-level expressions interspersed by @or@.
expr :: Parser Expr
expr :: Parser Expr
expr = Parser Expr -> String -> Parser Expr
singleInfixExpr Parser Expr
andExpr "or"

-- * checking sanity of paths

data PrincipalNodeType
  = TAttribute
  | TNamespace
  | TElement
    deriving PrincipalNodeType -> PrincipalNodeType -> Bool
(PrincipalNodeType -> PrincipalNodeType -> Bool)
-> (PrincipalNodeType -> PrincipalNodeType -> Bool)
-> Eq PrincipalNodeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrincipalNodeType -> PrincipalNodeType -> Bool
$c/= :: PrincipalNodeType -> PrincipalNodeType -> Bool
== :: PrincipalNodeType -> PrincipalNodeType -> Bool
$c== :: PrincipalNodeType -> PrincipalNodeType -> Bool
Eq

principalNodeType :: Axis -> PrincipalNodeType
principalNodeType :: Axis -> PrincipalNodeType
principalNodeType a :: Axis
a = case Axis
a of
  Attribute -> PrincipalNodeType
TAttribute
  Namespace -> PrincipalNodeType
TNamespace
  _ -> PrincipalNodeType
TElement

-- | may this step have further steps
isElementNode :: Step -> Bool
isElementNode :: Step -> Bool
isElementNode (Step a :: Axis
a t :: NodeTest
t _) =
  Axis -> PrincipalNodeType
principalNodeType Axis
a PrincipalNodeType -> PrincipalNodeType -> Bool
forall a. Eq a => a -> a -> Bool
== PrincipalNodeType
TElement Bool -> Bool -> Bool
&& case NodeTest
t of
  Node -> Bool
True
  NameTest _ -> Bool
True
  _ -> Bool
False

isLegalPath :: [Step] -> Bool
isLegalPath :: [Step] -> Bool
isLegalPath l :: [Step]
l = case [Step]
l of
  [] -> Bool
True
  [_] -> Bool
True
  s :: Step
s : r :: [Step]
r -> Step -> Bool
isElementNode Step
s Bool -> Bool -> Bool
&& [Step] -> Bool
isLegalPath [Step]
r

finalStep :: Path -> Maybe Step
finalStep :: Path -> Maybe Step
finalStep (Path _ l :: [Step]
l) = case [Step]
l of
  [] -> Maybe Step
forall a. Maybe a
Nothing
  _ -> Step -> Maybe Step
forall a. a -> Maybe a
Just (Step -> Maybe Step) -> Step -> Maybe Step
forall a b. (a -> b) -> a -> b
$ [Step] -> Step
forall a. [a] -> a
last [Step]
l

finalPrincipalNodeType :: Path -> PrincipalNodeType
finalPrincipalNodeType :: Path -> PrincipalNodeType
finalPrincipalNodeType p :: Path
p = case Path -> Maybe Step
finalStep Path
p of
  Nothing -> PrincipalNodeType
TElement
  Just (Step a :: Axis
a _ _) -> Axis -> PrincipalNodeType
principalNodeType Axis
a

data BasicType
  = NodeSet
  | Boolean
  | Numeral
  | String
  | Object

type FctEnv = [(String, (BasicType, [BasicType]))]

type VarEnv = [(String, BasicType)]

coreFcts :: FctEnv
coreFcts :: FctEnv
coreFcts =
  [ ("last", (BasicType
Numeral, []))
  , ("position", (BasicType
Numeral, []))
  , ("count", (BasicType
Numeral, [BasicType
NodeSet]))
  , ("id", (BasicType
NodeSet, [BasicType
Object]))
  , ("local-name", (BasicType
String, [BasicType
NodeSet]))
  , ("namespace-uri", (BasicType
String, [BasicType
NodeSet]))
  , ("name", (BasicType
String, [BasicType
NodeSet]))
  , ("string", (BasicType
String, [BasicType
Object]))
  , ("concat", (BasicType
String, [BasicType
String, BasicType
String]))
  , ("substring-before", (BasicType
String, [BasicType
String, BasicType
String]))
  , ("substring-after", (BasicType
String, [BasicType
String, BasicType
String]))
  , ("substring", (BasicType
String, [BasicType
String, BasicType
Numeral, BasicType
Numeral]))
  , ("starts-with", (BasicType
Boolean, [BasicType
String, BasicType
String]))
  , ("contains", (BasicType
Boolean, [BasicType
String, BasicType
String]))
  , ("string-length", (BasicType
Numeral, [BasicType
String]))
  , ("normalize-space", (BasicType
String, [BasicType
String]))
  , ("translate", (BasicType
String, [BasicType
String, BasicType
String, BasicType
String]))
  , ("boolean", (BasicType
Boolean, [BasicType
Object]))
  , ("not", (BasicType
Boolean, [BasicType
Boolean]))
  , ("true", (BasicType
Boolean, []))
  , ("false", (BasicType
Boolean, []))
  , ("lang", (BasicType
Boolean, [BasicType
String]))
  , ("number", (BasicType
Numeral, [BasicType
Object]))
  , ("sum", (BasicType
Numeral, [BasicType
NodeSet]))
  , ("floor", (BasicType
Numeral, [BasicType
Numeral]))
  , ("ceiling", (BasicType
Numeral, [BasicType
Numeral]))
  , ("round", (BasicType
Numeral, [BasicType
Numeral]))
  ]

basicType :: Expr -> BasicType
basicType :: Expr -> BasicType
basicType e :: Expr
e = case Expr
e of
  GenExpr infx :: Bool
infx op :: String
op _ ->
    if Bool
infx then case String
op of
       "|" -> BasicType
NodeSet
       _ | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
op ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ ["or", "and"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
eqOps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
relOps -> BasicType
Boolean
         | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
op ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ [String]
addOps [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
multOps -> BasicType
Numeral
       _ -> BasicType
Object
    else case String -> FctEnv -> Maybe (BasicType, [BasicType])
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
op FctEnv
coreFcts of
           Just (t :: BasicType
t, _) -> BasicType
t
           Nothing -> BasicType
Object
  PrimExpr k :: PrimKind
k _ -> case PrimKind
k of
    Number -> BasicType
Numeral
    Literal -> BasicType
String
    Var -> BasicType
Object
  _ -> BasicType
NodeSet

isPathExpr :: Expr -> Bool
isPathExpr :: Expr -> Bool
isPathExpr e :: Expr
e = case Expr
e of
  GenExpr True "|" args :: [Expr]
args -> (Expr -> Bool) -> [Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr -> Bool
isPathExpr [Expr]
args
  GenExpr False "id" [_] -> Bool
True
  PrimExpr Var _ -> Bool
True
  PathExpr m :: Maybe Expr
m (Path _ s :: [Step]
s) -> [Step] -> Bool
isLegalPath [Step]
s Bool -> Bool -> Bool
&& Bool -> (Expr -> Bool) -> Maybe Expr -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Expr -> Bool
isPathExpr Maybe Expr
m
  FilterExpr p :: Expr
p _ -> Expr -> Bool
isPathExpr Expr
p
  _ -> Bool
False

-- | parse string
parseExpr :: String -> Either String Expr
parseExpr :: String -> Either String Expr
parseExpr s :: String
s = case Parser Expr -> String -> String -> Either ParseError Expr
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (Parser Expr
expr Parser Expr -> ParsecT String () Identity () -> Parser Expr
forall (m :: * -> *) a b. Monad m => m a -> m b -> m a
<< ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) "" String
s of
  Right e :: Expr
e | Expr -> Bool
isPathExpr Expr
e -> Expr -> Either String Expr
forall a b. b -> Either a b
Right Expr
e
  Left e :: ParseError
e -> String -> Either String Expr
forall a b. a -> Either a b
Left (String -> Either String Expr) -> String -> Either String Expr
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
e
  _ -> String -> Either String Expr
forall a b. a -> Either a b
Left "not a legal path expression"

getPaths :: Expr -> [Path]
getPaths :: Expr -> [Path]
getPaths e :: Expr
e = case Expr
e of
  GenExpr True "|" args :: [Expr]
args -> (Expr -> [Path]) -> [Expr] -> [Path]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expr -> [Path]
getPaths [Expr]
args
  PathExpr m :: Maybe Expr
m p :: Path
p@(Path _ s :: [Step]
s) -> case Maybe Expr
m of
    Nothing -> [Path
p]
    Just fe :: Expr
fe -> (Path -> Path) -> [Path] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Path r :: Bool
r f :: [Step]
f) -> Bool -> [Step] -> Path
Path Bool
r ([Step] -> Path) -> [Step] -> Path
forall a b. (a -> b) -> a -> b
$ [Step]
f [Step] -> [Step] -> [Step]
forall a. [a] -> [a] -> [a]
++ [Step]
s) ([Path] -> [Path]) -> [Path] -> [Path]
forall a b. (a -> b) -> a -> b
$ Expr -> [Path]
getPaths Expr
fe
  FilterExpr p :: Expr
p _ -> Expr -> [Path]
getPaths Expr
p
  _ -> []