{-# LANGUAGE OverloadedStrings #-}
module Internal.Elements.XPath where

import Internal.Elements.XPathParse
import qualified Data.Text as Txt
import Data.Text (Text)

import Text.XML.Cursor hiding (bool)
import Text.XML
import qualified Data.Map.Strict as M

import Data.Time
import Data.Maybe
import Data.Either
import Data.List (nub)
import Text.Read (readMaybe)

-- Loosely transliterated from https://www.w3.org/TR/xpath-3/#eval_context
-- TODO How much are noops?
data Context = Context {
        item :: [Value],
        vars :: M.Map Name [Value],
        funcs :: M.Map (Name, Int) (Context -> [[Value]] -> [Value])
    }

---- Typesystem/coercion

atomize :: Value -> [Value]
atomize ret@(Number _) = [ret]
atomize ret@(String _) = [ret]
atomize ret@(Bool _) = [ret]
atomize ret@(Error _ _ _) = [ret]
atomize (Node n) = [String $ Txt.unpack $ nodeText $ node n] -- For a proper implementation, should be parsed via XSD?
atomize (Array vals) = atomsize $ concat vals
atomize (Map _) = [Error "err:FOTY0013" "Unnaceptable map item" ""]
atomize (Function _ _ _ _) = [Error "err:FOTY0013" "Unacceptable function item" ""]
atomize (FuncRef _ _) = [Error "err:FOTY0013" "Unacceptable function item" ""]
atomsize :: [Value] -> [Value]
atomsize = concatMap atomize

nodeText (NodeElement (Element _ _ nodes)) = Txt.concat $ map nodeText' nodes
nodeText (NodeInstruction (Instruction _ ret)) = ret
nodeText (NodeContent ret) = ret
nodeText (NodeComment ret) = ret
nodeText' (NodeElement (Element _ _ nodes)) = Txt.concat $ map nodeText' nodes
nodeText' (NodeContent ret) = ret
nodeText' _ = ""

maybeName (NodeElement (Element n _ _)) = n
maybeName _ = ""

nameMatch (Name "*" (Just "*") (Just "*")) _ = True
nameMatch (Name "*" (Just "*") (Just prefixA)) (Name _ _ (Just prefixB)) = prefixA == prefixB
nameMatch (Name "*" Nothing (Just prefixA)) (Name _ _ (Just prefixB)) = prefixA == prefixB
nameMatch (Name "*" (Just "*") Nothing) (Name _ _ prefix) = isNothing prefix
nameMatch (Name "*" (Just nsA) _) (Name _ (Just nsB) _) = nsA == nsB
nameMatch (Name "*" Nothing _) (Name _ ns _) = isNothing ns
nameMatch (Name nameA (Just "*") (Just "*")) (Name nameB _ _) = nameA == nameB
nameMatch (Name nameA (Just "*") (Just prefixA)) (Name nameB _ (Just prefixB)) = nameA == nameB && prefixA == prefixB
nameMatch (Name nameA Nothing (Just prefixA)) (Name nameB _ (Just prefixB)) = nameA == nameB && prefixA == prefixB
nameMatch (Name nameA (Just "*") Nothing) (Name nameB _ prefix) = nameA == nameB && isNothing prefix
nameMatch (Name nameA (Just nsA) _) (Name nameB (Just nsB) _) = nameA == nameB && nsA == nsB
nameMatch (Name nameA Nothing _) (Name nameB ns _) = nameA == nameB && isNothing ns
nameMatch _ _ = False

hasName name node = nameMatch (maybeName node) name

attribute' name (NodeElement (Element _ attrs _)) =
    [String $ Txt.unpack val | (key, val) <- M.toList attrs, nameMatch name key]
attribute' _ _ = []

bool [] = Right False
bool (Node _:_) = Right True
bool [Bool ret] = Right ret
bool [String ret] = Right $ not $ null ret
bool [Number x] = Right $ not (isNaN x || x == 0)
bool vals | ret@(_:_) <- [err | err@(Error _ _ _) <- vals] = Left ret
bool (val:_) = Left [Error "err:FORG0006" "Invalid argument type" $ show $ val2type val]

nums items | ret@(_:_) <- [err | err@(Error _ _ _) <- items] = Left ret
nums (Number x:items) = (x:) <$> nums items
nums (String str:items) | Just x <- readMaybe str = (x:) <$> nums items
    | otherwise = Left [Error "err:FORG0001" "Invalid cast to number" str]
nums (Bool True:items) = (1:) <$> nums items
nums (Bool False:items) = (0:) <$> nums items
nums [] = Right []
nums items = nums $ atomsize items
num items = case nums items of
    Left errs -> Left errs
    Right (x:_) -> Right x
    Right [] -> Right (0/0) -- NaN

withNums2 x y cb = withNums2' (nums x) (nums y) cb
withNums2' (Right xs) (Right ys) cb = cb xs ys
withNums2' x y _ = fromLeft [] x ++ fromLeft [] y
withNum2 x y cb = withNum2' (num x) (num y) cb
withNum2' (Right x) (Right y) cb = cb x y
withNum2' x y _ = fromLeft [] x ++ fromLeft [] y

text :: [Value] -> Either [Value] [String]
text items | ret@(_:_) <- [err | err@(Error _ _ _) <- items] = Left ret
text (Number x:items) = (show x:) <$> text items
text (String ret:items) = (ret:) <$> text items
text (Bool b:items) = (show b:) <$> text items
text [] = Right []
text items = text $ atomsize items

---Type system

cast (TypeAtomic ty) [x]
    | ty `elem` ["xsd:integer", "xsd:float", "xsd:double", "xsd:decimal"], Right x <- num [x] = [Number x]
    | ty == "xsd:bool", Right b <- bool [x] = [Bool b]
    | Right [str] <- text [x] = [String str]
cast TypeText [x] | Right [str] <- text [x] = [String str]
cast ty [_] = [Error "err:XPTY0004" "Invalid type to cast to." $ show ty]
cast _ [] = []
cast _ items = [Error "err:XPTY0004" "Too many items in cast." $ show $ length items]
cast' :: Quantity -> [Value] -> [Value]
cast' ty val | instanceOf' ty val = val
cast' (Quantity ty _ Many) _ = [Error "err:XPDY0050" "Can't cast to non-optional multiplicity" ""]
cast' (Quantity ty _ None) _ = []
cast' (Quantity ty Many One) _ = [Error "err:XPDY0050" "Can't cast to non-optional multiplicity" ""]
cast' (Quantity ty One One) val | null $ cast ty $ atomsize val = cast ty $ atomsize val
    | otherwise = [Error "err:XPTY0004" "Expected non-zero items in value." "0"]
cast' (Quantity ty None One) val = cast ty $ atomsize val
tryCast' (Just ty) val = let val' = cast (TypeAtomic ty) [val] in if any isErr val' then [] else val'
tryCast' Nothing val = [val]

instanceOf :: XType -> Value -> Bool
instanceOf (TypeDocument type_) (Node cursor) | null $ ancestor cursor = instanceOf type_ $ Node cursor
instanceOf (TypeElement (Just name) type_) (Node cursor)
    | NodeElement (Element n _ _) <- node cursor = instanceOf (TypeElement Nothing type_) $ Node cursor
instanceOf (TypeElement Nothing (Just "xsd:bool")) val
    | Right res <- text [val] = res `elem` [["true"], ["false"]]
instanceOf (TypeElement Nothing (Just "xsd:integer")) val
    | Right x <- num [val] = fromIntegral (floor x) == x
instanceOf (TypeElement Nothing (Just type_)) val
    | type_ `elem` ["xsd:double", "xsd:float", "xsd:decimal"] = isRight $ num [val]
    | otherwise = True
instanceOf (TypeArray Nothing) (Array _) = True
instanceOf (TypeArray (Just type_)) (Array vals) = all (instanceOf' type_) vals
instanceOf (TypeMap Nothing') (Map _) = True
instanceOf (TypeMap (Some' _ valType)) (Map m) = all (instanceOf' valType) $ M.elems m -- TODO check keytype
instanceOf (TypeFunction Nothing') (Array _) = True
instanceOf (TypeFunction Nothing') (Map _) = True
instanceOf (TypeFunction Nothing') (PartialFunc _ _) = True
instanceOf (TypeFunction Nothing') (FuncRef _ _) = True
instanceOf (TypeFunction Nothing') (Function _ _ _ _) = True
instanceOf (TypeFunction (Some' [Quantity (TypeAtomic "xsd:integer") One One] retty)) (Array vals) =
    all (instanceOf' retty) vals
instanceOf (TypeFunction (Some' [Quantity (TypeAtomic _) One One] retty)) (Map m) =
    all (instanceOf' retty) $ M.elems m
instanceOf (TypeFunction (Some' [Quantity TypeText One One] retty)) (Map m) =
    all (instanceOf' retty) $ M.elems m
-- FIXME doesn't actually check types, that requires deeper introspection than I currently model.
instanceOf (TypeFunction (Some' argtys _)) (PartialFunc args _) = length argtys == length args
instanceOf (TypeFunction (Some' argtys _)) (FuncRef _ nargs) = length argtys == nargs
instanceOf (TypeFunction (Some' argtys retty)) (Function args retty' _ _) =
    retty == retty' && and [ty == ty' | (ty, (_, ty')) <- zip argtys args]
instanceOf (TypeSchemaElement _) _ = False -- TODO What's this?
instanceOf TypeNode (Node _) = True
instanceOf TypeNamespaceNode _ = False -- Don't think I support this yet.
instanceOf TypeText (String _) = True
instanceOf TypeText (Node n) | NodeContent _ <- node n = True
instanceOf TypeComment (Node n) | NodeComment _ <- node n = True
instanceOf (TypePI Nothing) (Node n) | NodeInstruction _ <- node n = True
instanceOf (TypePI (Just name)) (Node n) | NodeInstruction (Instruction name' _) <- node n = name == name'
instanceOf (TypeSchemaAttribute _) _ = False -- Don't think I support this yet.
instanceOf (TypeAttribute _ _) _ = False -- XML Conduit's datamodel had me support this indirectly.
instanceOf (TypeAtomic "xsd:bool") (Bool _) = True
instanceOf (TypeAtomic "xsd:integer") (Number x) = fromIntegral (floor x) == x
instanceOf (TypeAtomic type_) (Number _) = type_ `elem` ["xsd:double", "xsd:float", "xsd:decimal"]
instanceOf (TypeAtomic type_) (String _) = type_ `notElem` ["xsd:bool", "xsd:double", "xsd:float", "xsd:decimal"]
instanceOf TypeItem _ = True
instanceOf _ _ = False
instanceOf' :: Quantity -> [Value] -> Bool
instanceOf' (Quantity ty Many high) vals@(_:_:_) = instanceOf' (Quantity ty None high) vals
instanceOf' (Quantity ty One high) vals@(_:_) = instanceOf' (Quantity ty None high) vals
instanceOf' (Quantity type_ None Many) vals = all (instanceOf type_) vals
instanceOf' (Quantity type_ None One) vals | length vals <= 1 = all (instanceOf type_) vals
instanceOf' (Quantity _ None None) [] = True
instanceOf' _ _ = False

---- Interpretor

evals ctx = concatMap $ eval ctx
eval :: Context -> Expression -> [Value]
eval ctx (ExprRange from to) = withNums2 (eval ctx from) (eval ctx to) inner
  where
    inner (from:_) (to:_) = map Number [from..to]
    inner _ _ = []
eval ctx (ExprUnion exps) = nub $ concat $ map (eval ctx) exps
eval ctx (ExprIntersect a b) = let b' = eval ctx b in
    [v | v <- eval ctx a, v `elem` b' || isErr v] ++ [err | err <- b', isErr err]
eval ctx (ExprExcept a b) = let b' = eval ctx b in
    [v | v <- eval ctx a, v `notElem` b' || isErr v] ++ [err | err <- b', isErr err]

eval ctx (ExprSum exps) = let (errs, xs) = partitionEithers $ map (num . eval ctx) exps in
    if null errs then [Number $ sum xs] else concat errs
eval ctx (ExprMul a b) = withNum2 (eval ctx a) (eval ctx b) $ \x y -> [Number (x*y)]
eval ctx (ExprDiv a b) = withNum2 (eval ctx a) (eval ctx b) $ \x y -> [Number (x/y)]
eval ctx (ExprIDiv a b) = withNum2 (eval ctx a) (eval ctx b) $
    \x y -> [Number $ fromIntegral (floor x `div` floor y)]
eval ctx (ExprMod a b) = withNum2 (eval ctx a) (eval ctx b) $
    \x y -> [Number $ fromIntegral (floor x `rem` floor y)]
eval ctx (ExprNegate a) = case num $ eval ctx a of
    Left errs -> errs
    Right x -> [Number $ negate x]

eval ctx (ExprStrConcat texts) = let (errs, texts') = partitionEithers $ map (text . eval ctx) texts
    in if null errs then [String $ concat $ map concat texts'] else concat errs

eval ctx (ExprGe' a b)
    | (Number a':_) <- atomsize $ eval ctx a, (Number b':_) <- atomsize $ eval ctx b = [Bool (a' >= b')]
    | Right a' <- num $ eval ctx a, Right b' <- num $ eval ctx b = [Bool (a' >= b')]
    | a' <- num $ eval ctx a, b' <- num $ eval ctx b = fromLeft [] a' ++ fromLeft [] b'
eval ctx (ExprGt' a b)
    | (Number a':_) <- atomsize $ eval ctx a, (Number b':_) <- atomsize $ eval ctx b = [Bool (a' > b')]
    | Right a' <- num $ eval ctx a, Right b' <- num $ eval ctx b = [Bool (a' > b')]
    | a' <- num $ eval ctx a, b' <- num $ eval ctx b = fromLeft [] a' ++ fromLeft [] b'
eval ctx (ExprLe' a b)
    | (Number a':_) <- atomsize $ eval ctx a, (Number b':_) <- atomsize $ eval ctx b = [Bool (a' <= b')]
    | Right a' <- num $ eval ctx a, Right b' <- num $ eval ctx b = [Bool (a' <= b')]
    | a' <- num $ eval ctx a, b' <- num $ eval ctx b = fromLeft [] a' ++ fromLeft [] b'
eval ctx (ExprLt' a b)
    | (Number a':_) <- atomsize $ eval ctx a, (Number b':_) <- atomsize $ eval ctx b = [Bool (a' < b')]
    | Right a' <- num $ eval ctx a, Right b' <- num $ eval ctx b = [Bool (a' < b')]
    | a' <- num $ eval ctx a, b' <- num $ eval ctx b = fromLeft [] a' ++ fromLeft [] b'
eval ctx (ExprNe' a b)
    | (Number a':_) <- atomsize $ eval ctx a, (Number b':_) <- atomsize $ eval ctx b = [Bool (a' /= b')]
    | Right a' <- num $ eval ctx a, Right b' <- num $ eval ctx b = [Bool (a' /= b')]
    | a' <- num $ eval ctx a, b' <- num $ eval ctx b = fromLeft [] a' ++ fromLeft [] b'
eval ctx (ExprEq' a b)
    | (Number a':_) <- atomsize $ eval ctx a, (Number b':_) <- atomsize $ eval ctx b = [Bool (a' == b')]
    | Right a' <- num $ eval ctx a, Right b' <- num $ eval ctx b = [Bool (a' == b')]
    | a' <- num $ eval ctx a, b' <- num $ eval ctx b = fromLeft [] a' ++ fromLeft [] b'
eval ctx (ExprGe a b) = withNums2 (eval ctx a) (eval ctx b) $ \a' b' -> [Bool (maximum a' >= minimum b')]
eval ctx (ExprGt a b) = withNums2 (eval ctx a) (eval ctx b) $ \a' b' -> [Bool (maximum a' > minimum b')]
eval ctx (ExprLe a b) = withNums2 (eval ctx a) (eval ctx b) $ \a' b' -> [Bool (minimum a' <= maximum b')]
eval ctx (ExprLt a b) = withNums2 (eval ctx a) (eval ctx b) $ \a' b' -> [Bool (minimum a' < maximum b')]
eval ctx (ExprNe a b) = let (a', b') = (atomsize $ eval ctx a, atomsize $ eval ctx b)
    in if any isErr a' || any isErr b' then [err | err <- a', isErr err] ++ [err | err <- b', isErr err]
    else [Bool $ any (`notElem` b') a']
eval ctx (ExprEq a b) = let (a', b') = (atomsize $ eval ctx a, atomsize $ eval ctx b)
    in if any isErr a' || any isErr b' then [err | err <- a', isErr err] ++ [err | err <- b', isErr err]
    else [Bool $ any (`elem` b') a']
-- TODO node order comparisons.

eval ctx (ExprAnd exps) = let (errs, bools) = partitionEithers $ map (bool . eval ctx) exps
    in if null errs then [Bool $ and bools] else concat errs
eval ctx (ExprOr exps) = let (errs, bools) = partitionEithers $ map (bool . eval ctx) exps
    in if null errs then [Bool $ or bools] else concat errs

eval ctx (ExprInstanceOf a type_) = [Bool $ instanceOf' type_ $ eval ctx a]
eval ctx (ExprTreatAs a type_) | instanceOf' type_ $ eval ctx a = eval ctx a
    | otherwise = [Error "err:XPDY0050" "Expression not of expected type" ("Expected " ++ show type_)]
eval ctx (ExprCastAs a type_) = cast' type_ $ eval ctx a
eval ctx (ExprCastableAs a type_) = let val = eval ctx a in if any isErr val
    then [err | err <- val, isErr err] else [Bool $ not $ any isErr $ cast' type_ val] 

eval ctx (ExprFor name expr body) = concat $ map inner $ eval ctx expr
    where inner subitem = eval ctx { vars = M.insert name [subitem] $ vars ctx } body
eval ctx (ExprLet name expr body) = eval ctx { vars = vars' } body
    where vars' = M.insert name (eval ctx expr) $ vars ctx
eval ctx (ExprIf cond pass fail) = case bool $ evals ctx cond of
    Left errs -> errs
    Right cond' -> eval ctx $ if cond' then pass else fail
eval ctx (ExprQuantified variant tests) =
    let (errs, res) = partitionEithers $ map (\x -> bool [x]) $ eval ctx tests
    in if null errs then [Bool $ (case variant of {Some -> or; Every -> and }) res]
    else concat errs

eval ctx (ExprMap a b) = concatMap (\a' -> eval ctx { item = [a'] } b) $ eval ctx a
eval ctx (ExprArrow self func args) =
    evalPostfix ctx { item = [retrieveArrow ctx func $ succ $ length args] } $ PostCall (self:args)
eval ctx (ExprPath (path:paths)) = eval ctx { item = evalPath ctx path } $ ExprPath paths
eval ctx (ExprPath []) = item ctx
eval _ _ = [] -- TODO

retrieveArrow _ (ArrowName n) arity = FuncRef n arity
retrieveArrow ctx (ArrowVar n) _ | Just [ret] <-  n `M.lookup` vars ctx = ret
    | otherwise = Error "err:XPST0008" "Undefined name" $ show n
retrieveArrow ctx (ArrowExpr exps) _ | [ret] <- evals ctx exps = ret
    | otherwise = Error "err:XPTY0004" "Too many (or no) items in collection identifying function to call" ""

evalPrimary _ (Literal x) = [x]
evalPrimary ctx (VarRef n) | Just val <- n `M.lookup` vars ctx = val
    | otherwise = [Error "err:XPST0008" "Undefined name" $ show n]
evalPrimary ctx (Expr exprs) = evals ctx exprs
evalPrimary ctx ContextItem | null $ item ctx = [Error "err:XPDY0002" "Absent context item" ""]
    | otherwise = item ctx
evalPrimary ctx (FunctionCall n args)
    | Just cb <- (n, length args) `M.lookup` funcs ctx = cb ctx $ map (eval ctx) args
    | otherwise = [Error "err:XPST0017" "Undefined function" (show n ++ '#':show (length args))]
-- NOTE: No recursion! Great! Not Turing Complete, hopefully!
evalPrimary ctx (FunctionItem args retty body) = [Function args retty body $ vars ctx]
evalPrimary ctx (MapConstruct entries)
    | any isErr $ concat $ map (eval ctx . fst) entries = filter isErr $ concat $ map (eval ctx . fst) entries
    | any isErr $ concat $ map (eval ctx . snd) entries = filter isErr $ concat $ map (eval ctx . snd) entries
    | otherwise = [Map $ M.fromList $ map buildEntry entries]
    where buildEntry (key, val) = (concat $ fromRight [] $ text $ eval ctx key, eval ctx val)
evalPrimary ctx (ArrayConstruct entries)
    | any isErr $ concat $ map (eval ctx) entries = filter isErr $ concat $ map (eval ctx) entries
    | otherwise = [Array $ map (eval ctx) entries]
evalPrimary ctx (UnaryLookup key) = evalPostfix ctx (PostLookup key) -- Both the same, both operating on `item ctx`

-- It's a little tricky to get errors thrown correctly this branch...
evalPostfix ctx (PostFilter cond) = concatMap inner $ zip [0..] $ item ctx
  where
    inner (i, item) = case evals ctx { item = [item] } cond of
        [Number x] -> test (x == i)
        v -> case bool v of
            Left ret -> ret
            Right ret -> test ret
      where test cond = if cond then [item] else []
evalPostfix ctx (PostCall _) | length (item ctx) /= 1 = [
    Error "err:XPTY0004" "Function calls require singleton values" (show (length $ item ctx) ++ " items")]
  | not $ null [1 | Error _ _ _ <- item ctx] = [err | err@(Error _ _ _) <- item ctx]
evalPostfix ctx (PostCall args) | not $ null [1 | ArgPlaceholder <- args] = [PartialFunc args $ head $ item ctx]
evalPostfix ctx (PostCall args) = case head $ item ctx of
    Array vals | [arg] <- args -> case nums $ eval ctx arg of
        Left errs -> errs
        Right [i] | i >= 1.0 && floor i <= length vals -> vals !! floor i
        Right [i] -> [Error "err:FOAY0001" "Array index out of bounds" $ show i]
        Right items -> [Error "err:XPTY0004" "Too many items in index" $ show $ length items]
    Map m | [arg] <- args -> case text $ eval ctx arg of
        Left errs -> errs
        Right [key] -> fromMaybe [] $ M.lookup key m
        Right items -> [Error "err:XPTY0004" "Too many items in key" $ show $ length items]
    PartialFunc tpl val -> case expandPartial tpl args of
        Left False -> [Error "err:XPTY0004" "Too few arguments to partial" $ show $ length args]
        Left True -> [Error "err:XPTY0004" "Too many arguments to partial" $ show $ length args]
        Right args' -> evalPostfix ctx { item = [val] } $ PostCall args'
    FuncRef name arity | arity /= length args -> [
        Error "err:XPTY0004" "Wrong number of args to referenced function." (show arity ++ " not " ++ show (length args))]
    FuncRef name arity | Just cb <- (name, arity) `M.lookup` funcs ctx -> cb ctx $ map (eval ctx) args
    FuncRef name arity -> [Error "err:XPST0017" "Undfined function" (show name ++ '#':show arity)]
    Function params retty body closure -> case assignArgs params args closure ctx of
        Left False -> [Error "err:XPTY0004" "Too few arguments to dynamic function" $ show $ length args]
        Left True -> [Error "err:XPTY0004" "Too many arguments to dynamic function" $ show $ length args]
        Right vars -> cast' retty $ evals ctx { item = [], vars = vars } body
    _ -> [Error "err:XPTY0004" "Invalid function type" ""]
evalPostfix ctx (PostLookup (KeyExpr exprs)) = case atomsize $ evals ctx exprs of
    [key] -> evalPostfix ctx $ PostLookup $ KeyLiteral key
    items -> [Error "err:XPTY0004" "Too many items in key" $ show $ length items]
evalPostfix ctx (PostLookup KeyWildcard) = case item ctx of
    [Array vals] -> concat $ vals
    [Map m] -> concat $ M.elems m
    _ -> [Error "err:XPTY0004" "Invalid collection type or arity" ""]
evalPostfix ctx (PostLookup (KeyLiteral k)) = case item ctx of
    [Array vals] -> case nums [k] of
        Left errs -> errs
        Right [i] | i >= 1.0 && floor i <= length vals -> vals !! floor i
        Right [i] -> [Error "err:FOAY0001" "Array index out of bounds" $ show i]
        Right items -> [Error "err:XPTY0004" "Too many items in index" $ show $ length items]
    [Map m] -> case text [k] of
        Left errs -> errs
        Right [key] -> fromMaybe [] $ M.lookup key m
        Right items -> [Error "err:XPTY0004" "Too many items in key" $ show $ length items]
    _ -> [Error "err:XPTY0004" "Invalid collection type or arity" ""]
evalPostfix' ctx (op:ops) = evalPostfix' ctx { item = evalPostfix ctx op } ops
evalPostfix' ctx [] = item ctx

evalPath ctx (PostExpr primary postfix) = evalPostfix' ctx { item = evalPrimary ctx primary } postfix
evalPath ctx (PathStep (Axis axis, test) filters) =
    [n | Node n <- item ctx] >>=
    axis >>=
    check (case test of {Left type_ -> instanceOf type_ . Node; Right name -> hasName name . node }) >>=
    return . Node >>=
    filter' filters ctx
evalPath ctx (PathStep (Attribute, Right n) filters) =
    [node n | Node n <- item ctx] >>= attribute' n >>= filter' filters ctx
evalPath ctx (PathStep (Attribute, Left (TypeAttribute (Just n) type_)) filters) =
    [node n | Node n <- item ctx] >>= attribute' n >>= tryCast' type_ >>= filter' filters ctx
evalPath ctx (PathStep (Attribute, Left (TypeAttribute Nothing type_)) filters) =
    [String $ Txt.unpack val |
        Node n <- item ctx,
        NodeElement (Element _ attrs _) <- [node n],
        (_, val) <- M.toList attrs] >>=
    tryCast' type_ >>=
    filter' filters ctx
evalPath _ (PathStep (Attribute, Left _) _) = []
evalPath _ (PathStep (Namespace, _) _) = [Error "err:XPST0010" "Namespace axis is unsupported" ""]

filter' filters ctx v =
    let (errs, pred) = partitionEithers $ map (bool . evals ctx {item = [v]}) filters
    in [v | and pred] ++ concat errs

---- Dynamic function call support
expandPartial (ArgPlaceholder:tpls) (arg:args) = (arg:) <$> expandPartial tpls args
expandPartial (ArgPlaceholder:_) [] = Left False
expandPartial (tpl:tpls) args = (tpl:) <$> expandPartial tpls args
expandPartial [] (_:_) = Left True
expandPartial [] [] = Right []

assignArgs ((name, type_):params) (arg:args) vars ctx =
    let vars' = M.insert name (cast' type_ $ eval ctx arg) vars
    in assignArgs params args vars' ctx
assignArgs (_:_) [] _ _ = Left False
assignArgs [] (_:_) _ _ = Left True
assignArgs [] [] vars _ = Right vars

----Utils

fromLeft _ (Left ret) = ret
fromLeft ret (Right _) = ret
fromRight _ (Right ret) = ret
fromRight ret (Left _) = ret

--- standard library

stdLib :: M.Map (Name, Int) (Context -> [[Value]] -> [Value])
stdLib = M.fromList [
    (("fn:node-name", 1), fnNodeName),
    (("fn:node-name", 0), fnNodeName),
--    (("fn:nilled", 1), fnNilled),
--    (("fn:nilled", 0), fnNilled),
    (("fn:string", 1), fnString),
    (("fn:string", 0), fnString),
    (("fn:data", 1), fnData),
    (("fn:data", 0), fnData),
--    (("fn:base-uri", 1), fnBaseURI),
--    (("fn:document-uri", 1), fnDocumentURI),

    (("fn:error", 0), fnError),
    (("fn:error", 1), fnError),
    (("fn:error", 2), fnError),
    (("fn:error", 3), fnError),

    (("op:numeric-add", 2), fnNumericAdd),
    (("op:numeric-subtract", 2), fnNumericSubtract),
    (("op:numeric-multiply", 2), fnNumericMultiply),
    (("op:numeric-divide", 2), fnNumericDivide),
    (("op:numeric-integer-divide", 2), fnNumericIntegerDivide),
    (("op:numeric-mod", 2), fnNumericMod),
    (("op:numeric-unary-plus", 1), fnNumericUnaryPlus),
    (("op:numeric-unary-minus", 1), fnNumericUnaryMinus),

    (("op:numeric-equal", 2), opNumericEqual),
    (("op:numeric-less-than", 2), opNumericLessThan),
    (("op:numeric-greater-than", 2), opNumericGreaterThan),

    (("fn:abs", 1), fnAbs),
    (("fn:ceiling", 1), fnCeiling),
    (("fn:floor", 1), fnFloor),
    (("fn:round", 1), fnRound),
    (("fn:round-half-to-even", 1), fnRoundToEven),

    (("fn:number", 1), fnNumericUnaryPlus),
--    (("fn:format-integer", 2), fnFormatInteger),
--    (("fn:format-integer", 3), fnFormatInteger),
--    (("fn:format-number", 2), fnFormatNumber),
--    (("fn:format-number", 3), fnFormatNumber),

    (("math:pi", 0), fnMathPi),
    (("math:exp", 1), fnMathExp),
    (("math:exp10", 1), fnMathExp10),
    (("math:log", 1), fnMathLog),
    (("math:log10", 1), fnMathLog10),
    (("math:pow", 2), fnMathPow),
    (("math:sqrt", 1), fnMathSqrt),
    (("math:sin", 1), fnMathSin),
    (("math:cos", 1), fnMathCos),
    (("math:tan", 1), fnMathTan),
    (("math:asin", 1), fnMathASin),
    (("math:acos", 1), fnMathACos),
    (("math:atan", 1), fnMathATan),
    (("math:atan2", 2), fnMathATan2)
  ]
typeError = [Error "fn:XPTY0004" "Invalid type signature for function" ""]

fnNodeName _ [[Node c]] | NodeElement (Element name _ _) <- node c = [String $ show name]
    | otherwise = typeError
fnNodeName ctx [] = fnNodeName ctx [item ctx]
fnNodeName _ _ = typeError
fnString _ [[Node c]] = [String $ Txt.unpack $ nodeText $ node c]
fnString ctx [] = fnString ctx [item ctx]
fnString _ _ = typeError
fnData _ [val] = atomsize val
fnData ctx [] = atomsize $ item ctx
fnData _ _ = typeError

fnError _ [] = [Error "err:user" "" ""]
fnError _ [code'] | Right [code] <- text code' =
    [Error (fromRight "err:user" $ parseQName $ Txt.pack code) "" ""]
fnError _ [code', msg'] | Right [code] <- text code', Right [msg] <- text msg' =
    [Error (fromRight "err:user" $ parseQName $ Txt.pack code) msg ""]
fnError _ [code', msg', items] | Right [code] <- text code', Right [msg] <- text msg' =
    [Error (fromRight "err:user" $ parseQName $ Txt.pack code) msg $ concat $ fromRight [] $ text items]
fnError _ _ = typeError

fnNumericAdd _ [x', y'] | Right x <- num x', Right y <- num y' = [Number (x + y)]
fnNumericAdd _ _ = typeError
fnNumericSubtract _ [x', y'] | Right x <- num x', Right y <- num y' = [Number (x - y)]
fnNumericSubtract _ _ = typeError
fnNumericMultiply _ [x', y'] | Right x <- num x', Right y <- num y' = [Number (x * y)]
fnNumericMultiply _ _ = typeError
fnNumericDivide _ [x', y'] | Right x <- num x', Right y <- num y' = [Number (x / y)]
fnNumericDivide _ _ = typeError
fnNumericIntegerDivide _ [x', y'] | Right x <- num x', Right y <- num y' = [Number $ fromIntegral (floor x `div` floor y)]
fnNumericIntegerDivide _ _ = typeError
fnNumericMod _ [x', y'] | Right x <- num x', Right y <- num y' = [Number $ fromIntegral (floor x `rem` floor y)]
fnNumericMod _ _ = typeError
fnNumericUnaryPlus _ [x'] | Right x <- num x' = [Number x]
fnNumericUnaryPlus _ _ = typeError
fnNumericUnaryMinus _ [x'] | Right x <- num x' = [Number $ negate x]
fnNumericUnaryMinus _ _ = typeError

opNumericEqual _ [x', y'] | Right x <- num x', Right y <- num y' = [Bool (x == y)]
opNumericEqual _ _ = typeError
opNumericLessThan _ [x', y'] | Right x <- num x', Right y <- num y' = [Bool (x < y)]
opNumericLessThan _ _ = typeError
opNumericGreaterThan _ [x', y'] | Right x <- num x', Right y <- num y' = [Bool (x > y)]
opNumericGreaterThan _ _ = typeError

fnAbs _ [x'] | Right x <- num x' = [Number $ abs x]
fnAbs _ _ = typeError
fnCeiling _ [x'] | Right x <- num x' = [Number $ fromIntegral $ ceiling x]
fnCeiling _ _ = typeError
fnFloor _ [x'] | Right x <- num x' = [Number $ fromIntegral $ floor x]
fnFloor _ _ = typeError
fnRound _ [x'] | Right x <- num x' = [Number $ fromIntegral $ round x]
fnRound _ _ = typeError
fnRoundToEven _ [x'] | Right x <- num x' = [Number $ fromIntegral $ toEven $ round x]
  where toEven y = if even y then y else succ y
fnRoundToEven _ _ = typeError

fnMathPi _ [] = [Number pi]
fnMathPi _ _ = typeError
fnMathExp _ [x'] | Right x <- num x' = [Number $ exp x]
fnMathExp _ _ = typeError
fnMathExp10 _ [x'] | Right x <- num x' = [Number (10 ** x)]
fnMathExp10 _ _ = typeError
fnMathLog _ [x'] | Right x <- num x' = [Number $ log x]
fnMathLog _ _ = typeError
fnMathLog10 _ [x'] | Right x <- num x' = [Number $ logBase 10 x]
fnMathLog10 _ _ = typeError
fnMathPow _ [x', y'] | Right x <- num x', Right y <- num y' = [Number (x ** y)]
fnMathPow _ _ = typeError
fnMathSqrt _ [x'] | Right x <- num x' = [Number $ sqrt x]
fnMathSqrt _ _ = typeError
fnMathSin _ [x'] | Right x <- num x' = [Number $ sin x]
fnMathSin _ _ = typeError
fnMathCos _ [x'] | Right x <- num x' = [Number $ cos x]
fnMathCos _ _ = typeError
fnMathTan _ [x'] | Right x <- num x' = [Number $ tan x]
fnMathTan _ _ = typeError
fnMathASin _ [x'] | Right x <- num x' = [Number $ asin x]
fnMathASin _ _ = typeError
fnMathACos _ [x'] | Right x <- num x' = [Number $ acos x]
fnMathACos _ _ = typeError
fnMathATan _ [x'] | Right x <- num x' = [Number $ atan x]
fnMathATan _ _ = typeError
fnMathATan2 _ [y', x'] | Right x <- num x', Right y <- num y' = [Number $ atan2 y x]
fnMathATan2 _ _ = typeError

---- Public API
runXPath' node sel = case parseXPath sel of
    Right ast -> evals Context {
            item = [Node node],
            vars = M.empty,
            funcs = stdLib
        } ast
    Left err -> [Error "err:syntax" err ""]
runXPath node sel = let ret = runXPath' node sel
    in if any isErr ret then Left [msg | Error name msg _ <- ret]
    else Right [n | Node n <- ret]