FerryCore 0.4.5.1 → 0.4.6.1

raw patch · 5 files changed

+123/−15 lines, 5 filesdep ~TableAlgebraPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: TableAlgebra

API changes (from Hackage documentation)

Files

• FerryCore.cabal +3/−2
• src/Database/Ferry/Common/Data/Plans.hs +84/−0
• src/Database/Ferry/Compiler/Stages/AlgebraToXMLStage.hs +8/−6
• src/Database/Ferry/Compiler/Stages/ToAlgebraStage.hs +4/−3
• src/Database/Ferry/TypedCore/Convert/CoreToAlgebra.hs +24/−4

@@ -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 

@@ -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)++

@@ -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)]

@@ -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 = []

@@ -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