module Database.Ferry.Algebra.Render.XML where
import Database.Ferry.Impossible
import Database.Ferry.Algebra.Data.Algebra
import Database.Ferry.Algebra.Data.GraphBuilder
import Database.Ferry.Algebra.Render.XMLUtils
import Control.Monad.Writer
import Text.XML.HaXml.Types
import Text.XML.HaXml.Pretty (document)
import Text.XML.HaXml.Escape (xmlEscape, stdXmlEscaper)
import Text.PrettyPrint.HughesPJ
import qualified Data.Map as M
transform :: (Bool, AlgPlan) -> Doc
transform (isList, p) = let plans = runXML M.empty $ planBuilder (mkProperty isList) p
planBundle = mkPlanBundle plans
in (document $ mkXMLDocument planBundle)
planBuilder :: Element () -> AlgPlan -> XML ()
planBuilder prop (nodes, (top, cols, subs)) = buildPlan Nothing (Just prop) (top, cols, subs)
where
buildPlan :: Maybe (Int, Int) -> Maybe (Element ()) -> AlgRes -> XML ()
buildPlan parent props (top', cols', subs') =
do
let colProp = cssToProp cols'
let planProp = case props of
Nothing -> [colProp] `childsOf` xmlElem "properties"
Just p -> [colProp, p] `childsOf` xmlElem "properties"
let plan = runXML nodeTable $ serializeAlgebra top' cols'
pId <- mkQueryPlan parent planProp plan
buildSubPlans pId subs'
buildSubPlans :: Int -> SubPlan -> XML ()
buildSubPlans parent (SubPlan m) = let subPlans = M.toList m
in mapM_ (\(cId, res) -> buildPlan (Just (parent, cId)) Nothing res) subPlans
nodeTable = M.fromList $ map (\(a, b) -> (b, a)) $ M.toList nodes
cssToProp :: Columns -> Element ()
cssToProp cols = map csToProp cols `childsOf` [attr "name" "cs"] `attrsOf` xmlElem "property"
csToProp :: Column -> Element ()
csToProp (Col i ty) = [[attr "name" "type", attr "value" $ show ty] `attrsOf` xmlElem "property"] `childsOf` [attr "name" "offset", attr "value" $ show i] `attrsOf` xmlElem "property"
csToProp (NCol x css) = [cssToProp css] `childsOf` [attr "name" "mapping", attr "value" x] `attrsOf` xmlElem "property"
serializeAlgebra :: GraphNode -> Columns -> XML XMLNode
serializeAlgebra qGId cols = do
qId <- alg2XML qGId
nilId <- nilNode
xId <- freshId
let contentN = ((:) iterCol $ (:) posCol $ fst $ colsToNodes 1 cols) `childsOf` contentNode
let edgeNil = mkEdge nilId
let edgeQ = mkEdge qId
tell [[contentN, edgeNil, edgeQ] `childsOf` node xId "serialize relation"]
return xId
iterCol :: Element ()
iterCol = [attr "name" "iter", attr "new" "false", attr "function" "iter"] `attrsOf` xmlElem "column"
posCol :: Element ()
posCol = [attr "name" "pos", attr "new" "false", attr "function" "pos"] `attrsOf` xmlElem "column"
colsToNodes :: Int -> Columns -> ([Element ()], Int)
colsToNodes i ((Col n _):cs) = let col = [attr "name" $ "item" ++ (show n), attr "new" "false", attr "function" "item", attr "position" $ show i] `attrsOf` xmlElem "column"
(els, i') = colsToNodes (i+1) cs
in (col:els, i')
colsToNodes i ((NCol _ cs):cs') = let (els, i') = colsToNodes i cs
(els', i'') = colsToNodes i' cs'
in (els ++ els', i'')
colsToNodes i [] = ([], i)
nilNode :: XML XMLNode
nilNode = do
xId <- freshId
tell [node xId "nil"]
return xId
alg2XML :: GraphNode -> XML XMLNode
alg2XML gId = do
def <- isDefined gId
case def of
Just x -> return x
Nothing -> do
nd <- getNode gId
xId <- alg2XML' nd
addNodeTrans gId xId
return xId
where
alg2XML' :: Algebra -> XML XMLNode
alg2XML' (LitTable [[v]] [(n, ty)]) = do
xId <- freshId
tell [mkTableNode xId n v ty]
return xId
alg2XML' (Attach (n, (ty, val)) cId1) = do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkAttachNode xId n val ty cxId1]
return xId
alg2XML' (Proj proj cId1) = do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkProjNode xId proj cxId1]
return xId
alg2XML' (EqJoin jc cId1 cId2) = do
cxId1 <- alg2XML cId1
cxId2 <- alg2XML cId2
xId <- freshId
tell [mkEqJoinNode xId jc cxId1 cxId2]
return xId
alg2XML' (FunBinOp (op, res, lArg, rArg) cId) = do
cxId1 <- alg2XML cId
xId <- freshId
tell [mkBinOpNode xId op res lArg rArg cxId1]
return xId
alg2XML' (EmptyTable schema) = do
xId <- freshId
tell [mkEmptyTable xId schema]
return xId
alg2XML' (DisjUnion cId1 cId2) = do
cxId1 <- alg2XML cId1
cxId2 <- alg2XML cId2
xId <- freshId
tell [mkUnion xId cxId1 cxId2]
return xId
alg2XML' (Rank (res, sort) cId1) = do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkRank xId res sort cxId1]
return xId
alg2XML' (Cross cId1 cId2) = do
cxId1 <- alg2XML cId1
cxId2 <- alg2XML cId2
xId <- freshId
tell [mkCross xId cxId1 cxId2]
return xId
alg2XML' (TableRef (n, cs, ks)) = do
xId <- freshId
tell [mkTable xId n cs ks]
return xId
alg2XML' (Sel n cId1) = do
cxId <- alg2XML cId1
xId <- freshId
tell [mkSelect xId n cxId]
return xId
alg2XML' (PosSel (n, sort, part) cId1) = do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkPosSel xId n sort part cxId1]
return xId
alg2XML' (FunBoolNot (res, col) cId1) = do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkBoolNot xId res col cxId1]
return xId
alg2XML' (RowNum (res, sort, part) cId1) = do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkRowNum xId res sort part cxId1]
return xId
alg2XML' (Distinct cId1) = do
cxId <- alg2XML cId1
xId <- freshId
tell [mkDistinct xId cxId]
return xId
alg2XML' (RowRank (res, sort) cId1) = do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkRowRank xId res sort cxId1]
return xId
alg2XML' (Aggr (aggrs, part) cId1)
= do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkAggrs xId aggrs part cxId1]
return xId
alg2XML' (Cast (r, o, t) cId1) = do
cxId1 <- alg2XML cId1
xId <- freshId
tell [mkCast xId o r t cxId1]
return xId
alg2XML' (Difference cId1 cId2) = do
cxId1 <- alg2XML cId1
cxId2 <- alg2XML cId2
xId <- freshId
tell [mkDifference xId cxId1 cxId2]
return xId
alg2XML' _ = $impossible
mkDifference :: XMLNode -> XMLNode -> XMLNode -> Element ()
mkDifference xId cxId1 cxId2 = [mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "difference"
mkCast :: XMLNode -> AttrName -> AttrName -> ATy -> XMLNode -> Element ()
mkCast xId o r t c = [[column r True, column o False, typeN t] `childsOf` contentNode, mkEdge c] `childsOf` node xId "cast"
mkAggrs :: XMLNode -> [(AggrType, ResAttrName, Maybe AttrName)] -> Maybe PartAttrName -> XMLNode -> Element ()
mkAggrs xId aggrs part cId = let partCol = case part of
Nothing -> []
Just x -> [[attr "function" "partition"] `attrsOf` column x False]
aggr = map mkAggr aggrs
in [(partCol ++ aggr) `childsOf` contentNode, mkEdge cId] `childsOf` node xId "aggr"
where
mkAggr :: (AggrType, ResAttrName, Maybe AttrName) -> Element ()
mkAggr (aggr, res, arg) = let argCol = case arg of
Just arg' -> [[attr "function" "item"] `attrsOf` column arg' False]
Nothing -> []
in ((column res True):argCol) `childsOf` [attr "kind" $ show aggr] `attrsOf` xmlElem "aggregate"
mkPosSel :: XMLNode -> Int -> SortInf -> Maybe PartAttrName -> XMLNode -> Element ()
mkPosSel xId n sort part cId = let sortCols = map mkSortColumn $ zip sort [1..]
partCol = case part of
Nothing -> []
Just x -> [[attr "function" "partition"] `attrsOf` column x False]
posNode = n `dataChildOf` xmlElem "position"
in [((posNode:sortCols) ++ partCol) `childsOf` contentNode, mkEdge cId] `childsOf` node xId "pos_select"
mkRowRank :: XMLNode -> ResAttrName -> SortInf -> XMLNode -> Element ()
mkRowRank xId res sort cId = let sortCols = map mkSortColumn $ zip sort [1..]
in [(column res True : sortCols) `childsOf` contentNode, mkEdge cId] `childsOf` node xId "rowrank"
mkDistinct :: XMLNode -> XMLNode -> Element ()
mkDistinct xId cxId = [mkEdge cxId] `childsOf` node xId "distinct"
mkRowNum :: XMLNode -> ResAttrName -> SortInf -> Maybe PartAttrName -> XMLNode -> Element ()
mkRowNum xId res sort part cxId = let sortCols = map mkSortColumn $ zip sort [1..]
partCol = case part of
Nothing -> []
Just x -> [[attr "function" "partition"] `attrsOf` column x False]
in [(column res True:(sortCols ++ partCol)) `childsOf` contentNode , mkEdge cxId] `childsOf` node xId "rownum"
mkBoolNot :: XMLNode -> String -> String -> XMLNode -> Element ()
mkBoolNot xId res arg cxId = [[column res True, column arg False] `childsOf` contentNode, mkEdge cxId] `childsOf` node xId "not"
mkSelect :: XMLNode -> String -> XMLNode -> Element ()
mkSelect xId n cxId = [[column n False] `childsOf` contentNode, mkEdge cxId] `childsOf` node xId "select"
mkTable :: XMLNode -> String -> TableAttrInf -> KeyInfos -> Element ()
mkTable xId n descr keys = [[mkKeys keys] `childsOf` xmlElem "properties", [mkTableDescr n descr] `childsOf` contentNode] `childsOf` node xId "ref_tbl"
mkTableDescr :: String -> TableAttrInf -> Element ()
mkTableDescr n descr = map (\d -> toTableCol d ) descr `childsOf` [attr "name" n] `attrsOf` xmlElem "table"
where
toTableCol :: (AttrName, AttrName, ATy) -> Element ()
toTableCol (cn, xn, t) = [attr "name" xn, attr "tname" cn, attr "type" $ show t] `attrsOf` xmlElem "column"
mkKey :: KeyInfo -> Element ()
mkKey k = let bd = map (\(k', p) -> [attr "name" k', attr "position" $ show p] `attrsOf` xmlElem "column") $ zip k [1..]
in bd `childsOf` xmlElem "key"
mkKeys :: KeyInfos -> Element ()
mkKeys ks = map mkKey ks `childsOf` xmlElem "keys"
mkRank :: XMLNode -> ResAttrName -> SortInf -> XMLNode -> Element ()
mkRank xId res sort cId = let sortCols = map mkSortColumn $ zip sort [1..]
resCol = column res True
in [resCol:sortCols `childsOf` contentNode, mkEdge cId] `childsOf` node xId "rank"
mkSortColumn :: ((SortAttrName, SortDir), Int) -> Element ()
mkSortColumn ((n, d), p) = [attr "function" "sort", attr "position" $ show p, attr "direction" $ show d] `attrsOf` column n False
mkCross :: XMLNode -> XMLNode -> XMLNode -> Element ()
mkCross xId cxId1 cxId2 = [mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "cross"
mkUnion :: XMLNode -> XMLNode -> XMLNode -> Element ()
mkUnion xId cxId1 cxId2 = [mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "union"
mkEmptyTable :: XMLNode -> SchemaInfos -> Element ()
mkEmptyTable xId schema = [map mkColumn schema `childsOf` contentNode] `childsOf` node xId "empty_tbl"
mkColumn :: (AttrName, ATy) -> Element ()
mkColumn (n, t) = [attr "type" $ show t] `attrsOf` column n True
mkBinOpNode :: XMLNode -> String -> ResAttrName -> LeftAttrName -> RightAttrName -> XMLNode -> Element ()
mkBinOpNode xId op res lArg rArg cId | elem op ["+", "-", "*", "%", "/"] = mkFnNode xId (arOptoFn op) res lArg rArg cId
| elem op [">", "==", "and", "or", "&&", "||"] = mkRelFnNode xId (relOptoFn op) res lArg rArg cId
| elem op ["<" ] = mkBinOpNode xId ">" res rArg lArg cId
| otherwise = $impossible
where
arOptoFn :: String -> String
arOptoFn "+" = "add"
arOptoFn "-" = "subtract"
arOptoFn "/" = "divide"
arOptoFn "*" = "multiply"
arOptoFn "%" = "modulo"
arOptoFn _ = $impossible
relOptoFn :: String -> String
relOptoFn ">" = "gt"
relOptoFn "==" = "eq"
relOptoFn "and" = "and"
relOptoFn "or" = "or"
relOptoFn "&&" = "and"
relOptoFn "||" = "or"
relOptoFn _ = $impossible
mkRelFnNode :: XMLNode -> String -> ResAttrName -> LeftAttrName -> RightAttrName -> XMLNode -> Element ()
mkRelFnNode xId fn res lArg rArg cId = let content = [column res True,
[attr "position" "1"] `attrsOf` column lArg False,
[attr "position" "2"] `attrsOf` column rArg False] `childsOf` contentNode
in [content, mkEdge cId] `childsOf` node xId fn
mkFnNode :: XMLNode -> String -> ResAttrName -> LeftAttrName -> RightAttrName -> XMLNode -> Element ()
mkFnNode xId fn res lArg rArg cId = let cont = [[attr "name" fn] `attrsOf` xmlElem "kind",
column res True,
[attr "position" "1"] `attrsOf` column lArg False,
[attr "position" "2"] `attrsOf` column rArg False] `childsOf` contentNode
in [cont, mkEdge cId] `childsOf` node xId "fun"
mkEqJoinNode :: XMLNode -> (LeftAttrName,RightAttrName) -> XMLNode -> XMLNode -> Element ()
mkEqJoinNode xId (lN, rN) cxId1 cxId2 = let contNode = [[attr "position" "1"] `attrsOf` column lN False,
[attr "position" "2"] `attrsOf` column rN False] `childsOf` contentNode
in [contNode, mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "eqjoin"
mkProjNode :: XMLNode -> [(NewAttrName, OldAttrName)] -> XMLNode -> Element ()
mkProjNode xId mapping cxId = [map mkProjColumn mapping `childsOf` contentNode, mkEdge cxId] `childsOf` node xId "project"
where
mkProjColumn :: (NewAttrName, OldAttrName) -> Element ()
mkProjColumn (n, o) = [attr "old_name" o] `attrsOf` column n True
mkAttachNode :: XMLNode -> ColName -> AVal -> ATy -> XMLNode -> Element ()
mkAttachNode xId n val ty cxId = let valNode = val `dataChildOf` [attr "type" $ show ty] `attrsOf` xmlElem "value"
colNode = [xmlEscape stdXmlEscaper valNode] `childsOf` column n True
in [[colNode] `childsOf` contentNode, mkEdge cxId]`childsOf` node xId "attach"
mkTableNode :: XMLNode -> ColName -> AVal -> ATy -> Element ()
mkTableNode xId n val ty = let valNode = val `dataChildOf` [attr "type" $ show ty] `attrsOf` xmlElem "value"
colNode = [xmlEscape stdXmlEscaper valNode] `childsOf` column n True
conNode = [colNode] `childsOf` contentNode
in [conNode] `childsOf` node xId "table"
mkEdge :: XMLNode -> Element ()
mkEdge n = [attr "to" $ show n] `attrsOf` xmlElem "edge"
mkQueryPlan :: Maybe (Int, Int) -> Element () -> [Element ()] -> XML Int
mkQueryPlan parent props els = let logicalPlan = els `childsOf` [attr "unique_names" "true"] `attrsOf` xmlElem "logical_query_plan"
in do
planId <- freshId
let attrs = case parent of
Nothing -> [attr "id" $ show planId]
Just (p, c) -> [attr "id" $ show planId, attr "idref" $ show p, attr "colref" $ show c]
tell [[props, logicalPlan] `childsOf` attrs `attrsOf` xmlElem "query_plan"]
return planId
mkPlanBundle :: [Element ()] -> Element ()
mkPlanBundle plans = plans `childsOf` xmlElem "query_plan_bundle"
mkXMLDocument :: Element () -> Document ()
mkXMLDocument el = let xmlDecl = XMLDecl "1.0" (Just $ EncodingDecl "UTF-8") Nothing
prol = Prolog (Just xmlDecl) [] Nothing []
in Document prol emptyST el []
mkProperty :: Bool -> Element ()
mkProperty isList = [attr "name" "overallResultType", attr "value" result] `attrsOf` xmlElem "property"
where
result = case isList of
True -> "LIST"
False -> "TUPLE"