dsh-sql (empty) → 0.2.0.0
raw patch · 24 files changed
+4321/−0 lines, 24 filesdep +DSHdep +Decimaldep +HDBCsetup-changed
Dependencies added: DSH, Decimal, HDBC, HDBC-odbc, HUnit, QuickCheck, aeson, algebra-dag, algebra-sql, base, bytestring, bytestring-lexing, containers, dsh-sql, either, mtl, process, random, semigroups, set-monad, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, text, vector
Files
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +3/−0
- dsh-sql.cabal +103/−0
- src/Database/DSH/Backend/Sql.hs +373/−0
- src/Database/DSH/Backend/Sql/Opt/OptimizeTA.hs +34/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Auxiliary.hs +81/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/BottomUp.hs +106/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Card1.hs +40/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Cols.hs +160/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Const.hs +75/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Empty.hs +38/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/FD.hs +125/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/ICols.hs +117/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Keys.hs +182/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Nullable.hs +88/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Order.hs +106/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/TopDown.hs +113/−0
- src/Database/DSH/Backend/Sql/Opt/Properties/Types.hs +69/−0
- src/Database/DSH/Backend/Sql/Opt/Rewrite/Basic.hs +1007/−0
- src/Database/DSH/Backend/Sql/Opt/Rewrite/Common.hs +35/−0
- src/Database/DSH/Backend/Sql/Vector.hs +102/−0
- src/Database/DSH/Backend/Sql/VectorAlgebra.hs +1306/−0
- testsuite/Main.hs +22/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright George Giorgidze, Alexander Ulrich, Tom Schreiber, Nils Schweinsberg and Jeroen Weijers 2010 - 2012++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the names of the authors nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,6 @@+# PostgreSQL backend for Database-Supported Haskell (DSH)++This package provides an SQL backend for Database Supported Haskell+(DSH). It provides the ability to generate SQL code and execute DSH+queries on supported SQL database engines. Currently, only PostgreSQL+is supported.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ dsh-sql.cabal view
@@ -0,0 +1,103 @@+Name: dsh-sql+Version: 0.2.0.0+Synopsis: SQL backend for Database Supported Haskell (DSH)+Description:+ This package provides an SQL backend for Database Supported Haskell+ (DSH). It provides the ability to generate SQL code and execute DSH+ queries on supported SQL database engines. Currently, only+ PostgreSQL is supported.++License: BSD3+License-file: LICENSE+Author: Alexander Ulrich+Maintainer: alex@etc-network.de+Stability: Experimental+Category: Database+Build-type: Simple++Extra-source-files: README.md++Cabal-version: >= 1.8++Flag debuggraph+ Description: Print debugging information for graph rewrites (TA)+ Default: False++Library+ Extensions: CPP+ Build-depends:+ DSH >= 0.12+ , random >= 1.1+ , process >= 1.2+ , Decimal >= 0.4+ , HDBC >= 2.4.0.1+ , HDBC-odbc >= 2.4+ , aeson >= 0.8+ , algebra-dag >= 0.1+ , algebra-sql >= 0.3+ , base >= 4.8 && < 5+ , bytestring >= 0.10+ , bytestring-lexing >= 0.4+ , containers >= 0.5+ , either >= 4.0+ , mtl >= 2.1+ , semigroups >= 0.16+ , set-monad >= 0.1+ , template-haskell >= 2.9+ , text >= 1.1+ , vector >= 0.10++ Hs-source-dirs: src++ if flag(debuggraph)+ CPP-Options: -DDEBUGGRAPH++ GHC-Options: -Wall -fno-warn-orphans -fprof-auto -O2++ Exposed-modules: Database.DSH.Backend.Sql++ Other-modules: Database.DSH.Backend.Sql.Opt.Properties.BottomUp+ Database.DSH.Backend.Sql.Opt.Properties.TopDown+ Database.DSH.Backend.Sql.Opt.Properties.Types+ Database.DSH.Backend.Sql.Opt.Properties.Cols+ Database.DSH.Backend.Sql.Opt.Properties.Nullable+ Database.DSH.Backend.Sql.Opt.Properties.FD+ Database.DSH.Backend.Sql.Opt.Properties.ICols+ Database.DSH.Backend.Sql.Opt.Properties.Auxiliary+ Database.DSH.Backend.Sql.Opt.Properties.Empty+ Database.DSH.Backend.Sql.Opt.Properties.Card1+ Database.DSH.Backend.Sql.Opt.Properties.Keys+ Database.DSH.Backend.Sql.Opt.Properties.Order+ Database.DSH.Backend.Sql.Opt.Properties.Const+ Database.DSH.Backend.Sql.Opt.Rewrite.Basic+ Database.DSH.Backend.Sql.Opt.Rewrite.Common+ Database.DSH.Backend.Sql.Opt.OptimizeTA+ Database.DSH.Backend.Sql.VectorAlgebra+ Database.DSH.Backend.Sql.Vector++Test-Suite sqltests+ type: exitcode-stdio-1.0+ Hs-Source-Dirs : testsuite+ Main-is: Main.hs+ Build-depends:+ DSH >= 0.10+ , HDBC >= 2.4.0.1+ , HDBC-odbc >= 2.4+ , HUnit >= 1.2+ , QuickCheck >= 2.4+ , base >= 4.8 && < 5+ , bytestring >= 0.10+ , bytestring-lexing >= 0.4+ , containers >= 0.5+ , dsh-sql >= 0.1+ , test-framework >= 0.6+ , test-framework-hunit >= 0.3+ , test-framework-quickcheck2 >= 0.2+ , text >= 1.1+ , vector >= 0.10+ GHC-Options: -Wall -fno-warn-orphans+ Extensions: CPP++source-repository head+ type: git+ location: https://github.com/ulricha/dsh-sql
+ src/Database/DSH/Backend/Sql.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module implements the execution of SQL query bundles and the+-- construction of nested values from the resulting vector bundle.+module Database.DSH.Backend.Sql+ ( -- * The relational SQL backend+ SqlBackend+ , sqlBackend+ , unwrapCode+ -- * Show and tell: display relational plans.+ , showRelationalQ+ , showRelationalOptQ+ , showSqlQ+ , showTabularQ+ ) where++import System.Process+import System.Random+import Text.Printf++import qualified Database.HDBC as H+import Database.HDBC.ODBC++import Control.Monad+import Control.Monad.State+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lex.Double as BD+import qualified Data.ByteString.Lex.Integral as BI+import Data.Decimal+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V++import qualified Database.Algebra.Dag as D+import qualified Database.Algebra.Dag.Build as B+import Database.Algebra.Dag.Common+import Database.Algebra.SQL.Compatibility+import Database.Algebra.SQL.Materialization.CTE+import Database.Algebra.SQL.Util+import qualified Database.Algebra.Table.Lang as TA++import qualified Database.DSH as DSH+import Database.DSH.Backend+import Database.DSH.Backend.Sql.Opt.OptimizeTA+import Database.DSH.Backend.Sql.Vector+import Database.DSH.Backend.Sql.VectorAlgebra+import Database.DSH.Common.Impossible+import Database.DSH.Common.QueryPlan+import Database.DSH.Common.Vector+import qualified Database.DSH.Compiler as C+import Database.DSH.VL++--------------------------------------------------------------------------------++newtype SqlBackend = SqlBackend Connection++-- | Construct a PostgreSQL backend based on an HDBC PostgreSQL+-- connection.+sqlBackend :: Connection -> SqlBackend+sqlBackend = SqlBackend++newtype SqlCode = SqlCode { unSql :: String }++data SqlVector = SqlVector SqlCode VecOrder VecKey VecRef VecItems++unwrapCode :: BackendCode SqlBackend -> String+unwrapCode (BC (SqlVector (SqlCode q) _ _ _ _)) = q++instance RelationalVector SqlVector where+ rvKeyCols (SqlVector _ _ k _ _) = map kc $ [1..unKey k]+ rvRefCols (SqlVector _ _ _ r _) = map rc $ [1..unRef r]+ rvItemCols (SqlVector _ _ _ _ i) = V.generate (unItems i) (ic . (+ 1))++--------------------------------------------------------------------------------++-- | In a query shape, render each root node for the algebraic plan+-- into a separate SQL query.++-- FIXME use materialization "prelude"+-- FIXME use Functor instance+generateSqlQueries :: QueryPlan TA.TableAlgebra TADVec -> Shape (BackendCode SqlBackend)+generateSqlQueries taPlan = renderSql $ queryShape taPlan+ where+ roots :: [AlgNode]+ roots = D.rootNodes $ queryDag taPlan++ (_sqlShared, sqlQueries) = renderOutputDSHWith PostgreSQL materialize (queryDag taPlan)++ nodeToQuery :: [(AlgNode, SqlCode)]+ nodeToQuery = zip roots (map SqlCode sqlQueries)++ lookupNode :: AlgNode -> SqlCode+ lookupNode n = maybe $impossible id $ lookup n nodeToQuery++ renderSql = fmap (\(TADVec q o k r i) -> BC $ SqlVector (lookupNode q) o k r i)++--------------------------------------------------------------------------------++type TAVecBuild a = VecBuild TA.TableAlgebra+ (DVec TA.TableAlgebra)+ (RVec TA.TableAlgebra)+ (KVec TA.TableAlgebra)+ (FVec TA.TableAlgebra)+ (SVec TA.TableAlgebra)+ a++-- | Insert SerializeRel operators in TA.TableAlgebra plans to define+-- descr and order columns as well as the required payload columns.+-- FIXME: once we are a bit more flexible wrt surrogates, determine the+-- surrogate (i.e. descr) columns from information in NDVec.+insertSerialize :: TAVecBuild (Shape (DVec TA.TableAlgebra))+ -> TAVecBuild (Shape (DVec TA.TableAlgebra))+insertSerialize g = g >>= traverseShape++ where+ traverseShape :: Shape TADVec -> TAVecBuild (Shape TADVec)+ traverseShape (VShape dvec lyt) = do+ mLyt' <- traverseLayout lyt+ case mLyt' of+ Just lyt' -> do+ dvec' <- insertOp dvec noRef needKey needOrd+ return $ VShape dvec' lyt'+ Nothing -> do+ dvec' <- insertOp dvec noRef noKey needOrd+ return $ VShape dvec' lyt++ traverseShape (SShape dvec lyt) = do+ mLyt' <- traverseLayout lyt+ case mLyt' of+ Just lyt' -> do+ dvec' <- insertOp dvec noRef needKey noOrd+ return $ SShape dvec' lyt'+ Nothing -> do+ dvec' <- insertOp dvec noRef noKey noOrd+ return $ SShape dvec' lyt++ traverseLayout :: (Layout TADVec) -> TAVecBuild (Maybe (Layout TADVec))+ traverseLayout LCol = return Nothing+ traverseLayout (LTuple lyts) = do+ mLyts <- mapM traverseLayout lyts+ if all isNothing mLyts+ then return Nothing+ else return $ Just $ LTuple $ zipWith (\l ml -> maybe l id ml) lyts mLyts+ traverseLayout (LNest dvec lyt) = do+ mLyt' <- traverseLayout lyt+ case mLyt' of+ Just lyt' -> do+ dvec' <- insertOp dvec needRef needKey needOrd+ return $ Just $ LNest dvec' lyt'+ Nothing -> do+ dvec' <- insertOp dvec needRef noKey needOrd+ return $ Just $ LNest dvec' lyt++ -- | Insert a Serialize node for the given vector+ insertOp :: TADVec+ -> (VecRef -> [TA.RefCol])+ -> (VecKey -> [TA.KeyCol])+ -> (VecOrder -> [TA.OrdCol])+ -> TAVecBuild TADVec+ insertOp (TADVec q o k r i) mkRef mkKey mkOrd = do+ let op = TA.Serialize (mkRef r, mkKey k, mkOrd o, needItems i)++ qp <- lift $ B.insert $ UnOp op q+ return $ TADVec qp o k r i++ needRef :: VecRef -> [TA.RefCol]+ needRef (VecRef 0) = []+ needRef (VecRef i) = [ TA.RefCol (rc c) (TA.ColE $ rc c) | c <- [1..i] ]++ noRef :: VecRef -> [TA.RefCol]+ noRef = const []++ needOrd :: VecOrder -> [TA.OrdCol]+ needOrd (VecOrder ds) = [ TA.OrdCol (oc i, d) (TA.ColE $ oc i)+ | i <- [1..] | d <- ds+ ]++ noOrd :: VecOrder -> [TA.OrdCol]+ noOrd = const []++ needKey :: VecKey -> [TA.KeyCol]+ needKey (VecKey i) = [ TA.KeyCol (kc c) (TA.ColE $ kc c) | c <- [1..i] ]++ noKey :: VecKey -> [TA.KeyCol]+ noKey = const []++ needItems :: VecItems -> [TA.PayloadCol]+ needItems (VecItems 0) = []+ needItems (VecItems i) = [ TA.PayloadCol (ic c) (TA.ColE $ ic c) | c <- [1..i] ]++implementVectorOps :: QueryPlan VL VLDVec -> QueryPlan TA.TableAlgebra TADVec+implementVectorOps vlPlan = mkQueryPlan dag shape tagMap+ where+ taPlan = vl2Algebra (D.nodeMap $ queryDag vlPlan)+ (queryShape vlPlan)+ serializedPlan = insertSerialize taPlan+ (dag, shape, tagMap) = runVecBuild serializedPlan++--------------------------------------------------------------------------------++instance RelationalVector (BackendCode SqlBackend) where+ rvKeyCols (BC v) = rvKeyCols v+ rvItemCols (BC v) = rvItemCols v+ rvRefCols (BC v) = rvRefCols v++instance Backend SqlBackend where+ data BackendRow SqlBackend = SqlRow (M.Map String H.SqlValue)+ data BackendCode SqlBackend = BC SqlVector+ data BackendPlan SqlBackend = QP (QueryPlan TA.TableAlgebra TADVec)++ execFlatQuery (SqlBackend conn) (BC (SqlVector q _ _ _ _)) = do+ stmt <- H.prepare conn (unSql q)+ void $ H.execute stmt []+ map SqlRow <$> H.fetchAllRowsMap' stmt++ generateCode :: BackendPlan SqlBackend -> Shape (BackendCode SqlBackend)+ generateCode (QP plan) = generateSqlQueries $ optimizeTA plan++ generatePlan :: QueryPlan VL VLDVec -> BackendPlan SqlBackend+ generatePlan = QP . implementVectorOps++ dumpPlan :: String -> Bool -> BackendPlan SqlBackend -> IO String+ dumpPlan prefix False (QP plan) = do+ let fileName = prefix ++ "_ta"+ exportPlan fileName plan+ return fileName+ dumpPlan prefix True (QP plan) = do+ let fileName = prefix ++ "_opt_ta"+ exportPlan fileName $ optimizeTA plan+ return fileName++ transactionally (SqlBackend conn) ma =+ H.withTransaction conn (\c -> ma (SqlBackend c))++--------------------------------------------------------------------------------++instance Row (BackendRow SqlBackend) where+ data Scalar (BackendRow SqlBackend) = SqlScalar H.SqlValue++ col c (SqlRow r) =+ case M.lookup c r of+ Just v -> SqlScalar v+ Nothing -> error $ printf "col lookup %s failed in %s" c (show r)++ keyVal :: Scalar (BackendRow SqlBackend) -> KeyVal+ keyVal (SqlScalar v) = case v of+ H.SqlInt32 i -> KInteger $ fromIntegral i+ H.SqlInt64 i -> KInteger $ fromIntegral i+ H.SqlWord32 i -> KInteger $ fromIntegral i+ H.SqlWord64 i -> KInteger $ fromIntegral i+ H.SqlInteger i -> KInteger $ fromIntegral i+ H.SqlString s -> KByteString $ BS.pack s+ H.SqlByteString s -> KByteString s+ H.SqlLocalDate d -> KDay d++ _ -> $impossible+++ descrVal (SqlScalar (H.SqlInt32 i)) = fromIntegral i+ descrVal (SqlScalar (H.SqlInteger i)) = fromIntegral i+ descrVal _ = $impossible++ unitVal (SqlScalar H.SqlNull) = unitE+ unitVal (SqlScalar (H.SqlInteger _)) = unitE+ unitVal (SqlScalar (H.SqlInt64 _)) = unitE+ unitVal (SqlScalar v) = error $ printf "unitVal: %s" (show v)++ integerVal (SqlScalar (H.SqlInteger i)) = integerE i+ integerVal (SqlScalar (H.SqlInt32 i)) = integerE $ fromIntegral i+ integerVal (SqlScalar (H.SqlInt64 i)) = integerE $ fromIntegral i+ integerVal (SqlScalar (H.SqlWord32 i)) = integerE $ fromIntegral i+ integerVal (SqlScalar (H.SqlWord64 i)) = integerE $ fromIntegral i+ integerVal _ = $impossible++ doubleVal (SqlScalar (H.SqlDouble d)) = doubleE d+ doubleVal (SqlScalar (H.SqlRational d)) = doubleE $ fromRational d+ doubleVal (SqlScalar (H.SqlInteger d)) = doubleE $ fromIntegral d+ doubleVal (SqlScalar (H.SqlInt32 d)) = doubleE $ fromIntegral d+ doubleVal (SqlScalar (H.SqlInt64 d)) = doubleE $ fromIntegral d+ doubleVal (SqlScalar (H.SqlWord32 d)) = doubleE $ fromIntegral d+ doubleVal (SqlScalar (H.SqlWord64 d)) = doubleE $ fromIntegral d+ doubleVal (SqlScalar (H.SqlByteString c)) = doubleE $ maybe $impossible fst (BD.readDouble c)+ doubleVal (SqlScalar v) = error $ printf "doubleVal: %s" (show v)++ boolVal (SqlScalar (H.SqlBool b)) = boolE b+ boolVal (SqlScalar (H.SqlInteger i)) = boolE (i /= 0)+ boolVal (SqlScalar (H.SqlInt32 i)) = boolE (i /= 0)+ boolVal (SqlScalar (H.SqlInt64 i)) = boolE (i /= 0)+ boolVal (SqlScalar (H.SqlWord32 i)) = boolE (i /= 0)+ boolVal (SqlScalar (H.SqlWord64 i)) = boolE (i /= 0)+ boolVal (SqlScalar (H.SqlByteString s)) = boolE $ (maybe $impossible fst (BI.readDecimal s) /= (0 :: Integer))+ boolVal (SqlScalar v) = error $ printf "boolVal: %s" (show v)++ charVal (SqlScalar (H.SqlChar c)) = charE c+ charVal (SqlScalar (H.SqlString (c:_))) = charE c+ charVal (SqlScalar (H.SqlByteString c)) = charE (head $ T.unpack $ TE.decodeUtf8 c)+ charVal _ = $impossible++ textVal (SqlScalar (H.SqlString t)) = textE (T.pack t)+ textVal (SqlScalar (H.SqlByteString s)) = textE (TE.decodeUtf8 s)+ textVal _ = $impossible++ -- FIXME this is an incredibly crude method to convert HDBC's+ -- rationals to decimals. Implement this reasonably or - even+ -- better - replace HDBC completely. Rationals do not make sense+ -- here.+ decimalVal (SqlScalar (H.SqlRational d)) = decimalE $ realFracToDecimal 5 d+ decimalVal (SqlScalar (H.SqlByteString c)) = decimalE $ read $ BS.unpack c+ decimalVal (SqlScalar v) = error $ printf "decimalVal: %s" (show v)++ dayVal (SqlScalar (H.SqlLocalDate d)) = dayE d+ dayVal _ = $impossible++--------------------------------------------------------------------------------++fileId :: IO String+fileId = sequence $ replicate 8 $ (randomRIO ('a', 'z'))++-- | Show the unoptimized relational table algebra plan+showRelationalQ :: forall a.DSH.QA a => DSH.Q a -> IO ()+showRelationalQ q = do+ let vl = C.vectorPlanQ q+ let bp = generatePlan vl :: BackendPlan SqlBackend+ h <- fileId+ fileName <- dumpPlan ("q_ta_" ++ h) False bp+ void $ runCommand $ printf ".cabal-sandbox/bin/tadot -i %s.plan | dot -Tpdf -o %s.pdf" fileName fileName+ void $ runCommand $ printf "evince %s.pdf" fileName++-- | Show the optimized relational table algebra plan+showRelationalOptQ :: forall a.DSH.QA a => DSH.Q a -> IO ()+showRelationalOptQ q = do+ let vl = C.vectorPlanQ q+ let bp = generatePlan vl :: BackendPlan SqlBackend+ h <- fileId+ fileName <- dumpPlan ("q_ta_" ++ h) True bp+ void $ runCommand $ printf ".cabal-sandbox/bin/tadot -i %s.plan | dot -Tpdf -o %s.pdf" fileName fileName+ void $ runCommand $ printf "evince %s.pdf" fileName++-- | Show all SQL queries produced for the given query+showSqlQ :: forall a.DSH.QA a => DSH.Q a -> IO ()+showSqlQ q = do+ putStrLn sepLine+ forM_ (map unwrapCode $ C.codeQ undefined q) $ \sql -> do+ putStrLn sql+ putStrLn sepLine++ where+ sepLine = replicate 80 '-'++-- | Show raw tabular results via 'psql', executed on the specified+-- database..+showTabularQ :: forall a. DSH.QA a => String -> DSH.Q a -> IO ()+showTabularQ db q = do+ forM_ (map unwrapCode $ C.codeQ undefined q) $ \sql -> do+ putStrLn ""+ h <- fileId+ let queryFile = printf "q_%s.sql" h+ writeFile queryFile sql+ hdl <- runCommand $ printf "psql %s < %s" db queryFile+ void $ waitForProcess hdl+ putStrLn sepLine++ where+ sepLine = replicate 80 '-'+
+ src/Database/DSH/Backend/Sql/Opt/OptimizeTA.hs view
@@ -0,0 +1,34 @@+module Database.DSH.Backend.Sql.Opt.OptimizeTA where++import qualified Data.IntMap as M++import qualified Database.Algebra.Dag as Dag+import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Opt.Rewrite.Basic+import Database.DSH.Backend.Sql.Vector+import Database.DSH.Common.QueryPlan++import Database.DSH.Common.Opt++type RewriteClass = Rewrite TableAlgebra (Shape TADVec) Bool++defaultPipeline :: [RewriteClass]+defaultPipeline = [cleanup]++runPipeline :: Dag.AlgebraDag TableAlgebra+ -> (Shape TADVec)+ -> [RewriteClass]+ -> Bool+ -> (Dag.AlgebraDag TableAlgebra, Log, Shape TADVec)+runPipeline d sh pipeline debug = (d', rewriteLog, sh')+ where (d', sh', _, rewriteLog) = runRewrite (sequence_ pipeline) d sh debug++optimizeTA :: QueryPlan TableAlgebra TADVec -> QueryPlan TableAlgebra TADVec+optimizeTA plan =+#ifdef DEBUGGRAPH+ let (d, _rewriteLog, shape) = runPipeline (queryDag plan) (queryShape plan) defaultPipeline True+#else+ let (d, _rewriteLog, shape) = runPipeline (queryDag plan) (queryShape plan) defaultPipeline False+#endif+ in QueryPlan { queryDag = d, queryShape = shape, queryTags = M.empty }
+ src/Database/DSH/Backend/Sql/Opt/Properties/Auxiliary.hs view
@@ -0,0 +1,81 @@+-- | Some auxiliary functions for property inference.+module Database.DSH.Backend.Sql.Opt.Properties.Auxiliary where++import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Set.Monad as S++import Database.Algebra.Table.Lang++(∪) :: Ord a => S.Set a -> S.Set a -> S.Set a+(∪) = S.union++(∩) :: Ord a => S.Set a -> S.Set a -> S.Set a+(∩) = S.intersection++(∖) :: Ord a => S.Set a -> S.Set a -> S.Set a+(∖) = S.difference++(∈) :: Ord a => a -> S.Set a -> Bool+(∈) = S.member++(⊆) :: Ord a => S.Set a -> S.Set a -> Bool+(⊆) = S.isSubsetOf++-- | Singleton set abbreviation+ss :: Ord a => a -> S.Set a+ss = S.singleton++-- | List set abbreviation+ls :: Ord a => [a] -> S.Set a+ls = S.fromList++unionss :: Ord a => S.Set (S.Set a) -> S.Set a+unionss = S.foldr (∪) S.empty++exprCols :: Expr -> S.Set Attr+exprCols (BinAppE _ e1 e2) = exprCols e1 ∪ exprCols e2+exprCols (IfE c t e) = exprCols c ∪ exprCols t ∪ exprCols e+exprCols (UnAppE _ e) = exprCols e+exprCols (ColE c) = S.singleton c+exprCols (ConstE _) = S.empty++aggrInput :: AggrType -> S.Set Attr+aggrInput (Avg e) = exprCols e+aggrInput (Max e) = exprCols e+aggrInput (Min e) = exprCols e+aggrInput (Sum e) = exprCols e+aggrInput (All e) = exprCols e+aggrInput (Any e) = exprCols e+aggrInput (Count e) = exprCols e+aggrInput CountStar = S.empty++winFunInput :: WinFun -> S.Set Attr+winFunInput (WinAvg e) = exprCols e+winFunInput (WinMax e) = exprCols e+winFunInput (WinMin e) = exprCols e+winFunInput (WinSum e) = exprCols e+winFunInput (WinAll e) = exprCols e+winFunInput (WinAny e) = exprCols e+winFunInput (WinFirstValue e) = exprCols e+winFunInput (WinLastValue e) = exprCols e+winFunInput WinCount = S.empty++mapCol :: Proj -> Maybe (Attr, Attr)+mapCol (a, ColE b) = Just (a, b)+mapCol (a, UnAppE (Cast _) (ColE b)) = Just (a, b)+mapCol _ = Nothing++-- | Build a map from a projection list that maps each attribute to+-- its new names after projection. Only attributes that are simply+-- renamed are considered.+mapColMulti :: [Proj] -> M.Map Attr (S.Set Attr)+mapColMulti projs = L.foldl' insertMap M.empty projs+ where+ insertMap m (a, ColE b) = M.insertWith S.union b (ss a) m+ insertMap m (a, UnAppE (Cast _) (ColE b)) = M.insertWith S.union b (ss a) m+ insertMap m _ = m++mColE :: Expr -> Maybe Attr+mColE (ColE c) = Just c+mColE _ = Nothing
+ src/Database/DSH/Backend/Sql/Opt/Properties/BottomUp.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Opt.Properties.BottomUp where++import qualified Data.Set.Monad as S++import Database.Algebra.Dag+import Database.Algebra.Dag.Common+import Database.Algebra.Table.Lang++import Database.DSH.Common.Impossible++import Database.DSH.Common.Opt++import Database.DSH.Backend.Sql.Opt.Properties.Card1+import Database.DSH.Backend.Sql.Opt.Properties.Cols+import Database.DSH.Backend.Sql.Opt.Properties.Const+import Database.DSH.Backend.Sql.Opt.Properties.Empty+import Database.DSH.Backend.Sql.Opt.Properties.FD+import Database.DSH.Backend.Sql.Opt.Properties.Keys+import Database.DSH.Backend.Sql.Opt.Properties.Nullable+import Database.DSH.Backend.Sql.Opt.Properties.Order+import Database.DSH.Backend.Sql.Opt.Properties.Types++-- FIXME this is (almost) identical to its X100 counterpart -> merge+inferWorker :: NodeMap TableAlgebra -> TableAlgebra -> AlgNode -> NodeMap BottomUpProps -> BottomUpProps+inferWorker _ op n pm =+ let res =+ case op of+ TerOp _ _ _ _ -> $impossible+ BinOp vl c1 c2 ->+ let c1Props = lookupUnsafe pm "no children properties" c1+ c2Props = lookupUnsafe pm "no children properties" c2+ in inferBinOp vl c1Props c2Props+ UnOp vl c ->+ let cProps = lookupUnsafe pm "no children properties" c+ in inferUnOp vl cProps+ NullaryOp vl -> inferNullOp vl+ in case res of+ Left msg -> error $ "Inference failed at node " ++ (show n) ++ ": " ++ msg+ Right props -> props++inferNullOp :: NullOp -> Either String BottomUpProps+inferNullOp op = do+ let opCols = inferColsNullOp op+ opKeys = inferKeysNullOp op+ opEmpty = inferEmptyNullOp op+ opCard1 = inferCard1NullOp op+ -- We only care for rownum-generated columns. Therefore, For+ -- nullary operators order is empty.+ opOrder = []+ opConst = inferConstNullOp op+ opNullable = inferNullableNullOp op+ opFDs = inferFDNullOp opCols opKeys op+ return $ BUProps { pCols = opCols+ , pKeys = opKeys+ , pEmpty = opEmpty+ , pCard1 = opCard1+ , pOrder = opOrder+ , pConst = opConst+ , pNullable = opNullable+ , pFunDeps = opFDs+ }++inferUnOp :: UnOp -> BottomUpProps -> Either String BottomUpProps+inferUnOp op cProps = do+ let opCols = inferColsUnOp (pCols cProps) op+ opKeys = inferKeysUnOp (pKeys cProps) (pCard1 cProps) (S.map fst $ pCols cProps) op+ opEmpty = inferEmptyUnOp (pEmpty cProps) op+ opCard1 = inferCard1UnOp (pCard1 cProps) (pEmpty cProps) op+ opOrder = inferOrderUnOp (pOrder cProps) op+ opConst = inferConstUnOp (pConst cProps) op+ opNullable = inferNullableUnOp (pNullable cProps) op+ opFDs = inferFDUnOp cProps op+ return $ BUProps { pCols = opCols+ , pKeys = opKeys+ , pEmpty = opEmpty+ , pCard1 = opCard1+ , pOrder = opOrder+ , pConst = opConst+ , pNullable = opNullable+ , pFunDeps = opFDs+ }++inferBinOp :: BinOp -> BottomUpProps -> BottomUpProps -> Either String BottomUpProps+inferBinOp op c1Props c2Props = do+ let opCols = inferColsBinOp (pCols c1Props) (pCols c2Props) op+ opKeys = inferKeysBinOp (pKeys c1Props) (pKeys c2Props) (pCard1 c1Props) (pCard1 c2Props) op+ opEmpty = inferEmptyBinOp (pEmpty c1Props) (pEmpty c2Props) op+ opCard1 = inferCard1BinOp (pCard1 c1Props) (pCard1 c2Props) op+ opOrder = inferOrderBinOp (pOrder c1Props) (pOrder c2Props) op+ opConst = inferConstBinOp (pConst c1Props) (pConst c2Props) op+ opNullable = inferNullableBinOp c1Props c2Props op+ opFDs = inferFDBinOp c1Props c2Props opKeys opCols op+ return $ BUProps { pCols = opCols+ , pKeys = opKeys+ , pEmpty = opEmpty+ , pCard1 = opCard1+ , pOrder = opOrder+ , pConst = opConst+ , pNullable = opNullable+ , pFunDeps = opFDs+ }++inferBottomUpProperties :: AlgebraDag TableAlgebra -> NodeMap BottomUpProps+inferBottomUpProperties dag = inferBottomUpGeneral inferWorker dag
+ src/Database/DSH/Backend/Sql/Opt/Properties/Card1.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Opt.Properties.Card1 where++import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Opt.Properties.Types++inferCard1NullOp :: NullOp -> Card1+inferCard1NullOp op =+ case op of+ LitTable (vals, _) -> length vals == 1+ TableRef (_, _, _) -> False++inferCard1UnOp :: Card1 -> Empty -> UnOp -> Card1+inferCard1UnOp childCard1 childEmpty op =+ case op of+ WinFun _ -> childCard1+ RowNum (_, _, _) -> childCard1+ RowRank (_, _) -> childCard1+ Rank (_, _) -> childCard1+ Project _ -> childCard1+ Select _ -> False+ Distinct _ -> childCard1+ Aggr (_, _ : _) -> childCard1+ Aggr (_, []) -> not childEmpty+ Serialize _ -> childCard1++inferCard1BinOp :: Card1 -> Card1 -> BinOp -> Card1+inferCard1BinOp leftCard1 rightCard1 op =+ case op of+ Cross _ -> leftCard1 && rightCard1+ EqJoin _ -> False+ ThetaJoin _ -> False+ LeftOuterJoin _ -> False+ SemiJoin _ -> False+ AntiJoin _ -> False+ DisjUnion _ -> False+ Difference _ -> False+
+ src/Database/DSH/Backend/Sql/Opt/Properties/Cols.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Infer the output schema of TableAlgebra operators.+module Database.DSH.Backend.Sql.Opt.Properties.Cols where++import qualified Data.Set.Monad as S+++import Database.Algebra.Table.Lang++import Database.DSH.Common.Impossible+import Database.DSH.Backend.Sql.Opt.Properties.Auxiliary+import Database.DSH.Backend.Sql.Opt.Properties.Types++----------------------------------------------------------------------------+-- Type inference for tablealgebra expressions++isNumeric :: BinFun -> Bool+isNumeric f = f `elem` [Plus, Minus, Times, Div]++isComp :: BinFun -> Bool+isComp f = f `elem` [Gt, Lt, LtE, GtE, Eq, Contains, SimilarTo, Like]++isBool :: BinFun -> Bool+isBool f = f `elem` [And, Or]++binAppTy :: BinFun -> ATy -> ATy -> ATy+binAppTy f t1 _t2 =+ case f of+ Gt -> ABool+ Lt -> ABool+ LtE -> ABool+ GtE -> ABool+ Eq -> ABool+ NEq -> ABool+ Contains -> ABool+ SimilarTo -> ABool+ Like -> ABool+ And -> ABool+ Or -> ABool+ Plus -> t1+ Minus -> t1+ Times -> t1+ Div -> t1+ Modulo -> AInt+ Concat -> AStr+ Coalesce -> t1++unAppTy :: UnFun -> ATy+unAppTy Not = ABool+unAppTy (Cast t) = t+unAppTy Sin = ADouble+unAppTy Cos = ADouble+unAppTy Tan = ADouble+unAppTy ASin = ADouble+unAppTy ACos = ADouble+unAppTy ATan = ADouble+unAppTy Log = ADouble+unAppTy Sqrt = ADouble+unAppTy Exp = ADouble+unAppTy SubString{} = AStr+unAppTy DateDay = AInt+unAppTy DateMonth = AInt+unAppTy DateYear = AInt+unAppTy IsNull = ABool++valType :: AVal -> ATy+valType (VInt _) = AInt+valType (VStr _) = AStr+valType (VBool _) = ABool+valType (VDouble _) = ADouble+valType (VDec _) = ADec+valType (VDate _) = ADate++exprTy :: S.Set TypedAttr -> Expr -> ATy+exprTy childCols expr =+ case expr of+ ColE c -> typeOf c childCols+ ConstE v -> valType v+ BinAppE f e1 e2 -> binAppTy f (exprTy childCols e1) (exprTy childCols e2)+ UnAppE f _ -> unAppTy f+ IfE _ t _ -> exprTy childCols t++----------------------------------------------------------------------------+-- Type inference for aggregate functions++numAggr :: ATy -> ATy+numAggr AInt = AInt+numAggr ADec = ADec+numAggr ADouble = ADouble+numAggr _ = $impossible++aggrTy :: S.Set TypedAttr -> (AggrType, Attr) -> TypedAttr+aggrTy childCols (aggr, resCol) = (resCol, resType)+ where+ resType = case aggr of+ All _ -> ABool+ Any _ -> ABool+ CountStar -> AInt+ Count _ -> AInt+ Avg e -> numAggr $ exprTy childCols e+ Max e -> numAggr $ exprTy childCols e+ Min e -> numAggr $ exprTy childCols e+ Sum e -> numAggr $ exprTy childCols e++winFunTy :: S.Set TypedAttr -> (WinFun, Attr) -> TypedAttr+winFunTy childCols (aggr, resCol) = (resCol, resType)+ where+ resType = case aggr of+ WinAll _ -> ABool+ WinAny _ -> ABool+ WinCount -> AInt+ WinAvg e -> numAggr $ exprTy childCols e+ WinMax e -> numAggr $ exprTy childCols e+ WinMin e -> numAggr $ exprTy childCols e+ WinSum e -> numAggr $ exprTy childCols e+ WinFirstValue e -> exprTy childCols e+ WinLastValue e -> exprTy childCols e++----------------------------------------------------------------------------+-- Schema inference for tablealgebra operators++inferColsNullOp :: NullOp -> S.Set TypedAttr+inferColsNullOp op =+ case op of+ LitTable (_, schema) -> S.fromList schema+ TableRef (_, attrs, _) -> S.fromList attrs++inferColsUnOp :: S.Set TypedAttr -> UnOp -> S.Set TypedAttr+inferColsUnOp childCols op =+ case op of+ WinFun ((resCol, fun), _, _, _) -> S.insert (winFunTy childCols (fun, resCol)) childCols+ RowNum (resCol, _, _) -> S.insert (resCol, AInt) childCols+ RowRank (resCol, _) -> S.insert (resCol, AInt) childCols+ Rank (resCol, _) -> S.insert (resCol, AInt) childCols+ Project projs -> S.fromList $ map (\(c, e) -> (c, exprTy childCols e)) projs+ Select _ -> childCols+ Distinct _ -> childCols+ Aggr (afuns, pexprs) -> (S.fromList $ map (aggrTy childCols) afuns)+ ∪+ [ (c, exprTy childCols e) | (c, e) <- S.fromList pexprs ]+ Serialize (ref, key, ord, items) ->+ let cols = (S.fromList $ map (\(PayloadCol c _) -> c) items)+ ∪ (S.fromList $ map (\(RefCol c _) -> c) ref)+ ∪ (S.fromList $ map (\(OrdCol (c, _) _) -> c) ord)+ ∪ (S.fromList $ map (\(KeyCol c _) -> c) key)+ in S.map (\c -> (c, typeOf c childCols)) cols++inferColsBinOp :: S.Set TypedAttr -> S.Set TypedAttr -> BinOp -> S.Set TypedAttr+inferColsBinOp leftCols rightCols op =+ case op of+ Cross _ -> S.union leftCols rightCols+ EqJoin _ -> S.union leftCols rightCols+ ThetaJoin _ -> S.union leftCols rightCols+ LeftOuterJoin _ -> S.union leftCols rightCols+ SemiJoin _ -> S.union leftCols rightCols+ AntiJoin _ -> S.union leftCols rightCols+ DisjUnion _ -> leftCols+ Difference _ -> leftCols
+ src/Database/DSH/Backend/Sql/Opt/Properties/Const.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Opt.Properties.Const+ ( inferConstNullOp+ , inferConstUnOp+ , inferConstBinOp+ , constExpr+ ) where++import Data.Maybe+import Data.List++import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Opt.Properties.Types++constExpr :: [ConstCol] -> Expr -> Maybe AVal+constExpr _ (BinAppE _ _ _) = Nothing+constExpr _ (UnAppE _ _) = Nothing+constExpr constCols (ColE c) = lookup c constCols+constExpr _ (ConstE v) = Just v+constExpr _ (IfE _ _ _) = Nothing++constProj :: [ConstCol] -> (Attr, Expr) -> Maybe ConstCol+constProj constCols (c, e) = constExpr constCols e >>= \v -> return (c, v)++inferConstNullOp :: NullOp -> [ConstCol]+inferConstNullOp op =+ case op of+ LitTable (tuples, schema) -> concat $ zipWith constCol (transpose tuples) (map fst schema)+ where+ constCol (v:vs) c | all (== v) vs = [(c, v)]+ constCol _ _ = []+ TableRef _ -> []++inferConstSelect :: Expr -> [ConstCol]+inferConstSelect (BinAppE Eq (ColE c) (ConstE v)) = [(c, v)]+inferConstSelect (BinAppE Eq (ConstE v) (ColE c)) = [(c, v)]+inferConstSelect (BinAppE And e1 e2) = inferConstSelect e1 ++ inferConstSelect e2+inferConstSelect _ = []++inferConstUnOp :: [ConstCol] -> UnOp -> [ConstCol]+inferConstUnOp childConst op =+ case op of+ WinFun _ -> childConst+ RowNum (_, _, _) -> childConst+ RowRank (_, _) -> childConst+ Rank (_, _) -> childConst+ Select p -> inferConstSelect p ++ childConst+ Distinct _ -> childConst+ Aggr _ -> []+ Project projs -> mapMaybe (constProj childConst) projs+ Serialize _ -> childConst++inferConstBinOp :: [ConstCol] -> [ConstCol] -> BinOp -> [ConstCol]+inferConstBinOp leftChildConst rightChildConst op =+ case op of+ Cross _ -> leftChildConst ++ rightChildConst+ EqJoin _ -> leftChildConst ++ rightChildConst+ ThetaJoin _ -> leftChildConst ++ rightChildConst+ -- For a left outer join, only consider constants from the+ -- left input. For the right input, columns might end up+ -- containing NULLs which we do not want to deal with here.+ LeftOuterJoin _ -> leftChildConst+ SemiJoin _ -> leftChildConst+ AntiJoin _ -> leftChildConst+ DisjUnion _ -> [ (c1, v1)+ | (c1, v1) <- leftChildConst+ , (c2, v2) <- rightChildConst+ , c1 == c2+ , v1 == v2+ ]+ Difference _ -> leftChildConst+
+ src/Database/DSH/Backend/Sql/Opt/Properties/Empty.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Opt.Properties.Empty where++import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Opt.Properties.Types++inferEmptyNullOp :: NullOp -> Empty+inferEmptyNullOp op =+ case op of+ LitTable (vs, _) -> null vs+ TableRef (_, _, _) -> False++inferEmptyUnOp :: Empty -> UnOp -> Empty+inferEmptyUnOp childEmpty op =+ case op of+ WinFun _ -> childEmpty+ RowNum (_, _, _) -> childEmpty+ RowRank (_, _) -> childEmpty+ Rank (_, _) -> childEmpty+ Project _ -> childEmpty+ Select _ -> childEmpty+ Distinct _ -> childEmpty+ Aggr (_, _) -> childEmpty+ Serialize _ -> childEmpty++inferEmptyBinOp :: Empty -> Empty -> BinOp -> Empty+inferEmptyBinOp leftEmpty rightEmpty op =+ case op of+ Cross _ -> leftEmpty || rightEmpty+ EqJoin _ -> leftEmpty || rightEmpty+ ThetaJoin _ -> leftEmpty || rightEmpty+ LeftOuterJoin _ -> leftEmpty || rightEmpty+ SemiJoin _ -> leftEmpty+ AntiJoin _ -> False+ DisjUnion _ -> False+ Difference _ -> False
+ src/Database/DSH/Backend/Sql/Opt/Properties/FD.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Infer functional dependencies from table algebra operators.+module Database.DSH.Backend.Sql.Opt.Properties.FD+ ( inferFDNullOp+ , inferFDUnOp+ , inferFDBinOp+ ) where++import qualified Data.Map as M+import Data.Maybe+import qualified Data.Set.Monad as S+import Data.Tuple++import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Opt.Properties.Auxiliary+import Database.DSH.Backend.Sql.Opt.Properties.Types+import Database.DSH.Common.Impossible++inferFDNullOp :: S.Set TypedAttr -> S.Set PKey -> NullOp -> FDSet+inferFDNullOp tcs ks op =+ case op of+ LitTable _ -> FDSet $ foldr (\k m -> M.insert k (cs S.\\ k) m) M.empty ks+ TableRef _ -> FDSet $ foldr (\k m -> M.insert k (cs S.\\ k) m) M.empty ks++ where+ cs = fmap fst tcs++-- | Update an attribute set with new names. All attributes must find+-- a new name.+updateSetAll :: [(Attr, Attr)] -> S.Set Attr -> Maybe (S.Set Attr)+updateSetAll colMap cs =+ S.foldr' (\c mcs -> S.insert <$> lookup c colMap <*> mcs)+ (Just S.empty)+ cs++-- | Update an attribute set with new names. Attributes for which no+-- new name exists are removed.+updateSet :: [(Attr, Attr)] -> S.Set Attr -> S.Set Attr+updateSet colMap cs = unionss $ fmap (\c -> maybe S.empty ss $ lookup c colMap) cs++updateFD :: [(Attr, Attr)] -> S.Set Attr -> S.Set Attr -> FDSet -> FDSet+updateFD colMap dets deps (FDSet m) =+ case (updateSetAll colMap dets, updateSet colMap deps) of+ (Just dets', deps') | deps' /= S.empty -> FDSet $ M.insert dets' deps' m+ _ -> FDSet m++-- | Update a set of functional dependencies with new names from a+-- projection. A functional dependency is kept if all attributes from+-- the determinant set can be mapped and if at least one attribute+-- from the dependent set can be mapped.+updateFDSet :: [(Attr, Attr)] -> FDSet -> FDSet+updateFDSet colMap (FDSet m) = M.foldrWithKey (updateFD colMap) emptyFDSet m++-- -- | Add a functional dependency for a single attribute to a set of FDs.+-- addFunDep :: S.Set Attr -> Attr -> FDSet -> FDSet+-- addFunDep cs c (FDSet m) = FDSet $ M.insertWith S.union cs (ss c) m++-- | Add a dependency for a set of attributes to a set of FDs.+addFunDeps :: S.Set Attr -> S.Set Attr -> FDSet -> FDSet+addFunDeps cs cs' (FDSet m) = FDSet $ M.insertWith S.union cs cs' m++cols :: BottomUpProps -> S.Set Attr+cols p = fmap fst $ pCols p++inferFDUnOp :: BottomUpProps -> UnOp -> FDSet+inferFDUnOp p op =+ case op of+ Distinct _ -> pFunDeps p+ Select _ -> pFunDeps p+ RowNum (r, _, []) -> addFunDeps (ss r) (cols p) (pFunDeps p)+ -- FIXME the combination of sorting and grouping cols propably+ -- determines r.+ RowNum (_, _, _) -> pFunDeps p+ -- FIXME dependency r -> sortcols+ RowRank _ -> pFunDeps p+ Aggr (_, []) -> emptyFDSet+ -- Dependencies among grouping columns stay intact and are+ -- updated in the same way as for projections.+ Aggr (as, gs) ->+ let colMap = S.toList $ S.map swap $ S.fromList $ mapMaybe mapCol gs+ in addFunDeps (ls $ map fst gs)+ (S.fromList $ map snd as)+ (updateFDSet colMap (pFunDeps p))+ Project ps ->+ let colMap = S.toList $ S.map swap $ S.fromList $ mapMaybe mapCol ps+ in updateFDSet colMap (pFunDeps p)+ Serialize _ -> pFunDeps p+ WinFun _ -> $unimplemented+ Rank _ -> $unimplemented++inferFDBinOp :: BottomUpProps -- ^ Properties of the left child+ -> BottomUpProps -- ^ Properties of the right child+ -> S.Set PKey -- ^ The keys of the operator itself+ -> S.Set TypedAttr -- ^ The cols of the operator itself+ -> BinOp -- ^ The operator+ -> FDSet+inferFDBinOp p1 p2 ks cs op =+ case op of+ -- Determine functional dependency of a cartesian+ -- product. Note: As we know that attribute sets of left and+ -- right inputs are disjunct, we don't have to care for+ -- collisions in the functional dependencies during unioning.+ Cross _ -> FDSet $+ -- Dependencies from either side are still valid after the product+ (fdsRep $ pFunDeps p1)+ `M.union`+ (fdsRep $ pFunDeps p2)+ `M.union`+ -- The new combined keys determine all result columns of the product.+ (foldr (\k m -> M.insert k ((fmap fst cs) S.\\ k) m) M.empty ks)+ ThetaJoin _ -> FDSet $+ (fdsRep $ pFunDeps p1)+ `M.union`+ (fdsRep $ pFunDeps p2)+ `M.union`+ (foldr (\k m -> M.insert k ((fmap fst cs) S.\\ k) m) M.empty ks)+ SemiJoin _ -> pFunDeps p1+ AntiJoin _ -> pFunDeps p1+ LeftOuterJoin _ -> pFunDeps p1+ DisjUnion _ -> emptyFDSet+ Difference _ -> pFunDeps p1+ EqJoin _ -> $unimplemented
+ src/Database/DSH/Backend/Sql/Opt/Properties/ICols.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Infer the input columns required in TableAlgebra plans.+module Database.DSH.Backend.Sql.Opt.Properties.ICols where++import qualified Data.Set.Monad as S++import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Opt.Properties.Auxiliary++inferIColsBinOp :: S.Set Attr -- ^ columns that are required from us+ -> S.Set Attr -- ^ Columns required from the left child+ -> S.Set Attr -- ^ Output of the left child+ -> S.Set Attr -- ^ Columns required from the right child+ -> S.Set Attr -- ^ Output of the left child+ -> BinOp -- ^ The operator+ -> (S.Set Attr, S.Set Attr)+inferIColsBinOp ownICols leftICols leftCols rightICols rightCols op =+ case op of+ -- Require columns from the originating side.+ Cross _ -> ( leftICols ∪ (ownICols ∩ leftCols)+ , rightICols ∪ (ownICols ∩ rightCols) )++ -- Require columns from the originating side, in addition to the join+ -- columns.+ EqJoin (leftJoinCol, rightJoinCol) ->+ ( leftICols ∪ (ownICols ∩ leftCols) ∪ (S.singleton leftJoinCol)+ , rightICols ∪ (ownICols ∩rightCols) ∪ (S.singleton rightJoinCol) )+ ThetaJoin cs ->+ let leftExprCols = S.unions $ map (\(l, _, _) -> exprCols l) cs+ rightExprCols = S.unions $ map (\(_, r, _) -> exprCols r) cs++ leftICols' = leftICols ∪ (ownICols ∩ leftCols) ∪ leftExprCols+ rightICols' = rightICols ∪ (ownICols ∩ rightCols) ∪ rightExprCols+ in (leftICols', rightICols')++ -- FIXME recheck+ LeftOuterJoin cs ->+ let leftExprCols = S.unions $ map (\(l, _, _) -> exprCols l) cs+ rightExprCols = S.unions $ map (\(_, r, _) -> exprCols r) cs++ leftICols' = leftICols ∪ (ownICols ∩ leftCols) ∪ leftExprCols+ rightICols' = rightICols ∪ (ownICols ∩ rightCols) ∪ rightExprCols+ in (leftICols', rightICols')++ -- From the left, we require all columns required by us, in addition to+ -- the left join columns.+ SemiJoin cs ->+ let leftExprCols = S.unions $ map (\(l, _, _) -> exprCols l) cs+ rightExprCols = S.unions $ map (\(_, r, _) -> exprCols r) cs++ leftICols' = leftICols ∪ ownICols ∪ leftExprCols+ rightICols' = rightICols ∪ rightExprCols+ in (leftICols', rightICols')+ AntiJoin cs ->+ let leftExprCols = S.unions $ map (\(l, _, _) -> exprCols l) cs+ rightExprCols = S.unions $ map (\(_, r, _) -> exprCols r) cs++ leftICols' = leftICols ∪ ownICols ∪ leftExprCols+ rightICols' = rightICols ∪ rightExprCols+ in (leftICols', rightICols')++ -- The schemata of both union inputs must be kept in sync. No+ -- ICols-based (i.e. colummn-pruning) rewrites can be+ -- performed unless there is a guarantee that they happen in+ -- both branches.+ DisjUnion _ -> (leftCols, rightCols)++ Difference _ -> (leftICols ∪ leftCols, rightICols ∪ leftCols)++inferIColsUnOp :: S.Set Attr -> S.Set Attr -> UnOp -> S.Set Attr+inferIColsUnOp ownICols childICols op =+ case op of+ WinFun ((resCol, fun), partExprs, sortInf, _) ->+ (S.delete resCol ownICols)+ ∪ (winFunInput fun)+ ∪ (S.unions $ map (exprCols . fst) sortInf)+ ∪ (S.unions $ map exprCols partExprs)+ ∪ childICols+ -- Require the sorting columns, if the rownum output is required.+ RowNum (resCol, sortInf, groupExprs) ->+ (S.delete resCol ownICols)+ ∪ (S.unions $ map (exprCols . fst) sortInf)+ ∪ (S.unions $ map exprCols groupExprs)+ ∪ childICols++ RowRank (resCol, sortInf) ->+ (S.delete resCol ownICols)+ ∪ (S.unions $ map (exprCols . fst) sortInf)+ ∪ childICols+ Rank (resCol, sortInf) ->+ (S.delete resCol ownICols)+ ∪ (S.unions $ map (exprCols . fst) sortInf)+ ∪ childICols++ -- For projections we require input columns of expressions, but only for+ -- those output columns which are actually required from downstream.+ Project projs -> S.foldr (∪) childICols $ S.fromList $ map (exprCols . snd) projs++ -- Require all columns for the select columns, in addition to columns+ -- required downstream+ Select e -> childICols ∪ ownICols ∪ exprCols e+ Distinct _ -> childICols ∪ ownICols++ Aggr (acols, pexprs) -> (S.foldr (∪) childICols $ S.fromList $ map (aggrInput . fst) acols)+ ∪+ (S.foldr (∪) S.empty $ S.fromList $ map (exprCols . snd) pexprs)++ Serialize cs ->+ let (ref, key, ord, items) = cs+ in childICols ∪+ (S.unions (map (\(RefCol _ e) -> exprCols e) ref+ ++ map (\(KeyCol _ e) -> exprCols e) key+ ++ map (\(OrdCol _ e) -> exprCols e) ord+ ++ map (\(PayloadCol _ e) -> exprCols e) items))
+ src/Database/DSH/Backend/Sql/Opt/Properties/Keys.hs view
@@ -0,0 +1,182 @@+-- FIXME once 7.8 is out, use overloaded list notation for sets+-- instead of S.fromList!+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Opt.Properties.Keys where++import Data.List+import qualified Data.Map as M++import qualified Data.Set.Monad as S++import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Opt.Properties.Auxiliary+import Database.DSH.Backend.Sql.Opt.Properties.Types+import Database.DSH.Common.Impossible++subsetsOfSize :: Ord a => Int -> S.Set a -> S.Set (S.Set a)+subsetsOfSize n s+ | n == 0 = S.singleton S.empty+ | S.size s < n || n < 0 = error "onlyLists: out of range n"+ | S.size s == n = S.singleton s+ | otherwise = S.fromDistinctAscList . map S.fromDistinctAscList $+ go n (S.size s) (S.toList s)+ where+ go 1 _ xs = map return xs+ go k l (x:xs)+ | k == l = [x:xs]+ | otherwise = map (x:) (go (k-1) (l-1) xs) ++ go k (l-1) xs+ go _ _ [] = $impossible++-- | Enumerate all subsets of size n++-- | Compute keys for rank and rowrank operators+rowRankKeys :: Attr -> S.Set Attr -> Card1 -> S.Set PKey -> S.Set PKey+rowRankKeys resCol sortCols childCard1 childKeys =+ -- All old keys stay intact+ childKeys+ ∪+ -- Trivial case: singleton input+ [ ss resCol | childCard1 ]+ ∪+ -- If sorting columns form a part of a key, the output column+ -- combined with the key columns that are not sorting columns also+ -- is a key.+ [ (ss resCol) ∪ (k ∖ sortCols)+ | k <- childKeys+ , k ∩ sortCols /= S.empty+ ]++-- | Update a key under a projection. If one attribute is mapped to+-- multiple attributes, the key is replicated.+updateKey :: M.Map Attr (S.Set Attr) -> PKey -> S.Set PKey+updateKey m k = go S.empty k+ where+ go :: S.Set PKey -> PKey -> S.Set PKey+ go keyPrefixes keySuffix =+ let (b, keySuffix') = S.deleteFindMin keySuffix+ in case M.lookup b m of+ Nothing -> S.empty+ Just as -> [ S.insert a kp | kp <- keyPrefixes, a <- as ]+++inferKeysNullOp :: NullOp -> S.Set PKey+inferKeysNullOp op =+ case op of+ -- FIXME check all combinations of columns for uniqueness+ LitTable (vals, schema) -> S.fromList+ $ map (ss . snd)+ $ filter (isUnique . fst)+ $ zip (transpose vals) (map fst schema)+ where+ isUnique :: [AVal] -> Bool+ isUnique vs = (length $ nub vs) == (length vs)++ TableRef (_, _, keys) -> S.fromList $ map (\(Key k) -> ls k) keys++inferKeysUnOp :: S.Set PKey -> Card1 -> S.Set Attr -> UnOp -> S.Set PKey+inferKeysUnOp childKeys childCard1 childCols op =+ case op of+ WinFun _ -> childKeys+ RowNum (resCol, _, []) -> S.insert (ss resCol) childKeys+ -- FIXME can we infer a key here if partitioning includes+ -- general expressions?+ RowNum (resCol, _, pexprs) -> {- (S.singleton $ ls [resCol, pattr])+ ∪ -}+ [ ss resCol | childCard1 ]+ ∪+ childKeys+ -- FIXME infer complete rank keys+ RowRank (resCol, sortInfo) -> childKeys -- rowRankKeys resCol (ls $ map fst sortInfo) childCard1 childKeys+ Rank (resCol, sortInfo) -> childKeys -- rowRankKeys resCol (ls $ map fst sortInfo) childCard1 childKeys++ -- This is just the standard Pathfinder way: we take all keys+ -- whose columns survive the projection and update to the new+ -- attr names. We could consider all expressions, but need to+ -- be careful here as not all operators might be injective.+ Project projs ->+ let m = mapColMulti projs+ in S.foldr (\k ks -> (updateKey m k) ∪ ks) S.empty childKeys+ Select _ -> childKeys+ Distinct _ -> S.insert childCols childKeys+ Aggr (_, []) -> S.empty+ Aggr (_, pexprs@(_ : _)) -> S.singleton $ S.fromList $ map fst pexprs+ Serialize _ -> S.empty++inferKeysBinOp :: S.Set PKey -> S.Set PKey -> Card1 -> Card1 -> BinOp -> S.Set PKey+inferKeysBinOp leftKeys rightKeys leftCard1 rightCard1 op =+ case op of+ Cross _ -> [ k | k <- leftKeys, rightCard1 ]+ ∪+ [ k | k <- rightKeys, leftCard1 ]+ ∪+ [ k1 ∪ k2 | k1 <- leftKeys, k2 <- rightKeys ]+ EqJoin (a, b) -> [ k | k <- leftKeys, rightCard1 ]+ ∪+ [ k | k <- rightKeys, leftCard1 ]+ ∪+ [ k | k <- leftKeys, (ss b) ∈ rightKeys ]+ ∪+ [ k | k <- rightKeys, (ss a) ∈ leftKeys ]+ ∪+ [ ( k1 ∖ (ss a)) ∪ k2+ | (ss b) ∈ rightKeys+ , k1 <- leftKeys+ , k2 <- rightKeys+ ]+ ∪+ [ k1 ∪ (k2 ∖ (ss b))+ | (ss a) ∈ leftKeys+ , k1 <- leftKeys+ , k2 <- rightKeys+ ]+ ∪+ [ k1 ∪ k2 | k1 <- leftKeys, k2 <- rightKeys ]++ ThetaJoin preds -> [ k | k <- leftKeys, rightCard1 ]+ ∪+ [ k | k <- rightKeys, leftCard1 ]+ ∪+ [ k+ | k <- leftKeys+ , (_, be, p) <- S.fromList preds+ , p == EqJ+ , b <- singleCol be+ , (ss b) ∈ rightKeys+ ]+ ∪+ [ k+ | k <- rightKeys+ , (ae, _, p) <- S.fromList preds+ , p == EqJ+ , a <- singleCol ae+ , (ss a) ∈ leftKeys+ ]+ ∪+ [ k1 ∪ k2 | k1 <- leftKeys, k2 <- rightKeys ]++ -- For a left outer join, only consider keys from the+ -- left input. For the right input, columns might end up+ -- containing NULLs which we do not want to deal with here.+ LeftOuterJoin preds -> [ k | k <- leftKeys, rightCard1 ]+ ∪+ [ k+ | k <- leftKeys+ , (_, be, p) <- S.fromList preds+ , p == EqJ+ , b <- singleCol be+ , (ss b) ∈ rightKeys+ ]++ SemiJoin _ -> leftKeys+ AntiJoin _ -> leftKeys+ DisjUnion _ -> S.empty -- FIXME need domain property.+ Difference _ -> leftKeys++singleCol :: Expr -> S.Set Attr+singleCol (ColE c) = S.singleton c+singleCol _ = S.empty++
+ src/Database/DSH/Backend/Sql/Opt/Properties/Nullable.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MonadComprehensions #-}++module Database.DSH.Backend.Sql.Opt.Properties.Nullable+ ( inferNullableNullOp+ , inferNullableUnOp+ , inferNullableBinOp+ ) where++import qualified Data.Set.Monad as S++import Database.Algebra.Table.Lang+++import Database.DSH.Backend.Sql.Opt.Properties.Types+import Database.DSH.Backend.Sql.Opt.Properties.Auxiliary++nullableExpr :: S.Set Attr -> Expr -> Bool+nullableExpr ns e =+ case e of+ BinAppE Coalesce e1 e2 -> (nullableExpr ns e1 && nullableExpr ns e2)+ ||+ (not (nullableExpr ns e1) && nullableExpr ns e2)+ BinAppE _ e1 e2 -> nullableExpr ns e1 || nullableExpr ns e2+ UnAppE _ e1 -> nullableExpr ns e1+ ColE c -> c `S.member` ns+ IfE e1 e2 e3 -> any (nullableExpr ns) [e1, e2, e3]+ ConstE _ -> False++nullableAggr :: S.Set Attr -> AggrType -> Bool+nullableAggr ns a =+ case a of+ CountStar -> False+ Count _ -> False+ Avg e -> nullableExpr ns e+ Max e -> nullableExpr ns e+ Min e -> nullableExpr ns e+ Sum e -> nullableExpr ns e+ All e -> nullableExpr ns e+ Any e -> nullableExpr ns e++inferNullableNullOp :: NullOp -> S.Set Attr+inferNullableNullOp op =+ case op of+ LitTable _ -> S.empty+ TableRef _ -> S.empty++inferNullableUnOp :: S.Set Attr -> UnOp -> S.Set Attr+inferNullableUnOp ns op =+ case op of+ Serialize _ -> ns+ Select _ -> ns+ Distinct _ -> ns+ Project ps -> ls [ a | (a, e) <- ps, nullableExpr ns e ]+ RowNum (c, _, _) -> S.delete c ns+ RowRank (c, _) -> S.delete c ns+ Rank (c, _) -> S.delete c ns+ -- Non-grouped aggregate functions might return NULL if their+ -- input is empty (except for COUNT)+ Aggr (as, []) -> ns ∪ (ls [ c | (a, c) <- as, nullableAggr ns a ])+ -- For grouped aggregates:+ -- 1. The grouping columns might be NULL if they were nullable in the input.+ --+ -- 2. Aggregate output (except for COUNT) is nullable if the+ -- input expression is nullable+ Aggr (as, gs) -> (ls [ c | (c, e) <- gs, nullableExpr ns e ])+ ∪+ (ls [ c | (a, c) <- as, nullableAggr ns a ])+ -- FIXME under what circumstances does the window aggregate+ -- output get NULL? This is the safe variant that considers+ -- the output always nullable.+ WinFun a -> let ((c, _), _, _, _) = a in S.insert c ns++inferNullableBinOp :: BottomUpProps -> BottomUpProps -> BinOp -> S.Set Attr+inferNullableBinOp ps1 ps2 op =+ case op of+ Cross _ -> pNullable ps1 ∪ pNullable ps2+ -- FIXME for joins we could be more precise: any column that+ -- shows up in the join predicate can be considered non-null+ -- in the join result (tuples in which the predicate evaluates+ -- to NULL will not be in the result).+ EqJoin _ -> (pNullable ps1) ∪ (pNullable ps2)+ ThetaJoin _ -> pNullable ps1 ∪ pNullable ps2+ LeftOuterJoin _ -> pNullable ps1 ∪ [ c | (c, _) <- pCols ps2 ]+ SemiJoin _ -> pNullable ps1+ AntiJoin _ -> pNullable ps1+ DisjUnion _ -> pNullable ps1 ∪ pNullable ps2+ Difference _ -> pNullable ps1
+ src/Database/DSH/Backend/Sql/Opt/Properties/Order.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Opt.Properties.Order where++import Data.Maybe+import qualified Data.Set.Monad as S+import Data.Tuple++import Database.Algebra.Table.Lang++import Database.DSH.Common.Impossible++import Database.DSH.Backend.Sql.Opt.Properties.Auxiliary+import Database.DSH.Backend.Sql.Opt.Properties.Types++-- | Column 'c' has been overwritten by the current operator. Remove+-- all associated sorting information.+invalidate :: Attr -> Orders -> Orders+invalidate c order = [ o | o@(c', _) <- order, c /= c' ]++-- | Overwrite (if present) order information for column 'o' with new+-- information.+-- FIXME Handle case of arbitrary expressions defining order.+overwrite :: (Attr, [Expr]) -> Orders -> Orders+overwrite (resCol, ordExprs) os =+ if all isJust mOrdCols+ -- Check if the result column overwrites some older order column+ then if any ((== resCol) . fst) os+ then [ (resCol, ordCols) | (oc, _) <- os, oc == resCol ]+ else (resCol, ordCols) : os+ -- The order is defined by non-column expressions. We don't handle+ -- that case currently.+ else os++ where+ mOrdCols = map mColE ordExprs+ ordCols = catMaybes mOrdCols++-- | Produce all new sorting columns from the list of new names per+-- old sorting column:+-- [[a, b, c], [d, e], [f]] => [[a, d, f], [a, e, f], [b, d, f], ...]+-- [[a, b, c], [], [f]] => []+ordCombinations :: [[Attr]] -> [[Attr]]+ordCombinations [] = $impossible+ordCombinations (s : []) = map (: []) s+ordCombinations (s : scs) = dist s (ordCombinations scs)++ where+ dist :: [Attr] -> [[Attr]] -> [[Attr]]+ dist as bs = [ a : b | a <- as, b <- bs ]++-- | Find all new names for column 'c'.+newCols :: [(Attr, Attr)] -> Attr -> [Attr]+newCols colMap c = [ cn | (co, cn) <- colMap, co == c ]++-- | Refresh order information with new names for the order column and+-- new names for the sorting columns.+update :: [(Attr, Attr)] -> (Attr, [Attr]) -> Orders+update colMap (ordCol, sortCols) =+ let ordCols' = newCols colMap ordCol+ sortCols' = map (newCols colMap) sortCols++ in if any null sortCols'+ then []+ else [ (oc, scs) | oc <- ordCols', scs <- ordCombinations sortCols' ]++inferOrderUnOp :: Orders -> UnOp -> Orders+inferOrderUnOp childOrder op =+ case op of+ WinFun _ -> childOrder+ RowNum (oc, scs, [])+ | not (null scs)+ -- Only consider ascending sorting+ && all ((== Asc) . snd) scs+ -- Avoid circular references+ && (ColE oc) `notElem` (map fst scs)+ -> overwrite (oc, map fst scs) childOrder+ | otherwise+ -> invalidate oc childOrder+ RowNum (resCol, _, _) -> invalidate resCol childOrder+ RowRank (resCol, _) -> invalidate resCol childOrder+ Rank (resCol, _) -> invalidate resCol childOrder+ Select _ -> childOrder+ Distinct _ -> childOrder+ Aggr _ -> []+ Project projs ->+ let colMap = S.toList $ S.map swap $ S.fromList $ mapMaybe mapCol projs+ in concatMap (update colMap) childOrder+ Serialize _ -> []++inferOrderBinOp :: Orders -> Orders -> BinOp -> Orders+inferOrderBinOp leftChildOrder rightChildOrder op =+ case op of+ Cross _ -> leftChildOrder ++ rightChildOrder+ EqJoin _ -> leftChildOrder ++ rightChildOrder+ ThetaJoin _ -> leftChildOrder ++ rightChildOrder+ -- For a left outer join, only consider order information from+ -- the left input. For the right input, columns might end up+ -- containing NULLs which we do not want to deal with here.+ LeftOuterJoin _ -> leftChildOrder+ SemiJoin _ -> leftChildOrder+ AntiJoin _ -> leftChildOrder+ DisjUnion _ -> []+ Difference _ -> leftChildOrder+
+ src/Database/DSH/Backend/Sql/Opt/Properties/TopDown.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Opt.Properties.TopDown where++import Control.Monad.State++import qualified Data.IntMap as M+import Data.List+import qualified Data.Set.Monad as S++import qualified Database.Algebra.Dag as D+import Database.Algebra.Dag.Common+import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Opt.Properties.ICols+import Database.DSH.Backend.Sql.Opt.Properties.Types+-- import Database.DSH.Backend.Sql.Opt.Properties.Use+import Database.DSH.Common.Opt+import Database.DSH.Common.Impossible+++seed :: TopDownProps+seed = TDProps { pICols = S.empty }++type InferenceState = NodeMap TopDownProps++lookupProps :: AlgNode -> State InferenceState TopDownProps+lookupProps n = do+ m <- get+ case M.lookup n m of+ Just props -> return props+ Nothing -> error "TopDown.lookupProps"++replaceProps :: AlgNode -> TopDownProps -> State InferenceState ()+replaceProps n p = modify (M.insert n p)++inferUnOp :: TopDownProps -> TopDownProps -> UnOp -> TopDownProps+inferUnOp ownProps cp op =+ TDProps { pICols = inferIColsUnOp (pICols ownProps) (pICols cp) op+ }++inferBinOp :: BottomUpProps+ -> BottomUpProps+ -> TopDownProps+ -> TopDownProps+ -> TopDownProps+ -> BinOp+ -> (TopDownProps, TopDownProps)+inferBinOp childBUProps1 childBUProps2 ownProps cp1 cp2 op =+ let (crc1', crc2') = inferIColsBinOp (pICols ownProps)+ (pICols cp1)+ (S.map fst $ pCols childBUProps1)+ (pICols cp2)+ (S.map fst $ pCols childBUProps2)+ op+ cp1' = TDProps { pICols = crc1' }+ cp2' = TDProps { pICols = crc2' }+ in (cp1', cp2')++inferChildProperties :: NodeMap BottomUpProps+ -> D.AlgebraDag TableAlgebra+ -> AlgNode+ -> State InferenceState ()+inferChildProperties buPropMap d n = do+ ownProps <- lookupProps n+ case D.operator n d of+ NullaryOp _ -> return ()+ UnOp op c -> do+ cp <- lookupProps c+ let cp' = inferUnOp ownProps cp op+ replaceProps c cp'+ BinOp op c1 c2 -> do+ cp1 <- lookupProps c1+ cp2 <- lookupProps c2+ let buProps1 = lookupUnsafe buPropMap "TopDown.inferChildProperties" c1+ buProps2 = lookupUnsafe buPropMap "TopDown.inferChildProperties" c2+ let (cp1', cp2') = inferBinOp buProps1 buProps2 ownProps cp1 cp2 op+ replaceProps c1 cp1'+ replaceProps c2 cp2'+ TerOp _ _ _ _ -> $impossible++-- | Infer properties during a top-down traversal.+inferAllProperties :: NodeMap BottomUpProps+ -> [AlgNode]+ -> D.AlgebraDag TableAlgebra+ -> NodeMap AllProps+inferAllProperties buPropMap topOrderedNodes d =+ case mergeProps buPropMap tdPropMap of+ Just ps -> ps+ Nothing -> $impossible+ where+ tdPropMap = execState action initialMap+ action = mapM_ (inferChildProperties buPropMap d) topOrderedNodes++ initialMap = M.map (const seed) $ D.nodeMap d++ mergeProps :: NodeMap BottomUpProps -> NodeMap TopDownProps -> Maybe (NodeMap AllProps)+ mergeProps bum tdm = do+ let keys1 = M.keys bum+ keys2 = M.keys tdm+ keys = keys1 `intersect` keys2+ guard $ length keys == length keys1 && length keys == length keys2++ let merge :: AlgNode -> Maybe (AlgNode, AllProps)+ merge n = do+ bup <- M.lookup n bum+ tdp <- M.lookup n tdm+ return (n, AllProps { td = tdp, bu = bup })++ merged <- mapM merge keys+ return $ M.fromList merged++
+ src/Database/DSH/Backend/Sql/Opt/Properties/Types.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Opt.Properties.Types where++import Data.List+import qualified Data.Map as M+import qualified Data.Set.Monad as S+import Database.Algebra.Table.Lang+import Database.DSH.Common.Impossible++----------------------------------------------------------------------------+-- Property types++data TopDownProps = TDProps+ { pICols :: S.Set Attr+ }++instance Show TopDownProps where+ show ps = show $ S.toList (pICols ps)++-- FIXME: unite with Database.Algebra.Pathfinder....Data.Algebra.Key+type PKey = S.Set Attr++-- | Signal if an operator produces exactly one or zero tuples, respectively.+type Card1 = Bool+type Empty = Bool++type Orders = [(Attr, [Attr])]++type ConstCol = (Attr, AVal)++newtype FDSet = FDSet { fdsRep :: M.Map (S.Set Attr) (S.Set Attr) }++emptyFDSet :: FDSet+emptyFDSet = FDSet $ M.empty++showSet :: Ord a => (a -> String) -> S.Set a -> String+showSet f s = "{" ++ intercalate "," (map f $ S.toList s) ++ "}"++instance Show FDSet where+ show fds = intercalate ", "+ $ map (\(cs, ds) -> showSet id cs ++ " -> " ++ showSet id ds)+ $ M.toList $ fdsRep fds++data BottomUpProps = BUProps+ { pCols :: S.Set TypedAttr+ , pKeys :: S.Set PKey+ , pCard1 :: Card1+ , pEmpty :: Empty+ , pOrder :: Orders+ , pConst :: [ConstCol]+ , pNullable :: S.Set Attr+ , pFunDeps :: FDSet+ } deriving (Show)++data AllProps = AllProps+ { bu :: BottomUpProps+ , td :: TopDownProps+ } deriving (Show)++----------------------------------------------------------------------------+-- Utility functions on properties++typeOf :: Attr -> S.Set TypedAttr -> ATy+typeOf k s =+ case S.toList $ [ b | (a, b) <- s, k == a ] of+ [b] -> b+ _ -> $impossible
+ src/Database/DSH/Backend/Sql/Opt/Rewrite/Basic.hs view
@@ -0,0 +1,1007 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Database.DSH.Backend.Sql.Opt.Rewrite.Basic where++import Debug.Trace+import Text.Printf++import Control.Monad+import Data.Either+-- import Data.Either.Combinators+import Data.List hiding+ (insert)+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Set.Monad as S++import Database.Algebra.Dag.Common+import Database.Algebra.Table.Lang hiding+ (replace)++import Database.DSH.Backend.Sql.Opt.Properties.Auxiliary+import Database.DSH.Backend.Sql.Opt.Properties.Const+import Database.DSH.Backend.Sql.Opt.Properties.Types+import Database.DSH.Backend.Sql.Opt.Rewrite.Common+import Database.DSH.Common.Impossible+import Database.DSH.Common.Opt++cleanup :: TARewrite Bool+cleanup = iteratively $ sequenceRewrites [ applyToAll noProps cleanupRules+ , applyToAll inferAll cleanupRulesTopDown+ ]++cleanupRules :: TARuleSet ()+cleanupRules = [ stackedProject+ -- , serializeProject+ , pullProjectWinFun+ , pullProjectSelect+ , pullProjectSerialize+ , pullProjectRownum+ , pullProjectAggr+ , pullProjectSemiJoinLeft+ , pullProjectSemiJoinRight+ , inlineProjectAggr+ , duplicateSortingCriteriaWin+ , duplicateSortingCriteriaRownum+ -- , duplicateSortingCriteriaSerialize+ , bypassRownumProject+ , pruneSerializeSortCols+ ]++cleanupRulesTopDown :: TARuleSet AllProps+cleanupRulesTopDown = [ unreferencedBaseTableCols+ , unreferencedRownum+ , unreferencedRank+ , unreferencedProjectCols+ , unreferencedAggrCols+ , unreferencedLiteralCols+ , unreferencedGroupingCols+ , pruneSerializeSortColsFD+ , inlineSortColsRownum+ -- , inlineSortColsSerialize+ , inlineSortColsWinFun+ , keyPrefixOrdering+ , constAggrKey+ , constRownumCol+ , constRowRankCol+ -- , constSerializeCol+ , constWinOrderCol+ , pullProjectThetaJoinLeft+ , pullProjectThetaJoinRight+ , pullProjectCrossLeft+ , pullProjectCrossRight+ ]++----------------------------------------------------------------------------------+-- Rewrite rules+++---------------------------------------------------------------------------+-- ICols rewrites++unreferencedBaseTableCols :: TARule AllProps+unreferencedBaseTableCols q =+ $(dagPatMatch 'q "TableRef args "+ [| do+ let (n, schema, keys) = $(v "args")+ reqCols <- pICols <$> td <$> properties q+ let schema' = filter (\(c, _) -> S.member c reqCols) schema++ predicate $ length schema' < length schema++ return $ do+ logRewrite "Basic.ICols.Table" q+ let keys' = filter (\(Key k) -> all (\c -> S.member c reqCols) k)+ keys+ void $ replaceWithNew q $ NullaryOp $ TableRef (n, schema', keys') |])++-- | Prune a rownumber operator if its output is not required+unreferencedRownum :: TARule AllProps+unreferencedRownum q =+ $(dagPatMatch 'q "RowNum args (q1)"+ [| do+ (res, _, _) <- return $(v "args")+ neededCols <- pICols <$> td <$> properties q+ predicate $ not (res `S.member` neededCols)++ return $ do+ logRewrite "Basic.ICols.Rownum" q+ replace q $(v "q1") |])++-- | Prune a rownumber operator if its output is not required+unreferencedRank :: TARule AllProps+unreferencedRank q =+ $(dagPatMatch 'q "[Rank | RowRank] args (q1)"+ [| do+ (res, _) <- return $(v "args")+ neededCols <- pICols <$> td <$> properties q+ predicate $ not (res `S.member` neededCols)++ return $ do+ logRewrite "Basic.ICols.Rank" q+ replace q $(v "q1") |])++-- | Prune projections from a project operator if the result columns+-- are not required.+unreferencedProjectCols :: TARule AllProps+unreferencedProjectCols q =+ $(dagPatMatch 'q "Project projs (q1)"+ [| do+ neededCols <- pICols <$> td <$> properties q+ let neededProjs = filter (flip S.member neededCols . fst) $(v "projs")++ -- Only modify the project if we could actually get rid of some columns.+ predicate $ length neededProjs < length $(v "projs")++ return $ do+ logRewrite "Basic.ICols.Project" q+ void $ replaceWithNew q $ UnOp (Project neededProjs) $(v "q1") |])++-- | Remove aggregate functions whose output is not referenced.+unreferencedAggrCols :: TARule AllProps+unreferencedAggrCols q =+ $(dagPatMatch 'q "Aggr args (q1)"+ [| do+ neededCols <- pICols <$> td <$> properties q+ (aggrs, partCols) <- return $(v "args")++ let neededAggrs = filter (flip S.member neededCols . snd) aggrs++ predicate $ length neededAggrs < length aggrs++ return $ do+ case neededAggrs of+ -- If the output of all aggregate functions is not+ -- required, we can replace it with a distinct operator+ -- on the grouping columns.+ [] -> do+ logRewrite "Basic.ICols.Aggr.PruneAggr" q+ projectNode <- insert $ UnOp (Project partCols) $(v "q1")+ void $ replaceWithNew q $ UnOp (Distinct ()) projectNode++ -- Otherwise, we just prune the unreferenced aggregate functions+ _ : _ -> do+ logRewrite "Basic.ICols.Aggr.Narrow" q+ void $ replaceWithNew q $ UnOp (Aggr (neededAggrs, partCols)) $(v "q1") |])++unreferencedLiteralCols :: TARule AllProps+unreferencedLiteralCols q =+ $(dagPatMatch 'q "LitTable tab "+ [| do+ neededCols <- pICols <$> td <$> properties q++ predicate (not $ S.null neededCols)++ let (tuples, schema) = $(v "tab")++ predicate (not $ null tuples)++ predicate $ S.size neededCols < length schema++ return $ do++ let columns = transpose tuples+ let (reqCols, reqSchema) =+ unzip+ $ filter (\(_, (colName, _)) -> colName `S.member` neededCols)+ $ zip columns schema+ let reqTuples = transpose reqCols++ void $ replaceWithNew q $ NullaryOp $ LitTable (reqTuples, reqSchema) |])++--------------------------------------------------------------------------------+-- Rewrites based on functional dependencies++-- | Helper function for 'prunePartExprs': Consider one particular not+-- required column and check wether it is functionally determined by+-- required columns and some other not required columns.+prunePartCols :: [(PartAttr, Attr)] -- ^ Columns to consider for removal+ -> FDSet+ -> [(PartAttr, Attr)] -- ^ Columns that will be preserved+ -> S.Set Attr -- ^ Required columns+ -> S.Set (S.Set Attr) -- ^ All determinant sets to consider+ -> [(PartAttr, Attr)]+prunePartCols [] _ reqProj _ _ = reqProj+prunePartCols ((c, gc) : ts) fds reqProj reqCols dets =+ case find (\ds -> coveredCol fds gc ds) dets' of+ -- 'det' determines 'gc' -> remove 'gc'+ Just det ->+ let -- Columns that are not required downstream but that+ -- are part of the determinant set that determines gc+ -- and need to be preserved.+ unreqDetCols = S.intersection det otherUnreqCols++ -- remove all unrequired columns that are in the+ -- determinant set from the set of columns to consider+ -- for removal+ (keepProjs, ts') = partition (\dc -> snd dc `S.member` unreqDetCols)+ ts++ -- if '(c, gc)' can be removed, all other (not+ -- required) projections '(c', gc)' can be removed as+ -- well.+ ts'' = filter ((/= gc) . snd) ts'++ -- Preserve all columns that are part of the+ -- determinant set just used.+ nextReqProjs = keepProjs ++ reqProj++ -- The set of columns that we keep in any case,+ -- including the columns in 'det'.+ nextReqCols = (unreqDetCols ∪ reqCols)++ -- Remove all determinant sets that contain the column+ -- we just removed.+ nextDets = S.filter (\ds -> not $ gc `S.member` ds) dets++ in prunePartCols ts'' fds nextReqProjs nextReqCols nextDets+++ -- 'gc' is not determined by any remaining determinant set.+ Nothing ->+ let nextReqProjs = (c, gc) : reqProj+ nextReqCols = S.insert gc reqCols+ -- If gc is required, we can still remove all other+ -- occurences of gc: For grouping semantics, one+ -- occurence is enough. Furthermore, we know that all+ -- grouping projections in 'ts' are /not/ required+ -- from above (icols).+ ts' = filter ((/= gc) . snd) ts+ in prunePartCols ts' fds nextReqProjs nextReqCols dets++ where+ otherUnreqCols = S.fromList $ map snd ts+ candCols = reqCols ∪ otherUnreqCols+ dets' = S.filter (\ds -> ds `S.isSubsetOf` candCols) dets++-- | Prune not required grouping columns that are functionally+-- determined by a set of other grouping columns.+--+-- The key to efficiently check wether a column is determined by a set+-- of columns is not to consider some subsets of the columns that+-- /might/ form a determinant set. Instead, we check exactly those+-- subsets that occur as determinant sets in the set of functional+-- dependencies.+--+-- This is a heuristic optimization and does not result in the exact+-- optimum: Computing the minimum set of non-required columns such+-- that the grouping is equivalent to the original grouping seems to+-- be considerably harder.+prunePartExprs :: S.Set Attr -- ^ Columns required from above+ -> [(PartAttr, Expr)] -- ^ Grouping projections+ -> FDSet -- ^ All available FDs+ -> [(PartAttr, Expr)]+prunePartExprs icols groupProjs fds =+ -- trace ("PRUNEPARTEXPRS REQPARTCOLS " ++ show reqPartCols) $+ -- trace ("PRUNEPARTEXPRS NOTREQPARTCOLS " ++ show notReqPartCols) $+ -- trace ("PRUNEPARTEXPRS DETS " ++ showSet (showSet id) dets) $+ partExprs+ ++ map mkExp (reqPartCols)+ ++ map mkExp (prunePartCols notReqPartCols' fds [] reqCols dets)+ where+ dets = S.filter (\ds -> ds `S.isSubsetOf` allCols)+ $ S.fromList $ M.keys $ fdsRep fds++ f :: (PartAttr, Expr) -> Either (PartAttr, Expr) (PartAttr, Attr)+ f (c, ColE gc) = Right (c, gc)+ f (c, e) = Left (c, e)++ mkExp :: (PartAttr, Attr) -> (PartAttr, Expr)+ mkExp (c, gc) = (c, ColE gc)++ (partExprs, partCols) = partitionEithers $ map f groupProjs++ (reqPartCols, notReqPartCols) = partition (\gp -> fst gp `S.member` icols)+ partCols++ -- Seed the set of required grouping columns with those who are+ -- required from above.+ reqCols = S.fromList $ map snd reqPartCols++ -- Before considering non-trivial functional dependencies, we try+ -- to remove grouping columns based on trivial functional+ -- dependencies: If the projection column of a grouping projection+ -- is not required from above and the corresponding grouping+ -- column is already present in the set of required grouping+ -- columns, the projection can be safely removed.+ notReqPartCols' = filter (\(_, gc) -> not $ gc `S.member` reqCols)+ notReqPartCols++ allCols = S.fromList $ map snd partCols++-- | Determine wether a column c is functionally determined by a+-- set of columns.+coveredCol :: FDSet -> Attr -> S.Set Attr -> Bool+coveredCol fds c cs =+ case M.lookup cs (fdsRep fds) of+ Just deps -> c `S.member` deps+ Nothing -> False++triviallyCovered :: S.Set Attr -> Attr -> Bool+triviallyCovered cs c = c `S.member` cs++-- | Prune unreferenced grouping columns based on functional+-- dependencies.+unreferencedGroupingCols :: TARule AllProps+unreferencedGroupingCols q =+ $(dagPatMatch 'q "Aggr args (q1)"+ [| do+ neededCols <- pICols <$> td <$> properties q+ fds <- pFunDeps <$> bu <$> properties $(v "q1")+ (aggrs, partCols) <- return $(v "args")++ -- trace ("AGGR PARTCOLS " ++ show partCols) $ return ()+ -- trace ("AGGR ICOLS " ++ show neededCols) $ return ()+ -- trace ("AGGR FDS " ++ show fds) $ return ()++ predicate $ not $ S.null $ (S.fromList $ map fst partCols) S.\\ neededCols+ predicate $ length partCols > 1++ let partCols' = prunePartExprs neededCols partCols fds++ predicate $ length partCols' < length partCols+ -- trace ("AGGR GROUP " ++ show partCols'') $ return ()++ return $ do+ logRewrite "Basic.ICols.Aggr.PruneGroupingCols" q+ void $ replaceWithNew q $ UnOp (Aggr (aggrs, partCols')) $(v "q1") |])++--------------------------------------------------------------------------------++-- | Prune ordering columns that are functionally determined by+-- preceding columns.+pruneOrdColsFD :: FDSet -> [OrdCol] -> [OrdCol]+pruneOrdColsFD fds ordCols = go S.empty ordCols+ where+ go :: S.Set Attr -> [OrdCol] -> [OrdCol]+ go cs (OrdCol c@(_, d) (ColE oc) : ocs)+ | any (\ds -> coveredCol fds oc ds) dets+ = go cs ocs+ | otherwise+ = OrdCol c (ColE oc) : go (S.insert oc cs) ocs+ where+ dets = S.filter (\ds -> ds `S.isSubsetOf` cs)+ $ S.fromList $ M.keys $ fdsRep fds+ go cs (OrdCol c e : ocs) = OrdCol c e : go cs ocs+ go _ [] = []++isAscOrd :: OrdCol -> Bool+isAscOrd (OrdCol (_, Asc) _) = True+isAscOrd _ = False++-- | Prune ordering columns based on functional dependenices.+pruneSerializeSortColsFD :: TARule AllProps+pruneSerializeSortColsFD q =+ $(dagPatMatch 'q "Serialize args (q1)"+ [| do+ fds <- pFunDeps <$> bu <$> properties $(v "q1")+ (rcs, kcs, ocs, pcs) <- return $(v "args")+ -- trace ("SERIALIZE OCS " ++ show ocs) $ return ()+ -- trace ("SERIALIZE FDS " ++ show fds) $ return ()++ -- We restrict pruning to all-ascending orders for a simple+ -- reason: We have no clue what should happen if there are+ -- descending orders as well.+ predicate $ all isAscOrd ocs++ let ocs' = pruneOrdColsFD fds ocs+ predicate $ length ocs' < length ocs++ return $ do+ logRewrite "Basic.ICols.Serialize.PruneSortingCols.FD" q+ let args' = (rcs, kcs, ocs', pcs)+ void $ replaceWithNew q $ UnOp (Serialize args') $(v "q1") |])++--------------------------------------------------------------------------------++-- | Prune ordering expressions that occur more than once+pruneOrdCols :: [OrdCol] -> [OrdCol]+pruneOrdCols ordCols = go S.empty ordCols+ where+ go :: S.Set Expr -> [OrdCol] -> [OrdCol]+ go es (OrdCol c e : ocs)+ | S.member e es+ = go es ocs+ | otherwise+ = OrdCol c e : go (S.insert e es) ocs+ go _ [] = []++-- | Eliminate ordering expressions that occur more than once.+pruneSerializeSortCols :: TARule ()+pruneSerializeSortCols q =+ $(dagPatMatch 'q "Serialize args (q1)"+ [| do+ (rcs, kcs, ocs, pcs) <- return $(v "args")+ -- trace ("SERIALIZE OCS " ++ show ocs) $ return ()+ -- trace ("SERIALIZE FDS " ++ show fds) $ return ()++ -- We restrict pruning to all-ascending orders for a simple+ -- reason: We have no clue what should happen if there are+ -- descending orders as well.+ predicate $ all isAscOrd ocs++ let ocs' = pruneOrdCols ocs+ predicate $ length ocs' < length ocs++ return $ do+ logRewrite "Basic.Serialize.PruneSortingCols" q+ let args' = (rcs, kcs, ocs', pcs)+ void $ replaceWithNew q $ UnOp (Serialize args') $(v "q1") |])++----------------------------------------------------------------------------------+-- Basic Const rewrites++isConstExpr :: [ConstCol] -> Expr -> Bool+isConstExpr constCols e = isJust $ constExpr constCols e++-- | Prune const columns from aggregation keys+constAggrKey :: TARule AllProps+constAggrKey q =+ $(dagPatMatch 'q "Aggr args (q1)"+ [| do+ constCols <- pConst <$> bu <$> properties $(v "q1")+ neededCols <- S.toList <$> pICols <$> td <$> properties q+ (aggrFuns, keyCols@(_:_)) <- return $(v "args")++ let keyCols' = filter (\(_, e) -> not $ isConstExpr constCols e) keyCols+ prunedKeys = (map fst keyCols) \\ (map fst keyCols')++ predicate $ not $ null prunedKeys++ return $ do+ logRewrite "Basic.Const.Aggr" q+ let necessaryKeys = prunedKeys `intersect` neededCols++ constProj c = lookup c constCols >>= \val -> return (c, ConstE val)++ constProjs = mapMaybe constProj necessaryKeys++ proj = map (\(_, c) -> (c, ColE c)) aggrFuns+ +++ map (\(c, _) -> (c, ColE c)) keyCols'+ +++ constProjs+++ aggrNode <- insert $ UnOp (Aggr ($(v "aggrFuns"), keyCols')) $(v "q1")+ void $ replaceWithNew q $ UnOp (Project proj) aggrNode |])++constRownumCol :: TARule AllProps+constRownumCol q =+ $(dagPatMatch 'q "RowNum args (q1)"+ [| do+ constCols <- pConst <$> bu <$> properties $(v "q1")++ (resCol, sortCols, partExprs) <- return $(v "args")+ let sortCols' = filter (\(e, _) -> not $ isConstExpr constCols e) sortCols+ predicate $ length sortCols' < length sortCols++ return $ do+ logRewrite "Basic.Const.RowNum" q+ void $ replaceWithNew q $ UnOp (RowNum (resCol, sortCols', partExprs)) $(v "q1") |])++constRowRankCol :: TARule AllProps+constRowRankCol q =+ $(dagPatMatch 'q "RowRank args (q1)"+ [| do+ constCols <- pConst <$> bu <$> properties $(v "q1")+ (resCol, sortCols) <- return $(v "args")+ let sortCols' = filter (\(e, _) -> not $ isConstExpr constCols e) sortCols+ predicate $ length sortCols' < length sortCols++ return $ do+ logRewrite "Basic.Const.RowRank" q+ void $ replaceWithNew q $ UnOp (RowRank (resCol, sortCols')) $(v "q1") |])++-- constSerializeCol :: TARule AllProps+-- constSerializeCol q =+-- $(dagPatMatch 'q "Serialize args (q1)"+-- [| do+-- (mDescr, RelPos sortCols, payload) <- return $(v "args")+-- constCols <- map fst <$> pConst <$> bu <$> properties $(v "q1")++-- let sortCols' = filter (\c -> c `notElem` constCols) sortCols+-- predicate $ length sortCols' < length sortCols++-- return $ do+-- logRewrite "Basic.Const.Serialize" q+-- void $ replaceWithNew q $ UnOp (Serialize (mDescr, RelPos sortCols', payload)) $(v "q1") |])++constWinOrderCol :: TARule AllProps+constWinOrderCol q =+ $(dagPatMatch 'q "WinFun args (q1)"+ [| do+ constCols <- pConst <$> bu <$> properties $(v "q1")+ let (f, part, sortCols, frameSpec) = $(v "args")+ let sortCols' = filter (\(e, _) -> not $ isConstExpr constCols e) sortCols+ predicate $ length sortCols' < length sortCols++ return $ do+ logRewrite "Basic.Const.WinFun" q+ void $ replaceWithNew q $ UnOp (WinFun (f, part, sortCols', frameSpec)) $(v "q1") |])+++----------------------------------------------------------------------------------+-- Basic Order rewrites++-- | @lookupSortCol@ returns @Left@ if there is no mapping from the+-- original sort column and @Right@ if there is a mapping from the+-- original sort column to a list of columns that define the same+-- order.+lookupSortCol :: SortSpec -> Orders -> Either [SortSpec] [SortSpec]+lookupSortCol (ColE oldSortCol, Asc) os =+ case lookup oldSortCol os of+ Nothing -> Left [(ColE oldSortCol, Asc)]+ Just newSortCols -> Right $ map (\c -> (ColE c, Asc)) newSortCols+-- We do not inline into arbitrary expressions for now. Likewise, we+-- do not consider non-ascending sorting.+lookupSortCol (e, dir) _ = Left [(e, dir)]++inlineSortColsRownum :: TARule AllProps+inlineSortColsRownum q =+ $(dagPatMatch 'q "RowNum o (q1)"+ [| do+ (resCol, sortCols@(_:_), groupCols) <- return $(v "o")++ predicate $ all ((== Asc) . snd) sortCols++ orders@(_:_) <- pOrder <$> bu <$> properties $(v "q1")++ -- For each sorting column, try to find the original+ -- order-defining sorting columns.+ let mSortCols = map (flip lookupSortCol orders) sortCols++ -- The rewrite should only fire if something actually changes+ predicate $ any isRight mSortCols++ let sortCols' = nub $ concatMap (either id id) mSortCols++ return $ do+ logRewrite "Basic.InlineOrder.RowNum" q+ void $ replaceWithNew q $ UnOp (RowNum (resCol, sortCols', groupCols)) $(v "q1") |])++-- inlineSortColsSerialize :: TARule AllProps+-- inlineSortColsSerialize q =+-- $(dagPatMatch 'q "Serialize scols (q1)"+-- [| do+-- (d, RelPos cs, reqCols) <- return $(v "scols")+-- orders@(_:_) <- pOrder <$> bu <$> properties $(v "q1")++-- let cs' = nub $ concatMap (\c -> maybe [c] id $ lookup c orders) cs+-- predicate $ cs /= cs'++-- return $ do+-- logRewrite "Basic.InlineOrder.Serialize" q+-- void $ replaceWithNew q $ UnOp (Serialize (d, RelPos cs', reqCols)) $(v "q1") |])++inlineSortColsWinFun :: TARule AllProps+inlineSortColsWinFun q =+ $(dagPatMatch 'q "WinFun args (q1)"+ [| do+ let (f, part, sortCols, frameSpec) = $(v "args")++ orders@(_:_) <- pOrder <$> bu <$> properties $(v "q1")++ -- For each sorting column, try to find the original+ -- order-defining sorting columns.+ let mSortCols = map (flip lookupSortCol orders) sortCols++ -- The rewrite should only fire if something actually changes+ predicate $ any isRight mSortCols++ let sortCols' = nub $ concatMap (either id id) mSortCols+ args' = (f, part, sortCols', frameSpec)++ return $ do+ logRewrite "Basic.InlineOrder.WinFun" q+ void $ replaceWithNew q $ UnOp (WinFun args') $(v "q1") |])++isKeyPrefix :: S.Set PKey -> [SortSpec] -> Bool+isKeyPrefix keys orderCols =+ case mapM mColE $ map fst orderCols of+ Just cols -> S.fromList cols `S.member` keys+ Nothing -> False++-- | If a prefix of the ordering columns in a rownum operator forms a+-- key, the suffix can be removed.+keyPrefixOrdering :: TARule AllProps+keyPrefixOrdering q =+ $(dagPatMatch 'q "RowNum args (q1)"+ [| do+ (resCol, sortCols, []) <- return $(v "args")+ keys <- pKeys <$> bu <$> properties $(v "q1")++ predicate $ not $ null sortCols++ -- All non-empty and incomplete prefixes of the ordering+ -- columns+ let ordPrefixes = init $ drop 1 (inits sortCols)+ Just prefix <- return $ find (isKeyPrefix keys) ordPrefixes++ return $ do+ logRewrite "Basic.SimplifyOrder.KeyPrefix" q+ let sortCols' = take (length prefix) sortCols+ void $ replaceWithNew q $ UnOp (RowNum (resCol, sortCols', [])) $(v "q1") |])++duplicateSortingCriteriaRownum :: TARule ()+duplicateSortingCriteriaRownum q =+ $(dagPatMatch 'q "RowNum args (q1)"+ [| do+ (resCol, sortCols, []) <- return $(v "args")++ let sortCols' = nub sortCols++ predicate $ length sortCols' < length sortCols++ return $ do+ logRewrite "Basic.SimplifyOrder.Duplicates.Rownum" q+ let args' = (resCol, sortCols', [])+ void $ replaceWithNew q $ UnOp (RowNum args') $(v "q1") |])++duplicateSortingCriteriaWin :: TARule ()+duplicateSortingCriteriaWin q =+ $(dagPatMatch 'q "WinFun args (q1)"+ [| do+ let (winFuns, part, sortCols, mFrameBounds) = $(v "args")++ let sortCols' = nub sortCols++ predicate $ length sortCols' < length sortCols++ return $ do+ logRewrite "Basic.SimplifyOrder.Duplicates.WinFun" q+ let args' = (winFuns, part, sortCols', mFrameBounds)+ void $ replaceWithNew q $ UnOp (WinFun args') $(v "q1") |])++-- duplicateSortingCriteriaSerialize :: TARule ()+-- duplicateSortingCriteriaSerialize q =+-- $(dagPatMatch 'q "Serialize args (q1)"+-- [| do+-- (mDescr, RelPos sortCols, payload) <- return $(v "args")+-- let sortCols' = nub sortCols++-- predicate $ length sortCols' < length sortCols++-- return $ do+-- logRewrite "Basic.SimplifyOrder.Duplicates.Serialize" q+-- let args' = (mDescr, RelPos sortCols', payload)+-- void $ replaceWithNew q $ UnOp (Serialize args') $(v "q1") |])++-- | If a rownum output is not refererenced by a parent projection,+-- discard it. This handles the case of a multi-parent rownum that is+-- not required by a specific parent but is required by other parents+-- and therefore can't be eliminated globally.+--+-- FIXME It would be more elegant and general to make the ICols+-- analysis parent-aware so that we can tell for an operator wether it+-- is required by a specific parent.+bypassRownumProject :: TARule ()+bypassRownumProject q =+ $(dagPatMatch 'q "Project p (RowNum s (q1))"+ [| do+ let (resCol, _, _) = $(v "s")+ predicate $ not $ S.member resCol (S.unions $ map (exprCols . snd) $(v "p"))+ return $ do+ logRewrite "Basic.SimplifyOrder.BypassRownum" q+ void $ replaceWithNew q $ UnOp (Project $(v "p")) $(v "q1") |])++----------------------------------------------------------------------------------+-- Serialize rewrites++-- -- | Merge a projection which only maps columns into a Serialize operator.+-- serializeProject :: TARule ()+-- serializeProject q =+-- $(dagPatMatch 'q "Serialize scols (Project projs (q1))"+-- [| do+-- (d, p, reqCols) <- return $(v "scols")++-- let projCol (c', ColE c) = return (c', c)+-- projCol _ = fail "no match"++-- lookupFail x xys = case lookup x xys of+-- Just y -> return y+-- Nothing -> fail "no match"++-- colMap <- mapM projCol $(v "projs")++-- -- find new names for all required columns+-- reqCols' <- mapM (\(PayloadCol c) -> PayloadCol <$> lookupFail c colMap) reqCols++-- -- find new name for the descriptor column (if required)+-- d' <- case d of+-- Just (DescrCol c) -> Just <$> DescrCol <$> lookupFail c colMap+-- Nothing -> return Nothing++-- -- find new name for the pos column (if required)+-- p' <- case p of+-- AbsPos c -> AbsPos <$> lookupFail c colMap+-- RelPos cs -> RelPos <$> mapM (flip lookupFail colMap) cs+-- NoPos -> return NoPos++-- return $ do+-- logRewrite "Basic.Serialize.Project" q+-- void $ replaceWithNew q $ UnOp (Serialize (d', p', reqCols')) $(v "q1") |])++--------------------------------------------------------------------------------+-- Pulling projections through other operators and merging them into+-- other operators++inlineExpr :: [Proj] -> Expr -> Expr+inlineExpr proj expr =+ case expr of+ BinAppE op e1 e2 -> BinAppE op (inlineExpr proj e1) (inlineExpr proj e2)+ UnAppE op e -> UnAppE op (inlineExpr proj e)+ ColE c -> fromMaybe (failedLookup c) (lookup c proj)+ ConstE val -> ConstE val+ IfE c t e -> IfE (inlineExpr proj c) (inlineExpr proj t) (inlineExpr proj e)++ where+ failedLookup :: Attr -> a+ failedLookup c = trace (printf "mergeProjections: column lookup %s failed\n%s\n%s"+ c (show expr) (show proj))+ $impossible++mergeProjections :: [Proj] -> [Proj] -> [Proj]+mergeProjections proj1 proj2 = map (\(c, e) -> (c, inlineExpr proj2 e)) proj1++stackedProject :: TARule ()+stackedProject q =+ $(dagPatMatch 'q "Project ps1 (Project ps2 (qi))"+ [| do+ return $ do+ let ps = mergeProjections $(v "ps1") $(v "ps2")+ logRewrite "Basic.Project.Merge" q+ void $ replaceWithNew q $ UnOp (Project ps) $(v "qi") |])++++mapWinFun :: (Expr -> Expr) -> WinFun -> WinFun+mapWinFun f (WinMax e) = WinMax $ f e+mapWinFun f (WinMin e) = WinMin $ f e+mapWinFun f (WinSum e) = WinSum $ f e+mapWinFun f (WinAvg e) = WinAvg $ f e+mapWinFun f (WinAll e) = WinAll $ f e+mapWinFun f (WinAny e) = WinAny $ f e+mapWinFun f (WinFirstValue e) = WinFirstValue $ f e+mapWinFun f (WinLastValue e) = WinLastValue $ f e+mapWinFun _ WinCount = WinCount++mapAggrFun :: (Expr -> Expr) -> AggrType -> AggrType+mapAggrFun f (Max e) = Max $ f e+mapAggrFun f (Min e) = Min $ f e+mapAggrFun f (Sum e) = Sum $ f e+mapAggrFun f (Avg e) = Avg $ f e+mapAggrFun f (All e) = All $ f e+mapAggrFun f (Any e) = Any $ f e+mapAggrFun f (Count e) = Count $ f e+mapAggrFun _ CountStar = CountStar++nameChangeProj :: (Attr, Expr) -> Either (Attr, Attr) (Attr, Expr)+nameChangeProj (c, ColE c') | c /= c' = Left (c, c')+nameChangeProj (c, e) = Right (c, e)++-- | If grouping columns are renamed, move renaming to a+-- projection. This makes plans more readable by keeping base table+-- names and should lead to more compact SQL code (less column+-- renaming)+pullProjectAggr :: TARule ()+pullProjectAggr q =+ $(dagPatMatch 'q "Aggr args (q1)"+ [| do+ let (as, gs) = $(v "args")+ -- Check wether there are projections that only change an+ -- attribute name+ let (gnps, gps) = partitionEithers $ map nameChangeProj gs+ predicate $ not $ null gnps++ -- Check that the original name in a grouping projection+ -- does not collide with one of the output names for+ -- aggregates.+ predicate $ null $ (map snd gnps) `intersect` (map snd as)++ return $ do+ logRewrite "Basic.PullProject.Aggr" q++ let gs' = nub $ gps ++ map (\(_, c) -> (c, ColE c)) gnps+ proj = map (\(_, c) -> (c, ColE c)) as+ ++ map (\(c, _) -> (c, ColE c)) gps+ ++ map (\(c, c') -> (c, ColE c')) gnps++ aggrNode <- insert $ UnOp (Aggr (as, gs')) $(v "q1")+ void $ replaceWithNew q $ UnOp (Project proj) aggrNode |])+++pullProjectWinFun :: TARule ()+pullProjectWinFun q =+ $(dagPatMatch 'q "WinFun args (Project proj (q1))"+ [| do+ -- Only consider window functions without partitioning for+ -- now. Partitioning requires proper values and inlining+ -- would be problematic.+ ((resCol, f), [], sortSpec, frameSpec) <- return $(v "args")++ -- If the window function result overwrites one of the+ -- projection columns, we can't pull.+ predicate $ resCol `notElem` (map fst $(v "proj"))++ return $ do+ logRewrite "Basic.PullProject.WinFun" q++ -- Merge the projection expressions into window function+ -- arguments and ordering expressions.+ let f' = mapWinFun (inlineExpr $(v "proj")) f++ sortSpec' = map (\(e, d) -> (inlineExpr $(v "proj") e, d)) sortSpec++ proj' = $(v "proj") ++ [(resCol, ColE resCol)]++ winNode <- insert $ UnOp (WinFun ((resCol, f'), [], sortSpec', frameSpec)) $(v "q1")+ void $ replaceWithNew q $ UnOp (Project proj') winNode |])++pullProjectSerialize :: TARule ()+pullProjectSerialize q =+ $(dagPatMatch 'q "Serialize args (Project proj (q1))"+ [| do+ return $ do+ logRewrite "Basic.PullProject.Serialize" q+ let (rcs, kcs, ocs, pcs) = $(v "args")+ let rcs' = [ RefCol c (inlineExpr $(v "proj") e) | RefCol c e <- rcs ]+ kcs' = [ KeyCol c (inlineExpr $(v "proj") e) | KeyCol c e <- kcs ]+ ocs' = [ OrdCol c (inlineExpr $(v "proj") e) | OrdCol c e <- ocs ]+ pcs' = [ PayloadCol c (inlineExpr $(v "proj") e)+ | PayloadCol c e <- pcs+ ]++ void $ replaceWithNew q $ UnOp (Serialize (rcs', kcs', ocs', pcs')) $(v "q1") |])++pullProjectSelect :: TARule ()+pullProjectSelect q =+ $(dagPatMatch 'q "Select p (Project proj (q1))"+ [| do+ return $ do+ logRewrite "Basic.PullProject.Select" q+ let p' = inlineExpr $(v "proj") $(v "p")+ selectNode <- insert $ UnOp (Select p') $(v "q1")+ void $ replaceWithNew q $ UnOp (Project $(v "proj")) selectNode |])++mergeProjIntoSortSpec :: (Attr, [SortSpec], [PartExpr])+ -> [(Attr, Expr)]+ -> (Attr, [SortSpec], [PartExpr])+mergeProjIntoSortSpec (attr, sortSpec, partSpec) proj = (attr, sortSpec', partSpec')+ where+ sortSpec' = map (\(e, dir) -> (inlineExpr proj e, dir)) sortSpec+ partSpec' = map (inlineExpr proj) partSpec++pullProjectRownum :: TARule ()+pullProjectRownum q =+ $(dagPatMatch 'q "RowNum s (Project p (q1))"+ [| do+ let (resCol, _, _) = $(v "s")++ -- If the rownum overwrites one of the columns generated by+ -- the projection, remove it from the projection.+ let p' = [ (a, e) | (a, e) <- $(v "p"), a /= resCol ]++ -- Make sure that the rownum result column does not appear+ -- in one of the projection expressions to avoid shadowing.+ predicate $ not $ S.member resCol (S.unions $ map (exprCols . snd) p')++ return $ do+ logRewrite "Basic.PullProject.Rownum" q+ let p'' = p' ++ [(resCol, ColE resCol)]+ s' = mergeProjIntoSortSpec $(v "s") $(v "p")+ rownumNode <- insert $ UnOp (RowNum s') $(v "q1")+ void $ replaceWithNew q $ UnOp (Project p'') rownumNode |])++inlineJoinPredRight :: [Proj] -> [(Expr, Expr, JoinRel)] -> [(Expr, Expr, JoinRel)]+inlineJoinPredRight proj p = map inlineConjunct p+ where+ inlineConjunct (le, re, rel) = (le, inlineExpr proj re, rel)++inlineJoinPredLeft :: [Proj] -> [(Expr, Expr, JoinRel)] -> [(Expr, Expr, JoinRel)]+inlineJoinPredLeft proj p = map inlineConjunct p+ where+ inlineConjunct (le, re, rel) = (inlineExpr proj le, re, rel)++pullProjectSemiJoinLeft :: TARule ()+pullProjectSemiJoinLeft q =+ $(dagPatMatch 'q "(Project proj (q1)) [SemiJoin | AntiJoin]@joinOp p (q2)"+ [| do+ return $ do+ logRewrite "Basic.PullProject.SemiJoin.Left" q+ let p' = inlineJoinPredLeft $(v "proj") $(v "p")+ joinNode <- insert $ BinOp ($(v "joinOp") p') $(v "q1") $(v "q2")+ void $ replaceWithNew q $ UnOp (Project $(v "proj")) joinNode |])++pullProjectSemiJoinRight :: TARule ()+pullProjectSemiJoinRight q =+ $(dagPatMatch 'q "(q1) [SemiJoin | AntiJoin]@jop p (Project proj (q2))"+ [| do+ return $ do+ logRewrite "Basic.PullProject.SemiJoin.Right" q+ let p' = inlineJoinPredRight $(v "proj") $(v "p")+ void $ replaceWithNew q $ BinOp ($(v "jop") p') $(v "q1") $(v "q2") |])++pullProjectThetaJoinLeft :: TARule AllProps+pullProjectThetaJoinLeft q =+ $(dagPatMatch 'q "(Project p (q1)) [ThetaJoin | LeftOuterJoin]@op jp (q2)"+ [| do+ colsLeft <- fmap fst <$> pCols <$> bu <$> properties $(v "q1")+ colsRight <- fmap fst <$> pCols <$> bu <$> properties $(v "q2")+ predicate $ S.null $ S.intersection colsLeft colsRight++ return $ do+ logRewrite "Basic.PullProject.Join.Left" q+ let jp' = inlineJoinPredLeft $(v "p") $(v "jp")+ p' = $(v "p")+ +++ S.toList (fmap (\c -> (c, ColE c)) colsRight)+ joinNode <- insert $ BinOp ($(v "op") jp') $(v "q1") $(v "q2")+ void $ replaceWithNew q $ UnOp (Project p') joinNode |])++pullProjectThetaJoinRight :: TARule AllProps+pullProjectThetaJoinRight q =+ $(dagPatMatch 'q "(q1) [ThetaJoin | LeftOuterJoin]@op jp (Project p (q2))"+ [| do+ colsLeft <- fmap fst <$> pCols <$> bu <$> properties $(v "q1")+ colsRight <- fmap fst <$> pCols <$> bu <$> properties $(v "q2")+ predicate $ S.null $ S.intersection colsLeft colsRight++ return $ do+ logRewrite "Basic.PullProject.Join.Right" q+ let jp' = inlineJoinPredRight $(v "p") $(v "jp")+ p' = S.toList (fmap (\c -> (c, ColE c)) colsLeft)+ +++ $(v "p")+ joinNode <- insert $ BinOp ($(v "op") jp') $(v "q1") $(v "q2")+ void $ replaceWithNew q $ UnOp (Project p') joinNode |])++pullProjectCrossLeft :: TARule AllProps+pullProjectCrossLeft q =+ $(dagPatMatch 'q "(Project p (q1)) Cross _ (q2)"+ [| do+ colsLeft <- fmap fst <$> pCols <$> bu <$> properties $(v "q1")+ colsRight <- fmap fst <$> pCols <$> bu <$> properties $(v "q2")+ predicate $ S.null $ S.intersection colsLeft colsRight++ return $ do+ logRewrite "Basic.PullProject.Cross.Left" q+ let p' = $(v "p")+ +++ S.toList (fmap (\c -> (c, ColE c)) colsRight)+ crossNode <- insert $ BinOp (Cross ()) $(v "q1") $(v "q2")+ void $ replaceWithNew q $ UnOp (Project p') crossNode |])++pullProjectCrossRight :: TARule AllProps+pullProjectCrossRight q =+ $(dagPatMatch 'q "(q1) Cross _ (Project p (q2))"+ [| do+ colsLeft <- fmap fst <$> pCols <$> bu <$> properties $(v "q1")+ colsRight <- fmap fst <$> pCols <$> bu <$> properties $(v "q2")+ predicate $ S.null $ S.intersection colsLeft colsRight++ return $ do+ logRewrite "Basic.PullProject.Cross.Right" q+ let p' = S.toList (fmap (\c -> (c, ColE c)) colsLeft)+ +++ $(v "p")+ crossNode <- insert $ BinOp (Cross ()) $(v "q1") $(v "q2")+ void $ replaceWithNew q $ UnOp (Project p') crossNode |])++inlineProjectAggr :: TARule ()+inlineProjectAggr q =+ $(dagPatMatch 'q "Aggr args (Project p (q1))"+ [| do+ let (as, gs) = $(v "args")+ let inline = inlineExpr $(v "p")+ let as' = map (\(a, c) -> (mapAggrFun inline a, c)) as+ gs' = map (\(c, e) -> (c, inline e)) gs++ return $ do+ logRewrite "Basic.PullProject.Aggr" q+ void $ replaceWithNew q $ UnOp (Aggr (as', gs')) $(v "q1") |])++--------------------------------------------------------------------------------+-- Rewrites based on functional dependencies+
+ src/Database/DSH/Backend/Sql/Opt/Rewrite/Common.hs view
@@ -0,0 +1,35 @@+module Database.DSH.Backend.Sql.Opt.Rewrite.Common where++import qualified Data.IntMap as M++import Database.Algebra.Dag.Common+import Database.Algebra.Table.Lang++import Database.DSH.Backend.Sql.Vector+import Database.DSH.Common.QueryPlan+import Database.DSH.Common.Opt++import Database.DSH.Backend.Sql.Opt.Properties.BottomUp+import Database.DSH.Backend.Sql.Opt.Properties.TopDown+import Database.DSH.Backend.Sql.Opt.Properties.Types++ -- Type abbreviations for convenience+type TARewrite p = Rewrite TableAlgebra (Shape TADVec) p+type TARule p = Rule TableAlgebra p (Shape TADVec)+type TARuleSet p = RuleSet TableAlgebra p (Shape TADVec)+type TAMatch p = Match TableAlgebra p (Shape TADVec)++inferBottomUp :: TARewrite (NodeMap BottomUpProps)+inferBottomUp = do+ props <- infer inferBottomUpProperties+ return props++inferAll :: TARewrite (NodeMap AllProps)+inferAll = do+ to <- topsort+ buPropMap <- infer inferBottomUpProperties+ props <- infer (inferAllProperties buPropMap to)+ return props++noProps :: Monad m => m (M.IntMap a)+noProps = return M.empty
+ src/Database/DSH/Backend/Sql/Vector.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Backend.Sql.Vector where++-- import Data.Monoid++import Data.Aeson.TH+++import Database.Algebra.Dag.Common+import qualified Database.Algebra.Table.Lang as TA+import Database.DSH.Common.Vector++--------------------------------------------------------------------------------++-- | The ordering columns of a data vector+newtype VecOrder = VecOrder [TA.SortDir]++unOrd :: VecOrder -> Int+unOrd (VecOrder os) = length os++instance Monoid VecOrder where+ mempty = VecOrder []+ mappend (VecOrder o1) (VecOrder o2) = VecOrder (o1 ++ o2)++--------------------------------------------------------------------------------++-- | The natural key of a data vector+newtype VecKey = VecKey { unKey :: Int }++instance Monoid VecKey where+ mempty = VecKey 0+ mappend (VecKey k1) (VecKey k2) = VecKey (k1 + k2)++--------------------------------------------------------------------------------++-- | Outer key reference columns+newtype VecRef = VecRef { unRef :: Int }++-- | Derive inner references from an outer key.+keyRef :: VecKey -> VecRef+keyRef (VecKey i) = VecRef i++instance Monoid VecRef where+ mempty = VecRef 0+ mappend (VecRef r1) (VecRef r2) = VecRef (r1 + r2)++--------------------------------------------------------------------------------++-- | Payload columns of a data vector+newtype VecItems = VecItems { unItems :: Int }++instance Monoid VecItems where+ mempty = VecItems 0+ mappend (VecItems i1) (VecItems i2) = VecItems (i1 + i2)++--------------------------------------------------------------------------------++-- | Source columns of a transformation vector+newtype VecTransSrc = VecTransSrc { unSrc :: Int }++-- | Destination columns of a transformation vector+newtype VecTransDst = VecTransDst { unDst :: Int }++--------------------------------------------------------------------------------++-- | Key columns of a filter vector+newtype VecFilter = VecFilter Int++--------------------------------------------------------------------------------++data TADVec = TADVec AlgNode VecOrder VecKey VecRef VecItems++data TAKVec = TAKVec AlgNode VecTransSrc VecTransDst++data TARVec = TARVec AlgNode VecTransSrc VecTransDst++-- | Sorting of segments is a NOOP in the natural key backend.+data TASVec = TASVec++data TAFVec = TAFVec AlgNode VecFilter++instance DagVector TADVec where+ vectorNodes (TADVec n _ _ _ _) = [n]++ updateVector n1 n2 (TADVec q o k r i)+ | q == n1 = TADVec n2 o k r i+ | otherwise = TADVec q o k r i++--------------------------------------------------------------------------------++$(deriveJSON defaultOptions ''VecOrder)+$(deriveJSON defaultOptions ''VecKey)+$(deriveJSON defaultOptions ''VecRef)+$(deriveJSON defaultOptions ''VecItems)+$(deriveJSON defaultOptions ''VecTransSrc)+$(deriveJSON defaultOptions ''VecTransDst)+$(deriveJSON defaultOptions ''TADVec)+$(deriveJSON defaultOptions ''TAKVec)+$(deriveJSON defaultOptions ''TARVec)++--------------------------------------------------------------------------------
+ src/Database/DSH/Backend/Sql/VectorAlgebra.hs view
@@ -0,0 +1,1306 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Implementation of vector primitives in terms of table algebra+-- operators.+module Database.DSH.Backend.Sql.VectorAlgebra+ ( ic, kc, oc, rc+ ) where++import Control.Exception.Base+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as N+import Data.Monoid hiding (Sum, Any, All)+import GHC.Exts++import Database.Algebra.Dag.Build+import Database.Algebra.Dag.Common+import Database.Algebra.Table.Construct+import Database.Algebra.Table.Lang++import qualified Database.DSH.Common.Lang as L+import qualified Database.DSH.Common.Type as T++import Database.DSH.Backend.Sql.Vector+import Database.DSH.Common.Impossible+import qualified Database.DSH.VL as VL++--------------------------------------------------------------------------------+-- Column names++-- | Item columns+ic :: Int -> Attr+ic i = "i" ++ show i++-- | Key columns+kc :: Int -> Attr+kc i = "k" ++ show i++-- | Order columns+oc :: Int -> Attr+oc i = "o" ++ show i++-- | Ref columns+rc :: Int -> Attr+rc i = "r" ++ show i++-- | (Key) source columns+sc :: Int -> Attr+sc i = "s" ++ show i++-- | (Key) destination columns+dc :: Int -> Attr+dc i = "d" ++ show i++-- | Grouping columns+gc :: Int -> Attr+gc i = "g" ++ show i++-- | Filter columns+fc :: Int -> Attr+fc i = "f" ++ show i++-- | Synthesized order column (left)+lsoc :: Attr+lsoc = "lso"++-- | Synthesized order column (right)+rsoc :: Attr+rsoc = "rso"++-- | Synthesized order column+soc :: Attr+soc = "so"++-- | Union side marker+usc :: Attr+usc = "us"++keyCols :: VecKey -> [Attr]+keyCols (VecKey i) = [ kc c | c <- [1..i] ]++ordCols :: VecOrder -> [Attr]+ordCols (VecOrder o) = [ oc c | c <- [1..] | _ <- o ]++refCols :: VecRef -> [Attr]+refCols (VecRef i) = [ rc c | c <- [1..i] ]++itemCols :: VecItems -> [Attr]+itemCols (VecItems i) = [ ic c | c <- [1..i] ]++filterCols :: VecFilter -> [Attr]+filterCols (VecFilter i) = [ fc c | c <- [1..i] ]++srcCols :: VecTransSrc -> [Attr]+srcCols (VecTransSrc i) = [ sc c | c <- [1..i] ]++--------------------------------------------------------------------------------+-- Projection++-- | Column projection: 'c'+cP :: Attr -> Proj+cP a = (a, ColE a)++-- | Expression projection 'c:e'+eP :: Attr -> Expr -> Proj+eP = (,)++-- | Mapping projection 'a:b'+mP :: Attr -> Attr -> Proj+mP n o = (n, ColE o)++keyProj :: VecKey -> [Proj]+keyProj (VecKey i) = map (cP . kc) $ [1..i]++ordProj :: VecOrder -> [Proj]+ordProj (VecOrder ds) = zipWith (\_ i -> cP (oc i)) ds [1..]++refProj :: VecRef -> [Proj]+refProj (VecRef 0) = []+refProj (VecRef i) = map (cP . rc) [1..i]++itemProj :: VecItems -> [Proj]+itemProj (VecItems 0) = []+itemProj (VecItems i) = map (cP . ic) [1..i]++-- srcProj :: VecTransSrc -> [Proj]+-- srcProj (VecTransSrc i) = map (cP . sc) [1..i]++filterProj :: VecKey -> [Proj]+filterProj (VecKey i) = [ mP (fc c) (kc c) | c <- [1..i] ]++-- | Generate a projection that shifts item names of a right input+-- vector to avoid collision with the items in the left input vector.+shiftItems :: VecItems -> VecItems -> [Proj]+shiftItems (VecItems li) (VecItems ri) =+ [ mP (ic (c + li)) (ic c) | c <- [1..ri] ]++-- | Generate a projection that shifts key columns of a right input+-- vector to avoid collision with the key columns in the left input+-- vector.+shiftKey :: VecKey -> VecKey -> [Proj]+shiftKey (VecKey lk) (VecKey rk) =+ [ mP (kc (c + lk)) (kc c) | c <- [1..rk] ]++-- | Generate a projection that shifts key columns of a right input+-- vector to avoid collision with the key columns in the left input+-- vector.+shiftRef :: VecRef -> VecRef -> [Proj]+shiftRef (VecRef lr) (VecRef rr) =+ [ mP (rc (c + lr)) (rc c) | c <- [1..rr] ]++-- | Generate a projection that shifts key columns of a right input+-- vector to avoid collision with the key columns in the left input+-- vector.+shiftOrd :: VecOrder -> VecOrder -> [Proj]+shiftOrd (VecOrder lo) (VecOrder ro) =+ [ mP (oc (c + length lo)) (oc c) | c <- [1..] | _ <- ro ]++shiftAll :: TADVec -> TADVec -> [Proj]+shiftAll (TADVec _ o1 k1 r1 i1) (TADVec _ o2 k2 r2 i2) =+ shiftOrd o1 o2 +++ shiftKey k1 k2 +++ shiftRef r1 r2 +++ shiftItems i1 i2++-- | Generate a join predicate that joins two vectors by their keys.+keyJoin :: VecKey -> VecKey -> [(Expr, Expr, JoinRel)]+keyJoin (VecKey k1) (VecKey k2) = assert (k1 == k2) $+ [ (ColE (kc c), ColE (kc (c + k1)), EqJ) | c <- [1..k1]]++keySrcProj :: VecKey -> [Proj]+keySrcProj (VecKey i) = [ mP (sc c) (kc c) | c <- [1..i] ]++-- -- | Create the relational representation of a transformation vector+-- -- from a single data vector. The key is duplicated into source and+-- -- destination columns.+-- transProj :: VecKey -> [Proj]+-- transProj (VecKey i) = [ mP (sc c) (kc c) | c <- [1..i] ]+-- +++-- [ mP (dc c) (kc c) | c <- [1..i] ]++-- | Generate the left propagation vector for a product-like operator.+prodTransProjLeft :: VecKey -> VecKey -> [Proj]+prodTransProjLeft k1 k2 =+ [ mP (sc c) (kc c) | c <- [1..unKey k1] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey (k1 <> k2)] ]++-- | Generate the right propagation vector for a product-like operator.+prodTransProjRight :: VecKey -> VecKey -> [Proj]+prodTransProjRight k1 k2 =+ [ mP (sc c) (kc $ c + unKey k1) | c <- [1..unKey k2] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey (k1 <> k2)] ]++-- | Generate a projection that keeps all required columns of a vector+vecProj :: VecOrder -> VecKey -> VecRef -> VecItems -> [Proj]+vecProj o k r i = ordProj o ++ keyProj k ++ refProj r ++ itemProj i++chooseBaseKey :: N.NonEmpty L.Key -> NonEmpty Attr+chooseBaseKey keys = case sortWith (\(L.Key k) -> N.length k) $ N.toList keys of+ L.Key k : _ -> fmap (\(L.ColName c) -> c) k+ _ -> $impossible++keyRefProj :: VecKey -> [Proj]+keyRefProj (VecKey i) = [ mP (rc c) (kc c) | c <- [1..i] ]++--------------------------------------------------------------------------------+-- Expressions++algVal :: L.ScalarVal -> AVal+algVal (L.IntV i) = int (fromIntegral i)+algVal (L.BoolV t) = bool t+algVal L.UnitV = int 0xdeadbeef+algVal (L.StringV s) = string s+algVal (L.DoubleV d) = double d+algVal (L.DateV d) = date d+algVal (L.DecimalV d) = dec d++binOp :: L.ScalarBinOp -> Expr -> Expr -> Expr+binOp (L.SBNumOp L.Add) = BinAppE Plus+binOp (L.SBNumOp L.Sub) = BinAppE Minus+binOp (L.SBNumOp L.Div) = BinAppE Div+binOp (L.SBNumOp L.Mul) = BinAppE Times+binOp (L.SBNumOp L.Mod) = BinAppE Modulo+binOp (L.SBRelOp L.Eq) = BinAppE Eq+binOp (L.SBRelOp L.NEq) = BinAppE NEq+binOp (L.SBRelOp L.Gt) = BinAppE Gt+binOp (L.SBRelOp L.GtE) = BinAppE GtE+binOp (L.SBRelOp L.Lt) = BinAppE Lt+binOp (L.SBRelOp L.LtE) = BinAppE LtE+binOp (L.SBBoolOp L.Conj) = BinAppE And+binOp (L.SBBoolOp L.Disj) = BinAppE Or+binOp (L.SBStringOp L.Like) = BinAppE Like+binOp (L.SBDateOp L.AddDays) = \e1 e2 -> BinAppE Plus e2 e1+binOp (L.SBDateOp L.SubDays) = \e1 e2 -> BinAppE Minus e2 e1+binOp (L.SBDateOp L.DiffDays) = \e1 e2 -> BinAppE Minus e2 e1++unOp :: L.ScalarUnOp -> UnFun+unOp (L.SUBoolOp L.Not) = Not+unOp (L.SUCastOp (L.CastDouble)) = Cast doubleT+unOp (L.SUCastOp (L.CastDecimal)) = Cast decT+unOp (L.SUNumOp L.Sin) = Sin+unOp (L.SUNumOp L.Cos) = Cos+unOp (L.SUNumOp L.Tan) = Tan+unOp (L.SUNumOp L.ASin) = ASin+unOp (L.SUNumOp L.ACos) = ACos+unOp (L.SUNumOp L.ATan) = ATan+unOp (L.SUNumOp L.Sqrt) = Sqrt+unOp (L.SUNumOp L.Exp) = Exp+unOp (L.SUNumOp L.Log) = Log+unOp (L.SUTextOp (L.SubString f t)) = SubString f t+unOp (L.SUDateOp L.DateDay) = DateDay+unOp (L.SUDateOp L.DateMonth) = DateMonth+unOp (L.SUDateOp L.DateYear) = DateYear++taExprOffset :: Int -> VL.Expr -> Expr+taExprOffset o (VL.BinApp op e1 e2) = binOp op (taExprOffset o e1) (taExprOffset o e2)+taExprOffset o (VL.UnApp op e) = UnAppE (unOp op) (taExprOffset o e)+taExprOffset o (VL.Column c) = ColE $ ic $ c + o+taExprOffset _ (VL.Constant v) = ConstE $ algVal v+taExprOffset o (VL.If c t e) = IfE (taExprOffset o c) (taExprOffset o t) (taExprOffset o e)++taExpr :: VL.Expr -> Expr+taExpr = taExprOffset 0++--------------------------------------------------------------------------------++algTy :: T.ScalarType -> ATy+algTy T.IntT = intT+algTy T.DoubleT = doubleT+algTy T.BoolT = boolT+algTy T.StringT = stringT+algTy T.UnitT = intT+algTy T.DateT = dateT+algTy T.DecimalT = decT++aggrFun :: VL.AggrFun -> AggrType+aggrFun (VL.AggrSum _ e) = Sum $ taExpr e+aggrFun (VL.AggrMin e) = Min $ taExpr e+aggrFun (VL.AggrMax e) = Max $ taExpr e+aggrFun (VL.AggrAvg e) = Avg $ taExpr e+aggrFun (VL.AggrAll e) = All $ taExpr e+aggrFun (VL.AggrAny e) = Any $ taExpr e+aggrFun VL.AggrCount = CountStar++-- | Map aggregate functions to relational aggregates for the+-- groupjoin operator. For Count, we need the first key column of the+-- right input to account for the NULLs produced by the outer join.:725+aggrFunGroupJoin :: Int -> VL.AggrFun -> AggrType+aggrFunGroupJoin _ (VL.AggrSum _ e) = Sum $ taExpr e+aggrFunGroupJoin _ (VL.AggrMin e) = Min $ taExpr e+aggrFunGroupJoin _ (VL.AggrMax e) = Max $ taExpr e+aggrFunGroupJoin _ (VL.AggrAvg e) = Avg $ taExpr e+aggrFunGroupJoin _ (VL.AggrAll e) = All $ taExpr e+aggrFunGroupJoin _ (VL.AggrAny e) = Any $ taExpr e+aggrFunGroupJoin c VL.AggrCount = Count $ ColE (kc c)++-- | Transform a VL join predicate into a TA predicate. Items of the+-- left input are necessary to account for the pre-join item column+-- shift in the right input.+joinPredicate :: VecItems -> L.JoinPredicate VL.Expr -> [(Expr, Expr, JoinRel)]+joinPredicate (VecItems o) (L.JoinPred conjs) =+ N.toList $ fmap (joinConjunct o) conjs++joinConjunct :: Int -> L.JoinConjunct VL.Expr -> (Expr, Expr, JoinRel)+joinConjunct o (L.JoinConjunct e1 op e2) = (taExpr e1, taExprOffset o e2, joinOp op)++refJoinPred :: VecRef -> [(Expr, Expr, JoinRel)]+refJoinPred (VecRef r) = [ (ColE $ rc c, ColE $ rc $ c + r, EqJ) | c <- [1..r] ]++joinOp :: L.BinRelOp -> JoinRel+joinOp L.Eq = EqJ+joinOp L.Gt = GtJ+joinOp L.GtE = GeJ+joinOp L.Lt = LtJ+joinOp L.LtE = LeJ+joinOp L.NEq = NeJ++windowFunction :: VL.WinFun -> WinFun+windowFunction (VL.WinSum e) = WinSum $ taExpr e+windowFunction (VL.WinMin e) = WinMin $ taExpr e+windowFunction (VL.WinMax e) = WinMax $ taExpr e+windowFunction (VL.WinAvg e) = WinAvg $ taExpr e+windowFunction (VL.WinAll e) = WinAll $ taExpr e+windowFunction (VL.WinAny e) = WinAny $ taExpr e+windowFunction (VL.WinFirstValue e) = WinFirstValue $ taExpr e+windowFunction VL.WinCount = WinCount++frameSpecification :: VL.FrameSpec -> FrameBounds+frameSpecification VL.FAllPreceding = ClosedFrame FSUnboundPrec FECurrRow+frameSpecification (VL.FNPreceding n) = ClosedFrame (FSValPrec n) FECurrRow++--------------------------------------------------------------------------------++-- | The default value for sums over empty lists for all possible+-- numeric input types.+sumDefault :: T.ScalarType -> (ATy, AVal)+sumDefault T.IntT = (AInt, int 0)+sumDefault T.DoubleT = (ADouble, double 0)+sumDefault T.DecimalT = (ADec, dec 0)+sumDefault _ = $impossible++groupJoinDefault :: AlgNode+ -> VecOrder+ -> VecKey+ -> VecRef+ -> VecItems+ -> AVal+ -> Build TableAlgebra AlgNode+groupJoinDefault qa o k r i defaultVal =+ proj (vecProj o k r i+ +++ [eP acol (BinAppE Coalesce (ColE acol) (ConstE defaultVal))])+ qa+ where+ acol = ic (unItems i + 1)++-- | For a segmented aggregate operator, apply the aggregate+-- function's default value for the empty segments. The first argument+-- specifies the outer vector, while the second argument specifies the+-- result vector of the aggregate.+--+-- Note: AggrS produces regular vector with singleton segments. For+-- key and order of this vector, we can not use the inner key and+-- order of the aggregation result, as the values for the empty+-- segments are missing. Also, we can not mix in order and key values+-- of the outer vector, because they might not be aligned at+-- all. Instead, we generate surrogate values for order and key based+-- on the ref values. This is necessary to keep the vector+-- presentation uniform, but we can statically say that these+-- rownum-generated values will not be used: the aggregation default+-- has to be unboxed and unboxing will discard inner key and order.+--+-- FIXME employ an outerjoin-based scheme for default values based on+-- the unbox operator.+segAggrDefault :: AlgNode -> AlgNode -> VecKey -> VecRef -> AVal -> Build TableAlgebra AlgNode+segAggrDefault qo qa ok r defaultValue =+ -- Generate synthetic ord and key values for the inner vector.+ projM ([cP (oc 1), mP (kc 1) (oc 1)] ++ refProj r ++ [cP (ic 1)])+ $ rownumM (oc 1) (refCols r) []+ $ (proj (refProj r ++ itemProj (VecItems 1)) qa)+ `unionM`+ (projM (refProj r ++ [eP (ic 1) (ConstE defaultValue)])+ -- We know that the outer key must be aligned with inner references.+ (differenceM+ (proj (keyRefProj ok) qo)+ (proj (refProj r) qa)))++aggrDefault :: AlgNode -> AVal -> Build TableAlgebra AlgNode+aggrDefault qa defaultVal =+ proj [cP (oc 1), cP (kc 1), eP (ic 1) defaultExpr] qa++ where+ defaultExpr = BinAppE Coalesce (ColE (ic 1)) (ConstE defaultVal)++flipDir :: SortDir -> SortDir+flipDir Asc = Desc+flipDir Desc = Asc++synthOrder :: VecOrder -> [SortSpec]+synthOrder (VecOrder dirs) = [ (ColE $ oc c, d)| c <- [1..] | d <- dirs ]++--------------------------------------------------------------------------------++-- | The VectorAlgebra instance for TA algebra, implemented using+-- natural keys.+instance VL.VectorAlgebra TableAlgebra where+ type DVec TableAlgebra = TADVec+ type RVec TableAlgebra = TARVec+ type KVec TableAlgebra = TAKVec+ type FVec TableAlgebra = TAFVec+ type SVec TableAlgebra = TASVec++ vecWinFun a w (TADVec q o k r i) = do+ let wfun = windowFunction a+ frameSpec = frameSpecification w+ winCol = ic $ unItems i + 1+ qw <- winFun (winCol, wfun) [] (synthOrder o) (Just frameSpec) q+ return $ TADVec qw o k r (i <> (VecItems 1))++ vecUnique (TADVec q o k r i) = do+ -- Create groups based on the items and select the first+ -- member of each group+ qu <- projM (ordProj o ++ keyProj k ++ refProj r ++ itemProj i)+ $ selectM (BinAppE Eq (ColE soc) (ConstE $ VInt 1))+ $ rownum soc (ordCols o) (map ColE $ itemCols i) q++ return $ TADVec qu o k r i++ vecUniqueS (TADVec q o k r i) = do+ -- Create per-segment groups based on the items and select the+ -- first member of each group+ qu <- projM (ordProj o ++ keyProj k ++ refProj r ++ itemProj i)+ $ selectM (BinAppE Eq (ColE soc) (ConstE $ VInt 1))+ $ rownum soc (ordCols o) (map ColE $ refCols r ++ itemCols i) q++ return $ TADVec qu o k r i++ vecNumber (TADVec q o@(VecOrder ds) k r i) = do+ let i' = VecItems (unItems i + 1)+ nc = ic (unItems i + 1)++ qn <- rownum' nc [ (ColE c, d) | c <- ordCols o | d <- ds ] [] q+ return $ TADVec qn o k r i'++ -- FIXME we might have key order for inner vectors. include the+ -- key here.+ vecNumberS (TADVec q o@(VecOrder ds) k r i) = do+ let i' = VecItems (unItems i + 1)+ nc = ic (unItems i + 1)++ qn <- rownum' nc+ [ (ColE c, d) | c <- ordCols o | d <- ds ]+ (map ColE (refCols r)) q+ return $ TADVec qn o k r i'++ -- FIXME does flipping the direction really implement reversing of+ -- the order?+ vecReverse (TADVec q (VecOrder ds) k r i) = do+ let o' = VecOrder $ map flipDir ds+ return ( TADVec q o' k r i+ , TASVec+ )++ vecReverseS = VL.vecReverse++ vecSort sortExprs (TADVec q o k r i) = do+ let o' = VecOrder (map (const Asc) sortExprs) <> o+ -- Include the old order columns. This implements stable+ -- sorting and guarantees a strict total order of columns.+ sortCols = [ eP (oc c) (taExpr e) | c <- [1..] | e <- sortExprs ]+ +++ [ mP (oc (c + length sortExprs)) (oc c)+ | c <- [1..unOrd o]+ ]++ qe <- proj (sortCols ++ keyProj k ++ refProj r ++ itemProj i) q+ return ( TADVec qe o' k r i+ , TASVec+ )++ -- Per-segment sorting is no different from regular sorting+ -- because we require only relative per-segment order in inner+ -- vectors.+ vecSortS = VL.vecSort++ vecThetaJoin p v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 o2 k2 _ i2) = do+ let o = o1 <> o2 -- New order is defined by both left and right+ k = k1 <> k2 -- New key is defined by both left and right++ -- FIXME we should be able to statically tell that+ -- argument vectors of thetajoin do not have+ -- (non-constant) ref columns+ r = r1 -- The left vector defines the reference+ i = i1 <> i2 -- We need items from left and right++ qj <- projM (vecProj o k r i)+ $ thetaJoinM (joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qp1 <- proj (prodTransProjLeft k1 k2) qj+ qp2 <- proj (prodTransProjRight k1 k2) qj++ return ( TADVec qj o k r i+ , TARVec qp1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k)+ , TARVec qp2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k)+ )++ vecThetaJoinS p v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 o2 k2 _ i2) = do+ let o = o1 <> o2 -- New order is defined by both left and right+ k = k1 <> k2 -- New key is defined by both left and right+ r = r1 -- The left vector defines the reference+ i = i1 <> i2 -- We need items from left and right++ qj <- projM (vecProj o k r i)+ $ thetaJoinM (refJoinPred r1 ++ joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qp1 <- proj (prodTransProjLeft k1 k2) qj+ qp2 <- proj (prodTransProjRight k1 k2) qj++ return ( TADVec qj o k r i+ , TARVec qp1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k)+ , TARVec qp2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k)+ )++ vecCartProduct v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 o2 k2 _ i2) = do+ let o = o1 <> o2 -- New order is defined by both left and right+ k = k1 <> k2 -- New key is defined by both left and right++ -- FIXME we should be able to statically tell that+ -- argument vectors of thetajoin do not have+ -- (non-constant) ref columns+ r = r1 -- The left vector defines the reference+ i = i1 <> i2 -- We need items from left and right++ qj <- projM (vecProj o k r i)+ $ crossM+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qp1 <- proj (prodTransProjLeft k1 k2) qj+ qp2 <- proj (prodTransProjRight k1 k2) qj++ return ( TADVec qj o k r i+ , TARVec qp1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k)+ , TARVec qp2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k)+ )++ vecCartProductS v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 o2 k2 _ i2) = do+ let o = o1 <> o2 -- New order is defined by both left and right+ k = k1 <> k2 -- New key is defined by both left and right+ r = r1 -- The left vector defines the reference+ i = i1 <> i2 -- We need items from left and right++ qj <- projM (vecProj o k r i)+ $ thetaJoinM (refJoinPred r1)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qp1 <- proj (prodTransProjLeft k1 k2) qj+ qp2 <- proj (prodTransProjRight k1 k2) qj++ return ( TADVec qj o k r i+ , TARVec qp1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k)+ , TARVec qp2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k)+ )++ vecSemiJoin p v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 _ _ _ _) = do+ let o = o1+ k = k1+ r = r1+ i = i1++ qj <- semiJoinM (joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qf <- proj (filterProj k1) qj++ return ( TADVec qj o k r i+ , TAFVec qf (VecFilter $ unKey k1)+ )++ vecSemiJoinS p v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 _ _ _ _) = do+ let o = o1+ k = k1+ r = r1+ i = i1++ qj <- semiJoinM (refJoinPred r1 ++ joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qf <- proj (filterProj k1) qj++ return ( TADVec qj o k r i+ , TAFVec qf (VecFilter $ unKey k1)+ )++ vecAntiJoin p v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 _ _ _ _) = do+ let o = o1+ k = k1+ r = r1+ i = i1++ qj <- antiJoinM (joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qf <- proj (filterProj k1) qj++ return ( TADVec qj o k r i+ , TAFVec qf (VecFilter $ unKey k1)+ )++ vecAntiJoinS p v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 _ _ _ _) = do+ let o = o1+ k = k1+ r = r1+ i = i1++ qj <- antiJoinM (refJoinPred r1 ++ joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qf <- proj (filterProj k1) qj++ return ( TADVec qj o k r i+ , TAFVec qf (VecFilter $ unKey k1)+ )++ vecNestJoin p v1@(TADVec q1 o1 k1 _ i1) v2@(TADVec q2 o2 k2 _ i2) = do+ let o = o1 <> o2 -- New order is defined by both left and right+ k = k1 <> k2 -- New key is defined by both left and right+ r = keyRef k1 -- nesting operator: left key defines reference+ i = i1 <> i2 -- We need items from left and right++ qj <- projM (ordProj o ++ keyProj k ++ keyRefProj k1 ++ itemProj i)+ $ thetaJoinM (joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qp1 <- proj (prodTransProjLeft k1 k2) qj+ qp2 <- proj (prodTransProjRight k1 k2) qj++ return ( TADVec qj o k r i+ , TARVec qp1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k)+ , TARVec qp2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k)+ )++ vecNestJoinS p v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 o2 k2 _ i2) = do+ let o = o1 <> o2 -- New order is defined by both left and right+ k = k1 <> k2 -- New key is defined by both left and right+ r = keyRef k1 -- Nesting operator: left vector defines reference+ i = i1 <> i2 -- We need items from left and right++ qj <- thetaJoinM (refJoinPred r1 ++ joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qd <- proj (ordProj o ++ keyProj k ++ keyRefProj k1 ++ itemProj i) qj+ qp1 <- proj (prodTransProjLeft k1 k2) qj+ qp2 <- proj (prodTransProjRight k1 k2) qj++ return ( TADVec qd o k r i+ , TARVec qp1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k)+ , TARVec qp2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k)+ )++ vecNestProduct v1@(TADVec q1 o1 k1 _ i1) v2@(TADVec q2 o2 k2 _ i2) = do+ let o = o1 <> o2 -- New order is defined by both left and right+ k = k1 <> k2 -- New key is defined by both left and right+ r = keyRef k1 -- nesting operator: left key defines reference+ i = i1 <> i2 -- We need items from left and right++ qj <- projM (ordProj o ++ keyProj k ++ keyRefProj k1 ++ itemProj i)+ $ crossM (return q1) (proj (shiftAll v1 v2) q2)++ qp1 <- proj (prodTransProjLeft k1 k2) qj+ qp2 <- proj (prodTransProjRight k1 k2) qj++ return ( TADVec qj o k r i+ , TARVec qp1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k)+ , TARVec qp2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k)+ )++ vecNestProductS v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 o2 k2 _ i2) = do+ let o = o1 <> o2 -- New order is defined by both left and right+ k = k1 <> k2 -- New key is defined by both left and right+ r = keyRef k1 -- Nesting operator: left vector defines reference+ i = i1 <> i2 -- We need items from left and right++ qj <- thetaJoinM (refJoinPred r1)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qd <- proj (ordProj o ++ keyProj k ++ keyRefProj k1 ++ itemProj i) qj+ qp1 <- proj (prodTransProjLeft k1 k2) qj+ qp2 <- proj (prodTransProjRight k1 k2) qj++ return ( TADVec qd o k r i+ , TARVec qp1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k)+ , TARVec qp2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k)+ )++ vecGroupJoin p a v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 _ _ _ _) = do+ let o = o1+ k = k1+ r = r1+ i = i1 <> VecItems 1++ let acol = ic (unItems i1 + 1)+ groupCols = [ (c, ColE c)+ | c <- keyCols k1 ++ ordCols o1 ++ refCols r1 ++ itemCols i1+ ]++ let join = case a of+ VL.AggrSum _ _ -> leftOuterJoinM+ VL.AggrAny _ -> leftOuterJoinM+ VL.AggrAll _ -> leftOuterJoinM+ VL.AggrCount -> leftOuterJoinM+ VL.AggrMax _ -> thetaJoinM+ VL.AggrMin _ -> thetaJoinM+ VL.AggrAvg _ -> thetaJoinM++ qa <- projM (ordProj o ++ keyProj k ++ refProj r1 ++ itemProj i)+ $ aggrM [(aggrFunGroupJoin (unKey k1 + 1) a, acol)] groupCols+ $ join (joinPredicate i1 p)+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qd <- case a of+ VL.AggrSum t _ -> groupJoinDefault qa o k r i1 (snd $ sumDefault t)+ VL.AggrAny _ -> groupJoinDefault qa o k r i1 (bool False)+ VL.AggrAll _ -> groupJoinDefault qa o k r i1 (bool True)+ _ -> return qa++ return $ TADVec qd o k r i++ vecAggr a (TADVec q _ _ _ _) = do+ let o = VecOrder [Asc]+ k = VecKey 1+ r = VecRef 0+ i = VecItems 1++ let oneE = ConstE $ int 1++ qa <- projM [eP (oc 1) oneE, eP (kc 1) oneE, cP (ic 1)]+ $ aggr [(aggrFun a, ic 1)] [] q++ qd <- case a of+ VL.AggrSum t _ -> aggrDefault qa (snd $ sumDefault t)+ VL.AggrAll _ -> aggrDefault qa (bool True)+ VL.AggrAny _ -> aggrDefault qa (bool False)+ -- SQL COUNT handles empty inputs.+ VL.AggrCount -> return qa+ -- All other aggregates can not be handled correctly.+ _ -> return qa++ return $ TADVec qd o k r i++ vecAggrS a (TADVec qo _ k1 _ _) (TADVec qi _ _ r2 _) = do+ let o = VecOrder [Asc]+ k = VecKey 1+ r = r2+ i = VecItems 1+ -- Group the inner vector by ref.+ qa <- aggr [(aggrFun a, ic 1)] [ (c, ColE c) | c <- refCols r2 ] qi+ qd <- case a of+ VL.AggrSum t _ -> segAggrDefault qo qa k1 r2 (snd $ sumDefault t)+ VL.AggrAny _ -> segAggrDefault qo qa k1 r2 (bool False)+ VL.AggrAll _ -> segAggrDefault qo qa k1 r2 (bool True)+ VL.AggrCount -> segAggrDefault qo qa k1 r2 (int 0)+ _ ->+ projM ([cP (oc 1), mP (kc 1) (oc 1)]+ ++ refProj r+ ++ itemProj i)+ $ rownum (oc 1) (refCols r) [] qa++ return $ TADVec qd o k r i++ vecGroupAggr groupExprs aggrFuns (TADVec q _ _ _ _) = do+ let gl = length groupExprs+ let o' = VecOrder $ replicate gl Asc+ k' = VecKey gl+ r' = VecRef 0+ i' = VecItems $ length groupExprs + N.length aggrFuns++ let parts = [ eP (ic c) (taExpr e) | e <- groupExprs | c <- [1..]]++ aggrs = [ (aggrFun a, ic i) | a <- N.toList aggrFuns | i <- [gl+1..] ]++ let ordProjs = [ mP (oc c) (ic c) | c <- [1..unItems i'] ]+ keyProjs = [ mP (kc c) (ic c) | c <- [1..unItems i'] ]++ qa <- projM (ordProjs ++ keyProjs ++ itemProj i')+ $ aggr aggrs parts q++ return $ TADVec qa o' k' r' i'++ vecGroup groupExprs (TADVec q o k r i) = do+ let gl = length groupExprs+ let o1 = VecOrder (map (const Asc) groupExprs)+ k1 = VecKey gl+ r1 = VecRef 0+ i1 = VecItems gl++ let o2 = o+ k2 = k+ r2 = VecRef gl+ i2 = i++ -- Apply the grouping expressions+ let groupCols = [ gc c | c <- [1..] | _ <- groupExprs ]+ groupProj = [ eP g (taExpr ge) | g <- groupCols | ge <- groupExprs ]++ qg <- proj (vecProj o k r i ++ groupProj) q++ -- Generate the outer vector: one tuple per distinct values of+ -- the grouping columns.+ let outerKeyProj = [ mP (kc c) g | c <- [1..] | g <- groupCols ]+ outerOrdProj = [ mP (oc c) g | c <- [1..] | g <- groupCols ]+ outerItemProj = [ mP (ic c) g | c <- [1..] | g <- groupCols ]++ qo <- projM (outerOrdProj ++ outerKeyProj ++ outerItemProj)+ $ distinctM+ $ proj [ cP g | g <- groupCols ] qg++ -- Generate the inner vector that references the groups in the+ -- outer vector.+ let innerRefProj = [ mP (rc c) g | c <- [1..] | g <- groupCols ]++ qi <- proj (ordProj o ++ keyProj k ++ innerRefProj ++ itemProj i) qg++ return ( TADVec qo o1 k1 r1 i1+ , TADVec qi o2 k2 r2 i2+ , TASVec+ )++ vecGroupS groupExprs (TADVec q o k r i) = do+ let gl = length groupExprs+ let o1 = VecOrder $ replicate gl Asc+ k1 = VecKey $ unRef r + gl+ r1 = r+ i1 = VecItems gl++ let o2 = o+ k2 = k+ r2 = VecRef $ unRef r + gl+ i2 = i++ -- Apply the grouping expressions+ let groupCols = [ gc c | c <- [1..] | _ <- groupExprs ]+ groupProj = [ eP g (taExpr ge) | g <- groupCols | ge <- groupExprs ]++ qg <- proj (vecProj o k r i ++ groupProj) q++ -- Generate the outer vector: one tuple per distinct values of+ -- the ref and grouping columns.+ let outerKeyProj = [ mP (kc c) g | c <- [1..] | g <- refCols r ++ groupCols ]+ outerOrdProj = [ mP (oc c) g | c <- [1..] | g <- groupCols ]+ outerItemProj = [ mP (ic c) g | c <- [1..] | g <- groupCols ]++ qo <- projM (outerOrdProj ++ outerKeyProj ++ refProj r ++ outerItemProj)+ $ distinctM+ $ proj (refProj r ++ [ cP g | g <- groupCols ]) qg++ -- Generate the inner vector that references the groups in the+ -- outer vector.+ let innerRefProj = [ mP (rc c) g | c <- [1..] | g <- refCols r ++ groupCols ]+ qi <- proj (ordProj o ++ keyProj k ++ innerRefProj ++ itemProj i) qg++ return ( TADVec qo o1 k1 r1 i1+ , TADVec qi o2 k2 r2 i2+ , TASVec+ )++ vecAlign (TADVec q1 o1 k1 r1 i1) (TADVec q2 _ k2 _ i2) = do+ -- Join both vectors by their keys. Because this is a+ -- 1:1-join, we can discard order and ref of the right input.+ qa <- projM (ordProj o1 ++ keyProj k1 ++ refProj r1 ++ itemProj (i1 <> i2))+ $ thetaJoinM (keyJoin k1 k2)+ (return q1)+ (proj (shiftKey k1 k2 ++ shiftItems i1 i2) q2)+ return $ TADVec qa o1 k1 r1 (i1 <> i2)++ vecSelect expr (TADVec q o k r i) = do+ qs <- select (taExpr expr) q+ qr <- proj (filterProj k) qs+ return ( TADVec qs o k r i+ , TAFVec qr (VecFilter $ unKey k)+ )++ vecZip (TADVec q1 o1 k1 r1 i1) (TADVec q2 o2 k2 _ i2) = do+ let -- The result vector uses synthetic rownum-generated order+ -- and keys+ o = VecOrder [Asc]+ k = VecKey 1+ r = r1+ i = i1 <> i2++ qj <- thetaJoinM [(ColE lsoc, ColE rsoc, EqJ)]+ (rownum' lsoc (synthOrder o1) [] q1)+ (projM ([cP rsoc] ++ shiftKey k1 k2 ++ shiftItems i1 i2)+ $ rownum' rsoc (synthOrder o2) [] q2)++ let keyProj1 = [mP (dc 1) lsoc] ++ [ mP (sc c) (kc c) | c <- [1..unKey k1]]+ keyProj2 = [mP (dc 1) lsoc]+ +++ [ mP (sc c) (kc $ c + unKey k1) | c <- [1..unKey k2] ]+ qk1 <- proj keyProj1 qj+ qk2 <- proj keyProj2 qj+ qd <- proj ([mP (oc 1) lsoc, mP (kc 1) lsoc] ++ refProj r1 ++ itemProj i) qj++ return ( TADVec qd o k r i+ , TAKVec qk1 (VecTransSrc $ unKey k1) (VecTransDst 1)+ , TAKVec qk2 (VecTransSrc $ unKey k2) (VecTransDst 1)+ )++ vecZipS (TADVec q1 o1 k1 r1 i1) (TADVec q2 o2 k2 r2 i2) = do+ let -- The result vector uses synthetic rownum-generated+ -- per-segment order. As key, we can simply use the key+ -- from either left or right side. Both will retain their+ -- key property as we are doing a 1:1 join.+ o = VecOrder [Asc]+ k = k1 <> k2+ r = r1+ i = i1 <> i2++ qj <- thetaJoinM ([ (ColE lsoc, ColE rsoc, EqJ)] ++ refJoinPred r1)+ (rownum' lsoc (synthOrder o1) (map ColE $ refCols r1) q1)+ (projM ([cP rsoc] ++ shiftKey k1 k2 ++ shiftRef r1 r2 ++ shiftItems i1 i2)+ $ rownum' rsoc (synthOrder o2) (map ColE $ refCols r2) q2)++ let keyProj1 = [ mP (dc c) (kc c) | c <- [1..unKey k1] ]+ +++ [ mP (sc c) (kc c) | c <- [1..unKey k1] ]+ keyProj2 = [ mP (dc c) (kc c) | c <- [1..unKey k1] ]+ +++ [ mP (sc c) (kc $ c + unKey k1) | c <- [1..unKey k2] ]++ qk1 <- proj keyProj1 qj+ qk2 <- proj keyProj2 qj+ qd <- proj ([mP (oc 1) lsoc] ++ keyProj k ++ refProj r1 ++ itemProj i) qj++ return ( TADVec qd o k r i+ , TAKVec qk1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey k1)+ , TAKVec qk2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey k1)+ )++ vecProject exprs (TADVec q o k r _) = do+ let items = zipWith (\c e -> eP (ic c) (taExpr e)) [1..] exprs+ qp <- proj (ordProj o ++ keyProj k ++ refProj r ++ items) q+ return $ TADVec qp o k r (VecItems $ length items)++ vecTableRef tableName schema = do+ q <- projM (baseKeyProj ++ baseOrdProj ++ baseItemProj)+ $ dbTable tableName taColumns taKeys+ return $ TADVec q order key ref items++ where+ -- Columns and keys for the TA table operator+ taColumns = [ (c, algTy t)+ | (L.ColName c, t) <- N.toList $ L.tableCols schema+ ]++ taKeys = [ Key [ c | L.ColName c <- N.toList k ]+ | L.Key k <- N.toList $ L.tableKeys schema+ ]++ -- We choose one key heuristically and use it to induce order.+ baseKeyCols = chooseBaseKey (L.tableKeys schema)+ (baseKeyProj, baseOrdProj)+ = unzip [ (mP (kc i) c, mP (oc i) c)+ | i <- [1..]+ | c <- N.toList baseKeyCols+ ]+ baseItemProj = [ mP (ic i) c | i <- [1..] | (c, _) <- taColumns ]++ items = VecItems $ N.length $ L.tableCols schema+ order = VecOrder $ fmap (const Asc) $ N.toList baseKeyCols+ key = VecKey $ N.length baseKeyCols+ ref = VecRef 0++ vecLit tys vs = do+ let o = VecOrder [Asc]+ k = VecKey 1+ r = VecRef 1+ i = VecItems (length tys)+ let litSchema = [(rc 1, intT), (kc 1, intT)]+ +++ [ (ic c, algTy t) | c <- [1..] | t <- tys ]+ qr <- projM ([mP (oc 1) (kc 1), cP (kc 1), cP (rc 1)] ++ itemProj i)+ $ litTable' (map (map algVal) vs) litSchema+ return $ TADVec qr o k r i+++ vecAppend (TADVec q1 o1 k1 r1 i1) (TADVec q2 o2 k2 r2 i2) = do+ -- We have to use synthetic rownum-generated order and keys+ -- because left and right inputs might have non-compapible+ -- order and keys.++ -- Create synthetic order keys based on the original order+ -- columns and a marker column for left and right inputs.+ qs1 <- projM ([eP usc (ConstE $ VInt 1), cP soc]+ ++ ordProj o1 ++ keyProj k1 ++ refProj r1 ++ itemProj i1)+ $ rownum' soc (synthOrder o1) [] q1++ -- Generate a rekeying vector that maps old keys to+ qk1 <- proj ([mP (dc 1) usc, mP (dc 2) soc]+ +++ keySrcProj k1) qs1++ -- Generate the union input for the left side: We use the+ -- marker column together with the rownum-generated values as+ -- order and keys.+ qu1 <- proj ([mP (oc 1) usc, mP (oc 2) soc, mP (kc 1) usc, mP (kc 2) soc]+ ++ refProj r1 ++ itemProj i1)+ qs1++ -- Do the same for the right input.+ qs2 <- projM ([eP usc (ConstE $ VInt 2), cP soc]+ ++ ordProj o2 ++ keyProj k2 ++ refProj r2 ++ itemProj i2)+ $ rownum' soc (synthOrder o2) [] q2+ qk2 <- proj ([mP (dc 1) usc, mP (dc 2) soc]+ +++ keySrcProj k2) qs2++ qu2 <- proj ([mP (oc 1) usc, mP (oc 2) soc, mP (kc 2) usc, mP (kc 2) soc]+ ++ refProj r2 ++ itemProj i2)+ qs2++ -- With synthetic order and key values, both inputs are+ -- schema-compatible and can be used in a union.+ qu <- union qu1 qu2++ return ( TADVec qu (VecOrder [Asc, Asc]) (VecKey 2) r1 i1+ , TAKVec qk1 (VecTransSrc $ unKey k1) (VecTransDst 2)+ , TAKVec qk2 (VecTransSrc $ unKey k2) (VecTransDst 2)+ )++ vecAppendS (TADVec q1 o1 k1 r1 i1) (TADVec q2 o2 k2 r2 i2) = do+ -- We have to use synthetic rownum-generated order and keys+ -- because left and right inputs might have non-compapible+ -- order and keys.++ -- Create synthetic order keys based on the original order+ -- columns and a marker column for left and right+ -- inputs. Order for inner vectors might not be key+ -- (per-segment order), so we have to include the key here to+ -- avoid random results.+ qs1 <- projM ([eP usc (ConstE $ VInt 1), cP soc]+ ++ ordProj o1 ++ keyProj k1 ++ refProj r1 ++ itemProj i1)+ $ rownum' soc+ (synthOrder o1 ++ map (\c -> (ColE c, Asc)) (keyCols k1))+ []+ q1++ -- Generate a rekeying vector that maps old keys to+ qk1 <- proj ([mP (dc 1) usc, mP (dc 2) soc]+ +++ keySrcProj k1) qs1++ -- Generate the union input for the left side: We use the+ -- marker column together with the rownum-generated values as+ -- order and keys.+ qu1 <- proj ([mP (oc 1) usc, mP (oc 2) soc, mP (kc 1) usc, mP (kc 2) soc]+ ++ refProj r1 ++ itemProj i1)+ qs1++ -- Do the same for the right input.+ qs2 <- projM ([eP usc (ConstE $ VInt 2), cP soc]+ ++ ordProj o2 ++ keyProj k2 ++ refProj r2 ++ itemProj i2)+ $ rownum' soc+ (synthOrder o2 ++ map (\c -> (ColE c, Asc)) (keyCols k2))+ []+ q2+ qk2 <- proj ([mP (dc 1) usc, mP (dc 2) soc]+ +++ keySrcProj k2) qs2++ qu2 <- proj ([mP (oc 1) usc, mP (oc 2) soc, mP (kc 2) usc, mP (kc 2) soc]+ ++ refProj r2 ++ itemProj i2)+ qs2++ -- With synthetic order and key values, both inputs are+ -- schema-compatible and can be used in a union.+ qu <- union qu1 qu2++ return ( TADVec qu (VecOrder [Asc, Asc]) (VecKey 2) r1 i1+ , TAKVec qk1 (VecTransSrc $ unKey k1) (VecTransDst 2)+ , TAKVec qk2 (VecTransSrc $ unKey k2) (VecTransDst 2)+ )++ -- FIXME can we really rely on keys being aligned/compatible?+ vecCombine (TADVec qb ob kb rb _)+ (TADVec q1 _ k1 _ i1)+ (TADVec q2 _ k2 _ i2) = do++ d1 <- thetaJoinM [ (ColE $ kc c, ColE $ kc $ c + unKey kb, EqJ)+ | c <- [1..unKey k1]+ ]+ (projM (ordProj ob ++ keyProj kb ++ refProj rb)+ $ select (ColE (ic 1)) qb)+ (proj (shiftKey kb k1 ++ itemProj i1) q1)++ d2 <- thetaJoinM [ (ColE $ kc c, ColE $ kc $ c + unKey kb, EqJ)+ | c <- [1..unKey k2]+ ]+ (projM (ordProj ob ++ keyProj kb ++ refProj rb)+ $ select (UnAppE Not (ColE (ic 1))) qb)+ (proj (shiftKey kb k2 ++ itemProj i2) q2)++ qu <- unionM+ (proj (ordProj ob ++ keyProj kb ++ refProj rb ++ itemProj i1) d1)+ (proj (ordProj ob ++ keyProj kb ++ refProj rb ++ itemProj i2) d2)++ qk1 <- proj ([ mP (sc c) (kc $ c + unKey kb) | c <- [1..unKey k1] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey kb] ])+ d1++ qk2 <- proj ([ mP (sc c) (kc $ c + unKey kb) | c <- [1..unKey k2] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey kb] ])+ d2++ return ( TADVec qu ob kb rb i1+ , TAKVec qk1 (VecTransSrc $ unKey k1) (VecTransDst $ unKey kb)+ , TAKVec qk2 (VecTransSrc $ unKey k2) (VecTransDst $ unKey kb)+ )++ -- Because we only demand per-segment order for inner vectors,+ -- reordering is a NOOP in the natural key model.+ vecAppSort _ dv = return (dv, TASVec)++ vecAppFilter (TAFVec qf f) (TADVec q o k r i) = do+ let filterPred = [ (ColE c1, ColE c2, EqJ)+ | c1 <- refCols r+ | c2 <- filterCols f+ ]+ qj <- semiJoin filterPred q qf+ qf' <- proj [ mP (fc c) (kc c) | c <- [1..unKey k] ] qj++ return ( TADVec qj o k r i+ , TAFVec qf' (VecFilter $ unKey k)+ )++ vecAppRep (TARVec qr s d) (TADVec q o k r i) = do+ let o' = o+ k' = k <> (VecKey $ unDst d)+ r' = VecRef $ unDst d+ i' = i++ let s' = VecTransSrc $ unKey k+ d' = VecTransDst $ unKey k'++ let repPred = [ (ColE c1, ColE c2, EqJ)+ | c1 <- refCols r+ | c2 <- srcCols s+ ]+ qj <- thetaJoin repPred q qr++ let newKeyProj = keyProj k+ +++ [ mP (kc $ c + unKey k) (dc c)+ | c <- [1..unDst d]+ ]+ newRefProj = [ mP (rc c) (dc c) | c <- [1..unDst d] ]+ qd <- proj (ordProj o' ++ newKeyProj ++ newRefProj ++ itemProj i) qj+ qr' <- proj ([ mP (sc c) (kc c) | c <- [1..unKey k] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey k'] ])+ qd+++ return ( TADVec qd o' k' r' i'+ , TARVec qr' s' d'+ )++ vecAppKey (TAKVec qk s d) (TADVec q o k r i) = do+ let o' = o+ k' = k+ r' = VecRef $ unDst d+ i' = i++ let s' = VecTransSrc $ unKey k+ d' = VecTransDst $ unKey k++ let repPred = [ (ColE c1, ColE c2, EqJ)+ | c1 <- refCols r+ | c2 <- srcCols s+ ]+ qj <- thetaJoin repPred q qk++ let newRefProj = [ mP (rc c) (dc c) | c <- [1..unDst d] ]+ qd <- proj (ordProj o' ++ keyProj k ++ newRefProj ++ itemProj i) qj+ qr' <- proj ([ mP (sc c) (kc c) | c <- [1..unKey k] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey k] ])+ qd++ return ( TADVec qd o' k' r' i'+ , TAKVec qr' s' d'+ )++ vecUnboxKey (TADVec q _ k r _) = do+ let mapSrcProj = [ mP (sc c) (kc c) | c <- [1..unKey k] ]+ mapDstProj = [ mP (dc c) (rc c) | c <- [1..unRef r] ]++ qk <- proj (mapSrcProj ++ mapDstProj) q+ return $ TAKVec qk (VecTransSrc $ unKey k) (VecTransDst $ unRef r)++ vecSegment (TADVec q o k r i) = do+ let mapRefProj = [ mP (rc c) (kc c) | c <- [1..unKey k]]+ qo <- proj (ordProj o ++ keyProj k ++ refProj r) q+ qi <- proj (ordProj o ++ keyProj k ++ mapRefProj ++ itemProj i) q+ return ( TADVec qo o k r (VecItems 0)+ , TADVec qi o k (VecRef $ unKey k) i+ )++ vecNest (TADVec q o k _ i) = do+ qo <- litTable' [[int 1, int 1]] [(oc 1, intT), (kc 1, intT)]+ let constRef = [eP (rc 1) (ConstE (int 1))]+ qi <- proj (ordProj o ++ keyProj k ++ constRef ++ itemProj i) q+ return ( TADVec qo (VecOrder [Asc]) (VecKey 1) (VecRef 0) (VecItems 0)+ , TADVec qi o k (VecRef 1) i+ )++ vecUnboxSng v1@(TADVec q1 o1 k1 r1 i1) v2@(TADVec q2 _ k2 _ i2) = do+ let o = o1+ k = k1+ r = r1+ i = i1 <> i2++ qj <- thetaJoinM [ (ColE $ kc c, ColE $ rc $ c + unRef r1, EqJ)+ | c <- [1..unKey k]+ ]+ (return q1)+ (proj (shiftAll v1 v2) q2)++ qv <- proj (vecProj o k r i) qj+ qk <- proj ([ mP (sc c) (kc $ c + unKey k1) | c <- [1..unKey k2] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey k1] ])+ qj++ return ( TADVec qv o k r i+ , TAKVec qk (VecTransSrc $ unKey k2) (VecTransDst $ unKey k1)+ )++ vecDistSng (TADVec q1 _ k1 _ i1) (TADVec q2 o2 k2 r2 i2) = do+ let o = o2+ k = k2+ r = r2+ i = i1 <> i2++ s = VecTransSrc $ unKey k1+ d = VecTransDst $ unKey k2++ qp <- crossM+ (proj (shiftKey k2 k1 ++ itemProj i1) q1)+ (proj (ordProj o2 ++ keyProj k2 ++ refProj r2 ++ shiftItems i1 i2) q2)++ qd <- proj (ordProj o2 ++ keyProj k2 ++ refProj r2 ++ itemProj i) qp+ qr <- proj ([ mP (sc c) (kc $ c + unKey k2) | c <- [1..unKey k1] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey k2] ])+ qp++ return ( TADVec qd o k r i+ , TARVec qr s d+ )++ vecDistLift (TADVec q1 _ k1 _ i1) (TADVec q2 o2 k2 r2 i2) = do+ let o = o2+ k = k2+ r = r2+ i = i1 <> i2++ s = VecTransSrc $ unKey k1+ d = VecTransDst $ unKey k2++ qj <- thetaJoinM [ (ColE (kc $ c + unKey k2), ColE (rc c), EqJ)+ | c <- [1..unRef r2]+ ]+ (proj (shiftKey k2 k1 ++ itemProj i1) q1)+ (proj (ordProj o2 ++ keyProj k2 ++ refProj r2 ++ shiftItems i1 i2) q2)++ qd <- proj (ordProj o2 ++ keyProj k2 ++ refProj r2 ++ itemProj i) qj+ qr <- proj ([ mP (sc c) (kc $ c + unKey k2) | c <- [1..unKey k1] ]+ +++ [ mP (dc c) (kc c) | c <- [1..unKey k2] ])+ qj++ return ( TADVec qd o k r i+ , TARVec qr s d+ )
+ testsuite/Main.hs view
@@ -0,0 +1,22 @@+module Main where++import System.Environment+import Text.Printf++import Database.HDBC.ODBC++import Database.DSH.Tests+import Database.DSH.Backend.Sql++getConn :: String -> IO SqlBackend+getConn connString = sqlBackend <$> connectODBC connString++main :: IO ()+main = do+ argv <- getArgs+ case argv of+ [db] -> do+ c <- getConn (printf "DSN=%s" db)+ runTests c defaultTests+ _ ->+ error "usage: sqltests <odbc dbname>"