XPath2Pf.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.XPath.XPath2Pf
-- Copyright   :  (c) 2011 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Multifocal:
-- Bidirectional Two-level Transformation of XML Schemas
-- 
-- Translation from XPath expressions into point-free function representations.
--
-----------------------------------------------------------------------------

module Language.XPath.XPath2Pf where

import Data.Type
import Data.Pf
import Data.Spine
import Generics.Pointless.Functors hiding (fmap)
import Language.XPath.HXTAliases

import Text.XML.HXT.XPath as HXT hiding (parseXPath)
import Text.XML.HXT.XPath.XPathDataTypes as XPath
import Text.XML.HXT.DOM.QualifiedName
import Control.Monad
import Data.Monoid

type XPathQ = Q [Dynamic]

xpath2pf :: MonadPlus m => XPath -> m (Pf XPathQ)
xpath2pf = expr2pf . relativeExpr

-- | Converts top-level absolute paths to relative paths
relativeExpr :: XPath -> XPath
relativeExpr (GenExpr op exprs) = GenExpr op (map relativeExpr exprs)
relativeExpr (PathExpr expr path) = PathExpr (fmap relativeExpr expr) (fmap relativeLocPath path)
relativeExpr (FilterExpr exprs) = FilterExpr (map relativeExpr exprs)
relativeExpr (FctExpr name exprs) = FctExpr name (map relativeExpr exprs)
relativeExpr xp = xp
relativeLocPath (LocPath Abs steps) = LocPath Rel steps
relativeLocPath (LocPath Rel steps) = LocPath Rel steps

expr2pf :: MonadPlus m => XPath -> m (Pf XPathQ)
expr2pf e@(GenExpr op lexp) | isBoolOp op = do
	pf <- xpath2boolpf e
	return $ mkXPathQ Bool pf
expr2pf e@(GenExpr op lexp) | isNumOp op = do
	pf <- xpath2numpf e
	return $ mkXPathQ Int pf
expr2pf (GenExpr Union lexp) = do
	pfs <- mapM expr2pf lexp
	return $ nestedUnion pfs
expr2pf (PathExpr Nothing (Just path)) = locpath2pf path
expr2pf (PathExpr (Just pred) Nothing) = expr2pf (FilterExpr [pred])
expr2pf (PathExpr (Just pred) (Just path)) = do
	pf <- locpath2pf path
	filter2pf pf pred
expr2pf (FilterExpr (xpath:preds)) = do
	xp <- expr2pf xpath
	filters2pf xp preds
expr2pf (VarExpr var) = error "no variables supported"
expr2pf (LiteralExpr str) = return $ constantpf (List Char) str
expr2pf (NumberExpr i) = return $ constantpf Int (xpathnum2int i)
expr2pf (FctExpr "count" [arg]) = do
	pf <- expr2pf arg
	return $ mkXPathQ nat $ SEQQ pf LENGTH
expr2pf (FctExpr "sum" args) = do
	pfs <- mapM expr2pf args
	let pf = nestedUnion $ map (`SEQQ` MAP (CAST nat)) pfs
	return $ mkXPathQ nat $ pf `SEQQ` FOLD
expr2pf (FctExpr name args) = error $ "function unsupported :" ++ name

locpath2pf :: MonadPlus m => LocationPath -> m (Pf XPathQ)
locpath2pf (LocPath Rel xsteps) = xsteps2pf xsteps
locpath2pf (LocPath Abs _) = error "absolute paths not supported"

xsteps2pf :: MonadPlus m => [XStep] -> m (Pf XPathQ)
xsteps2pf xsteps = do
	xs <- mapM xstep2pf xsteps
	return $ nestedXComp xs

nestedXComp :: [Pf XPathQ] -> Pf XPathQ
nestedXComp [] = EMPTYQ
nestedXComp [x] = x
nestedXComp (x:xs) = x :/: nestedXComp xs

xstep2pf :: MonadPlus m => XStep -> m (Pf XPathQ)
xstep2pf (Step axis node preds) =
	do { nd <- node2pf node; filters2pf (axis2pf axis :/: nd) preds }
	`mplus`
	do { filters2pf (axis2pf axis) preds }

node2pf :: MonadPlus m =>  NodeTest -> m (Pf XPathQ)
node2pf (NameTest n) = return $ NAME (qname n)
node2pf (TypeTest XPNode) = mzero
node2pf node = error $ "node " ++ show node ++ " unsupported"

qname :: QName -> String
qname n = localPart n

axis2pf :: AxisSpec -> Pf XPathQ
axis2pf Child = CHILD
axis2pf Descendant = DESCENDANT
axis2pf DescendantOrSelf = DESCSELF
axis2pf XPath.Self = SELF
axis2pf Attribute = ATTRIBUTE
axis2pf x = error $ "axisSpec2PF: axis " ++ show x ++ " not supported"

filters2pf :: MonadPlus m => Pf XPathQ -> [XPath] -> m (Pf XPathQ)
filters2pf pf = foldM filter2pf pf

filter2pf :: MonadPlus m => Pf XPathQ -> XPath -> m (Pf XPathQ)
filter2pf pf (NumberExpr i) = return $ filternatpf pf (intNat $ xpathnum2int i)
filter2pf pf pred = do
	p <- xpath2boolpf pred
	return $ pf :?: p

