diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/dsh-sql.cabal b/dsh-sql.cabal new file mode 100644 --- /dev/null +++ b/dsh-sql.cabal @@ -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 diff --git a/src/Database/DSH/Backend/Sql.hs b/src/Database/DSH/Backend/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql.hs @@ -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 '-' + diff --git a/src/Database/DSH/Backend/Sql/Opt/OptimizeTA.hs b/src/Database/DSH/Backend/Sql/Opt/OptimizeTA.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/OptimizeTA.hs @@ -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 } diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Auxiliary.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Auxiliary.hs @@ -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 diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/BottomUp.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/BottomUp.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/BottomUp.hs @@ -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 diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Card1.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Card1.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Card1.hs @@ -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 + diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Cols.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Cols.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Cols.hs @@ -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 diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Const.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Const.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Const.hs @@ -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 + diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Empty.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Empty.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Empty.hs @@ -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 diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/FD.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/FD.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/FD.hs @@ -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 diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/ICols.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/ICols.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/ICols.hs @@ -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)) diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Keys.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Keys.hs @@ -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 + + diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Nullable.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Nullable.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Nullable.hs @@ -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 diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Order.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Order.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Order.hs @@ -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 + diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/TopDown.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/TopDown.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/TopDown.hs @@ -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 + + diff --git a/src/Database/DSH/Backend/Sql/Opt/Properties/Types.hs b/src/Database/DSH/Backend/Sql/Opt/Properties/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Properties/Types.hs @@ -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 diff --git a/src/Database/DSH/Backend/Sql/Opt/Rewrite/Basic.hs b/src/Database/DSH/Backend/Sql/Opt/Rewrite/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Rewrite/Basic.hs @@ -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 + diff --git a/src/Database/DSH/Backend/Sql/Opt/Rewrite/Common.hs b/src/Database/DSH/Backend/Sql/Opt/Rewrite/Common.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Opt/Rewrite/Common.hs @@ -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 diff --git a/src/Database/DSH/Backend/Sql/Vector.hs b/src/Database/DSH/Backend/Sql/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/Vector.hs @@ -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) + +-------------------------------------------------------------------------------- diff --git a/src/Database/DSH/Backend/Sql/VectorAlgebra.hs b/src/Database/DSH/Backend/Sql/VectorAlgebra.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Backend/Sql/VectorAlgebra.hs @@ -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 + ) diff --git a/testsuite/Main.hs b/testsuite/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/Main.hs @@ -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 "