diff --git a/TableAlgebra.cabal b/TableAlgebra.cabal --- a/TableAlgebra.cabal +++ b/TableAlgebra.cabal @@ -2,7 +2,7 @@ Name: TableAlgebra synopsis: Ferry Table Algebra Category: Database -Version: 0.1.5 +Version: 0.6.1 Description: The Ferry 2.0 Table Algebra library . The table algebra [2] is an intermediate language used by Ferry 2.0 [3] and DSH [4]. @@ -30,12 +30,13 @@ buildable: True build-depends: base >= 4.2 && < 5, HaXml >= 1.20.2, mtl >= 2.0.1.0, containers >= 0.3.0.0, haskell98 >= 1.0.1.1, template-haskell >= 2.4.0.0, pretty >= 1.0.1.1 exposed-modules: Database.Ferry.Algebra + Database.Ferry.Algebra.Render.XML hs-source-dirs: src GHC-Options: -Wall -fno-warn-orphans -fno-warn-type-defaults -fno-warn-unused-do-bind other-modules: Database.Ferry.Algebra.Data.Algebra Database.Ferry.Algebra.Data.Create Database.Ferry.Algebra.Data.GraphBuilder - Database.Ferry.Algebra.Render.XML Database.Ferry.Algebra.Render.XMLUtils + Database.Ferry.Algebra.Monadic.Create Database.Ferry.Impossible diff --git a/src/Database/Ferry/Algebra.hs b/src/Database/Ferry/Algebra.hs --- a/src/Database/Ferry/Algebra.hs +++ b/src/Database/Ferry/Algebra.hs @@ -9,20 +9,19 @@ module Database.Ferry.Algebra ( AlgPlan, - transform, - union, emptyPlan, attach, proj, getLoop, subPlan, rownum, rownum', eqJoin, rank, eqTJoin, distinct, rowrank, cast, difference, aggr, - select, posSelect, dbTable, notC, cross, oper, emptyTable, - withBinding, withContext, getGamma, getPlan, fromGam, + union, attach, proj, getLoop, rownum, rownum', eqJoin, rank, eqTJoin, distinct, rowrank, cast, difference, aggr, + select, posSelect, dbTable, notC, cross, oper, emptyTable, tag, litTable, + withBinding, withContext, getGamma, fromGam, nat, int, bool, double, string, natT, intT, surT, boolT, doubleT, stringT, SortDir(..), AggrType(..), - SubPlan(..), AlgRes, Column(..), Columns, ATy(..), SchemaInfos, KeyInfos, AlgNode, GraphM, Gam, - initLoop, runGraph)where + initLoop, runGraph, ProjPair, ProjInf, + module Database.Ferry.Algebra.Monadic.Create)where import Database.Ferry.Algebra.Data.Algebra import Database.Ferry.Algebra.Data.Create import Database.Ferry.Algebra.Data.GraphBuilder -import Database.Ferry.Algebra.Render.XML +import Database.Ferry.Algebra.Monadic.Create diff --git a/src/Database/Ferry/Algebra/Data/Algebra.hs b/src/Database/Ferry/Algebra/Data/Algebra.hs --- a/src/Database/Ferry/Algebra/Data/Algebra.hs +++ b/src/Database/Ferry/Algebra/Data/Algebra.hs @@ -142,8 +142,9 @@ -- | Sort information, a list (ordered in sorting priority), of pair of columns and their sort direction-- type SortInf = [(SortAttrName, SortDir)] +type ProjPair = (NewAttrName, OldAttrName) -- | Projection information, a list of new attribute names, and their old names. -type ProjInf = [(NewAttrName, OldAttrName)] +type ProjInf = [ProjPair] -- | A tuple is a list of values type Tuple = [AVal] @@ -230,4 +231,5 @@ Aggr :: SemInfAggr -> AlgNode -> Algebra -- should have one child -- FunAggrCnt :: SemInfFunAggrCnt -> Algebra -- should have one child -- SerializeRel :: SemInfSerRel -> Algebra -- should have two children + Dummy :: String -> AlgNode -> Algebra -- Should have one child deriving (Show, Eq, Ord) diff --git a/src/Database/Ferry/Algebra/Data/Create.hs b/src/Database/Ferry/Algebra/Data/Create.hs --- a/src/Database/Ferry/Algebra/Data/Create.hs +++ b/src/Database/Ferry/Algebra/Data/Create.hs @@ -45,7 +45,7 @@ -- * Graph construction combinators for table algebra -- | Construct an empty table node with -emptyTable :: SchemaInfos -> GraphM AlgNode +emptyTable :: SchemaInfos -> GraphM a AlgNode emptyTable = insertNode . EmptyTable -- | Construct a database table node @@ -53,7 +53,7 @@ -- table. The second describes the columns in alphabetical order. -- The third argument describes the database keys (one table key can -- span over multiple columns). -dbTable :: String -> Columns -> KeyInfos -> GraphM AlgNode +dbTable :: String -> Columns -> KeyInfos -> GraphM a AlgNode dbTable n cs ks = insertNode $ TableRef (n, attr, ks) where attr = map (\c -> case c of @@ -61,90 +61,94 @@ _ -> error "Not a named column") cs -- | Construct a table with one value -litTable :: AVal -> String -> ATy -> GraphM AlgNode +litTable :: AVal -> String -> ATy -> GraphM a AlgNode litTable v s t = insertNode $ LitTable [[v]] [(s, t)] -- | Attach a column 'ResAttrName' of type `ATy' with value -- `AVal' in all rows to table `AlgNode' -attach :: ResAttrName -> ATy -> AVal -> AlgNode -> GraphM AlgNode +attach :: ResAttrName -> ATy -> AVal -> AlgNode -> GraphM a AlgNode attach n t v c = insertNode $ Attach (n, (t, v)) c -- | Cast column `AttrName' to type `ATy' and give it the name -- `ResAttrName' afterwards. -cast :: AttrName -> ResAttrName -> ATy -> AlgNode -> GraphM AlgNode +cast :: AttrName -> ResAttrName -> ATy -> AlgNode -> GraphM a AlgNode cast n r t c = insertNode $ Cast (r, n, t) c -- | Join two plans where the columns n1 of table 1 and columns n2 of table -- 2 are equal. -eqJoin :: String -> String -> AlgNode -> AlgNode -> GraphM AlgNode +eqJoin :: String -> String -> AlgNode -> AlgNode -> GraphM a AlgNode eqJoin n1 n2 c1 c2 = insertNode $ EqJoin (n1, n2) c1 c2 -- | The same as eqJoin but with multiple columns. -eqTJoin :: [(String, String)] -> ProjInf -> AlgNode -> AlgNode -> GraphM AlgNode +eqTJoin :: [(String, String)] -> ProjInf -> AlgNode -> AlgNode -> GraphM a AlgNode eqTJoin eqs projI q1 q2 = let (a, b) = head eqs in foldr filterEqs (eqJoin a b q1 q2) $ tail eqs where resCol = "item99999002" - filterEqs :: (String, String) -> GraphM AlgNode -> GraphM AlgNode + filterEqs :: (String, String) -> GraphM a AlgNode -> GraphM a AlgNode filterEqs (l, r) res = proj projI =<< select resCol =<< oper "==" resCol l r =<< res -- | Assign a number to each row in column 'ResAttrName' incrementing -- sorted by `SortInf'. The numbering is not dense! -rank :: ResAttrName -> SortInf -> AlgNode -> GraphM AlgNode +rank :: ResAttrName -> SortInf -> AlgNode -> GraphM a AlgNode rank res sort c1 = insertNode $ Rank (res, sort) c1 -- | Compute the difference between two plans. -difference :: AlgNode -> AlgNode -> GraphM AlgNode +difference :: AlgNode -> AlgNode -> GraphM a AlgNode difference q1 q2 = insertNode $ Difference q1 q2 -- | Same as rank but provides a dense numbering. -rowrank :: ResAttrName -> SortInf -> AlgNode -> GraphM AlgNode +rowrank :: ResAttrName -> SortInf -> AlgNode -> GraphM a AlgNode rowrank res sort c1 = insertNode $ RowRank (res, sort) c1 -- | Get's the nth element(s) of a (partitioned) table. -posSelect :: Int -> SortInf -> Maybe AttrName -> AlgNode -> GraphM AlgNode +posSelect :: Int -> SortInf -> Maybe AttrName -> AlgNode -> GraphM a AlgNode posSelect n sort part c1 = insertNode $ PosSel (n, sort, part) c1 -- | Select rows where the column `SelAttrName' contains True. -select :: SelAttrName -> AlgNode -> GraphM AlgNode +select :: SelAttrName -> AlgNode -> GraphM a AlgNode select sel c1 = insertNode $ Sel sel c1 -- | Remove duplicate rows -distinct :: AlgNode -> GraphM AlgNode +distinct :: AlgNode -> GraphM a AlgNode distinct c1 = insertNode $ Distinct c1 -- | Make cross product from two plans -cross :: AlgNode -> AlgNode -> GraphM AlgNode +cross :: AlgNode -> AlgNode -> GraphM a AlgNode cross c1 c2 = insertNode $ Cross c1 c2 -- | Negate the boolen value in column n and store it in column r -notC :: AttrName -> AttrName -> AlgNode -> GraphM AlgNode +notC :: AttrName -> AttrName -> AlgNode -> GraphM a AlgNode notC r n c1 = insertNode $ FunBoolNot (r, n) c1 -- | Union between two plans -union :: AlgNode -> AlgNode -> GraphM AlgNode +union :: AlgNode -> AlgNode -> GraphM a AlgNode union c1 c2 = insertNode $ DisjUnion c1 c2 -- | Project/rename certain column out of a plan -proj :: ProjInf -> AlgNode -> GraphM AlgNode +proj :: ProjInf -> AlgNode -> GraphM a AlgNode proj cols c = insertNode $ Proj cols c -- | Apply aggregate functions to a plan -aggr :: [(AggrType, ResAttrName, Maybe AttrName)] -> Maybe PartAttrName -> AlgNode -> GraphM AlgNode +aggr :: [(AggrType, ResAttrName, Maybe AttrName)] -> Maybe PartAttrName -> AlgNode -> GraphM a AlgNode aggr aggrs part c1 = insertNode $ Aggr (aggrs, part) c1 -- | Similar to rowrank but this will assign a \emph{unique} number to every row -- (even if two rows are equal) -rownum :: AttrName -> [AttrName] -> Maybe AttrName -> AlgNode -> GraphM AlgNode +rownum :: AttrName -> [AttrName] -> Maybe AttrName -> AlgNode -> GraphM a AlgNode rownum res sort part c1 = insertNode $ RowNum (res, zip sort $ repeat Asc, part) c1 -- | Same as rownum but columns can be assigned an ordering direction -rownum' :: AttrName -> [(AttrName, SortDir)] -> Maybe AttrName -> AlgNode -> GraphM AlgNode +rownum' :: AttrName -> [(AttrName, SortDir)] -> Maybe AttrName -> AlgNode -> GraphM a AlgNode rownum' res sort part c1 = insertNode $ RowNum (res, sort, part) c1 -- | Apply an operator to the element in `LeftAttrName' and `RightAttrName', -- store the result in `ResAttrName' -oper :: String -> ResAttrName -> LeftAttrName -> RightAttrName -> AlgNode -> GraphM AlgNode +oper :: String -> ResAttrName -> LeftAttrName -> RightAttrName -> AlgNode -> GraphM a AlgNode oper o r la ra c = insertNode $ FunBinOp (o, r, la, ra) c + +-- | Tag a subtree with a comment +tag :: String -> AlgNode -> GraphM a AlgNode +tag s c = insertNode $ Dummy s c -- | Shorthand for the initial loop condition used by Ferry. initLoop :: Algebra diff --git a/src/Database/Ferry/Algebra/Data/GraphBuilder.hs b/src/Database/Ferry/Algebra/Data/GraphBuilder.hs --- a/src/Database/Ferry/Algebra/Data/GraphBuilder.hs +++ b/src/Database/Ferry/Algebra/Data/GraphBuilder.hs @@ -16,64 +16,60 @@ -- | nodes to node ids. When a node is inserted and an equal node (equal means, equal node -- | and equal child nodes) already exists in the map the node id for that already existing -- | node is returned. This allows maximal sharing. -type GraphM = ReaderT (Gam, AlgNode) (State (Int, M.Map Algebra AlgNode)) +type GraphM a = ReaderT (Gam a, AlgNode) (State (Int, M.Map Algebra AlgNode, Tags)) -- | Variable environemtn mapping from variables to compiled nodes. -type Gam = [(String, AlgRes)] - -newtype SubPlan = SubPlan (M.Map Int AlgRes) - -instance Show SubPlan where - show (SubPlan p) = "SubPlans " ++ (show $ map (\(_,y,z) -> show (y, z)) $ M.elems p) - -emptyPlan :: SubPlan -emptyPlan = SubPlan M.empty - -subPlan :: Int -> AlgRes -> SubPlan -subPlan i p = SubPlan $ M.singleton i p - -getPlan :: Int -> SubPlan -> AlgRes -getPlan i (SubPlan p) = p M.! i --- | An algebraic solution is a triple consisting of the node id, a description of the database columns and all subplans -type AlgRes = (AlgNode, Columns, SubPlan) +type Gam a = [(String, a)] -- | An algebraic plan is the result of constructing a graph. -- | The pair consists of the mapping from nodes to their respective ids -- | and the algres from the top node. -type AlgPlan = (M.Map Algebra AlgNode, AlgRes) +type AlgPlan res = (M.Map Algebra AlgNode, res, Tags) +type Tags = M.Map AlgNode [String] + -- | Evaluate the monadic graph into an algebraic plan, given a loop relation. -runGraph :: Algebra -> GraphM AlgRes -> AlgPlan -runGraph l = (\(r, (_,m)) -> (m, r) ) . flip runState (2, M.singleton l 1) . flip runReaderT ([], 1) +runGraph :: Algebra -> GraphM res res -> AlgPlan res +runGraph l = (\(r, (_,m, c)) -> (m, r, c) ) . flip runState (2, M.singleton l 1, M.empty) . flip runReaderT ([], 1) +-- Add tag +addTag :: AlgNode -> String -> GraphM a () +addTag i c = modify insertTag + where + insertTag :: (Int, M.Map Algebra AlgNode, Tags) -> (Int, M.Map Algebra AlgNode, Tags) + insertTag (s, g, v) = (s, g, M.insertWith (++) i [c] v) + -- | Get the current loop table -getLoop :: GraphM AlgNode +getLoop :: GraphM a AlgNode getLoop = do (_, l) <- ask return l -- | Get the current variable environment -getGamma :: GraphM Gam +getGamma :: GraphM a (Gam a) getGamma = do (g, _) <- ask return g -- | Get a fresh node id -getFreshId :: GraphM Int +getFreshId :: GraphM a Int getFreshId = do - (n, t) <- get - put $ (n + 1, t) + (n, t, c) <- get + put $ (n + 1, t, c) return n -- | Check if a node already exists in the graph construction environment, if so return its id. -findNode :: Algebra -> GraphM (Maybe AlgNode) +findNode :: Algebra -> GraphM a (Maybe AlgNode) findNode n = do - (_, t) <- get + (_, t, _) <- get return $ M.lookup n t -- | Insert a node into the graph construction environment, first check if the node already exists -- | if so return its id, otherwise insert it and return its id. -insertNode :: Algebra -> GraphM AlgNode +insertNode :: Algebra -> GraphM a AlgNode +insertNode (Dummy s c) = do + addTag c s + return c insertNode n = do v <- findNode n case v of @@ -81,26 +77,26 @@ Nothing -> insertNode' n -- | Blindly insert a node, get a fresh id and return that -insertNode' :: Algebra -> GraphM AlgNode +insertNode' :: Algebra -> GraphM a AlgNode insertNode' n = do i <- getFreshId - (sup, t) <- get + (sup, t, c) <- get let t' = M.insert n i t - put $ (sup, t') + put $ (sup, t', c) return i -- | Evaluate the graph construction computation with the current environment extended with a binding n to v. -withBinding :: String -> AlgRes -> GraphM a -> GraphM a +withBinding :: String -> a -> GraphM a r -> GraphM a r withBinding n v a = do local (\(g, alg) -> ((n, v):g, alg)) a -- | Evaluate the graph construction computation with a differnt gamma, -- | and loop table. Return within he current computational context. -withContext :: Gam -> AlgNode -> GraphM a -> GraphM a +withContext :: Gam a -> AlgNode -> GraphM a r -> GraphM a r withContext gam loop = local (\_ -> (gam, loop)) -- | Lookup a variable in the environment -fromGam :: String -> GraphM AlgRes +fromGam :: String -> GraphM a a fromGam n = do (m, _) <- ask case lookup n m of diff --git a/src/Database/Ferry/Algebra/Monadic/Create.hs b/src/Database/Ferry/Algebra/Monadic/Create.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Algebra/Monadic/Create.hs @@ -0,0 +1,98 @@ +-- | This module exports monadic combinators for creating graphs +module Database.Ferry.Algebra.Monadic.Create (attachM, castM, eqJoinM, eqTJoinM, rankM, differenceM, rowrankM, posSelectM, selectM, + distinctM, crossM, notM, unionM, projM, aggrM, rownumM, rownum'M, operM, tagM) where + +import qualified Database.Ferry.Algebra.Data.Create as C +import Database.Ferry.Algebra.Data.Algebra +import Database.Ferry.Algebra.Data.GraphBuilder + +bind1 :: Monad m => (a -> m b) -> m a -> m b +bind1 = (=<<) + +bind2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c +bind2 f a b = do + a' <- a + b' <- b + f a' b' + +-- | Attach a column 'ResAttrName' of type `ATy' with value +-- `AVal' in all rows to table `AlgNode' +attachM :: ResAttrName -> ATy -> AVal -> GraphM a AlgNode -> GraphM a AlgNode +attachM n t v = bind1 (C.attach n t v) + +-- | Cast column `AttrName' to type `ATy' and give it the name +-- `ResAttrName' afterwards. +castM :: AttrName -> ResAttrName -> ATy -> GraphM a AlgNode -> GraphM a AlgNode +castM n r t = bind1 (C.cast n r t) + +-- | Join two plans where the columns n1 of table 1 and columns n2 of table +-- 2 are equal. +eqJoinM :: String -> String -> GraphM a AlgNode -> GraphM a AlgNode -> GraphM a AlgNode +eqJoinM n1 n2 = bind2 (C.eqJoin n1 n2) + +-- | The same as eqJoin but with multiple columns. +eqTJoinM :: [(String, String)] -> ProjInf -> GraphM a AlgNode -> GraphM a AlgNode -> GraphM a AlgNode +eqTJoinM eqs projI = bind2 (C.eqTJoin eqs projI) + +-- | Assign a number to each row in column 'ResAttrName' incrementing +-- sorted by `SortInf'. The numbering is not dense! +rankM :: ResAttrName -> SortInf -> GraphM a AlgNode -> GraphM a AlgNode +rankM res sort = bind1 (C.rank res sort) + +-- | Compute the difference between two plans. +differenceM :: GraphM a AlgNode -> GraphM a AlgNode -> GraphM a AlgNode +differenceM = bind2 C.difference + +-- | Same as rank but provides a dense numbering. +rowrankM :: ResAttrName -> SortInf -> GraphM a AlgNode -> GraphM a AlgNode +rowrankM res sort = bind1 (C.rowrank res sort) + +-- | Get's the nth element(s) of a (partitioned) table. +posSelectM :: Int -> SortInf -> Maybe AttrName -> GraphM a AlgNode -> GraphM a AlgNode +posSelectM n sort part = bind1 (C.posSelect n sort part) + +-- | Select rows where the column `SelAttrName' contains True. +selectM :: SelAttrName -> GraphM a AlgNode -> GraphM a AlgNode +selectM sel = bind1 (C.select sel) + +-- | Remove duplicate rows +distinctM :: GraphM a AlgNode -> GraphM a AlgNode +distinctM = bind1 C.distinct + +-- | Make cross product from two plans +crossM :: GraphM a AlgNode -> GraphM a AlgNode -> GraphM a AlgNode +crossM = bind2 C.cross + +-- | Negate the boolen value in column n and store it in column r +notM :: AttrName -> AttrName -> GraphM a AlgNode -> GraphM a AlgNode +notM r n = bind1 (C.notC r n) + +-- | Union between two plans +unionM :: GraphM a AlgNode -> GraphM a AlgNode -> GraphM a AlgNode +unionM = bind2 C.union + +-- | Project/rename certain column out of a plan +projM :: ProjInf -> GraphM a AlgNode -> GraphM a AlgNode +projM cols = bind1 (C.proj cols) + +-- | Apply aggregate functions to a plan +aggrM :: [(AggrType, ResAttrName, Maybe AttrName)] -> Maybe PartAttrName -> GraphM a AlgNode -> GraphM a AlgNode +aggrM aggrs part = bind1 (C.aggr aggrs part) + +-- | Similar to rowrank but this will assign a \emph{unique} number to every row +-- (even if two rows are equal) +rownumM :: AttrName -> [AttrName] -> Maybe AttrName -> GraphM a AlgNode -> GraphM a AlgNode +rownumM res sort part = bind1 (C.rownum res sort part) + +-- | Same as rownum but columns can be assigned an ordering direction +rownum'M :: AttrName -> [(AttrName, SortDir)] -> Maybe AttrName -> GraphM a AlgNode -> GraphM a AlgNode +rownum'M res sort part = bind1 (C.rownum' res sort part) + +-- | Apply an operator to the element in `LeftAttrName' and `RightAttrName', +-- store the result in `ResAttrName' +operM :: String -> ResAttrName -> LeftAttrName -> RightAttrName -> GraphM a AlgNode -> GraphM a AlgNode +operM o r la ra = bind1 (C.oper o r la ra) + +-- | Tag a subtree with a comment +tagM :: String -> GraphM a AlgNode -> GraphM a AlgNode +tagM s = bind1 (C.tag s) diff --git a/src/Database/Ferry/Algebra/Render/XML.hs b/src/Database/Ferry/Algebra/Render/XML.hs --- a/src/Database/Ferry/Algebra/Render/XML.hs +++ b/src/Database/Ferry/Algebra/Render/XML.hs @@ -1,66 +1,31 @@ {-# LANGUAGE TemplateHaskell #-} -module Database.Ferry.Algebra.Render.XML where +module Database.Ferry.Algebra.Render.XML (document, mkXMLDocument, mkPlanBundle, serializeAlgebra, + module Database.Ferry.Algebra.Render.XMLUtils, + module Text.XML.HaXml.Types, + iterCol, posCol, mkQueryPlan) where {- Transform a query plan DAG into an XML representation. -} 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 qualified Text.XML.HaXml.Pretty as P (document) import Text.XML.HaXml.Escape (xmlEscape, stdXmlEscaper) - import Text.PrettyPrint.HughesPJ -import qualified Data.Map as M - --- Transform a query plan with result type into a pretty doc. --- The type is used to add meta information to the XML that is used for pretty printing by ferryDB -transform :: (Bool, AlgPlan) -> Doc -transform (isList, p) = let plans = runXML M.empty $ planBuilder (mkProperty isList) p - planBundle = mkPlanBundle plans - in (document $ mkXMLDocument planBundle) - --- Transform a potentially nested algebraic plan into xml. --- The first argument is the overall result type property of the query. -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 - - --- Convert columns structure to xml properties for rendering by ferry DB -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" +document :: Document i -> Doc +document = P.document -- Serialize algebra -serializeAlgebra :: GraphNode -> Columns -> XML XMLNode -serializeAlgebra qGId cols = do +serializeAlgebra :: [Element ()] -> GraphNode -> XML XMLNode +serializeAlgebra cols qGId = do qId <- alg2XML qGId nilId <- nilNode xId <- freshId - let contentN = ((:) iterCol $ (:) posCol $ fst $ colsToNodes 1 cols) `childsOf` contentNode + let contentN = cols `childsOf` contentNode let edgeNil = mkEdge nilId let edgeQ = mkEdge qId tell [[contentN, edgeNil, edgeQ] `childsOf` node xId "serialize relation"] @@ -74,16 +39,6 @@ posCol :: Element () posCol = [attr "name" "pos", attr "new" "false", attr "function" "pos"] `attrsOf` xmlElem "column" --- Transform cs structure into xml columns -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) - -- XML defintion of nil node nilNode :: XML XMLNode nilNode = do @@ -100,12 +55,22 @@ case def of Just x -> return x Nothing -> do + debug <- debugEnabled nd <- getNode gId xId <- alg2XML' nd addNodeTrans gId xId - return xId - - + if debug + then + do + ts <- getTags gId + case ts of + Nothing -> return xId + Just x -> do + xId' <- alg2XML' (Dummy (unlines x) gId) + addNodeTrans gId xId' + return xId' + else + return xId where alg2XML' :: Algebra -> XML XMLNode alg2XML' (LitTable [[v]] [(n, ty)]) = do @@ -205,10 +170,18 @@ xId <- freshId tell [mkDifference xId cxId1 cxId2] return xId + alg2XML' (Dummy t cId1) = do + cxId1 <- alg2XML cId1 + xId <- freshId + tell [mkDummy xId t cxId1] + return xId alg2XML' _ = $impossible +mkDummy :: XMLNode -> String -> XMLNode -> Element () +mkDummy xId comment cxId1 = [[comment `dataChildOf` xmlElem "comment"] `childsOf` contentNode ,mkEdge cxId1]`childsOf` node xId "dummy" + mkDifference :: XMLNode -> XMLNode -> XMLNode -> Element () -mkDifference xId cxId1 cxId2 = [mkEdge cxId1, mkEdge cxId2]`childsOf` node xId "difference" +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" @@ -400,11 +373,3 @@ mkXMLDocument el = let xmlDecl = XMLDecl "1.0" (Just $ EncodingDecl "UTF-8") Nothing prol = Prolog (Just xmlDecl) [] Nothing [] in Document prol emptyST el [] - --- Create an xml property node so that ferryDB knows more or less how to print the result -mkProperty :: Bool -> Element () -mkProperty isList = [attr "name" "overallResultType", attr "value" result] `attrsOf` xmlElem "property" - where - result = case isList of - True -> "LIST" - False -> "TUPLE" diff --git a/src/Database/Ferry/Algebra/Render/XMLUtils.hs b/src/Database/Ferry/Algebra/Render/XMLUtils.hs --- a/src/Database/Ferry/Algebra/Render/XMLUtils.hs +++ b/src/Database/Ferry/Algebra/Render/XMLUtils.hs @@ -31,8 +31,19 @@ -- are the node ids from the graph. The state monad keeps track of the supply of fresh ids -- for xml nodes and the dictionary for looking up whether a certain graphnode already has -- an xml representation. -type XML = WriterT [Element ()] (ReaderT (M.Map AlgNode Algebra) (State (Int, Dictionary))) +type XML = WriterT [Element ()] (ReaderT (M.Map AlgNode Algebra, M.Map AlgNode [String], Bool) (State (Int, Dictionary))) +getTags :: GraphNode -> XML (Maybe [String]) +getTags i = do + (_, ts, _) <- ask + return $ M.lookup i ts + +-- Debug enabled? +debugEnabled :: XML Bool +debugEnabled = do + (_,_,d) <- ask + return d + -- Has a graphnode already been translated into an xml node. If yes which node? isDefined :: GraphNode -> XML (Maybe XMLNode) isDefined g = do @@ -55,13 +66,13 @@ -- Get a node from the algebraic plan with a certain graphNode id number getNode :: Int -> XML Algebra getNode i = do - nodes <- ask + (nodes, _, _) <- ask return $ nodes M.! i -- Run the monad and return a list of xml elements from the monad. -runXML :: M.Map AlgNode Algebra -> XML a -> [Element ()] -runXML m = snd . fst . flip runState (0, M.empty) . flip runReaderT m . runWriterT +runXML :: Bool -> M.Map AlgNode Algebra -> M.Map AlgNode [String] -> XML a -> [Element ()] +runXML debug m t = snd . fst . flip runState (0, M.empty) . flip runReaderT (m, t, debug) . runWriterT -- * Helper functions for constructing xml nodes