diff --git a/FerryCore.cabal b/FerryCore.cabal --- a/FerryCore.cabal +++ b/FerryCore.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.8 Name: FerryCore -Version: 0.4.5.1 +Version: 0.4.6.1 category: Database Synopsis: Ferry Core Components Description: The Ferry 2.0 Core @@ -26,7 +26,7 @@ Build-Type: Simple library buildable: True - build-depends: TableAlgebra >= 0.1.5, base >= 4.2 && < 5, HaXml >= 1.20.2, pretty >= 1.0.1.1, parsec >= 2.1.0.1, mtl >= 2.0.1.0, containers >= 0.3.0.0, haskell98 >= 1.0.1.1, template-haskell >= 2.4.0.0 + build-depends: TableAlgebra >= 0.6.1, base >= 4.2 && < 5, HaXml >= 1.20.2, pretty >= 1.0.1.1, parsec >= 2.1.0.1, mtl >= 2.0.1.0, containers >= 0.3.0.0, haskell98 >= 1.0.1.1, template-haskell >= 2.4.0.0 exposed-modules: Database.Ferry.Syntax Database.Ferry.Compiler Database.Ferry.SyntaxTyped @@ -69,4 +69,5 @@ Database.Ferry.TypeSystem.Types Database.Ferry.TypeSystem.Unification Database.Ferry.Common.Data.Base + Database.Ferry.Common.Data.Plans Database.Ferry.Impossible diff --git a/src/Database/Ferry/Common/Data/Plans.hs b/src/Database/Ferry/Common/Data/Plans.hs new file mode 100644 --- /dev/null +++ b/src/Database/Ferry/Common/Data/Plans.hs @@ -0,0 +1,84 @@ +module Database.Ferry.Common.Data.Plans where + +import Database.Ferry.Algebra(Columns, AlgNode) +import qualified Data.Map as M + +import Text.PrettyPrint.HughesPJ + +import Database.Ferry.Algebra(AlgPlan, Column(..)) +import Database.Ferry.Algebra.Render.XML + +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) + +-- * Rendering plans + +-- 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, Bool, AlgPlan AlgRes) -> Doc +transform (isList, debug, p) = let plans = runXML False M.empty M.empty $ planBuilder debug (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 :: Bool -> Element () -> AlgPlan AlgRes -> XML () +planBuilder debug prop (nodes, (top, cols, subs), tags) = 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 debug nodeTable tags $ serializeAlgebra ((:) iterCol $ (:) posCol $ fst $ colsToNodes 1 cols') top' + 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 + +-- 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" + +-- 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" + +-- 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) + + diff --git a/src/Database/Ferry/Compiler/Stages/AlgebraToXMLStage.hs b/src/Database/Ferry/Compiler/Stages/AlgebraToXMLStage.hs --- a/src/Database/Ferry/Compiler/Stages/AlgebraToXMLStage.hs +++ b/src/Database/Ferry/Compiler/Stages/AlgebraToXMLStage.hs @@ -5,18 +5,20 @@ import Database.Ferry.Compiler.Types import Database.Ferry.Compiler.ExecuteStep -import Database.Ferry.Algebra(AlgPlan, transform) +import Database.Ferry.Common.Data.Plans +import Database.Ferry.Algebra(AlgPlan) import Database.Ferry.TypedCore.Data.Type -xmlPhase :: (Qual FType, AlgPlan) -> PhaseResult String + +xmlPhase :: (Qual FType, AlgPlan AlgRes) -> PhaseResult String xmlPhase (_ :=> t, p) = executeStep xmlStage $ case t of - FList _ -> (True, p) - _ -> (False, p) + FList _ -> (True, False, p) + _ -> (False, False, p) -xmlStage :: CompilationStep (Bool, AlgPlan) String +xmlStage :: CompilationStep (Bool, Bool, AlgPlan AlgRes) String xmlStage = CompilationStep "ToXML" AlgebraXML step artefacts where - step :: (Bool, AlgPlan) -> PhaseResult String + step :: (Bool, Bool, AlgPlan AlgRes) -> PhaseResult String step = return . show . transform artefacts = [(XML, "xml", return)] diff --git a/src/Database/Ferry/Compiler/Stages/ToAlgebraStage.hs b/src/Database/Ferry/Compiler/Stages/ToAlgebraStage.hs --- a/src/Database/Ferry/Compiler/Stages/ToAlgebraStage.hs +++ b/src/Database/Ferry/Compiler/Stages/ToAlgebraStage.hs @@ -5,6 +5,7 @@ import Database.Ferry.Compiler.ExecuteStep import Database.Ferry.Algebra(runGraph, initLoop, AlgPlan) +import Database.Ferry.Common.Data.Plans import Database.Ferry.TypedCore.Data.Instances() import Database.Ferry.TypedCore.Convert.CoreToAlgebra @@ -12,13 +13,13 @@ import Database.Ferry.TypedCore.Data.TypedCore -algebraPhase :: CoreExpr -> PhaseResult (Qual FType, AlgPlan) +algebraPhase :: CoreExpr -> PhaseResult (Qual FType, AlgPlan AlgRes) algebraPhase e = executeStep algebraStage e -algebraStage :: CompilationStep CoreExpr (Qual FType, AlgPlan) +algebraStage :: CompilationStep CoreExpr (Qual FType, AlgPlan AlgRes) algebraStage = CompilationStep "ToAlg" Algebra step artefacts where - step :: CoreExpr -> PhaseResult (Qual FType, AlgPlan) + step :: CoreExpr -> PhaseResult (Qual FType, AlgPlan AlgRes) step e = let eTy = typeOf e in return $ (eTy, runGraph initLoop $ coreToAlgebra e) artefacts = [] diff --git a/src/Database/Ferry/TypedCore/Convert/CoreToAlgebra.hs b/src/Database/Ferry/TypedCore/Convert/CoreToAlgebra.hs --- a/src/Database/Ferry/TypedCore/Convert/CoreToAlgebra.hs +++ b/src/Database/Ferry/TypedCore/Convert/CoreToAlgebra.hs @@ -14,10 +14,12 @@ import Database.Ferry.Impossible import Database.Ferry.Common.Data.Base -import Database.Ferry.Algebra +import Database.Ferry.Algebra hiding (GraphM) +import qualified Database.Ferry.Algebra as A import Database.Ferry.TypedCore.Data.Type (Qual (..), FType (..), RLabel (..), isPrim) import Database.Ferry.TypedCore.Data.TypedCore as T +import Database.Ferry.Common.Data.Plans import qualified Data.Map as M import qualified Data.List as L @@ -52,6 +54,21 @@ prefixCol :: String prefixCol = "9999" +type GraphM = A.GraphM AlgRes + +recInNil2Alg :: Int -> [(RLabel, FType)] -> GraphM (Int, [(Int, AlgRes)]) +recInNil2Alg i [] = return (i, []) +recInNil2Alg i ((_, t):ts) = case t of + (FList _) -> do + r <- coreToAlgebra (Nil ([] :=> t)) + (i', p) <- recInNil2Alg (i + 1) ts + return (i', (i, r):p) + (FRec ts') -> do + (i', p) <- recInNil2Alg i ts' + (i'', p') <- recInNil2Alg i' ts + return (i'', p ++ p') + _ -> recInNil2Alg (i + 1) ts + -- | Transform Ferry core into a relation algebra modelled as a DAG coreToAlgebra :: CoreExpr -> GraphM AlgRes -- | Primitive values @@ -112,11 +129,14 @@ coreToAlgebra (Nil (_ :=> (FList t))) = do let cs = fst $ typeToCols t 1 let schema = ("iter", natT):("pos", natT):(colsToSchema cs) - n1 <- emptyTable schema + n1 <- tagM "Nil" $ emptyTable schema sub <- case t of (FList _) -> do s <- coreToAlgebra $ Nil $ [] :=> t return $ SubPlan $ M.singleton 1 s + (FRec ts) -> do + (_, p) <- recInNil2Alg 1 ts + return $ SubPlan $ M.fromList p _ -> return emptyPlan return (n1, cs, sub) coreToAlgebra (Nil _) = $impossible -- After type checking the only thing that reaches this stage has a list type @@ -167,7 +187,7 @@ -- | Transform the variable environment transformGam :: (AlgNode -> (String, AlgRes) -> GraphM (String, AlgRes)) - -> AlgNode -> Gam -> GraphM Gam + -> AlgNode -> Gam AlgRes -> GraphM (Gam AlgRes) transformGam f loop gamma = mapM (f loop) gamma -- | Transformation of gamma for if then else @@ -831,7 +851,7 @@ -- map forward transforms the environment etc into the versions needed to compute in -- a loop context. The result is (qv', qv, mapv, loopv, Gamv) -mapForward :: Gam -> AlgNode -> Columns -> GraphM (AlgNode, AlgNode, AlgNode, AlgNode, Gam) +mapForward :: Gam AlgRes -> AlgNode -> Columns -> GraphM (AlgNode, AlgNode, AlgNode, AlgNode, Gam AlgRes) mapForward gam q cs = do let csProj = zip (leafNames cs) (leafNames cs) qv' <- rownum inner ["iter", "pos"] Nothing q