filternatpf :: Pf XPathQ -> Nat -> Pf XPathQ
filternatpf pf (Nat 0) = EMPTYQ
filternatpf pf (Nat 1) = pf `SEQQ` LHEAD
filternatpf pf (Nat (pred -> n)) = filternatpf (SEQQ pf LTAIL) (Nat n)

mkXPathQ :: Typeable a => Type a -> Pf (Q a) -> Pf XPathQ
mkXPathQ a pf = pf `SEQQ` (MKDYN a) `SEQQ` WRAP

constantpf :: Typeable a => Type a -> a -> Pf XPathQ
constantpf a x = mkXPathQ a $ SEQQ EMPTYQ (PNT x)

xpathnum2int :: XPNumber -> Int
xpathnum2int (XPath.Float f) = fromEnum f
xpathnum2int (XPath.NaN) = error "xpnumber NaN"
xpathnum2int (XPath.NegInf) = -2147483648
xpathnum2int (XPath.PosInf) = 2147483647
xpathnum2int (XPath.Neg0) = 0
xpathnum2int (XPath.Pos0) = 0

xpath2boolpf :: MonadPlus m => XPath -> m (Pf (Q Bool))
xpath2boolpf (GenExpr op ps) | isBoolOp op = do
	xs <- mapM xpath2boolpf ps
	return $ nestedOp (boolop2pf op) xs
xpath2boolpf exp = do
	pf <- expr2pf exp
	return $ boolean pf
	where boolean :: Pf XPathQ -> Pf (Q Bool)
              boolean pf = pf `SEQQ` NONEMPTY

boolop2pf :: Op -> Pf ((Bool,Bool) -> Bool)
boolop2pf Or = FUN "or" $ uncurry (||)
boolop2pf And = FUN "and" $ uncurry (&&)
boolop2pf Eq = FUN "eq" $ uncurry (==)
boolop2pf NEq = FUN "neq" $ uncurry (/=)
boolop2pf Less = FUN "less" $ uncurry (<)
boolop2pf Greater = FUN "greater" $ uncurry (>)
boolop2pf LessEq = FUN "lesseq" $ uncurry (<=)
boolop2pf GreaterEq = FUN "greatereq" $ uncurry (>=)

xpath2numpf :: MonadPlus m => XPath -> m (Pf (Q Int))
xpath2numpf (GenExpr op is) | isNumOp op = do
	xs <- mapM xpath2numpf is
	return $ nestedOp (numop2pf op) xs
xpath2numpf (NumberExpr i) = return $ SEQQ EMPTYQ (PNT (xpathnum2int i))
xpath2numpf exp = do
	pf <- expr2pf exp
	return $ number pf
	where number :: Pf XPathQ -> Pf (Q Int)
	      number (SEQQ pf WRAP) = SEQQ pf (UNDYN Int)
	      number pf = error $ "expression not a number: " ++ show pf

numop2pf :: Op -> Pf ((Int,Int) -> Int)
numop2pf Plus = FUN "plus" (uncurry (+))
numop2pf Minus = FUN "plus" (uncurry (-))
numop2pf Div = FUN "plus" (uncurry div)
numop2pf Mod = FUN "mod" (uncurry mod)
numop2pf Mult = FUN "mult" (uncurry (*))
numop2pf Unary = error "unary?"

xpath2natpf :: MonadPlus m => XPath -> m (Pf (Q Nat))
xpath2natpf (GenExpr op is) | isNumOp op = do
	xs <- mapM xpath2natpf is
	return $ nestedOp (natop2pf op) xs
xpath2natpf exp = do
	pf <- expr2pf exp
	return $ number pf
	where number :: Pf XPathQ -> Pf (Q Nat)
	      number (SEQQ pf WRAP) = SEQQ pf (UNDYN nat)
	      number pf = error $ "expression not a natural: " ++ show pf

natop2pf :: Op -> Pf ((Nat,Nat) -> Nat)
natop2pf Plus = PLUS
natop2pf Minus = error "minus undefined for naturals"
natop2pf Div = error "div undefined for naturals"
natop2pf Mod = error "mod undefined for naturals"
natop2pf Mult = error "mult undefined for naturals"
natop2pf Unary = error "unary?"

nestedOp :: (Monoid a,Typeable a) => Pf ((a,a) -> a) -> [Pf (Q a)] -> Pf (Q a)
nestedOp op [] = EMPTYQ
nestedOp op [p] = p
nestedOp op (p:ps) = SEQQ (p :/\: nestedOp op ps) op

isBoolOp :: Op -> Bool
isBoolOp x = or $ map (x==) $ [Or,And,XPath.Eq,NEq,Less,Greater,LessEq,GreaterEq]

isNumOp :: Op -> Bool
isNumOp x = or $ map (x==) $ [Plus,Minus,Div,Mod,Mult,Unary]

nestedUnion :: [Pf (Q [a])] -> Pf (Q [a])
nestedUnion [] = EMPTYQ
nestedUnion [x] = x
nestedUnion (x:xs) = x `UNION` (nestedUnion xs)