diff --git a/DSH.cabal b/DSH.cabal --- a/DSH.cabal +++ b/DSH.cabal @@ -1,5 +1,5 @@ Name: DSH -Version: 0.8.2.3 +Version: 0.10.0.0 Synopsis: Database Supported Haskell Description: This is a Haskell library for database-supported program execution. Using @@ -25,25 +25,27 @@ resident data with Haskell. . Note that this package is flagged experimental and therefore is not suited - for production use. This is a proof of concept implementation only. To learn - more about DSH, our paper entitled as "Haskell Boards the Ferry: Database- - Supported Program Execution for Haskell" [1] is a recommended reading. The - package includes a couple of examples that demonstrate how to use DSH. + for production use (we mean it!). This is a proof of concept implementation + only. To learn more about DSH, our paper entitled as "Haskell Boards the Ferry: + Database-Supported Program Execution for Haskell" [1] is a recommended reading. + The package includes a couple of examples that demonstrate how to use DSH. . - The latest release implements new features described in our work-in-progress - paper entitled as "Algebraic Data Types for Language-Integrated - Queries" [3]. + In contrast to the DSH version described in [1], the current release does + not rely anymore on the loop-lifting compilation technique together with + the Pathfinder optimizer. Instead, it brings a completely rewritten query + compiler based on Guy Blelloch's flattening transformation. This approach + leads to a more robust compilation and produces more efficient query code. . - 1. + Please read the release notes in 'README.md'. . - 2. + 1. . - 3. + 2. License: BSD3 License-file: LICENSE -Author: George Giorgidze, Alexander Ulrich, Tom Schreiber, Nils Schweinsberg and Jeroen Weijers -Maintainer: giorgidze@gmail.com, jeroen.weijers@uni-tuebingen.de +Author: George Giorgidze, Alexander Ulrich, Nils Schweinsberg and Jeroen Weijers +Maintainer: alex@etc-network.de Stability: Experimental Category: Database Build-type: Simple @@ -51,37 +53,197 @@ Extra-source-files: examples/Example01.hs examples/Example02.hs examples/Example03.hs - examples/Makefile + examples/dshify-tpch.sql tests/Main.hs - tests/Makefile + tests/ComprehensionTests.hs + tests/DSHComprehensions.hs + tests/CombinatorTests.hs -Cabal-version: >= 1.4 +Cabal-version: >= 1.8 +Flag debugcomp + Description: Print debugging information for comprehension rewrites + Default: False + +Flag debuggraph + Description: Print debugging information for graph rewrites (VL, TA) + Default: False + Library - Build-depends: base >= 4.5 && < 5, - containers >= 0.4, - array >= 0.4, - bytestring >= 0.9, - template-haskell >= 2.7, + Extensions: CPP + Build-depends: base >= 4.7 && < 5, + template-haskell >= 2.9, + containers >= 0.5, mtl >= 2.1, - text >= 0.11, + bytestring >= 0.10, + text >= 1.1, HDBC >= 2.3, - HaXml >= 1.23, - csv >= 0.1, - Pathfinder >= 0.5, - FerryCore >= 0.4 + HDBC-postgresql >= 2.3, + pretty >= 1.1, + aeson >= 0.8, + kure >= 2.16, + either >= 4.0, + semigroups >= 0.16, + ansi-wl-pprint >= 0.6, + set-monad >= 0.1, + dlist >= 0.7, + algebra-dag >= 0.1, + algebra-sql >= 0.1 + Hs-source-dirs: src - GHC-options: -O3 -Wall -fno-warn-orphans + if flag(debugcomp) + CPP-Options: -DDEBUGCOMP + + if flag(debuggraph) + CPP-Options: -DDEBUGGRAPH - Exposed-modules: Database.DSH.Interpreter + GHC-Options: -Wall -fno-warn-orphans + + Exposed-modules: Database.DSH Database.DSH.Compiler - Database.DSH - Other-modules: Database.DSH.Internals - Database.DSH.Externals - Database.DSH.CSV + Other-modules: Database.DSH.Frontend.Internals + Database.DSH.Frontend.Schema + Database.DSH.Frontend.Externals + Database.DSH.Frontend.TH + Database.DSH.Frontend.TupleTypes + Database.DSH.Frontend.Funs + Database.DSH.Translate.Frontend2CL + Database.DSH.Execute.TH + Database.DSH.Execute.Sql + Database.DSH.Execute.Backend + Database.DSH.Common.Nat + Database.DSH.Common.Pretty + Database.DSH.Common.Type + Database.DSH.Common.Lang + Database.DSH.Common.QueryPlan + Database.DSH.Common.RewriteM + Database.DSH.Common.Kure + Database.DSH.Export + Database.DSH.CL.Lang + Database.DSH.CL.Kure + Database.DSH.CL.Primitives + Database.DSH.CL.Opt + Database.DSH.CL.Opt.Auxiliary + Database.DSH.CL.Opt.PostProcess + Database.DSH.CL.Opt.LoopInvariant + Database.DSH.CL.Opt.PredPushdown + Database.DSH.CL.Opt.Normalize + Database.DSH.CL.Opt.CompNormalization + Database.DSH.CL.Opt.PartialEval + Database.DSH.CL.Opt.FlatJoin + Database.DSH.CL.Opt.ThetaJoin + Database.DSH.CL.Opt.SemiJoin + Database.DSH.CL.Opt.AntiJoin + Database.DSH.CL.Opt.NestJoin + Database.DSH.CL.Opt.Resugar + Database.DSH.FKL.Lang + Database.DSH.FKL.Primitives + Database.DSH.FKL.Rewrite + Database.DSH.FKL.Kure + Database.DSH.NKL.Lang + Database.DSH.NKL.Kure + Database.DSH.NKL.Rewrite + Database.DSH.NKL.Primitives + Database.DSH.Translate.Algebra2Query + Database.DSH.Translate.CL2NKL + Database.DSH.Translate.FKL2VL + Database.DSH.Translate.NKL2FKL + Database.DSH.Translate.VL2Algebra + + Database.DSH.VL.Lang + Database.DSH.VL.Render.Dot + Database.DSH.VL.Render.JSON + Database.DSH.VL.Vector + Database.DSH.VL.VectorAlgebra + Database.DSH.VL.VectorAlgebra.TA + Database.DSH.VL.Vectorize + Database.DSH.VL.Primitives + Database.DSH.Impossible - Database.DSH.Compile - Database.DSH.TH + + Database.DSH.Optimizer.Common.Auxiliary + Database.DSH.Optimizer.Common.Rewrite + + Database.DSH.Optimizer.VL.Properties.BottomUp + Database.DSH.Optimizer.VL.Properties.Card + Database.DSH.Optimizer.VL.Properties.Common + Database.DSH.Optimizer.VL.Properties.Const + Database.DSH.Optimizer.VL.Properties.Empty + Database.DSH.Optimizer.VL.Properties.NonEmpty + Database.DSH.Optimizer.VL.Properties.ReqColumns + Database.DSH.Optimizer.VL.Properties.TopDown + Database.DSH.Optimizer.VL.Properties.Types + Database.DSH.Optimizer.VL.Properties.VectorType + + Database.DSH.Optimizer.TA.Properties.BottomUp + Database.DSH.Optimizer.TA.Properties.TopDown + Database.DSH.Optimizer.TA.Properties.Types + Database.DSH.Optimizer.TA.Properties.Cols + Database.DSH.Optimizer.TA.Properties.ICols + Database.DSH.Optimizer.TA.Properties.Use + Database.DSH.Optimizer.TA.Properties.Auxiliary + Database.DSH.Optimizer.TA.Properties.Empty + Database.DSH.Optimizer.TA.Properties.Card1 + Database.DSH.Optimizer.TA.Properties.Keys + Database.DSH.Optimizer.TA.Properties.Order + Database.DSH.Optimizer.TA.Properties.Const + Database.DSH.Optimizer.TA.Rewrite.Basic + Database.DSH.Optimizer.TA.Rewrite.Common + Database.DSH.Optimizer.TA.OptimizeTA + + Database.DSH.Optimizer.Common.Rewrite + Database.DSH.Optimizer.VL.OptimizeVL + Database.DSH.Optimizer.VL.Rewrite.Common + Database.DSH.Optimizer.VL.Rewrite.Expressions + Database.DSH.Optimizer.VL.Rewrite.PruneEmpty + Database.DSH.Optimizer.VL.Rewrite.Redundant + Database.DSH.Optimizer.VL.Rewrite.Aggregation + Database.DSH.Optimizer.VL.Rewrite.Window + Database.DSH.Optimizer.VL.Rewrite.Unused + +executable vldot + Main-is: Database/DSH/Tools/VLDotGen.hs + GHC-Options: -Wall -fno-warn-orphans + hs-source-dirs: src + build-depends: base >= 4.7 && < 5, + mtl >= 2.1, + pretty >= 1.1, + aeson >= 0.8, + containers >= 0.5, + template-haskell >= 2.9, + bytestring >= 0.10, + ansi-wl-pprint >= 0.6, + semigroups >= 0.16, + + algebra-dag >= 0.1, + algebra-sql >= 0.1 + GHC-Options: -Wall -fno-warn-orphans + +executable manual + hs-source-dirs: tests + main-is: Manual.hs + build-depends: base, DSH, HDBC-postgresql, text + ghc-options: -Wall -fno-warn-orphans + +Test-Suite Flattening_TA + type: exitcode-stdio-1.0 + Hs-Source-Dirs : tests + Main-is: Main.hs + Build-depends: base >= 4.7 && < 5, + QuickCheck >= 2.4, + containers >= 0.5, + text >= 1.1, + HDBC-postgresql >= 2.3, + HDBC >= 2.3, + test-framework-quickcheck2 >= 0.2, + test-framework-hunit >= 0.3, + test-framework >= 0.6, + HUnit >= 1.2, + + DSH >= 0.10 + cpp-options: -DTESTSQL + GHC-Options: -Wall -fno-warn-orphans + Extensions: CPP diff --git a/examples/Example01.hs b/examples/Example01.hs --- a/examples/Example01.hs +++ b/examples/Example01.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE ViewPatterns #-} +-- | Some simple example queries over (literal) integer lists. module Main where import qualified Prelude as P @@ -10,26 +11,82 @@ import Database.HDBC.PostgreSQL +-- The 'toQ' combinator constructs a query that returns a given native +-- Haskell value. ints :: Q [Integer] ints = toQ [1 .. 10] +ints2 :: Q [Integer] +ints2 = toQ $ [1..3] P.++ [7..12] + +-- Comprehensions are the main way to express queries query1 :: Q [(Integer,Integer)] query1 = [ pair i1 i2 | i1 <- ints - , i2 <- ints + , i2 <- ints2 + , i1 == i2 ] +-- Pattern matching on tuples is supported using View Patterns. query2 :: Q [(Integer,Integer)] query2 = [ pair i1 i2 | (view -> (i1,i2)) <- query1 - , i1 == i2 + , i1 > 3 ] +-- List combinators can be used freely. +query3 :: Q [(Integer, Integer)] +query3 = zip (drop 1 ints) ints + +-- Existential quantification +query4 :: Q [Integer] +query4 = [ x | x <- ints, x `elem` ints2 ] + +-- Existential quantification expressed using a boolean aggregate. +query5 :: Q [Integer] +query5 = [ x | x <- ints, or [ x == y | y <- ints2 ] ] + +-- Existential and universal quantification +query6 :: Q [Integer] +query6 = [ x | x <- ints, or [ x == y | y <- ints2 ] ] + ++ + [ x | x <- ints, and [ not $ x == y | y <- ints2 ] ] + +-- Query results may be nested. +query7 :: Q [[Integer]] +query7 = [ [ y | y <- ints, y < x ] | x <- ints2 ] + +-- Sorting +query8 :: Q [(Integer, Integer)] +query8 = take 3 $ sortWith fst $ toQ [(3,4),(5,1),(9,12),(8,3),(6,15)] + +xys :: Q [(Integer, Integer)] +xys = toQ [(3,5),(4,5),(3,8),(3,9),(5,6),(4,0)] + +-- Grouping and aggregation +query9 :: Q [(Integer, Integer)] +query9 = [ pair k (sum [ snd ge | ge <- g ]) + | (view -> (k, g)) <- groupWithKey (\xy -> fst xy) xys + ] + +-- To execute queries, a HDBC connection to a PostgreSQL database must +-- be supplied. getConn :: IO Connection -getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'" +getConn = connectPostgreSQL "user = 'au' password = 'foobar' host = 'localhost' dbname = 'test'" -runQ :: (Show a,QA a) => Q a -> IO () -runQ q = getConn P.>>= \conn -> (fromQ conn q P.>>= P.print) P.>> disconnect conn +-- Given a connection, queries are executed using the 'runQ' +-- combinator. +execQ :: (Show a,QA a) => Q a -> IO () +execQ q = getConn P.>>= \conn -> (runQ conn q P.>>= P.print) P.>> disconnect conn main :: IO () -main = runQ ints P.>> runQ query1 P.>> runQ query2 +main = execQ ints + P.>> execQ query1 + P.>> execQ query2 + P.>> execQ query3 + P.>> execQ query4 + P.>> execQ query5 + P.>> execQ query6 + P.>> execQ query7 + P.>> execQ query8 + P.>> execQ query9 diff --git a/examples/Example02.hs b/examples/Example02.hs --- a/examples/Example02.hs +++ b/examples/Example02.hs @@ -13,29 +13,56 @@ employees :: Q [(Text, Text, Integer)] employees = toQ [ ("Simon", "MS", 80) - , ("Erik", "MS", 90) - , ("Phil", "Ed", 40) - , ("Gordon", "Ed", 45) - , ("Paul", "Yale", 60) - ] + , ("Erik", "MS", 90) + , ("Phil", "Ed", 40) + , ("Gordon", "Ed", 45) + , ("Paul", "Yale", 60) + ] +dept :: Q (Text, Text, Integer) -> Q Text +dept (view -> (_, d, _)) = d + +sal :: Q (Text, Text, Integer) -> Q Integer +sal (view -> (_, _, s)) = s + +name :: Q (Text, Text, Integer) -> Q Text +name (view -> (n, _, _)) = n + +-- The duplicate-free list of departments. departments :: Q [Text] -departments = nub [ dept | (view -> (_name,dept,_salary)) <- employees] +departments = nub [ dept e | e <- employees] -deptSalary :: Q Text -> Q Integer -deptSalary dept = sum [ salary - | (view -> (_name,dept',salary)) <- employees - , dept == dept'] +-- The total salary for a given department +deptSalary :: Q Text -> Q Double +deptSalary d = avg [ sal e | e <- employees , d == dept e ] -mainQuery :: Q [(Text,Integer)] -mainQuery = [ pair dept (deptSalary dept) - | dept <- departments] +-- For each department, compute the total salary. +deptSalaries :: Q [(Text, Double)] +deptSalaries = [ pair d (deptSalary d) + | d <- departments + ] +-- Alternatively, employ the 'groupWithKey' combinator to express +-- grouping. +deptSalaries' :: Q [(Text, Double)] +deptSalaries' = [ pair d (avg [ sal ge | ge <- g ]) + | (view -> (d, g)) <- groupWithKey dept employees + ] + +-- Query with a nested result: For each department, compute the list +-- of employees. +employeesPerDept :: Q [(Text, [Text])] +employeesPerDept = [ pair d [ name e | e <- employees, dept e == d ] + | d <- departments + ] + getConn :: IO Connection -getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'" +getConn = connectPostgreSQL "user = 'au' password = 'foobar' host = 'localhost' dbname = 'test'" -runQ :: (Show a,QA a) => Q a -> IO () -runQ q = getConn P.>>= \conn -> (fromQ conn q P.>>= P.print) P.>> disconnect conn +execQ :: (Show a,QA a) => Q a -> IO () +execQ q = getConn P.>>= \conn -> (runQ conn q P.>>= P.print) P.>> disconnect conn main :: IO () -main = runQ mainQuery +main = execQ deptSalaries + P.>> execQ deptSalaries' + P.>> execQ employeesPerDept diff --git a/examples/Example03.hs b/examples/Example03.hs --- a/examples/Example03.hs +++ b/examples/Example03.hs @@ -9,6 +9,13 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +-- | A number of more complex DSH examples based on the TPC-H +-- benchmark schema. A data generator is available at +-- . Note that DSH currently does not +-- support temporal and decimal types. Those have to be mapped to +-- epoch integers and doubles, respectively. The script +-- 'examples/dshify-tpch.sql' modifies a PostgreSQL TPCH database +-- accordingly. module Main where import qualified Prelude as P @@ -17,85 +24,132 @@ import Database.HDBC.PostgreSQL -data Employee = Prof { name :: Text - , chair :: Text - , advisedStudents :: [Text] - } - | Stud { name :: Text - , topic :: Text - , advisor :: Text - } - deriving (Eq,Ord,Show) +-- | We declare a flat record type that maps to the relational +-- schema. Names of record selectors should match attribute names in +-- the schema. Note that record selectors should be listed in +-- alphabetical order. +data LineItem = LineItem + { l_comment :: Text + , l_commitdate :: Integer + , l_discount :: Double + , l_extendedprice :: Double + , l_linenumber :: Integer + , l_linestatus :: Text + , l_orderkey :: Integer + , l_partkey :: Integer + , l_quantity :: Double + , l_receiptdate :: Integer + , l_returnflag :: Text + , l_shipdate :: Integer + , l_shipinstruct :: Text + , l_shipmode :: Text + , l_suppkey :: Integer + , l_tax :: Double + } + deriving (Show) -deriveDSH ''Employee +-- A bit of Template Haskell code automatically derives instances and +-- infrastructure to use the record type in DSH queries. For each +-- record selector, we derive a variant that can be used in +-- queries. For example, we get a lifted record selector +-- 'l_commentQ :: Q LineItem -> Q Text'. +deriveDSH ''LineItem +deriveTA ''LineItem +generateTableSelectors ''LineItem -students :: Q [(Integer,Text,Text,Text)] -students = toQ [ (1,"J","P","T") - , (2,"A","Q","T") - ] +-- | The 'table' combinator implements a database table scan. +lineitems :: Q [LineItem] +lineitems = table "lineitem" $ TableHints [Key ["l_orderkey", "l_linenumber"]] NonEmpty -professors :: Q [(Integer,Text,Text)] -professors = toQ [ (0,"T","DB")] +data Order = Order + { o_clerk :: Text + , o_comment :: Text + , o_custkey :: Integer + , o_orderdate :: Integer + , o_orderkey :: Integer + , o_orderpriority :: Text + , o_orderstatus :: Text + , o_shippriority :: Integer + , o_totalprice :: Double + } + deriving (Show) -employment :: Q [(Integer,Text,Text,Integer)] -employment = toQ [ (0,"DB","professor",2008) - , (1,"DB","student",2010) - , (2,"DB","student",2011) - , (3,"PL","student",2012) - ] +deriveDSH ''Order +deriveTA ''Order +generateTableSelectors ''Order -salaries :: Q [(Integer,Integer)] -salaries = toQ [ (0,4096) - , (1,2048) - , (2,2048) - ] +orders :: Q [Order] +orders = table "orders" $ TableHints [Key ["o_orderkey"]] NonEmpty -employeesBySeniority :: Q [Employee] -employeesBySeniority = concat - [ if eStatus == "student" - then [ stud sName sTopic sAdvisor - | (view -> (sID, sName, sTopic, sAdvisor)) <- students - , eID == sID - ] - else [ prof pName pChair sAdvised - | (view -> (pID, pName, pChair)) <- professors - , eID == pID - , let sAdvised = [ sName - | (view -> (_, sName, _, sAdvisor)) <- students - , sAdvisor == pName - ] - ] - | (view -> (eID, _, eStatus, _)) <- sortWith (\(view -> (_, _, _, d)) -> d) employment - ] +-------------------------------------------------------------------------------- -safeMinimum :: (Ord a, QA a) => Q [a] -> Q (Maybe a) -safeMinimum as = if null as then nothing else just (minimum as) +-- Select all lineitems that were shipped before a given date +ordersBefore :: Q Integer -> Q [LineItem] +ordersBefore date = [ li | li <- lineitems , l_shipdateQ li <= date ] -salPerDept :: Q [(Text, [Integer])] -salPerDept = - [ pair dept [ salary - | (view -> (sID,salary)) <- salaries - , (view -> (dID,_,_,_)) <- deptMembers - , sID == dID - ] - | (view -> (dept, deptMembers)) <- groupWithKey (\(view -> (_,d,_,_)) -> d) employment - ] +fst9 :: (QA a, QA b, QA c, QA d, QA e, QA f, QA g, QA h, QA i) => Q (a, b, c, d, e, f, g, h, i) -> Q a +fst9 (view -> (a, _, _, _, _, _, _, _, _)) = a -minSalPerDept :: Q [(Text, Integer)] -minSalPerDept = [ pair dept (elim (safeMinimum sals) - 0 - (\minSal -> minSal)) - | (view -> (dept, sals)) <- salPerDept - ] +-- Compute the revenue of a single lineitem +revenue :: Q LineItem -> Q Double +revenue li = l_extendedpriceQ li * (1 - l_discountQ li) +-- TPC-H benchmark query Q1 +q1 :: Q Integer + -> Q [((Text, Text), Double, Double, Double, Double, Double, Double, Double, Integer)] +q1 maxDate = sortWith fst9 $ + [ tup9 + k + (sum $ map l_quantityQ lis) + (sum $ map l_extendedpriceQ lis) + (sum $ map revenue lis) + (sum $ map (\li -> revenue li * (1 + l_taxQ li)) lis) + (avg $ map l_quantityQ lis) + (avg $ map l_extendedpriceQ lis) + (avg $ map l_discountQ lis) + (length lis) + | (view -> (k, lis)) <- groupWithKey (\li -> pair (l_returnflagQ li) (l_linestatusQ li)) + $ ordersBefore maxDate + ] + +-------------------------------------------------------------------------------- + +data Range = Range { start :: Integer, end :: Integer } + +inside :: Q Integer -> Range -> Q Bool +inside d range = d >= toQ (start range) && d < toQ (end range) + +lineItemsOf :: Q Order -> Q [LineItem] +lineItemsOf o = [ l | l <- lineitems, + l_orderkeyQ l == o_orderkeyQ o ] + +-- Has at least one of the orders' items been delivered late? +hasLateItem :: Q Order -> Q Bool +hasLateItem o = + or [ l_commitdateQ l < l_receiptdateQ l | l <- lineItemsOf o ] + +-- Compute the number of delayed orders per priority level in the +-- given quarter (TPC-H benchmark query Q4). +q4 :: Range -> Q [(Text, Integer)] +q4 quarter = sortWith fst + [ pair priority (length delays) + | (view -> (priority, delays)) <- groupWithKey o_orderpriorityQ delayedOrders ] + where + delayedOrders = [ o | o <- orders + , o_orderdateQ o `inside` quarter + , hasLateItem o + ] + +-------------------------------------------------------------------------------- + getConn :: IO Connection -getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'" +getConn = connectPostgreSQL "user = 'au' password = 'foobar' host = 'localhost' dbname = 'tpchsmall'" -runQ :: (Show a,QA a) => Q a -> IO () -runQ q = getConn P.>>= \conn -> (fromQ conn q P.>>= P.print) P.>> disconnect conn +execQ :: (Show a,QA a) => Q a -> IO () +execQ q = getConn P.>>= \conn -> (runQ conn q P.>>= P.print) P.>> disconnect conn main :: IO () -main = sequence_ [ runQ employeesBySeniority - , runQ salPerDept - , runQ minSalPerDept +main = sequence_ [ execQ $ q1 904663977 + -- Compute Q4 for a three-month interval + , execQ (q4 $ Range 741540777 749489577) ] diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 --- a/examples/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -all: clean - ghc -Wall -O3 --make Example01.hs - ghc -Wall -O3 --make Example02.hs - ghc -Wall -O3 --make Example03.hs - rm -rf *.hi *.o - -clean: - rm -rf *.hi *.o Example01 Example02 Example03 diff --git a/examples/dshify-tpch.sql b/examples/dshify-tpch.sql new file mode 100644 --- /dev/null +++ b/examples/dshify-tpch.sql @@ -0,0 +1,19 @@ +alter table supplier alter column s_acctbal type real; + +alter table lineitem alter column l_acctbal type real; + +alter table customer alter column c_acctbal type real; + +alter table lineitem alter column l_quantity type real; +alter table lineitem alter column l_extendedprice type real; +alter table lineitem alter column l_discount type real; +alter table lineitem alter column l_tax type real; + +alter table orders alter column o_totalprice type real; +alter table orders alter column o_orderdate type int using extract(epoch from o_orderdate); + +alter table lineitem alter column l_shipdate type int using extract(epoch from l_shipdate); +alter table lineitem alter column l_commitdate type int using extract(epoch from l_commitdate); +alter table lineitem alter column l_receiptdate type int using extract(epoch from l_receiptdate); + +alter table part alter column p_retailprice type real; diff --git a/src/Database/DSH.hs b/src/Database/DSH.hs --- a/src/Database/DSH.hs +++ b/src/Database/DSH.hs @@ -1,4 +1,4 @@ --- | +-- | -- This module is intended to be imported @qualified@, to avoid name clashes -- with "Prelude" functions. For example: -- @@ -14,9 +14,9 @@ -- by Database.DSH. module Database.DSH - ( module Database.DSH.Externals - , Q, QA, TA, Elim, elim, View, view - , module Database.DSH.TH + ( module Database.DSH.Frontend.Externals + , Q, QA, TA, Elim, elim, View, view, Key(..), TableHints(..), Emptiness(..) + , module Database.DSH.Frontend.TH , module Data.String , module Data.Text , module Database.HDBC @@ -24,9 +24,9 @@ ) where -import Database.DSH.Externals -import Database.DSH.Internals (Q,QA,TA,Elim,elim,View,view) -import Database.DSH.TH +import Database.DSH.Frontend.Externals +import Database.DSH.Frontend.Internals (Q,QA,TA,Elim,elim,View,view,Key(..),TableHints(..), Emptiness(..)) +import Database.DSH.Frontend.TH import Data.String (IsString,fromString) import Data.Text (Text) @@ -35,12 +35,13 @@ not , (&&) , (||) - , (==) - , (/=) + , (==) , (/=) , (<) , (<=) , (>=) , (>) + , (++) + , mod , min , max , head @@ -86,4 +87,5 @@ , return , (>>=) , (>>) + , div ) diff --git a/src/Database/DSH/CL/Kure.hs b/src/Database/DSH/CL/Kure.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Kure.hs @@ -0,0 +1,461 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE InstanceSigs #-} + +-- | Infrastructure for KURE-based rewrites on CL expressions + +module Database.DSH.CL.Kure + ( -- * Re-export relevant KURE modules + module Language.KURE + , module Language.KURE.Lens + + -- * The KURE monad + , RewriteM, RewriteStateM, TransformC, RewriteC, LensC, freshName, freshNameT + + -- * Setters and getters for the translation state + , get, put, modify + + -- * Changing between stateful and non-stateful transforms + , statefulT, liftstateT + + -- * The KURE context + , CompCtx(..), CrumbC(..), PathC, initialCtx, freeIn, boundIn + , inScopeNames, bindQual, bindVar, withLocalPathT + + -- * Congruence combinators + , tableT, appe1T, appe2T, binopT, ifT, litT, varT, compT, letT + , tableR, appe1R, appe2R, binopR, ifR, litR, varR, compR, letR + , unopR, unopT + , bindQualT, guardQualT, bindQualR, guardQualR + , qualsT, qualsR, qualsemptyT, qualsemptyR + + -- * The sum type + , CL(..) + ) where + + +import Control.Monad +import Data.Monoid +import qualified Data.Map as M +import qualified Data.Foldable as F +import Text.PrettyPrint.ANSI.Leijen(text) + +import Language.KURE +import Language.KURE.Lens + +import Database.DSH.Common.Pretty +import qualified Database.DSH.Common.Lang as L +import Database.DSH.Common.RewriteM +import Database.DSH.CL.Lang + +-------------------------------------------------------------------------------- +-- Convenience type aliases + +type TransformC a b = Transform CompCtx (RewriteM Int) a b +type RewriteC a = TransformC a a +type LensC a b = Lens CompCtx (RewriteM Int) a b + +-------------------------------------------------------------------------------- + +data CrumbC = AppFun + | AppArg + | AppE1Arg + | AppE2Arg1 + | AppE2Arg2 + | BinOpArg1 + | BinOpArg2 + | UnOpArg + | LamBody + | IfCond + | IfThen + | IfElse + | CompHead + | CompQuals + | BindQualExpr + | GuardQualExpr + | QualsHead + | QualsTail + | QualsSingleton + | NLConsTail + -- One-based index into the list of element expressions + | TupleElem Int + | LetBind + | LetBody + deriving (Eq, Show) + +instance Pretty CrumbC where + pretty c = text $ show c + +type AbsPathC = AbsolutePath CrumbC + +type PathC = Path CrumbC + +-- | The context for KURE-based CL rewrites +data CompCtx = CompCtx { cl_bindings :: M.Map L.Ident Type + , cl_path :: AbsPathC + } + +instance ExtendPath CompCtx CrumbC where + c@@n = c { cl_path = cl_path c @@ n } + +instance ReadPath CompCtx CrumbC where + absPath c = cl_path c + +initialCtx :: CompCtx +initialCtx = CompCtx { cl_bindings = M.empty, cl_path = mempty } + +-- | Record a variable binding in the context +bindVar :: L.Ident -> Type -> CompCtx -> CompCtx +bindVar n ty ctx = ctx { cl_bindings = M.insert n ty (cl_bindings ctx) } + +-- | If the qualifier represents a generator, bind the variable in the context. +bindQual :: CompCtx -> Qual -> CompCtx +bindQual ctx (BindQ n e) = bindVar n (elemT $ typeOf e) ctx +bindQual ctx _ = ctx + +inScopeNames :: CompCtx -> [L.Ident] +inScopeNames = M.keys . cl_bindings + +boundIn :: L.Ident -> CompCtx -> Bool +boundIn n ctx = n `M.member` (cl_bindings ctx) + +freeIn :: L.Ident -> CompCtx -> Bool +freeIn n ctx = n `M.notMember` (cl_bindings ctx) + +-- | Generate a fresh name that is not bound in the current context. +freshNameT :: [L.Ident] -> TransformC a L.Ident +freshNameT avoidNames = do + ctx <- contextT + constT $ freshName (avoidNames ++ inScopeNames ctx) + +-- | Perform a transform with an empty path, i.e. a path starting from +-- the current node. +withLocalPathT :: Monad m => Transform CompCtx m a b -> Transform CompCtx m a b +withLocalPathT t = transform $ \c a -> applyT t (c { cl_path = SnocPath [] }) a + +-------------------------------------------------------------------------------- +-- Support for stateful transforms + +-- | Run a stateful transform with an initial state and turn it into a regular +-- (non-stateful) transform +statefulT :: s -> Transform CompCtx (RewriteStateM s) a b -> TransformC a (s, b) +statefulT s t = resultT (stateful s) t + +-- | Turn a regular rewrite into a stateful rewrite +liftstateT :: Transform CompCtx (RewriteM Int) a b -> Transform CompCtx (RewriteStateM s) a b +liftstateT t = resultT liftstate t + +-------------------------------------------------------------------------------- +-- Congruence combinators for CL expressions + +tableT :: Monad m => (Type -> String -> [L.Column] -> L.TableHints -> b) + -> Transform CompCtx m Expr b +tableT f = contextfreeT $ \expr -> case expr of + Table ty n cs hs -> return $ f ty n cs hs + _ -> fail "not a table node" +{-# INLINE tableT #-} + +tableR :: Monad m => Rewrite CompCtx m Expr +tableR = tableT Table +{-# INLINE tableR #-} + +appe1T :: Monad m => Transform CompCtx m Expr a + -> (Type -> Prim1 -> a -> b) + -> Transform CompCtx m Expr b +appe1T t f = transform $ \c expr -> case expr of + AppE1 ty p e -> f ty p <$> applyT t (c@@AppE1Arg) e + _ -> fail "not a unary primitive application" +{-# INLINE appe1T #-} + +appe1R :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Expr +appe1R t = appe1T t AppE1 +{-# INLINE appe1R #-} + +appe2T :: Monad m => Transform CompCtx m Expr a1 + -> Transform CompCtx m Expr a2 + -> (Type -> Prim2 -> a1 -> a2 -> b) + -> Transform CompCtx m Expr b +appe2T t1 t2 f = transform $ \c expr -> case expr of + AppE2 ty p e1 e2 -> f ty p <$> applyT t1 (c@@AppE2Arg1) e1 + <*> applyT t2 (c@@AppE2Arg2) e2 + _ -> fail "not a binary primitive application" +{-# INLINE appe2T #-} + +appe2R :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Expr -> Rewrite CompCtx m Expr +appe2R t1 t2 = appe2T t1 t2 AppE2 +{-# INLINE appe2R #-} + +binopT :: Monad m => Transform CompCtx m Expr a1 + -> Transform CompCtx m Expr a2 + -> (Type -> L.ScalarBinOp -> a1 -> a2 -> b) + -> Transform CompCtx m Expr b +binopT t1 t2 f = transform $ \c expr -> case expr of + BinOp ty op e1 e2 -> f ty op <$> applyT t1 (c@@BinOpArg1) e1 + <*> applyT t2 (c@@BinOpArg2) e2 + _ -> fail "not a binary operator application" +{-# INLINE binopT #-} + +binopR :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Expr -> Rewrite CompCtx m Expr +binopR t1 t2 = binopT t1 t2 BinOp +{-# INLINE binopR #-} + +unopT :: Monad m => Transform CompCtx m Expr a + -> (Type -> L.ScalarUnOp -> a -> b) + -> Transform CompCtx m Expr b +unopT t f = transform $ \ctx expr -> case expr of + UnOp ty op e -> f ty op <$> applyT t (ctx@@UnOpArg) e + _ -> fail "not an unary operator application" +{-# INLINE unopT #-} + +unopR :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Expr +unopR t = unopT t UnOp +{-# INLINE unopR #-} + +ifT :: Monad m => Transform CompCtx m Expr a1 + -> Transform CompCtx m Expr a2 + -> Transform CompCtx m Expr a3 + -> (Type -> a1 -> a2 -> a3 -> b) + -> Transform CompCtx m Expr b +ifT t1 t2 t3 f = transform $ \c expr -> case expr of + If ty e1 e2 e3 -> f ty <$> applyT t1 (c@@IfCond) e1 + <*> applyT t2 (c@@IfThen) e2 + <*> applyT t3 (c@@IfElse) e3 + _ -> fail "not an if expression" +{-# INLINE ifT #-} + +ifR :: Monad m => Rewrite CompCtx m Expr + -> Rewrite CompCtx m Expr + -> Rewrite CompCtx m Expr + -> Rewrite CompCtx m Expr +ifR t1 t2 t3 = ifT t1 t2 t3 If +{-# INLINE ifR #-} + +litT :: Monad m => (Type -> L.Val -> b) -> Transform CompCtx m Expr b +litT f = contextfreeT $ \expr -> case expr of + Lit ty v -> return $ f ty v + _ -> fail "not a constant" +{-# INLINE litT #-} + +litR :: Monad m => Rewrite CompCtx m Expr +litR = litT Lit +{-# INLINE litR #-} + +varT :: Monad m => (Type -> L.Ident -> b) -> Transform CompCtx m Expr b +varT f = contextfreeT $ \expr -> case expr of + Var ty n -> return $ f ty n + _ -> fail "not a variable" +{-# INLINE varT #-} + +varR :: Monad m => Rewrite CompCtx m Expr +varR = varT Var +{-# INLINE varR #-} + +compT :: Monad m => Transform CompCtx m Expr a1 + -> Transform CompCtx m (NL Qual) a2 + -> (Type -> a1 -> a2 -> b) + -> Transform CompCtx m Expr b +compT t1 t2 f = transform $ \ctx expr -> case expr of + Comp ty e qs -> f ty <$> applyT t1 (F.foldl' bindQual (ctx@@CompHead) qs) e + <*> applyT t2 (ctx@@CompQuals) qs + _ -> fail "not a comprehension" +{-# INLINE compT #-} + +compR :: Monad m => Rewrite CompCtx m Expr + -> Rewrite CompCtx m (NL Qual) + -> Rewrite CompCtx m Expr +compR t1 t2 = compT t1 t2 Comp +{-# INLINE compR #-} + +mkTupleT :: Monad m => Transform CompCtx m Expr a + -> (Type -> [a] -> b) + -> Transform CompCtx m Expr b +mkTupleT t f = transform $ \c expr -> case expr of + MkTuple ty es -> f ty <$> zipWithM (\e i -> applyT t (c@@TupleElem i) e) es [1..] + _ -> fail "not a tuple constructor" +{-# INLINE mkTupleT #-} + +mkTupleR :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Expr +mkTupleR r = mkTupleT r MkTuple + +letT :: Monad m => Transform CompCtx m Expr a1 + -> Transform CompCtx m Expr a2 + -> (Type -> L.Ident -> a1 -> a2 -> b) + -> Transform CompCtx m Expr b +letT t1 t2 f = transform $ \c expr -> case expr of + Let ty x xs e -> f ty x <$> applyT t1 (c@@LetBind) xs + <*> applyT t2 (bindVar x (typeOf xs) $ c@@LetBody) e + _ -> fail "not a let expression" + +letR :: Monad m => Rewrite CompCtx m Expr + -> Rewrite CompCtx m Expr + -> Rewrite CompCtx m Expr +letR r1 r2 = letT r1 r2 Let + +-------------------------------------------------------------------------------- +-- Congruence combinators for qualifiers + +bindQualT :: Monad m => Transform CompCtx m Expr a + -> (L.Ident -> a -> b) + -> Transform CompCtx m Qual b +bindQualT t f = transform $ \ctx expr -> case expr of + BindQ n e -> f n <$> applyT t (ctx@@BindQualExpr) e + _ -> fail "not a generator" +{-# INLINE bindQualT #-} + +bindQualR :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Qual +bindQualR t = bindQualT t BindQ +{-# INLINE bindQualR #-} + +guardQualT :: Monad m => Transform CompCtx m Expr a + -> (a -> b) + -> Transform CompCtx m Qual b +guardQualT t f = transform $ \ctx expr -> case expr of + GuardQ e -> f <$> applyT t (ctx@@GuardQualExpr) e + _ -> fail "not a guard" +{-# INLINE guardQualT #-} + +guardQualR :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Qual +guardQualR t = guardQualT t GuardQ +{-# INLINE guardQualR #-} + +-------------------------------------------------------------------------------- +-- Congruence combinator for a qualifier list + +qualsT :: Monad m => Transform CompCtx m Qual a1 + -> Transform CompCtx m (NL Qual) a2 + -> (a1 -> a2 -> b) + -> Transform CompCtx m (NL Qual) b +qualsT t1 t2 f = transform $ \ctx quals -> case quals of + q :* qs -> f <$> applyT t1 (ctx@@QualsHead) q + <*> applyT t2 (bindQual (ctx@@QualsTail) q) qs + S _ -> fail "not a nonempty cons" +{-# INLINE qualsT #-} + +qualsR :: Monad m => Rewrite CompCtx m Qual + -> Rewrite CompCtx m (NL Qual) + -> Rewrite CompCtx m (NL Qual) +qualsR t1 t2 = qualsT t1 t2 (:*) +{-# INLINE qualsR #-} + + +qualsemptyT :: Monad m => Transform CompCtx m Qual a + -> (a -> b) + -> Transform CompCtx m (NL Qual) b +qualsemptyT t f = transform $ \ctx quals -> case quals of + S q -> f <$> applyT t (ctx@@QualsSingleton) q + _ -> fail "not a nonempty singleton" +{-# INLINE qualsemptyT #-} + +qualsemptyR :: Monad m => Rewrite CompCtx m Qual + -> Rewrite CompCtx m (NL Qual) +qualsemptyR t = qualsemptyT t S +{-# INLINE qualsemptyR #-} + +-------------------------------------------------------------------------------- + +-- | The sum type of *nodes* considered for KURE traversals +data CL = ExprCL Expr + | QualCL Qual + | QualsCL (NL Qual) + +instance Pretty CL where + pretty (ExprCL e) = pretty e + pretty (QualCL q) = pretty q + pretty (QualsCL qs) = pretty qs + +instance Injection Expr CL where + inject = ExprCL + + project (ExprCL expr) = Just expr + project _ = Nothing + +instance Injection Qual CL where + inject = QualCL + + project (QualCL q) = Just q + project _ = Nothing + +instance Injection (NL Qual) CL where + inject = QualsCL + + project (QualsCL qs) = Just qs + project _ = Nothing + + +-- FIXME putting an INLINE pragma on allR would propably lead to good +-- things. However, with 7.6.3 it triggers a GHC panic. +instance Walker CompCtx CL where + allR :: forall m. MonadCatch m => Rewrite CompCtx m CL -> Rewrite CompCtx m CL + allR r = + rewrite $ \c cl -> case cl of + ExprCL expr -> inject <$> applyT allRexpr c expr + QualCL q -> inject <$> applyT allRqual c q + QualsCL qs -> inject <$> applyT allRquals c qs + + where + allRquals = readerT $ \qs -> case qs of + S{} -> qualsemptyR (extractR r) + (:*){} -> qualsR (extractR r) (extractR r) + {-# INLINE allRquals #-} + + allRqual = readerT $ \q -> case q of + GuardQ{} -> guardQualR (extractR r) + BindQ{} -> bindQualR (extractR r) + {-# INLINE allRqual #-} + + allRexpr = readerT $ \e -> case e of + Table{} -> idR + AppE1{} -> appe1R (extractR r) + AppE2{} -> appe2R (extractR r) (extractR r) + BinOp{} -> binopR (extractR r) (extractR r) + UnOp{} -> unopR (extractR r) + If{} -> ifR (extractR r) (extractR r) (extractR r) + Lit{} -> idR + Var{} -> idR + Comp{} -> compR (extractR r) (extractR r) + MkTuple{} -> mkTupleR (extractR r) + Let{} -> letR (extractR r) (extractR r) + {-# INLINE allRexpr #-} + +-------------------------------------------------------------------------------- +-- A Walker instance for qualifier lists so that we can use the +-- traversal infrastructure on lists. + +consT :: Monad m => Transform CompCtx m (NL Qual) b + -> (Qual -> b -> c) + -> Transform CompCtx m (NL Qual) c +consT t f = transform $ \ctx nl -> case nl of + a :* as -> f a <$> applyT t (bindQual (ctx@@NLConsTail) a) as + S _ -> fail "not a nonempty cons" +{-# INLINE consT #-} + +consR :: Monad m => Rewrite CompCtx m (NL Qual) + -> Rewrite CompCtx m (NL Qual) +consR t = consT t (:*) +{-# INLINE consR #-} + +singletonT :: Monad m => (Qual -> c) + -> Transform CompCtx m (NL Qual) c +singletonT f = contextfreeT $ \nl -> case nl of + S a -> return $ f a + _ :* _ -> fail "not a nonempty singleton" +{-# INLINE singletonT #-} + +singletonR :: Monad m => Rewrite CompCtx m (NL Qual) +singletonR = singletonT S +{-# INLINE singletonR #-} + +instance Walker CompCtx (NL Qual) where + allR r = consR r <+ singletonR + +-------------------------------------------------------------------------------- +-- I find it annoying that Applicative is not a superclass of Monad. + +(<$>) :: Monad m => (a -> b) -> m a -> m b +(<$>) = liftM +{-# INLINE (<$>) #-} + +(<*>) :: Monad m => m (a -> b) -> m a -> m b +(<*>) = ap +{-# INLINE (<*>) #-} diff --git a/src/Database/DSH/CL/Lang.hs b/src/Database/DSH/CL/Lang.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Lang.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} + +module Database.DSH.CL.Lang + ( module Database.DSH.Common.Type + , Expr(..) + , NL(..), reverseNL, toList, fromList, fromListSafe, appendNL, toNonEmpty + , Qual(..), isGuard, isBind + , Typed(..) + , Prim1(..) + , Prim2(..) + ) where + +import Control.Applicative hiding (empty) + +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import Data.List.NonEmpty (NonEmpty((:|))) + +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) +import qualified Text.PrettyPrint.ANSI.Leijen as PP +import Text.Printf + +import Database.DSH.Common.Nat +import qualified Database.DSH.Common.Lang as L +import Database.DSH.Common.Type +import Database.DSH.Common.Pretty +import Database.DSH.Impossible + +-------------------------------------------------------------------------------- +-- A simple type of nonempty lists, used for comprehension +-- qualifiers. This type is used instead of Data.List.NonEmpty to have +-- a proper list spine for which Kure traversals can be defined +-- easily. + +data NL a = a :* (NL a) + | S a + deriving (Eq, Ord) + +infixr :* + +instance Show a => Show (NL a) where + show = show . toList + +instance Pretty a => Pretty (NL a) where + pretty = pretty . toList + +instance Functor NL where + fmap f (a :* as) = (f a) :* (fmap f as) + fmap f (S a) = S (f a) + +instance F.Foldable NL where + foldr f z (a :* as) = f a (F.foldr f z as) + foldr f z (S a) = f a z + +instance T.Traversable NL where + traverse f (a :* as) = (:*) <$> (f a) <*> (T.traverse f as) + traverse f (S a) = S <$> (f a) + +toList :: NL a -> [a] +toList (a :* as) = a : toList as +toList (S a) = [a] + +fromList :: [a] -> Maybe (NL a) +fromList [] = Nothing +fromList as = Just $ aux as + where + aux :: [a] -> NL a + aux (x : []) = S x + aux (x : xs) = x :* aux xs + aux [] = $impossible + +fromListSafe :: a -> [a] -> NL a +fromListSafe a [a1] = a :* S a1 +fromListSafe a [] = S a +fromListSafe a (a1 : as) = a :* fromListSafe a1 as + +toNonEmpty :: NL a -> NonEmpty a +toNonEmpty (a :* as) = a :| toList as +toNonEmpty (S a) = a :| [] + +reverseNL :: NL a -> NL a +reverseNL (a :* as) = F.foldl (flip (:*)) (S a) as +reverseNL (S a) = S a + +appendNL :: NL a -> NL a -> NL a +appendNL (a :* as) bs = a :* appendNL as bs +appendNL (S a) bs = a :* bs + +-------------------------------------------------------------------------------- +-- CL primitives + +data Prim1 = Singleton + | Length + | Concat + | Null + | Sum + | Avg + | The + | Head + | Tail + | Minimum + | Maximum + | Reverse + | And + | Or + | Init + | Last + | Nub + | Number + | Guard + | Reshape Integer + | Transpose + | TupElem TupleIndex + deriving (Eq) + +instance Show Prim1 where + show Singleton = "sng" + show Length = "length" + show Concat = "concat" + show Null = "null" + show Sum = "sum" + show Avg = "avg" + show The = "the" + show Head = "head" + show Minimum = "minimum" + show Maximum = "maximum" + show Tail = "tail" + show Reverse = "reverse" + show And = "and" + show Or = "or" + show Init = "init" + show Last = "last" + show Nub = "nub" + show Number = "number" + show Guard = "guard" + show Transpose = "transpose" + show (Reshape n) = printf "reshape(%d)" n + -- tuple access is pretty-printed in a special way + show TupElem{} = $impossible + +data Prim2 = Sort + | Group + | Append + | Index + | Zip + | CartProduct + | NestProduct + | ThetaJoin (L.JoinPredicate L.JoinExpr) + | NestJoin (L.JoinPredicate L.JoinExpr) + | SemiJoin (L.JoinPredicate L.JoinExpr) + | AntiJoin (L.JoinPredicate L.JoinExpr) + deriving (Eq) + +instance Show Prim2 where + show Group = "group" + show Sort = "sort" + show Append = "append" + show Index = "index" + show Zip = "zip" + show CartProduct = "⨯" + show NestProduct = "▽" + show (ThetaJoin p) = printf "⨝_%s" (pp p) + show (NestJoin p) = printf "△_%s" (pp p) + show (SemiJoin p) = printf "⋉_%s" (pp p) + show (AntiJoin p) = printf "▷_%s" (pp p) + +-------------------------------------------------------------------------------- +-- CL expressions + +data Qual = BindQ L.Ident Expr + | GuardQ Expr + deriving (Eq, Show) + +isGuard :: Qual -> Bool +isGuard (GuardQ _) = True +isGuard (BindQ _ _) = False + +isBind :: Qual -> Bool +isBind (GuardQ _) = False +isBind (BindQ _ _) = True + +data Expr = Table Type String [L.Column] L.TableHints + | AppE1 Type Prim1 Expr + | AppE2 Type Prim2 Expr Expr + | BinOp Type L.ScalarBinOp Expr Expr + | UnOp Type L.ScalarUnOp Expr + | If Type Expr Expr Expr + | Lit Type L.Val + | Var Type L.Ident + | Comp Type Expr (NL Qual) + | MkTuple Type [Expr] + | Let Type L.Ident Expr Expr + deriving (Show) + +instance Pretty Expr where + pretty (AppE1 _ (TupElem n) e1) = + parenthize e1 <> dot <> int (tupleIndex n) + pretty (MkTuple _ es) = tupled $ map pretty es + pretty (Table _ n _ _) = text "table" <> parens (text n) + pretty (AppE1 _ p1 e) = (text $ show p1) <+> (parenthize e) + pretty (AppE2 _ p1 e1@(Comp _ _ _) e2) = (text $ show p1) <+> (align $ (parenthize e1) PP.<$> (parenthize e2)) + pretty (AppE2 _ p1 e1 e2@(Comp _ _ _)) = (text $ show p1) <+> (align $ (parenthize e1) PP.<$> (parenthize e2)) + pretty (AppE2 _ p1 e1 e2) = (text $ show p1) <+> (align $ (parenthize e1) (parenthize e2)) + pretty (BinOp _ o e1 e2) = (parenthize e1) <+> (pretty o) <+> (parenthize e2) + pretty (UnOp _ o e) = pretty o <> parens (pretty e) + pretty (If _ c t e) = text "if" + <+> pretty c + <+> text "then" + <+> (parenthize t) + <+> text "else" + <+> (parenthize e) + pretty (Lit _ v) = pretty v + pretty (Var _ s) = text s + + pretty (Comp _ e qs) = encloseSep lbracket rbracket empty docs + where docs = (char ' ' <> pretty e <> char ' ') : qsDocs + qsDocs = + case qs of + q :* qs' -> (char '|' <+> pretty q) + : [ char ',' <+> pretty q' | q' <- toList qs' ] + + S q -> [char '|' <+> pretty q] + pretty (Let _ x e1 e) = + align $ text "let" <+> text x <+> char '=' <+> pretty e1 + + text "in" <+> pretty e + +parenthize :: Expr -> Doc +parenthize e = + case e of + Var _ _ -> pretty e + Lit _ _ -> pretty e + Table _ _ _ _ -> pretty e + Comp _ _ _ -> pretty e + AppE1 _ (TupElem _) _ -> pretty e + _ -> parens $ pretty e + +instance Pretty Qual where + pretty (BindQ i e) = text i <+> text "<-" <+> pretty e + pretty (GuardQ e) = pretty e + +-- Binary relational operators are pretty-printed different from other +-- combinators +isRelOp :: Prim2 -> Bool +isRelOp o = + case o of + ThetaJoin _ -> True + NestJoin _ -> True + SemiJoin _ -> True + AntiJoin _ -> True + _ -> False + + + +deriving instance Eq Expr + +instance Typed Expr where + typeOf (Table t _ _ _) = t + typeOf (AppE1 t _ _) = t + typeOf (AppE2 t _ _ _) = t + typeOf (If t _ _ _) = t + typeOf (BinOp t _ _ _) = t + typeOf (UnOp t _ _) = t + typeOf (Lit t _) = t + typeOf (Var t _) = t + typeOf (Comp t _ _) = t + typeOf (MkTuple t _) = t + typeOf (Let t _ _ _) = t + + diff --git a/src/Database/DSH/CL/Opt.hs b/src/Database/DSH/CL/Opt.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt.hs @@ -0,0 +1,114 @@ +-- | This module performs optimizations on the Comprehension Language +-- (CL). +module Database.DSH.CL.Opt + ( optimizeComprehensions + ) where + +import Control.Arrow + +import Database.DSH.Common.Kure + +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang + +import Database.DSH.CL.Opt.Auxiliary +import Database.DSH.CL.Opt.CompNormalization +import Database.DSH.CL.Opt.FlatJoin +import Database.DSH.CL.Opt.LoopInvariant +import Database.DSH.CL.Opt.NestJoin +import Database.DSH.CL.Opt.Normalize +import Database.DSH.CL.Opt.PartialEval +import Database.DSH.CL.Opt.PostProcess +import Database.DSH.CL.Opt.PredPushdown +import Database.DSH.CL.Opt.Resugar + +-------------------------------------------------------------------------------- +-- Rewrite Strategy: Rule Groups + +-- | Comprehension normalization rules 1 to 3. +compNormEarlyR :: RewriteC CL +compNormEarlyR = m_norm_1R + <+ m_norm_2R + <+ m_norm_3R + -- Does not lead to good code. See lablog entry (24.11.2014) + -- <+ invariantguardR + <+ ifgeneratorR + <+ identityCompR + +-- | Comprehension normalization rules 4 and 5. Beware: these rewrites +-- should propably occur late in the chain, as they might prohibit +-- semijoin/antijoin introduction +compNormLateR :: RewriteC CL +compNormLateR = m_norm_4R <+ m_norm_5R + +-- | Nestjoin/Nestproduct rewrites are applied bottom-up. Innermost +-- nesting opportunities must be dealt with first in order to produce +-- trees of nesting operators. +buUnnestR :: RewriteC CL +buUnnestR = + zipCorrelatedR + <+ repeatR nestjoinR + -- If the inverse M-Norm-3 succeeds, try to unnest the new + -- generator + <+ (nestingGenR >>> pathR [CompQuals, QualsSingleton, BindQualExpr] nestjoinR) + +-- | Normalize unnested comprehensions. To avoid nested iterators +-- after desugaring whenever possible, consecutive generators that do +-- not depend on each other are mapped to cartesian products. After +-- that, we try to push guards down into product inputs. +postProcessCompR :: RewriteC CL +postProcessCompR = do + ExprCL Comp{} <- idR + (guardpushbackR + >+> repeatR introduceCartProductsR + >+> repeatR predpushdownR) + +postProcessR :: RewriteC CL +postProcessR = repeatR $ anybuR postProcessCompR + +-------------------------------------------------------------------------------- +-- Rewrite Strategy + +-- | Perform a top-down traversal of a query expression, looking for +-- rewrite opportunities on comprehensions and other expressions. +descendR :: RewriteC CL +descendR = readerT $ \cl -> case cl of + + ExprCL Comp{} -> optCompR + + -- On non-comprehensions, try to apply partial evaluation rules + -- before descending + ExprCL _ -> repeatR partialEvalR + >+> repeatR normalizeExprR + >+> anyR descendR + + -- We are looking only for expressions. On non-expressions, simply descend. + _ -> anyR descendR + + +-- | Optimize single comprehensions during a top-down traversal +optCompR :: RewriteC CL +optCompR = do + Comp{} <- promoteT idR + -- debugPretty "optCompR at" c + + repeatR (compNormEarlyR + <+ predpushdownR + <+ flatjoinsR + <+ anyR descendR + ) >>> debugShow "after comp" + +applyOptimizationsR :: RewriteC CL +applyOptimizationsR = descendR >+> anytdR loopInvariantR >+> anybuR buUnnestR + +optimizeR :: RewriteC CL +optimizeR = resugarR >+> + normalizeOnceR >+> + repeatR applyOptimizationsR >+> + postProcessR + +optimizeComprehensions :: Expr -> Expr +optimizeComprehensions expr = debugOpt "CL" expr optimizedExpr + where + optimizedExpr = applyExpr (optimizeR >>> projectT) expr + -- optimizedExpr = applyExpr projectT expr diff --git a/src/Database/DSH/CL/Opt/AntiJoin.hs b/src/Database/DSH/CL/Opt/AntiJoin.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/AntiJoin.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} + +module Database.DSH.CL.Opt.AntiJoin + ( antijoinR + ) where + +import Control.Arrow +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NL +import Data.Semigroup +import qualified Data.Traversable as T +import Data.List + +import Database.DSH.Common.Lang +import Database.DSH.Common.Kure +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang +import Database.DSH.CL.Opt.Auxiliary +import qualified Database.DSH.CL.Primitives as P + +-------------------------------------------------------------------------------- +-- Universal quantification with and without range predicates + +-- | Turn universal quantification with range and quantifier predicates into an +-- antijoin. We use the classification of queries in Claussen et al.: Optimizing +-- Queries with Universal Quantification in Object-Oriented and +-- Object-Relational Databases (VLDB 1995). + +pattern PAnd xs <- AppE1 _ And xs +pattern PNot e <- UnOp _ (SUBoolOp Not) e + +negateRelOp :: BinRelOp -> BinRelOp +negateRelOp op = case op of + Eq -> NEq + NEq -> Eq + GtE -> Lt + LtE -> Gt + Lt -> GtE + Gt -> LtE + +-- | Quantifier predicates that reference inner and outer relation +-- appear negated on the antijoin. The transform results in a +-- non-empty list of join conjuncts extracted from the negated +-- quantifier predicate. In addition, it returns a (possibly empty) +-- list of conjuncts that only reference the inner variable and can be +-- evaluated on the inner source. +quantifierPredicateT :: Ident + -> Ident + -> TransformC CL (NonEmpty (JoinConjunct JoinExpr), [Expr]) +quantifierPredicateT x y = readerT $ \q -> case q of + -- If the quantifier predicate is already negated, take its + -- non-negated form. + ExprCL (PNot _) -> do + conjs <- childT UnOpArg conjunctsT + + -- Separate predicate parts that only depend on the inner + -- variable. + let (nonCorrExprs, corrExprs) = partition (\e -> freeVars e == [y]) $ NL.toList conjs + + -- Note: We can't be sure that there actually is at least one + -- predicate that is correlated. As the caller only checks + -- that x and y occur in the combined predicate, we might run + -- into the following freak case: p1 x && p2 y. In this case, + -- fail the rewrite completely. + corrExprs' <- case corrExprs of + c : cs -> return $ c :| cs + [] -> fail "no correlated predicates for the join" + + corrPreds <- constT (return corrExprs') >>> mapT (splitJoinPredT x y) + return (corrPreds, nonCorrExprs) + + -- If the predicate is a simple relational operator, but + -- non-negated, try to negate the operator itself. + ExprCL (BinOp t (SBRelOp op) e1 e2) -> do + let e' = BinOp t (SBRelOp $ negateRelOp op) e1 e2 + q' <- constT (return e') >>> splitJoinPredT x y + return (q' :| [], []) + + _ -> fail "can't handle predicate" + +mkUniversalQuantOnlyAntiJoinT :: (Ident, Expr) + -> (Ident, Expr) + -> Expr + -> TransformC (NL Qual) Qual +mkUniversalQuantOnlyAntiJoinT (x, xs) (y, ys) q = do + (qPred, nonCorrPreds) <- constT (return q) >>> injectT >>> quantifierPredicateT x y + + let yst = typeOf ys + yt = elemT yst + + let innerQuals = case nonCorrPreds of + p : ps -> BindQ y ys :* fmap GuardQ (fromListSafe p ps) + [] -> S $ BindQ y ys + + -- Filter the inner source with the range + -- predicates. Additionally, filter it with the non-correlated + -- predicates extracted from the quantifier predicate. + -- [ y | y <- ys, ps ++ nonCorrPreds ] + let ys' = Comp yst (Var yt y) innerQuals + + return $ BindQ x (P.antijoin xs ys' $ JoinPred $ qPred) + +universalQualR :: RewriteC (NL Qual) +universalQualR = readerT $ \quals -> case quals of + -- Special case: no range predicate + -- [ ... | ..., x <- xs, and [ q | y <- ys ]] + BindQ x xs :* (S (GuardQ (PAnd (Comp _ q (S (BindQ y ys)))))) -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + antijoinGen <- mkUniversalQuantOnlyAntiJoinT (x, xs) (y, ys) q + return $ S antijoinGen + + -- Special case: no range predicate + -- [ ... | ..., x <- xs, and [ q | y <- ys ], ... ] + BindQ x xs :* (GuardQ (PAnd (Comp _ q (S (BindQ y ys))))) :* qs -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + antijoinGen <- mkUniversalQuantOnlyAntiJoinT (x, xs) (y, ys) q + return $ antijoinGen :* qs + + -- [ ... | ..., x <- xs, and [ q | y <- ys, ps ], ... ] + BindQ x xs :* GuardQ (PAnd (Comp _ q (BindQ y ys :* ps))) :* qs -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + antijoinGen <- mkUniversalRangeAntiJoinT (x, xs) (y, ys) ps q + return $ antijoinGen :* qs + + -- [ ... | ..., x <- xs, and [ q | y <- ys, ps ]] + BindQ x xs :* (S (GuardQ (PAnd (Comp _ q (BindQ y ys :* ps))))) -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + antijoinGen <- mkUniversalRangeAntiJoinT (x, xs) (y, ys) ps q + return $ S $ antijoinGen + _ -> fail "no and pattern" + +mkUniversalRangeAntiJoinT :: (Ident, Expr) + -> (Ident, Expr) + -> NL Qual + -> Expr + -> TransformC (NL Qual) Qual +mkUniversalRangeAntiJoinT (x, xs) (y, ys) ps q = do + psExprs <- constT $ T.mapM fromGuard ps + let psFVs = sort $ nub $ concatMap freeVars $ toList psExprs + qFVs = sort $ nub $ freeVars q + + let xy = sort [x, y] + + debugMsg $ show psFVs + debugMsg $ show qFVs + debugMsg $ show xy + + case (psFVs, qFVs) of + -- Class 12: p(y), q(x, y) + ([y'], qsvs@[_, _]) | y == y' && qsvs == xy -> do + (qPred, nonCorrPreds) <- constT (return q) >>> injectT >>> quantifierPredicateT x y + mkClass12AntiJoinT (x, xs) (y, ys) psExprs (JoinPred qPred) nonCorrPreds + + -- Class 15: p(x, y), q(y) + (psvs@[_, _], [y']) | psvs == xy && y == y' -> do + psConjs <- constT (return psExprs) >>> mapT (splitJoinPredT x y) + let psPred = JoinPred $ toNonEmpty psConjs + mkClass15AntiJoinT (x, xs) (y, ys) psPred q + + -- Class 16: p(x, y), q(x, y) + (psvs@[_, _], qsvs@[_, _]) | psvs == xy && qsvs == xy -> do + psConjs <- constT (return psExprs) >>> mapT (splitJoinPredT x y) + + -- Even if q itself references x and y, there might be + -- parts of the predicate (conjuncts) which only reference + -- y. These parts can (and should) be evaluated on ys. + (qPred, nonCorrPreds) <- constT (return q) >>> injectT >>> quantifierPredicateT x y + + mkClass16AntiJoinT (x, xs) (y, ys) (toNonEmpty psConjs) qPred nonCorrPreds + + _ -> fail "FIXME" + + +mkClass12AntiJoinT :: (Ident, Expr) -- ^ Generator variable and expression for the outer + -> (Ident, Expr) + -> NL Expr + -> JoinPredicate JoinExpr + -> [Expr] + -> TransformC (NL Qual) Qual +mkClass12AntiJoinT (x, xs) (y, ys) ps qs nonCorrPreds = do + let yst = typeOf ys + yt = elemT yst + + -- Filter the inner source with the range + -- predicates. Additionally, filter it with the non-correlated + -- predicates extracted from the quantifier predicate. + -- [ y | y <- ys, ps ++ nonCorrPreds ] + let innerPreds = case nonCorrPreds of + c : cs -> appendNL ps (fromListSafe c cs) + [] -> ps + + let ys' = Comp yst (Var yt y) (BindQ y ys :* fmap GuardQ innerPreds) + + -- xs ▷_ps [ y | y <- ys, not qs ] + return $ BindQ x (P.antijoin xs ys' qs) + +-- This rewrite implements plan 14 for Query Class 15 in Claussen et al., +-- Optimizing Queries with Universal Quantification... (VLDB, 1995). Class 15 +-- contains queries in which the range predicate ranges over both relations, +-- i.e. x and y occur free. The quantifier predicate on the other hand ranges +-- only over the inner relation: +-- p(x, y), q(y) +mkClass15AntiJoinT :: (Ident, Expr) -- ^ Generator variable and expression for the outer + -> (Ident, Expr) + -> JoinPredicate JoinExpr + -> Expr + -> TransformC (NL Qual) Qual +mkClass15AntiJoinT (x, xs) (y, ys) ps qs = do + let yst = typeOf ys + yt = elemT yst + + -- [ y | y <- ys, not q ] + let ys' = Comp yst (Var yt y) (BindQ y ys :* S (GuardQ $ P.not qs)) + + -- xs ▷_not(qs) [ y | y <- ys, ps ] + return $ BindQ x (P.antijoin xs ys' ps) + +mkClass16AntiJoinT :: (Ident, Expr) + -> (Ident, Expr) + -> NonEmpty (JoinConjunct JoinExpr) + -> NonEmpty (JoinConjunct JoinExpr) + -> [Expr] + -> TransformC (NL Qual) (Qual) +mkClass16AntiJoinT (x, xs) (y, ys) ps qs nonCorrPreds = do + -- Prepare a comprehension that filters the inner input by the + -- non-correlated predicates extracted from the quantifier + -- predicate. + let yst = typeOf ys + yt = elemT yst + + let ys' = case nonCorrPreds of + c : cs -> let quals = BindQ y ys :* fmap GuardQ (fromListSafe c cs) + in Comp yst (Var yt y) quals + [] -> ys + + -- xs ▷_(p && not q) ys + return $ BindQ x (P.antijoin xs ys' $ JoinPred $ ps <> qs) + +antijoinR :: RewriteC CL +antijoinR = do + Comp _ _ _ <- promoteT idR + childR CompQuals (promoteR $ onetdR universalQualR) diff --git a/src/Database/DSH/CL/Opt/Auxiliary.hs b/src/Database/DSH/CL/Opt/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/Auxiliary.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Common tools for rewrites +module Database.DSH.CL.Opt.Auxiliary + ( applyExpr + , applyInjectable + -- * Monad rewrites with additional state + , TuplifyM + -- * Converting predicate expressions into join predicates + , toJoinExpr + , splitJoinPredT + , joinConjunctsT + , conjunctsT + -- * Pushing guards towards the front of a qualifier list + , isThetaJoinPred + , isSemiJoinPred + , isAntiJoinPred + -- * Free and bound variables + , freeVars + , boundVars + , compBoundVars + -- * Substituion + , substR + , tuplifyR + -- * Combining generators and guards + , insertGuard + -- * Generic iterator to merge guards into generators + , Comp(..) + , MergeGuard + , mergeGuardsIterR + -- * Classification of expressions + , complexPrim1 + , complexPrim2 + , fromGuard + , fromQual + , fromGen + -- * NL spine traversal + , onetdSpineT + ) where + +import Control.Arrow +import Data.Either +import qualified Data.Foldable as F +import Data.List +import qualified Data.Set as S +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.Semigroup hiding (First) + +import Language.KURE + +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang +import Database.DSH.Common.Lang +import Database.DSH.Common.Nat +import Database.DSH.Common.RewriteM +import Database.DSH.Impossible + +-- | A version of the CompM monad in which the state contains an additional +-- rewrite. Use case: Returning a tuplify rewrite from a traversal over the +-- qualifier list so that it can be applied to the head expression. +type TuplifyM = RewriteStateM (RewriteC CL) + +-- | Run a translate on an expression without context +applyExpr :: TransformC CL b -> Expr -> Either String b +applyExpr f e = runRewriteM $ applyT f initialCtx (inject e) + +-- | Run a translate on any value which can be injected into CL +applyInjectable :: Injection a CL => TransformC CL b -> a -> Either String b +applyInjectable t e = runRewriteM $ applyT t initialCtx (inject e) + + +-------------------------------------------------------------------------------- +-- Rewrite general expressions into equi-join predicates + +toJoinBinOp :: Monad m => ScalarBinOp -> m JoinBinOp +toJoinBinOp (SBNumOp o) = return $ JBNumOp o +toJoinBinOp (SBStringOp o) = return $ JBStringOp o +toJoinBinOp (SBRelOp _) = fail "toJoinBinOp: join expressions can't contain relational ops" +toJoinBinOp (SBBoolOp _) = fail "toJoinBinOp: join expressions can't contain boolean ops" + +toJoinUnOp :: Monad m => ScalarUnOp -> m JoinUnOp +toJoinUnOp (SUNumOp o) = return $ JUNumOp o +toJoinUnOp (SUCastOp o) = return $ JUCastOp o +toJoinUnOp (SUTextOp o) = return $ JUTextOp o +toJoinUnOp (SUBoolOp _) = fail "toJoinUnOp: join expressions can't contain boolean ops" +toJoinUnOp SUDateOp = $unimplemented + +toJoinExpr :: Ident -> TransformC Expr JoinExpr +toJoinExpr n = do + e <- idR + + case e of + AppE1 _ (TupElem i) _ -> do + appe1T (toJoinExpr n) (\t _ e1 -> JTupElem t i e1) + BinOp _ o _ _ -> do + o' <- constT $ toJoinBinOp o + binopT (toJoinExpr n) (toJoinExpr n) (\t _ e1 e2 -> JBinOp t o' e1 e2) + UnOp _ o _ -> do + o' <- constT $ toJoinUnOp o + unopT (toJoinExpr n) (\t _ e1 -> JUnOp t o' e1) + Lit t v -> do + return $ JLit t v + Var t x -> do + guardMsg (n == x) "toJoinExpr: wrong name" + return $ JInput t + _ -> do + fail "toJoinExpr: can't translate to join expression" + +flipRelOp :: BinRelOp -> BinRelOp +flipRelOp Eq = Eq +flipRelOp NEq = NEq +flipRelOp Gt = Lt +flipRelOp Lt = Gt +flipRelOp GtE = LtE +flipRelOp LtE = GtE + +-- | Try to transform an expression into a thetajoin predicate. This +-- will fail if either the expression does not have the correct shape +-- (relational operator with simple projection expressions on both +-- sides) or if one side of the predicate has free variables which are +-- not the variables of the qualifiers given to the function. +splitJoinPredT :: Ident -> Ident -> TransformC Expr (JoinConjunct JoinExpr) +splitJoinPredT x y = do + BinOp _ (SBRelOp op) e1 e2 <- idR + + [x'] <- return $ freeVars e1 + [y'] <- return $ freeVars e2 + + if | x == x' && y == y' -> binopT (toJoinExpr x) + (toJoinExpr y) + (\_ _ e1' e2' -> JoinConjunct e1' op e2') + | y == x' && x == y' -> binopT (toJoinExpr y) + (toJoinExpr x) + (\_ _ e1' e2' -> JoinConjunct e2' (flipRelOp op) e1') + | otherwise -> fail "splitJoinPredT: not a theta-join predicate" + +-- | Split a conjunctive combination of join predicates. +joinConjunctsT :: Ident -> Ident -> TransformC CL (NonEmpty (JoinConjunct JoinExpr)) +joinConjunctsT x y = conjunctsT >>> mapT (splitJoinPredT x y) + +-- | Split a combination of logical conjunctions into its sub-terms. +conjunctsT :: TransformC CL (NonEmpty Expr) +conjunctsT = readerT $ \e -> case e of + -- For a logical AND, turn the left and right arguments into lists + -- of join predicates and combine them. + ExprCL (BinOp _ (SBBoolOp Conj) _ _) -> do + leftConjs <- childT BinOpArg1 conjunctsT + rightConjs <- childT BinOpArg2 conjunctsT + return $ leftConjs <> rightConjs + + -- For a non-AND expression, try to transform it into a join + -- predicate. + ExprCL expr -> return $ expr :| [] + + _ -> $impossible + + +-------------------------------------------------------------------------------- +-- Distinguish certain kinds of guards + +-- | An expression qualifies for a thetajoin predicate if both sides +-- are scalar expressions on exactly one of the join candidate +-- variables. +isThetaJoinPred :: Ident -> Ident -> Expr -> Bool +isThetaJoinPred x y (BinOp _ (SBRelOp _) e1 e2) = + isFlatExpr e1 && isFlatExpr e1 + && ([x] == freeVars e1 && [y] == freeVars e2 + || [x] == freeVars e2 && [y] == freeVars e1) +isThetaJoinPred _ _ _ = False + +-- | Does the predicate look like an existential quantifier? +isSemiJoinPred :: Ident -> Expr -> Bool +isSemiJoinPred x (AppE1 _ Or (Comp _ p + (S (BindQ y _)))) = isThetaJoinPred x y p +isSemiJoinPred _ _ = False + +-- | Does the predicate look like an universal quantifier? +isAntiJoinPred :: Ident -> Expr -> Bool +isAntiJoinPred x (AppE1 _ And (Comp _ p + (S (BindQ y _)))) = isThetaJoinPred x y p +isAntiJoinPred _ _ = False + +isFlatExpr :: Expr -> Bool +isFlatExpr expr = + case expr of + AppE1 _ (TupElem _) e -> isFlatExpr e + UnOp _ _ e -> isFlatExpr e + BinOp _ _ e1 e2 -> isFlatExpr e1 && isFlatExpr e2 + Var _ _ -> True + Lit _ _ -> True + _ -> False + +-------------------------------------------------------------------------------- +-- Computation of free variables + +freeVarsT :: TransformC CL [Ident] +freeVarsT = fmap nub $ crushbuT $ promoteT $ do (ctx, Var _ v) <- exposeT + guardM (v `freeIn` ctx) + return [v] + +-- | Compute free variables of the given expression +freeVars :: Expr -> [Ident] +freeVars = either error id . applyExpr freeVarsT + +-- | Compute all identifiers bound by a qualifier list +compBoundVars :: F.Foldable f => f Qual -> [Ident] +compBoundVars qs = F.foldr aux [] qs + where + aux :: Qual -> [Ident] -> [Ident] + aux (BindQ n _) ns = n : ns + aux (GuardQ _) ns = ns + +boundVarsT :: TransformC CL [Ident] +boundVarsT = fmap nub $ crushbuT $ promoteT $ readerT $ \expr -> case expr of + Comp _ _ qs -> return $ compBoundVars qs + Let _ v _ _ -> return [v] + _ -> return [] + +-- | Compute all names that are bound in the given expression. Note +-- that the only binding forms in NKL are comprehensions or 'let' +-- bindings. +boundVars :: Expr -> [Ident] +boundVars = either error id . applyExpr boundVarsT + +-------------------------------------------------------------------------------- +-- Substitution + +-- | /Exhaustively/ substitute term 's' for a variable 'v'. +substR :: Ident -> Expr -> RewriteC CL +substR v s = readerT $ \expr -> case expr of + -- Occurence of the variable to be replaced + ExprCL (Var _ n) | n == v -> return $ inject s + + -- If a let-binding shadows the name we substitute, only descend + -- into the bound expression. + ExprCL (Let _ n _ _) | n == v -> tryR $ childR LetBind (substR v s) + ExprCL (Let _ n _ _) | otherwise -> + if n `elem` freeVars s + -- If the let-bound name occurs free in the substitute, + -- alpha-convert the binding to avoid capturing the name. + then $unimplemented >>> tryR (anyR (substR v s)) + else tryR $ anyR (substR v s) + + -- If some generator shadows v, we must not substitute in the comprehension + -- head. However, substitute in the qualifier list. The traversal on + -- qualifiers takes care of shadowing generators. + -- FIXME in this case, rename the shadowing generator to avoid + -- name-capturing (see lambda case) + ExprCL (Comp _ _ qs) | v `elem` compBoundVars qs -> tryR $ childR CompQuals (substR v s) + ExprCL _ -> tryR $ anyR $ substR v s + + -- Don't substitute past shadowing generators + QualsCL ((BindQ n _) :* _) | n == v -> tryR $ childR QualsHead (substR v s) + QualsCL _ -> tryR $ anyR $ substR v s + QualCL _ -> tryR $ anyR $ substR v s + + +-------------------------------------------------------------------------------- +-- Tuplifying variables + +-- | Turn all occurences of two identifiers into accesses to one tuple variable. +-- tuplifyR z c y e = e[fst z/x][snd z/y] +tuplifyR :: Ident -> (Ident, Type) -> (Ident, Type) -> RewriteC CL +tuplifyR v (v1, t1) (v2, t2) = substR v1 v1Rep >+> substR v2 v2Rep + where + (v1Rep, v2Rep) = tupleVars v t1 t2 + +tupleVars :: Ident -> Type -> Type -> (Expr, Expr) +tupleVars n t1 t2 = (v1Rep, v2Rep) + where v = Var pt n + pt = pairT t1 t2 + v1Rep = AppE1 t1 (TupElem First) v + v2Rep = AppE1 t2 (TupElem (Next First)) v + +-------------------------------------------------------------------------------- +-- Helpers for combining generators with guards in a comprehensions' +-- qualifier list + +-- | Insert a guard in a qualifier list at the first possible +-- position. +insertGuard :: Expr -> S.Set Ident -> NL Qual -> NL Qual +insertGuard guardExpr initialEnv quals = go initialEnv quals + where + go :: S.Set Ident -> NL Qual -> NL Qual + go env (S q) = + if all (\v -> S.member v env) fvs + then GuardQ guardExpr :* S q + else q :* (S $ GuardQ guardExpr) + go env (q@(BindQ x _) :* qs) = + if all (\v -> S.member v env) fvs + then GuardQ guardExpr :* q :* qs + else q :* go (S.insert x env) qs + go env (GuardQ p :* qs) = + if all (\v -> S.member v env) fvs + then GuardQ guardExpr :* GuardQ p :* qs + else GuardQ p :* go env qs + + fvs = freeVars guardExpr + +------------------------------------------------------------------------ +-- Generic iterator that merges guards into generators one by one. + +-- | A container for the components of a comprehension expression +data Comp = C Type Expr (NL Qual) + +fromQual :: Qual -> Either (Ident, Expr) Expr +fromQual (BindQ x e) = Left (x, e) +fromQual (GuardQ p) = Right p + + +-- | Type of worker functions that merge guards into generators. It +-- receives the comprehension itself (with a qualifier list that +-- consists solely of generators), the current candidate guard +-- expression, guard expressions that have to be tried and guard +-- expressions that have been tried already. Last two are necessary if +-- the merging steps leads to tuplification. +type MergeGuard = Comp -> Expr -> [Expr] -> [Expr] -> TransformC () (Comp, [Expr], [Expr]) + +tryGuards :: MergeGuard -- ^ The worker function + -> Comp -- ^ The current state of the comprehension + -> [Expr] -- ^ Guards to try + -> [Expr] -- ^ Guards that have been tried and failed + -> TransformC () (Comp, [Expr]) +-- Try the next guard +tryGuards mergeGuardR comp (p : ps) testedGuards = do + let tryNextGuard :: TransformC () (Comp, [Expr]) + tryNextGuard = do + -- Try to combine p with some generators + (comp', ps', testedGuards') <- mergeGuardR comp p ps testedGuards + + -- On success, back out to give other rewrites + -- (i.e. predicate pushdown) a chance. + return (comp', ps' ++ testedGuards') + + -- If the current guard failed, try the next ones. + tryOtherGuards :: TransformC () (Comp, [Expr]) + tryOtherGuards = tryGuards mergeGuardR comp ps (p : testedGuards) + + tryNextGuard <+ tryOtherGuards + +-- No guards left to try and none succeeded +tryGuards _ _ [] _ = fail "no predicate could be merged" + +-- | Try to build flat joins (equi-, semi- and antijoins) from a +-- comprehensions qualifier list. +-- FIXME only try on those predicates that look like equi-/anti-/semi-join predicates. +-- FIXME TransformC () ... is an ugly abuse of the rewrite system +mergeGuardsIterR :: MergeGuard -> RewriteC CL +mergeGuardsIterR mergeGuardR = do + ExprCL (Comp ty e qs) <- idR + + -- Separate generators from guards + ((g : gs), guards@(_:_)) <- return $ partitionEithers $ map fromQual $ toList qs + + let initialComp = C ty e (fmap (uncurry BindQ) $ fromListSafe g gs) + + -- Try to merge one guard with some generators + (C _ e' qs', remGuards) <- constT (return ()) + >>> tryGuards mergeGuardR initialComp guards [] + + -- If there are any guards remaining which we could not turn into + -- joins, append them at the end of the new qualifier list + case remGuards of + rg : rgs -> let rqs = fmap GuardQ $ fromListSafe rg rgs + in return $ ExprCL $ Comp ty e' (appendNL qs' rqs) + [] -> return $ ExprCL $ Comp ty e' qs' + +-------------------------------------------------------------------------------- +-- Traversal functions + +-- | Traverse the spine of a NL list top-down and apply the translation as soon +-- as possible. +onetdSpineT + :: (ReadPath c Int, MonadCatch m, Walker c CL) + => Transform c m CL b + -> Transform c m CL b +onetdSpineT t = do + n <- idR + case n of + QualsCL (_ :* _) -> childT 0 t <+ childT 1 (onetdSpineT t) + QualsCL (S _) -> childT 0 t + _ -> $impossible + +-------------------------------------------------------------------------------- +-- Classification of expressions + +complexPrim2 :: Prim2 -> Bool +complexPrim2 _ = True + +complexPrim1 :: Prim1 -> Bool +complexPrim1 op = + case op of + Concat -> False + TupElem _ -> False + _ -> True + +fromGuard :: Monad m => Qual -> m Expr +fromGuard (GuardQ e) = return e +fromGuard (BindQ _ _) = fail "not a guard" + +fromGen :: Monad m => Qual -> m (Ident, Expr) +fromGen (BindQ x xs) = return (x, xs) +fromGen (GuardQ _) = fail "not a generator" diff --git a/src/Database/DSH/CL/Opt/CompNormalization.hs b/src/Database/DSH/CL/Opt/CompNormalization.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/CompNormalization.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Monad comprehension normalization rules (adapted from T. Grust +-- "Comprehending Queries") +module Database.DSH.CL.Opt.CompNormalization + ( m_norm_1R + , m_norm_2R + , m_norm_3R + , m_norm_4R + , m_norm_5R + , invariantguardR + , guardpushfrontR + , guardpushbackR + , ifgeneratorR + , identityCompR + ) where + +import Control.Applicative +import Control.Arrow +import Data.Either +import qualified Data.Map as M +import qualified Data.Set as S + +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang +import Database.DSH.CL.Opt.Auxiliary +import qualified Database.DSH.CL.Primitives as P +import Database.DSH.Common.Kure +import Database.DSH.Common.Lang +import Database.DSH.Impossible + +------------------------------------------------------------------ +-- Classical Monad Comprehension Normalization rules (Grust) + +-- | M-Norm-1: Eliminate comprehensions with empty generators +m_norm_1R :: RewriteC CL +m_norm_1R = do + Comp t _ _ <- promoteT idR + matches <- childT CompQuals $ onetdT (promoteT $ patternT <+ patternEndT) + guardM matches + return $ inject $ P.nil t + + where + patternT :: TransformC (NL Qual) Bool + patternT = do + BindQ _ (Lit _ (ListV [])) :* _ <- idR + return True + + patternEndT :: TransformC (NL Qual) Bool + patternEndT = do + (S (BindQ _ (Lit _ (ListV [])))) <- idR + return True + +-- | M-Norm-2: eliminate singleton generators. +-- [ h | qs, x <- [v], qs' ] +-- => [ h[v/x] | qs, qs'[v/x] ] +m_norm_2R :: RewriteC CL +m_norm_2R = (normSingletonCompR <+ normCompR) >>> debugTrace "m_norm_2" + + where + -- This rewrite is a bit annoying: If it triggers, we can remove a + -- qualifier. However, the type NL forces us to take care that we do not + -- produce a comprehension with an empty qualifier list. + + -- Due to non-empty NL lists, we have to consider the case of + -- removing a (the!) qualifier from a singleton list. + normSingletonCompR :: RewriteC CL + normSingletonCompR = do + Comp _ h (S q) <- promoteT idR + (x, e) <- constT (return q) >>> qualT + constT (return $ inject $ P.sng h) >>> substR x e + + -- The main rewrite + normCompR :: RewriteC CL + normCompR = do + Comp t _ (_ :* _) <- promoteT idR + (tuplifyHeadR, qs') <- statefulT idR $ childT CompQuals (promoteR normQualifiersR) >>> projectT + h' <- childT CompHead tuplifyHeadR >>> projectT + return $ inject $ Comp t h' qs' + + normQualifiersR :: Rewrite CompCtx TuplifyM (NL Qual) + normQualifiersR = anytdR (normQualsEndR <+ normQualsR) + + -- Match the pattern (singleton generator) on a qualifier + qualT :: TransformC Qual (Ident, Expr) + qualT = do + q <- idR + case q of + -- x <- [v] + BindQ x (Lit t (ListV [v])) -> return (x, Lit (elemT t) v) + -- x <- v : [] + BindQ x (AppE1 _ Singleton v) -> return (x, v) + _ -> fail "qualR: no match" + + -- Try to match the pattern at the end of the qualifier list + normQualsEndR :: Rewrite CompCtx TuplifyM (NL Qual) + normQualsEndR = do + q1 :* (S q2) <- idR + (x, e) <- liftstateT $ constT (return q2) >>> qualT + constT $ modify (>>> substR x e) + return (S q1) + + -- Try to match the pattern in the middle of the qualifier list + normQualsR :: Rewrite CompCtx TuplifyM (NL Qual) + normQualsR = do + q1 :* q2 :* qs <- idR + (x, e) <- liftstateT $ constT (return q2) >>> qualT + qs' <- liftstateT $ constT (return $ inject qs) >>> substR x e >>> projectT + constT $ modify (>>> substR x e) + return $ q1 :* qs' + +-- | M-Norm-3: unnest comprehensions from a generator +-- [ h | qs, x <- [ h' | qs'' ], qs' ] +-- => [ h[h'/x] | qs, qs'', qs'[h'/x] ] +m_norm_3R :: RewriteC CL +m_norm_3R = do + Comp t _ _ <- promoteT idR + (tuplifyHeadR, qs') <- statefulT idR $ childT CompQuals (promoteR normQualifiersR) >>> projectT + h' <- childT CompHead (tryR tuplifyHeadR) >>> projectT + return $ inject $ Comp t h' qs' + + where + + qualT :: TransformC Qual (Ident, Expr, NL Qual) + qualT = do + BindQ x (Comp _ h' qs'') <- idR + return (x, h', qs'') + + normQualifiersR :: Rewrite CompCtx TuplifyM (NL Qual) + normQualifiersR = anytdR (normQualsEndR <+ normQualsR) + + normQualsEndR :: Rewrite CompCtx TuplifyM (NL Qual) + normQualsEndR = do + (S q) <- idR + (x, h', qs'') <- liftstateT $ (constT $ return q) >>> qualT + constT $ modify (>>> substR x h') + return qs'' + + normQualsR :: Rewrite CompCtx TuplifyM (NL Qual) + normQualsR = do + q :* qs <- idR + (x, h', qs'') <- liftstateT $ (constT $ return q) >>> qualT + qs' <- liftstateT $ constT (return $ inject qs) >>> substR x h' >>> projectT + constT $ modify (>>> substR x h') + return $ appendNL qs'' qs' + +-- | M-Norm-4: unnest existential quantifiers if the outer comprehension is over +-- an idempotent monad (i.e. duplicates are eliminated from the result). +m_norm_4R :: RewriteC CL +m_norm_4R = $unimplemented + +-- | M-Norm-5: Unnest nested comprehensions over an idempotent monad. +m_norm_5R :: RewriteC CL +m_norm_5R = $unimplemented + + +-------------------------------------------------------------------------------- +-- Additional normalization rules for comprehensions + +qualsguardpushfrontR :: RewriteC (NL Qual) +qualsguardpushfrontR = do + qs <- idR + -- Separate generators from guards + ((g : gs), guards@(_:_)) <- return $ partitionEithers $ map fromQual $ toList qs + + let gens = fmap (uncurry BindQ) $ fromListSafe g gs + env <- S.fromList <$> M.keys <$> cl_bindings <$> contextT + let qs' = foldl (\quals guard -> insertGuard guard env quals) gens guards + guardM $ qs /= qs' + return qs' + +-- | Push all guards as far as possible to the front of the qualifier +-- list. Note that 'guardpushfrontR' loops with join introduction +-- rewrites and must not be isolated. +guardpushfrontR :: RewriteC CL +guardpushfrontR = do + Comp t h _ <- promoteT idR + qs' <- childT CompQuals (promoteR qualsguardpushfrontR) >>> projectT + return $ inject $ Comp t h qs' + +qualsguardpushbackR :: RewriteC (NL Qual) +qualsguardpushbackR = innermostR $ readerT $ \quals -> case quals of + GuardQ p :* BindQ x xs :* qs -> return $ BindQ x xs :* GuardQ p :* qs + GuardQ p :* (S (BindQ x xs)) -> return $ BindQ x xs :* (S (GuardQ p)) + _ -> fail "no pushable guard" + + +-- | Push all guards to the end of the qualifier list to bring +-- generators closer together. +guardpushbackR :: RewriteC CL +guardpushbackR = do + Comp t h _ <- promoteT idR + qs' <- childT CompQuals (promoteR qualsguardpushbackR) >>> projectT + return $ inject $ Comp t h qs' + + +-- | If a guard does not depend on any generators of the current +-- comprehension, it can be evaluated outside of the comprehension. As +-- preparation, we push guards towards the front of the qualifier +-- list. +invariantguardR :: RewriteC CL +invariantguardR = + tryR guardpushfrontR + >>> + (promoteR $ readerT $ \expr -> case expr of + Comp t h (GuardQ g :* qs) -> return $ inject $ P.if_ g (Comp t h qs) (P.nil t) + Comp t h (S (GuardQ p)) -> return $ inject $ P.if_ p (P.sng h) (P.nil t) + _ -> fail "no match") + +ifgeneratorqualsR :: RewriteC (NL Qual) +ifgeneratorqualsR = anytdR $ readerT $ \quals -> case quals of + BindQ x (If _ ce te (Lit _ (ListV []))) :* qs -> return $ BindQ x te :* GuardQ ce :* qs + S (BindQ x (If _ ce te (Lit _ (ListV [])))) -> return $ BindQ x te :* S (GuardQ ce) + _ -> fail "no match" + + +-- | Transform an 'if' conditional in a generator into a guard. +ifgeneratorR :: RewriteC CL +ifgeneratorR = do + Comp t h _ <- promoteT idR + qs' <- childT CompQuals (promoteR ifgeneratorqualsR) >>> projectT + return $ inject $ Comp t h qs' + +-- | Eliminate comprehensions that do not perform work. +identityCompR :: RewriteC CL +identityCompR = do + Comp _ (Var _ x) (S (BindQ x' xs)) <- promoteT idR + guardM $ x == x' + return $ inject xs diff --git a/src/Database/DSH/CL/Opt/FlatJoin.hs b/src/Database/DSH/CL/Opt/FlatJoin.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/FlatJoin.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Introduce simple theta joins +module Database.DSH.CL.Opt.FlatJoin + ( flatjoinsR + ) where + +import Control.Applicative +import Control.Arrow +import qualified Data.Map as M +import qualified Data.Set as S + +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang +import Database.DSH.CL.Opt.Auxiliary + +import Database.DSH.CL.Opt.AntiJoin +import Database.DSH.CL.Opt.SemiJoin +import Database.DSH.CL.Opt.ThetaJoin + +------------------------------------------------------------------------ +-- Flat join detection + +-- | Try to build a join from a list of generators and a single +-- guard. If we can build a theta join, the remaining predicates must +-- be tuplified. For this reason, we pass them in here. +mkFlatJoin :: MergeGuard +mkFlatJoin comp guard guardsToTry leftOverGuards = do + let C ty h qs = comp + env <- S.fromList <$> M.keys <$> cl_bindings <$> contextT + let comp' = ExprCL $ Comp ty h (insertGuard guard env qs) + tryAntijoinR comp' <+ trySemijoinR comp' <+ tryThetajoinR comp' + + where + tryAntijoinR :: CL -> TransformC () (Comp, [Expr], [Expr]) + tryAntijoinR comp' = do + ExprCL (Comp ty h qs') <- constT (return comp') >>> antijoinR + return (C ty h qs', guardsToTry, leftOverGuards) + + trySemijoinR :: CL -> TransformC () (Comp, [Expr], [Expr]) + trySemijoinR comp' = do + ExprCL (Comp ty h qs') <- constT (return comp') >>> semijoinR + return (C ty h qs', guardsToTry, leftOverGuards) + + tryThetajoinR :: CL -> TransformC () (Comp, [Expr], [Expr]) + tryThetajoinR comp' = do + res <- constT (return comp') >>> thetajoinR guardsToTry leftOverGuards + (ExprCL (Comp ty h qs), guardsToTry', leftOverGuards') <- return res + return (C ty h qs, guardsToTry', leftOverGuards') + +flatjoinsR :: RewriteC CL +flatjoinsR = mergeGuardsIterR mkFlatJoin + diff --git a/src/Database/DSH/CL/Opt/LoopInvariant.hs b/src/Database/DSH/CL/Opt/LoopInvariant.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/LoopInvariant.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Extract loop-invariant "complex" expressions from comprehensions +module Database.DSH.CL.Opt.LoopInvariant + ( loopInvariantR + ) where + +import Control.Applicative +import Data.Maybe +import Data.List + +import Database.DSH.Impossible +import Database.DSH.Common.Lang +import Database.DSH.Common.Kure +import Database.DSH.Common.Pretty +import Database.DSH.CL.Lang +import Database.DSH.CL.Kure +import qualified Database.DSH.CL.Primitives as P +import Database.DSH.CL.Opt.Auxiliary + +-- | Extract complex loop-invariant expressions from comprehension +-- heads and guards. +loopInvariantR :: RewriteC CL +loopInvariantR = loopInvariantGuardR <+ loopInvariantHeadR + +-------------------------------------------------------------------------------- +-- Common code for searching loop-invariant expressions + +traverseT :: [Ident] -> TransformC CL (Expr, PathC) +traverseT localVars = readerT $ \expr -> case expr of + -- We do not traverse into lambdas and comprehensions which are + -- nested in our current comprehension. + -- + -- FIXME technically, we could consider the generators of the + -- nested comprehension. + ExprCL (Comp _ _ _) -> fail "we don't traverse into comprehensions" + + ExprCL _ -> oneT $ searchInvariantExprT localVars + _ -> fail "we only consider expressions" + +-- | Collect a path to a complex expression +complexPathT :: [Ident] -> TransformC CL (Expr, PathC) +complexPathT localVars = do + ExprCL e <- idR + -- debugPretty "complexPathT" e + path <- snocPathToPath <$> absPathT + + -- We are only interested in constant expressions that do not + -- depend on variables bound by generators in the enclosing + -- comprehension. + -- debugMsg $ "free: " ++ pp (freeVars e) + guardM $ null $ freeVars e `intersect` localVars + + -- FIXME more precise heuristics could be employed: A + -- comprehension is only "complex" if it has more than one + -- generator OR a filter OR something complex in the head. + case e of + Comp _ _ _ -> return (e, path) + If _ _ _ _ -> return (e, path) + AppE2 _ op _ _ | complexPrim2 op -> return (e, path) + AppE1 _ op _ | complexPrim1 op -> return (e, path) + _ -> fail "not a complex expression" + +-- | Traverse expressions top-down, searching for loop-invariant +-- complex expressions. +searchInvariantExprT :: [Ident] -> TransformC CL (Expr, PathC) +searchInvariantExprT localVars = complexPathT localVars <+ (promoteT $ traverseT localVars) + +invariantQualR :: [Ident] -> TransformC CL (Expr, PathC) +invariantQualR localVars = readerT $ \expr -> case expr of + QualsCL (BindQ{} :* _) -> childT QualsTail (invariantQualR localVars) + QualsCL (GuardQ _ :* _) -> (childT QualsHead (searchInvariantExprT localVars) + <+ + childT QualsTail (invariantQualR localVars)) + QualsCL (S (GuardQ _)) -> pathT [QualsSingleton, GuardQualExpr] (searchInvariantExprT localVars) + QualsCL (S BindQ{}) -> fail "no match" + _ -> $impossible + +-------------------------------------------------------------------------------- +-- Search and replace loop-invariant expressions + +loopInvariantGuardR :: RewriteC CL +loopInvariantGuardR = do + c@(Comp _ _ qs) <- promoteT idR + -- FIXME passing *all* generator variables in the current + -- comprehension is too conservative. It would be sufficient to + -- consider those preceding the guard that is under investigation. + let genVars = fmap fst $ catMaybes $ fmap fromGen $ toList qs + (invExpr, invPath) <- childT CompQuals (invariantQualR genVars) + letName <- freshNameT (genVars ++ boundVars c) + + pathLen <- length <$> snocPathToPath <$> absPathT + let localPath = drop pathLen invPath + invVar = Var (typeOf invExpr) letName + + ExprCL comp' <- pathR localPath (constT $ return $ inject invVar) + return $ inject $ P.let_ letName invExpr comp' + +loopInvariantHeadR :: RewriteC CL +loopInvariantHeadR = do + Comp _ h qs <- promoteT idR + let genVars = fmap fst $ catMaybes $ fmap fromGen $ toList qs + (invExpr, invPath) <- childT CompHead (searchInvariantExprT genVars) + letName <- freshNameT (genVars ++ boundVars h) + + pathLen <- length <$> snocPathToPath <$> absPathT + let localPath = drop pathLen invPath + invVar = Var (typeOf invExpr) letName + + ExprCL comp' <- pathR localPath (constT $ return $ inject invVar) + debugMsg $ "loopInvariantHeadR " ++ pp (P.let_ letName invExpr comp') + return $ inject $ P.let_ letName invExpr comp' diff --git a/src/Database/DSH/CL/Opt/NestJoin.hs b/src/Database/DSH/CL/Opt/NestJoin.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/NestJoin.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Deal with nested comprehensions by introducing explicit nesting +-- operators (NestJoin, NestProduct). +module Database.DSH.CL.Opt.NestJoin + ( nestjoinR + , zipCorrelatedR + , nestingGenR + ) where + +import Control.Applicative((<$>)) +import Control.Arrow +import Control.Monad + +import Data.List +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.List.NonEmpty as N + +import Database.DSH.Common.Lang +import Database.DSH.Common.Kure + +import Database.DSH.CL.Lang +import Database.DSH.CL.Kure + +import qualified Database.DSH.CL.Primitives as P + +import Database.DSH.CL.Opt.Auxiliary +import Database.DSH.CL.Opt.CompNormalization + +nestjoinR :: RewriteC CL +nestjoinR = unnestFromGuardR <+ unnestFromHeadR + +-------------------------------------------------------------------------------- +-- Common code for unnesting from a comprehension head and from +-- comprehension guards + +-- A representation of a nested comprehension which is eligible for +-- unnesting +data NestedComp = NestedComp + { hType :: Type + , hHead :: Expr + , hGen :: (Ident, Expr) + , hGuards :: [Expr] + } deriving (Show) + +-- | Check if a comprehension is eligible for unnesting. This is the +-- case if the outer generator variable 'x' does not occur in the +-- inner generator and if there is only one inner generator. +nestedCompT :: Ident -> TransformC CL (PathC, NestedComp) +nestedCompT x = do + Comp t h qs <- promoteT idR + (y, ys, qsr) <- case qs of + S (BindQ y ys) -> return (y, ys, []) + BindQ y ys :* qsr -> return (y, ys, toList qsr) + _ -> fail "no match" + + guardM $ not $ x `elem` freeVars ys + guards <- constT $ mapM fromGuard qsr + + p <- snocPathToPath <$> absPathT + return (p, NestedComp t h (y, ys) guards) + +-- | Traverse though an expression and search for a comprehension that +-- is eligible for unnesting. +searchNestedCompT :: Ident -> TransformC CL (PathC, NestedComp) +searchNestedCompT x = + readerT $ \e -> case e of + -- We expect the single generator at the front of the + -- qualifiers. This might not be the case if a loop-invariant + -- guard is present and preceeds the generator. Therefore, we + -- pre-process by pushing all guards to the back. + ExprCL Comp{} -> tryR guardpushbackR >>> nestedCompT x + ExprCL _ -> oneT $ searchNestedCompT x + _ -> fail "only traverse through expressions" + +-- | Take an absolute path and drop the prefix of the path to a direct child of +-- the current node. This makes it a relative path starting from **some** direct +-- child of the current node. +relativePathT :: Path a -> TransformC b (Path a) +relativePathT p = do + curPath <- snocPathToPath <$> absPathT + return $ drop (1 + length curPath) p + +constNodeT :: (Injection a CL, Monad m) => a -> Transform c m b CL +constNodeT expr = constT $ return $ inject expr + +-- | Transform a suitable comprehension that was either nested in a +-- comprehension head or in a guard expression and the corresponding +-- outer generator. Returns a replacement for the inner comprehension, +-- outer generator with nesting op and the tuplify rewrite for the +-- outer generator variable. +unnestWorkerT + :: NestedComp -- ^ The nested comprehension + -> (Ident, Expr) -- ^ The outer generator + -> TransformC CL (Expr, Expr, RewriteC CL) +unnestWorkerT headComp (x, xs) = do + let (y, ys) = hGen headComp + + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + let (joinPredCandidates, nonJoinPreds) = partition (isThetaJoinPred x y) + (hGuards headComp) + + -- Determine which operator to use to implement the nesting. If + -- there is a join predicate, we use a nestjoin. Only if there is + -- no matching join predicate, we use a nested cartesian product + -- (nestproduct). + -- FIXME include all join predicates on the join operator + nestOp <- case joinPredCandidates of + [] -> return NestProduct + p : ps -> do + -- Split the join predicate + p' <- constT (return p) >>> splitJoinPredT x y + ps' <- constT (return ps) >>> mapT (splitJoinPredT x y) + + return $ NestJoin $ JoinPred $ p' N.:| ps' + + -- Identify predicates which only refer to y and can be evaluated + -- on the right nestjoin input. + let (yPreds, leftOverPreds) = partition ((== [y]) . freeVars) nonJoinPreds + + -- Left over we have predicates which (propably) refer to both + -- x and y and are not/can not be used as the join predicate. + -- [ [ e x y | y <- ys, p x y, p' x y ] | x <- xs ] + -- => [ [ e [fst y/x][snd y/y] | y <- snd x, p'[fst y/x][snd y/y] ] | x <- xs nj(p) ys ] + + let xt = elemT $ typeOf xs + yt = elemT $ typeOf ys + tupType = pairT xt (listT (pairT xt yt)) + joinVar = Var tupType x + + -- If there are inner predicates which only refer to y, + -- evaluate them on the right (ys) nestjoin input. + let ys' = case fromList yPreds of + Just ps -> Comp (listT yt) (Var yt y) (BindQ y ys :* fmap GuardQ ps) + Nothing -> ys + + -- the nesting operator combining xs and ys: + -- xs nj(p) ys + let xs' = AppE2 (listT tupType) nestOp xs ys' + + innerVar <- freshNameT [] + + let tuplifyInnerVarR :: Expr -> TransformC CL Expr + tuplifyInnerVarR e = constNodeT e + >>> tuplifyR innerVar (x, xt) (y, yt) + >>> projectT + + -- In the head of the inner comprehension, replace x and y + -- with the corresponding pair components of the inner lists + -- in the join result. + h' <- tuplifyInnerVarR (hHead headComp) + + -- Do the same on left over predicates, which will be + -- evaluated on the nestjoin result. + remPreds <- sequence $ map tuplifyInnerVarR leftOverPreds + let remGuards = map GuardQ remPreds + + -- Construct the inner comprehension with the tuplified head + -- and apply left-over predicates to the inner comprehension. + let ti = hType headComp + let headComp' = case remGuards of + g : gs -> Comp ti h' (BindQ innerVar (P.snd joinVar) :* fromListSafe g gs) + [] -> Comp ti h' (S $ BindQ innerVar (P.snd joinVar)) + + let tuplifyOuterR :: RewriteC CL + tuplifyOuterR = substR x $ P.fst joinVar + + return (headComp', xs', tuplifyOuterR) + + +-------------------------------------------------------------------------------- +-- Unnesting from a comprehension head + +-- In constrast to the previous strategy, we unnest only one +-- comprehension at a time. We unnest from the original comprehension +-- head, without normalizing it first. This saves quite a lot of +-- rather complex rewrites for normalizing the head and combining +-- multiple nesting operators. The resulting plans look the same. + +-- General rule: +-- [ e x [ f x y | y <- ys, jp x y, p1 x, p2 x y, p3 y ] | x <- xs, p4 x ] +-- => +-- [ e (fst x) [ f (fst y) (snd y) +-- | y <- snd x +-- , p1 (fst y) +-- , p2 (fst y) (snd y) +-- ] +-- | x <- xs △_jp [ y | y <- ys, p3 y ] +-- ] +-- +-- In the absence of a proper join predicate, we use the Nestproduct +-- operator ▽ instead of NestJoin. +-- +-- Predicates on the inner comprehension that only refer to y can be +-- safely evaluated before joining. Note that predicates on the inner +-- comprehension that only refer to x can **not** be evaluated on xs +-- alone! + +-- | Search for one comprehension nested in a comprehension head, +-- extract it and transform it into a nesting operator. +unnestFromHeadR :: RewriteC CL +unnestFromHeadR = do + Comp to ho qso <- promoteT idR + + -- We need one generator on a comprehension + (x, xs, qsr) <- case qso of + S (BindQ x xs) -> return (x, xs, []) + BindQ x xs :* qsr -> return (x, xs, toList qsr) + _ -> fail "no match" + + -- More precisely, we need *exactly one* generator on the + -- comprehension + guardM $ all isGuard qsr + + (headCompPath, headComp) <- childT CompHead (searchNestedCompT x) + + (headComp', nestOp, tuplifyOuterR) <- unnestWorkerT headComp (x, xs) + + -- Insert the replacement for the nested comprehension. + + -- The relative path to the comprehension to be replaced, starting + -- from the head expression + -- FIXME use withLocalPathT + relCompPath <- relativePathT headCompPath + + ExprCL tuplifiedHo <- constNodeT ho >>> tryR tuplifyOuterR + ExprCL unnestedHo <- constNodeT tuplifiedHo >>> pathR relCompPath (constNodeT headComp') + + -- In the outer comprehension's qualifier list, x is replaced by + -- the first pair component of the join result. + qsr' <- constT (return $ map inject qsr) + >>> mapT (tryR tuplifyOuterR) + >>> mapT projectT + + -- ExprCL tuplifiedHead <- constNodeT ho' >>> tryR tuplifyOuterR + + return $ inject $ Comp to unnestedHo (fromListSafe (BindQ x nestOp) qsr') + + +-------------------------------------------------------------------------------- +-- Nestjoin introduction: unnesting comprehensions from complex predicates + +-- | Try to unnest comprehensions from guards, which we can not unnest otherwise +-- (e.g. by introduing semi- or antijoins). +-- +-- [ e | qs, x <- xs, p x [ f x y | y < ys jp x y ], qs' ] +-- +-- rewrites into +-- +-- [ e[fst x/x] | +-- | qs +-- , x <- xs nestjoin(jp) ys +-- , p (fst x) [ f (fst y) (snd y) | y <- snd x ] +-- , qs'[fst x/x] +-- ] +-- +-- Additional predicates on the inner comprehension are handled in the +-- same way as in unnesting from a comprehension head. + +-- | Store not only the tuplifying rewrite in the state, but also the +-- rewritten guard expression. +-- FIXME this is a rather ugly hack +type GuardM = RewriteStateM (RewriteC CL, Maybe Expr) + +-- | Search for an eligible nested comprehension in the current guard +-- and unnest it. Returns the tuplifying rewrite for the outer +-- generator variable 'x', the new generator with the nesting +-- operator, and the modified predicate. +unnestGuardT :: [Ident] -> (Ident, Expr) -> Expr -> TransformC CL (RewriteC CL, Expr, Expr) +unnestGuardT localGenVars (x, xs) guardExpr = do + -- search for an unnestable comrehension + (headCompPath, headComp) <- withLocalPathT + $ constNodeT guardExpr >>> searchNestedCompT x + + -- Forbid the generator of a comprehension we want to unnest to + -- depend on *any* generator in the current outer + -- comprehension. This is to prevent that the right input of a + -- NestProduct that could be constructed depends on *any* + -- preceding generator. See lablog (31.07.14) for a more elaborate + -- explanation. + guardM $ null $ localGenVars `intersect` freeVars (snd $ hGen headComp) + + -- combine inner and outer comprehension + (headComp', nestOp, tuplifyOuterR) <- unnestWorkerT headComp (x, xs) + + -- Tuplify occurences of 'x' in the guard. + ExprCL tuplifiedGuardExpr <- constNodeT guardExpr + >>> tryR tuplifyOuterR + + -- Insert the new inner comprehension into the original guard + -- expression + ExprCL simplifiedGuardExpr <- constNodeT tuplifiedGuardExpr + >>> pathR headCompPath (constNodeT headComp') + + + return (tuplifyOuterR, nestOp, simplifiedGuardExpr) + +-- | Search for unnestable combinations of a generator and a nested +-- guard in a qualifier list. +unnestQualsR :: [Ident] -> Rewrite CompCtx GuardM (NL Qual) +unnestQualsR localGenVars = do + readerT $ \quals -> case quals of + -- In the middle of a qualifier list + BindQ x xs :* GuardQ p :* qs -> do + (tuplifyHeadR, xs', p') <- liftstateT $ constNodeT p + >>> + unnestGuardT localGenVars (x, xs) p + constT $ modify (\(r, _) -> (r >>> tuplifyHeadR, Just p')) + qs' <- liftstateT $ constNodeT qs >>> tuplifyHeadR >>> projectT + return $ BindQ x xs' :* qs' + + -- At the end of a qualifier list + BindQ x xs :* (S (GuardQ p)) -> do + (tuplifyHeadR, xs', p') <- liftstateT $ constNodeT p + >>> + unnestGuardT localGenVars (x, xs) p + constT $ modify (\(r, _) -> (r >>> tuplifyHeadR, Just p')) + return $ S $ BindQ x xs' + _ -> fail "no match" + +-- | Trigger the search for unnesting opportunities in the qualifier +-- list and tuplify comprehension head and remaining qualifiers on +-- success. +-- +-- Note: In contrast to e.g. flat join introduction, we can't merge +-- the complete guard into the operator. The non-comprehension part +-- remains. We handle this by including the succesfully unnested and +-- modified guard in the list of failed guard expressions, even on +-- success. +unnestGuardR :: [Expr] -> [Expr] -> TransformC CL (CL, [Expr], [Expr]) +unnestGuardR candGuards failedGuards = do + Comp t _ qs <- promoteT idR + let localGenVars = concatMap (either ((: []) . fst) (const [])) $ map fromQual $ toList qs + let unnestR = anytdR (promoteR $ unnestQualsR localGenVars) >>> projectT + ((tuplifyVarR, Just guardExpr), qs') <- statefulT (idR, Nothing) $ childT CompQuals unnestR + + h' <- childT CompHead tuplifyVarR >>> projectT + let tuplifyM e = constNodeT e >>> tuplifyVarR >>> projectT + candGuards' <- mapM tuplifyM candGuards + failedGuards' <- mapM tuplifyM failedGuards + return (inject $ Comp t h' qs', candGuards', guardExpr : failedGuards') + +-- | Worker for the MergeGuard iterator: Insert the current guard into +-- the qualifier list and search for an unnesting opportunity. +unnestGuardWorkerR :: MergeGuard +unnestGuardWorkerR comp guardExpr candGuards failedGuards = do + let C ty h qs = comp + env <- S.fromList <$> M.keys <$> cl_bindings <$> contextT + let compWithGuard = constT $ return $ ExprCL $ Comp ty h (insertGuard guardExpr env qs) + (comp', candGuards', failedGuards') <- compWithGuard >>> unnestGuardR candGuards failedGuards + ExprCL (Comp _ h' qs') <- return comp' + return (C ty h' qs', candGuards', failedGuards') + +unnestFromGuardR :: RewriteC CL +unnestFromGuardR = mergeGuardsIterR unnestGuardWorkerR + + +-------------------------------------------------------------------------------- +-- Rules that bring nested comprehension patterns into forms that are +-- suitable for unnesting + +-- | De-Normalization: This rule is the inverse of rule M-Norm-3 +-- [ [ f y | y <- g x ] x <- xs ] +-- => +-- [ [ f z | z <- y ] | y <- [ g x | x <- xs ] ] +-- provided that +-- (a) g is complex/expensive +-- (b) g contains a comprehension +-- +-- The original comprehension produces a collection for every rule of +-- the outer collection xs and then directly performs an action on all +-- elements of the inner collections. The problem here is that the +-- comprehension nested in g might be combined into a nesting operator +-- with xs (maybe even a nestjoin), but the enclosing comprehension +-- blocks this. + +-------------------------------------------------------------------------------- +-- Other forms of unnesting + +isComplexExpr :: Expr -> Bool +isComplexExpr e = + case e of + Comp{} -> True + If{} -> True + BinOp{} -> True + UnOp{} -> True + AppE2 _ op _ _ -> complexPrim2 op + AppE1 _ op _ -> complexPrim1 op + Lit{} -> False + Var{} -> False + Table{} -> False + MkTuple{} -> False + Let{} -> False + +containsComplexExprT :: TransformC CL () +containsComplexExprT = onetdT isComplexExprT + where + isComplexExprT :: TransformC CL () + isComplexExprT = do + e <- promoteT idR + guardM $ isComplexExpr e + return () + +-- | If a inner comprehension iterates over a complex function of the +-- outer element, pull the function out. The motivation of this +-- rewrite is the following: f is work performed in the head for every +-- x. The rewrite does not change that (f actually has to be performed +-- for every x), but it moves the work out of the head. This might +-- enable subsequent rewrites to move f out of the head of other +-- enclosing comprehensions as well (model use case: dft). +-- +-- [ [ e x y | y <- f x ] | x <- xs ] +-- => [ [ f [x/fst z] y | y <- snd z ] | z <- zip xs [ f x | x <- xs ] ] +-- +-- provided that f is "complex". +-- +-- We need the zip to provide the correlation between one x and the +-- group produced by f for this particular x. +-- +-- Note: This rule is actually a special case of the inverse M-Norm-3 +-- rule provided above. +zipCorrelatedR :: RewriteC CL +zipCorrelatedR = do + Comp to (Comp ti e (S (BindQ y f))) (S (BindQ x xs)) <- promoteT idR + + let fvs = freeVars e + guardM $ x `elem` fvs && y `elem` fvs + + guardM $ x `elem` freeVars f + + -- Is f complex as required? + void $ pathT [CompHead, CompQuals, QualsSingleton, BindQualExpr] containsComplexExprT + + z <- freshNameT [y] + + let genComp = Comp (listT $ typeOf f) f (S $ BindQ x xs) + zipGen = P.zip xs genComp + zt = elemT $ typeOf zipGen + zv = Var zt z + + ExprCL f' <- constNodeT e >>> substR x (P.fst zv) + + let innerComp = Comp ti f' (S $ BindQ y (P.snd zv)) + outerComp = Comp to innerComp (S (BindQ z zipGen)) + + return $ inject outerComp + +-------------------------------------------------------------------------------- +-- Normalization of nesting patterns + +-- | Consider the case in which a comprehension is hidden in the +-- generator of an inner comprehension, such that the generator +-- depends on the outer variable and the inner comprehension can not +-- be unnested. +-- +-- In this case, perform the inverse rewrite to M-Norm-3: Nest the +-- generator expression into the outer comprehension +-- +-- [ [ e y | y <- g x ] | x <- xs ] +-- => +-- [ [ e y | y <- z ] | z <- [ g x | x <- xs ] ] +-- +-- provided that g contains at least one unnestable comprehension +-- +-- Important: This is the dual rewrite to M-Norm-3. An unconditional +-- application will lead into a rewriting loop. It **must** be +-- combined with a rewrite that makes progress on g and xs. +nestingGenR :: RewriteC CL +nestingGenR = do + Comp to (Comp ti e (S (BindQ y g))) (S (BindQ x xs)) <- promoteT idR + + -- Generator expression g should depend on x (otherwise we could + -- unnest directly + guardM $ x `elem` freeVars g + + -- Generator expression g should contain at least one unnestable + -- comprehension + void $ constNodeT g >>> searchNestedCompT x + + z <- freshNameT [] + + let gty = typeOf g + + let innerComp = Comp ti e (S (BindQ y (Var gty z))) + genComp = Comp (listT gty) g (S (BindQ x xs)) + outerComp = Comp to innerComp (S (BindQ z genComp)) + + return $ inject outerComp diff --git a/src/Database/DSH/CL/Opt/Normalize.hs b/src/Database/DSH/CL/Opt/Normalize.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/Normalize.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Normalize patterns from source programs (not to be confused with +-- comprehension normalization) +module Database.DSH.CL.Opt.Normalize + ( normalizeOnceR + , normalizeExprR + ) where + +import Control.Monad +import Control.Arrow +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import Data.Monoid + +import Database.DSH.Impossible +import Database.DSH.Common.Lang +import Database.DSH.CL.Lang +import Database.DSH.CL.Kure +import qualified Database.DSH.CL.Primitives as P +import Database.DSH.CL.Opt.Auxiliary + +------------------------------------------------------------------ +-- Simple normalization rewrites that are applied only at the start of +-- rewriting. + +-- Rewrites that are expected to only match once in the beginning and whose +-- pattern should not occur due to subsequent rewrites. + +-- | Split conjunctive predicates. +splitConjunctsR :: RewriteC (NL Qual) +splitConjunctsR = splitR <+ splitEndR + where + splitR :: RewriteC (NL Qual) + splitR = do + (GuardQ (BinOp _ (SBBoolOp Conj) p1 p2)) :* qs <- idR + return $ GuardQ p1 :* GuardQ p2 :* qs + + splitEndR :: RewriteC (NL Qual) + splitEndR = do + (S (GuardQ (BinOp _ (SBBoolOp Conj) p1 p2))) <- idR + return $ GuardQ p1 :* (S $ GuardQ p2) + +normalizeOnceR :: RewriteC CL +normalizeOnceR = repeatR $ anytdR $ promoteR splitConjunctsR + +-------------------------------------------------------------------------------- +-- Simple normalization rewrites that are interleaved with other rewrites. + +normalizeExprR :: RewriteC CL +normalizeExprR = readerT $ \expr -> case expr of + ExprCL AppE1{} -> comprehensionNullR + ExprCL UnOp{} -> notNullR <+ notExistsR + ExprCL BinOp{} -> zeroLengthR + ExprCL Let{} -> unusedBindingR <+ simpleBindingR <+ referencedOnceR + _ -> fail "not a normalizable expression" + +-------------------------------------------------------------------------------- +-- Normalization rewrites for universal/existential quantification. + +pattern PEq e1 e2 <- BinOp _ (SBRelOp Eq) e1 e2 +pattern PLength e <- AppE1 _ Length e +pattern PAnd xs <- AppE1 _ And xs +pattern POr xs <- AppE1 _ Or xs +pattern PNot e <- UnOp _ (SUBoolOp Not) e +pattern PNull e <- AppE1 _ Null e + +-- Bring a NOT EXISTS pattern into universal quantification form: +-- not (or [ q | y <- ys, ps ]) +-- => +-- and [ not q | y <- ys, ps ] +notExistsR :: RewriteC CL +notExistsR = promoteT $ readerT $ \e -> case e of + -- With range predicates + PNot (POr (Comp t q (BindQ y ys :* ps))) -> do + + -- All remaining qualifiers have to be guards. + void $ constT $ T.mapM fromGuard ps + + return $ inject $ P.and $ Comp t (P.not q) (BindQ y ys :* ps) + + -- Without range predicates + PNot (POr (Comp t q (S (BindQ y ys)))) -> do + return $ inject $ P.and $ Comp t (P.not q) (S $ BindQ y ys) + + _ -> fail "no match" + +-- Normalization of null occurences +-- length xs == 0 => null xs +-- 0 == length xs => null xs +zeroLengthR :: RewriteC CL +zeroLengthR = promoteT $ readerT $ \e -> case e of + PEq (PLength xs) (Lit _ (IntV 0)) -> return $ inject $ P.null xs + PEq (Lit _ (IntV 0)) (PLength xs) -> return $ inject $ P.null xs + _ -> fail "no match" + +-- null [ _ | x <- xs, p1, p2, ... ] +-- => and [ not (p1 && p2 && ...) | x <- xs ] +comprehensionNullR :: RewriteC CL +comprehensionNullR = do + PNull (Comp _ _ (BindQ x xs :* guards)) <- promoteT idR + + -- We need exactly one generator and at least one guard. + guardExprs <- constT $ T.mapM fromGuard guards + + -- Merge all guards into a conjunctive form + let conjPred = P.not $ F.foldl1 P.conj guardExprs + return $ inject $ P.and $ Comp (listT boolT) conjPred (S $ BindQ x xs) + +-- not $ null [ _ | x <- xs, ps ] +-- => +-- not $ and [ not ps | x <- xs ] (comprehensionNullR) +-- => +-- or [ ps | x <- xs ] +notNullR :: RewriteC CL +notNullR = do + PNot (PAnd (Comp _ (PNot p) (S (BindQ x xs)))) <- promoteT idR + return $ inject $ P.or (Comp (listT boolT) p (S (BindQ x xs))) + +-------------------------------------------------------------------------------- +-- Inline let bindings + +-- | This function inlines let-bound expressions. In contrast to +-- general substitution, we do not inline into comprehensions, even if +-- we could. The reason is that expressions should not be evaluated +-- iteratively if they are loop-invariant. +inlineBindingR :: Ident -> Expr -> RewriteC CL +inlineBindingR v s = readerT $ \expr -> case expr of + -- Occurence of the variable to be replaced + ExprCL (Var _ n) | n == v -> return $ inject s + + -- If a let-binding shadows the name we substitute, only descend + -- into the bound expression. + ExprCL (Let _ n _ _) | n == v -> promoteR $ letR (extractR $ inlineBindingR v s) idR + ExprCL (Let _ n _ _) | otherwise -> + if n `elem` freeVars s + -- If the let-bound name occurs free in the substitute, + -- alpha-convert the binding to avoid capturing the name. + then $unimplemented >>> anyR (substR v s) + else anyR $ inlineBindingR v s + + -- We don't inline into comprehensions to avoid conflicts with + -- loop-invariant extraction. + ExprCL (Comp _ _ _) -> idR + ExprCL _ -> anyR $ inlineBindingR v s + _ -> $impossible + +-- | Count all occurences of an identifier for let-inlining. +countVarRefT :: Ident -> TransformC CL (Sum Int) +countVarRefT v = readerT $ \expr -> case expr of + -- Occurence of the variable to be replaced + ExprCL (Var _ n) | n == v -> return 1 + ExprCL (Var _ _) | otherwise -> return 0 + + ExprCL (Let _ n _ _) | n == v -> promoteT $ letT (constT $ return 0) + (extractT $ countVarRefT v) + (\_ _ c1 c2 -> c1 + c2) + ExprCL (Let _ _ _ _) | otherwise -> promoteT $ letT (extractT $ countVarRefT v) + (extractT $ countVarRefT v) + (\_ _ c1 c2 -> c1 + c2) + + ExprCL (Comp _ _ qs) | v `elem` compBoundVars qs -> promoteT $ compT (constT $ return 0) + (extractT $ countVarRefT v) + (\_ c1 c2 -> c1 + c2) + ExprCL (Comp _ _ _) | otherwise -> promoteT $ compT (extractT $ countVarRefT v) + (extractT $ countVarRefT v) + (\_ c1 c2 -> c1 + c2) + ExprCL Table{} -> return 0 + ExprCL Lit{} -> return 0 + + ExprCL _ -> allT (countVarRefT v) + + QualsCL (BindQ v' _ :* _) | v == v' -> childT QualsHead (countVarRefT v) + QualsCL _ -> allT (countVarRefT v) + + QualCL _ -> allT (countVarRefT v) + +-- | Remove a let-binding that is not referenced. +unusedBindingR :: RewriteC CL +unusedBindingR = do + Let _ x _ e2 <- promoteT idR + 0 <- childT LetBody $ countVarRefT x + return $ inject e2 + +-- | Inline a let-binding that is only referenced once. +referencedOnceR :: RewriteC CL +referencedOnceR = do + Let _ x e1 _ <- promoteT idR + 1 <- childT LetBody $ countVarRefT x + + -- We do not inline into comprehensions, but 'countVarRef' counts + -- all occurences including those in comprehensions. For this + -- reason, we check if the occurence was actually eliminated by + -- inlining and fail otherwise. + body' <- childT LetBody (inlineBindingR x e1) + 0 <- (constT $ return body') >>> countVarRefT x + return body' + +simpleExpr :: Expr -> Bool +simpleExpr Table{} = True +simpleExpr Var{} = True +simpleExpr _ = False + +-- | Inline a let-binding that binds a simple expression. +simpleBindingR :: RewriteC CL +simpleBindingR = do + Let _ x e1 _ <- promoteT idR + guardM $ simpleExpr e1 + childR LetBody $ substR x e1 + diff --git a/src/Database/DSH/CL/Opt/PartialEval.hs b/src/Database/DSH/CL/Opt/PartialEval.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/PartialEval.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Support rewrites (partial evaluation, house cleaning) +module Database.DSH.CL.Opt.PartialEval + ( partialEvalR + ) where + +import Database.DSH.Common.Nat +import Database.DSH.Common.Lang +import Database.DSH.CL.Lang +import Database.DSH.CL.Kure + +-------------------------------------------------------------------------------- +-- Partial evaluation rules + +-- | Eliminate tuple construction if the elements are first and second of the +-- same pair: +-- pair (fst x) (snd x) => x +identityPairR :: RewriteC CL +identityPairR = do + MkTuple _ [ AppE1 _ (TupElem First) v@(Var tupleTy x) + , AppE1 _ (TupElem (Next First)) (Var _ x') + ] <- promoteT idR + + -- Check that the original value actually was a /pair/ and that no + -- elements are discarded. + TupleT [_, _] <- return tupleTy + + guardM $ x == x' + return $ inject v + +tupleElemR :: RewriteC CL +tupleElemR = do + AppE1 _ (TupElem i) (MkTuple _ es) <- promoteT idR + return $ inject $ es !! (tupleIndex i - 1) + +fromLiteral :: Expr -> TransformC CL Val +fromLiteral (Lit _ val) = return val +fromLiteral _ = fail "not a literal" + +literalTupleR :: RewriteC CL +literalTupleR = do + MkTuple tupTy elems <- promoteT idR + vals <- mapM fromLiteral elems + return $ inject $ Lit tupTy $ TupleV vals + +literalAppendR :: RewriteC CL +literalAppendR = do + AppE2 listTy Append x y <- promoteT idR + ListV xVals <- fromLiteral x + ListV yVals <- fromLiteral y + return $ inject $ Lit listTy $ ListV $ xVals ++ yVals + +literalSingletonR :: RewriteC CL +literalSingletonR = do + AppE1 listTy Singleton x <- promoteT idR + xVal <- fromLiteral x + return $ inject $ Lit listTy $ ListV [xVal] + +appendEmptyLeftR :: RewriteC CL +appendEmptyLeftR = do + AppE2 _ Append (Lit _ (ListV [])) ys <- promoteT idR + return $ inject ys + +appendEmptyRightR :: RewriteC CL +appendEmptyRightR = do + AppE2 _ Append xs (Lit _ (ListV [])) <- promoteT idR + return $ inject xs + +partialEvalR :: RewriteC CL +partialEvalR = + readerT $ \cl -> case cl of + ExprCL AppE1{} -> tupleElemR <+ literalSingletonR + ExprCL MkTuple{} -> identityPairR <+ literalTupleR + ExprCL AppE2{} -> literalAppendR <+ appendEmptyLeftR <+ appendEmptyRightR + _ -> fail "can't apply partial evaluation rules" diff --git a/src/Database/DSH/CL/Opt/PostProcess.hs b/src/Database/DSH/CL/Opt/PostProcess.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/PostProcess.hs @@ -0,0 +1,72 @@ +module Database.DSH.CL.Opt.PostProcess + ( introduceCartProductsR + ) where + +import Control.Arrow + +import Database.DSH.Common.Lang +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang +import Database.DSH.CL.Opt.Auxiliary +import qualified Database.DSH.CL.Primitives as P + +-------------------------------------------------------------------------------- + + +-------------------------------------------------------------------------------- +-- Turn adjacent generators into cartesian products: +-- [ e | ..., x <- xs, y <- ys, qs ] +-- => +-- [ e[x/fst x][y/snd x] | ..., x <- xs × ys, qs[x/fst x][y/snd x] ] + +mkproduct :: (Ident, Expr) -> (Ident, Expr) -> (RewriteC CL, Qual) +mkproduct (x, xs) (y, ys) = + -- Conditions for the rewrite are fulfilled. + let xst = typeOf xs + yst = typeOf ys + xt = elemT xst + yt = elemT yst + tuplifyHeadR = tuplifyR x (x, xt) (y, yt) + joinGen = BindQ x (P.cartproduct xs ys) + + in (tuplifyHeadR, joinGen) + +cartProductR :: Rewrite CompCtx TuplifyM (NL Qual) +cartProductR = do + readerT $ \e -> case e of + BindQ x xs :* BindQ y ys :* qs -> do + -- xs and ys generators must be independent + guardM $ x `notElem` freeVars ys + + let (tuplifyHeadR, q') = mkproduct (x, xs) (y, ys) + -- Next, we apply the tuplifyHeadR rewrite to the tail, + -- i.e. to all following qualifiers + -- FIXME why is extractT required here? + qs' <- catchesT [ liftstateT $ (constT $ return qs) + >>> (extractR tuplifyHeadR) + , constT $ return qs + ] + + -- The tuplify rewrite must be handed to the top level + constT $ put tuplifyHeadR + + return $ q' :* qs' + + BindQ x xs :* (S (BindQ y ys)) -> do + -- xs and ys generators must be independent + guardM $ x `notElem` freeVars ys + + let (tuplifyHeadR, q') = mkproduct (x, xs) (y, ys) + + -- The tuplify rewrite must be handed to the top level + constT $ put tuplifyHeadR + + return (S q') + _ -> fail "no match" + +introduceCartProductsR :: RewriteC CL +introduceCartProductsR = do + Comp t _ _ <- promoteT idR + (tuplifyHeadR, qs') <- statefulT idR $ childT CompQuals (promoteR cartProductR) >>> projectT + ExprCL h' <- childT CompHead tuplifyHeadR + return $ inject $ Comp t h' qs' diff --git a/src/Database/DSH/CL/Opt/PredPushdown.hs b/src/Database/DSH/CL/Opt/PredPushdown.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/PredPushdown.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module implements predicate pushdown on comprehensions. +module Database.DSH.CL.Opt.PredPushdown + ( predpushdownR + ) where + +import Control.Applicative +import Control.Arrow +import qualified Data.List.NonEmpty as N +import qualified Data.Set as S + +import Database.DSH.Common.Lang +import Database.DSH.Common.Nat +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang +import Database.DSH.CL.Opt.Auxiliary + +-------------------------------------------------------------------------------- +-- Auxiliary functions + +-- | Return path to occurence of variable x +varPathT :: Ident -> TransformC CL PathC +varPathT x = do + Var _ x' <- promoteT idR + guardM $ x == x' + snocPathToPath <$> absPathT + +-- | Collect all paths to variable x in the current expression and +-- turn them into relative paths. +allVarPathsT :: Ident -> TransformC CL [PathC] +allVarPathsT x = do + varPaths <- collectT $ varPathT x + guardM $ not $ null varPaths + parentPathLen <- length <$> snocPathToPath <$> absPathT + let localPaths = map (init . drop parentPathLen) varPaths + return localPaths + +-- | All occurences of variable x must occur in the form of a tuple +-- accessor, either fst or snd. Remove this tuple accessor. +unTuplifyR :: (Prim1 -> Bool) -> PathC -> RewriteC CL +unTuplifyR isTupleOp path = pathR path $ do + AppE1 ty op (Var _ x) <- promoteT idR + guardM $ isTupleOp op + return $ inject $ Var ty x + +-------------------------------------------------------------------------- +-- Push a guard into a branch of a join operator + +-- | Try to push predicate into the left input of a binary operator +-- which produces tuples: equijoin, nestjoin, nestproduct +pushLeftTupleR :: Ident -> Expr -> RewriteC CL +pushLeftTupleR x p = do + AppE2 t op xs ys <- promoteT idR + + let predTrans = constT $ return $ inject p + + localPaths <- predTrans >>> allVarPathsT x + + ExprCL p' <- predTrans >>> andR (map (unTuplifyR (== (TupElem First))) localPaths) + + let xst = typeOf xs + + let filterComp = Comp xst (Var (elemT xst) x) (BindQ x xs :* S (GuardQ p')) + return $ inject $ AppE2 t op filterComp ys + +-- | Try to push predicate into the right input of a binary operator +-- which produces tuples: equijoin +pushRightTupleR :: Ident -> Expr -> RewriteC CL +pushRightTupleR x p = do + AppE2 t op xs ys <- promoteT idR + + let predTrans = constT $ return $ inject p + + localPaths <- predTrans >>> allVarPathsT x + + ExprCL p' <- predTrans >>> andR (map (unTuplifyR (== (TupElem (Next (First))))) localPaths) + + let yst = typeOf ys + + let filterComp = Comp yst (Var (elemT yst) x) (BindQ x ys :* S (GuardQ p')) + return $ inject $ AppE2 t op xs filterComp + +pushLeftOrRightTupleR :: Ident -> Expr -> RewriteC CL +pushLeftOrRightTupleR x p = pushLeftTupleR x p <+ pushRightTupleR x p + +-- | Try to push predicates into the left input of a binary operator +-- which produces only the left input, i.e. semijoin, antijoin +pushLeftR :: Ident -> Expr -> RewriteC CL +pushLeftR x p = do + AppE2 ty op xs ys <- promoteT idR + let xst = typeOf xs + let xs' = Comp xst (Var (elemT xst) x) (BindQ x xs :* (S $ GuardQ p)) + return $ inject $ AppE2 ty op xs' ys + +-------------------------------------------------------------------------- +-- Merging of join predicates into already established theta-join +-- operators +-- +-- A predicate can be merged into a theta-join as an additional +-- conjunct if it has the shape of a join predicate and if its left +-- expression refers only to the fst component of the join pair and +-- the right expression refers only to the snd component (or vice +-- versa). + +mkMergeableJoinPredT :: Ident -> Expr -> BinRelOp -> Expr -> TransformC CL (JoinConjunct JoinExpr) +mkMergeableJoinPredT x leftExpr op rightExpr = do + let constLeftExpr = constT $ return $ inject leftExpr + constRightExpr = constT $ return $ inject rightExpr + + leftVarPaths <- constLeftExpr >>> allVarPathsT x + rightVarPaths <- constRightExpr >>> allVarPathsT x + + leftExpr' <- constLeftExpr + >>> andR (map (unTuplifyR (== (TupElem First))) leftVarPaths) + >>> projectT + >>> toJoinExpr x + + rightExpr' <- constRightExpr + >>> andR (map (unTuplifyR (== (TupElem (Next First)))) rightVarPaths) + >>> projectT + >>> toJoinExpr x + + return $ JoinConjunct leftExpr' op rightExpr' + +mirrorRelOp :: BinRelOp -> BinRelOp +mirrorRelOp Eq = Eq +mirrorRelOp Gt = Lt +mirrorRelOp GtE = LtE +mirrorRelOp Lt = Gt +mirrorRelOp LtE = GtE +mirrorRelOp NEq = NEq + +splitMergeablePredT :: Ident -> Expr -> TransformC CL (JoinConjunct JoinExpr) +splitMergeablePredT x p = do + ExprCL (BinOp _ (SBRelOp op) leftExpr rightExpr) <- return $ inject p + guardM $ freeVars p == [x] + + -- We might have e1(fst x) op e2(snd x) or e1(snd x) op e2(fst x) + mkMergeableJoinPredT x leftExpr op rightExpr + <+ mkMergeableJoinPredT x rightExpr (mirrorRelOp op) leftExpr + +-- | If a predicate can be turned into a join predicate, merge it into +-- the current theta join. +mergePredIntoJoinR :: Ident -> Expr -> RewriteC CL +mergePredIntoJoinR x p = do + AppE2 t (ThetaJoin (JoinPred ps)) xs ys <- promoteT idR + joinConjunct <- splitMergeablePredT x p + + let extendedJoin = ThetaJoin (JoinPred $ joinConjunct N.<| ps) + + return $ inject $ AppE2 t extendedJoin xs ys + +-- | Push into the /first/ argument (input) of some operator that +-- commutes with selection. + +-- This was nicer with a higher-order 'sortWith'. With first-order +-- 'sort', we have to push the predicate into both arguments, which +-- works only if the comprehension for the sorting criteria is still +-- in its original form. +pushSortInputR :: Ident -> Expr -> RewriteC CL +pushSortInputR x p = do + AppE2 t Sort xs (Comp st se (S (BindQ x' xs'))) <- promoteT idR + + -- FIXME this compares whole terms in an uncontrolled way and + -- could be too expensive. + guardM $ xs == xs' + guardM $ x == x' + + let xst = typeOf xs + xt = elemT xt + -- We reuse the generator variable for the filter comprehension + xsFiltered = Comp xst (Var xt x) (BindQ x xs :* S (GuardQ p)) + ssFiltered = Comp st se (BindQ x' xs' :* S (GuardQ p)) + + return $ inject $ AppE2 t Sort xsFiltered ssFiltered + +-------------------------------------------------------------------------- +-- Take remaining comprehension guards and try to push them into the +-- generator. This might be accomplished by either merging it into a +-- join, pushing it into a join input or pushing it through some other +-- operator that commutes with selection (e.g. sorting). + +pushPredicateR :: Ident -> Expr -> RewriteC CL +pushPredicateR x p = do + readerT $ \e -> case e of + -- First, try to merge the predicate into the join. For + -- regular joins and products, non-join predicates might apply + -- to the left or right input. + ExprCL (AppE2 _ (ThetaJoin _) _ _) -> mergePredIntoJoinR x p + <+ pushLeftOrRightTupleR x p + ExprCL (AppE2 _ CartProduct _ _) -> pushLeftOrRightTupleR x p + + -- For nesting operators, a guard can only refer to the left + -- input, i.e. the original outer generator. + + -- FIXME why commented out? + -- ExprCL (AppE2 _ (Prim2 (NestProduct _ _) _) _ _) -> pushLeftTupleR p + ExprCL (AppE2 _ (NestJoin _) _ _) -> pushLeftTupleR x p + + -- Semi- and Antijoin operators produce a subset of their left + -- input. A filter can only apply to the left input, + -- consequently. + ExprCL (AppE2 _ (SemiJoin _) _ _) -> pushLeftR x p + ExprCL (AppE2 _ (AntiJoin _) _ _) -> pushLeftR x p + + -- Sorting commutes with selection + ExprCL (AppE2 _ Sort _ _) -> pushSortInputR x p + _ -> fail "expression does not allow predicate pushing" + +pushQualsR :: RewriteC CL +pushQualsR = do + BindQ x _ :* GuardQ p :* qs <- promoteT idR + [x'] <- return $ freeVars p + guardM $ x == x' + ExprCL gen' <- pathT [QualsHead, BindQualExpr] (pushPredicateR x p) + return $ inject $ BindQ x gen' :* qs + +pushQualsEndR :: RewriteC CL +pushQualsEndR = do + BindQ x _ :* (S (GuardQ p)) <- promoteT idR + [x'] <- return $ freeVars p + guardM $ x == x' + ExprCL gen' <- pathT [QualsHead, BindQualExpr] (pushPredicateR x p) + return $ inject $ S $ BindQ x gen' + +pushDownSinglePredR :: RewriteC CL +pushDownSinglePredR = do + Comp _ _ _ <- promoteT idR + childR CompQuals (promoteR $ pushQualsR <+ pushQualsEndR) + +pushDownPredsR :: MergeGuard +pushDownPredsR comp guard guardsToTry leftOverGuards = do + let C ty h qs = comp + env <- S.fromList <$> inScopeNames <$> contextT + let compExpr = ExprCL $ Comp ty h (insertGuard guard env qs) + ExprCL (Comp _ _ qs') <- constT (return compExpr) >>> pushDownSinglePredR + return (C ty h qs', guardsToTry, leftOverGuards) + +-- | Push down all guards in a qualifier list, if possible. +predpushdownR :: RewriteC CL +predpushdownR = mergeGuardsIterR pushDownPredsR diff --git a/src/Database/DSH/CL/Opt/Resugar.hs b/src/Database/DSH/CL/Opt/Resugar.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/Resugar.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | Resguaring rules that restore a source comprehension form from +-- the desugared 'concatMap' form. +module Database.DSH.CL.Opt.Resugar + ( resugarR + ) where + +import Control.Arrow + +import Database.DSH.Common.Lang +import Database.DSH.Common.Kure +import Database.DSH.CL.Lang +import Database.DSH.CL.Kure +import Database.DSH.CL.Opt.PartialEval + +pattern ConcatP xs <- AppE1 _ Concat xs +pattern SingletonP x <- AppE1 _ Singleton x +pattern GuardP p <- AppE1 _ Guard p + +-- | Eliminate a singleton list in a comprehension head. +-- concat [ [e] | qs ] => [ e | qs ] +concatCompSingletonR :: RewriteC CL +concatCompSingletonR = do + ConcatP (Comp (ListT ty) (SingletonP e) qs) <- promoteT idR + return $ inject $ Comp ty e qs + +-- | Eliminate a singleton literal list in a comprehension head. +-- concat [ [v] | qs ] => [ v | qs ] +concatCompSingletonLitR :: RewriteC CL +concatCompSingletonLitR = do + ConcatP (Comp _ (Lit (ListT ty) (ListV [v])) qs) <- promoteT idR + return $ inject $ Comp (ListT $ ListT ty) (Lit ty v) qs + +-- | Merge nested comprehensions +-- concat [ [ e | qs' ] | qs ] => [ e | qs, qs' ] +concatNestedCompR :: RewriteC CL +concatNestedCompR = do + ConcatP (Comp _ (Comp compTy innerHead innerQs) outerQs) <- promoteT idR + return $ inject $ Comp compTy innerHead (appendNL outerQs innerQs) + +-- | Eliminate the guard combinator +-- [ e | qs, x <- guard p, qs' ] => [ e | qs, p, qs' ] +-- FIXME To be extra sure, we should check wether x occurs free in or qs' +guardGeneratorR :: RewriteC (NL Qual) +guardGeneratorR = readerT $ \qual -> case qual of + BindQ _ (GuardP p) :* qs -> do + return $ GuardQ p :* qs + S (BindQ _ (GuardP p)) -> do + return $ S $ GuardQ p + _ -> fail "not a guard combinator" + +guardGeneratorsR :: RewriteC CL +guardGeneratorsR = do + Comp _ _ _ <- promoteT idR + childR CompQuals (promoteR $ onetdR guardGeneratorR) + +resugarRulesR :: RewriteC CL +resugarRulesR = readerT $ \expr -> case expr of + ExprCL (ConcatP (Comp _ _ _)) -> concatCompSingletonR + <+ concatCompSingletonLitR + <+ concatNestedCompR + ExprCL (Comp _ _ _) -> guardGeneratorsR + ExprCL _ -> partialEvalR + _ -> fail "no resugaring rule applies" + +-- | Resugar a comprehension. +resugarR :: RewriteC CL +resugarR = (repeatR $ anybuR resugarRulesR) >>> debugShow "resugared" diff --git a/src/Database/DSH/CL/Opt/SemiJoin.hs b/src/Database/DSH/CL/Opt/SemiJoin.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/SemiJoin.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Database.DSH.CL.Opt.SemiJoin + ( semijoinR + ) where + +import Control.Arrow +import qualified Data.Traversable as T +import Data.List +import Data.List.NonEmpty(NonEmpty((:|))) +import qualified Data.List.NonEmpty as NL + +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang +import Database.DSH.CL.Opt.Auxiliary +import Database.DSH.Common.Lang +import qualified Database.DSH.CL.Primitives as P + +-------------------------------------------------------------------------------- +-- Introduce semi joins (existential quantification) + +pattern POr xs <- AppE1 _ Or xs +pattern PTrue = Lit BoolT (BoolV True) + +existentialQualR :: RewriteC (NL Qual) +existentialQualR = readerT $ \quals -> case quals of + -- Special case: existential quantifier without a quantifier predicate + -- [ ... | ..., x <- xs, or [ True | y <- ys, ps ], ... ] + BindQ x xs :* (GuardQ (POr (Comp _ PTrue (BindQ y ys :* ps)))) :* qs -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + semijoinGen <- mkExistentialSemiJoinT (x, xs) (y, ys) Nothing (Just ps) + return $ semijoinGen :* qs + + -- Special case: existential quantifier without a quantifier predicate + -- [ ... | ..., x <- xs, or [ True | y <- ys, ps ] ] + BindQ x xs :* (S (GuardQ (POr (Comp _ PTrue (BindQ y ys :* ps))))) -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + semijoinGen <- mkExistentialSemiJoinT (x, xs) (y, ys) Nothing (Just ps) + return $ S semijoinGen + + -- Special case: Existential quantifier without a range predicate + -- [ ... | ..., x <- xs, or [ q | y <- ys ], ... ] + BindQ x xs :* (GuardQ (POr (Comp _ q (S (BindQ y ys))))) :* qs -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + semijoinGen <- mkExistentialSemiJoinT (x, xs) (y, ys) (Just q) Nothing + return $ semijoinGen :* qs + + -- Special case: Existential quantifier without a range predicate + -- [ ... | ..., x <- xs, or [ q | y <- ys ] ] + BindQ x xs :* (S (GuardQ (POr (Comp _ q (S (BindQ y ys)))))) -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + semijoinGen <- mkExistentialSemiJoinT (x, xs) (y, ys) (Just q) Nothing + return $ S semijoinGen + + -- Existential quantifier with range and quantifier predicates + -- [ ... | ..., x <- xs, or [ True | y <- ys, ps ], ... ] + BindQ x xs :* (GuardQ (POr (Comp _ q (BindQ y ys :* ps)))) :* qs -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + semijoinGen <- mkExistentialSemiJoinT (x, xs) (y, ys) (Just q) (Just ps) + return $ semijoinGen :* qs + + -- Existential quantifier with range and quantifier predicates + -- [ ... | ..., x <- xs, or [ True | y <- ys, ps ] ] + BindQ x xs :* (S (GuardQ (POr (Comp _ q (BindQ y ys :* ps))))) -> do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + semijoinGen <- mkExistentialSemiJoinT (x, xs) (y, ys) (Just q) (Just ps) + return $ S semijoinGen + + _ -> fail "no match" + +mkExistentialSemiJoinT :: (Ident, Expr) + -> (Ident, Expr) + -> Maybe Expr + -> Maybe (NL Qual) + -> TransformC (NL Qual) Qual +mkExistentialSemiJoinT (x, xs) (y, ys) mq mps = do + let yst = typeOf ys + yt = elemT yst + + -- All inner qualifiers have to be guards. + guardExprs <- case mps of + Just ps -> constT (T.mapM fromGuard ps) >>^ toList + Nothing -> return [] + + quantExprs <- case mq of + Just q -> constT (return $ inject q) >>> conjunctsT >>^ NL.toList + Nothing -> return [] + + let allExprs = guardExprs ++ quantExprs + + -- We demand at least one predicate expression + guardM $ not $ null allExprs + + -- Separate those guards that can be evaluated just on the + -- inner generator + let (innerGuards, corrGuards) = partition (\e -> freeVars e == [y]) + allExprs + + let ys' = case innerGuards of + ige : iges -> let igs = fmap GuardQ $ fromListSafe ige iges + in Comp yst (Var yt y) (BindQ y ys :* igs) + [] -> ys + + corrPreds <- constT (return corrGuards) >>> mapT (splitJoinPredT x y) + + case corrPreds of + cp : cps -> return $ BindQ x $ P.semijoin xs ys' (JoinPred $ cp :| cps) + _ -> fail "there have to be correlation predicates for a semijoin" + + + +existentialQualsR :: RewriteC (NL Qual) +existentialQualsR = onetdR existentialQualR + +semijoinR :: RewriteC CL +semijoinR = do + Comp _ _ _ <- promoteT idR + childR CompQuals (promoteR existentialQualsR) diff --git a/src/Database/DSH/CL/Opt/ThetaJoin.hs b/src/Database/DSH/CL/Opt/ThetaJoin.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Opt/ThetaJoin.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Introduce simple theta joins. +module Database.DSH.CL.Opt.ThetaJoin + ( thetajoinR + ) where + +import Control.Arrow + +import Database.DSH.CL.Kure +import Database.DSH.CL.Lang +import Database.DSH.CL.Opt.Auxiliary +import Database.DSH.Common.Lang +import qualified Database.DSH.CL.Primitives as P + +-------------------------------------------------------------------------------- +-- Introduce simple theta joins + +-- | Concstruct an thetajoin generator +mkthetajoinT + :: Expr -- ^ The predicate + -> Ident -- ^ Identifier from the first generator + -> Ident -- ^ Identifier from the second generator + -> Expr -- ^ First generator expression + -> Expr -- ^ Second generator expression + -> Transform CompCtx TuplifyM (NL Qual) (RewriteC CL, Qual) +mkthetajoinT joinPred x y xs ys = do + -- Generators have to be indepedent + guardM $ x `notElem` freeVars ys + + -- The predicate must be a join predicate + joinConjunct <- constT (return joinPred) >>> (liftstateT $ splitJoinPredT x y) + + -- Conditions for the rewrite are fulfilled. + let xst = typeOf xs + yst = typeOf ys + xt = elemT xst + yt = elemT yst + tuplifyHeadR = tuplifyR x (x, xt) (y, yt) + joinGen = BindQ x (P.thetajoin xs ys (singlePred joinConjunct)) + + return (tuplifyHeadR, joinGen) + +-- | Match a thetajoin pattern in the middle of a qualifier list +thetajoinQualR :: Rewrite CompCtx TuplifyM (NL Qual) +thetajoinQualR = do + -- We need two generators followed by a predicate + BindQ x xs :* BindQ y ys :* GuardQ p :* qs <- promoteT idR + + (tuplifyHeadR, q') <- mkthetajoinT p x y xs ys + + -- Next, we apply the tuplifyHeadR rewrite to the tail, i.e. to all following + -- qualifiers + -- FIXME why is extractT required here? + qs' <- catchesT [ liftstateT $ (constT $ return qs) >>> (extractR tuplifyHeadR) + , constT $ return qs + ] + + -- The tuplify rewrite must be handed to the top level + constT $ put tuplifyHeadR + + return $ q' :* qs' + +-- | Match a thetajoin pattern at the end of a qualifier list +thetajoinQualEndR :: Rewrite CompCtx TuplifyM (NL Qual) +thetajoinQualEndR = do + -- We need two generators followed by a predicate + BindQ x xs :* BindQ y ys :* (S (GuardQ p)) <- promoteT idR + + (tuplifyHeadR, q') <- mkthetajoinT p x y xs ys + + -- The tuplify rewrite must be handed to the top level + constT $ put tuplifyHeadR + + return (S q') + +thetajoinQualsR :: Rewrite CompCtx TuplifyM (NL Qual) +thetajoinQualsR = onetdR (thetajoinQualEndR <+ thetajoinQualR) + +thetajoinR :: [Expr] -> [Expr] -> TransformC CL (CL, [Expr], [Expr]) +thetajoinR currentGuards testedGuards = do + Comp t _ _ <- promoteT idR + (tuplifyHeadR, qs') <- statefulT idR $ childT CompQuals (promoteR thetajoinQualsR >>> projectT) + e' <- (tryR $ childT CompHead tuplifyHeadR) >>> projectT + -- FIXME should propably wrap tuplifyHeadR in tryR + currentGuards' <- constT (return currentGuards) >>> mapT (extractR tuplifyHeadR) + testedGuards' <- constT (return testedGuards) >>> mapT (extractR tuplifyHeadR) + return $ (inject $ Comp t e' qs', currentGuards', testedGuards') diff --git a/src/Database/DSH/CL/Primitives.hs b/src/Database/DSH/CL/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/CL/Primitives.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Smart constructors for CL primitives +module Database.DSH.CL.Primitives where + +import qualified Prelude as P + +import qualified Data.List as List +import Text.Printf + +import Database.DSH.CL.Lang +import qualified Database.DSH.Common.Lang as L +import Database.DSH.Common.Nat +import Database.DSH.Common.Pretty +import Database.DSH.Impossible + +tyErr :: P.String -> a +tyErr comb = P.error P.$ printf "CL.Primitives type error in %s" comb + +tyErrShow :: P.String -> [Type] -> a +tyErrShow comb ts = P.error (printf "CL.Primitives type error in %s: %s" comb (P.show P.$ P.map pp ts)) + +if_ :: Expr -> Expr -> Expr -> Expr +if_ c t e = if BoolT P.== typeOf c + then If (typeOf t) c t e + else tyErr "if_" + +reverse :: Expr -> Expr +reverse e = let t@(ListT _) = typeOf e + in AppE1 t Reverse e + +length :: Expr -> Expr +length e = let t = typeOf e + in if isList t + then AppE1 intT Length e + else tyErr "length" + +null :: Expr -> Expr +null e = + if isList t + then AppE1 boolT Null e + else tyErr "null" + + where t = typeOf e + +and :: Expr -> Expr +and e = let t = typeOf e + in if listT boolT P.== t + then AppE1 boolT And e + else tyErrShow "and" [t] + +or :: Expr -> Expr +or e = let t = typeOf e + in if listT boolT P.== t + then AppE1 boolT Or e + else tyErr "or" + +concat :: Expr -> Expr +concat e = let t = typeOf e + in if listDepth t P.> 1 + then AppE1 (unliftType t) Concat e + else tyErr "concat" + +-- reshape :: [a] -> [[a]] +reshape :: P.Integer -> Expr -> Expr +reshape n e = + let t = typeOf e + in AppE1 (ListT t) (Reshape n) e + +-- transpose :: [[a]] -> [[a]] +transpose :: Expr -> Expr +transpose e = + let t = typeOf e + in AppE1 t Transpose e + +sum :: Expr -> Expr +sum e = let (ListT t) = typeOf e + in if isNum t + then AppE1 t Sum e + else tyErr "sum" + +avg :: Expr -> Expr +avg e = let (ListT t) = typeOf e + in if isNum t + then AppE1 doubleT Avg e + else tyErr "avg" + +minimum :: Expr -> Expr +minimum e = let (ListT t) = typeOf e + in if isNum t + then AppE1 t Minimum e + else tyErr "minimum" + +maximum :: Expr -> Expr +maximum e = let (ListT t) = typeOf e + in if isNum t + then AppE1 t Maximum e + else tyErr "maximum" + +the :: Expr -> Expr +the e = let (ListT t) = typeOf e + in AppE1 t The e + +head :: Expr -> Expr +head e = let (ListT t) = typeOf e + in AppE1 t Head e + +last :: Expr -> Expr +last e = let (ListT t) = typeOf e + in AppE1 t Last e + +tail :: Expr -> Expr +tail e = let (ListT t) = typeOf e + in AppE1 (ListT t) Tail e + +nub :: Expr -> Expr +nub e = let (ListT t) = typeOf e + in AppE1 (ListT t) Nub e + +number :: Expr -> Expr +number e = let (ListT t) = typeOf e + in AppE1 (ListT (pairT t IntT )) Number e + +guard :: Expr -> Expr +guard e = AppE1 (listT UnitT) Guard e + +init :: Expr -> Expr +init e = let (ListT t) = typeOf e + in AppE1 (ListT t) Init e + +tupElem :: TupleIndex -> Expr -> Expr +tupElem f e = + let t = tupleElemT (typeOf e) f + in AppE1 t (TupElem f) e + +fst :: Expr -> Expr +fst e = tupElem First e + +snd :: Expr -> Expr +snd e = tupElem (Next First) e + +singleGenComp :: Expr -> L.Ident -> Expr -> Expr +singleGenComp bodyExp v gen = + let bodyTy = typeOf bodyExp + in Comp (listT bodyTy) bodyExp (S P.$ BindQ v gen) + +group :: Expr -> Expr -> Expr +group xs gs = let ListT xt = typeOf xs + ListT grt = typeOf gs + rt = ListT (TupleT [grt, ListT xt]) + in AppE2 rt Group xs gs + +sort :: Expr -> Expr -> Expr +sort xs ss = AppE2 (typeOf xs) Sort xs ss + +pair :: Expr -> Expr -> Expr +pair a b = tuple [a, b] + +tuple :: [Expr] -> Expr +tuple es = + let ts = P.map typeOf es + rt = TupleT ts + in MkTuple rt es + +append :: Expr -> Expr -> Expr +append e1 e2 = let t1@(ListT _) = typeOf e1 + t2@(ListT _) = typeOf e2 + in if t1 P.== t2 + then AppE2 t1 Append e1 e2 + else tyErr "append" + +index :: Expr -> Expr -> Expr +index e1 e2 = let ListT t = typeOf e1 + t2 = typeOf e2 + in if intT P.== t2 + then AppE2 t Index e1 e2 + else tyErr "index" + +sng :: Expr -> Expr +sng e = AppE1 (listT P.$ typeOf e) Singleton e + +zip :: Expr -> Expr -> Expr +zip e1 e2 = let ListT t1' = typeOf e1 + ListT t2' = typeOf e2 + in AppE2 (listT P.$ pairT t1' t2') Zip e1 e2 + +var :: Type -> P.String -> Expr +var = Var + +table :: Type -> P.String -> [L.Column] -> L.TableHints -> Expr +table = Table + +cond :: Expr -> Expr -> Expr -> Expr +cond eb et ee = let tb = typeOf eb + tt = typeOf et + te = typeOf ee + in if tb P.== boolT P.&& tt P.== te + then If te eb et ee + else tyErr "cond" + +let_ :: L.Ident -> Expr -> Expr -> Expr +let_ x e1 e2 = let t = typeOf e2 in Let t x e1 e2 + +--------------------------------------------------------------------------------------- +-- Smart constructors for join operators + +cartproduct :: Expr -> Expr -> Expr +cartproduct xs ys = AppE2 resType CartProduct xs ys + where + resType = listT P.$ pairT (elemT P.$ typeOf xs) (typeOf ys) + +nestjoin :: Expr -> Expr -> L.JoinPredicate L.JoinExpr -> Expr +nestjoin xs ys p = AppE2 resType (NestJoin p) xs ys + where + resType = listT P.$ pairT (elemT P.$ typeOf xs) (typeOf ys) + +thetajoin :: Expr -> Expr -> L.JoinPredicate L.JoinExpr -> Expr +thetajoin xs ys p = AppE2 rt (ThetaJoin p) xs ys + where + xst = typeOf xs + yst = typeOf ys + rt = listT (pairT (elemT xst) (elemT yst)) + +semijoin :: Expr -> Expr -> L.JoinPredicate L.JoinExpr -> Expr +semijoin xs ys p = AppE2 xst (SemiJoin p) xs ys + where + xst = typeOf xs + +antijoin :: Expr -> Expr -> L.JoinPredicate L.JoinExpr -> Expr +antijoin xs ys p = AppE2 xst (AntiJoin p) xs ys + where + xst = typeOf xs + +--------------------------------------------------------------------------------------- +-- Literal value constructors + +unit :: Expr +unit = Lit unitT L.UnitV + +int :: P.Int -> Expr +int i = Lit intT (L.IntV i) + +bool :: P.Bool -> Expr +bool b = Lit boolT (L.BoolV b) + +string :: P.String -> Expr +string s = Lit stringT (L.StringV s) + +double :: P.Double -> Expr +double d = Lit doubleT (L.DoubleV d) + +nil :: Type -> Expr +nil t = Lit t (L.ListV []) + +list :: Type -> [Expr] -> Expr +list _ (e : es) = List.foldl' append (sng e) (P.map sng es) +list t [] = nil t + +cons :: Expr -> Expr -> Expr +cons e1 e2 = append (sng e1) e2 + +--------------------------------------------------------------------------------------- +-- Smart constructors for scalar unary operators + +scalarUnOp :: L.ScalarUnOp -> Expr -> Expr +scalarUnOp op e = + let t = typeOf e + in case (op, t) of + (L.SUNumOp _, DoubleT) -> UnOp t op e + (L.SUBoolOp _, BoolT) -> UnOp BoolT op e + (L.SUCastOp L.CastDouble, _) | isNum t -> UnOp DoubleT op e + (L.SUTextOp L.SubString{}, StringT) -> UnOp StringT op e + (L.SUDateOp, _) -> $unimplemented + (_, _) -> P.error err + where err = printf "CL.Primitives.scalarUnOp: %s" (P.show (op, t)) + +castDouble :: Expr -> Expr +castDouble = scalarUnOp (L.SUCastOp L.CastDouble) + +not :: Expr -> Expr +not = scalarUnOp (L.SUBoolOp L.Not) + +sin :: Expr -> Expr +sin = scalarUnOp (L.SUNumOp L.Sin) + +cos :: Expr -> Expr +cos = scalarUnOp (L.SUNumOp L.Cos) + +tan :: Expr -> Expr +tan = scalarUnOp (L.SUNumOp L.Tan) + +asin :: Expr -> Expr +asin = scalarUnOp (L.SUNumOp L.ASin) + +acos :: Expr -> Expr +acos = scalarUnOp (L.SUNumOp L.ACos) + +atan :: Expr -> Expr +atan = scalarUnOp (L.SUNumOp L.ATan) + +log :: Expr -> Expr +log = scalarUnOp (L.SUNumOp L.Log) + +sqrt :: Expr -> Expr +sqrt = scalarUnOp (L.SUNumOp L.Sqrt) + +exp :: Expr -> Expr +exp = scalarUnOp (L.SUNumOp L.Exp) + +substring :: P.Integer -> P.Integer -> Expr -> Expr +substring f t = scalarUnOp (L.SUTextOp P.$ L.SubString f t) + +--------------------------------------------------------------------------------------- +-- Smart constructors for scalar binary operators + +scalarBinOp :: L.ScalarBinOp -> Expr -> Expr -> Expr +scalarBinOp op e1 e2 = + let t1 = typeOf e1 + t2 = typeOf e2 + in case (op, t1, t2) of + (L.SBNumOp _, _, _) | t1 P.== t2 P.&& isNum t1 P.&& isNum t2 -> BinOp t1 op e1 e2 + (L.SBRelOp _, _, _) | t1 P.== t2 -> BinOp BoolT op e1 e2 + (L.SBBoolOp _, BoolT, BoolT) -> BinOp BoolT op e1 e2 + (L.SBStringOp L.Like, StringT, StringT) -> BinOp BoolT op e1 e2 + _ -> P.error err + where err = printf "CL.Primitives.scalarBinOp: %s" (P.show (op, t1, t2)) + +add :: Expr -> Expr -> Expr +add = scalarBinOp (L.SBNumOp L.Add) + +sub :: Expr -> Expr -> Expr +sub = scalarBinOp (L.SBNumOp L.Sub) + +mul :: Expr -> Expr -> Expr +mul = scalarBinOp (L.SBNumOp L.Mul) + +div :: Expr -> Expr -> Expr +div = scalarBinOp (L.SBNumOp L.Div) + +mod :: Expr -> Expr -> Expr +mod = scalarBinOp (L.SBNumOp L.Mod) + +eq :: Expr -> Expr -> Expr +eq = scalarBinOp (L.SBRelOp L.Eq) + +neq :: Expr -> Expr -> Expr +neq = scalarBinOp (L.SBRelOp L.NEq) + +gt :: Expr -> Expr -> Expr +gt = scalarBinOp (L.SBRelOp L.Gt) + +lt :: Expr -> Expr -> Expr +lt = scalarBinOp (L.SBRelOp L.Lt) + +gte :: Expr -> Expr -> Expr +gte = scalarBinOp (L.SBRelOp L.GtE) + +lte :: Expr -> Expr -> Expr +lte = scalarBinOp (L.SBRelOp L.LtE) + +conj :: Expr -> Expr -> Expr +conj = scalarBinOp (L.SBBoolOp L.Conj) + +disj :: Expr -> Expr -> Expr +disj = scalarBinOp (L.SBBoolOp L.Disj) + +like :: Expr -> Expr -> Expr +like = scalarBinOp (L.SBStringOp L.Like) + diff --git a/src/Database/DSH/CSV.hs b/src/Database/DSH/CSV.hs deleted file mode 100644 --- a/src/Database/DSH/CSV.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Database.DSH.CSV (csvImport) where - -import Database.DSH.Internals - -import qualified Data.Text as T -import Text.CSV - -csvImport :: (Reify a) => FilePath -> Type [a] -> IO (Exp [a]) -csvImport filepath csvType = do - let rType = recordType csvType - contents <- readFile filepath - let csv1 = case parseCSV filepath contents of - Left er -> error (show er) - Right r -> filter (\l -> not (all null l) || length l > 1) (tail r) - return (ListE (fmap (csvRecordToNorm rType) csv1)) - where csvError :: String -> a - csvError s = error ("Error in '" ++ filepath ++ "': " ++ s) - - recordType :: Type [a] -> Type a - recordType (ListT rType) = rType - - csvRecordToNorm :: Type a -> [String] -> Exp a - csvRecordToNorm UnitT [] = UnitE - csvRecordToNorm t [] = csvError ("When converting record '" ++ "[]" ++ "' to a value of type '" ++ show t ++ "'") - csvRecordToNorm t1 [bs] = csvFieldToNorm t1 bs - csvRecordToNorm (PairT (t1 :: Type b) (t2 :: Type c)) (bs : bss) = PairE (csvFieldToNorm t1 bs :: Exp b) (csvRecordToNorm t2 bss) - csvRecordToNorm t rs = csvError ("When converting record '" ++ show rs ++ "' to a value of type '" ++ show t ++ "'") - - - csvFieldToNorm :: Type a -> String -> Exp a - csvFieldToNorm t s = case t of - UnitT -> UnitE - BoolT -> BoolE (read s) - CharT -> CharE (head s) - IntegerT -> IntegerE (read s) - DoubleT -> DoubleE (read s) - TextT -> TextE (T.pack s) - _ -> er - where er = csvError ("When converting CSV field'" ++ s ++ "' to a value of type '" ++ show t ++ "'") diff --git a/src/Database/DSH/Common/Kure.hs b/src/Database/DSH/Common/Kure.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Common/Kure.hs @@ -0,0 +1,87 @@ +module Database.DSH.Common.Kure + ( -- * Debugging combinators + prettyR + , debug + , debugPretty + , debugMsg + , debugOpt + , debugPipeR + , debugTrace + , debugShow + ) where + +#ifdef DEBUGCOMP +import Debug.Trace +import Text.Printf +#endif + +import Language.KURE +import Database.DSH.Common.Pretty +import Control.Arrow + +-------------------------------------------------------------------------------- +-- Simple debugging combinators + +-- | Trace output of the value being rewritten; use for debugging only. +prettyR :: (Monad m, Pretty a) => String -> Rewrite c m a +#ifdef DEBUGCOMP +prettyR msg = acceptR (\a -> trace (msg ++ pp a) True) +#else +prettyR _ = idR +#endif + +debug :: Pretty a => String -> a -> b -> b +#ifdef DEBUGCOMP +debug msg a b = trace ("\n" ++ msg ++ " =>\n" ++ pp a) b +#else +debug _ _ b = b +#endif + +debugPretty :: (Pretty a, Monad m) => String -> a -> m () +debugPretty msg a = debug msg a (return ()) + +debugMsg :: Monad m => String -> m () +#ifdef DEBUGCOMP +debugMsg msg = trace msg $ return () +#else +debugMsg _ = return () +#endif + +debugOpt :: Pretty e => String -> e -> Either String e -> e +debugOpt stage origExpr mExpr = +#ifdef DEBUGCOMP + trace (showOrig origExpr) + $ either (flip trace origExpr) (\e -> trace (showOpt e) e) mExpr + + where + padSep :: String -> String + padSep s = "\n" ++ s ++ " " ++ replicate (100 - length s) '=' ++ "\n" + + showOrig :: Pretty e => e -> String + showOrig e = padSep (printf "Original Query (%s)" stage) ++ pp e ++ padSep "" + + showOpt :: Pretty e => e -> String + showOpt e = padSep (printf "Optimized Query (%s)" stage) ++ pp e ++ padSep "" +#else + either (const origExpr) id mExpr +#endif + +debugPipeR :: (Monad m, Pretty a) => Rewrite c m a -> Rewrite c m a +debugPipeR r = prettyR "Before >>>>>>" + >>> r + >>> prettyR ">>>>>>> After" + +debugTrace :: Monad m => String -> Rewrite c m a +#ifdef DEBUGCOMP +debugTrace msg = trace msg idR +#else +debugTrace _ = idR +#endif + +debugShow :: (Monad m, Pretty a) => String -> Rewrite c m a +#ifdef DEBUGCOMP +debugShow msg = prettyR (msg ++ "\n") +#else +debugShow _ = idR +#endif + diff --git a/src/Database/DSH/Common/Lang.hs b/src/Database/DSH/Common/Lang.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Common/Lang.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Common.Lang where + +import Data.Aeson +import Data.Aeson.TH +import qualified Data.List.NonEmpty as N +import Text.PrettyPrint.ANSI.Leijen +import Text.Printf + +import Database.DSH.Common.Type +import Database.DSH.Impossible + +import Database.DSH.Common.Nat + +instance ToJSON a => ToJSON (N.NonEmpty a) where + toJSON (n N.:| nl) = toJSON (n, nl) + +instance FromJSON a => FromJSON (N.NonEmpty a) where + parseJSON doc = parseJSON doc >>= \(n, nl) -> return $ n N.:| nl + +----------------------------------------------------------------------------- +-- Common types for backend expressions + +-- | Basic values in both FKL and NKL. +data Val where + ListV :: [Val] -> Val + IntV :: Int -> Val + BoolV :: Bool -> Val + StringV :: String -> Val + DoubleV :: Double -> Val + TupleV :: [Val] -> Val + UnitV :: Val + deriving (Eq, Ord, Show) + +newtype ColName = ColName String deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''ColName) + +-- | Typed table columns +type Column = (ColName, Type) + +-- | Table keys +newtype Key = Key [ColName] deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''Key) + +-- | Is the table guaranteed to be not empty? +data Emptiness = NonEmpty + | PossiblyEmpty + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''Emptiness) + +-- | Catalog information hints that users may give to DSH +data TableHints = TableHints + { keysHint :: [Key] + , nonEmptyHint :: Emptiness + } deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''TableHints) + +-- | Identifiers +type Ident = String + + +----------------------------------------------------------------------------- +-- Scalar operators + +data UnCastOp = CastDouble + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''UnCastOp) + +data UnBoolOp = Not + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''UnBoolOp) + +data UnNumOp = Sin + | Cos + | Tan + | ASin + | ACos + | ATan + | Sqrt + | Exp + | Log + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''UnNumOp) + +data UnTextOp = SubString Integer Integer + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''UnTextOp) + +data ScalarUnOp = SUNumOp UnNumOp + | SUBoolOp UnBoolOp + | SUCastOp UnCastOp + | SUTextOp UnTextOp + | SUDateOp + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''ScalarUnOp) + +data BinNumOp = Add + | Sub + | Div + | Mul + | Mod + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''BinNumOp) + +data BinRelOp = Eq + | Gt + | GtE + | Lt + | LtE + | NEq + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''BinRelOp) + +data BinBoolOp = Conj + | Disj + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''BinBoolOp) + +data BinStringOp = Like + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''BinStringOp) + +-- FIXME this would be a good fit for PatternSynonyms +data ScalarBinOp = SBNumOp BinNumOp + | SBRelOp BinRelOp + | SBBoolOp BinBoolOp + | SBStringOp BinStringOp + deriving (Show, Eq, Ord) + +$(deriveJSON defaultOptions ''ScalarBinOp) + + +----------------------------------------------------------------------------- +-- Join operator arguments: limited expressions that can be used on joins + +data JoinConjunct e = JoinConjunct e BinRelOp e + deriving (Show, Eq, Ord) + +instance ToJSON e => ToJSON (JoinConjunct e) where + toJSON (JoinConjunct e1 op e2) = toJSON (e1, op, e2) + +instance FromJSON e => FromJSON (JoinConjunct e) where + parseJSON d = parseJSON d >>= \(e1, op, e2) -> return $ JoinConjunct e1 op e2 + +newtype JoinPredicate e = JoinPred (N.NonEmpty (JoinConjunct e)) + deriving (Show, Eq, Ord) + +instance ToJSON e => ToJSON (JoinPredicate e) where + toJSON (JoinPred conjs) = toJSON conjs + +instance FromJSON e => FromJSON (JoinPredicate e) where + parseJSON d = parseJSON d >>= \conjs -> return $ JoinPred conjs + +singlePred :: JoinConjunct e -> JoinPredicate e +singlePred c = JoinPred $ c N.:| [] + +data JoinBinOp = JBNumOp BinNumOp + | JBStringOp BinStringOp + deriving (Show, Eq, Ord) + +data JoinUnOp = JUNumOp UnNumOp + | JUCastOp UnCastOp + | JUTextOp UnTextOp + deriving (Show, Eq, Ord) + +data JoinExpr = JBinOp Type JoinBinOp JoinExpr JoinExpr + | JUnOp Type JoinUnOp JoinExpr + | JTupElem Type TupleIndex JoinExpr + | JLit Type Val + | JInput Type + deriving (Show, Eq) + +instance Typed JoinExpr where + typeOf (JBinOp t _ _ _) = t + typeOf (JUnOp t _ _) = t + typeOf (JTupElem t _ _) = t + typeOf (JLit t _) = t + typeOf (JInput t) = t + +----------------------------------------------------------------------------- +-- Pretty-printing of stuff + +parenthize :: JoinExpr -> Doc +parenthize e = + case e of + JBinOp _ _ _ _ -> parens $ pretty e + JUnOp _ _ _ -> parens $ pretty e + JTupElem _ _ _ -> pretty e + JLit _ _ -> pretty e + JInput _ -> pretty e + +instance Pretty Val where + pretty (ListV xs) = list $ map pretty xs + pretty (IntV i) = int i + pretty (BoolV b) = bool b + pretty (StringV s) = dquotes $ string s + pretty (DoubleV d) = double d + pretty UnitV = text "()" + pretty (TupleV vs) = tupled $ map pretty vs + +instance Pretty BinRelOp where + pretty Eq = text "==" + pretty Gt = text ">" + pretty Lt = text "<" + pretty GtE = text ">=" + pretty LtE = text "<=" + pretty NEq = text "/=" + +instance Pretty BinStringOp where + pretty Like = text "LIKE" + +instance Pretty BinNumOp where + pretty Add = text "+" + pretty Sub = text "-" + pretty Div = text "/" + pretty Mul = text "*" + pretty Mod = text "%" + +instance Pretty BinBoolOp where + pretty Conj = text "&&" + pretty Disj = text "||" + +instance Pretty UnNumOp where + pretty Sin = text "sin" + pretty Cos = text "cos" + pretty Tan = text "tan" + pretty Sqrt = text "sqrt" + pretty Exp = text "exp" + pretty Log = text "log" + pretty ASin = text "asin" + pretty ACos = text "acos" + pretty ATan = text "atan" + +instance Pretty UnCastOp where + pretty CastDouble = text "double" + +instance Pretty JoinUnOp where + pretty (JUNumOp o) = pretty o + pretty (JUCastOp o) = pretty o + pretty (JUTextOp o) = pretty o + +instance Pretty JoinBinOp where + pretty (JBNumOp o) = pretty o + pretty (JBStringOp o) = pretty o + +instance Pretty JoinExpr where + pretty (JBinOp _ op e1 e2) = parenthize e1 <+> pretty op <+> parenthize e2 + pretty (JUnOp _ op e) = pretty op <+> parenthize e + pretty (JLit _ v) = pretty v + pretty (JInput _) = text "I" + pretty (JTupElem _ i e1) = + parenthize e1 <> dot <> int (tupleIndex i) + +instance Pretty e => Pretty (JoinConjunct e) where + pretty (JoinConjunct e1 op e2) = parens $ pretty e1 <+> pretty op <+> pretty e2 + +instance Pretty e => Pretty (JoinPredicate e) where + pretty (JoinPred ps) = list $ map pretty $ N.toList ps + + +instance Pretty ScalarBinOp where + pretty (SBNumOp o) = pretty o + pretty (SBRelOp o) = pretty o + pretty (SBBoolOp o) = pretty o + pretty (SBStringOp o) = pretty o + +instance Pretty UnBoolOp where + pretty Not = text "not" + +instance Pretty ScalarUnOp where + pretty (SUNumOp op) = pretty op + pretty (SUBoolOp op) = pretty op + pretty (SUCastOp op) = pretty op + pretty SUDateOp = $unimplemented + pretty (SUTextOp op) = pretty op + +instance Pretty UnTextOp where + pretty (SubString f t) = text $ printf "subString_%d,%d" f t diff --git a/src/Database/DSH/Common/Nat.hs b/src/Database/DSH/Common/Nat.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Common/Nat.hs @@ -0,0 +1,23 @@ +module Database.DSH.Common.Nat where + +import Control.Exception + +-- | Natural numbers that encode lifting levels +data Nat = Zero | Succ Nat deriving (Show, Eq) + +intFromNat :: Nat -> Int +intFromNat Zero = 0 +intFromNat (Succ n) = 1 + intFromNat n + +-- | Indexes of tuple fields +data TupleIndex = First | Next TupleIndex deriving (Show, Eq) + +tupleIndex :: TupleIndex -> Int +tupleIndex First = 1 +tupleIndex (Next f) = 1 + tupleIndex f + +intIndex :: Int -> TupleIndex +intIndex i = assert (i >= 1) $ + if i > 1 + then Next $ (intIndex $ i - 1) + else First diff --git a/src/Database/DSH/Common/Pretty.hs b/src/Database/DSH/Common/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Common/Pretty.hs @@ -0,0 +1,9 @@ +module Database.DSH.Common.Pretty + ( pp + , Pretty, pretty + ) where + +import Text.PrettyPrint.ANSI.Leijen + +pp :: Pretty a => a -> String +pp a = (displayS $ renderPretty 0.9 120 $ pretty a) "" diff --git a/src/Database/DSH/Common/QueryPlan.hs b/src/Database/DSH/Common/QueryPlan.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Common/QueryPlan.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | A QueryPlan describes the computation of the top-level query +-- result from algebraic plans over some algebra and describes how the +-- result's structure is encoded by the individual queries. +module Database.DSH.Common.QueryPlan where + +import Data.Aeson.TH + +import Database.Algebra.Dag +import Database.Algebra.Dag.Common + +import Database.DSH.VL.Vector + +-- | A Layout describes the tuple structure of values encoded by +-- one particular query from a bundle. +data Layout q = LCol Int + | LNest q (Layout q) + | LTuple [Layout q] + deriving (Show, Read) + +-- | A Shape describes the structure of the result produced by a +-- bundle of nested queries. 'q' is the type of individual vectors, +-- e.g. plan entry nodes or rendered database code. On the top level +-- we distinguish between a single value and a proper vector with more +-- than one element. +data Shape q = VShape q (Layout q) -- | A regular vector shape + | SShape q (Layout q) -- | A shape for a singleton vector + deriving (Show, Read) + +$(deriveJSON defaultOptions ''Layout) +$(deriveJSON defaultOptions ''Shape) + +-- | Extract all plan root nodes stored in the layout +layoutNodes :: DagVector v => Layout v -> [AlgNode] +layoutNodes (LCol _) = [] +layoutNodes (LNest v lyt) = vectorNodes v ++ layoutNodes lyt +layoutNodes (LTuple lyts) = concatMap layoutNodes lyts + +-- | Extract all plan root nodes stored in the shape +shapeNodes :: DagVector v => Shape v -> [AlgNode] +shapeNodes (VShape v lyt) = vectorNodes v ++ layoutNodes lyt +shapeNodes (SShape v lyt) = vectorNodes v ++ layoutNodes lyt + +-- | Replace a node in a top shape with another node. +updateShape :: DagVector v => AlgNode -> AlgNode -> Shape v -> Shape v +updateShape old new shape = + case shape of + VShape dbv lyt -> VShape (updateVector old new dbv) (updateLayout lyt) + SShape dbv lyt -> SShape (updateVector old new dbv) (updateLayout lyt) + + where + updateLayout (LNest dbv lyt) = LNest (updateVector old new dbv) (updateLayout lyt) + updateLayout (LTuple lyts) = LTuple (map updateLayout lyts) + updateLayout l = l + +columnsInLayout :: Layout q -> Int +columnsInLayout (LCol _) = 1 +columnsInLayout (LNest _ _) = 0 +columnsInLayout (LTuple lyts) = sum $ map columnsInLayout lyts + +isOuterMost :: AlgNode -> Shape NDVec -> Bool +isOuterMost n (VShape (ADVec n' _) _) = n == n' +isOuterMost n (SShape (ADVec n' _) _) = n == n' + +-- | A query plan consists of a DAG over some algebra and information about the +-- shape of the query. +data QueryPlan a v = + QueryPlan { queryDag :: AlgebraDag a + , queryShape :: Shape v + , queryTags :: NodeMap [Tag] + } + +-- | Construct a query plan from the operator map and the description +-- of the result shape. +mkQueryPlan :: (Operator a, DagVector v) + => AlgebraDag a + -> Shape v + -> NodeMap [Tag] + -> QueryPlan a v +mkQueryPlan dag shape tagMap = + QueryPlan { queryDag = addRootNodes dag (shapeNodes shape) + , queryShape = shape + , queryTags = tagMap + } diff --git a/src/Database/DSH/Common/RewriteM.hs b/src/Database/DSH/Common/RewriteM.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Common/RewriteM.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE InstanceSigs #-} + +module Database.DSH.Common.RewriteM + ( RewriteM + , RewriteStateM + , runRewriteM + , freshName + , freshNameS + , put + , get + , modify + , stateful + , liftstate + ) where + +import Control.Applicative +import Control.Monad + +import Language.KURE + +import Database.DSH.Common.Lang + +-------------------------------------------------------------------------------- +-- | The rewriting monad. Currently, it only provides fresh names +-- FIXME Figure out how to define a MonadCatch instance and use StateT s RewriteM +newtype RewriteM s a = RewriteM { compM :: s -> (s, Either String a) } + +-- | A variant of RewriteM which adds extra state to the +-- name-generating counter. +type RewriteStateM s = RewriteM (Int, s) + +runRewriteM :: RewriteM Int a -> Either String a +runRewriteM m = snd (compM m 0) + +runRewriteM' :: s -> RewriteM s a -> (s, Either String a) +runRewriteM' s m = compM m s + +instance Monad (RewriteM s) where + return = returnM + (>>=) = bindM + fail = failM + +returnM :: a -> RewriteM s a +returnM a = RewriteM (\n -> (n, Right a)) +{-# INLINE returnM #-} + +bindM :: RewriteM s a -> (a -> RewriteM s b) -> RewriteM s b +bindM (RewriteM f) gg = RewriteM $ \ n -> case f n of + (n', Left msg) -> (n', Left msg) + (n', Right a) -> compM (gg a) n' +{-# INLINE bindM #-} + +failM :: String -> RewriteM s a +failM msg = RewriteM (\n -> (n, Left msg)) +{-# INLINE failM #-} + +instance MonadCatch (RewriteM s) where + catchM = catchRewriteM + +catchRewriteM :: RewriteM s a -> (String -> RewriteM s a) -> RewriteM s a +catchRewriteM (RewriteM st) f = RewriteM $ \ n -> case st n of + (n', Left msg) -> compM (f msg) n' + (n', Right a) -> (n', Right a) +{-# INLINE catchRewriteM #-} + + +instance Functor (RewriteM s) where + fmap = liftM + +instance Applicative (RewriteM s) where + pure = return + (<*>) = ap + +suggestName :: RewriteM Int Ident +suggestName = RewriteM (\n -> ((n+1), Right ("v" ++ show n))) + +-- | Generate a fresh name, taking the list of in-scope names as parameter. We +-- assume that every name is bound. Therefore, a name that is not bound is +-- assumed to be fresh. +freshName :: [Ident] -> RewriteM Int Ident +freshName vs = do v <- suggestName + if v `elem` vs + then freshName vs + else return v + +suggestName' :: RewriteStateM s Ident +suggestName' = RewriteM (\(n, s) -> ((n+1, s), Right ("v" ++ show n))) + +freshNameS :: [Ident] -> RewriteStateM s Ident +freshNameS vs = do v <- suggestName' + if v `elem` vs + then freshNameS vs + else return v + +get :: RewriteStateM s s +get = RewriteM $ \(i, s) -> ((i, s), Right s) +{-# INLINE get #-} + +put :: s -> RewriteStateM s () +put s = RewriteM $ \(i, _) -> ((i, s), Right ()) +{-# INLINE put #-} + +modify :: (s -> s) -> RewriteStateM s () +modify f = RewriteM $ \(i, s) -> ((i, f s), Right ()) +{-# INLINE modify #-} + +stateful :: s -> RewriteStateM s a -> RewriteM Int (s, a) +stateful s ma = RewriteM $ \i -> + case runRewriteM' (i, s) ma of + ((i', _), Left msg) -> (i', Left msg) + ((i', s'), Right a) -> (i', Right (s', a)) + +liftstate :: RewriteM Int a -> RewriteStateM s a +liftstate ma = RewriteM $ \(i, s) -> let (i', a) = runRewriteM' i ma + in ((i', s), a) + + +-- runRewriteM' (i, s) (ma :: RewriteM (Int, s) a) :: ((i', s'), + +{- +type FooM s = StateT s RewriteM + +-- automatic due to StateT +-- instance Monad ... + +instance MonadCatch (FooM s) where + ma `catchM` f = StateT $ \s -> + let (ka, s') = runStateT ma s + in runRewriteM (return . return) undefined ka +-} diff --git a/src/Database/DSH/Common/Type.hs b/src/Database/DSH/Common/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Common/Type.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Common.Type + ( isNum + , isList + , elemT + , tupleElemT + , tupleElemTypes + , fstT + , sndT + , listDepth + , extractShape + , unliftTypeN + , unliftType + , liftType + , liftTypeN + , Type(..) + , intT + , boolT + , unitT + , stringT + , doubleT + , listT + , pairT + , Typed (..) + ) where + +import Text.PrettyPrint.ANSI.Leijen + +import Database.DSH.Impossible +import Database.DSH.Common.Pretty +import Database.DSH.Common.Nat + +instance Pretty Type where + pretty IntT = text "Int" + pretty BoolT = text "Bool" + pretty DoubleT = text "Double" + pretty StringT = text "String" + pretty UnitT = text "()" + pretty (ListT t) = brackets $ pretty t + pretty (TupleT ts) = tupled $ map pretty ts + +-- | We use the following type language to type the various +-- intermediate languages. +data Type = IntT + | BoolT + | DoubleT + | StringT + | UnitT + | ListT Type + | TupleT [Type] + deriving (Show, Eq, Ord) + +isNum :: Type -> Bool +isNum IntT = True +isNum DoubleT = True +isNum BoolT = False +isNum StringT = False +isNum UnitT = False +isNum (ListT _) = False +isNum (TupleT _) = False + +intT :: Type +intT = IntT + +stringT :: Type +stringT = StringT + +doubleT :: Type +doubleT = DoubleT + +boolT :: Type +boolT = BoolT + +unitT :: Type +unitT = UnitT + +listT :: Type -> Type +listT = ListT + +pairT :: Type -> Type -> Type +pairT t1 t2 = TupleT [t1, t2] + +isList :: Type -> Bool +isList (ListT _) = True +isList _ = False + +elemT :: Type -> Type +elemT (ListT t) = t +elemT _ = error "elemT: argument is not a list type" + +tupleElemT :: Type -> TupleIndex -> Type +tupleElemT (TupleT ts) f = ts !! (tupleIndex f - 1) +tupleElemT _ _ = $impossible + +tupleElemTypes :: Type -> [Type] +tupleElemTypes (TupleT ts) = ts +tupleElemTypes _ = $impossible + +listDepth :: Type -> Int +listDepth (ListT t1) = 1 + listDepth t1 +listDepth _ = 0 + +fstT :: Type -> Type +fstT (TupleT [t1, _]) = t1 +fstT _ = error "Type is not a pair type" + +sndT :: Type -> Type +sndT (TupleT [_, t2]) = t2 +sndT _ = error "Type is not a pair type" + +extractShape :: Type -> Type -> Type +extractShape (ListT t1) = \x -> listT $ extractShape t1 x +extractShape _ = \x -> x + +liftTypeN :: Nat -> Type -> Type +liftTypeN Zero t = t +liftTypeN (Succ n) t = liftTypeN n $ liftType t + +liftType :: Type -> Type +liftType t = listT t + +unliftTypeN :: Nat -> Type -> Type +unliftTypeN Zero t = t +unliftTypeN (Succ n) t = unliftTypeN n $ unliftType t + +unliftType :: Type -> Type +unliftType (ListT t1) = t1 +unliftType t = error $ "Type: " ++ pp t ++ " cannot be unlifted." + +class Typed a where + typeOf :: a -> Type diff --git a/src/Database/DSH/Compile.hs b/src/Database/DSH/Compile.hs deleted file mode 100644 --- a/src/Database/DSH/Compile.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -module Database.DSH.Compile where - -import Database.DSH.Internals -import Database.DSH.Impossible - -import Database.Pathfinder - -import qualified Data.Array as A -import qualified Data.List as L -import Data.Maybe (fromJust, isNothing, isJust, fromMaybe) -import Data.List (sortBy) -import Data.Function -import Control.Arrow -import Control.Monad.Reader -import Control.Exception (evaluate) - -import qualified Text.XML.HaXml as X -import Text.XML.HaXml (Content(..), AttValue(..), tag, deep, children, xmlParse, Document(..)) - -import Database.HDBC -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - --- | Wrapper type with phantom type for algebraic plan --- The type variable represents the type of the result of the plan -newtype AlgebraXML a = Algebra String - --- | Wrapper type with phantom type for SQL plan --- The type variable represents the type of the result of the plan -newtype SQLXML a = SQL String - deriving Show - --- | Type representing a query bundle, the type variable represents the type --- of the result of the query bundle. A bundle consists of pair of numbered queries. --- Each query consists of the query itself, a schema explaining its types. --- If the query is a nested value in the result of another query the optional attribute --- represents (queryID, columnID). The queryId refers to the number of the query in the bundle --- the columnID refers -newtype QueryBundle a = Bundle [(Int, (String, SchemaInfo, Maybe (Int, Int)))] - --- | Description of a table. The field iterN contains the name of the iter column --- the items field contains a list of item column names and their position within the result. -data SchemaInfo = SchemaInfo {iterN :: String, items :: [(String, Int)]} - --- | Description of result data of a query. The field iterR contains the column number of --- the iter column. resCols contains a for all items columns their column number in the result. -data ResultInfo = ResultInfo {iterR :: Int, resCols :: [(String, Int)]} - deriving Show - --- | Translate the algebraic plan to SQL and then execute it using the provided --- DB connection. If debug is switchd on the SQL code is written to a file --- named query.sql -executePlan :: forall a. forall conn. (Reify a, IConnection conn) => conn -> AlgebraXML a -> IO (Exp a) -executePlan c p = do - sql@(SQL _s) <- algToSQL p - runSQL c $ extractSQL sql - -algToAlg :: AlgebraXML a -> IO (AlgebraXML a) -algToAlg (Algebra s) = do r <- pathfinder s [] OutputXml - case r of - (Right sql) -> return $ Algebra sql - (Left err) -> error $ "Pathfinder compilation for input: \n" - ++ s ++ "\n failed with error: \n" - ++ err - --- | Translate an algebraic plan into SQL code using Pathfinder -algToSQL :: AlgebraXML a -> IO (SQLXML a) -algToSQL (Algebra s) = do r <- pathfinder s [] OutputSql - case r of - (Right sql) -> return $ SQL sql - (Left err) -> error $ "Pathfinder compilation for input: \n" - ++ s ++ "\n failed with error: \n" - ++ err - --- | Extract the SQL queries from the XML structure generated by pathfinder -extractSQL :: SQLXML a -> QueryBundle a -extractSQL (SQL q) = let (Document _ _ r _) = xmlParse "query" q - in Bundle $ map extractQuery $ (deep $ tag "query_plan") (CElem r $impossible) - where - extractQuery c@(CElem (X.Elem n attrs cs) _) = let qId = maybe ($impossible) attrToInt (lookup (X.N "id") attrs) - rId = fmap attrToInt $ lookup (X.N "idref") attrs - cId = fmap attrToInt $ lookup (X.N "colref") attrs - ref = liftM2 (,) rId cId - query = extractCData $ head $ concatMap children $ deep (tag "query") c - schema = toSchemeInf $ map process $ concatMap (deep (tag "column")) $ deep (tag "schema") c - in (qId, (query, schema, ref)) - extractQuery _ = $impossible - attrToInt :: AttValue -> Int - attrToInt (AttValue [Left i]) = read i - attrToInt _ = $impossible - attrToString :: AttValue -> String - attrToString (AttValue [Left i]) = i - attrToString _ = $impossible - extractCData :: Content i -> String - extractCData (CString _ d _) = d - extractCData _ = $impossible - toSchemeInf :: [(String, Maybe Int)] -> SchemaInfo - toSchemeInf results = let iterName = fst $ head $ filter (\(_, p) -> isNothing p) results - cols = map (second fromJust) $ filter (\(_, p) -> isJust p) results - in SchemaInfo iterName cols - process :: Content i -> (String, Maybe Int) - process (CElem (X.Elem _ attrs _) _) = let name = fromJust $ fmap attrToString $ lookup (X.N "name") attrs - pos = fmap attrToInt $ lookup (X.N "position") attrs - in (name, pos) - process _ = $impossible - --- | Execute the given SQL queries and assemble the results into one structure -runSQL :: forall a. forall conn. (Reify a, IConnection conn) => conn -> QueryBundle a -> IO (Exp a) -runSQL c (Bundle queries) = do - results <- mapM (runQuery c) queries - let (queryMap, valueMap) = foldr buildRefMap ([],[]) results - let ty = reify (undefined :: a) - let results' = runReader (processResults 0 ty) (queryMap, valueMap) - case ty of - (ListT _) -> return $ fromMaybe (ListE []) (lookup 1 results') - _ -> return $ fromJust (lookup 1 results') - --- | Type of the environment under which we reconstruct ordinary haskell data from the query result. --- The first component of the reader monad contains a mapping from (queryNumber, columnNumber) to --- the number of a nested query. The second component is a tuple consisting of query number associated --- with a pair of the raw result data partitioned by iter, and a description of this result data. -type QueryR = Reader ([((Int, Int), Int)] ,[(Int, ([(Int, [[SqlValue]])], ResultInfo))]) - --- | Retrieve the data asociated with query i. -getResults :: Int -> QueryR [(Int, [[SqlValue]])] -getResults i = do - env <- ask - return $ case lookup i $ snd env of - Just x -> fst x - Nothing -> $impossible - --- | Get the position of item i of query q -getColResPos :: Int -> Int -> QueryR Int -getColResPos q i = do - env <- ask - return $ case lookup q $ snd env of - Just (_, ResultInfo _ x) -> snd (x !! i) - Nothing -> $impossible - --- | Get the id of the query that is nested in column c of query q. -findQuery :: (Int, Int) -> QueryR Int -findQuery (q, c) = do - env <- ask - return $ fromMaybe (error $ show $ fst env) $ lookup (q, c + 1) $ fst env - --- | Reconstruct the haskell value out of the result of query i with type ty. -processResults :: Int -> Type a -> QueryR [(Int, Exp a)] -processResults i (ListT t1) = do - v <- getResults i - mapM (\(it, vals) -> do - v1 <- processResults' i 0 vals t1 - return (it, ListE v1)) v -processResults i t = do - v <- getResults i - mapM (\(it, vals) -> do - v1 <- processResults' i 0 vals t - return (it, head v1)) v - -nrColsInType :: Type a -> Int -nrColsInType UnitT = 1 -nrColsInType BoolT = 1 -nrColsInType CharT = 1 -nrColsInType IntegerT = 1 -nrColsInType DoubleT = 1 -nrColsInType TextT = 1 -nrColsInType (PairT t1 t2) = nrColsInType t1 + nrColsInType t2 -nrColsInType (ListT _) = 1 -nrColsInType (ArrowT _ _) = $impossible - --- | Reconstruct the values for column c of query q out of the rawData vals with type t. -processResults' :: Int -> Int -> [[SqlValue]] -> Type a -> QueryR [Exp a] -processResults' _ _ vals UnitT = return $ map (\_ -> UnitE) vals -processResults' q c vals (PairT t1 t2) = do - v1s <- processResults' q c vals t1 - v2s <- processResults' q (c + nrColsInType t1) vals t2 - return (zipWith PairE v1s v2s) -processResults' q c vals t@(ListT _) = do - nestQ <- findQuery (q, c) - list <- processResults nestQ t - i <- getColResPos q c - let (maxV, vals') = foldr (\v (m,vs) -> let v' = sqlValueToInt (v !! i) - in (m `max` v', v':vs)) (1,[]) vals - let maxI = if null list - then 1 - else fst $ L.maximumBy (compare `on` fst) list - let lA = A.accumArray ($impossible) Nothing (1,maxI `max` maxV) [] A.// map (second Just) list - return $ map (\val -> fromMaybe (ListE []) (lA A.! val)) vals' -processResults' _ _ _ (ArrowT _ _) = $impossible -processResults' q c vals t = do - i <- getColResPos q c - return $ map (\val -> convert (val !! i) t) vals - -sqlValueToInt :: SqlValue -> Int -sqlValueToInt (SqlInteger i) = fromIntegral i -sqlValueToInt _ = $impossible - -convert :: SqlValue -> Type a -> Exp a -convert SqlNull UnitT = UnitE -convert (SqlInteger i) IntegerT = IntegerE i -convert (SqlInt32 i) IntegerT = IntegerE $ fromIntegral i -convert (SqlInt64 i) IntegerT = IntegerE $ fromIntegral i -convert (SqlWord32 i) IntegerT = IntegerE $ fromIntegral i -convert (SqlWord64 i) IntegerT = IntegerE $ fromIntegral i -convert (SqlDouble d) DoubleT = DoubleE d -convert (SqlRational d) DoubleT = DoubleE $ fromRational d -convert (SqlInteger d) DoubleT = DoubleE $ fromIntegral d -convert (SqlInt32 d) DoubleT = DoubleE $ fromIntegral d -convert (SqlInt64 d) DoubleT = DoubleE $ fromIntegral d -convert (SqlWord32 d) DoubleT = DoubleE $ fromIntegral d -convert (SqlWord64 d) DoubleT = DoubleE $ fromIntegral d -convert (SqlBool b) BoolT = BoolE b -convert (SqlInteger i) BoolT = BoolE (i /= 0) -convert (SqlInt32 i) BoolT = BoolE (i /= 0) -convert (SqlInt64 i) BoolT = BoolE (i /= 0) -convert (SqlWord32 i) BoolT = BoolE (i /= 0) -convert (SqlWord64 i) BoolT = BoolE (i /= 0) -convert (SqlChar c) CharT = CharE c -convert (SqlString (c:_)) CharT = CharE c -convert (SqlByteString c) CharT = CharE (head $ T.unpack $ T.decodeUtf8 c) -convert (SqlString t) TextT = TextE (T.pack t) -convert (SqlByteString s) TextT = TextE (T.decodeUtf8 s) -convert sql _ = error $ "Unsupported SqlValue: " ++ show sql - --- | Partition by iter column --- The first argument is the position of the iter column. --- The second argument the raw data --- It returns a list of pairs (iterVal, rawdata within iter) -partByIter :: Int -> [[SqlValue]] -> [(Int, [[SqlValue]])] -partByIter n (v:vs) = let i = getIter n v - (vi, vr) = span (\v' -> i == getIter n v') vs - in (i, v:vi) : partByIter n vr - where - getIter :: Int -> [SqlValue] -> Int - getIter n' vals = fromSql (vals !! n') :: Int -partByIter _ [] = [] - - --- | Execute the given query plan bundle, over the provided connection. --- It returns the raw data for each query along with a description on how to reconstruct --- ordinary haskell data -runQuery :: IConnection conn => conn -> (Int, (String, SchemaInfo, Maybe (Int, Int))) -> IO (Int, ([(Int, [[SqlValue]])], ResultInfo, Maybe (Int, Int))) -runQuery c (qId, (query, schema, ref)) = do - sth <- prepare c query - _ <- execute sth [] - res <- dshFetchAllRowsStrict sth - resDescr <- describeResult sth - let ri = schemeToResult schema resDescr - let res' = partByIter (iterR ri) res - return (qId, (res', ri, ref)) - -dshFetchAllRowsStrict :: Statement -> IO [[SqlValue]] -dshFetchAllRowsStrict stmt = go [] - where - go :: [[SqlValue]] -> IO [[SqlValue]] - go acc = do mRow <- fetchRow stmt - case mRow of - Nothing -> return (reverse acc) - Just row -> do mapM_ evaluate row - go (row : acc) - --- | Transform algebraic plan scheme info into resultinfo -schemeToResult :: SchemaInfo -> [(String, SqlColDesc)] -> ResultInfo -schemeToResult (SchemaInfo itN cols) resDescr = let ordCols = sortBy (\(_, c1) (_, c2) -> compare c1 c2) cols - resColumns = flip zip [0..] $ map (\(c, _) -> takeWhile (/= '_') c) resDescr - itC = fromJust $ lookup itN resColumns - in ResultInfo itC $ map (\(n, _) -> (n, fromJust $ lookup n resColumns)) ordCols - --- | -buildRefMap :: (Int, ([(Int, [[SqlValue]])], ResultInfo, Maybe (Int, Int))) -> ([((Int, Int), Int)] ,[(Int, ([(Int, [[SqlValue]])], ResultInfo))]) -> ([((Int, Int), Int)] ,[(Int, ([(Int, [[SqlValue]])], ResultInfo))]) -buildRefMap (q, (r, ri, Just (t, c))) (qm, rm) = (((t, c), q):qm, (q, (r, ri)):rm) -buildRefMap (q, (r, ri, _)) (qm, rm) = (qm, (q, (r, ri)):rm) diff --git a/src/Database/DSH/Compiler.hs b/src/Database/DSH/Compiler.hs --- a/src/Database/DSH/Compiler.hs +++ b/src/Database/DSH/Compiler.hs @@ -1,353 +1,132 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - --- | DSH compiler module exposes the function fromQ that can be used to --- execute DSH programs on a database. It transform the DSH program into --- FerryCore which is then translated into SQL (through a table algebra). The SQL --- code is executed on the database and then processed to form a Haskell value. - -module Database.DSH.Compiler (fromQ, debugPlan, debugCore, debugPlanOpt, debugSQL, debugCoreDot) where - -import Database.DSH.Internals as D -import Database.DSH.Impossible -import Database.DSH.CSV - -import Database.DSH.Compile as C - -import Database.Ferry.SyntaxTyped as F -import Database.Ferry.Compiler - -import qualified Data.Map as M -import Data.Char -import Database.HDBC - -import Control.Monad.State -import Control.Applicative - -import Data.Text (unpack) - -import Data.List (nub) -import qualified Data.List as L - -{- -N monad, version of the state monad that can provide fresh variable names. --} -type N conn = StateT (conn, Int, M.Map String [(String,FType -> Bool)]) IO - --- | Provide a fresh identifier name during compilation -freshVar :: N conn Int -freshVar = do - (c, i, env) <- get - put (c, i + 1, env) - return i - --- | Get from the state the connection to the database -getConnection :: IConnection conn => N conn conn -getConnection = do - (c, _, _) <- get - return c - --- | Lookup information that describes a table. If the information is --- not present in the state then the connection is used to retrieve the --- table information from the Database. -tableInfo :: IConnection conn => String -> N conn [(String,FType -> Bool)] -tableInfo t = do - (c, i, env) <- get - case M.lookup t env of - Nothing -> do - inf <- lift $ getTableInfo c t - put (c, i, M.insert t inf env) - return inf - Just v -> return v - --- | Turn a given integer into a variable beginning with prefix "__fv_" -prefixVar :: Int -> String -prefixVar = (++) "__fv_" . show - --- | Execute the transformation computation. During --- compilation table information can be retrieved from --- the database, therefor the result is wrapped in the IO --- Monad. -runN :: IConnection conn => conn -> N conn a -> IO a -runN c = liftM fst . flip runStateT (c, 1, M.empty) - --- * Convert DB queries into Haskell values - --- | Execute the query on the database -fromQ :: (QA a, IConnection conn) => conn -> Q a -> IO a -fromQ c (Q e) = fmap frExp (evaluate c e) - --- | Convert the query into unoptimised algebraic plan -debugPlan :: (IConnection conn,Reify a) => conn -> Exp a -> IO String -debugPlan = doCompile - --- | Convert the query into optimised algebraic plan -debugPlanOpt :: (IConnection conn,Reify a) => conn -> Exp a -> IO String -debugPlanOpt q c = do - p <- doCompile q c - (C.Algebra r) <- algToAlg (C.Algebra p :: AlgebraXML a) - return r - -debugCore :: (IConnection conn,Reify a) => conn -> Exp a -> IO String -debugCore c a = do core <- runN c $ transformE a - return $ show core - - -debugCoreDot :: (IConnection conn,Reify a) => conn -> Exp a -> IO String -debugCoreDot c a = do core <- runN c $ transformE a - return $ (\(Right d) -> d) $ dot core - --- | Convert the query into SQL -debugSQL :: (IConnection conn,Reify a) => conn -> Exp a -> IO String -debugSQL q c = do p <- doCompile q c - (C.SQL r) <- algToSQL (C.Algebra p :: AlgebraXML a) - return r - --- | evaluate compiles the given Q query into an executable plan, executes this and returns --- the result as norm. For execution it uses the given connection. If the boolean flag is set --- to true it outputs the intermediate algebraic plan to disk. -evaluate :: (Reify a, IConnection conn) => conn -> Exp a -> IO (Exp a) -evaluate c q = do algPlan' <- doCompile c q - let algPlan = C.Algebra algPlan' :: AlgebraXML a - n <- executePlan c algPlan - disconnect c - return n +{-# LANGUAGE TemplateHaskell #-} --- | Transform a query into an algebraic plan. -doCompile :: (IConnection conn, Reify a) => conn -> Exp a -> IO String -doCompile c a = do core <- runN c $ transformE a - return $ typedCoreToAlgebra core +-- | Compilation, execution and introspection of queries +module Database.DSH.Compiler + ( -- * Executing queries + runQ + -- * Debug functions + , debugQ + , debugVL + , debugVLOpt + , debugTA + , debugTAOpt + , runPrint + ) where --- | Transform the Query into a ferry core program. -transformE :: forall a conn. (IConnection conn, Reify a) => Exp a -> N conn CoreExpr -transformE (UnitE ) = return $ Constant ([] :=> int) $ CInt 1 -transformE (BoolE b) = return $ Constant ([] :=> bool) $ CBool b -transformE (CharE c) = return $ Constant ([] :=> string) $ CString [c] -transformE (IntegerE i) = return $ Constant ([] :=> int) $ CInt i -transformE (DoubleE d) = return $ Constant ([] :=> float) $ CFloat d -transformE (TextE t) = return $ Constant ([] :=> string) $ CString $ unpack t -transformE (PairE e1 e2) = do let ty = reify (undefined :: a) - c1 <- transformE e1 - c2 <- transformE e2 - return $ Rec ([] :=> transformTy ty) [RecElem (typeOf c1) "1" c1, RecElem (typeOf c2) "2" c2] -transformE (ListE es) = let ty = reify (undefined :: a) - qt = ([] :=> transformTy ty) - in foldr (F.Cons qt) (Nil qt) <$> mapM transformE es -transformE (AppE GroupWithKey (PairE (gfn :: Exp (ta -> rt)) (e :: Exp el))) = do - let tel = reify (undefined :: el) - fn' <- transformLamArg gfn - let (_ :=> tfn@(FFn _ rt)) = typeOf fn' - let gtr = list $ rec [(RLabel "1", rt), (RLabel "2", transformTy $ ListT tel)] - e' <- transformArg e - let (_ :=> te) = typeOf e' - fv <- transformLamArg (LamE id :: Exp (el -> el)) - let (_ :=> tfv) = typeOf fv - return $ App ([] :=> gtr) - (App ([] :=> te .-> gtr) - (App ([] :=> tfn .-> te .-> gtr) (Var ([] :=> tfv .-> tfn .-> te .-> gtr) "groupWith") fv) - fn') - e' -transformE (AppE D.Cons (PairE e1 e2)) = do - e1' <- transformE e1 - e2' <- transformE e2 - let (_ :=> t) = typeOf e1' - return $ F.Cons ([] :=> list t) e1' e2' -transformE (AppE Cond (PairE e1 (PairE e2 e3))) = do - e1' <- transformE e1 - e2' <- transformE e2 - e3' <- transformE e3 - let (_ :=> t) = typeOf e2' - return $ If ([] :=> t) e1' e2' e3' -transformE (AppE Fst (PairE e1 e2)) = do - let ty = reify (undefined :: a) - let tr = transformTy ty - e1' <- transformArg (PairE e1 e2) - let (_ :=> ta) = typeOf e1' - return $ App ([] :=> tr) (transformF Fst (ta .-> tr)) e1' +import Control.Applicative +import Control.Arrow +import qualified Database.HDBC.PostgreSQL as H -transformE (AppE Snd (PairE e1 e2)) = do - let ty = reify (undefined :: a) - let tr = transformTy ty - e1' <- transformArg (PairE e1 e2) - let (_ :=> ta) = typeOf e1' - return $ App ([] :=> tr) (transformF Snd (ta .-> tr)) e1' +import Database.DSH.Translate.Frontend2CL +import Database.DSH.Execute.Sql -transformE (AppE f2 (PairE (LamE f) e)) = do - let ty = reify (undefined :: a) - let tr = transformTy ty - f' <- transformLamArg (LamE f) - e' <- transformArg e - let (_ :=> t1) = typeOf f' - let (_ :=> t2) = typeOf e' - return $ App ([] :=> tr) - (App ([] :=> t2 .-> tr) (transformF f2 (t1 .-> t2 .-> tr)) f') - e' +import qualified Database.DSH.VL.Lang as VL +import Database.DSH.VL.Vector +import Database.DSH.NKL.Rewrite +import qualified Database.DSH.CL.Lang as CL +import Database.DSH.CL.Opt +import Database.DSH.Common.QueryPlan +import Database.DSH.Export +import Database.DSH.Frontend.Internals +import Database.DSH.Optimizer.TA.OptimizeTA +import Database.DSH.Optimizer.VL.OptimizeVL +import Database.DSH.Frontend.Schema +import Database.DSH.Translate.Algebra2Query +import Database.DSH.Translate.CL2NKL +import Database.DSH.Translate.FKL2VL +import Database.DSH.Translate.NKL2FKL +import Database.DSH.Translate.VL2Algebra -transformE (AppE f2 (PairE e1 e2)) = do - let ty = reify (undefined :: a) - let tr = transformTy ty - if isOp f2 - then do e1' <- transformE e1 - e2' <- transformE e2 - return $ BinOp ([] :=> tr) (transformOp f2) e1' e2' - else do e1' <- transformArg e1 - e2' <- transformArg e2 - let (_ :=> ta1) = typeOf e1' - let (_ :=> ta2) = typeOf e2' - return $ App ([] :=> tr) (App ([] :=> ta2 .-> tr) (transformF f2 (ta1 .-> ta2 .-> tr)) e1') e2' +-------------------------------------------------------------------------------- +-- Different versions of the flattening compiler pipeline -transformE (AppE f1 e1) = do - let ty = reify (undefined :: a) - let tr = transformTy ty - e1' <- transformArg e1 - let (_ :=> ta) = typeOf e1' - return $ App ([] :=> tr) (transformF f1 (ta .-> tr)) e1' +-- | Backend-agnostic part of the pipeline. +commonPipeline :: CL.Expr -> QueryPlan VL.VL VLDVec +commonPipeline = + optimizeComprehensions + >>> desugarComprehensions + >>> optimizeNKL + >>> flatTransform + >>> specializeVectorOps -transformE (VarE i) = do - let ty = reify (undefined :: a) - return $ Var ([] :=> transformTy ty) $ prefixVar $ fromIntegral i - -transformE (TableE (TableCSV filepath)) = do - let ty = reify (undefined :: a) - e1 <- lift (csvImport filepath ty) - transformE e1 +nkl2Sql :: CL.Expr -> Shape (BackendCode SqlBackend) +nkl2Sql = + commonPipeline + >>> optimizeVLDefault + >>> implementVectorOpsPF + >>> optimizeTA + >>> generateSqlQueries --- When a table node is encountered check that the given description --- matches the actual table information in the database. -transformE (TableE (TableDB n ks)) = do - let ty = reify (undefined :: a) - fv <- freshVar - let tTy@(FList (FRec ts)) = flatFTy ty - let varB = Var ([] :=> FRec ts) $ prefixVar fv - tableDescr <- tableInfo n - let tyDescr = if length tableDescr == length ts - then zip tableDescr ts - else error $ "Inferred typed: " ++ show tTy ++ " \n doesn't match type of table: \"" - ++ n ++ "\" in the database. The table has the shape: " ++ show (map fst tableDescr) ++ ". " ++ show ty - let cols = [Column cn t | ((cn, f), (RLabel i, t)) <- tyDescr, legalType n cn i t f] - let keyCols = nub (concat ks) L.\\ map fst tableDescr - let keys = if keyCols == [] - then if ks /= [] then map Key ks else [Key $ map (\(Column n' _) -> n') cols] - else error $ "The following columns were used as key but not a column of table " ++ n ++ " : " ++ show keyCols - let table' = Table ([] :=> tTy) n cols keys - let pattern = [prefixVar fv] - let nameType = map (\(Column name t) -> (name, t)) cols - let body = foldr (\(nr, t) b -> - let (_ :=> bt) = typeOf b - in Rec ([] :=> FRec [(RLabel "1", t), (RLabel "2", bt)]) [RecElem ([] :=> t) "1" (F.Elem ([] :=> t) varB nr), RecElem ([] :=> bt) "2" b]) - ((\(nr,t) -> F.Elem ([] :=> t) varB nr) $ last nameType) - (init nameType) - let ([] :=> rt) = typeOf body - let lambda = ParAbstr ([] :=> FRec ts .-> rt) pattern body - let expr = App ([] :=> FList rt) (App ([] :=> (FList $ FRec ts) .-> FList rt) - (Var ([] :=> (FRec ts .-> rt) .-> (FList $ FRec ts) .-> FList rt) "map") - lambda) - (ParExpr (typeOf table') table') - return expr - where - legalType :: String -> String -> String -> FType -> (FType -> Bool) -> Bool - legalType tn cn nr t f = f t || error ( "The type: " - ++ show t - ++ "\nis not compatible with the type of column nr: " ++ nr - ++ " namely: " ++ cn ++ "\n in table " ++ tn ++ ".") -transformE (LamE _) = $impossible +nkl2TAFile :: String -> CL.Expr -> IO () +nkl2TAFile prefix = + commonPipeline + >>> optimizeVLDefault + >>> implementVectorOpsPF + >>> (exportTAPlan prefix) -transformLamArg :: forall a b conn. (IConnection conn) => Exp (a -> b) -> N conn Param -transformLamArg (LamE f) = do - let ty = reify (undefined :: a -> b) - n <- freshVar - let fty = transformTy ty - let e1 = f $ VarE $ fromIntegral n - ParAbstr ([] :=> fty) [prefixVar n] <$> transformE e1 -transformLamArg (AppE _ _) = $impossible -transformLamArg (VarE _) = $impossible +nkl2TAFileOpt :: String -> CL.Expr -> IO () +nkl2TAFileOpt prefix = + commonPipeline + >>> optimizeVLDefault + >>> implementVectorOpsPF + >>> optimizeTA + >>> exportTAPlan (prefix ++ "_opt") +nkl2VLFile :: String -> CL.Expr -> IO () +nkl2VLFile prefix = commonPipeline >>> exportVLPlan prefix -transformArg :: (IConnection conn,Reify a) => Exp a -> N conn Param -transformArg e = (\e' -> ParExpr (typeOf e') e') <$> transformE e - --- | Construct a flat-FerryCore type out of a DSH type --- A flat type consists out of two tuples, a record is translated as: --- {r1 :: t1, r2 :: t2, r3 :: t3, r4 :: t4} (t1, (t2, (t3, t4))) -flatFTy :: Type a -> FType -flatFTy (ListT t) = FList $ FRec $ flatFTy' 1 t - where - flatFTy' :: Int -> Type a -> [(RLabel, FType)] - flatFTy' i (PairT t1 t2) = (RLabel $ show i, transformTy t1) : flatFTy' (i + 1) t2 - flatFTy' i ty = [(RLabel $ show i, transformTy ty)] -flatFTy _ = $impossible +nkl2VLFileOpt :: String -> CL.Expr -> IO () +nkl2VLFileOpt prefix = + commonPipeline + >>> optimizeVLDefault + >>> exportVLPlan (prefix ++ "_opt") --- Determine the size of a flat type -sizeOfTy :: Type a -> Int -sizeOfTy (PairT _ t2) = 1 + sizeOfTy t2 -sizeOfTy _ = 1 +-------------------------------------------------------------------------------- +-- Functions for executing and debugging DSH queries via the Flattening backend --- | Transform an arbitrary DSH-type into a ferry core type -transformTy :: Type a -> FType -transformTy UnitT = int -transformTy BoolT = bool -transformTy CharT = string -transformTy TextT = string -transformTy IntegerT = int -transformTy DoubleT = float -transformTy (PairT t1 t2) = FRec [(RLabel "1", transformTy t1), (RLabel "2", transformTy t2)] -transformTy (ListT t1) = FList $ transformTy t1 -transformTy (ArrowT t1 t2) = transformTy t1 .-> transformTy t2 +-- | Run a query on a SQL backend +runQ :: QA a => H.Connection -> Q a -> IO a +runQ conn (Q q) = do + let ty = reify (undefined :: a) + q' <- toComprehensions (getTableInfo conn) q + let sqlQueryBundle = nkl2Sql q' + frExp <$> executeSql (SqlBackend conn) sqlQueryBundle ty +-- | Debugging function: dump the table algebra plan (JSON) to a file. +debugTA :: QA a => String -> H.Connection -> Q a -> IO () +debugTA prefix c (Q e) = do + e' <- toComprehensions (getTableInfo c) e + nkl2TAFile prefix e' -isOp :: Fun a b -> Bool -isOp Add = True -isOp Sub = True -isOp Mul = True -isOp Div = True -isOp Equ = True -isOp Lt = True -isOp Lte = True -isOp Gte = True -isOp Gt = True -isOp Conj = True -isOp Disj = True -isOp _ = False +-- | Debugging function: dump the optimized table algebra plan (JSON) to a file. +debugTAOpt :: QA a => String -> H.Connection -> Q a -> IO () +debugTAOpt prefix c (Q e) = do + e' <- toComprehensions (getTableInfo c) e + nkl2TAFileOpt prefix e' --- | Translate the DSH operator to Ferry Core operators -transformOp :: Fun a b -> Op -transformOp Add = Op "+" -transformOp Sub = Op "-" -transformOp Mul = Op "*" -transformOp Div = Op "/" -transformOp Equ = Op "==" -transformOp Lt = Op "<" -transformOp Lte = Op "<=" -transformOp Gte = Op ">=" -transformOp Gt = Op ">" -transformOp Conj = Op "&&" -transformOp Disj = Op "||" -transformOp _ = $impossible +-- | Debugging function: dump the VL query plan (DAG) for a query to a +-- file (SQL version). +debugVL :: QA a => String -> H.Connection -> Q a -> IO () +debugVL prefix c (Q e) = do + e' <- toComprehensions (getTableInfo c) e + nkl2VLFile prefix e' +-- | Debugging function: dump the optimized VL query plan (DAG) for a +-- query to a file (SQL version). +debugVLOpt :: QA a => String -> H.Connection -> Q a -> IO () +debugVLOpt prefix c (Q e) = do + e' <- toComprehensions (getTableInfo c) e + nkl2VLFileOpt prefix e' --- | Transform a DSH-primitive-function (f) with an instantiated typed into a FerryCore --- expression -transformF :: (Show f) => f -> FType -> CoreExpr -transformF f t = Var ([] :=> t) $ (\txt -> case txt of - (x:xs) -> toLower x : xs - _ -> $impossible) $ show f +-- | Dump all intermediate algebra representations (VL, TA) to files. +debugQ :: QA a => String -> H.Connection -> Q a -> IO () +debugQ prefix conn q = do + debugVL prefix conn q + debugVLOpt prefix conn q + debugTA prefix conn q + debugTAOpt prefix conn q --- | Retrieve through the given database connection information on the table (columns with their types) --- which name is given as the second argument. -getTableInfo :: IConnection conn => conn -> String -> IO [(String,FType -> Bool)] -getTableInfo c n = do - info <- describeTable c n - return $ toTableDescr info - - where - toTableDescr :: [(String, SqlColDesc)] -> [(String,FType -> Bool)] - toTableDescr = L.sortBy (\(n1, _) (n2, _) -> compare n1 n2) . map (\(name, props) -> (name, compatibleType (colType props))) - compatibleType :: SqlTypeId -> FType -> Bool - compatibleType dbT hsT = case hsT of - FUnit -> True - FBool -> dbT `L.elem` [SqlSmallIntT, SqlIntegerT, SqlBitT] - FString -> dbT `L.elem` [SqlCharT, SqlWCharT, SqlVarCharT] - FInt -> dbT `L.elem` [SqlSmallIntT, SqlIntegerT, SqlTinyIntT, SqlBigIntT, SqlNumericT] - FFloat -> dbT `L.elem` [SqlDecimalT, SqlRealT, SqlFloatT, SqlDoubleT] - t -> error $ "You can't store this kind of data in a table... " ++ show t ++ " " ++ show n +-- | Convenience function: execute a query on a SQL backend and print +-- its result +runPrint :: (Show a, QA a) => H.Connection -> Q a -> IO () +runPrint conn q = (show <$> runQ conn q) >>= putStrLn diff --git a/src/Database/DSH/Execute/Backend.hs b/src/Database/DSH/Execute/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Execute/Backend.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module provides an abstraction over flat relational backends +-- w.r.t. to query execution and result value construction. +module Database.DSH.Execute.Backend where + +import Text.Printf +import qualified Data.IntMap as IM +import qualified Data.DList as D +import Data.List + +import Database.DSH.Impossible +import Database.DSH.Frontend.Internals +import Database.DSH.Common.QueryPlan +import Database.DSH.Common.Pretty +import Database.DSH.Execute.TH + +-- | An abstract backend on which flat queries can be executed. +class Backend c where + data BackendRow c + data BackendCode c + + execFlatQuery :: c -> BackendCode c -> IO [BackendRow c] + +-- | Abstraction over result rows for a specific backend. +class Row r where + -- | The type of single attribute values + data Scalar r + + -- | Look up an attribute in the row + col :: String -> r -> (Scalar r) + + -- | Convert an attribute value to a segment descriptor value + descrVal :: Scalar r -> Int + + -- | Convert an attribute value to a value term + scalarVal :: Scalar r -> Type a -> Exp a + +------------------------------------------------------------------------------ +-- Different kinds of layouts that contain results in various forms + +-- Generate the definition for the 'TabTuple' type +$(mkTabTupleType 16) + +-- | Row layout with nesting data in the form of raw tabular results +data TabLayout a where + TCol :: Type a -> String -> TabLayout a + TNest :: (Reify a, Backend c, Row (BackendRow c)) => Type [a] -> [BackendRow c] -> TabLayout a -> TabLayout [a] + TTuple :: TabTuple a -> TabLayout a + +-- Generate the definition for the 'SegTuple' type +$(mkSegTupleType 16) + +-- | A map from segment descriptor to list value expressions +type SegMap a = IM.IntMap (Exp a) + +-- | Row layout with nesting data in the form of segment maps +data SegLayout a where + SCol :: Type a -> String -> SegLayout a + SNest :: Reify a => Type [a] -> SegMap [a] -> SegLayout [a] + STuple :: SegTuple a -> SegLayout a + +execQueryBundle :: (Backend c, Row (BackendRow c)) => c -> Shape (BackendCode c) -> Type a -> IO (Exp a) +execQueryBundle conn shape ty = + case (shape, ty) of + (VShape q lyt, ListT ety) -> do + tab <- execFlatQuery conn q + tlyt <- execNested conn lyt ety + return $ fromVector tab tlyt + (SShape q lyt, _) -> do + tab <- execFlatQuery conn q + tlyt <- execNested conn lyt ty + return $ fromPrim tab tlyt + _ -> $impossible + +-- | Traverse the layout and execute all subqueries for nested vectors +execNested :: (Backend c, Row (BackendRow c)) => c -> Layout (BackendCode c) -> Type a -> IO (TabLayout a) +execNested conn lyt ty = + case (lyt, ty) of + (LCol i, t) -> return $ TCol t (itemCol i) + (LNest q clyt, ListT t) -> do + tab <- execFlatQuery conn q + clyt' <- execNested conn clyt t + return $ TNest ty tab clyt' + (LTuple lyts, TupleT tupTy) -> let execTuple = $(mkExecTuple 16) + in execTuple lyts tupTy + (_, ty) -> error $ printf "Type does not match query structure: %s" (pp ty) + +------------------------------------------------------------------------------ +-- Construct result value terms from raw tabular results + +-- | +itemCol :: Int -> String +itemCol 1 = "item1" +itemCol 2 = "item2" +itemCol 3 = "item3" +itemCol 4 = "item4" +itemCol 5 = "item5" +itemCol 6 = "item6" +itemCol 7 = "item7" +itemCol 8 = "item8" +itemCol 9 = "item9" +itemCol 10 = "item10" +itemCol n = "item" ++ show n + +posCol :: Row r => r -> Int +posCol row = descrVal $ col "pos" row + +descrCol :: Row r => r -> Int +descrCol row = descrVal $ col "descr" row + +fromVector :: (Reify a, Row r) => [r] -> TabLayout a -> Exp [a] +fromVector tab tlyt = + let slyt = segmentLayout tlyt + in ListE $ D.toList $ foldl' (vecIter slyt) D.empty tab + +vecIter :: Row r => SegLayout a -> D.DList (Exp a) -> r -> D.DList (Exp a) +vecIter slyt vals row = + let val = constructVal slyt row + in D.snoc vals val + +fromPrim :: Row r => [r] -> TabLayout a -> Exp a +fromPrim tab tlyt = + let slyt = segmentLayout tlyt + in case tab of + [row] -> constructVal slyt row + _ -> $impossible + +------------------------------------------------------------------------------ +-- Construct nested result values from segmented vectors + +-- | Construct values for nested vectors in the layout. +segmentLayout :: TabLayout a -> SegLayout a +segmentLayout tlyt = + case tlyt of + TCol ty s -> SCol ty s + TNest ty tab clyt -> SNest ty (fromSegVector tab clyt) + TTuple tup -> let segmentTuple = $(mkSegmentTupleFun 16) + in STuple $ segmentTuple tup + +data SegAcc a = SegAcc { currSeg :: Int + , segMap :: SegMap [a] + , currVec :: D.DList (Exp a) + } + +-- | Construct a segment map from a segmented vector +fromSegVector :: (Reify a, Row r) => [r] -> TabLayout a -> SegMap [a] +fromSegVector tab tlyt = + let slyt = segmentLayout tlyt + initialAcc = SegAcc { currSeg = 0, segMap = IM.empty, currVec = D.empty } + finalAcc = foldl' (segIter slyt) initialAcc tab + in IM.insert (currSeg finalAcc) (ListE $ D.toList $ currVec finalAcc) (segMap finalAcc) + +-- | Fold iterator that constructs a map from segment descriptor to +-- the list value that is represented by that segment +segIter :: (Reify a, Row r) => SegLayout a -> SegAcc a -> r -> SegAcc a +segIter lyt acc row = + let val = constructVal lyt row + descr = descrCol row + in if descr == currSeg acc + then acc { currVec = D.snoc (currVec acc) val } + else acc { currSeg = descr + , segMap = IM.insert (currSeg acc) (ListE $ D.toList $ currVec acc) (segMap acc) + , currVec = D.singleton val + } + +------------------------------------------------------------------------------ +-- Construct values from table rows + +-- | Construct a value from a vector row according to the given layout +constructVal :: Row r => SegLayout a -> r -> Exp a +constructVal lyt row = + case lyt of + STuple stup -> let constructTuple = $(mkConstructTuple 16) + in constructTuple stup row + SNest _ segmap -> let pos = posCol row + in case IM.lookup pos segmap of + Just v -> v + Nothing -> ListE [] + SCol ty c -> scalarVal (col c row) ty diff --git a/src/Database/DSH/Execute/Sql.hs b/src/Database/DSH/Execute/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Execute/Sql.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +-- | This module implements the execution of SQL query bundles and the +-- construction of nested values from the resulting vector bundle. +module Database.DSH.Execute.Sql + ( executeSql + , SqlBackend(..) + , BackendCode(..) + ) where + +import Text.Printf + +import Database.HDBC +import Database.HDBC.PostgreSQL + +import qualified Data.Text as Txt +import qualified Data.Text.Encoding as Txt +import qualified Data.Map as M +import Control.Monad +import Control.Applicative + +import Database.DSH.Impossible +import Database.DSH.Frontend.Internals +import Database.DSH.Execute.Backend + +import Database.DSH.Common.QueryPlan + +newtype SqlBackend = SqlBackend Connection + +instance Backend SqlBackend where + data BackendRow SqlBackend = SqlRow (M.Map String SqlValue) + data BackendCode SqlBackend = SqlCode String + + execFlatQuery (SqlBackend conn) (SqlCode q) = do + stmt <- prepare conn q + void $ execute stmt [] + map SqlRow <$> fetchAllRowsMap' stmt + +instance Row (BackendRow SqlBackend) where + data Scalar (BackendRow SqlBackend) = SqlScalar 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) + + descrVal (SqlScalar (SqlInt32 i)) = fromIntegral i + descrVal (SqlScalar (SqlInteger i)) = fromIntegral i + descrVal _ = $impossible + + scalarVal (SqlScalar SqlNull) UnitT = UnitE + scalarVal (SqlScalar (SqlInteger _)) UnitT = UnitE + scalarVal (SqlScalar (SqlInteger i)) IntegerT = IntegerE i + scalarVal (SqlScalar (SqlInt32 i)) IntegerT = IntegerE $ fromIntegral i + scalarVal (SqlScalar (SqlInt64 i)) IntegerT = IntegerE $ fromIntegral i + scalarVal (SqlScalar (SqlWord32 i)) IntegerT = IntegerE $ fromIntegral i + scalarVal (SqlScalar (SqlWord64 i)) IntegerT = IntegerE $ fromIntegral i + scalarVal (SqlScalar (SqlDouble d)) DoubleT = DoubleE d + scalarVal (SqlScalar (SqlRational d)) DoubleT = DoubleE $ fromRational d + scalarVal (SqlScalar (SqlInteger d)) DoubleT = DoubleE $ fromIntegral d + scalarVal (SqlScalar (SqlInt32 d)) DoubleT = DoubleE $ fromIntegral d + scalarVal (SqlScalar (SqlInt64 d)) DoubleT = DoubleE $ fromIntegral d + scalarVal (SqlScalar (SqlWord32 d)) DoubleT = DoubleE $ fromIntegral d + scalarVal (SqlScalar (SqlWord64 d)) DoubleT = DoubleE $ fromIntegral d + scalarVal (SqlScalar (SqlBool b)) BoolT = BoolE b + scalarVal (SqlScalar (SqlInteger i)) BoolT = BoolE (i /= 0) + scalarVal (SqlScalar (SqlInt32 i)) BoolT = BoolE (i /= 0) + scalarVal (SqlScalar (SqlInt64 i)) BoolT = BoolE (i /= 0) + scalarVal (SqlScalar (SqlWord32 i)) BoolT = BoolE (i /= 0) + scalarVal (SqlScalar (SqlWord64 i)) BoolT = BoolE (i /= 0) + scalarVal (SqlScalar (SqlChar c)) CharT = CharE c + scalarVal (SqlScalar (SqlString (c:_))) CharT = CharE c + scalarVal (SqlScalar (SqlByteString c)) CharT = CharE (head $ Txt.unpack $ Txt.decodeUtf8 c) + scalarVal (SqlScalar (SqlString t)) TextT = TextE (Txt.pack t) + scalarVal (SqlScalar (SqlByteString s)) TextT = TextE (Txt.decodeUtf8 s) + scalarVal (SqlScalar sql) _ = error $ "Unsupported SqlValue: " ++ show sql + +-- | Execute a SQL query bundle on PostgreSQL. +executeSql :: SqlBackend -> Shape (BackendCode SqlBackend) -> Type a -> IO (Exp a) +executeSql = execQueryBundle diff --git a/src/Database/DSH/Execute/TH.hs b/src/Database/DSH/Execute/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Execute/TH.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Execute.TH + ( mkExecTuple + , mkTabTupleType + , mkSegTupleType + , mkSegmentTupleFun + , mkConstructTuple + ) where + +import Control.Applicative +import Language.Haskell.TH +import Data.List + +import Text.Printf + +import Database.DSH.Impossible +import Database.DSH.Frontend.TupleTypes +import qualified Database.DSH.Frontend.Internals as DSH + +-------------------------------------------------------------------------------- +-- Common name definitions + +tabTupleConsName :: Int -> Name +tabTupleConsName width = mkName $ printf "TTuple%d" width + +segTupleConsName :: Int -> Name +segTupleConsName width = mkName $ printf "STuple%d" width + +-------------------------------------------------------------------------------- +-- Generate the function that executes queries in a tuple layout + +elemTyName :: Int -> Q Name +elemTyName i = newName $ printf "ty%d" i + +elemLytName :: Int -> Q (Name, Name) +elemLytName i = (,) <$> newName (printf "lyt%d" i) + <*> newName (printf "lyt%d'" i) + + +-- | Generate the recursive call to 'execNested' +-- 'lyt' <- execNested conn lyt ty' +mkExecNestedStmt :: Name -> Name -> Name -> Stmt +mkExecNestedStmt tyName lytName resLytName = + let execNested = VarE $ mkName "execNested" + conn = VarE $ mkName "conn" + callE = AppE (AppE (AppE execNested conn) (VarE lytName)) (VarE tyName) + + in BindS (VarP resLytName) callE + +-- | Generate the case for one particular tuple type +mkExecTupleMatch :: Int -> Q Match +mkExecTupleMatch width = do + tyNames <- mapM elemTyName [1..width] + (lytNames, lytNames') <- unzip <$> mapM elemLytName [1..width] + + -- '([lyt1, ..., lyt], TupleT ty1 ... ty)' + let pat = TupP [ ListP $ map VarP lytNames + , ConP (tupTyConstName width) (map VarP tyNames) + ] + + -- 'return $ TTuple $ TTuple ty lyt1 ... lyt' + let execNestedStmts = zipWith3 mkExecNestedStmt tyNames lytNames lytNames' + returnStmt = NoBindS $ AppE (VarE 'return) + $ AppE (ConE $ mkName "TTuple") + $ foldl' AppE + (AppE (ConE $ tabTupleConsName width) (VarE $ mkName "ty")) + (map VarE lytNames') + + + return $ Match pat (NormalB $ DoE $ execNestedStmts ++ [returnStmt]) [] + +-- | Generate a lambda expression that matches on a tuple type layout +-- and recursively calls execNested on the tuple member layouts. +-- @ +-- \lyts ty -> +-- case (lyts, ty) of +-- ([lyt1, ..., lyt], TupleT ty1 ... ty) -> do +-- lyt1' <- execNested conn lyt1 ty1 +-- ... +-- lyt' <- execNested conn lyt ty +-- return $ TTuple $ TTuple ty lyt1 ... lyt +-- @ +-- +-- The lambda expression is /not/ closed: The names 'conn' and 'ty' must be in +-- scope where 'conn' is the database connection and 'ty' is the tuple type being +-- dissected. +mkExecTuple :: Int -> Q Exp +mkExecTuple maxWidth = do + lytName <- newName "lyts" + tyName <- newName "tys" + + tupMatches <- mapM mkExecTupleMatch [2..maxWidth] + impossibleExp <- impossible + let matches = tupMatches ++ [Match WildP (NormalB impossibleExp) []] + + let lamBody = CaseE (TupE [VarE lytName, VarE tyName]) matches + return $ LamE [VarP lytName, VarP tyName] lamBody + +-------------------------------------------------------------------------------- +-- Generate tuple layout type containing individual query results or +-- segmaps. The code generated for both is mostly identical except for +-- the layout type constructor and the constructor names. + +tupElemTyName :: Int -> Q Name +tupElemTyName i = newName $ printf "t%d" i + +-- | Generate a single constructor for the 'TabTuple' type. +mkTupleLytCons :: Name -> (Type -> Type) -> (Int -> Name) -> Int -> Q Con +mkTupleLytCons tupTyName lytTyCons conName width = do + + tupElemTyNames <- mapM tupElemTyName [1..width] + + let tyVarBinders = map PlainTV tupElemTyNames + + -- (t1, ..., t) + tupTy = foldl' AppT (TupleT width) + $ map VarT tupElemTyNames + + -- a ~ (t1, ..., t) + tupConstraint = EqualP (VarT tupTyName) tupTy + + -- Reify t1, ..., Reify t + reifyConstraints = map (\n -> ClassP ''DSH.Reify [VarT n]) tupElemTyNames + + constraints = tupConstraint : reifyConstraints + + let -- 'Type a' + dshTypeTy = (NotStrict, AppT (ConT ''DSH.Type) (VarT tupTyName)) + -- 'TabLayout t1, TabLayout t + elemLytTys = [ (NotStrict, lytTyCons (VarT t)) -- AppT (ConT $ mkName "TabLayout") (VarT t)) + | t <- tupElemTyNames + ] + argTys = dshTypeTy : elemLytTys + + return $ ForallC tyVarBinders constraints + $ NormalC (conName width) {- (tabTupleConsName width) -} argTys + +-- | Generate the data type for 'TabTuple'/'SegTuple' layouts that contain +-- tabular query results. +-- @ +-- data TabTuple a where +-- TTuple3 :: (Reify t1, ..., Reify t) => Type (t1, ..., t) +-- -> TabLayout t1 +-- -> ... +-- -> TabLayout t +-- -> TabTuple (t1, ..., t) +-- @ +-- +-- Because TH does not directly support GADT syntax, we have to +-- emulate it using explicit universal quantification: +-- +-- @ +-- data TabTuple a = +-- forall t1, ..., t. a ~ (t1, ..., t), +-- Reify t1, +-- ... +-- Reify t => +-- Type a -> TabLayout t1 -> ... -> TabLayout t +-- @ +mkTupleLyt :: Name -> (Type -> Type) -> (Int -> Name) -> Int -> Q [Dec] +mkTupleLyt tyName lytTyCons conName maxWidth = do + tupTyName <- newName "a" + cons <- mapM (mkTupleLytCons tupTyName lytTyCons conName) [2..maxWidth] + + return $ [DataD [] tyName [PlainTV tupTyName] cons []] + +-------------------------------------------------------------------------------- +-- Generate the tuple layout type containing tabular results + +mkTabTupleType :: Int -> Q [Dec] +mkTabTupleType maxWidth = mkTupleLyt tabTupleTyName tabLayoutTyCons tabTupleConsName maxWidth + where + tabLayoutTyCons :: Type -> Type + tabLayoutTyCons argTy = AppT (ConT $ mkName "TabLayout") argTy + + tabTupleTyName :: Name + tabTupleTyName = mkName "TabTuple" + +-------------------------------------------------------------------------------- +-- Generate the tuple layout type containing segment maps + +mkSegTupleType :: Int -> Q [Dec] +mkSegTupleType maxWidth = mkTupleLyt segTupleTyName segLayoutTyCons segTupleConsName maxWidth + where + segLayoutTyCons :: Type -> Type + segLayoutTyCons argTy = AppT (ConT $ mkName "SegLayout") argTy + + segTupleTyName :: Name + segTupleTyName = mkName "SegTuple" + +-------------------------------------------------------------------------------- +-- Generate the mapping function between tabular and segment map layouts. + +mkSegmentTupleMatch :: Int -> Q Match +mkSegmentTupleMatch width = do + tyName <- newName "ty" + lytNames <- mapM (\i -> newName $ printf "tlyt%d" i) [1..width] + let tuplePat = ConP (tabTupleConsName width) (VarP tyName : map VarP lytNames) + + let segFun = VarE $ mkName "segmentLayout" + segLyts = map ((AppE segFun) . VarE) lytNames + + let bodyExp = foldl' AppE (ConE $ segTupleConsName width) + (VarE tyName : segLyts) + return $ Match tuplePat (NormalB bodyExp) [] + +-- | Generate the definition for the 'segmentTuple' function that maps +-- layouts with tabular SQL results to layouts with segment maps. +-- @ +-- +-- \lyt -> +-- case lyt of +-- ... +-- (TTuple ty tlyt1 ... tlyt) = STuple ty (segmentLayout tlyt1) +-- ... +-- (segmentLayout tlyt) +-- @ +mkSegmentTupleFun :: Int -> Q Exp +mkSegmentTupleFun maxWidth = do + lytName <- newName "lyt" + tupMatches <- mapM mkSegmentTupleMatch [2..maxWidth] + let lamBody = CaseE (TupE [VarE lytName]) tupMatches + + return $ LamE [VarP lytName] lamBody + +-------------------------------------------------------------------------------- +-- Generate the constructor function from a segmap tuple layout to a +-- tuple value + +mkConstructTupleMatch :: Name -> Int -> Q Match +mkConstructTupleMatch rowName width = do + lytNames <- mapM (\i -> newName $ printf "slyt%d" i) [1..width] + + let tuplePat = ConP (segTupleConsName width) (WildP : map VarP lytNames) + + let constructFun = VarE $ mkName "constructVal" + resultElemExps = [ AppE (AppE constructFun (VarE l)) (VarE rowName) + | l <- lytNames + ] + resultValExp = AppE (ConE outerConst) + (foldl' AppE (ConE $ innerConst width) resultElemExps) + + return $ Match tuplePat (NormalB resultValExp) [] + +mkConstructTuple :: Int -> Q Exp +mkConstructTuple maxWidth = do + lytName <- newName "lyt" + rowName <- newName "row" + + tupMatches <- mapM (mkConstructTupleMatch rowName) [2..maxWidth] + let lamBody = CaseE (TupE [VarE lytName]) tupMatches + + return $ LamE [VarP lytName, VarP rowName] lamBody diff --git a/src/Database/DSH/Export.hs b/src/Database/DSH/Export.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Export.hs @@ -0,0 +1,37 @@ +-- | Debug functions to export query plans and rendered database code +-- in various forms. +module Database.DSH.Export + ( exportVLPlan + , exportTAPlan + ) where + +import Database.Algebra.Dag +import Database.Algebra.Table.Lang +import qualified Database.Algebra.Table.Render.JSON as PFJSON + +import Database.DSH.Common.QueryPlan +import Database.DSH.VL.Lang +import Database.DSH.VL.Vector +import qualified Database.DSH.VL.Render.JSON as VLJSON + +exportVLPlan :: String -> QueryPlan VL VLDVec -> IO () +exportVLPlan prefix vlPlan = do + let planPath = prefix ++ "_vl.plan" + shapePath = prefix ++ "_vl.shape" + + VLJSON.planToFile planPath ( queryTags vlPlan + , shapeNodes $ queryShape vlPlan + , nodeMap $ queryDag vlPlan + ) + writeFile shapePath $ show $ queryShape vlPlan + +exportTAPlan :: String -> QueryPlan TableAlgebra NDVec -> IO () +exportTAPlan prefix pfPlan = do + let planPath = prefix ++ "_ta.plan" + shapePath = prefix ++ "_ta.shape" + + PFJSON.planToFile planPath ( queryTags pfPlan + , shapeNodes $ queryShape pfPlan + , nodeMap $ queryDag pfPlan + ) + writeFile shapePath $ show $ queryShape pfPlan diff --git a/src/Database/DSH/Externals.hs b/src/Database/DSH/Externals.hs deleted file mode 100644 --- a/src/Database/DSH/Externals.hs +++ /dev/null @@ -1,661 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} - -module Database.DSH.Externals where - -import Database.DSH.Internals -import Database.DSH.Impossible -import Database.DSH.TH - -import Prelude ( Eq, Ord, Num(..), Fractional(..), Show(..) - , Bool(..), Char, Integer, Double, String, Maybe(..), Either(..) - , id, undefined, ($), (.)) -import qualified Prelude as P - -import Data.String -import Data.Text (Text) -import qualified Data.Text as T - --- QA Instances - -instance QA () where - type Rep () = () - toExp () = UnitE - frExp UnitE = () - frExp _ = $impossible - -instance QA Bool where - type Rep Bool = Bool - toExp = BoolE - frExp (BoolE b) = b - frExp _ = $impossible - -instance QA Char where - type Rep Char = Char - toExp = CharE - frExp (CharE c) = c - frExp _ = $impossible - -instance QA Integer where - type Rep Integer = Integer - toExp = IntegerE - frExp (IntegerE i) = i - frExp _ = $impossible - -instance QA Double where - type Rep Double = Double - toExp = DoubleE - frExp (DoubleE d) = d - frExp _ = $impossible - -instance QA Text where - type Rep Text = Text - toExp = TextE - frExp (TextE t) = t - frExp _ = $impossible - -instance (QA a,QA b) => QA (a,b) where - type Rep (a,b) = (Rep a,Rep b) - toExp (a,b) = PairE (toExp a) (toExp b) - frExp (PairE a b) = (frExp a,frExp b) - frExp _ = $impossible - -instance (QA a,QA b,QA c) => QA (a,b,c) where - type Rep (a,b,c) = (Rep a,(Rep b,Rep c)) - toExp (a,b,c) = PairE (toExp a) (PairE (toExp b) (toExp c)) - frExp (PairE a (PairE b c)) = (frExp a,frExp b,frExp c) - frExp _ = $impossible - -instance (QA a) => QA [a] where - type Rep [a] = [Rep a] - toExp as = ListE (P.map toExp as) - frExp (ListE as) = P.map frExp as - frExp _ = $impossible - -instance (QA a) => QA (Maybe a) where - type Rep (Maybe a) = [Rep a] - toExp Nothing = ListE [] - toExp (Just a) = ListE [toExp a] - frExp (ListE []) = Nothing - frExp (ListE (a : _)) = Just (frExp a) - frExp _ = $impossible - -instance (QA a,QA b) => QA (Either a b) where - type Rep (Either a b) = ([Rep a],[Rep b]) - toExp (Left a) = PairE (ListE [toExp a]) (ListE []) - toExp (Right b) = PairE (ListE []) (ListE [toExp b]) - frExp (PairE (ListE (a : _)) _) = Left (frExp a) - frExp (PairE _ (ListE (a : _))) = Right (frExp a) - frExp _ = $impossible - --- Elim instances - -instance (QA r) => Elim () r where - type Eliminator () r = Q r -> Q r - elim _ r = r - -instance (QA r) => Elim Bool r where - type Eliminator Bool r = Q r -> Q r -> Q r - elim (Q e) (Q e1) (Q e2) = Q (AppE Cond (PairE e (PairE e1 e2))) - -instance (QA r) => Elim Char r where - type Eliminator Char r = (Q Char -> Q r) -> Q r - elim q f = f q - -instance (QA r) => Elim Integer r where - type Eliminator Integer r = (Q Integer -> Q r) -> Q r - elim q f = f q - -instance (QA r) => Elim Double r where - type Eliminator Double r = (Q Double -> Q r) -> Q r - elim q f = f q - -instance (QA r) => Elim Text r where - type Eliminator Text r = (Q Text -> Q r) -> Q r - elim q f = f q - -instance (QA a,QA b,QA r) => Elim (a,b) r where - type Eliminator (a,b) r = (Q a -> Q b -> Q r) -> Q r - elim q f = f (fst q) (snd q) - -instance (QA a,QA r) => Elim (Maybe a) r where - type Eliminator (Maybe a) r = Q r -> (Q a -> Q r) -> Q r - elim q r f = maybe r f q - -instance (QA a,QA b,QA r) => Elim (Either a b) r where - type Eliminator (Either a b) r = (Q a -> Q r) -> (Q b -> Q r) -> Q r - elim q f g = either f g q - --- BasicType instances - -instance BasicType () where -instance BasicType Bool where -instance BasicType Char where -instance BasicType Integer where -instance BasicType Double where -instance BasicType Text where - --- TA instances - -instance TA () where -instance TA Bool where -instance TA Char where -instance TA Integer where -instance TA Double where -instance TA Text where -instance (BasicType a, BasicType b) => TA (a,b) where -instance (BasicType a, BasicType b, BasicType c) => TA (a,b,c) where - --- Num and Fractional instances - -instance Num (Exp Integer) where - (+) e1 e2 = AppE Add (PairE e1 e2) - (*) e1 e2 = AppE Mul (PairE e1 e2) - (-) e1 e2 = AppE Sub (PairE e1 e2) - - fromInteger = IntegerE - - abs e = let c = AppE Lt (PairE e 0) - in AppE Cond (PairE c (PairE (negate e) e)) - - signum e = let c1 = AppE Lt (PairE e 0) - c2 = AppE Equ (PairE e 0) - e' = AppE Cond (PairE c2 (PairE 0 1)) - in AppE Cond (PairE c1 (PairE (-1) e')) - -instance Num (Exp Double) where - (+) e1 e2 = AppE Add (PairE e1 e2) - (*) e1 e2 = AppE Mul (PairE e1 e2) - (-) e1 e2 = AppE Sub (PairE e1 e2) - - fromInteger = DoubleE . fromInteger - - abs e = let c = AppE Lt (PairE e 0) - in AppE Cond (PairE c (PairE (negate e) e)) - - signum e = let c1 = AppE Lt (PairE e 0.0) - c2 = AppE Equ (PairE e 0.0) - e' = AppE Cond (PairE c2 (PairE 0 1)) - in AppE Cond (PairE c1 (PairE (-1) e')) - -instance Fractional (Exp Double) where - (/) e1 e2 = AppE Div (PairE e1 e2) - fromRational = DoubleE . fromRational - -instance Num (Q Integer) where - (+) (Q e1) (Q e2) = Q (e1 + e2) - (*) (Q e1) (Q e2) = Q (e1 * e2) - (-) (Q e1) (Q e2) = Q (e1 - e2) - fromInteger = Q . IntegerE - abs (Q e) = Q (abs e) - signum (Q e) = Q (signum e) - -instance Num (Q Double) where - (+) (Q e1) (Q e2) = Q (e1 + e2) - (*) (Q e1) (Q e2) = Q (e1 * e2) - (-) (Q e1) (Q e2) = Q (e1 - e2) - fromInteger = Q . DoubleE . fromInteger - abs (Q e) = Q (abs e) - signum (Q e) = Q (signum e) - -instance Fractional (Q Double) where - (/) (Q e1) (Q e2) = Q (e1 / e2) - fromRational = Q . DoubleE . fromRational - --- View instances - -instance View (Q ()) where - type ToView (Q ()) = Q () - view = id - -instance View (Q Bool) where - type ToView (Q Bool) = Q Bool - view = id - -instance View (Q Char) where - type ToView (Q Char) = Q Char - view = id - -instance View (Q Integer) where - type ToView (Q Integer) = Q Integer - view = id - -instance View (Q Double) where - type ToView (Q Double) = Q Double - view = id - -instance View (Q Text) where - type ToView (Q Text) = Q Text - view = id - -instance (QA a, QA b) => View (Q (a,b)) where - type ToView (Q (a,b)) = (Q a,Q b) - view (Q e) = (Q (AppE Fst e),Q (AppE Snd e)) - -instance (QA a,QA b,QA c) => View (Q (a,b,c)) where - type ToView (Q (a,b,c)) = (Q a,Q b,Q c) - view (Q e) = (Q (AppE Fst e),Q (AppE Fst (AppE Snd e)),Q (AppE Snd (AppE Snd e))) - --- IsString instances - -instance IsString (Q Text) where - fromString = Q . TextE . T.pack - --- * Referring to persistent tables - -table :: (QA a, TA a) => String -> Q [a] -table name = Q (TableE (TableDB name [])) - -tableDB :: (QA a, TA a) => String -> Q [a] -tableDB name = Q (TableE (TableDB name [])) - -tableWithKeys :: (QA a, TA a) => String -> [[String]] -> Q [a] -tableWithKeys name keys = Q (TableE (TableDB name keys)) - -tableCSV :: (QA a, TA a) => String -> Q [a] -tableCSV filename = Q (TableE (TableCSV filename)) - --- * toQ - -toQ :: (QA a) => a -> Q a -toQ = Q . toExp - --- * Unit - -unit :: Q () -unit = Q UnitE - --- * Boolean logic - -false :: Q Bool -false = Q (BoolE False) - -true :: Q Bool -true = Q (BoolE True) - -not :: Q Bool -> Q Bool -not (Q e) = Q (AppE Not e) - -(&&) :: Q Bool -> Q Bool -> Q Bool -(&&) (Q a) (Q b) = Q (AppE Conj (PairE a b)) - -(||) :: Q Bool -> Q Bool -> Q Bool -(||) (Q a) (Q b) = Q (AppE Disj (PairE a b)) - --- * Equality and Ordering - -eq :: (QA a,Eq a) => Q a -> Q a -> Q Bool -eq (Q a) (Q b) = Q (AppE Equ (PairE a b)) - -(==) :: (QA a,Eq a) => Q a -> Q a -> Q Bool -(==) = eq - -neq :: (QA a,Eq a) => Q a -> Q a -> Q Bool -neq a b = not (eq a b) - -(/=) :: (QA a,Eq a) => Q a -> Q a -> Q Bool -(/=) = neq - -lt :: (QA a,Ord a) => Q a -> Q a -> Q Bool -lt (Q a) (Q b) = Q (AppE Lt (PairE a b)) - -(<) :: (QA a,Ord a) => Q a -> Q a -> Q Bool -(<) = lt - -lte :: (QA a,Ord a) => Q a -> Q a -> Q Bool -lte (Q a) (Q b) = Q (AppE Lte (PairE a b)) - -(<=) :: (QA a,Ord a) => Q a -> Q a -> Q Bool -(<=) = lte - -gte :: (QA a,Ord a) => Q a -> Q a -> Q Bool -gte (Q a) (Q b) = Q (AppE Gte (PairE a b)) - -(>=) :: (QA a,Ord a) => Q a -> Q a -> Q Bool -(>=) = gte - -gt :: (QA a,Ord a) => Q a -> Q a -> Q Bool -gt (Q a) (Q b) = Q (AppE Gt (PairE a b)) - -(>) :: (QA a,Ord a) => Q a -> Q a -> Q Bool -(>) = gt - -min :: (QA a,Ord a) => Q a -> Q a -> Q a -min (Q a) (Q b) = Q (AppE Min (PairE a b)) - -max :: (QA a,Ord a) => Q a -> Q a -> Q a -max (Q a) (Q b) = Q (AppE Max (PairE a b)) - --- * Conditionals - -bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a -bool f t b = cond b t f - -cond :: (QA a) => Q Bool -> Q a -> Q a -> Q a -cond (Q c) (Q a) (Q b) = Q (AppE Cond (PairE c (PairE a b))) - -ifThenElse :: (QA a) => Q Bool -> Q a -> Q a -> Q a -ifThenElse = cond - -(?) :: (QA a) => Q Bool -> (Q a,Q a) -> Q a -(?) c (a,b) = cond c a b - --- * Maybe - -listToMaybe :: (QA a) => Q [a] -> Q (Maybe a) -listToMaybe (Q as) = Q as - -maybeToList :: (QA a) => Q (Maybe a) -> Q [a] -maybeToList (Q ma) = Q ma - -nothing :: (QA a) => Q (Maybe a) -nothing = listToMaybe nil - -just :: (QA a) => Q a -> Q (Maybe a) -just a = listToMaybe (singleton a) - -isNothing :: (QA a) => Q (Maybe a) -> Q Bool -isNothing ma = null (maybeToList ma) - -isJust :: (QA a) => Q (Maybe a) -> Q Bool -isJust ma = not (isNothing ma) - -fromJust :: (QA a) => Q (Maybe a) -> Q a -fromJust ma = head (maybeToList ma) - -maybe :: (QA a,QA b) => Q b -> (Q a -> Q b) -> Q (Maybe a) -> Q b -maybe b f ma = isNothing ma ? (b,f (fromJust ma)) - -fromMaybe :: (QA a) => Q a -> Q (Maybe a) -> Q a -fromMaybe a ma = isNothing ma ? (a,fromJust ma) - -catMaybes :: (QA a) => Q [Maybe a] -> Q [a] -catMaybes = concatMap maybeToList - -mapMaybe :: (QA a,QA b) => (Q a -> Q (Maybe b)) -> Q [a] -> Q [b] -mapMaybe f = concatMap (maybeToList . f) - --- * Either - -pairToEither :: (QA a,QA b) => Q ([a],[b]) -> Q (Either a b) -pairToEither (Q a) = Q a - -eitherToPair :: (QA a,QA b) => Q (Either a b) -> Q ([a],[b]) -eitherToPair (Q a) = Q a - -left :: (QA a,QA b) => Q a -> Q (Either a b) -left a = pairToEither (pair (singleton a) nil) - -right :: (QA a,QA b) => Q b -> Q (Either a b) -right a = pairToEither (pair nil (singleton a)) - -isLeft :: (QA a,QA b) => Q (Either a b) -> Q Bool -isLeft = null . snd . eitherToPair - -isRight :: (QA a,QA b) => Q (Either a b) -> Q Bool -isRight = null . fst . eitherToPair - -either :: (QA a,QA b,QA c) => (Q a -> Q c) -> (Q b -> Q c) -> Q (Either a b) -> Q c -either lf rf e = - let p = eitherToPair e - in head (map lf (fst p) ++ map rf (snd p)) - -lefts :: (QA a,QA b) => Q [Either a b] -> Q [a] -lefts = concatMap (fst . eitherToPair) - -rights :: (QA a,QA b) => Q [Either a b] -> Q [b] -rights = concatMap (snd . eitherToPair) - -partitionEithers :: (QA a,QA b) => Q [Either a b] -> Q ([a], [b]) -partitionEithers es = pair (lefts es) (rights es) - --- * List Construction - -nil :: (QA a) => Q [a] -nil = Q (ListE []) - -empty :: (QA a) => Q [a] -empty = nil - -cons :: (QA a) => Q a -> Q [a] -> Q [a] -cons (Q a) (Q as) = Q (AppE Cons (PairE a as)) - -(<|) :: (QA a) => Q a -> Q [a] -> Q [a] -(<|) = cons - -snoc :: (QA a) => Q [a] -> Q a -> Q [a] -snoc as a = append as (singleton a) - -(|>) :: (QA a) => Q [a] -> Q a -> Q [a] -(|>) = snoc - -singleton :: (QA a) => Q a -> Q [a] -singleton (Q e) = cons (Q e) nil - --- * List Operations - -head :: (QA a) => Q [a] -> Q a -head (Q as) = Q (AppE Head as) - -tail :: (QA a) => Q [a] -> Q [a] -tail (Q as) = Q (AppE Tail as) - -take :: (QA a) => Q Integer -> Q [a] -> Q [a] -take (Q i) (Q as) = Q (AppE Take (PairE i as)) - -drop :: (QA a) => Q Integer -> Q [a] -> Q [a] -drop (Q i) (Q as) = Q (AppE Drop (PairE i as)) - -map :: (QA a,QA b) => (Q a -> Q b) -> Q [a] -> Q [b] -map f (Q as) = Q (AppE Map (PairE (LamE (toLam f)) as)) - -append :: (QA a) => Q [a] -> Q [a] -> Q [a] -append (Q as) (Q bs) = Q (AppE Concat (ListE [as,bs])) - -(++) :: (QA a) => Q [a] -> Q [a] -> Q [a] -(++) = append - -filter :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] -filter f (Q as) = Q (AppE Filter (PairE (LamE (toLam f)) as)) - -groupWithKey :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [(b,[a])] -groupWithKey f (Q as) = Q (AppE GroupWithKey (PairE (LamE (toLam f)) as)) - -groupWith :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [[a]] -groupWith f as = map snd (groupWithKey f as) - -sortWith :: (QA a,QA b,Ord b) => (Q a -> Q b) -> Q [a] -> Q [a] -sortWith f (Q as) = Q (AppE SortWith (PairE (LamE (toLam f)) as)) - -last :: (QA a) => Q [a] -> Q a -last (Q as) = Q (AppE Last as) - -init :: (QA a) => Q [a] -> Q [a] -init (Q as) = Q (AppE Init as) - -null :: (QA a) => Q [a] -> Q Bool -null (Q as) = Q (AppE Null as) - -length :: (QA a) => Q [a] -> Q Integer -length (Q as) = Q (AppE Length as) - -index :: (QA a) => Q [a] -> Q Integer -> Q a -index (Q as) (Q i) = Q (AppE Index (PairE as i)) - -(!!) :: (QA a) => Q [a] -> Q Integer -> Q a -(!!) = index - -reverse :: (QA a) => Q [a] -> Q [a] -reverse (Q as) = Q (AppE Reverse as) - --- * Special folds - -and :: Q [Bool] -> Q Bool -and (Q bs) = Q (AppE And bs) - -or :: Q [Bool] -> Q Bool -or (Q bs) = Q (AppE Or bs) - -any :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool -any f = or . map f - -all :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool -all f = and . map f - -sum :: (QA a,Num a) => Q [a] -> Q a -sum (Q as) = Q (AppE Sum as) - -concat :: (QA a) => Q [[a]] -> Q [a] -concat (Q ass) = Q (AppE Concat ass) - -concatMap :: (QA a,QA b) => (Q a -> Q [b]) -> Q [a] -> Q [b] -concatMap f as = concat (map f as) - -maximum :: (QA a,Ord a) => Q [a] -> Q a -maximum (Q as) = Q (AppE Maximum as) - -minimum :: (QA a,Ord a) => Q [a] -> Q a -minimum (Q as) = Q (AppE Minimum as) - --- * Sublists - -splitAt :: (QA a) => Q Integer -> Q [a] -> Q ([a],[a]) -splitAt (Q i) (Q as) = Q (AppE SplitAt (PairE i as)) - -takeWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] -takeWhile f (Q as) = Q (AppE TakeWhile (PairE (LamE (toLam f)) as)) - -dropWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] -dropWhile f (Q as) = Q (AppE DropWhile (PairE (LamE (toLam f)) as)) - -span :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) -span f as = pair (takeWhile f as) (dropWhile f as) - -break :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) -break f = span (not . f) - --- * Searching Lists - -elem :: (QA a,Eq a) => Q a -> Q [a] -> Q Bool -elem a as = null (filter (a ==) as) ? (false,true) - -notElem :: (QA a,Eq a) => Q a -> Q [a] -> Q Bool -notElem a as = not (a `elem` as) - -lookup :: (QA a,QA b,Eq a) => Q a -> Q [(a, b)] -> Q (Maybe b) -lookup a = listToMaybe . map snd . filter ((a ==) . fst) - --- * Zipping and Unzipping Lists - -zip :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)] -zip (Q as) (Q bs) = Q (AppE Zip (PairE as bs)) - -zipWith :: (QA a,QA b,QA c) => (Q a -> Q b -> Q c) -> Q [a] -> Q [b] -> Q [c] -zipWith f as bs = map (\e -> f (fst e) (snd e)) (zip as bs) - -unzip :: (QA a,QA b) => Q [(a,b)] -> Q ([a],[b]) -unzip as = pair (map fst as) (map snd as) - -zip3 :: (QA a,QA b,QA c) => Q [a] -> Q [b] -> Q [c] -> Q [(a,b,c)] -zip3 as bs cs = map (\abc -> triple (fst abc) (fst (snd abc)) (snd (snd abc))) (zip as (zip bs cs)) - -zipWith3 :: (QA a,QA b,QA c,QA d) => (Q a -> Q b -> Q c -> Q d) -> Q [a] -> Q [b] -> Q [c] -> Q [d] -zipWith3 f as bs cs = map (\e -> (case view e of (a,b,c) -> f a b c)) - (zip3 as bs cs) - -unzip3 :: (QA a,QA b,QA c) => Q [(a,b,c)] -> Q ([a],[b],[c]) -unzip3 abcs = triple (map (\e -> (case view e of (a,_,_) -> a)) abcs) - (map (\e -> (case view e of (_,b,_) -> b)) abcs) - (map (\e -> (case view e of (_,_,c) -> c)) abcs) - --- * Set-oriented operations - -nub :: (QA a,Eq a) => Q [a] -> Q [a] -nub (Q as) = Q (AppE Nub as) - --- * Tuple Projection Functions - -fst :: (QA a,QA b) => Q (a,b) -> Q a -fst (Q e) = Q (AppE Fst e) - -snd :: (QA a,QA b) => Q (a,b) -> Q b -snd (Q e) = Q (AppE Snd e) - --- * Conversions between numeric types - -integerToDouble :: Q Integer -> Q Double -integerToDouble (Q i) = Q (AppE IntegerToDouble i) - --- * Rebind Monadic Combinators - -return :: (QA a) => Q a -> Q [a] -return = singleton - -(>>=) :: (QA a,QA b) => Q [a] -> (Q a -> Q [b]) -> Q [b] -(>>=) ma f = concatMap f ma - -(>>) :: (QA a,QA b) => Q [a] -> Q [b] -> Q [b] -(>>) ma mb = concatMap (\_ -> mb) ma - -mzip :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)] -mzip = zip - -guard :: Q Bool -> Q [()] -guard c = cond c (singleton unit) nil - --- * Construction of tuples - -pair :: (QA a,QA b) => Q a -> Q b -> Q (a,b) -pair (Q a) (Q b) = Q (PairE a b) - -triple :: (QA a,QA b,QA c) => Q a -> Q b -> Q c -> Q (a,b,c) -triple (Q a) (Q b) (Q c)= Q (PairE a (PairE b c)) - -infixl 9 !! -infixr 5 ++, <|, |> -infix 4 ==, /=, <, <=, >=, > -infixr 3 && -infixr 2 || -infix 0 ? - -deriveTupleRangeQA 4 7 -deriveTupleRangeTA 4 7 -deriveTupleRangeView 4 7 -deriveTupleRangeSmartConstructors 2 7 - --- * Missing functions - --- $missing -{- $missing - -This module offers most of the functions on lists given in PreludeList for the -'Q' type. Missing functions are: - -General folds: - -> foldl -> foldl1 -> scanl -> scanl1 -> foldr -> foldr1 -> scanr -> scanr1 - -Infinit lists: - -> iterate -> repeat -> cycle - -String functions: - -> lines -> words -> unlines -> unwords - --} diff --git a/src/Database/DSH/FKL/Kure.hs b/src/Database/DSH/FKL/Kure.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/FKL/Kure.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Infrastructure for KURE-based rewrites on FKL expressions +module Database.DSH.FKL.Kure + ( -- * Re-export relevant KURE modules + module Language.KURE + , module Language.KURE.Lens + + -- * The KURE monad + , RewriteM, RewriteStateM, TransformF, RewriteF, LensF + + -- * Setters and getters for the translation state + , get, put, modify, initialCtx + + -- * Changing between stateful and non-stateful transforms + , statefulT, liftstateT + + -- * The KURE context + , FlatCtx(..), CrumbF(..), PathF + + -- * Universes + , FKL(..) + + -- * Congruence combinators + , tableT, papp1T, papp2T, papp3T, binopT, unopT + , ifT, constExprT, varT, letT + + , tableR, papp1R, papp2R, papp3R, binopR, unopR + , ifR, constExprR, varR, letR + + , inScopeNames, freeIn, boundIn, freshNameT + + ) where + + +import Control.Monad +import Data.Monoid + +import Language.KURE +import Language.KURE.Lens + +import Database.DSH.Common.RewriteM +import Database.DSH.Common.Nat +import Database.DSH.Common.Lang +import Database.DSH.Common.Type +import Database.DSH.Common.Pretty +import Database.DSH.FKL.Lang + +-------------------------------------------------------------------------------- +-- Convenience type aliases + +type TransformF a b = Transform FlatCtx (RewriteM Int) a b +type RewriteF a = TransformF a a +type LensF a b = Lens FlatCtx (RewriteM Int) a b + +-------------------------------------------------------------------------------- + +data CrumbF = AppFun + | PApp1Arg + | PApp2Arg1 + | PApp2Arg2 + | PApp3Arg1 + | PApp3Arg2 + | PApp3Arg3 + | BinOpArg1 + | BinOpArg2 + | UnOpArg + | IfCond + | IfThen + | IfElse + | ImprintArg1 + | ImprintArg2 + | ForgetArg + | BroadcastArg1 + | BroadcastArg2 + | BroadcastLArg1 + | BroadcastLArg2 + | LetBind + | LetBody + | TupleElem Int + | ExtExpr + deriving (Eq, Show) + +type AbsPathF = AbsolutePath CrumbF + +type PathF = Path CrumbF + +-- | The context for KURE-based FKL rewrites +data FlatCtx = FlatCtx { fkl_path :: AbsPathF + , fkl_bindings :: [Ident] + } + +instance ExtendPath FlatCtx CrumbF where + c@@n = c { fkl_path = fkl_path c @@ n } + +instance ReadPath FlatCtx CrumbF where + absPath c = fkl_path c + +initialCtx :: FlatCtx +initialCtx = FlatCtx { fkl_path = mempty, fkl_bindings = [] } + +-- | Record a variable binding in the context +bindVar :: Ident -> FlatCtx -> FlatCtx +bindVar n ctx = ctx { fkl_bindings = n : fkl_bindings ctx } + +inScopeNames :: FlatCtx -> [Ident] +inScopeNames = fkl_bindings + +boundIn :: Ident -> FlatCtx -> Bool +boundIn n ctx = n `elem` (fkl_bindings ctx) + +freeIn :: Ident -> FlatCtx -> Bool +freeIn n ctx = n `notElem` (fkl_bindings ctx) + +-- | Generate a fresh name that is not bound in the current context. +freshNameT :: [Ident] -> TransformF a Ident +freshNameT avoidNames = do + ctx <- contextT + constT $ freshName (avoidNames ++ inScopeNames ctx) + +-------------------------------------------------------------------------------- +-- Support for stateful transforms + +-- | Run a stateful transform with an initial state and turn it into a regular +-- (non-stateful) transform +statefulT :: s -> Transform FlatCtx (RewriteStateM s) a b -> TransformF a (s, b) +statefulT s t = resultT (stateful s) t + +-- | Turn a regular rewrite into a stateful rewrite +liftstateT :: Transform FlatCtx (RewriteM Int) a b -> Transform FlatCtx (RewriteStateM s) a b +liftstateT t = resultT liftstate t + +-------------------------------------------------------------------------------- +-- Congruence combinators for FKL lexpressions + +tableT :: Monad m => (Type -> String -> [Column] -> TableHints -> b) + -> Transform FlatCtx m (ExprTempl l e) b +tableT f = contextfreeT $ \expr -> case expr of + Table ty n cs ks -> return $ f ty n cs ks + _ -> fail "not a table node" +{-# INLINE tableT #-} + + +tableR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) +tableR = tableT Table +{-# INLINE tableR #-} + +ifT :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 + -> Transform FlatCtx m (ExprTempl l e) a2 + -> Transform FlatCtx m (ExprTempl l e) a3 + -> (Type -> a1 -> a2 -> a3 -> b) + -> Transform FlatCtx m (ExprTempl l e) b +ifT t1 t2 t3 f = transform $ \c expr -> case expr of + If ty e1 e2 e3 -> f ty <$> applyT t1 (c@@IfCond) e1 + <*> applyT t2 (c@@IfThen) e2 + <*> applyT t3 (c@@IfElse) e3 + _ -> fail "not an if expression" +{-# INLINE ifT #-} + +ifR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) + -> Rewrite FlatCtx m (ExprTempl l e) + -> Rewrite FlatCtx m (ExprTempl l e) + -> Rewrite FlatCtx m (ExprTempl l e) +ifR t1 t2 t3 = ifT t1 t2 t3 If +{-# INLINE ifR #-} + +{- FIXME will be needed again when let-bindings are added. +varT :: Monad m => (Type -> Ident -> b) -> Transform FlatCtx m (Expr l) b +varT f = contextfreeT $ \expr -> case expr of + Var ty n -> return $ f ty n + _ -> fail "not a variable" +{-# INLINE varT #-} + +varR :: Monad m => Rewrite FlatCtx m (Expr l) +varR = varT Var +{-# INLINE varR #-} +-} + +binopT :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 + -> Transform FlatCtx m (ExprTempl l e) a2 + -> (Type -> ScalarBinOp -> l -> a1 -> a2 -> b) + -> Transform FlatCtx m (ExprTempl l e) b +binopT t1 t2 f = transform $ \c expr -> case expr of + BinOp ty op l e1 e2 -> f ty op l <$> applyT t1 (c@@BinOpArg1) e1 <*> applyT t2 (c@@BinOpArg2) e2 + _ -> fail "not a binary operator application" +{-# INLINE binopT #-} + +binopR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) -> Rewrite FlatCtx m (ExprTempl l e) -> Rewrite FlatCtx m (ExprTempl l e) +binopR t1 t2 = binopT t1 t2 BinOp +{-# INLINE binopR #-} + +unopT :: Monad m => Transform FlatCtx m (ExprTempl l e) a + -> (Type -> ScalarUnOp -> l -> a -> b) + -> Transform FlatCtx m (ExprTempl l e) b +unopT t f = transform $ \ctx expr -> case expr of + UnOp ty op l e -> f ty op l <$> applyT t (ctx@@UnOpArg) e + _ -> fail "not an unary operator application" +{-# INLINE unopT #-} + +unopR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) -> Rewrite FlatCtx m (ExprTempl l e) +unopR t = unopT t UnOp +{-# INLINE unopR #-} + +papp1T :: Monad m => Transform FlatCtx m (ExprTempl l e) a + -> (Type -> Prim1 -> l -> a -> b) + -> Transform FlatCtx m (ExprTempl l e) b +papp1T t f = transform $ \c expr -> case expr of + PApp1 ty p l e -> f ty p l <$> applyT t (c@@PApp1Arg) e + _ -> fail "not a unary primitive application" +{-# INLINE papp1T #-} + +papp1R :: Monad m => Rewrite FlatCtx m (ExprTempl l e) -> Rewrite FlatCtx m (ExprTempl l e) +papp1R t = papp1T t PApp1 +{-# INLINE papp1R #-} + +papp2T :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 + -> Transform FlatCtx m (ExprTempl l e) a2 + -> (Type -> Prim2 -> l -> a1 -> a2 -> b) + -> Transform FlatCtx m (ExprTempl l e) b +papp2T t1 t2 f = transform $ \c expr -> case expr of + PApp2 ty p l e1 e2 -> f ty p l <$> applyT t1 (c@@PApp2Arg1) e1 <*> applyT t2 (c@@PApp2Arg2) e2 + _ -> fail "not a binary primitive application" +{-# INLINE papp2T #-} + +papp2R :: Monad m => Rewrite FlatCtx m (ExprTempl l e) -> Rewrite FlatCtx m (ExprTempl l e) -> Rewrite FlatCtx m (ExprTempl l e) +papp2R t1 t2 = papp2T t1 t2 PApp2 +{-# INLINE papp2R #-} + +papp3T :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 + -> Transform FlatCtx m (ExprTempl l e) a2 + -> Transform FlatCtx m (ExprTempl l e) a3 + -> (Type -> Prim3 -> l -> a1 -> a2 -> a3 -> b) + -> Transform FlatCtx m (ExprTempl l e) b +papp3T t1 t2 t3 f = transform $ \c expr -> case expr of + PApp3 ty p l e1 e2 e3 -> f ty p l + <$> applyT t1 (c@@PApp3Arg1) e1 + <*> applyT t2 (c@@PApp3Arg2) e2 + <*> applyT t3 (c@@PApp3Arg3) e3 + _ -> fail "not a ternary primitive application" +{-# INLINE papp3T #-} + +papp3R :: Monad m + => Rewrite FlatCtx m (ExprTempl l e) + -> Rewrite FlatCtx m (ExprTempl l e) + -> Rewrite FlatCtx m (ExprTempl l e) + -> Rewrite FlatCtx m (ExprTempl l e) +papp3R t1 t2 t3 = papp3T t1 t2 t3 PApp3 +{-# INLINE papp3R #-} + +constExprT :: Monad m => (Type -> Val -> b) -> Transform FlatCtx m (ExprTempl l e) b +constExprT f = contextfreeT $ \expr -> case expr of + Const ty v -> return $ f ty v + _ -> fail "not a constant" +{-# INLINE constExprT #-} + +constExprR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) +constExprR = constExprT Const +{-# INLINE constExprR #-} + +letT :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 + -> Transform FlatCtx m (ExprTempl l e) a2 + -> (Type -> Ident -> a1 -> a2 -> b) + -> Transform FlatCtx m (ExprTempl l e) b +letT t1 t2 f = transform $ \c expr -> case expr of + Let ty x xs e -> f ty x <$> applyT t1 (c@@LetBind) xs + <*> applyT t2 (bindVar x $ c@@LetBody) e + _ -> fail "not a let expression" +{-# INLINE letT #-} + +letR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) + -> Rewrite FlatCtx m (ExprTempl l e) + -> Rewrite FlatCtx m (ExprTempl l e) +letR r1 r2 = letT r1 r2 Let +{-# INLINE letR #-} + +varT :: Monad m => (Type -> Ident -> b) -> Transform FlatCtx m (ExprTempl l e) b +varT f = contextfreeT $ \expr -> case expr of + Var ty n -> return $ f ty n + _ -> fail "not a variable" +{-# INLINE varT #-} + +varR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) +varR = varT Var +{-# INLINE varR #-} + +mkTupleT :: Monad m => Transform FlatCtx m (ExprTempl l e) a + -> (Type -> l -> [a] -> b) + -> Transform FlatCtx m (ExprTempl l e) b +mkTupleT t f = transform $ \c expr -> case expr of + MkTuple ty l es -> f ty l <$> zipWithM (\e i -> applyT t (c@@TupleElem i) e) es [1..] + _ -> fail "not a tuple constructor" +{-# INLINE mkTupleT #-} + +mkTupleR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) -> Rewrite FlatCtx m (ExprTempl l e) +mkTupleR r = mkTupleT r MkTuple + +extT :: Monad m => Transform FlatCtx m e a + -> (a -> b) + -> Transform FlatCtx m (ExprTempl l e) b +extT t f = transform $ \c expr -> case expr of + Ext e -> f <$> applyT t (c@@ExtExpr) e + _ -> fail "not an extension mode" +{-# INLINE extT #-} + + +extR :: Monad m => Rewrite FlatCtx m e -> Rewrite FlatCtx m (ExprTempl l e) +extR r = extT r Ext +{-# INLINE extR #-} + +-------------------------------------------------------------------------------- + +forgetT :: Monad m => Transform FlatCtx m FExpr a + -> (Nat -> Type -> a -> b) + -> Transform FlatCtx m ShapeExt b +forgetT t f = transform $ \c expr -> case expr of + Forget n ty e -> f n ty <$> applyT t (c@@ForgetArg) e + _ -> fail "not a forget application" +{-# INLINE forgetT #-} + +forgetR :: Monad m => Rewrite FlatCtx m FExpr -> Rewrite FlatCtx m ShapeExt +forgetR t = forgetT t Forget +{-# INLINE forgetR #-} + +imprintT :: Monad m => Transform FlatCtx m FExpr a1 + -> Transform FlatCtx m FExpr a2 + -> (Nat -> Type -> a1 -> a2 -> b) + -> Transform FlatCtx m ShapeExt b +imprintT t1 t2 f = transform $ \c expr -> case expr of + Imprint n ty e1 e2 -> f n ty <$> applyT t1 (c@@ImprintArg1) e1 + <*> applyT t2 (c@@ImprintArg2) e2 + _ -> fail "not a imprint call" +{-# INLINE imprintT #-} + +imprintR :: Monad m => Rewrite FlatCtx m FExpr -> Rewrite FlatCtx m FExpr -> Rewrite FlatCtx m ShapeExt +imprintR t1 t2 = imprintT t1 t2 Imprint +{-# INLINE imprintR #-} + +-------------------------------------------------------------------------------- + +broadcastT :: Monad m => Transform FlatCtx m LExpr a1 + -> Transform FlatCtx m LExpr a2 + -> (Nat -> Type -> a1 -> a2 -> b) + -> Transform FlatCtx m BroadcastExt b +broadcastT t1 t2 f = transform $ \c expr -> case expr of + Broadcast n ty e1 e2 -> f n ty <$> applyT t1 (c@@BroadcastArg1) e1 + <*> applyT t2 (c@@BroadcastArg2) e2 +{-# INLINE broadcastT #-} + +broadcastR :: Monad m => Rewrite FlatCtx m LExpr + -> Rewrite FlatCtx m LExpr + -> Rewrite FlatCtx m BroadcastExt +broadcastR r1 r2 = broadcastT r1 r2 Broadcast +{-# INLINE broadcastR #-} + +-------------------------------------------------------------------------------- + +data FKL l e = ExprFKL (ExprTempl l e) + | ExtFKL e + +instance (Pretty e, Pretty l) => Pretty (FKL l e) where + pretty (ExprFKL e) = pretty e + pretty (ExtFKL o) = pretty o + +instance Injection FExpr (FKL Lifted ShapeExt) where + inject = ExprFKL + + project (ExprFKL e) = Just e + project _ = Nothing + +instance Injection ShapeExt (FKL Lifted ShapeExt) where + inject = ExtFKL + + project (ExtFKL s) = Just s + project _ = Nothing + +-------------------------------------------------------------------------------- + +instance Injection LExpr (FKL LiftedN BroadcastExt) where + inject = ExprFKL + + project (ExprFKL e) = Just e + project _ = Nothing + +instance Injection BroadcastExt (FKL LiftedN BroadcastExt) where + inject = ExtFKL + + project (ExtFKL s) = Just s + project _ = Nothing + + +-------------------------------------------------------------------------------- + +instance Walker FlatCtx (FKL Lifted ShapeExt) where + allR r = + rewrite $ \c fkl -> case fkl of + ExprFKL expr -> inject <$> applyT (allRExpr r) c expr + ExtFKL o -> inject <$> applyT allRShape c o + + where + allRShape = readerT $ \o -> case o of + Imprint{} -> imprintR (extractR r) (extractR r) + Forget{} -> forgetR (extractR r) + +instance Walker FlatCtx (FKL LiftedN BroadcastExt) where + allR r = + rewrite $ \c fkl -> case fkl of + ExprFKL expr -> inject <$> applyT (allRExpr r) c expr + ExtFKL o -> inject <$> applyT allRBC c o + + where + allRBC = readerT $ \o -> case o of + Broadcast{} -> broadcastR (extractR r) (extractR r) + +allRExpr :: (Injection (ExprTempl t t1) g, Injection t1 g, Monad m) + => Rewrite FlatCtx m g + -> Transform FlatCtx m (ExprTempl t t1) (ExprTempl t t1) +allRExpr r = readerT $ \e -> case e of + Table{} -> idR + PApp1{} -> papp1R (extractR r) + PApp2{} -> papp2R (extractR r) (extractR r) + PApp3{} -> papp3R (extractR r) (extractR r) (extractR r) + BinOp{} -> binopR (extractR r) (extractR r) + UnOp{} -> unopR (extractR r) + If{} -> ifR (extractR r) (extractR r) (extractR r) + Const{} -> idR + Let{} -> letR (extractR r) (extractR r) + Var{} -> idR + MkTuple{} -> mkTupleR (extractR r) + Ext{} -> extR (extractR r) + + +-------------------------------------------------------------------------------- +-- I find it annoying that Applicative is not a superclass of Monad. + +(<$>) :: Monad m => (a -> b) -> m a -> m b +(<$>) = liftM +{-# INLINE (<$>) #-} + +(<*>) :: Monad m => m (a -> b) -> m a -> m b +(<*>) = ap +{-# INLINE (<*>) #-} + diff --git a/src/Database/DSH/FKL/Lang.hs b/src/Database/DSH/FKL/Lang.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/FKL/Lang.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.FKL.Lang where + +import Text.PrettyPrint.ANSI.Leijen +import Text.Printf + +import Database.DSH.Impossible +import Database.DSH.Common.Pretty +import Database.DSH.Common.Nat +import qualified Database.DSH.Common.Lang as L +import Database.DSH.Common.Type (Type, Typed, typeOf) + + +-- | 'LiftedN' defines an FKL dialect in which primitives and +-- operators might be lifted to arbitrary levels. +data LiftedN = LiftedN Nat deriving (Show) + +-- | 'Lifted' defines an FKL dialect in which primitives and operators +-- occur either unlifted or lifted once. +data Lifted = Lifted | NotLifted deriving (Show) + +-- | 'FExpr' is the target language of the flattening transformation. +data ExprTempl l e = Table Type String [L.Column] L.TableHints + | PApp1 Type Prim1 l (ExprTempl l e) + | PApp2 Type Prim2 l (ExprTempl l e) (ExprTempl l e) + | PApp3 Type Prim3 l (ExprTempl l e) (ExprTempl l e) (ExprTempl l e) + | If Type (ExprTempl l e) (ExprTempl l e) (ExprTempl l e) + | BinOp Type L.ScalarBinOp l (ExprTempl l e) (ExprTempl l e) + | UnOp Type L.ScalarUnOp l (ExprTempl l e) + | Const Type L.Val + | Ext e + | Let Type L.Ident (ExprTempl l e) (ExprTempl l e) + | Var Type L.Ident + | MkTuple Type l [(ExprTempl l e)] + +data BroadcastExt = Broadcast Nat Type LExpr LExpr + +data ShapeExt = Forget Nat Type FExpr + | Imprint Nat Type FExpr FExpr + +type FExpr = ExprTempl Lifted ShapeExt +type LExpr = ExprTempl LiftedN BroadcastExt + +-- | Forget does not unsegment the vector. That is: the descriptor +-- might not be normalized and segment descriptors other than 1 might +-- occur. This is propably ok when we know that a concated vector will +-- be unconcated again. We know this statically when introducing +-- concat/unconcat for higher-lifted primitives. + +data Prim1 = Length + | Concat + | TupElem TupleIndex + | Sum + | Avg + | Minimum + | Maximum + | The + | Tail + | Reverse + | And + | Or + | Init + | Last + | Nub + | Number + | Singleton + | Transpose + | Reshape Integer + deriving (Show, Eq) + +data Prim2 = Group + | Sort + | Restrict + | Append + | Index + | Zip + | CartProduct + | NestProduct + | ThetaJoin (L.JoinPredicate L.JoinExpr) + | NestJoin (L.JoinPredicate L.JoinExpr) + | SemiJoin (L.JoinPredicate L.JoinExpr) + | AntiJoin (L.JoinPredicate L.JoinExpr) + | Dist + deriving (Show, Eq) + +data Prim3 = Combine + deriving (Show, Eq) + +instance Typed e => Typed (ExprTempl l e) where + typeOf (Var t _) = t + typeOf (Let t _ _ _) = t + typeOf (Table t _ _ _) = t + typeOf (PApp1 t _ _ _) = t + typeOf (PApp2 t _ _ _ _) = t + typeOf (PApp3 t _ _ _ _ _) = t + typeOf (If t _ _ _) = t + typeOf (BinOp t _ _ _ _) = t + typeOf (UnOp t _ _ _) = t + typeOf (Const t _) = t + typeOf (MkTuple t _ _) = t + typeOf (Ext o) = typeOf o + +instance Typed BroadcastExt where + typeOf (Broadcast _ t _ _) = t + +instance Typed ShapeExt where + typeOf (Forget _ t _) = t + typeOf (Imprint _ t _ _) = t + +-------------------------------------------------------------------------------- +-- Pretty-printing of FKL dialects + +superscript :: Int -> Doc +superscript 1 = char '¹' +superscript 2 = char '²' +superscript 3 = char '³' +superscript 4 = char '⁴' +superscript 5 = char '⁵' +superscript 6 = char '⁶' +superscript n = char '^' <> int n + +instance Pretty Lifted where + pretty Lifted = text "ᴸ" + pretty NotLifted = empty + +instance Pretty LiftedN where + pretty (LiftedN Zero) = empty + pretty (LiftedN n) = superscript (intFromNat n) + +instance Pretty Prim1 where + pretty Length = text "length" + pretty Concat = text "concat" + pretty Sum = text "sum" + pretty Avg = text "avg" + pretty The = text "the" + pretty Minimum = text "minimum" + pretty Maximum = text "maximum" + pretty Tail = text "tail" + pretty Reverse = text "reverse" + pretty And = text "and" + pretty Or = text "or" + pretty Init = text "init" + pretty Last = text "last" + pretty Nub = text "nub" + pretty Number = text "number" + pretty Transpose = text "transpose" + pretty (Reshape n) = text $ printf "reshape(%d)" n + pretty Singleton = text "sng" + pretty TupElem{} = $impossible + +instance Pretty Prim2 where + pretty Group = text "group" + pretty Sort = text "sort" + pretty Dist = text "dist" + pretty Restrict = text "restrict" + pretty Append = text "append" + pretty Index = text "index" + pretty Zip = text "zip" + pretty CartProduct = text "⨯" + pretty NestProduct = text "▽" + pretty (ThetaJoin p) = text $ printf "⨝_%s" (pp p) + pretty (NestJoin p) = text $ printf "△_%s" (pp p) + pretty (SemiJoin p) = text $ printf "⋉_%s" (pp p) + pretty (AntiJoin p) = text $ printf "▷_%s" (pp p) + +instance Pretty Prim3 where + pretty Combine = text "combine" + +instance (Pretty l, Pretty e) => Pretty (ExprTempl l e) where + pretty (MkTuple _ l es) = (tupled $ map pretty es) <> pretty l + + pretty (Var _ n) = text n + pretty (Let _ x e1 e) = + align $ text "let" <+> text x {- <> colon <> colon <> pretty (typeOf e1) -} <+> char '=' <+> pretty e1 + <$> + text "in" <+> pretty e + + pretty (Table _ n _c _k) = text "table" <> parens (text n) + + pretty (PApp1 _ (TupElem n) l e1) = + parenthize e1 <> dot <> int (tupleIndex n) <> pretty l + + pretty (PApp1 _ f l e1) = + pretty f <> pretty l <+> (parenthize e1) + + pretty (PApp2 _ f l e1 e2) = + pretty f <> pretty l <+> (align $ (parenthize e1) (parenthize e2)) + + pretty (PApp3 _ f l e1 e2 e3) = + pretty f <> pretty l + <+> (align $ (parenthize e1) + (parenthize e2) + (parenthize e3)) + pretty (If _ e1 e2 e3) = + let e1' = pretty e1 + e2' = pretty e2 + e3' = pretty e3 + in text "if" <+> e1' + (nest 2 $ text "then" <+> e2') + (nest 2 $ text "else" <+> e3') + + pretty (BinOp _ o l e1 e2) = + align $ parenthize e1 pretty o <> pretty l parenthize e2 + + pretty (UnOp _ o l e) = + pretty o <> pretty l <> parens (pretty e) + + pretty (Const _ v) = pretty v + + pretty (Ext o) = pretty o + +instance Pretty ShapeExt where + pretty (Forget n _ e) = + text "forget" + <> (angles $ int $ intFromNat n) + <+> (parenthize e) + + pretty (Imprint n _ e1 e2) = + text "imprint" + <> (angles $ int $ intFromNat n) + <+> (align $ (parenthize e1) + (parenthize e2)) + +instance Pretty BroadcastExt where + pretty (Broadcast n _ e1 e2) = + text "forget" + <> (angles $ int $ intFromNat n) + <+> (align $ (parenthize e1) + (parenthize e2)) + +parenthize :: (Pretty l, Pretty e) => ExprTempl l e -> Doc +parenthize e = + case e of + Const{} -> pretty e + Table{} -> pretty e + Var{} -> pretty e + PApp1 _ (TupElem _) _ _ -> pretty e + _ -> parens $ pretty e + diff --git a/src/Database/DSH/FKL/Primitives.hs b/src/Database/DSH/FKL/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/FKL/Primitives.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Smart constructors for FKL functions and operators +module Database.DSH.FKL.Primitives where + +import Prelude hiding (concat, fst, snd) + +import Text.Printf + +import Database.DSH.Common.Lang +import Database.DSH.Common.Nat +import Database.DSH.Common.Pretty +import Database.DSH.Common.Type +import Database.DSH.FKL.Lang +import Database.DSH.Impossible + +-------------------------------------------------------------------------------- +-- Smart constructors for primitive combinators in the lifting FKL dialect + +-- tranpose :: [[a]] -> [[a]] +transpose :: LExpr -> Nat -> LExpr +transpose e d = + let t = unliftTypeN d $ typeOf e + in PApp1 (liftTypeN d t) Transpose (LiftedN d) e + +-- transpose :: [a] -> [[a]] +reshape :: Integer -> LExpr -> Nat -> LExpr +reshape n e d = + let t = unliftTypeN d $ typeOf e + in PApp1 (liftTypeN d $ ListT t) (Reshape n) (LiftedN d) e + +-- group :: [a] -> [b] -> [(b, [a])] +group :: LExpr -> LExpr -> Nat -> LExpr +group xs gs d = + let ListT xt = unliftTypeN d $ typeOf xs + ListT gt = unliftTypeN d $ typeOf gs + rt = listT (pairT gt (listT xt)) + in PApp2 (liftTypeN d rt) Group (LiftedN d) xs gs + +-- sort :: [a] -> [b] -> [a] +sort :: LExpr -> LExpr -> Nat -> LExpr +sort xs ss d = + let xst = unliftTypeN d $ typeOf xs + in PApp2 (liftTypeN d xst) Sort (LiftedN d) xs ss + +sng :: LExpr -> Nat -> LExpr +sng e d = + let t = unliftTypeN d $ typeOf e + in PApp1 (liftTypeN d t) Singleton (LiftedN d) e + +tuple :: [LExpr] -> Nat -> LExpr +tuple es d = + let ts = map (unliftTypeN d . typeOf) es + rt = TupleT ts + in MkTuple (liftTypeN d rt) (LiftedN d) es + +-- zip :: [a] -> [b] -> [(a, b)] +zip :: LExpr -> LExpr -> Nat -> LExpr +zip xs ys d = + let ListT xt = unliftTypeN d $ typeOf xs + ListT yt = unliftTypeN d $ typeOf ys + in PApp2 (liftTypeN d $ listT (pairT xt yt)) Zip (LiftedN d) xs ys + +cartProduct :: LExpr -> LExpr -> Nat -> LExpr +cartProduct xs ys d = + let ListT xt = unliftTypeN d $ typeOf xs + ListT yt = typeOf ys + in PApp2 (liftTypeN d $ listT (pairT xt yt)) CartProduct (LiftedN d) xs ys + +-- nestProduct :: [a] -> [b] -> [(a, [(a, b)])] +nestProduct :: LExpr -> LExpr -> Nat -> LExpr +nestProduct xs ys d = + let ListT xt = unliftTypeN d $ typeOf xs + ListT yt = unliftTypeN d $ typeOf ys + rt = listT (pairT xt (listT (pairT xt yt))) + in PApp2 (liftTypeN d rt) NestProduct (LiftedN d) xs ys + +thetaJoin :: JoinPredicate JoinExpr -> LExpr -> LExpr -> Nat -> LExpr +thetaJoin p xs ys d = + let ListT xt = unliftTypeN d $ typeOf xs + ListT yt = unliftTypeN d $ typeOf ys + in PApp2 (liftTypeN d $ listT (pairT xt yt)) (ThetaJoin p) (LiftedN d) xs ys + +nestJoin :: JoinPredicate JoinExpr -> LExpr -> LExpr -> Nat -> LExpr +nestJoin p xs ys d = + let ListT xt = unliftTypeN d $ typeOf xs + ListT yt = unliftTypeN d $ typeOf ys + rt = listT (pairT xt (listT (pairT xt yt))) + in PApp2 (liftTypeN d rt) (NestJoin p) (LiftedN d) xs ys + +semiJoin :: JoinPredicate JoinExpr -> LExpr -> LExpr -> Nat -> LExpr +semiJoin p e1 e2 d = + let t1 = unliftTypeN d $ typeOf e1 + in PApp2 (liftTypeN d t1) (SemiJoin p) (LiftedN d) e1 e2 + +antiJoin :: JoinPredicate JoinExpr -> LExpr -> LExpr -> Nat -> LExpr +antiJoin p e1 e2 d = + let t1 = unliftTypeN d $ typeOf e1 + in PApp2 (liftTypeN d t1) (AntiJoin p) (LiftedN d) e1 e2 + +append :: LExpr -> LExpr -> Nat -> LExpr +append e1 e2 d = + let t1 = unliftTypeN d $ typeOf e1 + in PApp2 (liftTypeN d t1) Append (LiftedN d) e1 e2 + +index :: LExpr -> LExpr -> Nat -> LExpr +index e1 e2 d = + let ListT t = unliftTypeN d $ typeOf e1 + in PApp2 (liftTypeN d t) Index (LiftedN d) e1 e2 + +length :: LExpr -> Nat -> LExpr +length e1 d = PApp1 (liftTypeN d intT) Length (LiftedN d) e1 + +-- FIXME this is not the right place to perform this step. If at all, +-- do it during compilation to VL. +head :: LExpr -> Nat -> LExpr +head = the + +the :: LExpr -> Nat -> LExpr +the e1 d = + let ListT t1 = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t1) The (LiftedN d) e1 + +last :: LExpr -> Nat -> LExpr +last e1 d = + let ListT t1 = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t1) Last (LiftedN d) e1 + +tail :: LExpr -> Nat -> LExpr +tail e1 d = + let t1@(ListT _) = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t1) Tail (LiftedN d) e1 + +nub :: LExpr -> Nat -> LExpr +nub e1 d = + let t1@(ListT _) = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t1) Nub (LiftedN d) e1 + +number :: LExpr -> Nat -> LExpr +number e1 d = + let ListT t = unliftTypeN d $ typeOf e1 + rt = (ListT (pairT t IntT )) + in PApp1 (liftTypeN d rt) Number (LiftedN d) e1 + +init :: LExpr -> Nat -> LExpr +init e1 d = + let t1@(ListT _) = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t1) Init (LiftedN d) e1 + +reverse :: LExpr -> Nat -> LExpr +reverse e1 d = + let t1@(ListT _) = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t1) Reverse (LiftedN d) e1 + +and :: LExpr -> Nat -> LExpr +and e1 d = PApp1 (liftTypeN d BoolT) And (LiftedN d) e1 + +or :: LExpr -> Nat -> LExpr +or e1 d = PApp1 (liftTypeN d BoolT) Or (LiftedN d) e1 + +sum :: LExpr -> Nat -> LExpr +sum e1 d = + let ListT t = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t) Sum (LiftedN d) e1 + +avg :: LExpr -> Nat -> LExpr +avg e1 d = PApp1 (liftTypeN d DoubleT) Avg (LiftedN d) e1 + +minimum :: LExpr -> Nat -> LExpr +minimum e1 d = + let ListT t = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t) Minimum (LiftedN d) e1 + +maximum :: LExpr -> Nat -> LExpr +maximum e1 d = + let ListT t = unliftTypeN d $ typeOf e1 + in PApp1 (liftTypeN d t) Maximum (LiftedN d) e1 + +concat :: LExpr -> Nat -> LExpr +concat e d = + let ListT rt@(ListT _) = unliftTypeN d $ typeOf e + in PApp1 (liftTypeN d rt) Concat (LiftedN d) e + +dist :: LExpr -> LExpr -> Nat -> LExpr +dist e1 e2 d = + let t1 = typeOf e1 + in PApp2 (listT t1) Dist (LiftedN d) e1 e2 + +restrict :: LExpr -> LExpr -> Nat -> LExpr +restrict xs bs d = + let xst = unliftTypeN d $ typeOf xs + in PApp2 (liftTypeN d xst) Restrict (LiftedN d) xs bs + +-- combine :: [Bool] -> [a] -> [a] -> [a] +combine :: LExpr -> LExpr -> LExpr -> Nat -> LExpr +combine e1 e2 e3 d = + let xst = unliftTypeN d $ typeOf e2 + in PApp3 (liftTypeN d xst) Combine (LiftedN d) e1 e2 e3 + +tupElem :: TupleIndex -> LExpr -> Nat -> LExpr +tupElem f e d = + let t = tupleElemT (unliftTypeN d $ typeOf e) f + in PApp1 (liftTypeN d t) (TupElem f) (LiftedN d) e + +if_ :: Typed e => ExprTempl l e -> ExprTempl l e -> ExprTempl l e -> ExprTempl l e +if_ eb et ee = + let (BoolT, tt, te) = (typeOf eb, typeOf et, typeOf ee) + in if tt == te + then If tt eb et ee + else error $ printf "FKL.if: incompatible types: %s %s" (pp tt) (pp te) + +let_ :: Typed e => Ident -> ExprTempl l e -> ExprTempl l e -> ExprTempl l e +let_ x e1 e2 = Let (typeOf e2) x e1 e2 + +-------------------------------------------------------------------------------- +-- Smart constructors for binary and unary operators. + +-- FIXME typing of binary operators is not correct +bin :: Type -> ScalarBinOp -> LExpr -> LExpr -> Nat -> LExpr +bin t o e1 e2 d = BinOp (liftTypeN d t) o (LiftedN d) e1 e2 + +un :: Type -> ScalarUnOp -> LExpr -> Nat -> LExpr +un t o e d = UnOp (liftTypeN d t) o (LiftedN d) e + + +-------------------------------------------------------------------------------- +-- Smart constructors for special forms in the flat FKL dialect + +forget :: Nat -> FExpr -> FExpr +forget n xs = + let xst = typeOf xs + in Ext $ Forget n (unwrapListType n xst) xs + +unwrapListType :: Nat -> Type -> Type +unwrapListType Zero t = t +unwrapListType (Succ n') (ListT xt) = unwrapListType n' xt +unwrapListType _ _ = $impossible + +imprint :: Nat -> FExpr -> FExpr -> FExpr +imprint n shape bottom = Ext $ Imprint n (wrapListType n bt) shape bottom + where + bt = typeOf bottom + +wrapListType :: Nat -> Type -> Type +wrapListType Zero t = t +wrapListType (Succ n') t = wrapListType n' (listT t) + +-- | A regular single 'dist' in the normalized FKL dialect +fdist :: FExpr -> FExpr -> FExpr +fdist e1 e2 = PApp2 (listT $ typeOf e1) Dist NotLifted e1 e2 + +-------------------------------------------------------------------------------- +-- Smart constructors for special forms in the flat FKL dialect + +broadcast :: LExpr -> LExpr -> Nat -> LExpr +broadcast e1 e2 d = Ext $ Broadcast d ty e1 e2 + where + ty = wrapListType d (typeOf e1) diff --git a/src/Database/DSH/FKL/Rewrite.hs b/src/Database/DSH/FKL/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/FKL/Rewrite.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Database.DSH.FKL.Rewrite + ( optimizeFKL + ) where + +import Data.Monoid +import Data.List +import Control.Arrow + +import Database.DSH.Common.RewriteM +import Database.DSH.Common.Lang +import Database.DSH.Common.Type +import Database.DSH.Common.Kure +import Database.DSH.Common.Pretty +import Database.DSH.FKL.Lang +import Database.DSH.FKL.Kure + +-- | Run a translate on an expression without context +applyExpr :: (Injection (ExprTempl l e) (FKL l e)) + => TransformF (FKL l e) b -> ExprTempl l e -> Either String b +applyExpr f e = runRewriteM $ applyT f initialCtx (inject e) + +-------------------------------------------------------------------------------- +-- Computation of free and bound variables + +freeVarsT :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e)) + => TransformF (FKL l e) [Ident] +freeVarsT = fmap nub + $ crushbuT + $ do (ctx, ExprFKL (Var _ v)) <- exposeT + guardM (v `freeIn` ctx) + return [v] + +-- | Compute free variables of the given expression +freeVars :: (Walker FlatCtx (FKL l e), Injection (ExprTempl l e) (FKL l e)) + => ExprTempl l e -> [Ident] +freeVars = either error id . applyExpr freeVarsT + + +-------------------------------------------------------------------------------- +-- Substitution + +alphaLetR :: ( Injection (ExprTempl l e) (FKL l e) + , Walker FlatCtx (FKL l e) + , Typed e) + => [Ident] -> RewriteF (FKL l e) +alphaLetR avoidNames = do + ExprFKL (Let _ x e1 e2) <- idR + x' <- freshNameT (x : freeVars e2 ++ avoidNames) + let varTy = typeOf e1 + childR LetBody (tryR $ substR x (Var varTy x')) + +substR :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e), Typed e) + => Ident -> ExprTempl l e -> RewriteF (FKL l e) +substR v s = readerT $ \expr -> case expr of + -- Occurence of the variable to be replaced + ExprFKL (Var _ n) | n == v -> return $ inject s + + -- Some other variable + ExprFKL (Var _ _) -> idR + + ExprFKL (Let _ x _ e2) | x /= v && v `elem` freeVars e2 -> + if x `elem` freeVars s + then alphaLetR (freeVars s) >>> substR v s + else anyR $ substR v s + + -- A let binding which shadows v -> don't descend into the body + ExprFKL (Let _ x _ _) | v == x -> tryR $ childR LetBind (substR v s) + _ -> anyR $ substR v s + +-------------------------------------------------------------------------------- +-- Simple optimizations + +-- | Count all occurences of an identifier for let-inlining. +countVarRefT :: Walker FlatCtx (FKL l e) => Ident -> TransformF (FKL l e) (Sum Int) +countVarRefT v = readerT $ \expr -> case expr of + -- Occurence of the variable to be replaced + ExprFKL (Var _ n) | n == v -> return 1 + ExprFKL (Var _ _) | otherwise -> return 0 + ExprFKL Table{} -> return 0 + ExprFKL Const{} -> return 0 + + ExprFKL (Let _ n _ _) | n == v -> childT LetBody (countVarRefT v) + + ExprFKL Let{} | otherwise -> allT (countVarRefT v) + + _ -> allT (countVarRefT v) + + +-- | Remove a let-binding that is not referenced. +unusedBindingR :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e)) + => RewriteF (FKL l e) +unusedBindingR = do + ExprFKL (Let _ x _ e2) <- idR + 0 <- childT LetBody $ countVarRefT x + return $ inject e2 + + +-- | Inline a let-binding that is only referenced once. +referencedOnceR :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e), Typed e) + => RewriteF (FKL l e) +referencedOnceR = do + ExprFKL (Let _ x e1 _) <- idR + 1 <- childT LetBody $ countVarRefT x + childT LetBody $ substR x e1 + +simpleExpr :: ExprTempl l e -> Bool +simpleExpr Table{} = True +simpleExpr Var{} = True +simpleExpr (PApp1 _ (TupElem _) _ e) = simpleExpr e +simpleExpr _ = False + +-- | Inline a let-binding that binds a simple expression. +simpleBindingR :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e), Typed e) + => RewriteF (FKL l e) +simpleBindingR = do + ExprFKL (Let _ x e1 _) <- idR + guardM $ simpleExpr e1 + childT LetBody $ substR x e1 + +fklOptimizations :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e), Typed e) + => RewriteF (FKL l e) +fklOptimizations = anybuR $ unusedBindingR + <+ referencedOnceR + <+ simpleBindingR + +optimizeFKL :: ( Injection (ExprTempl l e) (FKL l e) + , Walker FlatCtx (FKL l e) + , Typed e, Pretty (ExprTempl l e) + ) + => String -> ExprTempl l e -> ExprTempl l e +optimizeFKL stage expr = debugOpt stage expr expr' + where + expr' = applyExpr (fklOptimizations >>> projectT) expr diff --git a/src/Database/DSH/Frontend/Externals.hs b/src/Database/DSH/Frontend/Externals.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Frontend/Externals.hs @@ -0,0 +1,719 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Database.DSH.Frontend.Externals where + +import Database.DSH.Frontend.Internals +import Database.DSH.Frontend.Funs +import Database.DSH.Impossible +import Database.DSH.Frontend.TupleTypes + +import Prelude ( Eq, Ord, Num(..), Fractional(..), Floating(..) + , Bool(..), Char, Integer, Double, Maybe(..), Either(..) + , id, ($), (.)) +import qualified Prelude as P + +import Data.String +import Data.Text (Text) +import qualified Data.Text as T + +-- QA Instances + +instance QA () where + type Rep () = () + toExp () = UnitE + frExp UnitE = () + frExp _ = $impossible + +instance QA Bool where + type Rep Bool = Bool + toExp = BoolE + frExp (BoolE b) = b + frExp _ = $impossible + +instance QA Char where + type Rep Char = Char + toExp = CharE + frExp (CharE c) = c + frExp _ = $impossible + +instance QA Integer where + type Rep Integer = Integer + toExp = IntegerE + frExp (IntegerE i) = i + frExp _ = $impossible + +instance QA Double where + type Rep Double = Double + toExp = DoubleE + frExp (DoubleE d) = d + frExp _ = $impossible + +instance QA Text where + type Rep Text = Text + toExp = TextE + frExp (TextE t) = t + frExp _ = $impossible + +instance (QA a) => QA [a] where + type Rep [a] = [Rep a] + toExp as = ListE (P.map toExp as) + frExp (ListE as) = P.map frExp as + frExp _ = $impossible + +instance (QA a) => QA (Maybe a) where + type Rep (Maybe a) = [Rep a] + toExp Nothing = ListE [] + toExp (Just a) = ListE [toExp a] + frExp (ListE []) = Nothing + frExp (ListE (a : _)) = Just (frExp a) + frExp _ = $impossible + +instance (QA a,QA b) => QA (Either a b) where + type Rep (Either a b) = ([Rep a],[Rep b]) + toExp (Left a) = pairE (ListE [toExp a]) (ListE []) + toExp (Right b) = pairE (ListE []) (ListE [toExp b]) + frExp (TupleConstE (Tuple2E (ListE (a : _)) _)) = Left (frExp a) + frExp (TupleConstE (Tuple2E _ (ListE (a : _)))) = Right (frExp a) + frExp _ = $impossible + +-- Elim instances + +instance (QA r) => Elim () r where + type Eliminator () r = Q r -> Q r + elim _ r = r + +instance (QA r) => Elim Bool r where + type Eliminator Bool r = Q r -> Q r -> Q r + elim (Q e) (Q e1) (Q e2) = Q (AppE Cond (TupleConstE (Tuple3E e e1 e2))) + +instance (QA r) => Elim Char r where + type Eliminator Char r = (Q Char -> Q r) -> Q r + elim q f = f q + +instance (QA r) => Elim Integer r where + type Eliminator Integer r = (Q Integer -> Q r) -> Q r + elim q f = f q + +instance (QA r) => Elim Double r where + type Eliminator Double r = (Q Double -> Q r) -> Q r + elim q f = f q + +instance (QA r) => Elim Text r where + type Eliminator Text r = (Q Text -> Q r) -> Q r + elim q f = f q + +instance (QA a,QA b,QA r) => Elim (a,b) r where + type Eliminator (a,b) r = (Q a -> Q b -> Q r) -> Q r + elim q f = f (fst q) (snd q) + +instance (QA a,QA r) => Elim (Maybe a) r where + type Eliminator (Maybe a) r = Q r -> (Q a -> Q r) -> Q r + elim q r f = maybe r f q + +instance (QA a,QA b,QA r) => Elim (Either a b) r where + type Eliminator (Either a b) r = (Q a -> Q r) -> (Q b -> Q r) -> Q r + elim q f g = either f g q + +-- BasicType instances + +instance BasicType () where +instance BasicType Bool where +instance BasicType Char where +instance BasicType Integer where +instance BasicType Double where +instance BasicType Text where + +-- TA instances + +instance TA () where +instance TA Bool where +instance TA Char where +instance TA Integer where +instance TA Double where +instance TA Text where + +-- Num and Fractional instances + +instance Num (Exp Integer) where + (+) e1 e2 = AppE Add (pairE e1 e2) + (*) e1 e2 = AppE Mul (pairE e1 e2) + (-) e1 e2 = AppE Sub (pairE e1 e2) + + fromInteger = IntegerE + + abs e = let c = AppE Lt (pairE e 0) + in AppE Cond (tripleE c (negate e) e) + + signum e = let c1 = AppE Lt (pairE e 0) + c2 = AppE Equ (pairE e 0) + e' = AppE Cond (tripleE c2 0 1) + in AppE Cond (tripleE c1 (-1) e') + +instance Num (Exp Double) where + (+) e1 e2 = AppE Add (pairE e1 e2) + (*) e1 e2 = AppE Mul (pairE e1 e2) + (-) e1 e2 = AppE Sub (pairE e1 e2) + + fromInteger = DoubleE . fromInteger + + abs e = let c = AppE Lt (pairE e 0) + in AppE Cond (tripleE c (negate e) e) + + signum e = let c1 = AppE Lt (pairE e 0.0) + c2 = AppE Equ (pairE e 0.0) + e' = AppE Cond (tripleE c2 0 1) + in AppE Cond (tripleE c1 (-1) e') + +instance Fractional (Exp Double) where + (/) e1 e2 = AppE Div (pairE e1 e2) + fromRational = DoubleE . fromRational + +instance Floating (Exp Double) where + pi = DoubleE 3.141592653589793 + sin e = AppE Sin e + cos e = AppE Cos e + tan e = AppE Tan e + sqrt e = AppE Sqrt e + exp e = AppE Exp e + log e = AppE Log e + asin e = AppE ASin e + acos e = AppE ACos e + atan e = AppE ATan e + sinh = $unimplemented + cosh = $unimplemented + asinh = $unimplemented + atanh = $unimplemented + acosh = $unimplemented + +instance Num (Q Integer) where + (+) (Q e1) (Q e2) = Q (e1 + e2) + (*) (Q e1) (Q e2) = Q (e1 * e2) + (-) (Q e1) (Q e2) = Q (e1 - e2) + fromInteger = Q . IntegerE + abs (Q e) = Q (abs e) + signum (Q e) = Q (signum e) + +instance Num (Q Double) where + (+) (Q e1) (Q e2) = Q (e1 + e2) + (*) (Q e1) (Q e2) = Q (e1 * e2) + (-) (Q e1) (Q e2) = Q (e1 - e2) + fromInteger = Q . DoubleE . fromInteger + abs (Q e) = Q (abs e) + signum (Q e) = Q (signum e) + +instance Fractional (Q Double) where + (/) (Q e1) (Q e2) = Q (e1 / e2) + fromRational = Q . DoubleE . fromRational + +instance Floating (Q Double) where + pi = Q pi + sin (Q e) = Q (sin e) + cos (Q e) = Q (cos e) + tan (Q e) = Q (tan e) + asin (Q e) = Q (asin e) + acos (Q e) = Q (acos e) + atan (Q e) = Q (atan e) + exp (Q e) = Q (exp e) + log (Q e) = Q (log e) + sqrt (Q e) = Q (sqrt e) + sinh = $unimplemented + cosh = $unimplemented + asinh = $unimplemented + atanh = $unimplemented + acosh = $unimplemented + +-- View instances + +instance View (Q ()) where + type ToView (Q ()) = Q () + view = id + +instance View (Q Bool) where + type ToView (Q Bool) = Q Bool + view = id + +instance View (Q Char) where + type ToView (Q Char) = Q Char + view = id + +instance View (Q Integer) where + type ToView (Q Integer) = Q Integer + view = id + +instance View (Q Double) where + type ToView (Q Double) = Q Double + view = id + +instance View (Q Text) where + type ToView (Q Text) = Q Text + view = id + +-- IsString instances + +instance IsString (Q Text) where + fromString = Q . TextE . T.pack + +-- * Referring to persistent tables + +defaultHints :: TableHints +defaultHints = TableHints [] PossiblyEmpty + +table :: (QA a, TA a) => String -> TableHints -> Q [a] +table name hints = Q (TableE (TableDB name hints)) + +-- * toQ + +toQ :: (QA a) => a -> Q a +toQ = Q . toExp + +-- * Unit + +unit :: Q () +unit = Q UnitE + +-- * Boolean logic + +false :: Q Bool +false = Q (BoolE False) + +true :: Q Bool +true = Q (BoolE True) + +not :: Q Bool -> Q Bool +not (Q e) = Q (AppE Not e) + +(&&) :: Q Bool -> Q Bool -> Q Bool +(&&) (Q a) (Q b) = Q (AppE Conj (pairE a b)) + +(||) :: Q Bool -> Q Bool -> Q Bool +(||) (Q a) (Q b) = Q (AppE Disj (TupleConstE (Tuple2E a b))) + +-- * Equality and Ordering + +eq :: (QA a,Eq a,TA a) => Q a -> Q a -> Q Bool +eq (Q a) (Q b) = Q (AppE Equ (TupleConstE (Tuple2E a b))) + +(==) :: (QA a,Eq a,TA a) => Q a -> Q a -> Q Bool +(==) = eq + +neq :: (QA a,Eq a,TA a) => Q a -> Q a -> Q Bool +neq (Q a) (Q b) = Q (AppE NEq (pairE a b)) + +(/=) :: (QA a,Eq a,TA a) => Q a -> Q a -> Q Bool +(/=) = neq + +lt :: (QA a,Ord a,TA a) => Q a -> Q a -> Q Bool +lt (Q a) (Q b) = Q (AppE Lt (pairE a b)) + +(<) :: (QA a,Ord a,TA a) => Q a -> Q a -> Q Bool +(<) = lt + +lte :: (QA a,Ord a,TA a) => Q a -> Q a -> Q Bool +lte (Q a) (Q b) = Q (AppE Lte (pairE a b)) + +(<=) :: (QA a,Ord a,TA a) => Q a -> Q a -> Q Bool +(<=) = lte + +gte :: (QA a,Ord a,TA a) => Q a -> Q a -> Q Bool +gte (Q a) (Q b) = Q (AppE Gte (pairE a b)) + +(>=) :: (QA a,Ord a,TA a) => Q a -> Q a -> Q Bool +(>=) = gte + +gt :: (QA a,Ord a,TA a) => Q a -> Q a -> Q Bool +gt (Q a) (Q b) = Q (AppE Gt (pairE a b)) + +(>) :: (QA a,Ord a,TA a) => Q a -> Q a -> Q Bool +(>) = gt + +min :: (QA a,Ord a,TA a) => Q a -> Q a -> Q a +min a b = cond (a < b) a b + +max :: (QA a,Ord a,TA a) => Q a -> Q a -> Q a +max a b = cond (a > b) a b + +mod :: Q Integer -> Q Integer -> Q Integer +mod (Q a) (Q b) = Q (AppE Mod (pairE a b)) + +div :: Q Integer -> Q Integer -> Q Integer +div (Q a) (Q b) = Q (AppE Div (pairE a b)) + +-- * Conditionals + +bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a +bool f t b = cond b t f + +cond :: (QA a) => Q Bool -> Q a -> Q a -> Q a +cond (Q c) (Q a) (Q b) = Q (AppE Cond (TupleConstE (Tuple3E c a b))) + +ifThenElse :: (QA a) => Q Bool -> Q a -> Q a -> Q a +ifThenElse = cond + +(?) :: (QA a) => Q Bool -> (Q a,Q a) -> Q a +(?) c (a,b) = cond c a b + +-- * Maybe + +listToMaybe :: (QA a) => Q [a] -> Q (Maybe a) +listToMaybe (Q as) = Q as + +maybeToList :: (QA a) => Q (Maybe a) -> Q [a] +maybeToList (Q ma) = Q ma + +nothing :: (QA a) => Q (Maybe a) +nothing = listToMaybe nil + +just :: (QA a) => Q a -> Q (Maybe a) +just a = listToMaybe (singleton a) + +isNothing :: (QA a) => Q (Maybe a) -> Q Bool +isNothing ma = null (maybeToList ma) + +isJust :: (QA a) => Q (Maybe a) -> Q Bool +isJust ma = not (isNothing ma) + +fromJust :: (QA a) => Q (Maybe a) -> Q a +fromJust ma = head (maybeToList ma) + +maybe :: (QA a,QA b) => Q b -> (Q a -> Q b) -> Q (Maybe a) -> Q b +maybe b f ma = isNothing ma ? (b,f (fromJust ma)) + +fromMaybe :: (QA a) => Q a -> Q (Maybe a) -> Q a +fromMaybe a ma = isNothing ma ? (a,fromJust ma) + +catMaybes :: (QA a) => Q [Maybe a] -> Q [a] +catMaybes = concatMap maybeToList + +mapMaybe :: (QA a,QA b) => (Q a -> Q (Maybe b)) -> Q [a] -> Q [b] +mapMaybe f = concatMap (maybeToList . f) + +-- * Either + +pairToEither :: (QA a,QA b) => Q ([a],[b]) -> Q (Either a b) +pairToEither (Q a) = Q a + +eitherToPair :: (QA a,QA b) => Q (Either a b) -> Q ([a],[b]) +eitherToPair (Q a) = Q a + +left :: (QA a,QA b) => Q a -> Q (Either a b) +left a = pairToEither (pair (singleton a) nil) + +right :: (QA a,QA b) => Q b -> Q (Either a b) +right a = pairToEither (pair nil (singleton a)) + +isLeft :: (QA a,QA b) => Q (Either a b) -> Q Bool +isLeft = null . snd . eitherToPair + +isRight :: (QA a,QA b) => Q (Either a b) -> Q Bool +isRight = null . fst . eitherToPair + +either :: (QA a,QA b,QA c) => (Q a -> Q c) -> (Q b -> Q c) -> Q (Either a b) -> Q c +either lf rf e = + let p = eitherToPair e + in head (map lf (fst p) ++ map rf (snd p)) + +lefts :: (QA a,QA b) => Q [Either a b] -> Q [a] +lefts = concatMap (fst . eitherToPair) + +rights :: (QA a,QA b) => Q [Either a b] -> Q [b] +rights = concatMap (snd . eitherToPair) + +partitionEithers :: (QA a,QA b) => Q [Either a b] -> Q ([a], [b]) +partitionEithers es = pair (lefts es) (rights es) + +-- * List Construction + +nil :: (QA a) => Q [a] +nil = Q (ListE []) + +empty :: (QA a) => Q [a] +empty = nil + +cons :: (QA a) => Q a -> Q [a] -> Q [a] +cons (Q a) (Q as) = Q (AppE Cons (pairE a as)) + +(<|) :: (QA a) => Q a -> Q [a] -> Q [a] +(<|) = cons + +snoc :: (QA a) => Q [a] -> Q a -> Q [a] +snoc as a = append as (singleton a) + +(|>) :: (QA a) => Q [a] -> Q a -> Q [a] +(|>) = snoc + +singleton :: (QA a) => Q a -> Q [a] +singleton (Q e) = cons (Q e) nil + +-- * List Operations + +head :: (QA a) => Q [a] -> Q a +head (Q as) = Q (AppE Head as) + +tail :: (QA a) => Q [a] -> Q [a] +tail (Q as) = Q (AppE Tail as) + +take :: (QA a) => Q Integer -> Q [a] -> Q [a] +take i xs = map fst $ filter (\xp -> snd xp <= i) $ number xs + +drop :: (QA a) => Q Integer -> Q [a] -> Q [a] +drop i xs = map fst $ filter (\xp -> snd xp > i) $ number xs + +map :: (QA a,QA b) => (Q a -> Q b) -> Q [a] -> Q [b] +map f (Q as) = Q (AppE Map (pairE (LamE (toLam f)) as)) + +append :: (QA a) => Q [a] -> Q [a] -> Q [a] +append (Q as) (Q bs) = Q (AppE Append (pairE as bs)) + +(++) :: (QA a) => Q [a] -> Q [a] -> Q [a] +(++) = append + +filter :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] +filter f (Q as) = Q (AppE Filter (pairE (LamE (toLam f)) as)) + +-- | Partition a list into groups according to the supplied projection +-- function. +groupWithKey :: (QA a,QA b,Ord b, TA b) => (Q a -> Q b) -> Q [a] -> Q [(b,[a])] +groupWithKey f (Q as) = Q (AppE GroupWithKey (pairE (LamE (toLam f)) as)) + +groupWith :: (QA a,QA b,Ord b, TA b) => (Q a -> Q b) -> Q [a] -> Q [[a]] +groupWith f as = map snd (groupWithKey f as) + +sortWith :: (QA a,QA b,Ord b, TA b) => (Q a -> Q b) -> Q [a] -> Q [a] +sortWith f (Q as) = Q (AppE SortWith (pairE (LamE (toLam f)) as)) + +last :: (QA a) => Q [a] -> Q a +last (Q as) = Q (AppE Last as) + +init :: (QA a) => Q [a] -> Q [a] +init (Q as) = Q (AppE Init as) + +null :: (QA a) => Q [a] -> Q Bool +null (Q as) = Q (AppE Null as) + +length :: (QA a) => Q [a] -> Q Integer +length (Q as) = Q (AppE Length as) + +index :: (QA a) => Q [a] -> Q Integer -> Q a +index (Q as) (Q i) = Q (AppE Index (pairE as i)) + +(!!) :: (QA a) => Q [a] -> Q Integer -> Q a +(!!) = index + +reverse :: (QA a) => Q [a] -> Q [a] +reverse (Q as) = Q (AppE Reverse as) + +number :: (QA a) => Q [a] -> Q [(a, Integer)] +number (Q as) = Q (AppE Number as) + +-- * Special folds + +and :: Q [Bool] -> Q Bool +and (Q bs) = Q (AppE And bs) + +or :: Q [Bool] -> Q Bool +or (Q bs) = Q (AppE Or bs) + +any :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool +any f = or . map f + +all :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q Bool +all f = and . map f + +sum :: (QA a,Num a) => Q [a] -> Q a +sum (Q as) = Q (AppE Sum as) + +avg :: (QA a,Num a) => Q [a] -> Q Double +avg (Q as) = Q (AppE Avg as) + +concat :: (QA a) => Q [[a]] -> Q [a] +concat (Q ass) = Q (AppE Concat ass) + +concatMap :: (QA a,QA b) => (Q a -> Q [b]) -> Q [a] -> Q [b] +concatMap f (Q as) = Q (AppE ConcatMap (pairE (LamE (toLam f)) as)) + +maximum :: (QA a,Ord a,TA a) => Q [a] -> Q a +maximum (Q as) = Q (AppE Maximum as) + +minimum :: (QA a,Ord a,TA a) => Q [a] -> Q a +minimum (Q as) = Q (AppE Minimum as) + +-- * Sublists + +splitAt :: (QA a) => Q Integer -> Q [a] -> Q ([a],[a]) +splitAt i xs = pair (take i xs) (drop i xs) + +-- FIXME might be implemented using non-dense numbering! +takeWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] +takeWhile p xs = + let ys = map (\xpos -> pair xpos (p $ fst xpos)) $ number xs + notQualifying = filter (\xposp -> not (snd xposp)) ys + maxPos = minimum $ map (\xposp -> snd $ fst xposp) notQualifying + + in cond (null notQualifying) + xs + (map (\xposp -> fst $ fst xposp) $ filter (\xposp -> (snd $ fst xposp) < maxPos) ys) + +-- FIXME might be implemented using non-dense numbering! +dropWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a] +dropWhile p xs = + let ys = map (\xpos -> pair xpos (p $ fst xpos)) $ number xs + minPos = minimum $ map (\xposp -> snd $ fst xposp) $ filter (\xposp -> not (snd xposp)) ys + in map (\xposp -> fst $ fst xposp) $ filter (\xposp -> (snd $ fst xposp) >= minPos) ys + +span :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) +span f as = pair (takeWhile f as) (dropWhile f as) + +break :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q ([a],[a]) +break f = span (not . f) + +-- * Searching Lists + +elem :: (QA a,Eq a,TA a) => Q a -> Q [a] -> Q Bool +elem a as = any (a ==) as + +notElem :: (QA a,Eq a,TA a) => Q a -> Q [a] -> Q Bool +notElem a as = not (a `elem` as) + +lookup :: (QA a,QA b,Eq a,TA a) => Q a -> Q [(a, b)] -> Q (Maybe b) +lookup a = listToMaybe . map snd . filter ((a ==) . fst) + +-- * Zipping and Unzipping Lists + +zip :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)] +zip (Q as) (Q bs) = Q (AppE Zip (pairE as bs)) + +zipWith :: (QA a,QA b,QA c) => (Q a -> Q b -> Q c) -> Q [a] -> Q [b] -> Q [c] +zipWith f as bs = map (\e -> f (fst e) (snd e)) (zip as bs) + +unzip :: (QA a,QA b) => Q [(a,b)] -> Q ([a],[b]) +unzip as = pair (map fst as) (map snd as) + +zip3 :: (QA a,QA b,QA c) => Q [a] -> Q [b] -> Q [c] -> Q [(a,b,c)] +zip3 as bs cs = map (\abc -> triple (fst abc) (fst (snd abc)) (snd (snd abc))) (zip as (zip bs cs)) + +zipWith3 :: (QA a,QA b,QA c,QA d) => (Q a -> Q b -> Q c -> Q d) -> Q [a] -> Q [b] -> Q [c] -> Q [d] +zipWith3 f as bs cs = map (\e -> (case view e of (a,b,c) -> f a b c)) + (zip3 as bs cs) + +unzip3 :: (QA a,QA b,QA c) => Q [(a,b,c)] -> Q ([a],[b],[c]) +unzip3 abcs = triple (map (\e -> (case view e of (a,_,_) -> a)) abcs) + (map (\e -> (case view e of (_,b,_) -> b)) abcs) + (map (\e -> (case view e of (_,_,c) -> c)) abcs) + +-- * Set-oriented operations + +nub :: (QA a,Eq a,TA a) => Q [a] -> Q [a] +nub (Q as) = Q (AppE Nub as) + +-- * Tuple Projection Functions + +fst :: (QA a,QA b) => Q (a,b) -> Q a +fst (Q e) = Q (AppE Fst e) + +snd :: (QA a,QA b) => Q (a,b) -> Q b +snd (Q e) = Q (AppE Snd e) + +-- * Conversions between numeric types + +integerToDouble :: Q Integer -> Q Double +integerToDouble (Q i) = Q (AppE IntegerToDouble i) + +-- * Text Functions + +-- | 'like' matches a string (first argument) against a pattern (second +-- argument). The pattern must be a SQL LIKE pattern, that is use '_' for single +-- character wildcards and '_' for multi-character wildcards. +like :: Q Text -> Q Text -> Q Bool +like (Q t) (Q p) = Q (AppE Like (pairE t p)) + +subString :: Integer -> Integer -> Q Text -> Q Text +subString from to (Q t) = Q (AppE (SubString from to) t) + +-- * Matrix/Vector-like operators + +-- | Transpose a matrix in nested-list representation +transpose :: QA a => Q [[a]] -> Q [[a]] +transpose (Q ass) = Q (AppE Transpose ass) + +-- | Divide the list into sublists of length 'n' +-- FIXME should propably have a constraint to flat types +reshape :: QA a => Integer -> Q [a] -> Q [[a]] +reshape n (Q e) = Q (AppE (Reshape n) e) + +-- * Rebind Monadic Combinators + +return :: (QA a) => Q a -> Q [a] +return = singleton + +(>>=) :: (QA a,QA b) => Q [a] -> (Q a -> Q [b]) -> Q [b] +(>>=) ma f = concatMap f ma + +(>>) :: (QA a,QA b) => Q [a] -> Q [b] -> Q [b] +(>>) ma mb = concatMap (\_ -> mb) ma + +mzip :: (QA a,QA b) => Q [a] -> Q [b] -> Q [(a,b)] +mzip = zip + +guard :: Q Bool -> Q [()] +guard (Q c) = Q (AppE Guard c) + +-- * Construction of tuples + +pair :: (QA a,QA b) => Q a -> Q b -> Q (a,b) +pair (Q a) (Q b) = Q (pairE a b) + +triple :: (QA a,QA b,QA c) => Q a -> Q b -> Q c -> Q (a,b,c) +triple (Q a) (Q b) (Q c)= Q (TupleConstE (Tuple3E a b c)) + +infixl 9 !! +infixr 5 ++, <|, |> +infix 4 ==, /=, <, <=, >=, > +infixr 3 && +infixr 2 || +infix 0 ? + +-- * Generate instances and constructor functions for tuple types + +mkQAInstances 16 +mkTAInstances 16 +mkViewInstances 16 +mkTupleConstructors 16 + +-- * Missing functions + +-- $missing +{- $missing + +This module offers most of the functions on lists given in PreludeList for the +'Q' type. Missing functions are: + +General folds: + +> foldl +> foldl1 +> scanl +> scanl1 +> foldr +> foldr1 +> scanr +> scanr1 + +Infinit lists: + +> iterate +> repeat +> cycle + +String functions: + +> lines +> words +> unlines +> unwords + +-} diff --git a/src/Database/DSH/Frontend/Funs.hs b/src/Database/DSH/Frontend/Funs.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Frontend/Funs.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Frontend.Funs + ( Fun(..) + , TupElem(..) + ) where + +import Data.Text (Text) + +import Database.DSH.Frontend.TupleTypes + +-- Splice in the type for tuple element accessors +$(mkTupElemType 16) + +data Fun a b where + Not :: Fun Bool Bool + IntegerToDouble :: Fun Integer Double + And :: Fun [Bool] Bool + Or :: Fun [Bool] Bool + Concat :: Fun [[a]] [a] + Head :: Fun [a] a + Tail :: Fun [a] [a] + Init :: Fun [a] [a] + Last :: Fun [a] a + Null :: Fun [a] Bool + Length :: Fun [a] Integer + Guard :: Fun Bool [()] + Reverse :: Fun [a] [a] + Number :: Fun [a] [(a, Integer)] + Fst :: Fun (a,b) a + Snd :: Fun (a,b) b + Sum :: Fun [a] a + Avg :: Fun [a] Double + Maximum :: Fun [a] a + Minimum :: Fun [a] a + Nub :: Fun [a] [a] + Append :: Fun ([a], [a]) [a] + Add :: Fun (a,a) a + Mul :: Fun (a,a) a + Sub :: Fun (a,a) a + Div :: Fun (a,a) a + Mod :: Fun (Integer,Integer) Integer + Lt :: Fun (a,a) Bool + Lte :: Fun (a,a) Bool + Equ :: Fun (a,a) Bool + NEq :: Fun (a,a) Bool + Gte :: Fun (a,a) Bool + Gt :: Fun (a,a) Bool + Conj :: Fun (Bool,Bool) Bool + Disj :: Fun (Bool,Bool) Bool + Cons :: Fun (a,[a]) [a] + Index :: Fun ([a],Integer) a + Zip :: Fun ([a],[b]) [(a,b)] + Map :: Fun (a -> b,[a]) [b] + ConcatMap :: Fun (a -> [b],[a]) [b] + Filter :: Fun (a -> Bool,[a]) [a] + GroupWithKey :: Fun (a -> b,[a]) [(b, [a])] + SortWith :: Fun (a -> b,[a]) [a] + Cond :: Fun (Bool,a,a) a + Like :: Fun (Text,Text) Bool + SubString :: Integer -> Integer -> Fun Text Text + Transpose :: Fun [[a]] [[a]] + Reshape :: Integer -> Fun [a] [[a]] + Sin :: Fun Double Double + Cos :: Fun Double Double + Tan :: Fun Double Double + Sqrt :: Fun Double Double + Exp :: Fun Double Double + Log :: Fun Double Double + ASin :: Fun Double Double + ACos :: Fun Double Double + ATan :: Fun Double Double + TupElem :: TupElem a b -> Fun a b diff --git a/src/Database/DSH/Frontend/Internals.hs b/src/Database/DSH/Frontend/Internals.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Frontend/Internals.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Database.DSH.Frontend.Internals where + +import Data.Text (Text) +import Text.PrettyPrint.ANSI.Leijen + +import Database.DSH.Impossible +import Database.DSH.Frontend.Funs +import Database.DSH.Frontend.TupleTypes + +-------------------------------------------------------------------------------- +-- Typed frontend ASTs + +-- Generate the data types 'TupleConst' and 'TupleType' for tuple term +-- and type construction. +$(mkTupleAstComponents 16) + +data Exp a where + UnitE :: Exp () + BoolE :: Bool -> Exp Bool + CharE :: Char -> Exp Char + IntegerE :: Integer -> Exp Integer + DoubleE :: Double -> Exp Double + TextE :: Text -> Exp Text + ListE :: (Reify a) => [Exp a] -> Exp [a] + AppE :: (Reify a, Reify b) => Fun a b -> Exp a -> Exp b + LamE :: (Reify a, Reify b) => (Exp a -> Exp b) -> Exp (a -> b) + VarE :: (Reify a) => Integer -> Exp a + TableE :: (Reify a) => Table -> Exp [a] + TupleConstE :: TupleConst a -> Exp a + +data Type a where + UnitT :: Type () + BoolT :: Type Bool + CharT :: Type Char + IntegerT :: Type Integer + DoubleT :: Type Double + TextT :: Type Text + ListT :: (Reify a) => Type a -> Type [a] + ArrowT :: (Reify a,Reify b) => Type a -> Type b -> Type (a -> b) + TupleT :: TupleType a -> Type a + +instance Pretty (Type a) where + pretty UnitT = text "()" + pretty BoolT = text "Bool" + pretty CharT = text "Char" + pretty IntegerT = text "Integer" + pretty DoubleT = text "Double" + pretty TextT = text "Text" + pretty (ListT t) = brackets $ pretty t + pretty (ArrowT t1 t2) = parens $ pretty t1 <+> text "->" <+> pretty t2 + pretty (TupleT t) = pretty t + +-- FIXME generate with TH +instance Pretty (TupleType a) where + pretty (Tuple2T t1 t2) = tupled $ [pretty t1, pretty t2] + pretty _ = $unimplemented + +-------------------------------------------------------------------------------- +-- Classes + +class Reify a where + reify :: a -> Type a + +class (Reify (Rep a)) => QA a where + type Rep a + toExp :: a -> Exp (Rep a) + frExp :: Exp (Rep a) -> a + +class (QA a,QA r) => Elim a r where + type Eliminator a r + elim :: Q a -> Eliminator a r + +class BasicType a where + +class TA a where + +class View a where + type ToView a + view :: a -> ToView a + +newtype Q a = Q (Exp (Rep a)) + +pairE :: (Reify a, Reify b) => Exp a -> Exp b -> Exp (a, b) +pairE a b = TupleConstE (Tuple2E a b) + +tripleE :: (Reify a, Reify b, Reify c) => Exp a -> Exp b -> Exp c -> Exp (a, b, c) +tripleE a b c = TupleConstE (Tuple3E a b c) + +-- | A combination of column names that form a candidate key +newtype Key = Key [String] deriving (Eq, Ord, Show) + +-- | Is the table guaranteed to be not empty? +data Emptiness = NonEmpty + | PossiblyEmpty + deriving (Eq, Ord, Show) + +-- | Catalog information hints that users may give to DSH +data TableHints = TableHints + { keysHint :: [Key] + , nonEmptyHint :: Emptiness + } deriving (Eq, Ord, Show) + +data Table = TableDB String TableHints + +-- Reify instances + +instance Reify () where + reify _ = UnitT + +instance Reify Bool where + reify _ = BoolT + +instance Reify Char where + reify _ = CharT + +instance Reify Integer where + reify _ = IntegerT + +instance Reify Double where + reify _ = DoubleT + +instance Reify Text where + reify _ = TextT + +instance (Reify a) => Reify [a] where + reify _ = ListT (reify (undefined :: a)) + +instance (Reify a, Reify b) => Reify (a -> b) where + reify _ = ArrowT (reify (undefined :: a)) (reify (undefined :: b)) + +-- Utility functions + +unQ :: Q a -> Exp (Rep a) +unQ (Q e) = e + +toLam :: (QA a,QA b) => (Q a -> Q b) -> Exp (Rep a) -> Exp (Rep b) +toLam f = unQ . f . Q + +-- * Generate Reify instances for tuple types +mkReifyInstances 16 diff --git a/src/Database/DSH/Frontend/Schema.hs b/src/Database/DSH/Frontend/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Frontend/Schema.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | This module contains functionality to retrieve information about +-- the schema of actual database tables. +module Database.DSH.Frontend.Schema + ( getTableInfo + ) where + +import qualified Data.List as L +import GHC.Exts +import Text.Printf + +import qualified Database.HDBC as H + +import qualified Database.DSH.Common.Type as T + +-- | Retrieve through the given database connection information on the +-- table (columns with their types) which name is given as the second +-- argument. +getTableInfo :: H.IConnection conn => conn -> String -> IO [(String, String, (T.Type -> Bool))] +getTableInfo conn tableName = do + info <- H.describeTable conn tableName + case info of + [] -> error $ printf "Unknown table %s" tableName + _ : _ -> return $ toTableDescr info + + where + toTableDescr :: [(String, H.SqlColDesc)] -> [(String, String, T.Type -> Bool)] + toTableDescr cols = sortWith (\(n, _, _) -> n) + [ (name, show colTy, compatibleType colTy) + | (name, props) <- cols + , let colTy = H.colType props + ] + + + compatibleType :: H.SqlTypeId -> T.Type -> Bool + compatibleType dbT hsT = + case hsT of + T.UnitT -> True + T.BoolT -> L.elem dbT [H.SqlSmallIntT, H.SqlIntegerT, H.SqlBitT] + T.StringT -> L.elem dbT [H.SqlCharT, H.SqlWCharT, H.SqlVarCharT] + T.IntT -> L.elem dbT [H.SqlSmallIntT, H.SqlIntegerT, H.SqlTinyIntT, H.SqlBigIntT, H.SqlNumericT] + T.DoubleT -> L.elem dbT [H.SqlDecimalT, H.SqlRealT, H.SqlFloatT, H.SqlDoubleT] + t -> error $ printf "Unsupported column type %s for table %s" (show t) (show tableName) diff --git a/src/Database/DSH/Frontend/TH.hs b/src/Database/DSH/Frontend/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Frontend/TH.hs @@ -0,0 +1,564 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Frontend.TH + ( deriveDSH + , deriveQA + , deriveTA + , deriveView + , deriveElim + , deriveSmartConstructors + , generateTableSelectors + -- FIXME don't expose tuple constructors but use qualified names + , DSH.TupleConst(..) + , F.TupElem(..) + , DSH.Exp(..) + , F.Fun(..) + ) where + +import Control.Monad +import Control.Applicative +import Data.Char +import Data.List + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import qualified Database.DSH.Frontend.Internals as DSH +import Database.DSH.Frontend.TupleTypes +import qualified Database.DSH.Frontend.Funs as F +import Database.DSH.Impossible + + +----------------------------------------- +-- Deriving all DSH-relevant instances -- +----------------------------------------- + +deriveDSH :: Name -> Q [Dec] +deriveDSH n = do + qaDecs <- deriveQA n + -- elimDecs <- deriveElim n + cc <- countConstructors n + viewDecs <- if cc == 1 + then deriveView n + else return [] + scDecs <- deriveSmartConstructors n + return (qaDecs {- ++ elimDecs -} ++ viewDecs ++ scDecs) + +----------------- +-- Deriving QA -- +----------------- + +-- | Derive QA instances for data types and newtypes. +deriveQA :: Name -> Q [Dec] +deriveQA name = do + info <- reify name + case info of + TyConI (DataD _cxt name1 tyVarBndrs cons _names) -> + deriveTyConQA name1 tyVarBndrs cons + TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> + deriveTyConQA name1 tyVarBndrs [con] + _ -> fail errMsgExoticType + +deriveTyConQA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] +deriveTyConQA name tyVarBndrs cons = do + let context = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) + tyVarBndrs + let typ = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) + let instanceHead = AppT (ConT ''DSH.QA) typ + let repDec = deriveRep typ cons + toExpDec <- deriveToExp cons + frExpDec <- deriveFrExp cons + return [InstanceD context instanceHead [repDec,toExpDec,frExpDec]] + +-- Deriving the Rep type function + +-- | Derive the representation type 'Rep' for a data type +deriveRep :: Type -> [Con] -> Dec +-- GHC-7.8.2 (template-haskell-2.9.0.0) has a trivial but incompatible +-- modification: two arguments of TySynInstD are now encapsulated in a +-- TySynEqn constructor +#if MIN_VERSION_template_haskell(2,9,0) +deriveRep typ cons = TySynInstD ''DSH.Rep $ TySynEqn [typ] (deriveRepCons cons) +#else +deriveRep typ cons = TySynInstD ''DSH.Rep [typ] (deriveRepCons cons) +#endif + +-- | Derive the representation type 'Rep' for the complete type (all +-- constructors). +deriveRepCons :: [Con] -> Type +deriveRepCons [] = error errMsgExoticType +-- The representation of a type with only one constructor is the +-- representation of that constructor. +deriveRepCons [c] = deriveRepCon c +-- The representation of a type with multiple constructors is a tuple +-- of the representation types for all individual constructors (each +-- wrapped in a list). +deriveRepCons cs | length cs <= 16 = mkTupleType $ map (AppT (ConT ''[]) . deriveRepCon) cs +deriveRepCons _ = error errMsgTypeTooBroad + + +-- | Derive the representation type 'Rep' for a single constructor +deriveRepCon :: Con -> Type +deriveRepCon con = case conToTypes con of + -- A constructor without fields is represented by the empty type + [] -> ConT ''() + -- The representation of a constructor with only one field is the + -- field type itself. + [t] -> t + -- Constructors with more fields (up to 16) are represented by a + -- tuple that contains values for all fields. + ts | length ts <= 16 -> mkTupleType $ map (AppT (ConT ''DSH.Rep)) ts + _ | otherwise -> error errMsgTypeTooBroad + +-- Deriving the toExp function of the QA class + +deriveToExp :: [Con] -> Q Dec +deriveToExp [] = fail errMsgExoticType +deriveToExp cons = do + clauses <- sequence (zipWith3 deriveToExpClause (repeat (length cons)) [0 .. ] cons) + return (FunD 'DSH.toExp clauses) + +deriveToExpClause :: Int -- Total number of constructors + -> Int -- Index of the constructor + -> Con + -> Q Clause +deriveToExpClause 0 _ _ = fail errMsgExoticType +deriveToExpClause 1 _ con = do + (pat1,names1) <- conToPattern con + exp1 <- deriveToExpMainExp names1 + let body1 = NormalB exp1 + return (Clause [pat1] body1 []) +-- FIXME adapt code for types with multiple constructors to new tuple +-- regime. +deriveToExpClause n i con = $unimplemented +{- + (pat1,names1) <- conToPattern con + let exp1 = deriveToExpMainExp names1 + expList1 <- [| DSH.ListE [ $(return exp1) ] |] + expEmptyList <- [| DSH.ListE [] |] + let lists = concat [ replicate i expEmptyList + , [expList1] + , replicate (n - i - 1) expEmptyList] + let exp2 = foldr1 (AppE . AppE (ConE 'DSH.PairE)) lists + let body1 = NormalB exp2 + return (Clause [pat1] body1 []) +-} + +deriveToExpMainExp :: [Name] -> Q Exp +deriveToExpMainExp [] = return $ ConE 'DSH.UnitE +deriveToExpMainExp [name] = return $ AppE (VarE 'DSH.toExp) (VarE name) +deriveToExpMainExp names = mkTupConstTerm $ map (AppE (VarE 'DSH.toExp) . VarE) names + +-- Deriving to frExp function of the QA class + +deriveFrExp :: [Con] -> Q Dec +deriveFrExp cons = do + clauses <- sequence (zipWith3 deriveFrExpClause (repeat (length cons)) [0 .. ] cons) + imp <- impossible + let lastClause = Clause [WildP] (NormalB imp) [] + return (FunD 'DSH.frExp (clauses ++ [lastClause])) + +deriveFrExpClause :: Int -- Total number of constructors + -> Int -- Index of the constructor + -> Con + -> Q Clause +deriveFrExpClause 1 _ con = do + (_,names1) <- conToPattern con + let pat1 = deriveFrExpMainPat names1 + let exp1 = foldl AppE + (ConE (conToName con)) + (map (AppE (VarE 'DSH.frExp) . VarE) names1) + let body1 = NormalB exp1 + return (Clause [pat1] body1 []) +-- FIXME adapt code for types with multiple constructors to new tuple +-- regime. +deriveFrExpClause n i con = $unimplemented +{- + (_,names1) <- conToPattern con + let pat1 = deriveFrExpMainPat names1 + let patList1 = ConP 'DSH.ListE [ConP '(:) [pat1,WildP]] + let lists = replicate i WildP ++ [patList1] ++ replicate (n - i - 1) WildP + let pat2 = foldr1 (\p1 p2 -> ConP 'DSH.PairE [p1,p2]) lists + let exp1 = foldl AppE + (ConE (conToName con)) + (map (AppE (VarE 'DSH.frExp) . VarE) names1) + let body1 = NormalB exp1 + return (Clause [pat2] body1 []) +-} + +deriveFrExpMainPat :: [Name] -> Pat +deriveFrExpMainPat [] = ConP 'DSH.UnitE [] +deriveFrExpMainPat [name] = VarP name +deriveFrExpMainPat names = mkTuplePat names + +----------------- +-- Deriving TA -- +----------------- + +deriveTA :: Name -> Q [Dec] +deriveTA name = do + info <- reify name + case info of + TyConI (DataD _cxt name1 tyVarBndrs cons _names) -> + deriveTyConTA name1 tyVarBndrs cons + TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> + deriveTyConTA name1 tyVarBndrs [con] + _ -> fail errMsgExoticType + +deriveTyConTA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] +deriveTyConTA name tyVarBndrs _cons = do + let context = map (\tv -> ClassP ''DSH.BasicType [VarT (tyVarBndrToName tv)]) + tyVarBndrs + let typ = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) + let instanceHead = AppT (ConT ''DSH.TA) typ + return [InstanceD context instanceHead []] + +------------------- +-- Deriving View -- +------------------- + +deriveView :: Name -> Q [Dec] +deriveView name = do + info <- reify name + case info of + TyConI (DataD _cxt name1 tyVarBndrs [con] _names) -> + deriveTyConView name1 tyVarBndrs con + TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> + deriveTyConView name1 tyVarBndrs con + _ -> fail errMsgExoticType + +deriveTyConView :: Name -> [TyVarBndr] -> Con -> Q [Dec] +deriveTyConView name tyVarBndrs con = do + let context = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs + let typ1 = AppT (ConT ''DSH.Q) + (foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs)) + let instanceHead = AppT (ConT ''DSH.View) typ1 + let typs = conToTypes con + let typ2 = if null typs + then AppT (ConT ''DSH.Q) (ConT ''()) + else foldl AppT (TupleT (length typs)) (map (AppT (ConT ''DSH.Q)) typs) +#if MIN_VERSION_template_haskell(2,9,0) + let toViewDecTF = TySynInstD ''DSH.ToView $ TySynEqn [typ1] typ2 +#else + let toViewDecTF = TySynInstD ''DSH.ToView [typ1] typ2 +#endif + viewDec <- deriveToView (length typs) + return [InstanceD context instanceHead [toViewDecTF, viewDec]] + +deriveToView :: Int -> Q Dec +deriveToView n = do + en <- newName "e" + let ep = VarP en + let pat1 = ConP 'DSH.Q [ep] + + tupElems <- mapM (\i -> [| DSH.Q $ $(mkTupElemTerm n i (VarE en)) |]) [1..n] + + let body1 = TupE $ tupElems + let clause1 = Clause [pat1] (NormalB body1) [] + return (FunD 'DSH.view [clause1]) + +------------------- +-- Deriving Elim -- +------------------- + +deriveElim :: Name -> Q [Dec] +deriveElim name = do + info <- reify name + case info of + TyConI (DataD _cxt name1 tyVarBndrs cons _names) -> + deriveTyConElim name1 tyVarBndrs cons + TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> + deriveTyConElim name1 tyVarBndrs [con] + _ -> fail errMsgExoticType + +deriveTyConElim :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] +deriveTyConElim name tyVarBndrs cons = do + resultTyName <- newName "r" + let resTy = VarT resultTyName + let ty = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) + let context = ClassP ''DSH.QA [resTy] : + map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs + let instanceHead = AppT (AppT (ConT ''DSH.Elim) ty) resTy + let eliminatorDec = deriveEliminator ty resTy cons + elimDec <- deriveElimFun cons + return [InstanceD context instanceHead [eliminatorDec,elimDec]] + +-- Deriving the Eliminator type function + +deriveEliminator :: Type -> Type -> [Con] -> Dec +deriveEliminator typ resTy cons = +#if MIN_VERSION_template_haskell(2,9,0) + TySynInstD ''DSH.Eliminator $ TySynEqn [typ,resTy] (deriveEliminatorCons resTy cons) +#else + TySynInstD ''DSH.Eliminator [typ,resTy] (deriveEliminatorCons resTy cons) +#endif + + +deriveEliminatorCons :: Type -> [Con] -> Type +deriveEliminatorCons _ [] = error errMsgExoticType +deriveEliminatorCons resTy cs = + foldr (AppT . AppT ArrowT . deriveEliminatorCon resTy) + (AppT (ConT ''DSH.Q) resTy) + cs + +deriveEliminatorCon :: Type -> Con -> Type +deriveEliminatorCon resTy con = + foldr (AppT . AppT ArrowT . AppT (ConT ''DSH.Q)) + (AppT (ConT ''DSH.Q) resTy) + (conToTypes con) + +-- Deriving the elim function of the Elim type class + +deriveElimFun :: [Con] -> Q Dec +deriveElimFun cons = do + clause1 <- deriveElimFunClause cons + return (FunD 'DSH.elim [clause1]) + +deriveElimFunClause :: [Con] -> Q Clause +deriveElimFunClause cons = do + en <- newName "e" + fns <- mapM (\ _ -> newName "f") cons + let fes = map VarE fns + let pats1 = ConP 'DSH.Q [VarP en] : map VarP fns + + fes2 <- zipWithM deriveElimToLamExp fes (map (length . conToTypes) cons) + + let e = VarE en + liste <- [| DSH.ListE $(listE $ deriveElimFunClauseExp (return e) (map return fes2)) |] + let concate = AppE (AppE (ConE 'DSH.AppE) (ConE 'F.Concat)) liste + let heade = AppE (AppE (ConE 'DSH.AppE) (ConE 'F.Head)) concate + let qe = AppE (ConE 'DSH.Q) heade + return (Clause pats1 (NormalB qe) []) + +deriveElimToLamExp :: Exp -> Int -> Q Exp +deriveElimToLamExp f 0 = + return (AppE (VarE 'const) (AppE (VarE 'DSH.unQ) f)) +deriveElimToLamExp f 1 = do + xn <- newName "x" + let xe = VarE xn + let xp = VarP xn + let qe = AppE (ConE 'DSH.Q) xe + let fappe = AppE f qe + let unqe = AppE (VarE 'DSH.unQ) fappe + return (LamE [xp] unqe) +deriveElimToLamExp f n = do + xn <- newName "x" + let xe = VarE xn + let xp = VarP xn + let fste = AppE (AppE (ConE 'DSH.AppE) (ConE 'F.Fst)) xe + let snde = AppE (AppE (ConE 'DSH.AppE) (ConE 'F.Snd)) xe + let qe = AppE (ConE 'DSH.Q) fste + let fappe = AppE f qe + f' <- deriveElimToLamExp fappe (n - 1) + return (LamE [xp] (AppE f' snde)) + +deriveElimFunClauseExp :: Q Exp -> [Q Exp] -> [Q Exp] +deriveElimFunClauseExp _ [] = error errMsgExoticType +deriveElimFunClauseExp e [f] = [ [| DSH.ListE [$f $e] |] ] +deriveElimFunClauseExp e fs = go e fs + where + go :: Q Exp -> [Q Exp] -> [Q Exp] + go _ [] = error errMsgExoticType + -- FIXME PairE + go e1 [f1] = do + [ [| DSH.AppE F.Map (DSH.TupleConstE (DSH.Tuple2E (DSH.LamE $f1) $e1)) |] ] + go e1 (f1 : fs1) = do + let mape = [| DSH.AppE F.Map (DSH.TupleConstE (DSH.Tuple2E (DSH.LamE $f1) (DSH.AppE F.Fst $e1))) |] + let snde = [| DSH.AppE F.Snd $e1 |] + mape : go snde fs1 + +--------------------------------- +-- Deriving Smart Constructors -- +--------------------------------- + +deriveSmartConstructors :: Name -> Q [Dec] +deriveSmartConstructors name = do + info <- reify name + case info of + TyConI (DataD _cxt typConName tyVarBndrs cons _names) -> do + decss <- zipWithM (deriveSmartConstructor typConName tyVarBndrs (length cons)) + [0 .. ] + cons + return (concat decss) + TyConI (NewtypeD _cxt typConName tyVarBndrs con _names) -> + deriveSmartConstructor typConName tyVarBndrs 1 0 con + _ -> fail errMsgExoticType + +deriveSmartConstructor :: Name -> [TyVarBndr] -> Int -> Int -> Con -> Q [Dec] +deriveSmartConstructor typConName tyVarBndrs n i con = do + let smartConName = toSmartConName (conToName con) + + let boundTyps = map (VarT . tyVarBndrToName) tyVarBndrs + + let resTyp = AppT (ConT ''DSH.Q) (foldl AppT (ConT typConName) boundTyps) + + let smartConContext = map (ClassP ''DSH.QA . return) boundTyps + + let smartConTyp = foldr (AppT . AppT ArrowT . AppT (ConT ''DSH.Q)) + resTyp + (conToTypes con) + + let smartConDec = SigD smartConName (ForallT tyVarBndrs smartConContext smartConTyp) + + ns <- mapM (\_ -> newName "e") (conToTypes con) + let es = map VarE ns + + let smartConPat = map (ConP 'DSH.Q . return . VarP) ns + + -- FIXME PairE -> TupleE + smartConExp <- if null es + then return $ ConE 'DSH.UnitE + else mkTupConstTerm es + smartConBody <- deriveSmartConBody n i smartConExp + let smartConClause = Clause smartConPat (NormalB smartConBody) [] + + let funDec = FunD smartConName [smartConClause] + + return [smartConDec,funDec] + +deriveSmartConBody :: Int -- Total number of constructors + -> Int -- Index of the constructor + -> Exp + -> Q Exp +deriveSmartConBody 0 _ _ = fail errMsgExoticType +deriveSmartConBody 1 _ e = return (AppE (ConE 'DSH.Q) e) +deriveSmartConBody n i e = do + listExp <- [| DSH.ListE [ $(return e) ] |] + emptyListExp <- [| DSH.ListE [] |] + let lists = concat [ replicate i emptyListExp + , [listExp] + , replicate (n - i - 1) emptyListExp + ] + tupleExp <- mkTupConstTerm lists + return $ AppE (ConE 'DSH.Q) tupleExp + +toSmartConName :: Name -> Name +toSmartConName name1 = case nameBase name1 of + "()" -> mkName "unit" + '(' : cs -> mkName ("tuple" ++ show (length (filter (== ',') cs) + 1)) + c : cs | isAlpha c -> mkName (toLower c : cs) + cs -> mkName (':' : cs) + +---------------------------------------- +-- Generating lifted record selectors -- +---------------------------------------- + +{- + +For a record declaration like + +data R = R { a :: Integer, b :: Text } + +we generate the following lifted selectors: + +aQ :: Q R -> Q Integer +aQ (view -> (a, _)) = a + +bQ :: Q R -> Q Text +bQ (view -> (_, b)) = b + +-} + +-- | Create lifted record selectors +generateTableSelectors :: Name -> Q [Dec] +generateTableSelectors name = do + info <- reify name + case info of + TyConI (DataD _ typName [] [RecC _ fields] _) -> concat <$> mapM instSelectors fields + where fieldNames = map (\(f, _, _) -> f) fields + instSelectors = generateTableSelector typName fieldNames + _ -> fail errMsgBaseRecCons + +generateTableSelector :: Name -> [Name] -> VarStrictType -> Q [Dec] +generateTableSelector typeName allFieldNames (fieldName, _strict, typ) = do + let selName = case fieldName of + Name (OccName n) _ -> mkName $ n ++ "Q" + + let selType = AppT (AppT ArrowT (AppT (ConT ''DSH.Q) (ConT typeName))) (AppT (ConT ''DSH.Q) typ) + sigDec = SigD selName selType + + fieldVarName <- newName "x" + let projectField f | f == fieldName = VarP fieldVarName + projectField _ = WildP + + tupPat = map projectField allFieldNames + + argPat = ViewP (VarE 'DSH.view) (TupP tupPat) + + bodyExp = NormalB $ VarE fieldVarName + + funDec = FunD selName [Clause [argPat] bodyExp []] + + + return [sigDec, funDec] + +-- Helper Functions + + +-- | From a list of operand patterns, construct a DSH tuple term +-- pattern. +-- @ +-- TupleE (Tuple3E a b) -> ... +-- @ +mkTuplePat :: [Name] -> Pat +mkTuplePat names = ConP 'DSH.TupleConstE [ConP (innerConst $ length names) (map VarP names)] + +-- | Generate a (flat) tuple type from the list of element types. +mkTupleType :: [Type] -> Type +mkTupleType ts = foldl' AppT (TupleT $ length ts) ts + +-- | Return the types of all fields of a constructor. +conToTypes :: Con -> [Type] +conToTypes (NormalC _name strictTypes) = map snd strictTypes +conToTypes (RecC _name varStrictTypes) = map (\(_,_,t) -> t) varStrictTypes +conToTypes (InfixC st1 _name st2) = [snd st1,snd st2] +conToTypes (ForallC _tyVarBndrs _cxt con) = conToTypes con + +tyVarBndrToName :: TyVarBndr -> Name +tyVarBndrToName (PlainTV name) = name +tyVarBndrToName (KindedTV name _kind) = name + +-- | For a given constructor, create a pattern that matches the +-- constructor and binds all fields to the names returned. +conToPattern :: Con -> Q (Pat,[Name]) +conToPattern (NormalC name strictTypes) = do + ns <- mapM (\ _ -> newName "x") strictTypes + return (ConP name (map VarP ns),ns) +conToPattern (RecC name varStrictTypes) = do + ns <- mapM (\ _ -> newName "x") varStrictTypes + return (ConP name (map VarP ns),ns) +conToPattern (InfixC st1 name st2) = do + ns <- mapM (\ _ -> newName "x") [st1,st2] + return (ConP name (map VarP ns),ns) +conToPattern (ForallC _tyVarBndr _cxt con) = conToPattern con + +conToName :: Con -> Name +conToName (NormalC name _) = name +conToName (RecC name _) = name +conToName (InfixC _ name _) = name +conToName (ForallC _ _ con) = conToName con + +countConstructors :: Name -> Q Int +countConstructors name = do + info <- reify name + case info of + TyConI (DataD _ _ _ cons _) -> return (length cons) + TyConI (NewtypeD {}) -> return 1 + _ -> fail errMsgExoticType + +-- Error messages + +errMsgExoticType :: String +errMsgExoticType = + "Automatic derivation of DSH related type class instances only works for Haskell 98\n" + ++ "types. Derivation of View patterns is only supported for single-constructor data\n" + ++ "types." + +errMsgBaseRecCons :: String +errMsgBaseRecCons = + "Generation of lifted record selectors is only supported for records of base types." + +errMsgTypeTooBroad :: String +errMsgTypeTooBroad = + "DSH currently supports data types with up to 16 constructors and in which \n" + ++ "all constructors have up to 16 fields." diff --git a/src/Database/DSH/Frontend/TupleTypes.hs b/src/Database/DSH/Frontend/TupleTypes.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Frontend/TupleTypes.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Generate AST types, functions and instances for tuples. +module Database.DSH.Frontend.TupleTypes + ( -- * Generate tuple types, functions and instances + mkQAInstances + , mkTAInstances + , mkTupleConstructors + , mkTupElemType + , mkTupElemCompile + , mkReifyInstances + , mkTranslateTupleTerm + , mkTranslateType + , mkViewInstances + , mkTupleAstComponents + -- * Helper functions + , innerConst + , outerConst + , tupAccName + , mkTupElemTerm + , mkTupConstTerm + , tupTyConstName + ) where + +import Control.Applicative +import Data.List +import Text.Printf + +import Language.Haskell.TH + +import Database.DSH.Impossible +import Database.DSH.Common.Nat +import qualified Database.DSH.Common.Type as T +import qualified Database.DSH.CL.Primitives as CP +import qualified Database.DSH.CL.Lang as CL + +-------------------------------------------------------------------------------- +-- Tuple Accessors + +-- | Generate all constructors for a given tuple width. +mkTupElemCons :: Name -> Name -> Int -> Q [Con] +mkTupElemCons aTyVar bTyVar width = do + boundTyVars <- mapM (\i -> newName $ printf "t%d" i) [1..width-1] + mapM (mkTupElemCon aTyVar bTyVar boundTyVars width) [1..width] + +mkTupType :: Int -> Int -> [Name] -> Name -> Type +mkTupType elemIdx width boundTyVars bTyVar = + let elemTys = map VarT $ take (elemIdx - 1) boundTyVars + ++ [bTyVar] + ++ drop (elemIdx - 1) boundTyVars + in foldl' AppT (TupleT width) elemTys + +mkTupElemCon :: Name -> Name -> [Name] -> Int -> Int -> Q Con +mkTupElemCon aTyVar bTyVar boundTyVars width elemIdx = do + let binders = map PlainTV boundTyVars + let tupTy = mkTupType elemIdx width boundTyVars bTyVar + let con = tupAccName width elemIdx + let ctx = [EqualP (VarT aTyVar) tupTy] + return $ ForallC binders ctx (NormalC con []) + +-- | Generate the complete type of tuple acccessors for all tuple +-- widths. +-- +-- @ +-- data TupElem a b where +-- Tup2_1 :: TupElem (a, b) a +-- Tup2_2 :: TupElem (a, b) b +-- Tup3_1 :: TupElem (a, b, c) a +-- Tup3_2 :: TupElem (a, b, c) b +-- Tup3_3 :: TupElem (a, b, c) c +-- ... +-- @ +-- +-- Due to the lack of support for proper GADT syntax in TH, we have +-- to work with explicit universal quantification: +-- +-- @ +-- data TupElem a b = +-- | forall d. a ~ (b, d) => Tup2_1 +-- | forall d. a ~ (d, b) => Tup2_2 +-- +-- | forall d e. a ~ (b, d, e) => Tup3_1 +-- | forall d e. a ~ (d, b, e) => Tup3_2 +-- | forall d e. a ~ (d, e, b) => Tup3_3 +-- ... +-- @ +mkTupElemType :: Int -> Q [Dec] +mkTupElemType maxWidth = do + let tyName = mkName "TupElem" + + aTyVar <- newName "a" + bTyVar <- newName "b" + let tyVars = map PlainTV [aTyVar, bTyVar] + + cons <- concat <$> mapM (mkTupElemCons aTyVar bTyVar) [2..maxWidth] + + return $ [DataD [] tyName tyVars cons []] + +-------------------------------------------------------------------------------- +-- Translation of tuple accessors to CL + +mkCompileMatch :: Name -> (Name, Int) -> Q Match +mkCompileMatch exprName (con, elemIdx) = do + let translateVar = return $ VarE $ mkName "translate" + exprVar = return $ VarE exprName + idxLit = return $ LitE $ IntegerL $ fromIntegral elemIdx + bodyExp <- [| CP.tupElem (intIndex $idxLit) <$> $translateVar $exprVar |] + let body = NormalB $ bodyExp + return $ Match (ConP con []) body [] + +mkTupElemCompile :: Int -> Q Exp +mkTupElemCompile maxWidth = do + let cons = concat [ [ (tupAccName width idx, idx) + | idx <- [1..width] + ] + | width <- [2..maxWidth] + ] + + exprName <- newName "e" + opName <- newName "te" + + matches <- mapM (mkCompileMatch exprName) cons + + let lamBody = CaseE (VarE opName) matches + return $ LamE [VarP opName, VarP exprName] lamBody + +-------------------------------------------------------------------------------- +-- Reify instances for tuple types + +reifyType :: Name -> Exp +reifyType tyName = AppE (VarE $ mkName "reify") (SigE (VarE 'undefined) (VarT tyName)) + +mkReifyFun :: [Name] -> Dec +mkReifyFun tyNames = + let argTys = map reifyType tyNames + body = AppE (ConE $ mkName "TupleT") + $ foldl' AppE (ConE $ tupTyConstName $ length tyNames) argTys + in FunD (mkName "reify") [Clause [WildP] (NormalB body) []] + +mkReifyInstance :: Int -> Dec +mkReifyInstance width = + let tyNames = map (\i -> mkName $ "t" ++ show i) [1..width] + instTy = AppT (ConT $ mkName "Reify") $ tupleType $ map VarT tyNames + reifyCxt = map (\tyName -> ClassP (mkName "Reify") [VarT tyName]) tyNames + + in InstanceD reifyCxt instTy [mkReifyFun tyNames] + +mkReifyInstances :: Int -> Q [Dec] +mkReifyInstances maxWidth = return $ map mkReifyInstance [2..maxWidth] + +-------------------------------------------------------------------------------- +-- QA instances for tuple types + +mkToExp :: Int -> [Name] -> Dec +mkToExp width elemNames = + let toExpVar = VarE $ mkName "toExp" + elemArgs = map (\n -> AppE toExpVar (VarE n)) elemNames + body = NormalB $ AppE (ConE outerConst) + $ foldl' AppE (ConE $ innerConst width) elemArgs + tupClause = Clause [TupP $ map VarP elemNames] body [] + in FunD (mkName "toExp") [tupClause] + +mkFrExp :: Int -> [Name] -> Q Dec +mkFrExp width elemNames = do + impossibleExpr <- [| error $(litE $ StringL $ printf "frExp %d" width) |] + let tupPattern = ConP outerConst [ConP (innerConst width) (map VarP elemNames) ] + tupleExpr = TupE $ map (\n -> AppE (VarE $ mkName "frExp") (VarE n)) elemNames + tupleClause = Clause [tupPattern] (NormalB tupleExpr) [] + impossibleClause = Clause [WildP] (NormalB impossibleExpr) [] + return $ FunD (mkName "frExp") [tupleClause, impossibleClause] + +mkRep :: Int -> [Name] -> Type -> Dec +mkRep width tyNames tupTyPat = + let resTy = foldl' AppT (TupleT width) + $ map (AppT $ ConT $ mkName "Rep") + $ map VarT tyNames + in TySynInstD (mkName "Rep") (TySynEqn [tupTyPat] resTy) + +mkQAInstance :: Int -> Q Dec +mkQAInstance width = do + let tyNames = map (\i -> mkName $ "t" ++ show i) [1..width] + tupTy = tupleType $ map VarT tyNames + instTy = AppT (ConT $ mkName "QA") tupTy + qaCxt = map (\tyName -> ClassP (mkName "QA") [VarT tyName]) tyNames + rep = mkRep width tyNames tupTy + toExp = mkToExp width tyNames + frExp <- mkFrExp width tyNames + return $ InstanceD qaCxt instTy [rep, toExp, frExp] + +-- | Generate QA instances for tuple types according to the following template: +-- +-- @ +-- instance (QA t1, ..., QA tn) => QA (t1, ..., tn) where +-- type Rep (t1, ..., tn) = (Rep t1, ..., Rep tn) +-- toExp (v1, ..., vn) = TupleConstE (TupleE (toExp v1) ... (toExp vn)) +-- frExp (TupleConstE (TupleE v1 ... vn)) = (frExp v1, ... b, frExp vn) +-- frExp _ = $impossible +-- @ +mkQAInstances :: Int -> Q [Dec] +mkQAInstances maxWidth = mapM mkQAInstance [2..maxWidth] + +-------------------------------------------------------------------------------- +-- TA instances for tuple types + +mkTAInstance :: Int -> Dec +mkTAInstance width = + let tyNames = map (\i -> mkName $ "t" ++ show i) [1..width] + tupTy = foldl' AppT (TupleT width) $ map VarT tyNames + instTy = AppT (ConT $ mkName "TA") tupTy + taCxt = map (\tyName -> ClassP (mkName "BasicType") [VarT tyName]) tyNames + in InstanceD taCxt instTy [] + +-- | Generate TA instances for tuple types according to the following template: +-- +-- @ +-- instance (BasicType t1, ..., BasicType tn) => TA (t1, ..., tn) where +-- @ +mkTAInstances :: Int -> Q [Dec] +mkTAInstances maxWidth = return $ map mkTAInstance [2..maxWidth] + +-------------------------------------------------------------------------------- +-- Smart constructors for tuple values + +tupConName :: Int -> Name +tupConName width = mkName $ printf "tup%d" width + +mkArrowTy :: Type -> Type -> Type +mkArrowTy domTy coDomTy = AppT (AppT ArrowT domTy) coDomTy + +mkTupleConstructor :: Int -> [Dec] +mkTupleConstructor width = + let tyNames = map (\i -> mkName $ "t" ++ show i) [1..width] + + -- Type stuff + tupTy = AppT (ConT qName) $ foldl' AppT (TupleT width) $ map VarT tyNames + elemTys = map (AppT (ConT qName)) $ map VarT tyNames + arrowTy = foldr mkArrowTy tupTy elemTys + qaConstr = map (\n -> ClassP (mkName "QA") [VarT n]) tyNames + funTy = ForallT (map PlainTV tyNames) qaConstr arrowTy + + -- Term stuff + qPats = map (\n -> ConP qName [VarP n]) tyNames + tupConApp = foldl' AppE (ConE $ innerConst width) $ map VarE tyNames + bodyExp = AppE (ConE qName) (AppE (ConE outerConst) tupConApp) + + sig = SigD (tupConName width) funTy + body = FunD (tupConName width) [Clause qPats (NormalB bodyExp) []] + in [sig, body] + +-- | Construct smart constructors for tuple types according to the +-- following template. +-- +-- @ +-- tup :: (QA t1, ...,QA tn) => Q t1 -> ... -> Q tn -> Q (t1, ..., tn) +-- tup (Q v1) ... (Q vn)= Q (TupleConstE (TupleE v1 ... vn)) +-- @ +mkTupleConstructors :: Int -> Q [Dec] +mkTupleConstructors maxWidth = return $ concatMap mkTupleConstructor [2..maxWidth] + +-------------------------------------------------------------------------------- +-- Translation function for tuple constructors in terms + +{- +\t -> case t of + Tuple2E a b -> do + a' <- translate a + b' <- translate b + return $ CL.MkTuple (T.TupleT $ map T.typeOf [a', b']) [a', b'] + Tuple3E a b c -> ... +-} + +mkTransBind :: Name -> Name -> Stmt +mkTransBind argName resName = + BindS (VarP resName) (AppE (VarE $ mkName "translate") (VarE argName)) + +-- | Generate the translation case for a particular tuple value +-- constructor. +mkTranslateTermMatch :: Int -> Q Match +mkTranslateTermMatch width = do + let names = map (\c -> [c]) $ take width ['a' .. 'z'] + subTermNames = map mkName names + transTermNames = map (mkName . (++ "'")) names + transBinds = zipWith mkTransBind subTermNames transTermNames + + transTerms = listE $ map varE transTermNames + conStmt <- NoBindS <$> + [| return $ CL.MkTuple (T.TupleT $ map T.typeOf $transTerms) $transTerms |] + let matchBody = DoE $ transBinds ++ [conStmt] + matchPat = ConP (innerConst width) (map VarP subTermNames) + return $ Match matchPat (NormalB matchBody) [] + +-- | Generate the lambda expression that translates frontend tuple +-- value constructors into CL tuple constructors. +mkTranslateTupleTerm :: Int -> Q Exp +mkTranslateTupleTerm maxWidth = do + lamArgName <- newName "tupleConst" + + matches <- mapM mkTranslateTermMatch [2..maxWidth] + + let lamBody = CaseE (VarE lamArgName) matches + return $ LamE [VarP lamArgName] lamBody + +-------------------------------------------------------------------------------- +-- Translation function for tuple types + +{- +\t -> case t of + Tuple3T t1 t2 t3 -> T.TupleT [translateType t1, translateType t2, translateType t3] +-} + +mkTranslateTypeMatch :: Int -> Q Match +mkTranslateTypeMatch width = do + let subTyNames = map mkName $ map (\c -> [c]) $ take width ['a' .. 'z'] + matchPat = ConP (tupTyConstName width) (map VarP subTyNames) + transElemTys = ListE $ map (\n -> AppE (VarE $ mkName "translateType") (VarE n)) subTyNames + + let matchBody = AppE (ConE 'T.TupleT) transElemTys + + return $ Match matchPat (NormalB matchBody) [] + +mkTranslateType :: Int -> Q Exp +mkTranslateType maxWidth = do + lamArgName <- newName "typeConst" + matches <- mapM mkTranslateTypeMatch [2..maxWidth] + + let lamBody = CaseE (VarE lamArgName) matches + return $ LamE [VarP lamArgName] lamBody + +-------------------------------------------------------------------------------- +-- View instances + +{- +instance (QA a,QA b,QA c) => View (Q (a,b,c)) where + type ToView (Q (a,b,c)) = (Q a,Q b,Q c) + view (Q e) = ( Q (AppE (TupElem Tup3_1) e) + , Q (AppE (TupElem Tup3_2) e) + , Q (AppE (TupElem Tup3_3) e) + ) +-} + +mkToView :: [Name] -> Type -> Dec +mkToView names tupTyPat = + let qTupPat = AppT (ConT qName) tupTyPat + resTupTy = tupleType $ map (\n -> AppT (ConT qName) (VarT n)) names + in TySynInstD (mkName "ToView") (TySynEqn [qTupPat] resTupTy) + +mkViewFun :: Int -> Q Dec +mkViewFun width = do + expName <- newName "e" + let expVar = VarE expName + qPat = ConP qName [VarP expName] + + viewBodyExp <- TupE <$> mapM (\idx -> appE (conE qName) $ mkTupElemTerm width idx expVar) + [1..width] + + let viewClause = Clause [qPat] (NormalB viewBodyExp) [] + + return $ FunD (mkName "view") [viewClause] + +mkViewInstance :: Int -> Q Dec +mkViewInstance width = do + let names = map (\i -> mkName $ "t" ++ show i) [1..width] + tupTy = tupleType $ map VarT names + instTy = AppT (ConT $ mkName "View") (AppT (ConT qName) tupTy) + + viewCxt = map (\n -> ClassP (mkName "QA") [VarT n]) names + toViewDec = mkToView names tupTy + viewDec <- mkViewFun width + return $ InstanceD viewCxt instTy [toViewDec, viewDec] + +mkViewInstances :: Int -> Q [Dec] +mkViewInstances maxWidth = mapM mkViewInstance [2..maxWidth] + +-------------------------------------------------------------------------------- +-- Generate the 'TupleConst' type + +tupElemTyName :: Int -> Q Name +tupElemTyName i = newName $ printf "t%d" i + +-- | Generate a single constructor for the 'TabTuple' type. +mkTupleCons :: Name -> (Int -> Name) -> (Type -> Type) -> Int -> Q Con +mkTupleCons tupTyName conName elemTyCons width = do + + tupElemTyNames <- mapM tupElemTyName [1..width] + + let tyVarBinders = map PlainTV tupElemTyNames + + -- (t1, ..., t) + tupTy = foldl' AppT (TupleT width) + $ map VarT tupElemTyNames + + -- a ~ (t1, ..., t) + tupConstraint = EqualP (VarT tupTyName) tupTy + + -- Reify t1, ..., Reify t + reifyConstraints = map (\n -> ClassP (mkName "Reify") [VarT n]) tupElemTyNames + + constraints = tupConstraint : reifyConstraints + + let -- '(Exp/Type t1) ... (Exp/Type t)' + elemTys = [ (NotStrict, elemTyCons (VarT t)) + | t <- tupElemTyNames + ] + + return $ ForallC tyVarBinders constraints + $ NormalC (conName width) elemTys + +-- | Generate the types for AST type and term tuple constructors: 'TupleConst' and +-- 'TupleType'. The first parameter is the name of the type. The second parameter +-- is the type constructor for element fields and the third parameter generates +-- the constructor name for a given tuple width. +-- +-- @ +-- data TupleConst a where +-- TupleE :: (Reify t1, ..., Reify t) => Exp t1 +-- -> ... +-- -> Exp t +-- -> TupleConst (t1, ..., t) +-- @ +-- +-- Because TH does not directly support GADT syntax, we have to +-- emulate it using explicit universal quantification: +-- +-- @ +-- data TupleConst a = +-- forall t1, ..., t. a ~ (t1, ..., t), +-- Reify t1, +-- ... +-- Reify t => +-- Exp t1 -> ... -> Exp t +-- @ +mkTupleASTTy :: Name -> (Type -> Type) -> (Int -> Name) -> Int -> Q [Dec] +mkTupleASTTy tyName elemTyCons conName maxWidth = do + tupTyName <- newName "a" + cons <- mapM (mkTupleCons tupTyName conName elemTyCons) [2..maxWidth] + + return $ [DataD [] tyName [PlainTV tupTyName] cons []] + +-- | Generate the 'TupleConst' AST type for tuple term construction +mkAstTupleConst :: Int -> Q [Dec] +mkAstTupleConst maxWidth = + mkTupleASTTy (mkName "TupleConst") expCon innerConst maxWidth + where + expCon = AppT $ ConT $ mkName "Exp" + +-- | Generate the 'TupleConst' AST type for tuple term construction +mkAstTupleType :: Int -> Q [Dec] +mkAstTupleType maxWidth = + mkTupleASTTy (mkName "TupleType") expCon tupTyConstName maxWidth + where + expCon = AppT $ ConT $ mkName "Type" + +mkTupleAstComponents :: Int -> Q [Dec] +mkTupleAstComponents maxWidth = (++) <$> mkAstTupleConst maxWidth <*> mkAstTupleType maxWidth + + + +-------------------------------------------------------------------------------- +-- Helper functions + +-- | The name of the constructor that constructs a tuple construction +-- term. +outerConst :: Name +outerConst = mkName "TupleConstE" + +-- | The name of the constructor for a given tuple width. +innerConst :: Int -> Name +innerConst width = mkName $ printf "Tuple%dE" width + +-- | The name of a tuple access constructor for a given tuple width +-- and element index. +tupAccName :: Int -> Int -> Name +tupAccName width elemIdx = mkName $ printf "Tup%d_%d" width elemIdx + +-- | The name of the tuple type constructor for a given tuple width. +tupTyConstName :: Int -> Name +tupTyConstName width = mkName $ printf "Tuple%dT" width + +-- | +tupleType :: [Type] -> Type +tupleType elemTypes = foldl' AppT (TupleT width) elemTypes + where + width = length elemTypes + +qName :: Name +qName = mkName "Q" + +-- | Construct a DSH term that accesses a specificed tuple element. +mkTupElemTerm :: Int -> Int -> Exp -> Q Exp +mkTupElemTerm width idx arg = do + let ta = ConE $ tupAccName width idx + return $ AppE (AppE (ConE $ mkName "AppE") (AppE (ConE $ mkName "TupElem") ta)) arg + +-- | From a list of operand terms, construct a DSH tuple term. +mkTupConstTerm :: [Exp] -> Q Exp +mkTupConstTerm ts + | length ts <= 16 = return $ AppE (ConE $ mkName "TupleConstE") + $ foldl' AppE (ConE $ innerConst $ length ts) ts + | otherwise = impossible diff --git a/src/Database/DSH/Impossible.hs b/src/Database/DSH/Impossible.hs --- a/src/Database/DSH/Impossible.hs +++ b/src/Database/DSH/Impossible.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -module Database.DSH.Impossible (impossible) where +module Database.DSH.Impossible (impossible, unimplemented) where import qualified Language.Haskell.TH as TH @@ -8,5 +8,12 @@ impossible = do loc <- TH.location let pos = (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc)) - let message = "DSH: Impossbile happend at " ++ show pos + let message = "DSH: Impossible happened at " ++ show pos + return (TH.AppE (TH.VarE 'error) (TH.LitE (TH.StringL message))) + +unimplemented :: TH.ExpQ +unimplemented = do + loc <- TH.location + let pos = (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc)) + let message = "DSH: Unimplemented at " ++ show pos return (TH.AppE (TH.VarE 'error) (TH.LitE (TH.StringL message))) diff --git a/src/Database/DSH/Internals.hs b/src/Database/DSH/Internals.hs deleted file mode 100644 --- a/src/Database/DSH/Internals.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -module Database.DSH.Internals where - -import Data.Text (Text) - -data Exp a where - UnitE :: Exp () - BoolE :: Bool -> Exp Bool - CharE :: Char -> Exp Char - IntegerE :: Integer -> Exp Integer - DoubleE :: Double -> Exp Double - TextE :: Text -> Exp Text - PairE :: (Reify a, Reify b) => Exp a -> Exp b -> Exp (a,b) - ListE :: (Reify a) => [Exp a] -> Exp [a] - AppE :: (Reify a, Reify b) => Fun a b -> Exp a -> Exp b - LamE :: (Reify a, Reify b) => (Exp a -> Exp b) -> Exp (a -> b) - VarE :: (Reify a) => Integer -> Exp a - TableE :: (Reify a) => Table -> Exp [a] - -data Table = TableDB String [[String]] | TableCSV String deriving (Eq, Ord, Show) - -data Type a where - UnitT :: Type () - BoolT :: Type Bool - CharT :: Type Char - IntegerT :: Type Integer - DoubleT :: Type Double - TextT :: Type Text - PairT :: (Reify a,Reify b) => Type a -> Type b -> Type (a,b) - ListT :: (Reify a) => Type a -> Type [a] - ArrowT :: (Reify a,Reify b) => Type a -> Type b -> Type (a -> b) - -data Fun a b where - Not :: Fun Bool Bool - IntegerToDouble :: Fun Integer Double - And :: Fun [Bool] Bool - Or :: Fun [Bool] Bool - Concat :: (Reify a) => Fun [[a]] [a] - Head :: Fun [a] a - Tail :: Fun [a] [a] - Init :: Fun [a] [a] - Last :: Fun [a] a - Null :: Fun [a] Bool - Length :: Fun [a] Integer - Reverse :: Fun [a] [a] - Fst :: Fun (a,b) a - Snd :: Fun (a,b) b - Sum :: Fun [a] a - Maximum :: Fun [a] a - Minimum :: Fun [a] a - Nub :: Fun [a] [a] - Add :: Fun (a,a) a - Mul :: Fun (a,a) a - Sub :: Fun (a,a) a - Div :: Fun (a,a) a - Lt :: Fun (a,a) Bool - Lte :: Fun (a,a) Bool - Equ :: Fun (a,a) Bool - Gte :: Fun (a,a) Bool - Gt :: Fun (a,a) Bool - Conj :: Fun (Bool,Bool) Bool - Disj :: Fun (Bool,Bool) Bool - Min :: Fun (a,a) a - Max :: Fun (a,a) a - Cons :: Fun (a,[a]) [a] - Take :: Fun (Integer,[a]) [a] - Drop :: Fun (Integer,[a]) [a] - Index :: Fun ([a],Integer) a - SplitAt :: Fun (Integer,[a]) ([a],[a]) - Zip :: Fun ([a],[b]) [(a,b)] - Map :: Fun (a -> b,[a]) [b] - Filter :: Fun (a -> Bool,[a]) [a] - GroupWithKey :: Fun (a -> b,[a]) [(b,[a])] - SortWith :: Fun (a -> b,[a]) [a] - TakeWhile :: Fun (a -> Bool,[a]) [a] - DropWhile :: Fun (a -> Bool,[a]) [a] - Cond :: Fun (Bool,(a,a)) a - -newtype Q a = Q (Exp (Rep a)) - --- Classes - -class Reify a where - reify :: a -> Type a - -class (Reify (Rep a)) => QA a where - type Rep a - toExp :: a -> Exp (Rep a) - frExp :: Exp (Rep a) -> a - -class (QA a,QA r) => Elim a r where - type Eliminator a r - elim :: Q a -> Eliminator a r - -class BasicType a where - -class TA a where - -class View a where - type ToView a - view :: a -> ToView a - --- Show instances - -instance Show (Type a) where - show UnitT = "()" - show BoolT = "Bool" - show CharT = "Char" - show IntegerT = "Integer" - show DoubleT = "Double" - show TextT = "Text" - show (PairT l r) = "(" ++ show l ++ ", " ++ show r ++ ")" - show (ListT t) = "[" ++ show t ++ "]" - show (ArrowT t1 t2) = "(" ++ show t1 ++ " -> " ++ show t2 ++ ")" - -instance Show (Fun a b) where - show Fst = "fst" - show Snd = "snd" - show Not = "not" - show Concat = "concat" - show Head = "head" - show Tail = "tail" - show Init = "init" - show Last = "last" - show Null = "null" - show Length = "length" - show Reverse = "reverse" - show And = "and" - show Or = "or" - show Sum = "sum" - show Maximum = "maximum" - show Minimum = "minimum" - show Nub = "nub" - show IntegerToDouble = "integerToDouble" - show Add = "+" - show Mul = "*" - show Sub = "-" - show Div = "/" - show Lt = "<" - show Lte = "<=" - show Equ = "==" - show Gte = ">=" - show Gt = ">" - show Conj = "&&" - show Disj = "||" - show Min = "min" - show Max = "max" - show Cons = "cons" - show Take = "take" - show Drop = "drop" - show Index = "index" - show SplitAt = "splitAt" - show Zip = "zip" - show Map = "map" - show Filter = "filter" - show GroupWithKey = "groupWithKey" - show SortWith = "sortWith" - show TakeWhile = "takeWhile" - show DropWhile = "dropWhile" - show Cond = "cond" - --- Reify instances - -instance Reify () where - reify _ = UnitT - -instance Reify Bool where - reify _ = BoolT - -instance Reify Char where - reify _ = CharT - -instance Reify Integer where - reify _ = IntegerT - -instance Reify Double where - reify _ = DoubleT - -instance Reify Text where - reify _ = TextT - -instance (Reify a, Reify b) => Reify (a,b) where - reify _ = PairT (reify (undefined :: a)) (reify (undefined :: b)) - -instance (Reify a) => Reify [a] where - reify _ = ListT (reify (undefined :: a)) - -instance (Reify a, Reify b) => Reify (a -> b) where - reify _ = ArrowT (reify (undefined :: a)) (reify (undefined :: b)) - --- Utility functions - -unQ :: Q a -> Exp (Rep a) -unQ (Q e) = e - -toLam :: (QA a,QA b) => (Q a -> Q b) -> Exp (Rep a) -> Exp (Rep b) -toLam f = unQ . f . Q diff --git a/src/Database/DSH/Interpreter.hs b/src/Database/DSH/Interpreter.hs deleted file mode 100644 --- a/src/Database/DSH/Interpreter.hs +++ /dev/null @@ -1,382 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - --- | This module provides the reference implementation of DSH by interpreting --- the embedded representation. - -module Database.DSH.Interpreter (fromQ) where - -import Database.DSH.Internals -import Database.DSH.Impossible -import Database.DSH.CSV - -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Database.HDBC -import Data.List - -fromQ :: (QA a, IConnection conn) => conn -> Q a -> IO a -fromQ c (Q e) = fmap frExp (evaluate c e) - -evaluate :: forall a conn. (Reify a, IConnection conn) => conn -> Exp a -> IO (Exp a) -evaluate c e = case e of - UnitE -> return UnitE - BoolE b -> return $ BoolE b - CharE ch -> return $ CharE ch - IntegerE i -> return $ IntegerE i - DoubleE d -> return $ DoubleE d - TextE t -> return $ TextE t - VarE _ -> $impossible - LamE _ -> $impossible - PairE e1 e2 -> do - e1' <- evaluate c e1 - e2' <- evaluate c e2 - return (PairE e1' e2') - ListE es -> do - es1 <- mapM (evaluate c) es - return $ ListE es1 - AppE Cond (PairE cond (PairE a b)) -> do - (BoolE c1) <- evaluate c cond - if c1 then evaluate c a else evaluate c b - AppE Cons (PairE a as) -> do - a1 <- evaluate c a - (ListE as1) <- evaluate c as - return $ ListE (a1 : as1) - AppE Head as -> do - (ListE as1) <- evaluate c as - return $ head as1 - AppE Tail as -> do - (ListE as1) <- evaluate c as - return $ ListE (tail as1) - AppE Take (PairE i as) -> do - (IntegerE i1) <- evaluate c i - (ListE as1) <- evaluate c as - return $ ListE (take (fromIntegral i1) as1) - AppE Drop (PairE i as) -> do - (IntegerE i1) <- evaluate c i - (ListE as1) <- evaluate c as - return $ ListE (drop (fromIntegral i1) as1) - AppE Map (PairE (LamE f) as) -> do - (ListE as1) <- evaluate c as - evaluate c $ ListE (map f as1) - AppE Filter (PairE (LamE f) as) -> do - (ListE as1) <- evaluate c as - (ListE as2) <- evaluate c (ListE (map f as1)) - return $ ListE (map fst (filter (\(_,BoolE b) -> b) (zip as1 as2))) - AppE GroupWithKey (PairE (LamE f) as) -> do - (ListE as1) <- evaluate c as - (ListE ks1) <- evaluate c (ListE (map f as1)) - return $ ListE - $ map (\kas1 -> PairE (fst (head kas1)) (ListE (map snd kas1))) - $ groupBy (\(k1,_) (k2,_) -> equExp k1 k2) - $ sortBy (\(k1,_) (k2,_) -> compareExp k1 k2) - $ zip ks1 as1 - AppE SortWith (PairE (LamE f) as) -> do - (ListE as1) <- evaluate c as - (ListE as2) <- evaluate c $ ListE (map f as1) - return $ ListE - $ map fst - $ sortBy (\(_,a1) (_,a2) -> compareExp a1 a2) - $ zip as1 as2 - (AppE Max (PairE e1 e2)) -> - case reify (undefined :: a) of - IntegerT -> do (IntegerE v1) <- evaluate c e1 - (IntegerE v2) <- evaluate c e2 - return $ IntegerE (max v1 v2) - DoubleT -> do (DoubleE v1) <- evaluate c e1 - (DoubleE v2) <- evaluate c e2 - return $ DoubleE (max v1 v2) - _ -> $impossible - (AppE Min (PairE e1 e2)) -> - case reify (undefined :: a) of - IntegerT -> do (IntegerE v1) <- evaluate c e1 - (IntegerE v2) <- evaluate c e2 - return $ IntegerE (min v1 v2) - DoubleT -> do (DoubleE v1) <- evaluate c e1 - (DoubleE v2) <- evaluate c e2 - return $ DoubleE (min v1 v2) - _ -> $impossible - AppE Last as -> do - (ListE as1) <- evaluate c as - return $ last as1 - AppE Init as -> do - (ListE as1) <- evaluate c as - return $ ListE (init as1) - AppE Null as -> do - (ListE as1) <- evaluate c as - return $ BoolE (null as1) - AppE Length as -> do - (ListE as1) <- evaluate c as - return $ IntegerE (fromIntegral $ length as1) - AppE Index (PairE as i) -> do - (IntegerE i1) <- evaluate c i - (ListE as1) <- evaluate c as - return $ as1 !! fromIntegral i1 - AppE Reverse as -> do - (ListE as1) <- evaluate c as - return $ ListE (reverse as1) - AppE And as -> do - (ListE as1) <- evaluate c as - return $ BoolE (all (\(BoolE b) -> b) as1) - AppE Or as -> do - (ListE as1) <- evaluate c as - return $ BoolE (any (\(BoolE b) -> b) as1) - (AppE Sum as) -> do - let ty = reify (undefined :: a) - (ListE as1) <- evaluate c as - case ty of - IntegerT -> return $ IntegerE (sum $ map (\(IntegerE i) -> i) as1) - DoubleT -> return $ DoubleE (sum $ map (\(DoubleE d) -> d) as1) - _ -> $impossible - AppE Concat as -> do - (ListE as1) <- evaluate c as - return $ ListE (concatMap (\(ListE as2) -> as2) as1) - AppE Maximum as -> do - (ListE as1) <- evaluate c as - return $ maximumBy compareExp as1 - AppE Minimum as -> do - (ListE as1) <- evaluate c as - return $ minimumBy compareExp as1 - AppE SplitAt (PairE i as) -> do - (IntegerE i1) <- evaluate c i - (ListE as1) <- evaluate c as - let r = splitAt (fromIntegral i1) as1 - return $ PairE (ListE (fst r)) (ListE (snd r)) - AppE TakeWhile (PairE (LamE f) as) -> do - (ListE as1) <- evaluate c as - (ListE as2) <- evaluate c (ListE (map f as1)) - return $ ListE (map fst $ takeWhile (\(_,BoolE b) -> b) $ zip as1 as2) - AppE DropWhile (PairE (LamE f) as) -> do - (ListE as1) <- evaluate c as - (ListE as2) <- evaluate c (ListE (map f as1)) - return $ ListE (map fst $ dropWhile (\(_,BoolE b) -> b) $ zip as1 as2) - AppE Zip (PairE as bs) -> do - (ListE as1) <- evaluate c as - (ListE bs1) <- evaluate c bs - return $ ListE (zipWith PairE as1 bs1) - AppE Nub as -> do - (ListE as1) <- evaluate c as - return $ ListE (nubBy equExp as1) - AppE Fst a -> do - (PairE a1 _) <- evaluate c a - return a1 - AppE Snd a -> do - (PairE _ a1) <- evaluate c a - return a1 - (AppE Add (PairE e1 e2)) -> do - let ty = reify (undefined :: a) - case ty of - IntegerT -> do - (IntegerE i1) <- evaluate c e1 - (IntegerE i2) <- evaluate c e2 - return $ IntegerE (i1 + i2) - DoubleT -> do - (DoubleE d1) <- evaluate c e1 - (DoubleE d2) <- evaluate c e2 - return $ DoubleE (d1 + d2) - _ -> $impossible - (AppE Sub (PairE e1 e2)) -> do - let ty = reify (undefined :: a) - case ty of - IntegerT -> do - (IntegerE i1) <- evaluate c e1 - (IntegerE i2) <- evaluate c e2 - return $ IntegerE (i1 - i2) - DoubleT -> do - (DoubleE d1) <- evaluate c e1 - (DoubleE d2) <- evaluate c e2 - return $ DoubleE (d1 - d2) - _ -> $impossible - (AppE Mul (PairE e1 e2)) -> do - let ty = reify (undefined :: a) - case ty of - IntegerT -> do - (IntegerE i1) <- evaluate c e1 - (IntegerE i2) <- evaluate c e2 - return $ IntegerE (i1 * i2) - DoubleT -> do - (DoubleE d1) <- evaluate c e1 - (DoubleE d2) <- evaluate c e2 - return $ DoubleE (d1 * d2) - _ -> $impossible - (AppE Div (PairE e1 e2)) -> do - let ty = reify (undefined :: a) - case ty of - DoubleT -> do - (DoubleE d1) <- evaluate c e1 - (DoubleE d2) <- evaluate c e2 - return $ DoubleE (d1 / d2) - _ -> $impossible - AppE IntegerToDouble e1 -> do - (IntegerE i1) <- evaluate c e1 - return $ DoubleE (fromInteger i1) - AppE Equ (PairE e1 e2) -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolE $ equExp e3 e4 - AppE Lt (PairE e1 e2) -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolE $ ltExp e3 e4 - AppE Lte (PairE e1 e2) -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolE $ lteExp e3 e4 - AppE Gte (PairE e1 e2) -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolE $ gteExp e3 e4 - AppE Gt (PairE e1 e2) -> do - e3 <- evaluate c e1 - e4 <- evaluate c e2 - return $ BoolE $ gtExp e3 e4 - AppE Not e1 -> do - (BoolE b1) <- evaluate c e1 - return $ BoolE (not b1) - AppE Conj (PairE e1 e2) -> do - (BoolE b1) <- evaluate c e1 - (BoolE b2) <- evaluate c e2 - return $ BoolE (b1 && b2) - AppE Disj (PairE e1 e2) -> do - (BoolE b1) <- evaluate c e1 - (BoolE b2) <- evaluate c e2 - return $ BoolE (b1 || b2) - (TableE (TableDB tName _)) -> - let ty = reify (undefined :: a) - in case ty of - ListT tType -> do - tDesc <- describeTable c (escape tName) - let columnNames = intercalate " , " $ map (\s -> "\"" ++ s ++ "\"") $ sort $ map fst tDesc - let query = "SELECT " ++ columnNames ++ " FROM " ++ "\"" ++ escape tName ++ "\"" - -- print query - fmap (sqlToExpWithType (escape tName) tType) (quickQuery c query []) - _ -> $impossible - (TableE (TableCSV filename)) -> csvImport filename (reify (undefined :: a)) - _ -> $impossible - -compareExp :: Exp a -> Exp a -> Ordering -compareExp UnitE UnitE = EQ -compareExp (BoolE v1) (BoolE v2) = compare v1 v2 -compareExp (CharE v1) (CharE v2) = compare v1 v2 -compareExp (IntegerE v1) (IntegerE v2) = compare v1 v2 -compareExp (DoubleE v1) (DoubleE v2) = compare v1 v2 -compareExp (TextE v1) (TextE v2) = compare v1 v2 -compareExp (PairE a1 b1) (PairE a2 b2) = case compareExp a1 a2 of - EQ -> compareExp b1 b2 - LT -> LT - GT -> GT -compareExp (ListE []) (ListE []) = EQ -compareExp (ListE (_ : _)) (ListE []) = GT -compareExp (ListE []) (ListE (_ : _)) = LT -compareExp (ListE (a : as)) (ListE (b : bs)) = case compareExp a b of - EQ -> compareExp (ListE as) (ListE bs) - LT -> LT - GT -> GT -compareExp _ _ = $impossible - -equExp :: Exp a -> Exp a -> Bool -equExp a b = case compareExp a b of - EQ -> True - _ -> False - -ltExp :: Exp a -> Exp a -> Bool -ltExp a b = case compareExp a b of - LT -> True - _ -> False - -lteExp :: Exp a -> Exp a -> Bool -lteExp a b = case compareExp a b of - GT -> False - _ -> True - -gteExp :: Exp a -> Exp a -> Bool -gteExp a b = case compareExp a b of - LT -> False - _ -> True - -gtExp :: Exp a -> Exp a -> Bool -gtExp a b = case compareExp a b of - GT -> True - _ -> False - -escape :: String -> String -escape [] = [] -escape (c : cs) | c == '"' = '\\' : '"' : escape cs -escape (c : cs) = c : escape cs - --- | Read SQL values into 'Norm' values -sqlToExpWithType :: (Reify a) - => String -- ^ Table name, used to generate more informative error messages - -> Type a - -> [[SqlValue]] - -> Exp [a] -sqlToExpWithType tName ty = ListE . map (sqlValueToNorm ty) - where - sqlValueToNorm :: Type a -> [SqlValue] -> Exp a - sqlValueToNorm (PairT t1 t2) s = let v1 = sqlValueToNorm t1 $ take (sizeOfType t1) s - v2 = sqlValueToNorm t2 $ drop (sizeOfType t1) s - in PairE v1 v2 - -- On a single value, just compare the 'Type' and convert the 'SqlValue' to - -- a Norm value on match - sqlValueToNorm t [s] = if t `typeMatch` s - then convert s t - else typeError t [s] - -- Everything else will raise an error - sqlValueToNorm t s = typeError t s - - typeError :: Type a -> [SqlValue] -> b - typeError t s = error $ - "ferry: Type mismatch on table \"" ++ tName ++ "\":" - ++ "\n\tExpected table type: " ++ show t - ++ "\n\tTable entry: " ++ show s - -convert :: SqlValue -> Type a -> Exp a -convert SqlNull UnitT = UnitE -convert (SqlInteger i) IntegerT = IntegerE i -convert (SqlInt32 i) IntegerT = IntegerE $ fromIntegral i -convert (SqlInt64 i) IntegerT = IntegerE $ fromIntegral i -convert (SqlWord32 i) IntegerT = IntegerE $ fromIntegral i -convert (SqlWord64 i) IntegerT = IntegerE $ fromIntegral i -convert (SqlDouble d) DoubleT = DoubleE d -convert (SqlRational d) DoubleT = DoubleE $ fromRational d -convert (SqlInteger d) DoubleT = DoubleE $ fromIntegral d -convert (SqlInt32 d) DoubleT = DoubleE $ fromIntegral d -convert (SqlInt64 d) DoubleT = DoubleE $ fromIntegral d -convert (SqlWord32 d) DoubleT = DoubleE $ fromIntegral d -convert (SqlWord64 d) DoubleT = DoubleE $ fromIntegral d -convert (SqlBool b) BoolT = BoolE b -convert (SqlInteger i) BoolT = BoolE (i /= 0) -convert (SqlInt32 i) BoolT = BoolE (i /= 0) -convert (SqlInt64 i) BoolT = BoolE (i /= 0) -convert (SqlWord32 i) BoolT = BoolE (i /= 0) -convert (SqlWord64 i) BoolT = BoolE (i /= 0) -convert (SqlChar c) CharT = CharE c -convert (SqlString (c:_)) CharT = CharE c -convert (SqlByteString c) CharT = CharE (head $ T.unpack $ T.decodeUtf8 c) -convert (SqlString t) TextT = TextE (T.pack t) -convert (SqlByteString s) TextT = TextE (T.decodeUtf8 s) -convert sql _ = error $ "Unsupported SqlValue: " ++ show sql - -sizeOfType :: Type a -> Int -sizeOfType UnitT = 1 -sizeOfType IntegerT = 1 -sizeOfType DoubleT = 1 -sizeOfType BoolT = 1 -sizeOfType CharT = 1 -sizeOfType TextT = 1 -sizeOfType (PairT t1 t2) = sizeOfType t1 + sizeOfType t2 -sizeOfType _ = error "sizeOfType: Not a record type" - --- | Check if a 'SqlValue' matches a 'Type' -typeMatch :: Type a -> SqlValue -> Bool -typeMatch t s = - case (t,s) of - (UnitT , SqlNull) -> True - (IntegerT , SqlInteger _) -> True - (DoubleT , SqlDouble _) -> True - (BoolT , SqlBool _) -> True - (CharT , SqlChar _) -> True - (TextT , SqlString _) -> True - (TextT , SqlByteString _) -> True - _ -> False diff --git a/src/Database/DSH/NKL/Kure.hs b/src/Database/DSH/NKL/Kure.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/NKL/Kure.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE InstanceSigs #-} + +-- | Infrastructure for KURE-based rewrites on NKL expressions +module Database.DSH.NKL.Kure + ( -- * Re-export relevant KURE modules + module Language.KURE + , module Language.KURE.Lens + + -- * The KURE monad + , RewriteM, RewriteStateM, TransformN, RewriteN, LensN, freshNameT + + -- * Setters and getters for the translation state + , get, put, modify + + -- * Changing between stateful and non-stateful transforms + , statefulT, liftstateT + + -- * The KURE context + , NestedCtx(..), CrumbN(..), PathN, initialCtx, freeIn, boundIn + , inScopeNames, bindVar + + -- * Congruence combinators + , tableT, appe1T, appe2T, binopT, ifT, constExprT, varT, iteratorT, letT + , tableR, appe1R, appe2R, binopR, ifR, litR, varR, iteratorR, letR + + ) where + + +import Control.Monad +import Data.Monoid + +import Language.KURE +import Language.KURE.Lens + +import Database.DSH.Common.RewriteM +import Database.DSH.Common.Lang +import Database.DSH.Common.Type +import Database.DSH.NKL.Lang + +-------------------------------------------------------------------------------- +-- Convenience type aliases + +type TransformN a b = Transform NestedCtx (RewriteM Int) a b +type RewriteN a = TransformN a a +type LensN a b = Lens NestedCtx (RewriteM Int) a b + +-------------------------------------------------------------------------------- + +data CrumbN = IteratorHead + | IteratorSource + | AppE1Arg + | AppE2Arg1 + | AppE2Arg2 + | BinOpArg1 + | BinOpArg2 + | UnOpArg + | LamBody + | IfCond + | IfThen + | IfElse + | LetBind + | LetBody + | TupleElem Int + deriving (Eq, Show) + +type AbsPathN = AbsolutePath CrumbN + +type PathN = Path CrumbN + +-- | The context for KURE-based NKL rewrites +data NestedCtx = NestedCtx { nkl_bindings :: [Ident] + , nkl_path :: AbsPathN + } + +instance ExtendPath NestedCtx CrumbN where + c@@n = c { nkl_path = nkl_path c @@ n } + +instance ReadPath NestedCtx CrumbN where + absPath c = nkl_path c + +initialCtx :: [Ident] -> NestedCtx +initialCtx nameCtx = NestedCtx { nkl_bindings = nameCtx, nkl_path = mempty } + +-- | Record a variable binding in the context +bindVar :: Ident -> NestedCtx -> NestedCtx +bindVar n ctx = ctx { nkl_bindings = n : nkl_bindings ctx } + +inScopeNames :: NestedCtx -> [Ident] +inScopeNames = nkl_bindings + +boundIn :: Ident -> NestedCtx -> Bool +boundIn n ctx = n `elem` (nkl_bindings ctx) + +freeIn :: Ident -> NestedCtx -> Bool +freeIn n ctx = n `notElem` (nkl_bindings ctx) + +-- | Generate a fresh name that is not bound in the current context. +freshNameT :: [Ident] -> TransformN a Ident +freshNameT avoidNames = do + ctx <- contextT + constT $ freshName (avoidNames ++ inScopeNames ctx) + +-------------------------------------------------------------------------------- +-- Support for stateful transforms + +-- | Run a stateful transform with an initial state and turn it into a regular +-- (non-stateful) transform +statefulT :: s -> Transform NestedCtx (RewriteStateM s) a b -> TransformN a (s, b) +statefulT s t = resultT (stateful s) t + +-- | Turn a regular rewrite into a stateful rewrite +liftstateT :: Transform NestedCtx (RewriteM Int) a b -> Transform NestedCtx (RewriteStateM s) a b +liftstateT t = resultT liftstate t + +-------------------------------------------------------------------------------- +-- Congruence combinators for CL expressions + +tableT :: Monad m => (Type -> String -> [Column] -> TableHints -> b) + -> Transform NestedCtx m Expr b +tableT f = contextfreeT $ \expr -> case expr of + Table ty n cs ks -> return $ f ty n cs ks + _ -> fail "not a table node" +{-# INLINE tableT #-} + +tableR :: Monad m => Rewrite NestedCtx m Expr +tableR = tableT Table +{-# INLINE tableR #-} + +iteratorT :: Monad m => Transform NestedCtx m Expr a1 + -> Transform NestedCtx m Expr a2 + -> (Type -> a1 -> Ident -> a2 -> b) + -> Transform NestedCtx m Expr b +iteratorT t1 t2 f = transform $ \c expr -> case expr of + Iterator ty h x xs -> f ty <$> applyT t1 (c@@IteratorHead) h + <*> return x + <*> applyT t2 (c@@IteratorSource) xs + _ -> fail "not an iterator node" +{-# INLINE iteratorT #-} + +iteratorR :: Monad m => Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr +iteratorR t1 t2 = iteratorT t1 t2 Iterator +{-# INLINE iteratorR #-} + +appe1T :: Monad m => Transform NestedCtx m Expr a + -> (Type -> Prim1 -> a -> b) + -> Transform NestedCtx m Expr b +appe1T t f = transform $ \c expr -> case expr of + AppE1 ty p e -> f ty p <$> applyT t (c@@AppE1Arg) e + _ -> fail "not a unary primitive application" +{-# INLINE appe1T #-} + +appe1R :: Monad m => Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr +appe1R t = appe1T t AppE1 +{-# INLINE appe1R #-} + +appe2T :: Monad m => Transform NestedCtx m Expr a1 + -> Transform NestedCtx m Expr a2 + -> (Type -> Prim2 -> a1 -> a2 -> b) + -> Transform NestedCtx m Expr b +appe2T t1 t2 f = transform $ \c expr -> case expr of + AppE2 ty p e1 e2 -> f ty p <$> applyT t1 (c@@AppE2Arg1) e1 + <*> applyT t2 (c@@AppE2Arg2) e2 + _ -> fail "not a binary primitive application" +{-# INLINE appe2T #-} + +appe2R :: Monad m => Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr +appe2R t1 t2 = appe2T t1 t2 AppE2 +{-# INLINE appe2R #-} + +binopT :: Monad m => Transform NestedCtx m Expr a1 + -> Transform NestedCtx m Expr a2 + -> (Type -> ScalarBinOp -> a1 -> a2 -> b) + -> Transform NestedCtx m Expr b +binopT t1 t2 f = transform $ \c expr -> case expr of + BinOp ty op e1 e2 -> f ty op <$> applyT t1 (c@@BinOpArg1) e1 + <*> applyT t2 (c@@BinOpArg2) e2 + _ -> fail "not a binary operator application" +{-# INLINE binopT #-} + +binopR :: Monad m => Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr +binopR t1 t2 = binopT t1 t2 BinOp +{-# INLINE binopR #-} + +unopT :: Monad m => Transform NestedCtx m Expr a + -> (Type -> ScalarUnOp -> a -> b) + -> Transform NestedCtx m Expr b +unopT t f = transform $ \ctx expr -> case expr of + UnOp ty op e -> f ty op <$> applyT t (ctx@@UnOpArg) e + _ -> fail "not an unary operator application" +{-# INLINE unopT #-} + +unopR :: Monad m => Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr +unopR t = unopT t UnOp +{-# INLINE unopR #-} + +ifT :: Monad m => Transform NestedCtx m Expr a1 + -> Transform NestedCtx m Expr a2 + -> Transform NestedCtx m Expr a3 + -> (Type -> a1 -> a2 -> a3 -> b) + -> Transform NestedCtx m Expr b +ifT t1 t2 t3 f = transform $ \c expr -> case expr of + If ty e1 e2 e3 -> f ty <$> applyT t1 (c@@IfCond) e1 + <*> applyT t2 (c@@IfThen) e2 + <*> applyT t3 (c@@IfElse) e3 + _ -> fail "not an if expression" +{-# INLINE ifT #-} + +ifR :: Monad m => Rewrite NestedCtx m Expr + -> Rewrite NestedCtx m Expr + -> Rewrite NestedCtx m Expr + -> Rewrite NestedCtx m Expr +ifR t1 t2 t3 = ifT t1 t2 t3 If +{-# INLINE ifR #-} + +constExprT :: Monad m => (Type -> Val -> b) -> Transform NestedCtx m Expr b +constExprT f = contextfreeT $ \expr -> case expr of + Const ty v -> return $ f ty v + _ -> fail "not a constant" +{-# INLINE constExprT #-} + +litR :: Monad m => Rewrite NestedCtx m Expr +litR = constExprT Const +{-# INLINE litR #-} + +varT :: Monad m => (Type -> Ident -> b) -> Transform NestedCtx m Expr b +varT f = contextfreeT $ \expr -> case expr of + Var ty n -> return $ f ty n + _ -> fail "not a variable" +{-# INLINE varT #-} + +varR :: Monad m => Rewrite NestedCtx m Expr +varR = varT Var +{-# INLINE varR #-} + +letT :: Monad m => Transform NestedCtx m Expr a1 + -> Transform NestedCtx m Expr a2 + -> (Type -> Ident -> a1 -> a2 -> b) + -> Transform NestedCtx m Expr b +letT t1 t2 f = transform $ \c expr -> case expr of + Let ty x xs e -> f ty x <$> applyT t1 (c@@LetBind) xs + <*> applyT t2 (bindVar x $ c@@LetBody) e + _ -> fail "not a let expression" + +letR :: Monad m => Rewrite NestedCtx m Expr + -> Rewrite NestedCtx m Expr + -> Rewrite NestedCtx m Expr +letR r1 r2 = letT r1 r2 Let + +mkTupleT :: Monad m => Transform NestedCtx m Expr a + -> (Type -> [a] -> b) + -> Transform NestedCtx m Expr b +mkTupleT t f = transform $ \c expr -> case expr of + MkTuple ty es -> f ty <$> zipWithM (\e i -> applyT t (c@@TupleElem i) e) es [1..] + _ -> fail "not a tuple constructor" +{-# INLINE mkTupleT #-} + +mkTupleR :: Monad m => Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr +mkTupleR r = mkTupleT r MkTuple + + +-------------------------------------------------------------------------------- + +instance Walker NestedCtx Expr where + allR :: forall m. MonadCatch m => Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr + allR r = readerT $ \e -> case e of + Table{} -> idR + AppE1{} -> appe1R (extractR r) + AppE2{} -> appe2R (extractR r) (extractR r) + BinOp{} -> binopR (extractR r) (extractR r) + UnOp{} -> unopR (extractR r) + Iterator{} -> iteratorR (extractR r) (extractR r) + If{} -> ifR (extractR r) (extractR r) (extractR r) + Const{} -> idR + Var{} -> idR + Let{} -> letR (extractR r) (extractR r) + MkTuple{} -> mkTupleR (extractR r) + +-------------------------------------------------------------------------------- +-- I find it annoying that Applicative is not a superclass of Monad. + +(<$>) :: Monad m => (a -> b) -> m a -> m b +(<$>) = liftM +{-# INLINE (<$>) #-} + +(<*>) :: Monad m => m (a -> b) -> m a -> m b +(<*>) = ap +{-# INLINE (<*>) #-} + diff --git a/src/Database/DSH/NKL/Lang.hs b/src/Database/DSH/NKL/Lang.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/NKL/Lang.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.NKL.Lang + ( Expr(..) + , Typed(..) + , Prim1(..) + , Prim2(..) + ) where + +import Text.PrettyPrint.ANSI.Leijen +import Text.Printf + +import Database.DSH.Impossible +import qualified Database.DSH.Common.Lang as L +import Database.DSH.Common.Pretty +import Database.DSH.Common.Nat +import Database.DSH.Common.Type (Type, Typed, typeOf) + +-- | Nested Kernel Language (NKL) expressions +data Expr = Table Type String [L.Column] L.TableHints + | AppE1 Type Prim1 Expr + | AppE2 Type Prim2 Expr Expr + | BinOp Type L.ScalarBinOp Expr Expr + | UnOp Type L.ScalarUnOp Expr + | If Type Expr Expr Expr + | Const Type L.Val + | Var Type L.Ident + | Iterator Type Expr L.Ident Expr + | Let Type L.Ident Expr Expr + | MkTuple Type [Expr] + deriving (Show) + +instance Typed Expr where + typeOf (Table t _ _ _) = t + typeOf (AppE1 t _ _) = t + typeOf (AppE2 t _ _ _) = t + typeOf (If t _ _ _) = t + typeOf (BinOp t _ _ _) = t + typeOf (UnOp t _ _) = t + typeOf (Const t _) = t + typeOf (Var t _) = t + typeOf (Iterator t _ _ _) = t + typeOf (Let t _ _ _) = t + typeOf (MkTuple t _) = t + +instance Pretty Expr where + pretty (MkTuple _ es) = tupled $ map pretty es + pretty (AppE1 _ (TupElem n) e1) = + parenthize e1 <> dot <> int (tupleIndex n) + pretty (Table _ n _ _) = text "table" <> parens (text n) + pretty (AppE1 _ p1 e) = (text $ show p1) <+> (parenthize e) + pretty (AppE2 _ p1 e1 e2) = (text $ show p1) <+> (align $ (parenthize e1) (parenthize e2)) + pretty (BinOp _ o e1 e2) = (parenthize e1) <+> (pretty o) <+> (parenthize e2) + pretty (UnOp _ o e) = text (show o) <> parens (pretty e) + pretty (If _ c t e) = text "if" + <+> pretty c + <+> text "then" + <+> (parenthize t) + <+> text "else" + <+> (parenthize e) + pretty (Const _ v) = pretty v + pretty (Var _ s) = text s + pretty (Iterator _ e x xs) = align + $ brackets + $ enclose (char ' ') (char ' ') + $ pretty e char '|' <+> text x <+> text "<-" <+> pretty xs + pretty (Let _ x e1 e) = + align $ text "let" <+> text x <+> char '=' <+> pretty e1 + + text "in" <+> pretty e + +parenthize :: Expr -> Doc +parenthize e = + case e of + Var _ _ -> pretty e + Const _ _ -> pretty e + Table _ _ _ _ -> pretty e + Iterator _ _ _ _ -> pretty e + AppE1 _ (TupElem _) _ -> pretty e + _ -> parens $ pretty e + +data Prim1 = Singleton + | Length + | Concat + | Sum + | Avg + | The + | Head + | Tail + | Minimum + | Maximum + | Reverse + | And + | Or + | Init + | Last + | Nub + | Number + | Reshape Integer + | Transpose + | TupElem TupleIndex + deriving (Eq) + +instance Show Prim1 where + show Singleton = "sng" + show Length = "length" + show Concat = "concat" + show Sum = "sum" + show Avg = "avg" + show The = "the" + show Head = "head" + show Minimum = "minimum" + show Maximum = "maximum" + show Tail = "tail" + show Reverse = "reverse" + show And = "and" + show Or = "or" + show Init = "init" + show Last = "last" + show Nub = "nub" + show Number = "number" + show Transpose = "transpose" + show (Reshape n) = printf "reshape(%d)" n + -- tuple access is pretty-printed in a special way + show TupElem{} = $impossible + +data Prim2 = Group + | Sort + | Restrict + | Append + | Index + | Zip + | CartProduct + | NestProduct + | ThetaJoin (L.JoinPredicate L.JoinExpr) + | NestJoin (L.JoinPredicate L.JoinExpr) + | SemiJoin (L.JoinPredicate L.JoinExpr) + | AntiJoin (L.JoinPredicate L.JoinExpr) + deriving (Eq) + +instance Show Prim2 where + show Group = "group" + show Sort = "sort" + show Restrict = "restrict" + show Append = "append" + show Index = "index" + show Zip = "zip" + show CartProduct = "⨯" + show NestProduct = "▽" + show (ThetaJoin p) = printf "⨝_%s" (pp p) + show (NestJoin p) = printf "△_%s" (pp p) + show (SemiJoin p) = printf "⋉_%s" (pp p) + show (AntiJoin p) = printf "▷_%s" (pp p) diff --git a/src/Database/DSH/NKL/Primitives.hs b/src/Database/DSH/NKL/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/NKL/Primitives.hs @@ -0,0 +1,74 @@ +-- | Smart constructors for NKL combinators +module Database.DSH.NKL.Primitives where + +import Prelude hiding (filter, map, concat, concatMap, fst, snd) +import qualified Prelude as P +import Text.Printf + +import Database.DSH.Common.Type +import Database.DSH.Common.Nat +import Database.DSH.Common.Pretty +import Database.DSH.Common.Lang +import Database.DSH.NKL.Lang + +-------------------------------------------------------------------------------- +-- Error reporting + +tyErr :: P.String -> a +tyErr comb = P.error $ printf "NKL.Primitives type error in %s" comb + +tyErrShow :: P.String -> [Type] -> a +tyErrShow comb ts = P.error (printf "NKL.Primitives type error in %s: %s" comb (P.show P.$ P.map pp ts)) + +-------------------------------------------------------------------------------- +-- Smart constructors + +tupElem :: TupleIndex -> Expr -> Expr +tupElem f e = + let t = tupleElemT (typeOf e) f + in AppE1 t (TupElem f) e + +fst :: Expr -> Expr +fst e = tupElem First e + +snd :: Expr -> Expr +snd e = tupElem (Next First) e + +pair :: Expr -> Expr -> Expr +pair a b = tuple [a, b] + +tuple :: [Expr] -> Expr +tuple es = + let ts = P.map typeOf es + rt = TupleT ts + in MkTuple rt es + +sng :: Expr -> Expr +sng x = AppE1 (listT $ typeOf x) Singleton x + +concat :: Expr -> Expr +concat e = let t = typeOf e + in if listDepth t P.> 1 + then AppE1 (unliftType t) Concat e + else tyErrShow "concat" [t] + +restrict :: Expr -> Expr -> Expr +restrict vs bs = let vst@(ListT _) = typeOf vs + in AppE2 vst Restrict vs bs + +sort :: Expr -> Expr -> Expr +sort vs ss = let vst@(ListT _) = typeOf vs + in AppE2 vst Sort vs ss + +-- FIXME type is not correct +group :: Expr -> Expr -> Expr +group vs gs = let vst@(ListT _) = typeOf vs + in AppE2 vst Group vs gs + +let_ :: Ident -> Expr -> Expr -> Expr +let_ x e1 e2 = let t = typeOf e1 in Let t x e1 e2 + +if_ :: Expr -> Expr -> Expr -> Expr +if_ c t e = if BoolT == typeOf c + then If (typeOf t) c t e + else tyErr "if_" diff --git a/src/Database/DSH/NKL/Rewrite.hs b/src/Database/DSH/NKL/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/NKL/Rewrite.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.NKL.Rewrite + ( substR + , subst + , freeVars + , boundVars + , optimizeNKL + ) where + +import Control.Arrow +import Data.List +import Data.Monoid + +import Database.DSH.Impossible +import Database.DSH.Common.Type +import Database.DSH.Common.Lang +import Database.DSH.Common.Kure +import Database.DSH.Common.RewriteM +import Database.DSH.NKL.Kure +import Database.DSH.NKL.Lang + +-- | Run a translate on an expression without context +applyExpr :: [Ident] -> TransformN Expr b -> Expr -> Either String b +applyExpr nameCtx f e = runRewriteM $ applyT f (initialCtx nameCtx) (inject e) + +-------------------------------------------------------------------------------- +-- Computation of free and bound variables + +freeVarsT :: TransformN Expr [Ident] +freeVarsT = fmap nub $ crushbuT $ do (ctx, Var _ v) <- exposeT + guardM (v `freeIn` ctx) + return [v] + +-- | Compute free variables of the given expression +freeVars :: Expr -> [Ident] +freeVars = either error id . applyExpr [] freeVarsT + +boundVarsT :: TransformN Expr [Ident] +boundVarsT = fmap nub $ crushbuT $ readerT $ \expr -> case expr of + Iterator _ _ v _ -> return [v] + Let _ v _ _ -> return [v] + _ -> return [] + +-- | Compute all names that are bound in the given expression. Note +-- that the only binding forms in NKL are comprehensions or 'let' +-- bindings. +boundVars :: Expr -> [Ident] +boundVars = either error id . applyExpr [] boundVarsT + +-------------------------------------------------------------------------------- +-- Substitution + +subst :: [Ident] -> Ident -> Expr -> Expr -> Expr +subst nameCtx x s e = either (const e) id $ applyExpr nameCtx (substR x s) e + +alphaCompR :: [Ident] -> RewriteN Expr +alphaCompR avoidNames = do + Iterator compTy h x _ <- idR + x' <- freshNameT (x : freeVars h ++ avoidNames) + let varTy = elemT compTy + iteratorT (tryR $ substR x (Var varTy x')) + idR + (\_ h' _ xs' -> Iterator compTy h' x' xs') + +alphaLetR :: [Ident] -> RewriteN Expr +alphaLetR avoidNames = do + Let letTy x e1 e2 <- idR + x' <- freshNameT (x : freeVars e2 ++ avoidNames) + let varTy = typeOf e1 + letT idR (tryR $ substR x (Var varTy x')) (\_ _ e1' e2' -> Let letTy x' e1' e2') + +-- | Replace /all/ references to variable 'v' by expression 's'. +substR :: Ident -> Expr -> RewriteN Expr +substR v s = readerT $ \expr -> case expr of + -- Occurence of the variable to be replaced + Var _ n | n == v -> return s + + -- Some other variable + Var _ _ -> idR + + -- A comprehension which does not shadow v and in which v occurs + -- free in the head. If the comprehension variable occurs free in + -- the substitute, we rename the comprehension to avoid name + -- capturing. + Iterator _ h x _ | x /= v && v `elem` freeVars h -> + if x `elem` freeVars s + then alphaCompR (freeVars s) >>> substR v s + else anyR $ substR v s + + -- A comprehension whose generator shadows v -> don't descend into the head + Iterator _ _ x _ | v == x -> iteratorR idR (substR v s) + + Let _ x _ e2 | x /= v && v `elem` freeVars e2 -> + if x `elem` freeVars s + then alphaLetR (freeVars s) >>> substR v s + else anyR $ substR v s + + -- A let binding which shadows v -> don't descend into the body + Let _ x _ _ | v == x -> letR (substR v s) idR + _ -> anyR $ substR v s + +-------------------------------------------------------------------------------- +-- Simple optimizations + +-- | This function inlines let-bound expressions. In contrast to +-- general substitution, we do not inline into comprehensions, even if +-- we could. The reason is that expressions should not be evaluated +-- iteratively if they are loop-invariant. +inlineBindingR :: Ident -> Expr -> RewriteN Expr +inlineBindingR v s = readerT $ \expr -> case expr of + -- Occurence of the variable to be replaced + Var _ n | n == v -> return $ inject s + + -- If a let-binding shadows the name we substitute, only descend + -- into the bound expression. + Let _ n _ _ | n == v -> promoteR $ letR idR (extractR $ inlineBindingR v s) + Let _ n _ _ | otherwise -> + if n `elem` freeVars s + -- If the let-bound name occurs free in the substitute, + -- alpha-convert the binding to avoid capturing the name. + then $unimplemented >>> anyR (inlineBindingR v s) + else anyR $ inlineBindingR v s + + -- We don't inline into comprehensions to avoid conflicts with + -- loop-invariant extraction. + Iterator _ _ _ _ -> idR + _ -> anyR $ inlineBindingR v s + +pattern ConcatP t xs <- AppE1 t Concat xs +pattern SingletonP e <- AppE1 _ Singleton e + +-- concatMap (\x -> [e x]) xs +-- concat [ [ e x ] | x <- xs ] +-- => +-- [ e x | x <- xs ] +singletonHeadR :: RewriteN Expr +singletonHeadR = do + ConcatP t (Iterator _ (SingletonP e) x xs) <- idR + return $ Iterator t e x xs + +-- | Count all occurences of an identifier for let-inlining. +countVarRefT :: Ident -> TransformN Expr (Sum Int) +countVarRefT v = readerT $ \expr -> case expr of + -- Occurence of the variable to be replaced + Var _ n | n == v -> return 1 + Var _ _ | otherwise -> return 0 + + Let _ n _ _ | n == v -> letT (constT $ return 0) + (countVarRefT v) + (\_ _ c1 c2 -> c1 + c2) + Let _ _ _ _ | otherwise -> letT (countVarRefT v) + (countVarRefT v) + (\_ _ c1 c2 -> c1 + c2) + + Iterator _ _ x _ | v == x -> iteratorT (constT $ return 0) + (countVarRefT v) + (\_ c1 _ c2 -> c1 + c2) + Iterator _ _ _ _ | otherwise -> iteratorT (countVarRefT v) + (countVarRefT v) + (\_ c1 _ c2 -> c1 + c2) + + Table{} -> return 0 + Const{} -> return 0 + _ -> allT (countVarRefT v) + +-- | Remove a let-binding that is not referenced. +unusedBindingR :: RewriteN Expr +unusedBindingR = do + Let _ x _ e2 <- idR + 0 <- childT LetBody $ countVarRefT x + return $ e2 + +-- | Inline a let-binding that is only referenced once. +referencedOnceR :: RewriteN Expr +referencedOnceR = do + Let _ x e1 _ <- idR + 1 <- childT LetBody $ countVarRefT x + + -- We do not inline into comprehensions, but 'countVarRef' counts + -- all occurences including those in comprehensions. For this + -- reason, we check if the occurence was actually eliminated by + -- inlining and fail otherwise. + body' <- childT LetBody (inlineBindingR x e1) + 0 <- (constT $ return body') >>> countVarRefT x + return body' + +simpleExpr :: Expr -> Bool +simpleExpr Table{} = True +simpleExpr Var{} = True +simpleExpr _ = False + +-- | Inline a let-binding that binds a simple expression. +simpleBindingR :: RewriteN Expr +simpleBindingR = do + Let _ x e1 _ <- idR + guardM $ simpleExpr e1 + childT LetBody $ substR x e1 + +nklOptimizations :: RewriteN Expr +nklOptimizations = anybuR $ singletonHeadR + <+ unusedBindingR + <+ referencedOnceR + <+ simpleBindingR + +optimizeNKL :: Expr -> Expr +optimizeNKL expr = debugOpt "NKL" expr optimizedExpr + where + optimizedExpr = applyExpr [] nklOptimizations expr + diff --git a/src/Database/DSH/Optimizer/Common/Auxiliary.hs b/src/Database/DSH/Optimizer/Common/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/Common/Auxiliary.hs @@ -0,0 +1,11 @@ +module Database.DSH.Optimizer.Common.Auxiliary where + +import qualified Data.IntMap as M + +-- | Perform a map lookup and fail with the given error string if the key +-- is not present +lookupUnsafe :: Show a => M.IntMap a -> String -> Int -> a +lookupUnsafe m s u = + case M.lookup u m of + Just p -> p + Nothing -> error $ s ++ " " ++ (show u) ++ " in " ++ (show m) diff --git a/src/Database/DSH/Optimizer/Common/Rewrite.hs b/src/Database/DSH/Optimizer/Common/Rewrite.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/Common/Rewrite.hs @@ -0,0 +1,74 @@ +module Database.DSH.Optimizer.Common.Rewrite + ( module Database.Algebra.Rewrite.Match + , module Database.Algebra.Rewrite.PatternConstruction + , module Database.Algebra.Rewrite.Properties + , module Database.Algebra.Rewrite.Rule + , module Database.Algebra.Rewrite.Traversal + , replaceRoot + , replaceWithNew + , replace + , R.Rewrite + , R.runRewrite + , R.initRewriteState + , R.Log + , R.logGeneral + , R.logRewrite + , R.parents + , R.topsort + , R.operator + , R.rootNodes + , R.exposeDag + , R.getExtras + , R.condRewrite + , R.updateExtras + , R.insert + , R.insertNoShare + , R.replaceChild + , R.infer + , R.collect + ) + +where + +import qualified Database.Algebra.Dag as D +import Database.Algebra.Dag.Common +import qualified Database.Algebra.Rewrite.DagRewrite as R +import Database.Algebra.Rewrite.Match +import Database.Algebra.Rewrite.PatternConstruction (dagPatMatch, v) +import Database.Algebra.Rewrite.Properties +import Database.Algebra.Rewrite.Rule +import Database.Algebra.Rewrite.Traversal + +import Database.DSH.Common.QueryPlan +import Database.DSH.VL.Vector + +-------------------------------------------------------------- +-- Versions of rewrite combinators that maintain the Shape +-- description of the query structure. + +-- | Replace a root node while maintaining the query structure +-- information. +replaceRoot :: (DagVector v, D.Operator o) => AlgNode -> AlgNode -> R.Rewrite o (Shape v) () +replaceRoot oldRoot newRoot = do + sh <- R.getExtras + R.updateExtras $ updateShape oldRoot newRoot sh + R.replaceRoot oldRoot newRoot + +-- | Replace a node with a new operator while mainting the query +-- structure information. +replaceWithNew :: (D.Operator o, Show o, DagVector v) + => AlgNode -> o -> R.Rewrite o (Shape v) AlgNode +replaceWithNew oldNode newOp = do + sh <- R.getExtras + newNode <- R.replaceWithNew oldNode newOp + R.updateExtras $ updateShape oldNode newNode sh + return newNode + +-- | Replace a node with another node while maintaining the query +-- structure information. +replace :: (DagVector v, D.Operator o) + => AlgNode -> AlgNode -> R.Rewrite o (Shape v) () +replace oldNode newNode = do + sh <- R.getExtras + R.replace oldNode newNode + R.updateExtras $ updateShape oldNode newNode sh diff --git a/src/Database/DSH/Optimizer/TA/OptimizeTA.hs b/src/Database/DSH/Optimizer/TA/OptimizeTA.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/OptimizeTA.hs @@ -0,0 +1,52 @@ +module Database.DSH.Optimizer.TA.OptimizeTA where + +import qualified Data.IntMap as M + +import qualified Database.Algebra.Dag as Dag + +import Database.Algebra.Table.Lang + +import Database.DSH.Common.QueryPlan +import Database.DSH.VL.Vector + +import Database.DSH.Optimizer.Common.Rewrite + +import Database.DSH.Optimizer.TA.Rewrite.Basic + +{- + +rough plan/first goals: + +merge projections: no properties, leads to basic infrastructure + +prune unreferenced rownums: icols prop + +simplify rownums, e.g. key-based: key prop, maybe fd (not sure if necessary) + +merge sorting criteria into rownums: track sorting criteria + +remove rownums if concrete values not required: use prop, key prop, ? + +-} + +type RewriteClass = Rewrite TableAlgebra (Shape NDVec) Bool + +defaultPipeline :: [RewriteClass] +defaultPipeline = [cleanup] + +runPipeline :: Dag.AlgebraDag TableAlgebra + -> (Shape NDVec) + -> [RewriteClass] + -> Bool + -> (Dag.AlgebraDag TableAlgebra, Log, Shape NDVec) +runPipeline d sh pipeline debug = (d', rewriteLog, sh') + where (d', sh', _, rewriteLog) = runRewrite (sequence_ pipeline) d sh debug + +optimizeTA :: QueryPlan TableAlgebra NDVec -> QueryPlan TableAlgebra NDVec +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/Optimizer/TA/Properties/Auxiliary.hs b/src/Database/DSH/Optimizer/TA/Properties/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Auxiliary.hs @@ -0,0 +1,73 @@ +-- | Some auxiliary functions for property inference. +module Database.DSH.Optimizer.TA.Properties.Auxiliary where + +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 = 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 + +mColE :: Expr -> Maybe Attr +mColE (ColE c) = Just c +mColE _ = Nothing + +posCol :: SerializeOrder -> S.Set Attr +posCol (AbsPos c) = S.singleton c +posCol (RelPos cs) = S.fromList cs +posCol NoPos = S.empty diff --git a/src/Database/DSH/Optimizer/TA/Properties/BottomUp.hs b/src/Database/DSH/Optimizer/TA/Properties/BottomUp.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/BottomUp.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.TA.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.Impossible + +import Database.DSH.Optimizer.Common.Auxiliary +import Database.DSH.Optimizer.Common.Rewrite + +import Database.DSH.Optimizer.TA.Properties.Card1 +import Database.DSH.Optimizer.TA.Properties.Cols +import Database.DSH.Optimizer.TA.Properties.Empty +import Database.DSH.Optimizer.TA.Properties.Keys +import Database.DSH.Optimizer.TA.Properties.Order +import Database.DSH.Optimizer.TA.Properties.Const +import Database.DSH.Optimizer.TA.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 + return $ BUProps { pCols = opCols + , pKeys = opKeys + , pEmpty = opEmpty + , pCard1 = opCard1 + , pOrder = opOrder + , pConst = opConst + } + +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 + return $ BUProps { pCols = opCols + , pKeys = opKeys + , pEmpty = opEmpty + , pCard1 = opCard1 + , pOrder = opOrder + , pConst = opConst + } + +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 + return $ BUProps { pCols = opCols + , pKeys = opKeys + , pEmpty = opEmpty + , pCard1 = opCard1 + , pOrder = opOrder + , pConst = opConst + } + +inferBottomUpProperties :: AlgebraDag TableAlgebra -> NodeMap BottomUpProps +inferBottomUpProperties dag = inferBottomUpGeneral inferWorker dag diff --git a/src/Database/DSH/Optimizer/TA/Properties/Card1.hs b/src/Database/DSH/Optimizer/TA/Properties/Card1.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Card1.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.TA.Properties.Card1 where + +import Database.Algebra.Table.Lang + +import Database.DSH.Optimizer.TA.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 + SemiJoin _ -> False + AntiJoin _ -> False + DisjUnion _ -> False + Difference _ -> False + diff --git a/src/Database/DSH/Optimizer/TA/Properties/Cols.hs b/src/Database/DSH/Optimizer/TA/Properties/Cols.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Cols.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Infer the output schema of TableAlgebra operators. +module Database.DSH.Optimizer.TA.Properties.Cols where + +import qualified Data.Set.Monad as S + + +import Database.Algebra.Table.Lang + +import Database.DSH.Impossible +import Database.DSH.Optimizer.TA.Properties.Auxiliary +import Database.DSH.Optimizer.TA.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 + +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 + +valType :: AVal -> ATy +valType (VInt _) = AInt +valType (VStr _) = AStr +valType (VBool _) = ABool +valType (VDouble _) = ADouble +valType (VDec _) = ADec +valType (VNat _) = ANat + +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 ANat = ANat +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 + 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 (md, mp, cs) -> + let cols = (S.fromList $ map (\(PayloadCol c) -> c) cs) + ∪ (maybe S.empty (\(DescrCol c) -> S.singleton c) md) + ∪ posCol mp + 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 + SemiJoin _ -> S.union leftCols rightCols + AntiJoin _ -> S.union leftCols rightCols + DisjUnion _ -> leftCols + Difference _ -> leftCols + + + diff --git a/src/Database/DSH/Optimizer/TA/Properties/Const.hs b/src/Database/DSH/Optimizer/TA/Properties/Const.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Const.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.TA.Properties.Const + ( inferConstNullOp + , inferConstUnOp + , inferConstBinOp + , constExpr + ) where + +import Data.Maybe +import Data.List + +import Database.Algebra.Table.Lang + +import Database.DSH.Optimizer.TA.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 + 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/Optimizer/TA/Properties/Empty.hs b/src/Database/DSH/Optimizer/TA/Properties/Empty.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Empty.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.TA.Properties.Empty where + +import Database.Algebra.Table.Lang + +import Database.DSH.Optimizer.TA.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 + SemiJoin _ -> leftEmpty + AntiJoin _ -> False + DisjUnion _ -> False + Difference _ -> False diff --git a/src/Database/DSH/Optimizer/TA/Properties/ICols.hs b/src/Database/DSH/Optimizer/TA/Properties/ICols.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/ICols.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Infer the input columns required in TableAlgebra plans. +module Database.DSH.Optimizer.TA.Properties.ICols where + +import qualified Data.Set.Monad as S + +import Database.Algebra.Table.Lang + +import Database.DSH.Optimizer.TA.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') + + -- 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' = 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' = 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 (mDescr, mPos, cols) = cs + in childICols + ∪ (S.fromList $ map (\(PayloadCol c) -> c) cols) + ∪ (maybe S.empty (\(DescrCol c) -> S.singleton c) mDescr) + ∪ posCol mPos diff --git a/src/Database/DSH/Optimizer/TA/Properties/Keys.hs b/src/Database/DSH/Optimizer/TA/Properties/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Keys.hs @@ -0,0 +1,170 @@ +-- FIXME once 7.8 is out, use overloaded list notation for sets +-- instead of S.fromList! +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.TA.Properties.Keys where + +import Data.Maybe +import Data.List +import qualified Data.Set.Monad as S + +import Database.Algebra.Table.Lang + +import Database.DSH.Impossible +import Database.DSH.Optimizer.TA.Properties.Auxiliary +import Database.DSH.Optimizer.TA.Properties.Types + +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 + ] + +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 -> -- all sets A of a's s.t. |A| = |k| and + -- associated bs = k + S.foldr S.union S.empty + [ [ as + | as <- subsetsOfSize (S.size k) pa + , let bs = [ b | (a, b) <- attrPairs, a ∈ as ] + , bs == k + ] + | k <- childKeys + -- check that the key survives at all + , let attrPairs = S.fromList $ mapMaybe mapCol projs + , k ⊆ [ snd x | x <- attrPairs ] + -- generate the set pa of a's s.t. (a, b) ∈ attrPairs and b ∈ k + -- i.e. consider only those a's for which the original b is + -- actually part of the current key. + , let pa = [ a | (a, b) <- attrPairs, b ∈ k ] + ] + + 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 ] + + 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/Optimizer/TA/Properties/Order.hs b/src/Database/DSH/Optimizer/TA/Properties/Order.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Order.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.TA.Properties.Order where + +import Data.Maybe +import qualified Data.Set.Monad as S +import Data.Tuple + +import Database.Algebra.Table.Lang + +import Database.DSH.Impossible + +import Database.DSH.Optimizer.TA.Properties.Auxiliary +import Database.DSH.Optimizer.TA.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 + SemiJoin _ -> leftChildOrder + AntiJoin _ -> leftChildOrder + DisjUnion _ -> [] + Difference _ -> leftChildOrder + diff --git a/src/Database/DSH/Optimizer/TA/Properties/TopDown.hs b/src/Database/DSH/Optimizer/TA/Properties/TopDown.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/TopDown.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.TA.Properties.TopDown where + +import Control.Monad.State + +import qualified Data.IntMap as M +import Data.List +import qualified Data.Set.Monad as S + +import Database.Algebra.Dag +import Database.Algebra.Dag.Common +import Database.Algebra.Table.Lang + +import Database.DSH.Impossible +import Database.DSH.Optimizer.Common.Auxiliary +import Database.DSH.Optimizer.TA.Properties.ICols +import Database.DSH.Optimizer.TA.Properties.Types +import Database.DSH.Optimizer.TA.Properties.Use + + +seed :: TopDownProps +seed = TDProps { pICols = S.empty, pUse = 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 + , pUse = inferUseUnOp (pUse ownProps) (pUse 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 + (urc1', urc2') = inferUseBinOp (pUse ownProps) + (pUse cp1) + (pUse cp2) + (S.map fst $ pCols childBUProps1) + (S.map fst $ pCols childBUProps2) + op + cp1' = TDProps { pICols = crc1', pUse = urc1' } + cp2' = TDProps { pICols = crc2', pUse = urc2' } + in (cp1', cp2') + +inferChildProperties :: NodeMap BottomUpProps -> AlgebraDag TableAlgebra -> AlgNode -> State InferenceState () +inferChildProperties buPropMap d n = do + ownProps <- lookupProps n + case 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] -> 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) $ 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/Optimizer/TA/Properties/Types.hs b/src/Database/DSH/Optimizer/TA/Properties/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Types.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.TA.Properties.Types where + +import qualified Data.Set.Monad as S +import Database.Algebra.Table.Lang +import Database.DSH.Impossible + +---------------------------------------------------------------------------- +-- Property types + +data TopDownProps = TDProps { pICols :: S.Set Attr + , pUse :: 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) + +data BottomUpProps = BUProps { pCols :: S.Set TypedAttr + , pKeys :: S.Set PKey + , pCard1 :: Card1 + , pEmpty :: Empty + , pOrder :: Orders + , pConst :: [ConstCol] + } 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/Optimizer/TA/Properties/Use.hs b/src/Database/DSH/Optimizer/TA/Properties/Use.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Properties/Use.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Infer columns whose exact values are required to compute the +-- correct result. +module Database.DSH.Optimizer.TA.Properties.Use where + +import qualified Data.Set.Monad as S + +import Database.Algebra.Table.Lang + +import Database.DSH.Optimizer.TA.Properties.Auxiliary + +flatten :: S.Set (S.Set Attr) -> S.Set Attr +flatten = S.foldl' (∪) S.empty + + +inferUseBinOp :: S.Set Attr + -> S.Set Attr + -> S.Set Attr + -> S.Set Attr + -> S.Set Attr + -> BinOp + -> (S.Set Attr, S.Set Attr) +inferUseBinOp ownUse leftUse rightUse leftCols rightCols op = + case op of + Cross _ -> ( leftUse ∪ [ c | c <- leftCols, c ∈ ownUse ] + , rightUse ∪ [ c | c <- rightCols, c ∈ ownUse ] ) + + EqJoin (jc1, jc2) -> ( leftUse ∪ (ss jc1) ∪ [ c | c <- leftCols, c ∈ ownUse ] + , rightUse ∪ (ss jc2) ∪ [ c | c <- rightCols, c ∈ ownUse ] ) + ThetaJoin ps -> ( leftUse + ∪ + flatten [ exprCols a | (a, _, _) <- S.fromList ps ] + ∪ + [ c | c <- leftCols, c ∈ ownUse ] + , rightUse + ∪ + flatten [ exprCols b | (_, b, _) <- S.fromList ps ] + ∪ + [ c | c <- rightCols, c ∈ ownUse ] + ) + SemiJoin ps -> ( leftUse + ∪ + flatten [ exprCols a | (a, _, _) <- S.fromList ps ] + ∪ + [ c | c <- leftCols, c ∈ ownUse ] + , rightUse + ∪ + flatten [ exprCols b | (_, b, _) <- S.fromList ps ] + ) + AntiJoin ps -> ( leftUse + ∪ + flatten [ exprCols a | (a, _, _) <- S.fromList ps ] + ∪ + [ c | c <- leftCols, c ∈ ownUse ] + , rightUse + ∪ + flatten [ exprCols b | (_, b, _) <- S.fromList ps ]) + + DisjUnion _ -> ( leftUse ∪ leftCols, rightUse ∪ rightCols ) + Difference _ -> ( leftUse ∪ leftCols, rightUse ∪ rightCols ) + +absPos :: SerializeOrder -> S.Set Attr +absPos (AbsPos c) = S.singleton c +absPos (RelPos _) = S.empty +absPos NoPos = S.empty + +inferUseUnOp :: S.Set Attr -> S.Set Attr -> UnOp -> S.Set Attr +inferUseUnOp ownUse childUse op = + case op of + WinFun ((resCol, winFun), partExprs, sortCols, _) -> + childUse + ∪ (S.delete resCol ownUse) + ∪ (S.unions $ map exprCols partExprs) + ∪ (S.unions $ map (exprCols . fst) sortCols) + ∪ (winFunInput winFun) + RowNum (resCol, _, _) -> childUse ∪ (S.delete resCol ownUse) + RowRank (resCol, _) -> childUse ∪ (S.delete resCol ownUse) + Rank (resCol, _) -> childUse ∪ (S.delete resCol ownUse) + Project projs -> childUse + ∪ (unionss [ exprCols e | (a, e) <- S.fromList projs, a ∈ ownUse ]) + Select e -> childUse ∪ ownUse ∪ (exprCols e) + Distinct _ -> childUse ∪ ownUse + + -- FIXME unconditionally declaring pcols as used might be a bit too defensive. + Aggr (acols, pexprs) -> (S.unions $ map (exprCols . snd) pexprs) + ∪ + (S.unions $ map (aggrInput . fst) acols) + + Serialize (md, mp, cs) -> childUse + ∪ (S.fromList $ map (\(PayloadCol c) -> c) cs) + ∪ (maybe S.empty (\(DescrCol c) -> S.singleton c) md) + -- FIXME once order and -- surrogates are decoupled, absolute pos + -- values are no longer required. + ∪ absPos mp diff --git a/src/Database/DSH/Optimizer/TA/Rewrite/Basic.hs b/src/Database/DSH/Optimizer/TA/Rewrite/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Rewrite/Basic.hs @@ -0,0 +1,562 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Database.DSH.Optimizer.TA.Rewrite.Basic where + +import Debug.Trace +import Text.Printf + +import Control.Applicative +import Control.Monad +import Data.Either.Combinators +import Data.List hiding (insert) +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.Impossible +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.TA.Properties.Auxiliary +import Database.DSH.Optimizer.TA.Properties.Types +import Database.DSH.Optimizer.TA.Properties.Const +import Database.DSH.Optimizer.TA.Rewrite.Common + +cleanup :: TARewrite Bool +cleanup = iteratively $ sequenceRewrites [ applyToAll noProps cleanupRules + , applyToAll inferAll cleanupRulesTopDown + ] + +cleanupRules :: TARuleSet () +cleanupRules = [ stackedProject + , serializeProject + , pullProjectWinFun + , pullProjectSelect + , duplicateSortingCriteriaWin + , duplicateSortingCriteriaRownum + , duplicateSortingCriteriaSerialize + ] + +cleanupRulesTopDown :: TARuleSet AllProps +cleanupRulesTopDown = [ unreferencedRownum + , unreferencedRank + , unreferencedProjectCols + , unreferencedAggrCols + , unreferencedLiteralCols + , postFilterRownum + , inlineSortColsRownum + , inlineSortColsSerialize + , inlineSortColsWinFun + , keyPrefixOrdering + , constAggrKey + , constRownumCol + , constRowRankCol + , constSerializeCol + , constWinOrderCol + ] + +---------------------------------------------------------------------------------- +-- Rewrite rules + +-- | Eliminate rownums which re-generate positions based on one +-- sorting column. These rownums typically occur after filtering +-- operators, i.e. select, antijoin, semijoin. If the absolute values +-- generated by the rownum are not required and only the encoded order +-- is relevant, we can safely remove the rownum and use the sorting +-- column. In that case, positions might not be dense anymore. +postFilterRownum :: TARule AllProps +postFilterRownum q = + $(dagPatMatch 'q "RowNum args (q1)" + [| do + (res, [(ColE sortCol, Asc)], []) <- return $(v "args") + useCols <- pUse <$> td <$> properties q + keys <- pKeys <$> bu <$> properties $(v "q1") + cols <- pCols <$> bu <$> properties $(v "q1") + + -- To get rid of the rownum, the absolute values generated by + -- it must not be required. + predicate $ not $ res `S.member` useCols + + -- Rownum produces a key. If we remove the rownum because its + -- absolute values are not needed and replace it with the + -- original sorting column, it should still be a key. + predicate $ (S.singleton sortCol) `S.member` keys + + -- If we reuse a sorting column, it's type should be int. + predicate $ AInt == typeOf sortCol cols + + return $ do + logRewrite "Basic.Rownum.Unused" q + let projs = (res, ColE sortCol) : map (\c -> (c, ColE c)) (map fst $ S.toList cols) + void $ replaceWithNew q $ UnOp (Project projs) $(v "q1") |]) + + +--------------------------------------------------------------------------- +-- ICols rewrites + +-- | 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.Prune" 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) |]) + +---------------------------------------------------------------------------------- +-- 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 -> TAMatch AllProps (Either [SortSpec] [SortSpec]) +lookupSortCol (ColE oldSortCol, Asc) os = + case lookup oldSortCol os of + Nothing -> return $ Left [(ColE oldSortCol, Asc)] + Just newSortCols -> return $ Right $ map (\c -> (ColE c, Asc)) newSortCols +lookupSortCol (_, Asc) _ = fail "only consider column expressions for now" +lookupSortCol (_, Desc) _ = fail "only consider ascending orders" + +inlineSortColsRownum :: TARule AllProps +inlineSortColsRownum q = + $(dagPatMatch 'q "RowNum o (q1)" + [| do + (resCol, sortCols@(_:_), []) <- 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. + mSortCols <- mapM (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', [])) $(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. + mSortCols <- mapM (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") |]) + + +---------------------------------------------------------------------------------- +-- 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 _ Count = Count + +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 |]) + +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 |]) + +inlineJoinPredRight :: [Proj] -> [(Expr, Expr, JoinRel)] -> [(Expr, Expr, JoinRel)] +inlineJoinPredRight proj p = map inlineConjunct p + where + inlineConjunct (le, re, rel) = (le, inlineExpr proj re, rel) diff --git a/src/Database/DSH/Optimizer/TA/Rewrite/Common.hs b/src/Database/DSH/Optimizer/TA/Rewrite/Common.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/TA/Rewrite/Common.hs @@ -0,0 +1,38 @@ +module Database.DSH.Optimizer.TA.Rewrite.Common where + +import qualified Data.IntMap as M + +import Database.Algebra.Dag.Common + +import Database.DSH.Common.QueryPlan + +import Database.DSH.Optimizer.Common.Rewrite + +import Database.Algebra.Table.Lang + +import Database.DSH.VL.Vector + +import Database.DSH.Optimizer.TA.Properties.BottomUp +import Database.DSH.Optimizer.TA.Properties.TopDown +import Database.DSH.Optimizer.TA.Properties.Types + + -- Type abbreviations for convenience +type TARewrite p = Rewrite TableAlgebra (Shape NDVec) p +type TARule p = Rule TableAlgebra p (Shape NDVec) +type TARuleSet p = RuleSet TableAlgebra p (Shape NDVec) +type TAMatch p = Match TableAlgebra p (Shape NDVec) + +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/Optimizer/VL/OptimizeVL.hs b/src/Database/DSH/Optimizer/VL/OptimizeVL.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/OptimizeVL.hs @@ -0,0 +1,56 @@ +module Database.DSH.Optimizer.VL.OptimizeVL where + +import qualified Data.IntMap as M + +import qualified Database.Algebra.Dag as Dag + +import Database.DSH.Common.QueryPlan + +import Database.DSH.VL.Lang +import Database.DSH.VL.Vector + +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.VL.Rewrite.Expressions +import Database.DSH.Optimizer.VL.Rewrite.PruneEmpty +import Database.DSH.Optimizer.VL.Rewrite.Redundant + +type RewriteClass = Rewrite VL (Shape VLDVec) Bool + +rewriteClasses :: [(Char, RewriteClass)] +rewriteClasses = [ ('E', pruneEmpty) + , ('R', removeRedundancy) + , ('C', optExpressions) + ] + +defaultPipeline :: [RewriteClass] +defaultPipeline = case assemblePipeline "ER" of + Just p -> p + Nothing -> error "invalid default pipeline" + +runPipeline + :: Dag.AlgebraDag VL + -> (Shape VLDVec) + -> [RewriteClass] + -> Bool -> (Dag.AlgebraDag VL, Log, Shape VLDVec) +runPipeline d sh pipeline debug = (d', rewriteLog, sh') + where (d', sh', _, rewriteLog) = runRewrite (sequence_ pipeline) d sh debug + +assemblePipeline :: String -> Maybe [RewriteClass] +assemblePipeline s = mapM (flip lookup rewriteClasses) s + +optimizeVL :: [RewriteClass] -> QueryPlan VL VLDVec -> QueryPlan VL VLDVec +optimizeVL pipeline plan = +#ifdef DEBUGGRAPH + let (d, _, shape) = runPipeline (queryDag plan) (queryShape plan) pipeline True +#else + let (d, _, shape) = runPipeline (queryDag plan) (queryShape plan) pipeline False +#endif + in QueryPlan { queryDag = d, queryShape = shape, queryTags = M.empty } + +optimizeVL' :: [RewriteClass] -> QueryPlan VL VLDVec -> (QueryPlan VL VLDVec, Log) +optimizeVL' pipeline plan = + let (d, l, shape) = runPipeline (queryDag plan) (queryShape plan) pipeline False + in (QueryPlan { queryDag = d, queryShape = shape, queryTags = M.empty }, l) + +optimizeVLDefault :: QueryPlan VL VLDVec -> QueryPlan VL VLDVec +optimizeVLDefault = optimizeVL defaultPipeline diff --git a/src/Database/DSH/Optimizer/VL/Properties/BottomUp.hs b/src/Database/DSH/Optimizer/VL/Properties/BottomUp.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/BottomUp.hs @@ -0,0 +1,100 @@ +module Database.DSH.Optimizer.VL.Properties.BottomUp where + +import Text.Printf + +import Database.Algebra.Dag +import Database.Algebra.Dag.Common + +import Database.DSH.VL.Lang +import Database.DSH.Optimizer.Common.Auxiliary +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.VL.Properties.Card +import Database.DSH.Optimizer.VL.Properties.Const +import Database.DSH.Optimizer.VL.Properties.Empty +import Database.DSH.Optimizer.VL.Properties.NonEmpty +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Properties.VectorType + +-- FIXME this is (almost) identical to its X100 counterpart -> merge +inferWorker :: NodeMap VL -> VL -> AlgNode -> NodeMap BottomUpProps -> BottomUpProps +inferWorker d op node pm = + case op of + TerOp vl c1 c2 c3 -> + let c1Props = lookupUnsafe pm "no children properties" c1 + c2Props = lookupUnsafe pm "no children properties" c2 + c3Props = lookupUnsafe pm "no children properties" c3 + in checkError d node [c1Props, c2Props, c3Props] pm $ inferTerOp vl c1Props c2Props c3Props + BinOp vl c1 c2 -> + let c1Props = lookupUnsafe pm "no children properties" c1 + c2Props = lookupUnsafe pm "no children properties" c2 + in checkError d node [c1Props, c2Props] pm $ inferBinOp vl c1Props c2Props + UnOp vl c -> + let cProps = lookupUnsafe pm "no children properties" c + in checkError d node [cProps] pm $ inferUnOp vl cProps + NullaryOp vl -> checkError d node [] pm $ inferNullOp vl + +checkError :: NodeMap VL -> AlgNode -> [BottomUpProps] -> NodeMap BottomUpProps -> Either String BottomUpProps -> BottomUpProps +checkError d n childProps propMap (Left msg) = + let childPropsMsg = concatMap ((++) "\n" . show) childProps + completeMsg = printf "Inference failed at node %d\n%s\n%s\n%s\n%s" n msg childPropsMsg (show propMap) (show d) + in error completeMsg +checkError _ _ _ _ (Right props) = props + +inferNullOp :: NullOp -> Either String BottomUpProps +inferNullOp op = do + opEmpty <- inferEmptyNullOp op + opNonEmpty <- inferNonEmptyNullOp op + opConst <- inferConstVecNullOp op + opType <- inferVectorTypeNullOp op + opCard <- inferCardOneNullOp op + return $ BUProps { emptyProp = opEmpty + , nonEmptyProp = opNonEmpty + , constProp = opConst + , card1Prop = opCard + , vectorTypeProp = opType } + +inferUnOp :: UnOp -> BottomUpProps -> Either String BottomUpProps +inferUnOp op cProps = do + opEmpty <- inferEmptyUnOp (emptyProp cProps) op + opNonEmpty <- inferNonEmptyUnOp (nonEmptyProp cProps) op + opType <- inferVectorTypeUnOp (vectorTypeProp cProps) op + opConst <- inferConstVecUnOp (constProp cProps) op + opCard <- inferCardOneUnOp (card1Prop cProps) op + return $ BUProps { emptyProp = opEmpty + , nonEmptyProp = opNonEmpty + , constProp = opConst + , card1Prop = opCard + , vectorTypeProp = opType } + +inferBinOp :: BinOp -> BottomUpProps -> BottomUpProps -> Either String BottomUpProps +inferBinOp op c1Props c2Props = do + opEmpty <- inferEmptyBinOp (emptyProp c1Props) (emptyProp c2Props) op + opNonEmpty <- inferNonEmptyBinOp (nonEmptyProp c1Props) (nonEmptyProp c2Props) op + opType <- inferVectorTypeBinOp (vectorTypeProp c1Props) (vectorTypeProp c2Props) op + opConst <- inferConstVecBinOp (constProp c1Props) (constProp c2Props) op + opCard <- inferCardOneBinOp (card1Prop c1Props) (card1Prop c2Props) op + return $ BUProps { emptyProp = opEmpty + , nonEmptyProp = opNonEmpty + , constProp = opConst + , card1Prop = opCard + , vectorTypeProp = opType } + +inferTerOp :: TerOp + -> BottomUpProps + -> BottomUpProps + -> BottomUpProps + -> Either String BottomUpProps +inferTerOp op c1Props c2Props c3Props = do + opEmpty <- inferEmptyTerOp (emptyProp c1Props) (emptyProp c2Props) (emptyProp c3Props) op + opNonEmpty <- inferNonEmptyTerOp (nonEmptyProp c1Props) (nonEmptyProp c2Props) (nonEmptyProp c3Props) op + opType <- inferVectorTypeTerOp (vectorTypeProp c1Props) (vectorTypeProp c2Props) (vectorTypeProp c3Props) op + opConst <- inferConstVecTerOp (constProp c1Props) (constProp c2Props) (constProp c3Props) op + opCard <- inferCardOneTerOp (card1Prop c1Props) (card1Prop c2Props) (card1Prop c3Props) op + return $ BUProps { emptyProp = opEmpty + , nonEmptyProp = opNonEmpty + , constProp = opConst + , card1Prop = opCard + , vectorTypeProp = opType } + +inferBottomUpProperties :: AlgebraDag VL -> NodeMap BottomUpProps +inferBottomUpProperties dag = inferBottomUpGeneral inferWorker dag diff --git a/src/Database/DSH/Optimizer/VL/Properties/Card.hs b/src/Database/DSH/Optimizer/VL/Properties/Card.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/Card.hs @@ -0,0 +1,102 @@ +-- FIXME complete rules +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.VL.Properties.Card where + +import Control.Applicative + +import Database.DSH.VL.Lang + +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Properties.Common + +unp :: Show a => VectorProp a -> Either String a +unp = unpack "Properties.Card" + +inferCardOneNullOp :: NullOp -> Either String (VectorProp Bool) +inferCardOneNullOp op = + case op of + SingletonDescr -> Right $ VProp True + Lit (_, _, rows) -> Right $ VProp $ length rows == 1 + TableRef _ -> Right $ VProp False + +inferCardOneUnOp :: VectorProp Bool -> UnOp -> Either String (VectorProp Bool) +inferCardOneUnOp c op = + case op of + UniqueS -> Right c + Aggr _ -> Right $ VProp True + AggrNonEmpty _ -> Right $ VProp True + WinFun _ -> Right c + UnboxRename -> Right c + Segment -> Right c + Unsegment -> Right c + Project _ -> Right c + Reverse -> unp c >>= (\uc -> return $ VPropPair uc uc) + ReverseS -> unp c >>= (\uc -> return $ VPropPair uc uc) + SelectPos1{} -> Right $ VPropTriple False False False + SelectPos1S{} -> Right $ VPropTriple False False False + Select _ -> Right $ VPropPair False False + SortS _ -> unp c >>= (\uc -> return $ VPropPair uc uc) + GroupS _ -> unp c >>= (\uc -> return $ VPropTriple uc uc uc) + R1 -> + case c of + VProp _ -> Left "Properties.Card: not a pair/triple" + VPropPair b _ -> Right $ VProp b + VPropTriple b _ _ -> Right $ VProp b + R2 -> + case c of + VProp _ -> Left "Properties.Card: not a pair/triple" + VPropPair _ b -> Right $ VProp b + VPropTriple _ b _ -> Right $ VProp b + R3 -> + case c of + VPropTriple _ _ b -> Right $ VProp b + _ -> Left "Properties.Card: not a triple" + GroupAggr ([], _) -> Right $ VProp True + GroupAggr (_, _) -> Right c + Number -> Right c + NumberS -> Right c + Reshape _ -> unp c >>= (\uc -> return $ VPropPair uc uc) + ReshapeS _ -> unp c >>= (\uc -> return $ VPropPair uc uc) + Transpose -> unp c >>= (\uc -> return $ VPropPair uc uc) + AggrNonEmptyS _ -> return $ VProp False + + +inferCardOneBinOp :: VectorProp Bool -> VectorProp Bool -> BinOp -> Either String (VectorProp Bool) +inferCardOneBinOp c1 c2 op = + case op of + AggrS _ -> return $ VProp False + NestProduct -> return $ VPropTriple False False False + DistLift -> return $ VPropPair False False + PropRename -> return $ VProp False + PropFilter -> return $ VPropPair False False + PropReorder -> return $ VPropPair False False + UnboxNested -> return $ VPropPair False False + UnboxScalar -> return $ VProp False + -- FIXME more precisely: empty(left) and card1(right) or card1(left) and empty(right) + Append -> Right $ VPropTriple False False False + AppendS -> Right $ VPropTriple False False False + SelectPos _ -> return $ VPropTriple False False False + SelectPosS _ -> return $ VPropTriple False False False + Zip -> VProp <$> ((||) <$> unp c1 <*> unp c2) + Align -> VProp <$> ((||) <$> unp c1 <*> unp c2) + CartProduct -> return $ VPropTriple False False False + CartProductS -> return $ VPropTriple False False False + NestProductS -> return $ VPropTriple False False False + ThetaJoin _ -> return $ VPropTriple False False False + NestJoin _ -> return $ VPropTriple False False False + ThetaJoinS _ -> return $ VPropTriple False False False + NestJoinS _ -> return $ VPropTriple False False False + SemiJoin _ -> return $ VPropPair False False + SemiJoinS _ -> return $ VPropPair False False + AntiJoin _ -> return $ VPropPair False False + AntiJoinS _ -> return $ VPropPair False False + TransposeS -> return $ VPropPair False False + ZipS -> do + c <- (||) <$> unp c1 <*> unp c2 + return $ VPropTriple c c c + +inferCardOneTerOp :: VectorProp Bool -> VectorProp Bool -> VectorProp Bool -> TerOp -> Either String (VectorProp Bool) +inferCardOneTerOp _ _ _ op = + case op of + Combine -> return $ VPropTriple False False False diff --git a/src/Database/DSH/Optimizer/VL/Properties/Common.hs b/src/Database/DSH/Optimizer/VL/Properties/Common.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/Common.hs @@ -0,0 +1,19 @@ +module Database.DSH.Optimizer.VL.Properties.Common where + +import Control.Monad + +import Database.DSH.Optimizer.VL.Properties.Types + +unpack :: Show a => String -> VectorProp a -> Either String a +unpack _ (VProp b) = Right b +unpack moduleName p = Left $ "no single vector in " ++ moduleName ++ " " ++ (show p) + +mapUnpack :: Show a => String + -> VectorProp a + -> VectorProp a + -> (a -> a -> VectorProp a) + -> Either String (VectorProp a) +mapUnpack moduleName e1 e2 f = let ue1 = unpack moduleName e1 + ue2 = unpack moduleName e2 + in liftM2 f ue1 ue2 + diff --git a/src/Database/DSH/Optimizer/VL/Properties/Const.hs b/src/Database/DSH/Optimizer/VL/Properties/Const.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/Const.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.VL.Properties.Const + ( inferConstVecNullOp + , inferConstVecUnOp + , inferConstVecBinOp + , inferConstVecTerOp + ) where + +import Control.Monad +import Data.List +import qualified Data.List.NonEmpty as N +import Data.Maybe + +import Database.DSH.Impossible +import Database.DSH.Optimizer.VL.Properties.Common +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.VL.Lang +import Database.DSH.Common.Lang + +unp :: Show a => VectorProp a -> Either String a +unp = unpack "Properties.Const" + +fromDBV :: ConstVec -> Either String (ConstDescr, [ConstPayload]) +fromDBV (DBVConst d ps) = Right (d, ps) +fromDBV x = Left $ "Properties.Const fromDBV " ++ (show x) + +fromRVec :: ConstVec -> Either String (SourceConstDescr, TargetConstDescr) +fromRVec (RenameVecConst s t) = Right (s, t) +fromRVec x = Left ("Properties.Const fromRVec " ++ (show x)) + +fromPVec :: ConstVec -> Either String (SourceConstDescr, TargetConstDescr) +fromPVec (PropVecConst s t) = Right (s, t) +fromPVec _ = Left "Properties.Const fromPVec" + +-------------------------------------------------------------------------------- +-- Evaluation of constant expressions + +-- FIXME finish remaining cases, only integer numeric operations so +-- far. + +mkEnv :: [ConstPayload] -> [(DBCol, VLVal)] +mkEnv constCols = mapMaybe envEntry $ zip [1..] constCols + where + envEntry :: (DBCol, ConstPayload) -> Maybe (DBCol, VLVal) + envEntry (_, NonConstPL) = mzero + envEntry (c, ConstPL v) = return (c, v) + +evalNumOp :: BinNumOp -> Int -> Int -> Int +evalNumOp op v1 v2 = + case op of + Add -> v1 + v2 + Sub -> v1 - v2 + Div -> v1 `div` v2 + Mul -> v1 * v2 + Mod -> v1 `mod` v2 + +evalBinOp :: ScalarBinOp -> VLVal -> VLVal -> Maybe VLVal +evalBinOp op v1 v2 = + case (v1, v2) of + (VLInt i1, VLInt i2) -> + case op of + SBNumOp nop -> return $ VLInt $ evalNumOp nop i1 i2 + SBRelOp _ -> mzero + SBBoolOp _ -> $impossible + SBStringOp _ -> $impossible + + (VLBool _, VLBool _) -> + case op of + SBBoolOp _ -> mzero + SBRelOp _ -> mzero + SBNumOp _ -> $impossible + SBStringOp _ -> $impossible + (VLString _, VLString _) -> + case op of + SBRelOp _ -> mzero + SBStringOp _ -> mzero + SBBoolOp _ -> $impossible + SBNumOp _ -> $impossible + (VLDouble _, VLDouble _) -> + case op of + SBRelOp _ -> mzero + SBNumOp _ -> mzero + SBBoolOp _ -> $impossible + SBStringOp _ -> $impossible + (VLUnit, VLUnit) -> mzero + _ -> $impossible + +evalUnOp :: ScalarUnOp -> VLVal -> Maybe VLVal +evalUnOp _ _ = mzero + +constExpr :: [ConstPayload] -> Expr -> Either String ConstPayload +constExpr constCols expr = + case eval expr of + Just v -> return $ ConstPL v + Nothing -> return NonConstPL + + where + env :: [(DBCol, VLVal)] + env = mkEnv constCols + + eval :: Expr -> Maybe VLVal + eval (Constant v) = return v + eval (Column i) = lookup i env + eval (BinApp op e1 e2) = do + v1 <- eval e1 + v2 <- eval e2 + evalBinOp op v1 v2 + eval (UnApp op e1) = do + v <- eval e1 + evalUnOp op v + eval (If c t e) = do + cv <- eval c + case cv of + VLBool True -> eval t + VLBool False -> eval e + _ -> mzero + +-------------------------------------------------------------------------------- +-- Stuff + +nonConstPVec :: ConstVec +nonConstPVec = PropVecConst (SC NonConstDescr) (TC NonConstDescr) + +nonConstRVec :: ConstVec +nonConstRVec = RenameVecConst (SC NonConstDescr) (TC NonConstDescr) + +inferConstVecNullOp :: NullOp -> Either String (VectorProp ConstVec) +inferConstVecNullOp op = + case op of + SingletonDescr -> return $ VProp $ DBVConst (ConstDescr 1) [] + -- do not include the first two columns in the payload columns because they represent descr and pos. + Lit (_, colTypes, rows) -> + if null rows + then return $ VProp $ DBVConst NonConstDescr $ map (const NonConstPL) colTypes + else return $ VProp $ DBVConst (ConstDescr 1) constCols + where constCols = map toConstPayload $ drop 2 $ transpose rows + + toConstPayload col@(c : _) = if all (c ==) col + then ConstPL c + else NonConstPL + toConstPayload [] = NonConstPL + + TableRef (_, cols, _) -> return $ VProp $ DBVConst (ConstDescr 1) $ map (const NonConstPL) cols + +inferConstVecUnOp :: (VectorProp ConstVec) -> UnOp -> Either String (VectorProp ConstVec) +inferConstVecUnOp c op = + case op of + WinFun _ -> do + (d, cols) <- unp c >>= fromDBV + return $ VProp $ DBVConst d (cols ++ [NonConstPL]) + + UniqueS -> return c + + Aggr _ -> do + return $ VProp $ DBVConst NonConstDescr [NonConstPL] + + AggrNonEmpty _ -> do + return $ VProp $ DBVConst (ConstDescr 1) [NonConstPL] + + UnboxRename -> do + (d, _) <- unp c >>= fromDBV + return $ VProp $ RenameVecConst (SC NonConstDescr) (TC d) + + Segment -> do + (_, constCols) <- unp c >>= fromDBV + return $ VProp $ DBVConst NonConstDescr constCols + + Unsegment -> do + (_, constCols) <- unp c >>= fromDBV + return $ VProp $ DBVConst NonConstDescr constCols + + SelectPos1{} -> do + (d, cols) <- unp c >>= fromDBV + return $ VPropTriple (DBVConst d cols) + (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + + SelectPos1S{} -> do + (d, cols) <- unp c >>= fromDBV + return $ VPropTriple (DBVConst d cols) + (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + + Reverse -> do + (d, cs) <- unp c >>= fromDBV + return $ VPropPair (DBVConst d cs) (PropVecConst (SC NonConstDescr) (TC NonConstDescr)) + + ReverseS -> do + (d, cs) <- unp c >>= fromDBV + return $ VPropPair (DBVConst d cs) (PropVecConst (SC NonConstDescr) (TC NonConstDescr)) + + Project projExprs -> do + (constDescr, constCols) <- unp c >>= fromDBV + constCols' <- mapM (constExpr constCols) projExprs + return $ VProp $ DBVConst constDescr constCols' + + Select _ -> do + (d, cols) <- unp c >>= fromDBV + return $ VPropPair (DBVConst d cols) (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + + GroupAggr (g, as) -> do + (d, _) <- unp c >>= fromDBV + return $ VProp $ DBVConst d (map (const NonConstPL) [ 1 .. (length g) + (N.length as) ]) + + Number -> do + (d, cols) <- unp c >>= fromDBV + return $ VProp $ DBVConst d (cols ++ [NonConstPL]) + + NumberS -> do + (d, cols) <- unp c >>= fromDBV + return $ VProp $ DBVConst d (cols ++ [NonConstPL]) + + SortS _ -> do + (d, cs) <- unp c >>= fromDBV + return $ VPropPair (DBVConst d cs) (PropVecConst (SC NonConstDescr) (TC NonConstDescr)) + + GroupS es -> do + (d, cs) <- unp c >>= fromDBV + return $ VPropTriple (DBVConst d (map (const NonConstPL) es)) + (DBVConst NonConstDescr (map (const NonConstPL) cs)) + (PropVecConst (SC NonConstDescr) (TC NonConstDescr)) + + Transpose -> do + (_, cols) <- unp c >>= fromDBV + return $ VPropPair (DBVConst NonConstDescr []) (DBVConst NonConstDescr cols) + Reshape _ -> do + (_, cols) <- unp c >>= fromDBV + return $ VPropPair (DBVConst NonConstDescr []) (DBVConst NonConstDescr cols) + ReshapeS _ -> do + (_, cols) <- unp c >>= fromDBV + return $ VPropPair (DBVConst NonConstDescr []) (DBVConst NonConstDescr cols) + + AggrNonEmptyS _ -> do + return $ VProp $ DBVConst NonConstDescr [NonConstPL] + + R1 -> + case c of + VProp _ -> Left "Properties.Const: not a pair/triple" + VPropPair b _ -> Right $ VProp b + VPropTriple b _ _ -> Right $ VProp b + R2 -> + case c of + VProp _ -> Left "Properties.Const: not a pair/triple" + VPropPair _ b -> Right $ VProp b + VPropTriple _ b _ -> Right $ VProp b + R3 -> + case c of + VPropTriple _ _ b -> Right $ VProp b + _ -> Left "Properties.Const: not a triple" + +inferConstVecBinOp :: (VectorProp ConstVec) -> (VectorProp ConstVec) -> BinOp -> Either String (VectorProp ConstVec) +inferConstVecBinOp c1 c2 op = + case op of + -- FIXME use cardinality property to infer the length if possible + -- FIXME handle special cases: empty input, cardinality 1 and const input, ... + AggrS _ -> do + return $ VProp $ DBVConst NonConstDescr [NonConstPL] + + DistLift -> do + (_, cols1) <- unp c1 >>= fromDBV + (d, cols2) <- unp c2 >>= fromDBV + return $ VPropPair (DBVConst d (cols1 ++ cols2)) (PropVecConst (SC NonConstDescr) (TC NonConstDescr)) + + PropRename -> do + (_, cols) <- unp c2 >>= fromDBV + (SC _, TC target) <- unp c1 >>= fromRVec + + return $ VProp $ DBVConst target cols + + PropFilter -> do + (_, cols) <- unp c2 >>= fromDBV + (SC _, TC target) <- unp c1 >>= fromRVec + + return $ VPropPair (DBVConst target cols) (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + + PropReorder -> do + (_, cols) <- unp c2 >>= fromDBV + (SC _, TC target) <- unp c1 >>= fromPVec + + return $ VPropPair (DBVConst target cols) (PropVecConst (SC NonConstDescr) (TC NonConstDescr)) + + UnboxNested -> do + (_, TC descr) <- unp c1 >>= fromRVec + (_, cols) <- unp c2 >>= fromDBV + + return $ VPropPair (DBVConst descr cols) (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + + UnboxScalar -> do + (d1, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + return $ VProp $ DBVConst d1 (cols1 ++ cols2) + + Append -> do + (d1, cols1) <- unp c1 >>= fromDBV + (d2, cols2) <- unp c2 >>= fromDBV + + let constCols = map sameConst $ zip cols1 cols2 + + sameConst ((ConstPL v1), (ConstPL v2)) | v1 == v2 = ConstPL v1 + sameConst (_, _) = NonConstPL + + d = case (d1, d2) of + (ConstDescr n1, ConstDescr n2) | n1 == n2 -> ConstDescr n1 + _ -> NonConstDescr + + return $ VPropTriple (DBVConst d constCols) nonConstRVec nonConstRVec + + AppendS -> do + (d1, cols1) <- unp c1 >>= fromDBV + (d2, cols2) <- unp c2 >>= fromDBV + + let constCols = map sameConst $ zip cols1 cols2 + + sameConst ((ConstPL v1), (ConstPL v2)) | v1 == v2 = ConstPL v1 + sameConst (_, _) = NonConstPL + + d = case (d1, d2) of + (ConstDescr n1, ConstDescr n2) | n1 == n2 -> ConstDescr n1 + _ -> NonConstDescr + + return $ VPropTriple (DBVConst d constCols) nonConstRVec nonConstRVec + + SelectPos _ -> do + (d1, cols1) <- unp c1 >>= fromDBV + + return $ VPropTriple (DBVConst d1 cols1) + (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + + SelectPosS _ -> do + (d1, cols1) <- unp c1 >>= fromDBV + + return $ VPropTriple (DBVConst d1 cols1) + (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + (RenameVecConst (SC NonConstDescr) (TC NonConstDescr)) + + Align -> do + (d1, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let cols = cols1 ++ cols2 + + return $ VProp $ DBVConst d1 cols + + Zip -> do + (d1, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let cols = cols1 ++ cols2 + + return $ VProp $ DBVConst d1 cols + + ZipS -> do + (d1, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let cols = cols1 ++ cols2 + renameVec = RenameVecConst (SC NonConstDescr) (TC NonConstDescr) + + return $ VPropTriple (DBVConst d1 cols) renameVec renameVec + + CartProduct -> do + (_, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let constCols = cols1 ++ cols2 + + -- FIXME check propVec components for correctness/precision + -- FIXME descr = 1 is almost certainly not correct + return $ VPropTriple (DBVConst (ConstDescr 1) constCols) nonConstPVec nonConstPVec + + CartProductS -> do + (_, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let constCols = cols1 ++ cols2 + + -- FIXME check propVec components for correctness/precision + return $ VPropTriple (DBVConst NonConstDescr constCols) nonConstPVec nonConstPVec + + NestProductS -> do + (_, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let constCols = cols1 ++ cols2 + + -- FIXME check propVec components for correctness/precision + return $ VPropTriple (DBVConst NonConstDescr constCols) nonConstPVec nonConstPVec + + NestJoin _ -> do + (_, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let constCols = cols1 ++ cols2 + + -- FIXME check propVec components for correctness/precision + return $ VPropTriple (DBVConst NonConstDescr constCols) nonConstPVec nonConstPVec + + NestProduct -> do + (_, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let constCols = cols1 ++ cols2 + + -- FIXME check propVec components for correctness/precision + return $ VPropTriple (DBVConst NonConstDescr constCols) nonConstPVec nonConstPVec + + ThetaJoin _ -> do + (_, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let constCols = cols1 ++ cols2 + + -- FIXME check propVec components for correctness/precision + return $ VPropTriple (DBVConst (ConstDescr 1) constCols) nonConstPVec nonConstPVec + + ThetaJoinS _ -> do + (_, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let constCols = cols1 ++ cols2 + + -- FIXME check propVec components for correctness/precision + return $ VPropTriple (DBVConst NonConstDescr constCols) nonConstPVec nonConstPVec + + NestJoinS _ -> do + (_, cols1) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + + let constCols = cols1 ++ cols2 + + -- FIXME check propVec components for correctness/precision + return $ VPropTriple (DBVConst NonConstDescr constCols) nonConstPVec nonConstPVec + + SemiJoin _ -> do + (_, cols1) <- unp c1 >>= fromDBV + + -- FIXME This is propably too pessimistic for the source descriptor + let renameVec = RenameVecConst (SC NonConstDescr) (TC NonConstDescr) + + -- FIXME This is propably too pessimistic for the descr + return $ VPropPair (DBVConst NonConstDescr cols1) renameVec + + SemiJoinS _ -> do + (_, cols1) <- unp c1 >>= fromDBV + + -- FIXME This is propably too pessimistic for the source descriptor + let renameVec = RenameVecConst (SC NonConstDescr) (TC NonConstDescr) + + -- FIXME This is propably too pessimistic for the descr + return $ VPropPair (DBVConst NonConstDescr cols1) renameVec + + AntiJoin _ -> do + (_, cols1) <- unp c1 >>= fromDBV + + -- FIXME This is propably too pessimistic for the source descriptor + let renameVec = RenameVecConst (SC NonConstDescr) (TC NonConstDescr) + + -- FIXME This is propably too pessimistic for the descr + return $ VPropPair (DBVConst NonConstDescr cols1) renameVec + + AntiJoinS _ -> do + (_, cols1) <- unp c1 >>= fromDBV + + -- FIXME This is propably too pessimistic for the source descriptor + let renameVec = RenameVecConst (SC NonConstDescr) (TC NonConstDescr) + + -- FIXME This is propably too pessimistic for the descr + return $ VPropPair (DBVConst NonConstDescr cols1) renameVec + + TransposeS -> do + (_, cols2) <- unp c2 >>= fromDBV + return $ VPropPair (DBVConst NonConstDescr []) (DBVConst NonConstDescr cols2) + +inferConstVecTerOp :: (VectorProp ConstVec) -> (VectorProp ConstVec) -> (VectorProp ConstVec) -> TerOp -> Either String (VectorProp ConstVec) +inferConstVecTerOp c1 c2 c3 op = + case op of + Combine -> do + (d1, _) <- unp c1 >>= fromDBV + (_, cols2) <- unp c2 >>= fromDBV + (_, cols3) <- unp c3 >>= fromDBV + + let constCols = map sameConst $ zip cols2 cols3 + + sameConst ((ConstPL v1), (ConstPL v2)) | v1 == v2 = ConstPL v1 + sameConst (_, _) = NonConstPL + + renameVec = RenameVecConst (SC NonConstDescr) (TC NonConstDescr) + + return $ VPropTriple (DBVConst d1 constCols) renameVec renameVec + diff --git a/src/Database/DSH/Optimizer/VL/Properties/Empty.hs b/src/Database/DSH/Optimizer/VL/Properties/Empty.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/Empty.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.VL.Properties.Empty where + +import Control.Monad + +import Database.DSH.VL.Lang + +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Properties.Common + +unp :: Show a => VectorProp a -> Either String a +unp = unpack "Properties.Empty" + +mapUnp :: Show a => VectorProp a + -> VectorProp a + -> (a -> a -> VectorProp a) + -> Either String (VectorProp a) +mapUnp = mapUnpack "Properties.Empty" + +inferEmptyNullOp :: NullOp -> Either String (VectorProp Bool) +inferEmptyNullOp op = + case op of + SingletonDescr -> Right $ VProp False + Lit (_, _, []) -> Right $ VProp True + Lit (_, _, _) -> Right $ VProp False + TableRef (_, _, _) -> Right $ VProp False + +inferEmptyUnOp :: VectorProp Bool -> UnOp -> Either String (VectorProp Bool) +inferEmptyUnOp e op = + case op of + WinFun _ -> Right e + UniqueS -> Right e + Aggr _ -> Right $ VProp False + AggrNonEmpty _ -> Right $ VProp False + UnboxRename -> Right e + Segment -> Right e + Unsegment -> Right e + Reverse -> let ue = unp e in liftM2 VPropPair ue ue + ReverseS -> let ue = unp e in liftM2 VPropPair ue ue + Project _ -> Right e + Select _ -> let ue = unp e in liftM2 VPropPair ue ue + SortS _ -> let ue = unp e in liftM2 VPropPair ue ue + GroupS _ -> let ue = unp e in liftM3 VPropTriple ue ue ue + + -- FIXME this documents the current implementation behaviour, not + -- what _should_ happen! + ReshapeS _ -> let ue = unp e in liftM2 VPropPair ue ue + Reshape _ -> let ue = unp e in liftM2 VPropPair ue ue + Transpose -> let ue = unp e in liftM2 VPropPair ue ue + + SelectPos1{} -> let ue = unp e in liftM3 VPropTriple ue ue ue + SelectPos1S{} -> let ue = unp e in liftM3 VPropTriple ue ue ue + -- FIXME think about it: what happens if we feed an empty vector into the aggr operator? + GroupAggr (_, _) -> Right $ VProp False + Number -> Right e + NumberS -> Right e + AggrNonEmptyS _ -> return $ VProp False + + R1 -> + case e of + VProp _ -> Left "Properties.Empty: not a pair/triple" + VPropPair b _ -> Right $ VProp b + VPropTriple b _ _ -> Right $ VProp b + R2 -> + case e of + VProp _ -> Left "Properties.Empty: not a pair/triple" + VPropPair _ b -> Right $ VProp b + VPropTriple _ b _ -> Right $ VProp b + R3 -> + case e of + VPropTriple _ _ b -> Right $ VProp b + p -> Left ("Properties.Empty: not a triple" ++ show p) + + +inferEmptyBinOp :: VectorProp Bool -> VectorProp Bool -> BinOp -> Either String (VectorProp Bool) +inferEmptyBinOp e1 e2 op = + case op of + DistLift -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 || ue2) (ue1 || ue2)) + PropRename -> mapUnp e1 e2 (\ue1 ue2 -> VProp (ue1 || ue2)) + PropFilter -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 || ue2) (ue1 || ue2)) + PropReorder -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 || ue2) (ue1 || ue2)) + UnboxNested -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 || ue2) (ue1 || ue2)) + UnboxScalar -> mapUnp e1 e2 (\ue1 ue2 -> VProp (ue1 || ue2)) + Append -> mapUnp e1 e2 (\ue1 ue2 -> VPropTriple (ue1 && ue2) ue1 ue2) + AppendS -> mapUnp e1 e2 (\ue1 ue2 -> VPropTriple (ue1 && ue2) ue1 ue2) + AggrS _ -> return $ VProp False + SelectPos _ -> mapUnp e1 e2 (\ue1 ue2 -> let b = ue1 || ue2 in VPropTriple b b b) + SelectPosS _ -> mapUnp e1 e2 (\ue1 ue2 -> let b = ue1 || ue2 in VPropTriple b b b) + Zip -> mapUnp e1 e2 (\ue1 ue2 -> VProp (ue1 || ue2)) + Align -> mapUnp e1 e2 (\ue1 ue2 -> VProp (ue1 || ue2)) + ZipS -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + CartProduct -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + CartProductS -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + NestProductS -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + ThetaJoin _ -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + NestJoin _ -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + NestProduct -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + ThetaJoinS _ -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + NestJoinS _ -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 || ue2)) + SemiJoin _ -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropPair p p) (ue1 || ue2)) + SemiJoinS _ -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropPair p p) (ue1 || ue2)) + AntiJoin _ -> mapUnp e1 e2 (\ue1 _ -> (\p -> VPropPair p p) ue1) + AntiJoinS _ -> mapUnp e1 e2 (\ue1 _ -> (\p -> VPropPair p p) ue1) + -- FIXME This documents the current behaviour of the algebraic + -- implementations, not what _should_ happen! + TransposeS -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropPair p p) (ue1 || ue2)) + +inferEmptyTerOp :: VectorProp Bool -> VectorProp Bool -> VectorProp Bool -> TerOp -> Either String (VectorProp Bool) +inferEmptyTerOp _ e2 e3 op = + case op of + Combine -> let ue2 = unp e2 + ue3 = unp e3 + in liftM3 VPropTriple (liftM2 (&&) ue2 ue3) ue2 ue3 + diff --git a/src/Database/DSH/Optimizer/VL/Properties/NonEmpty.hs b/src/Database/DSH/Optimizer/VL/Properties/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/NonEmpty.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- + +FIXME semantics need to be clarified. + +For an inner vector (one with multiple segments), True means that all +segments contained in the outer vector will be present. This is +particularly true for the output of a grouping operator. + +For a non-segmented vector, it is true if we can (derived from a base +tables non-empty property) statically assert that a vector will not be +empty. + +This is all rather unclear. Currently, the main purpose of this +property is to avoid the special treatment of empty segments in +segmented aggregates. + +-} + +module Database.DSH.Optimizer.VL.Properties.NonEmpty where + +import Control.Monad + +import Database.DSH.Common.Lang(nonEmptyHint, Emptiness(..)) +import Database.DSH.VL.Lang + +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Properties.Common + +unp :: Show a => VectorProp a -> Either String a +unp = unpack "Properties.NonEmpty" + +mapUnp :: Show a => VectorProp a + -> VectorProp a + -> (a -> a -> VectorProp a) + -> Either String (VectorProp a) +mapUnp = mapUnpack "Properties.NonEmpty" + +inferNonEmptyNullOp :: NullOp -> Either String (VectorProp Bool) +inferNonEmptyNullOp op = + case op of + SingletonDescr -> Right $ VProp False + Lit (NonEmpty, _, _) -> Right $ VProp True + Lit (PossiblyEmpty, _, _) -> Right $ VProp False + TableRef (_, _, hs) -> return $ VProp $ (nonEmptyHint hs) == NonEmpty + +inferNonEmptyUnOp :: VectorProp Bool -> UnOp -> Either String (VectorProp Bool) +inferNonEmptyUnOp e op = + case op of + WinFun _ -> Right e + UniqueS -> Right e + Aggr _ -> Right $ VProp True + AggrNonEmpty _ -> Right $ VProp True + UnboxRename -> Right e + Segment -> Right e + Unsegment -> Right e + Reverse -> let ue = unp e in liftM2 VPropPair ue ue + ReverseS -> let ue = unp e in liftM2 VPropPair ue ue + Project _ -> Right e + Select _ -> Right $ VPropPair False False + SortS _ -> let ue = unp e in liftM2 VPropPair ue ue + -- If the input is not completely empty (that is, segments exist), + -- grouping leads to a nested vector in which every inner segment + -- is not empty. + GroupS _ -> let ue = unp e in liftM3 VPropTriple ue (return True) ue + + -- FIXME this documents the current implementation behaviour, not + -- what _should_ happen! + ReshapeS _ -> let ue = unp e in liftM2 VPropPair ue ue + Reshape _ -> let ue = unp e in liftM2 VPropPair ue ue + Transpose -> let ue = unp e in liftM2 VPropPair ue ue + + SelectPos1{} -> return $ VPropTriple False False False + SelectPos1S{} -> return $ VPropTriple False False False + -- FIXME think about it: what happens if we feed an empty vector into the aggr operator? + GroupAggr (_, _) -> Right e + Number -> Right e + NumberS -> Right e + AggrNonEmptyS _ -> return $ VProp True + + R1 -> + case e of + VProp _ -> Left "Properties.NonEmpty: not a pair/triple" + VPropPair b _ -> Right $ VProp b + VPropTriple b _ _ -> Right $ VProp b + R2 -> + case e of + VProp _ -> Left "Properties.NonEmpty: not a pair/triple" + VPropPair _ b -> Right $ VProp b + VPropTriple _ b _ -> Right $ VProp b + R3 -> + case e of + VPropTriple _ _ b -> Right $ VProp b + _ -> Left "Properties.NonEmpty: not a triple" + + +inferNonEmptyBinOp :: VectorProp Bool -> VectorProp Bool -> BinOp -> Either String (VectorProp Bool) +inferNonEmptyBinOp e1 e2 op = + case op of + DistLift -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 && ue2) (ue1 && ue2)) + PropRename -> mapUnp e1 e2 (\ue1 ue2 -> VProp (ue1 && ue2)) + PropFilter -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 && ue2) (ue1 && ue2)) + PropReorder -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 && ue2) (ue1 && ue2)) + UnboxNested -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 && ue2) (ue1 && ue2)) + UnboxScalar -> mapUnp e1 e2 (\ue1 ue2 -> VProp (ue1 && ue2)) + Append -> mapUnp e1 e2 (\ue1 ue2 -> VPropTriple (ue1 || ue2) ue1 ue2) + AppendS -> mapUnp e1 e2 (\ue1 ue2 -> VPropTriple (ue1 || ue2) ue1 ue2) + AggrS _ -> return $ VProp True + SelectPos _ -> mapUnp e1 e2 (\ue1 ue2 -> let b = ue1 && ue2 in VPropTriple b b b) + SelectPosS _ -> mapUnp e1 e2 (\ue1 ue2 -> let b = ue1 && ue2 in VPropTriple b b b) + Zip -> mapUnp e1 e2 (\ue1 ue2 -> VProp (ue1 && ue2)) + Align -> mapUnp e1 e2 (\ue1 ue2 -> VProp (ue1 && ue2)) + ZipS -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 && ue2)) + CartProduct -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 && ue2)) + CartProductS -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 && ue2)) + NestProductS -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropTriple p p p) (ue1 && ue2)) + ThetaJoin _ -> return $ VPropTriple False False False + NestJoin _ -> return $ VPropTriple False False False + NestProduct -> return $ VPropTriple False False False + ThetaJoinS _ -> return $ VPropTriple False False False + NestJoinS _ -> return $ VPropTriple False False False + SemiJoin _ -> return $ VPropPair False False + SemiJoinS _ -> return $ VPropPair False False + AntiJoin _ -> return $ VPropPair False False + AntiJoinS _ -> return $ VPropPair False False + -- FIXME This documents the current behaviour of the algebraic + -- implementations, not what _should_ happen! + TransposeS -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropPair p p) (ue1 || ue2)) + +inferNonEmptyTerOp :: VectorProp Bool -> VectorProp Bool -> VectorProp Bool -> TerOp -> Either String (VectorProp Bool) +inferNonEmptyTerOp e1 e2 e3 op = + case op of + Combine -> do + ue1 <- unp e1 + ue2 <- unp e2 + ue3 <- unp e3 + return $ VPropTriple ue1 ue2 ue3 + diff --git a/src/Database/DSH/Optimizer/VL/Properties/ReqColumns.hs b/src/Database/DSH/Optimizer/VL/Properties/ReqColumns.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/ReqColumns.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.VL.Properties.ReqColumns where + +import Control.Applicative +import qualified Data.List as L +import qualified Data.List.NonEmpty as N + +import Database.DSH.Common.Lang +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.VL.Lang + + +(∪) :: VectorProp ReqCols -> VectorProp ReqCols -> Either String (VectorProp ReqCols) +(∪) (VProp (Just cols1)) (VProp (Just cols2)) = return $ VProp $ Just $ cols1 `L.union` cols2 +(∪) (VProp (Just cols1)) (VProp Nothing) = return $ VProp $ Just $ cols1 +(∪) (VProp Nothing) (VProp (Just cols2)) = return $ VProp $ Just $ cols2 +(∪) (VProp Nothing) (VProp Nothing) = return $ VProp $ Nothing +(∪) p1 p2 = Left $ "ReqColumns.union" + ++ " " + ++ (show p1) + ++ " " + ++ (show p2) + +none :: VectorProp ReqCols +none = VProp $ Just [] + +one :: VectorProp ReqCols +one = VProp $ Just [1] + +na :: VectorProp ReqCols +na = VProp Nothing + +reqExprCols :: Expr -> [DBCol] +reqExprCols (BinApp _ e1 e2) = reqExprCols e1 `L.union` reqExprCols e2 +reqExprCols (UnApp _ e) = reqExprCols e +reqExprCols (Column col) = [col] +reqExprCols (Constant _) = [] +reqExprCols (If c t e) = reqExprCols c `L.union` reqExprCols t `L.union` reqExprCols e + +reqLeftPredCols :: JoinPredicate Expr -> [DBCol] +reqLeftPredCols (JoinPred cs) = L.nub + $ concatMap (\(JoinConjunct le _ _) -> reqExprCols le) + $ N.toList cs + +reqRightPredCols :: JoinPredicate Expr -> [DBCol] +reqRightPredCols (JoinPred cs) = L.nub + $ concatMap (\(JoinConjunct _ _ re) -> reqExprCols re) + $ N.toList cs + +aggrReqCols :: AggrFun -> [DBCol] +aggrReqCols (AggrSum _ e) = reqExprCols e +aggrReqCols (AggrMin e) = reqExprCols e +aggrReqCols (AggrMax e) = reqExprCols e +aggrReqCols (AggrAvg e) = reqExprCols e +aggrReqCols (AggrAll e) = reqExprCols e +aggrReqCols (AggrAny e) = reqExprCols e +aggrReqCols AggrCount = [] + +winReqCols :: WinFun -> [DBCol] +winReqCols (WinSum e) = reqExprCols e +winReqCols (WinMin e) = reqExprCols e +winReqCols (WinMax e) = reqExprCols e +winReqCols (WinAvg e) = reqExprCols e +winReqCols (WinAll e) = reqExprCols e +winReqCols (WinAny e) = reqExprCols e +winReqCols (WinFirstValue e) = reqExprCols e +winReqCols WinCount = [] + +fromProp :: Show a => VectorProp a -> Either String a +fromProp (VProp p) = return p +fromProp x = fail $ "ReqColumns.fromProp " ++ (show x) + +fromPropPair :: VectorProp a -> Either String (a, a) +fromPropPair (VPropPair x y) = return (x, y) +fromPropPair _ = fail "not a property pair" + +fromPropTriple :: VectorProp a -> Either String (a, a, a) +fromPropTriple (VPropTriple x y z) = return (x, y, z) +fromPropTriple _ = fail "not a property triple" + +allCols :: BottomUpProps -> Either String (VectorProp ReqCols) +allCols props = do + VProp (ValueVector w) <- return $ vectorTypeProp props + return $ VProp $ Just [1 .. w] + +-- | For operators that combine two value vectors in a product-like +-- manner (products, joins, zips, ...), map the columns that are +-- required from above to the respective input columns. +partitionCols :: BottomUpProps -- ^ Available columns in the left input + -> BottomUpProps -- ^ Available columns in the right input + -> ReqCols -- ^ Columns required from above + -> Either String (VectorProp ReqCols, VectorProp ReqCols) +partitionCols childBUProps1 childBUProps2 ownReqCols = do + ValueVector w1 <- fromProp $ vectorTypeProp childBUProps1 + ValueVector w2 <- fromProp $ vectorTypeProp childBUProps2 + + let cols = maybe [] id ownReqCols + + -- If both inputs are ValueVectors, map the required columns to + -- the respective inputs + let leftReqCols = cols `L.intersect` [1 .. w1] + rightReqCols = map (\c -> c - w1) $ cols `L.intersect` [(w1 + 1) .. (w1 + w2)] + return (VProp $ Just leftReqCols, VProp $ Just rightReqCols) + +-- | Infer required columns for unary operators +inferReqColumnsUnOp :: BottomUpProps -- ^ Input properties + -> VectorProp ReqCols -- ^ Columns required from the current node + -> VectorProp ReqCols -- ^ Columns required from the input node + -> UnOp -- ^ Current operator + -> Either String (VectorProp ReqCols) +inferReqColumnsUnOp childBUProps ownReqColumns childReqColumns op = + case op of + WinFun (wfun, _) -> do + cs <- (VProp $ Just $ winReqCols wfun) + ∪ + childReqColumns + cs ∪ ownReqColumns + Transpose -> do + cols <- snd <$> fromPropPair ownReqColumns + childReqColumns ∪ VProp cols + + Reshape _ -> do + cols <- snd <$> fromPropPair ownReqColumns + VProp cols ∪ childReqColumns + + ReshapeS _ -> do + cols <- snd <$> fromPropPair ownReqColumns + VProp cols ∪ childReqColumns + + UniqueS -> ownReqColumns ∪ childReqColumns + + Aggr aggrFun -> (VProp $ Just $ aggrReqCols aggrFun) + ∪ + childReqColumns + + AggrNonEmpty aggrFuns -> (VProp $ Just $ concatMap aggrReqCols (N.toList aggrFuns)) + ∪ + childReqColumns + + UnboxRename -> none ∪ childReqColumns + + Segment -> ownReqColumns ∪ childReqColumns + Unsegment -> ownReqColumns ∪ childReqColumns + + -- Numbering operators add one column at the end. We have to + -- determine the column index of the new column and remove it + -- from the set of required columns + Number -> do + ValueVector w <- fromProp $ vectorTypeProp childBUProps + Just cols <- fromProp ownReqColumns + let cols' = filter (/= w) cols + VProp (Just cols') ∪ childReqColumns + NumberS -> do + ValueVector w <- fromProp $ vectorTypeProp childBUProps + (Just cols) <- fromProp ownReqColumns + let cols' = filter (/= w) cols + VProp (Just cols') ∪ childReqColumns + + Reverse -> do + cols <- fst <$> fromPropPair ownReqColumns + VProp cols ∪ childReqColumns + ReverseS -> do + cols <- fst <$> fromPropPair ownReqColumns + VProp cols ∪ childReqColumns + + Project ps -> childReqColumns ∪ (VProp $ Just $ L.nub $ concatMap reqExprCols ps) + + Select e -> do + cols <- fst <$> fromPropPair ownReqColumns + ownReqColumns' <- (VProp cols) ∪ (VProp $ Just $ reqExprCols e) + ownReqColumns' ∪ childReqColumns + + SelectPos1{} -> do + (cols, _, _) <- fromPropTriple ownReqColumns + childReqColumns ∪ (VProp cols) + + SelectPos1S{} -> do + (cols, _, _) <- fromPropTriple ownReqColumns + childReqColumns ∪ (VProp cols) + + -- We don't need to look at the columns required from above, + -- because they can only be a subset of (gs ++ as). + GroupAggr (gs, as) -> childReqColumns + ∪ + (VProp $ Just $ L.nub $ concatMap reqExprCols gs + ++ + concatMap aggrReqCols (N.toList as)) + + SortS exprs -> do + cols <- fst <$> fromPropPair ownReqColumns + ownReqColumns' <- VProp cols + ∪ + (VProp $ Just $ L.nub $ concatMap reqExprCols exprs) + childReqColumns ∪ ownReqColumns' + + GroupS exprs -> do + (_, colsi, _) <- fromPropTriple ownReqColumns + ownReqColumns' <- VProp colsi + ∪ + (VProp $ Just $ L.nub $ concatMap reqExprCols exprs) + childReqColumns ∪ ownReqColumns' + + AggrNonEmptyS aggrFuns -> do + reqCols <- (VProp $ Just $ concatMap aggrReqCols (N.toList aggrFuns)) + ∪ + childReqColumns + return reqCols + + R1 -> + case childReqColumns of + VProp _ -> Left $ "ReqColumns.R1 " ++ (show childReqColumns) + VPropPair cols1 cols2 -> do + cols1' <- fromProp =<< VProp cols1 ∪ ownReqColumns + return $ VPropPair cols1' cols2 + VPropTriple cols1 cols2 cols3 -> do + cols1' <- fromProp =<< VProp cols1 ∪ ownReqColumns + return $ VPropTriple cols1' cols2 cols3 + + R2 -> + case childReqColumns of + VProp _ -> fail "ReqColumns.R2" + VPropPair cols1 cols2 -> do + cols2' <- fromProp =<< VProp cols2 ∪ ownReqColumns + return $ VPropPair cols1 cols2' + VPropTriple cols1 cols2 cols3 -> do + cols2' <- fromProp =<< VProp cols2 ∪ ownReqColumns + return $ VPropTriple cols1 cols2' cols3 + + R3 -> + case childReqColumns of + VProp _ -> fail "ReqColumns.R3/1" + VPropPair _ _ -> fail "ReqColumns.R3/2" + VPropTriple cols1 cols2 cols3 -> do + cols3' <- fromProp =<< VProp cols3 ∪ ownReqColumns + return $ VPropTriple cols1 cols2 cols3' + + +-- | Infer required columns for binary operators +inferReqColumnsBinOp :: BottomUpProps + -> BottomUpProps + -> VectorProp ReqCols + -> VectorProp ReqCols + -> VectorProp ReqCols + -> BinOp + -> Either String (VectorProp ReqCols, VectorProp ReqCols) +inferReqColumnsBinOp childBUProps1 childBUProps2 ownReqColumns childReqColumns1 childReqColumns2 op = + case op of + AggrS aggrFun -> do + fromLeft <- childReqColumns1 ∪ none + fromRight <- (VProp $ Just $ aggrReqCols aggrFun) + ∪ + childReqColumns2 + return (fromLeft, fromRight) + + DistLift -> do + cols <- fst <$> fromPropPair ownReqColumns + (ownLeft, ownRight) <- partitionCols childBUProps1 childBUProps2 cols + (,) <$> (childReqColumns1 ∪ ownLeft) <*> (childReqColumns2 ∪ ownRight) + + PropRename -> do + fromRight <- childReqColumns2 ∪ ownReqColumns + return (na, fromRight) + + PropFilter -> do + cols <- fst <$> fromPropPair ownReqColumns + fromRight <- childReqColumns2 ∪ VProp cols + return (na, fromRight) + + PropReorder -> do + cols <- fst <$> fromPropPair ownReqColumns + fromRight <- childReqColumns2 ∪ VProp cols + return (na, fromRight) + + UnboxNested -> do + cols <- fst <$> fromPropPair ownReqColumns + fromRight <- childReqColumns2 ∪ VProp cols + return (na, fromRight) + + Append -> do + (cols, _, _) <- fromPropTriple ownReqColumns + fromLeft <- (VProp cols) ∪ childReqColumns1 + fromRight <- (VProp cols) ∪ childReqColumns2 + return (fromLeft, fromRight) + + AppendS -> do + (cols, _, _) <- fromPropTriple ownReqColumns + fromLeft <- (VProp cols) ∪ childReqColumns1 + fromRight <- (VProp cols) ∪ childReqColumns2 + return (fromLeft, fromRight) + + SelectPos _ -> do + (cols, _, _) <- fromPropTriple ownReqColumns + fromLeft <- VProp cols ∪ childReqColumns1 + return (fromLeft, one) + + SelectPosS _ -> do + (cols, _, _) <- fromPropTriple ownReqColumns + fromLeft <- VProp cols ∪ childReqColumns1 + return (fromLeft, one) + + Align -> do + cols <- fromProp ownReqColumns + (ownLeft, ownRight) <- partitionCols childBUProps1 childBUProps2 cols + (,) <$> (childReqColumns1 ∪ ownLeft) <*> (childReqColumns2 ∪ ownRight) + + Zip -> do + cols <- fromProp ownReqColumns + (ownLeft, ownRight) <- partitionCols childBUProps1 childBUProps2 cols + (,) <$> (childReqColumns1 ∪ ownLeft) <*> (childReqColumns2 ∪ ownRight) + + CartProduct -> do + (cols1, _, _) <- fromPropTriple ownReqColumns + (ownLeft, ownRight) <- partitionCols childBUProps1 childBUProps2 cols1 + (,) <$> (childReqColumns1 ∪ ownLeft) <*> (childReqColumns2 ∪ ownRight) + + CartProductS -> do + (cols1, _, _) <- fromPropTriple ownReqColumns + (ownLeft, ownRight) <- partitionCols childBUProps1 childBUProps2 cols1 + (,) <$> (childReqColumns1 ∪ ownLeft) <*> (childReqColumns2 ∪ ownRight) + + NestProductS -> do + cols1 <- fst <$> fromPropPair ownReqColumns + (ownLeft, ownRight) <- partitionCols childBUProps1 childBUProps2 cols1 + (,) <$> (childReqColumns1 ∪ ownLeft) <*> (childReqColumns2 ∪ ownRight) + + ThetaJoin p -> do + (cols1, _, _) <- fromPropTriple ownReqColumns + (leftReqCols, rightReqCols) <- partitionCols childBUProps1 childBUProps2 cols1 + leftReqCols' <- (VProp $ Just $ reqLeftPredCols p) ∪ leftReqCols + rightReqCols' <- (VProp $ Just $ reqRightPredCols p) ∪ rightReqCols + (,) <$> (childReqColumns1 ∪ leftReqCols') <*> (childReqColumns2 ∪ rightReqCols') + + UnboxScalar -> do + cols1 <- fromProp ownReqColumns + (leftReqCols, rightReqCols) <- partitionCols childBUProps1 childBUProps2 cols1 + (,) <$> (childReqColumns1 ∪ leftReqCols) <*> (childReqColumns2 ∪ rightReqCols) + + NestJoin p -> do + (cols1, _, _) <- fromPropTriple ownReqColumns + (leftReqCols, rightReqCols) <- partitionCols childBUProps1 childBUProps2 cols1 + leftReqCols' <- (VProp $ Just $ reqLeftPredCols p) ∪ leftReqCols + rightReqCols' <- (VProp $ Just $ reqRightPredCols p) ∪ rightReqCols + (,) <$> (childReqColumns1 ∪ leftReqCols') <*> (childReqColumns2 ∪ rightReqCols') + NestProduct -> do + (cols1, _, _) <- fromPropTriple ownReqColumns + (leftReqCols, rightReqCols) <- partitionCols childBUProps1 childBUProps2 cols1 + (,) <$> (childReqColumns1 ∪ leftReqCols) <*> (childReqColumns2 ∪ rightReqCols) + + ThetaJoinS p -> do + (cols1, _, _) <- fromPropTriple ownReqColumns + (leftReqCols, rightReqCols) <- partitionCols childBUProps1 childBUProps2 cols1 + leftReqCols' <- (VProp $ Just $ reqLeftPredCols p) ∪ leftReqCols + rightReqCols' <- (VProp $ Just $ reqRightPredCols p) ∪ rightReqCols + (,) <$> (childReqColumns1 ∪ leftReqCols') <*> (childReqColumns2 ∪ rightReqCols') + + NestJoinS p -> do + cols1 <- fst <$> fromPropPair ownReqColumns + (leftReqCols, rightReqCols) <- partitionCols childBUProps1 childBUProps2 cols1 + leftReqCols' <- (VProp $ Just $ reqLeftPredCols p) ∪ leftReqCols + rightReqCols' <- (VProp $ Just $ reqRightPredCols p) ∪ rightReqCols + (,) <$> (childReqColumns1 ∪ leftReqCols') <*> (childReqColumns2 ∪ rightReqCols') + + ZipS -> do + (cols, _, _) <- fromPropTriple ownReqColumns + (ownLeft, ownRight) <- partitionCols childBUProps1 childBUProps2 cols + (,) <$> (childReqColumns1 ∪ ownLeft) <*> (childReqColumns2 ∪ ownRight) + + -- For a semijoin, we only require the columns used in the join argument + -- from the right input. + SemiJoin p -> do + cols1 <- fst <$> fromPropPair ownReqColumns + fromLeft <- ((VProp $ Just $ reqLeftPredCols p) ∪ VProp cols1) >>= (∪ childReqColumns1) + fromRight <- (VProp $ Just $ reqRightPredCols p) ∪ childReqColumns2 + return (fromLeft, fromRight) + + -- For a semijoin, we only require the columns used in the join argument + -- from the right input. + SemiJoinS p -> do + cols1 <- fst <$> fromPropPair ownReqColumns + fromLeft <- ((VProp $ Just $ reqLeftPredCols p) ∪ VProp cols1) >>= (∪ childReqColumns1) + fromRight <- (VProp $ Just $ reqRightPredCols p) ∪ childReqColumns2 + return (fromLeft, fromRight) + + -- For a antijoin, we only require the columns used in the join argument + -- from the right input. + AntiJoin p -> do + cols1 <- fst <$> fromPropPair ownReqColumns + fromLeft <- ((VProp $ Just $ reqLeftPredCols p) ∪ VProp cols1) >>= (∪ childReqColumns1) + fromRight <- (VProp $ Just $ reqRightPredCols p) ∪ childReqColumns2 + return (fromLeft, fromRight) + + -- For a antijoin, we only require the columns used in the join argument + -- from the right input. + AntiJoinS p -> do + cols1 <- fst <$> fromPropPair ownReqColumns + fromLeft <- ((VProp $ Just $ reqLeftPredCols p) ∪ VProp cols1) >>= (∪ childReqColumns1) + fromRight <- (VProp $ Just $ reqRightPredCols p) ∪ childReqColumns2 + return (fromLeft, fromRight) + + TransposeS -> do + cols <- snd <$> fromPropPair ownReqColumns + fromRight <- childReqColumns2 ∪ VProp cols + return (none, fromRight) + +inferReqColumnsTerOp :: VectorProp ReqCols + -> VectorProp ReqCols + -> VectorProp ReqCols + -> VectorProp ReqCols + -> TerOp + -> Either String (VectorProp ReqCols, VectorProp ReqCols, VectorProp ReqCols) +inferReqColumnsTerOp ownReqColumns _ childReqColumns2 childReqColumns3 op = + case op of + Combine -> do + (cols, _, _) <- fromPropTriple ownReqColumns + fromLeft <- VProp cols ∪ childReqColumns2 + fromRight <- VProp cols ∪ childReqColumns3 + return (one, fromLeft, fromRight) diff --git a/src/Database/DSH/Optimizer/VL/Properties/TopDown.hs b/src/Database/DSH/Optimizer/VL/Properties/TopDown.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/TopDown.hs @@ -0,0 +1,185 @@ +module Database.DSH.Optimizer.VL.Properties.TopDown(inferTopDownProperties) where + +import Control.Monad.State +import Text.Printf + +import qualified Data.IntMap as M + +import Database.Algebra.Dag.Common +import Database.Algebra.Dag + +import Database.DSH.VL.Lang +import Database.DSH.Optimizer.Common.Auxiliary +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Properties.ReqColumns + +reqColumnsSeed :: ReqCols +reqColumnsSeed = Nothing + +vPropSeed :: TopDownProps +vPropSeed = TDProps { reqColumnsProp = VProp reqColumnsSeed } + +vPropPairSeed :: TopDownProps +vPropPairSeed = TDProps { reqColumnsProp = VPropPair reqColumnsSeed reqColumnsSeed } + +vPropTripleSeed :: TopDownProps +vPropTripleSeed = TDProps { reqColumnsProp = VPropTriple reqColumnsSeed reqColumnsSeed reqColumnsSeed } + +seed :: VL -> TopDownProps +seed (NullaryOp _) = vPropSeed +seed (UnOp op _) = + case op of + WinFun _ -> vPropSeed + SelectPos1{} -> vPropTripleSeed + SelectPos1S{} -> vPropTripleSeed + Reverse -> vPropPairSeed + ReverseS -> vPropPairSeed + UniqueS -> vPropSeed + UnboxRename -> vPropSeed + Segment -> vPropSeed + Unsegment -> vPropSeed + Select _ -> vPropPairSeed + SortS _ -> vPropPairSeed + GroupS _ -> vPropTripleSeed + Project _ -> vPropSeed + Aggr _ -> vPropSeed + AggrNonEmpty _ -> vPropSeed + AggrNonEmptyS _ -> vPropSeed + GroupAggr (_, _) -> vPropSeed + R1 -> vPropSeed + R2 -> vPropSeed + R3 -> vPropSeed + Number -> vPropSeed + NumberS -> vPropSeed + Transpose -> vPropPairSeed + Reshape _ -> vPropPairSeed + ReshapeS _ -> vPropPairSeed + +seed (BinOp op _ _) = + case op of + Append -> vPropTripleSeed + AppendS -> vPropTripleSeed + ZipS -> vPropTripleSeed + DistLift -> vPropPairSeed + PropFilter -> vPropPairSeed + PropReorder -> vPropPairSeed + UnboxNested -> vPropPairSeed + UnboxScalar -> vPropSeed + SelectPos _ -> vPropTripleSeed + SelectPosS _ -> vPropTripleSeed + PropRename -> vPropSeed + AggrS _ -> vPropSeed + Zip -> vPropSeed + Align -> vPropSeed + CartProduct -> vPropTripleSeed + CartProductS -> vPropTripleSeed + ThetaJoin _ -> vPropTripleSeed + NestJoin _ -> vPropTripleSeed + NestProduct -> vPropTripleSeed + ThetaJoinS _ -> vPropTripleSeed + SemiJoin _ -> vPropPairSeed + SemiJoinS _ -> vPropPairSeed + AntiJoin _ -> vPropPairSeed + AntiJoinS _ -> vPropPairSeed + NestJoinS _ -> vPropPairSeed + NestProductS -> vPropPairSeed + TransposeS -> vPropPairSeed + + +seed (TerOp op _ _ _) = + case op of + Combine -> vPropTripleSeed + + +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 :: BottomUpProps -> TopDownProps -> TopDownProps -> UnOp -> Either String TopDownProps +inferUnOp childBUProps ownProps cp op = do + cols <- inferReqColumnsUnOp childBUProps + (reqColumnsProp ownProps) + (reqColumnsProp cp) + op + return $ TDProps { reqColumnsProp = cols } + +inferBinOp :: BottomUpProps + -> BottomUpProps + -> TopDownProps + -> TopDownProps + -> TopDownProps + -> BinOp + -> Either String (TopDownProps, TopDownProps) +inferBinOp childBUProps1 childBUProps2 ownProps cp1 cp2 op = do + (crc1', crc2') <- inferReqColumnsBinOp childBUProps1 + childBUProps2 + (reqColumnsProp ownProps) + (reqColumnsProp cp1) + (reqColumnsProp cp2) op + let cp1' = TDProps { reqColumnsProp = crc1' } + cp2' = TDProps { reqColumnsProp = crc2' } + return (cp1', cp2') + +inferTerOp :: TopDownProps + -> TopDownProps + -> TopDownProps + -> TopDownProps + -> TerOp + -> Either String (TopDownProps, TopDownProps, TopDownProps) +inferTerOp ownProps cp1 cp2 cp3 op = do + (crc1', crc2', crc3') <- inferReqColumnsTerOp (reqColumnsProp ownProps) + (reqColumnsProp cp1) + (reqColumnsProp cp2) + (reqColumnsProp cp3) op + let cp1' = TDProps { reqColumnsProp = crc1' } + cp2' = TDProps { reqColumnsProp = crc2' } + cp3' = TDProps { reqColumnsProp = crc3' } + return (cp1', cp2', cp3') + +inferChildProperties :: NodeMap BottomUpProps -> AlgebraDag VL -> AlgNode -> State InferenceState () +inferChildProperties buPropMap d n = do + ownProps <- lookupProps n + case operator n d of + NullaryOp _ -> return () + UnOp op c -> do + cp <- lookupProps c + let buProps = lookupUnsafe buPropMap "TopDown.infer" c + let cp' = checkError n [cp] d $ inferUnOp buProps 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') = checkError n [cp1, cp2] d $ inferBinOp buProps1 buProps2 ownProps cp1 cp2 op + replaceProps c1 cp1' + replaceProps c2 cp2' + TerOp op c1 c2 c3 -> do + cp1 <- lookupProps c1 + cp2 <- lookupProps c2 + cp3 <- lookupProps c3 + let (cp1', cp2', cp3') = checkError n [cp1, cp2, cp3] d $ inferTerOp ownProps cp1 cp2 cp3 op + replaceProps c1 cp1' + replaceProps c2 cp2' + replaceProps c3 cp3' + +checkError :: AlgNode -> [TopDownProps] -> AlgebraDag VL -> Either String p -> p +checkError n childProps d (Left msg) = + let completeMsg = printf "Inference failed at node %d\n%s\n%s\n%s" n msg (show childProps) (show $ nodeMap d) + in error completeMsg +checkError _ _ _ (Right props) = props + +-- | Infer properties during a top-down traversal. +inferTopDownProperties :: NodeMap BottomUpProps -> [AlgNode] -> AlgebraDag VL -> NodeMap TopDownProps +inferTopDownProperties buPropMap topOrderedNodes d = execState action initialMap + where action = mapM_ (inferChildProperties buPropMap d) topOrderedNodes + initialMap = M.map seed $ nodeMap d + diff --git a/src/Database/DSH/Optimizer/VL/Properties/Types.hs b/src/Database/DSH/Optimizer/VL/Properties/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/Types.hs @@ -0,0 +1,127 @@ +module Database.DSH.Optimizer.VL.Properties.Types where + +import Text.PrettyPrint + +import Database.DSH.VL.Lang +import Database.DSH.VL.Render.Dot + +data VectorProp a = VProp a + | VPropPair a a + | VPropTriple a a a + +instance Show a => Show (VectorProp a) where + show (VProp a) = show a + show (VPropPair a1 a2) = show (a1, a2) + show (VPropTriple a1 a2 a3) = show (a1, a2, a3) + +data VectorType = ValueVector Int + | RenameVector + | PropVector + deriving Show + +data Const = Const VLVal + | NoConst + deriving Show + +data ConstDescr = ConstDescr Int + | NonConstDescr + +data ConstPayload = ConstPL VLVal + | NonConstPL + deriving Show + +data ConstVec = DBVConst ConstDescr [ConstPayload] + | RenameVecConst SourceConstDescr TargetConstDescr + | PropVecConst SourceConstDescr TargetConstDescr + deriving Show + +newtype SourceConstDescr = SC ConstDescr deriving Show +newtype TargetConstDescr = TC ConstDescr deriving Show + +data BottomUpProps = BUProps { emptyProp :: VectorProp Bool + -- Documents wether a vector is + -- statically known to be not empty. For + -- a flat vector (i.e. a vector with only + -- one segment) t his property is true if + -- we can statically decide that the + -- vector is not empty. For an inner + -- vector, i.e. a vector with multiple + -- segments, it is true if *every* + -- segment is non-empty. + , nonEmptyProp :: VectorProp Bool + , constProp :: VectorProp ConstVec + , card1Prop :: VectorProp Bool + , vectorTypeProp :: VectorProp VectorType + } deriving (Show) + + +type ReqCols = Maybe [DBCol] + +data TopDownProps = TDProps { reqColumnsProp :: VectorProp ReqCols } deriving (Show) + +data Properties = Properties { bu :: BottomUpProps + , td :: TopDownProps + } + +class Renderable a where + renderProp :: a -> Doc + +insertComma :: Doc -> Doc -> Doc +insertComma d1 d2 = d1 <> comma <+> d2 + +instance Renderable a => Renderable (VectorProp a) where + renderProp (VProp p) = renderProp p + renderProp (VPropPair p1 p2) = parens $ (renderProp p1) `insertComma` (renderProp p2) + renderProp (VPropTriple p1 p2 p3) = parens $ (renderProp p1) `insertComma` (renderProp p2) `insertComma` (renderProp p3) + +instance Renderable a => Renderable (Maybe a) where + renderProp (Just x) = renderProp x + renderProp Nothing = text "na" + +instance Renderable Bool where + renderProp = text . show + +bracketList :: (a -> Doc) -> [a] -> Doc +bracketList f = brackets . hsep . punctuate comma . map f + +instance Renderable Int where + renderProp = text . show + +instance Renderable a => Renderable [a] where + renderProp = bracketList renderProp + +instance Show ConstDescr where + show (ConstDescr v) = render $ int v + show NonConstDescr = "NC" + +instance Renderable ConstVec where + renderProp (DBVConst d ps) = (text $ show d) <+> payload + where payload = bracketList id $ map renderPL $ foldr isConst [] $ zip [1..] ps + isConst (_, NonConstPL) vals = vals + isConst (i, (ConstPL v)) vals = (i, v) : vals + + renderPL (i, v) = int i <> colon <> renderTblVal v + + renderProp (RenameVecConst (SC ds) (TC ts)) = (text $ show ds) <> text " -> " <> (text $ show ts) + renderProp (PropVecConst (SC ds) (TC ts)) = (text $ show ds) <> text " -> " <> (text $ show ts) + +instance Renderable VectorType where + renderProp = text . show + +instance Renderable BottomUpProps where + renderProp p = text "empty:" <+> (renderProp $ emptyProp p) + $$ text "const:" <+> (renderProp $ constProp p) + $$ text "schema:" <+> (renderProp $ vectorTypeProp p) + +instance Renderable TopDownProps where + renderProp p = text "reqCols:" <+> (text $ show $ reqColumnsProp p) + +-- | Rendering function for the bottom-up properties container. +renderBottomUpProps :: BottomUpProps -> [String] +renderBottomUpProps ps = [render $ renderProp ps] + +renderTopDownProps :: TopDownProps -> [String] +renderTopDownProps ps = [render $ renderProp ps] + +renderProperties :: Properties -> [String] +renderProperties ps = (renderBottomUpProps $ bu ps) ++ (renderTopDownProps $ td ps) diff --git a/src/Database/DSH/Optimizer/VL/Properties/VectorType.hs b/src/Database/DSH/Optimizer/VL/Properties/VectorType.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Properties/VectorType.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- FIXME introduce consistency checks for schema inference +module Database.DSH.Optimizer.VL.Properties.VectorType where + +import Control.Monad +import Control.Applicative +import qualified Data.List.NonEmpty as N + +import Database.DSH.Optimizer.VL.Properties.Types + +import Database.DSH.VL.Lang + +{- Implement more checks: check the input types for correctness -} + +vectorWidth :: VectorProp VectorType -> Int +vectorWidth (VProp (ValueVector w)) = w +vectorWidth _ = error "vectorWidth: non-ValueVector input" + +inferVectorTypeNullOp :: NullOp -> Either String (VectorProp VectorType) +inferVectorTypeNullOp op = + case op of + SingletonDescr -> Right $ VProp $ ValueVector 0 + Lit (_, t, _) -> Right $ VProp $ ValueVector $ length t + TableRef (_, cs, _) -> Right $ VProp $ ValueVector $ length cs + +unpack :: VectorProp VectorType -> Either String VectorType +unpack (VProp s) = Right s +unpack _ = Left "Input is not a single vector property" + +inferVectorTypeUnOp :: VectorProp VectorType -> UnOp -> Either String (VectorProp VectorType) +inferVectorTypeUnOp s op = + case op of + WinFun _ -> do + ValueVector w <- unpack s + return $ VProp $ ValueVector $ w + 1 + UniqueS -> VProp <$> unpack s + Aggr _ -> Right $ VProp $ ValueVector 1 + AggrNonEmpty as -> Right $ VProp $ ValueVector $ N.length as + UnboxRename -> Right $ VProp $ RenameVector + Segment -> VProp <$> unpack s + Unsegment -> VProp <$> unpack s + Reverse -> liftM2 VPropPair (unpack s) (Right PropVector) + ReverseS -> liftM2 VPropPair (unpack s) (Right PropVector) + SelectPos1{} -> liftM3 VPropTriple (unpack s) (Right RenameVector) (Right RenameVector) + SelectPos1S{} -> liftM3 VPropTriple (unpack s) (Right RenameVector) (Right RenameVector) + R1 -> + case s of + VPropPair s1 _ -> Right $ VProp s1 + VPropTriple s1 _ _ -> Right $ VProp s1 + _ -> Left "Input of R1 is not a tuple" + R2 -> + case s of + VPropPair _ s2 -> Right $ VProp s2 + VPropTriple _ s2 _ -> Right $ VProp s2 + _ -> Left "Input of R2 is not a tuple" + R3 -> + case s of + VPropTriple s3 _ _ -> Right $ VProp s3 + _ -> Left "Input of R3 is not a tuple" + + Project valProjs -> Right $ VProp $ ValueVector $ length valProjs + + Select _ -> VPropPair <$> unpack s <*> (Right RenameVector) + SortS _ -> liftM2 VPropPair (unpack s) (Right PropVector) + AggrNonEmptyS as -> Right $ VProp $ ValueVector $ N.length as + + GroupS es -> + case s of + VProp t@(ValueVector _) -> + Right $ VPropTriple (ValueVector $ length es) t PropVector + _ -> + Left "Input of GroupSimple is not a value vector" + GroupAggr (g, as) -> Right $ VProp $ ValueVector (length g + N.length as) + Number -> do + ValueVector w <- unpack s + return $ VProp $ ValueVector (w + 1) + NumberS -> do + ValueVector w <- unpack s + return $ VProp $ ValueVector (w + 1) + + Reshape _ -> liftM2 VPropPair (return $ ValueVector 0) (unpack s) + ReshapeS _ -> liftM2 VPropPair (return $ ValueVector 0) (unpack s) + Transpose -> liftM2 VPropPair (return $ ValueVector 0) (unpack s) + +reqValVectors :: VectorProp VectorType + -> VectorProp VectorType + -> (Int -> Int -> VectorProp VectorType) + -> String + -> Either String (VectorProp VectorType) +reqValVectors (VProp (ValueVector w1)) (VProp (ValueVector w2)) f _ = + Right $ f w1 w2 +reqValVectors _ _ _ e = + Left $ "Inputs of " ++ e ++ " are not ValueVectors" + +inferVectorTypeBinOp :: VectorProp VectorType -> VectorProp VectorType -> BinOp -> Either String (VectorProp VectorType) +inferVectorTypeBinOp s1 s2 op = + case op of + AggrS _ -> return $ VProp $ ValueVector 1 + + DistLift -> do + ValueVector w1 <- unpack s1 + ValueVector w2 <- unpack s2 + return $ VPropPair (ValueVector $ w1 + w2) PropVector + + PropRename -> Right s2 + PropFilter -> liftM2 VPropPair (unpack s2) (Right RenameVector) + PropReorder -> liftM2 VPropPair (unpack s2) (Right PropVector) + UnboxNested -> liftM2 VPropPair (unpack s2) (Right RenameVector) + Append -> + case (s1, s2) of + (VProp (ValueVector w1), VProp (ValueVector w2)) | w1 == w2 -> + Right $ VPropTriple (ValueVector w1) RenameVector RenameVector + (VProp (ValueVector w1), VProp (ValueVector w2)) -> + Left $ "Inputs of Append do not have the same width " ++ (show w1) ++ " " ++ (show w2) + v -> + Left $ "Input of Append is not a ValueVector " ++ (show v) + AppendS -> + case (s1, s2) of + (VProp (ValueVector w1), VProp (ValueVector w2)) | w1 == w2 -> + Right $ VPropTriple (ValueVector w1) RenameVector RenameVector + (VProp (ValueVector w1), VProp (ValueVector w2)) -> + Left $ "Inputs of Append do not have the same width " ++ (show w1) ++ " " ++ (show w2) + v -> + Left $ "Input of Append is not a ValueVector " ++ (show v) + + SelectPos _ -> liftM3 VPropTriple (unpack s1) (Right RenameVector) (Right RenameVector) + SelectPosS _ -> liftM3 VPropTriple (unpack s1) (Right RenameVector) (Right RenameVector) + Align -> + case (s1, s2) of + (VProp (ValueVector w1), VProp (ValueVector w2)) -> Right $ VProp $ ValueVector $ w1 + w2 + _ -> Left "Inputs of Align are not ValueVectors" + Zip -> + case (s1, s2) of + (VProp (ValueVector w1), VProp (ValueVector w2)) -> Right $ VProp $ ValueVector $ w1 + w2 + _ -> Left "Inputs of PairL are not ValueVectors" + ZipS -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) RenameVector RenameVector) "ZipL" + CartProduct -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) PropVector PropVector) "CartProduct" + CartProductS -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) PropVector PropVector) "CartProductS" + NestProductS -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) PropVector PropVector) "NestProductS" + ThetaJoin _ -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) PropVector PropVector) "ThetaJoin" + UnboxScalar -> reqValVectors s1 s2 (\w1 w2 -> VProp $ ValueVector $ w1 + w2) "UnboxScalar" + NestJoin _ -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) PropVector PropVector) "NestJoin" + NestProduct -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) PropVector PropVector) "NestProduct" + ThetaJoinS _ -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) PropVector PropVector) "ThetaJoinS" + NestJoinS _ -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (ValueVector $ w1 + w2) PropVector PropVector) "NestJoinS" + SemiJoin _ -> liftM2 VPropPair (unpack s1) (Right RenameVector) + SemiJoinS _ -> liftM2 VPropPair (unpack s1) (Right RenameVector) + AntiJoin _ -> liftM2 VPropPair (unpack s1) (Right RenameVector) + AntiJoinS _ -> liftM2 VPropPair (unpack s1) (Right RenameVector) + + TransposeS -> liftM2 VPropPair (return $ ValueVector 0) (unpack s2) + +inferVectorTypeTerOp :: VectorProp VectorType -> VectorProp VectorType -> VectorProp VectorType -> TerOp -> Either String (VectorProp VectorType) +inferVectorTypeTerOp _ s2 s3 op = + case op of + Combine -> + case (s2, s3) of + (VProp (ValueVector w1), VProp (ValueVector w2)) | w1 == w2 -> + Right $ VPropTriple (ValueVector w1) RenameVector RenameVector + (VProp (ValueVector _), VProp (ValueVector _)) -> + Left $ "Inputs of CombineVec do not have the same width" + _ -> + Left $ "Inputs of CombineVec are not ValueVectors/DescrVectors " ++ (show (s2, s3)) diff --git a/src/Database/DSH/Optimizer/VL/Rewrite/Aggregation.hs b/src/Database/DSH/Optimizer/VL/Rewrite/Aggregation.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Rewrite/Aggregation.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE TemplateHaskell #-} +module Database.DSH.Optimizer.VL.Rewrite.Aggregation(groupingToAggregation) where + +import Control.Applicative +import Control.Monad +import qualified Data.List.NonEmpty as N +import Data.Semigroup + +import Database.Algebra.Dag.Common + +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Rewrite.Common +import Database.DSH.VL.Lang + +aggregationRules :: VLRuleSet () +aggregationRules = [ inlineAggrSProject + , inlineAggrProject + , inlineAggrNonEmptyProject + , inlineAggrSNonEmptyProject + , flatGrouping + , mergeNonEmptyAggrs + , mergeGroupAggr + , mergeGroupWithGroupAggrLeft + ] + +aggregationRulesBottomUp :: VLRuleSet BottomUpProps +aggregationRulesBottomUp = [ nonEmptyAggr + , nonEmptyAggrS + ] + +groupingToAggregation :: VLRewrite Bool +groupingToAggregation = iteratively $ sequenceRewrites [ applyToAll inferBottomUp aggregationRulesBottomUp + , applyToAll noProps aggregationRules + ] + +-- FIXME this rewrite will no longer work: take the UnboxScalarS +-- operator into account. +mergeNonEmptyAggrs :: VLRule () +mergeNonEmptyAggrs q = + $(dagPatMatch 'q "(AggrNonEmptyS afuns1 (qi1)) Zip (AggrNonEmptyS afuns2 (qi2))" + [| do + predicate $ $(v "qi1") == $(v "qi2") + + return $ do + logRewrite "Aggregation.NonEmpty.Merge" q + let afuns = $(v "afuns1") <> $(v "afuns2") + let aggrOp = UnOp (AggrNonEmptyS afuns) $(v "qi1") + void $ replaceWithNew q aggrOp |]) + +-- | If we can infer that the vector is not empty, we can employ a +-- simplified version of the aggregate operator that does not add a +-- default value for an empty input. +nonEmptyAggr :: VLRule BottomUpProps +nonEmptyAggr q = + $(dagPatMatch 'q "Aggr aggrFun (q1)" + [| do + VProp True <- nonEmptyProp <$> properties $(v "q1") + + return $ do + logRewrite "Aggregation.NonEmpty.Aggr" q + let aggrOp = UnOp (AggrNonEmpty ($(v "aggrFun") N.:| [])) $(v "q1") + void $ replaceWithNew q aggrOp |]) + +-- | If we can infer that all segments (if there are any) are not +-- empty, we can employ a simplified version of the aggregate operator +-- that does not add default values for empty segments. +nonEmptyAggrS :: VLRule BottomUpProps +nonEmptyAggrS q = + $(dagPatMatch 'q "(_) AggrS aggrFun (q2)" + [| do + VProp True <- nonEmptyProp <$> properties $(v "q2") + + return $ do + logRewrite "Aggregation.NonEmpty.AggrS" q + let aggrOp = UnOp (AggrNonEmptyS ($(v "aggrFun") N.:| [])) $(v "q2") + void $ replaceWithNew q aggrOp |]) + +-- | Merge a projection into a segmented aggregate operator. +inlineAggrProject :: VLRule () +inlineAggrProject q = + $(dagPatMatch 'q "Aggr afun (Project proj (qi))" + [| do + let env = zip [1..] $(v "proj") + let afun' = mapAggrFun (mergeExpr env) $(v "afun") + + return $ do + logRewrite "Aggregation.Normalize.Aggr.Project" q + void $ replaceWithNew q $ UnOp (Aggr afun') $(v "qi") |]) + +-- | Merge a projection into a segmented aggregate operator. +inlineAggrSProject :: VLRule () +inlineAggrSProject q = + $(dagPatMatch 'q "(qo) AggrS afun (Project proj (qi))" + [| do + let env = zip [1..] $(v "proj") + let afun' = mapAggrFun (mergeExpr env) $(v "afun") + + return $ do + logRewrite "Aggregation.Normalize.AggrS.Project" q + void $ replaceWithNew q $ BinOp (AggrS afun') $(v "qo") $(v "qi") |]) + +-- | Merge a projection into a non-empty aggregate operator. We +-- restrict this to only one aggregate function. Therefore, merging of +-- projections must happen before merging of aggregate operators +inlineAggrNonEmptyProject :: VLRule () +inlineAggrNonEmptyProject q = + $(dagPatMatch 'q "AggrNonEmpty afuns (Project proj (qi))" + [| do + let env = zip [1..] $(v "proj") + let afuns' = fmap (mapAggrFun (mergeExpr env)) $(v "afuns") + + return $ do + logRewrite "Aggregation.Normalize.AggrNonEmpty.Project" q + let aggrOp = UnOp (AggrNonEmpty afuns') $(v "qi") + void $ replaceWithNew q aggrOp |]) + +-- | Merge a projection into a non-empty segmented aggregate +-- operator. We restrict this to only one aggregate +-- function. Therefore, merging of projections must happen before +-- merging of aggregate operators +inlineAggrSNonEmptyProject :: VLRule () +inlineAggrSNonEmptyProject q = + $(dagPatMatch 'q "AggrNonEmptyS afuns (Project proj (qi))" + [| do + let env = zip [1..] $(v "proj") + let afuns' = fmap (mapAggrFun (mergeExpr env)) $(v "afuns") + + return $ do + logRewrite "Aggregation.Normalize.AggrNonEmptyS.Project" q + let aggrOp = UnOp (AggrNonEmptyS afuns') $(v "qi") + void $ replaceWithNew q aggrOp |]) + +-- We rewrite a combination of GroupBy and aggregation operators into a single +-- VecAggr operator if the following conditions hold: +-- +-- 1. The R2 output of GroupBy is only consumed by aggregation operators (MaxL, +-- MinL, VecSumL, LengthSeg) +-- 2. The grouping criteria is a simple column projection from the input vector +flatGrouping :: VLRule () +flatGrouping q = + $(dagPatMatch 'q "(R1 (qg)) UnboxScalar (AggrNonEmptyS afuns (R2 (qg1=GroupS groupExprs (q1))))" + [| do + + -- Ensure that the aggregate results are unboxed using the + -- outer vector of the grouping operator. + predicate $ $(v "qg") == $(v "qg1") + + return $ do + logRewrite "Aggregation.Grouping.Aggr" q + void $ replaceWithNew q $ UnOp (GroupAggr ($(v "groupExprs"), $(v "afuns"))) $(v "q1") |]) + +mergeGroupAggr :: VLRule () +mergeGroupAggr q = + $(dagPatMatch 'q "(GroupAggr args1 (q1)) Align (GroupAggr args2 (q2))" + [| do + let (ges1, afuns1) = $(v "args1") + let (ges2, afuns2) = $(v "args2") + + -- The rewrite can be applied if the same input is grouped + -- according to the same grouping expressions. + predicate $ ges1 == ges2 + predicate $ $(v "q1") == $(v "q2") + + return $ do + logRewrite "Aggregation.Normalize.MergeGroupAggr" q + groupNode <- insert $ UnOp (GroupAggr ($(v "ges1"), ($(v "afuns1") <> $(v "afuns2")))) $(v "q1") + + -- Reconstruct the schema produced by Zip. Note that this + -- duplicates the grouping columns. + let groupWidth = length $(v "ges1") + aggrWidth1 = N.length afuns1 + aggrWidth2 = N.length afuns2 + groupCols = [ Column c | c <- [1 .. groupWidth]] + + let proj = groupCols + ++ + [ Column $ c + groupWidth | c <- [1 .. aggrWidth1] ] + ++ + groupCols + ++ + [ Column $ c + groupWidth + aggrWidth1 | c <- [1 .. aggrWidth2] ] + + void $ replaceWithNew q $ UnOp (Project proj) groupNode |]) + +-- | This is a cleanup rewrite: It applies in a situation when +-- aggregates have already been merged with GroupScalarS into +-- GroupAggr. If the GroupAggr output is combined with the R1 output +-- of GroupScalarS on the same input and grouping expressions via Zip, +-- the effect is that only the grouping expressions are duplicated. +mergeGroupWithGroupAggrLeft :: VLRule () +mergeGroupWithGroupAggrLeft q = + $(dagPatMatch 'q "(R1 (GroupS ges (q1))) Align (GroupAggr args (q2))" + [| do + let (ges', afuns) = $(v "args") + + -- Input vectors and grouping expressions have to be the same. + predicate $ $(v "q1") == $(v "q2") + predicate $ $(v "ges") == ges' + + return $ do + logRewrite "Aggregation.Normalize.MergeGroupScalars" q + + -- To keep the schema, we have to duplicate the grouping + -- columns. + let groupWidth = length ges' + aggrWidth = N.length afuns + groupCols = [ Column c | c <- [1..groupWidth] ] + proj = groupCols + ++ + groupCols + ++ + [ Column $ c + groupWidth | c <- [1..aggrWidth] ] + + groupNode <- insert $ UnOp (GroupAggr (ges', afuns)) $(v "q1") + void $ replaceWithNew q $ UnOp (Project proj) groupNode |]) + + diff --git a/src/Database/DSH/Optimizer/VL/Rewrite/Common.hs b/src/Database/DSH/Optimizer/VL/Rewrite/Common.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Rewrite/Common.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TemplateHaskell #-} +module Database.DSH.Optimizer.VL.Rewrite.Common where + +import qualified Data.IntMap as M + +import Control.Monad + +import Database.Algebra.Dag.Common + +import Database.DSH.Common.QueryPlan +import Database.DSH.Impossible + +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.VL.Lang +import Database.DSH.VL.Vector + +import Database.DSH.Optimizer.VL.Properties.BottomUp +import Database.DSH.Optimizer.VL.Properties.TopDown +import Database.DSH.Optimizer.VL.Properties.Types + + -- Type abbreviations for convenience +type VLRewrite p = Rewrite VL (Shape VLDVec) p +type VLRule p = Rule VL p (Shape VLDVec) +type VLRuleSet p = RuleSet VL p (Shape VLDVec) +type VLMatch p = Match VL p (Shape VLDVec) + +inferBottomUp :: VLRewrite (NodeMap BottomUpProps) +inferBottomUp = do + props <- infer inferBottomUpProperties + return props + +inferTopDown :: VLRewrite (NodeMap TopDownProps) +inferTopDown = do + to <- topsort + buPropMap <- infer inferBottomUpProperties + props <- infer (inferTopDownProperties buPropMap to) + return props + +inferProperties :: VLRewrite (NodeMap Properties) +inferProperties = do + buMap <- inferBottomUp + tdMap <- inferTopDown + return $ M.intersectionWith Properties buMap tdMap + +noProps :: Monad m => m (M.IntMap a) +noProps = return M.empty + +--------------------------------------------------------------------------------- +-- Rewrite helper functions + +lookupR1Parents :: AlgNode -> VLRewrite [AlgNode] +lookupR1Parents q = do + let isR1 q' = do + o <- operator q' + case o of + UnOp R1 _ -> return True + _ -> return False + + ps <- parents q + filterM isR1 ps + +lookupR2Parents :: AlgNode -> VLRewrite [AlgNode] +lookupR2Parents q = do + let isR2 q' = do + o <- operator q' + case o of + UnOp R2 _ -> return True + _ -> return False + + ps <- parents q + filterM isR2 ps + +mergeExpr :: [(DBCol, Expr)] -> Expr -> Expr +mergeExpr env expr = + case expr of + BinApp o e1 e2 -> BinApp o (mergeExpr env e1) (mergeExpr env e2) + UnApp o e1 -> UnApp o (mergeExpr env e1) + Column c -> case lookup c env of + Just expr' -> expr' + Nothing -> $impossible + If c t e -> If (mergeExpr env c) (mergeExpr env t) (mergeExpr env e) + Constant _ -> expr + +-- | Unwrap a constant value +constVal :: Monad m => (VLVal -> a) -> ConstPayload -> m a +constVal wrap (ConstPL val) = return $ wrap val +constVal _ _ = fail "no match" + +mapAggrFun :: (Expr -> Expr) -> AggrFun -> AggrFun +mapAggrFun f (AggrMax e) = AggrMax $ f e +mapAggrFun f (AggrSum t e) = AggrSum t $ f e +mapAggrFun f (AggrMin e) = AggrMin $ f e +mapAggrFun f (AggrAvg e) = AggrAvg $ f e +mapAggrFun f (AggrAny e) = AggrAny $ f e +mapAggrFun f (AggrAll e) = AggrAll $ f e +mapAggrFun _ AggrCount = AggrCount + +mapWinFun :: (Expr -> Expr) -> WinFun -> WinFun +mapWinFun f (WinMax e) = WinMax $ f e +mapWinFun f (WinSum e) = WinSum $ f e +mapWinFun f (WinMin e) = WinMin $ f e +mapWinFun f (WinAvg e) = WinAvg $ f e +mapWinFun f (WinAny e) = WinAny $ f e +mapWinFun f (WinAll e) = WinAll $ f e +mapWinFun f (WinFirstValue e) = WinFirstValue $ f e +mapWinFun _ WinCount = WinCount + +mapExprCols :: (DBCol -> DBCol) -> Expr -> Expr +mapExprCols f (BinApp op e1 e2) = BinApp op (mapExprCols f e1) (mapExprCols f e2) +mapExprCols f (UnApp op e) = UnApp op (mapExprCols f e) +mapExprCols f (Column c) = Column $ f c +mapExprCols _ (Constant val) = Constant val +mapExprCols f (If c t e) = If (mapExprCols f c) + (mapExprCols f t) + (mapExprCols f e) diff --git a/src/Database/DSH/Optimizer/VL/Rewrite/Expressions.hs b/src/Database/DSH/Optimizer/VL/Rewrite/Expressions.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Rewrite/Expressions.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ParallelListComp #-} + +module Database.DSH.Optimizer.VL.Rewrite.Expressions where + +-- This module contains rewrites which aim to simplify and merge complex expressions +-- which are expressed through multiple operators. + +import Control.Monad +import Control.Applicative +import Data.Maybe + +import Database.Algebra.Dag.Common + +import Database.DSH.VL.Lang +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Rewrite.Common + +optExpressions :: VLRewrite Bool +optExpressions = iteratively $ applyToAll inferBottomUp expressionRules + +expressionRules :: VLRuleSet BottomUpProps +expressionRules = [ mergeExpr1 + , identityProject + , mergeSelectProject + ] + +mergeExpr1 :: VLRule BottomUpProps +mergeExpr1 q = + $(dagPatMatch 'q "Project es1 (Project es2 (q1))" + [| do + + return $ do + logRewrite "Expr.Merge.11" q + let env = zip [1..] $(v "es2") + es1' = map (mergeExpr env) $(v "es1") + void $ replaceWithNew q $ UnOp (Project es1') $(v "q1") |]) + +mergeSelectProject :: VLRule BottomUpProps +mergeSelectProject q = + $(dagPatMatch 'q "R1 (qs=Select p (Project projs (q1)))" + [| do + return $ do + logRewrite "Expr.Merge.Select" q + let env = zip [1..] $(v "projs") + let p' = mergeExpr env $(v "p") + selectNode <- insert $ UnOp (Select p') $(v "q1") + r1Node <- insert $ UnOp R1 selectNode + void $ replaceWithNew q $ UnOp (Project $(v "projs")) r1Node + + r2Parents <- lookupR2Parents $(v "qs") + + -- If there are any R2 nodes linking to the original + -- Restrict operator (i.e. there are inner vectors to which + -- changes must be propagated), they have to be rewired to + -- the new Select operator. + when (not $ null r2Parents) $ do + qr2' <- insert $ UnOp R2 selectNode + mapM_ (\qr2 -> replace qr2 qr2') r2Parents |]) + +identityProject :: VLRule BottomUpProps +identityProject q = + $(dagPatMatch 'q "Project ps (q1)" + [| do + VProp (ValueVector w) <- vectorTypeProp <$> properties $(v "q1") + predicate $ length $(v "ps") == w + + let sameCol :: (Int, Expr) -> Bool + sameCol (i, Column i') = i == i' + sameCol _ = False + + predicate $ all sameCol (zip [1..] $(v "ps")) + + rs <- getRootNodes + predicate $ not $ q `elem` rs + + return $ do + logRewrite "Project.Identity" q + replace q $(v "q1") |]) + +------------------------------------------------------------------------------ +-- Constant expression inputs + +liftPairRight :: Monad m => (a, m b) -> m (a, b) +liftPairRight (a, mb) = mb >>= \b -> return (a, b) + +mapPair :: (a -> c) -> (b -> d) -> (a, b) -> (c, d) +mapPair f g (a, b) = (f a, g b) + +insertConstants :: [(DBCol, VLVal)] -> Expr -> Expr +insertConstants env expr = + case expr of + BinApp o e1 e2 -> BinApp o (insertConstants env e1) (insertConstants env e2) + UnApp o e1 -> UnApp o (insertConstants env e1) + Column c -> case lookup c env of + Just val -> Constant val + Nothing -> Column c + If c t e -> If (insertConstants env c) (insertConstants env t) (insertConstants env e) + Constant _ -> expr + +constProject :: VLRule BottomUpProps +constProject q = + $(dagPatMatch 'q "Project projs (q1)" + [| do + VProp (DBVConst _ constCols) <- constProp <$> properties $(v "q1") + let envEntry = liftPairRight . mapPair id (constVal id) + let constEnv = mapMaybe envEntry $ zip [1..] constCols + + predicate $ not $ null constEnv + + let projs' = map (insertConstants constEnv) $(v "projs") + + -- To avoid rewriting loops, ensure that a change occured. + predicate $ projs' /= $(v "projs") + + return $ do + logRewrite "Expr.Project.Const" q + void $ replaceWithNew q $ UnOp (Project projs') $(v "q1") |]) diff --git a/src/Database/DSH/Optimizer/VL/Rewrite/PruneEmpty.hs b/src/Database/DSH/Optimizer/VL/Rewrite/PruneEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Rewrite/PruneEmpty.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.VL.Rewrite.PruneEmpty(pruneEmpty) where + +import Control.Applicative +import Control.Monad + +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Rewrite.Common + +import Database.Algebra.Dag.Common +import Database.DSH.VL.Lang + +pruneEmpty :: VLRewrite Bool +pruneEmpty = applyToAll inferBottomUp emptyRules + +emptyRules :: VLRuleSet BottomUpProps +emptyRules = [ emptyAppendLeftR1 + -- , emptyAppendLeftR2 + -- , emptyAppendLeftR3 + , emptyAppendRightR1 + -- , emptyAppendRightR2 + -- , emptyAppendRightR3 + ] + +isEmpty :: AlgNode -> VLMatch BottomUpProps Bool +isEmpty q = do + ps <- liftM emptyProp $ properties q + case ps of + VProp b -> return b + x -> error $ "PruneEmpty.isEmpty: non-vector input " ++ show x + +{- If the left input is empty and the other is not, the resulting value vector +is simply the right input. -} +emptyAppendLeftR1 :: VLRule BottomUpProps +emptyAppendLeftR1 q = + $(dagPatMatch 'q "R1 ((q1) [Append | AppendS] (q2))" + [| do + predicate =<< ((&&) <$> (isEmpty $(v "q1")) <*> (not <$> isEmpty $(v "q2"))) + + return $ do + logRewrite "Empty.Append.Left.R1" q + replace q $(v "q2") |]) + +-- FIXME re-add rules when +{- +-- If the left input is empty, renaming will make the inner vector +-- empty as well. +emptyAppendLeftR2 :: VLRule BottomUpProps +emptyAppendLeftR2 q = + $(dagPatMatch 'q "(R2 ((q1) Append (q2))) PropRename (qv)" + [| do + predicate =<< ((&&) <$> (isEmpty $(v "q1")) <*> (not <$> isEmpty $(v "q2"))) + + VProp (ValueVector w) <- vectorTypeProp <$> properties $(v "qv") + + return $ do + logRewrite "Empty.Append.Left.R2" q + void $ replaceWithNew q (NullaryOp $ Empty w) |]) + +-- If the left input is empty, the rename vector for the right inner +-- vectors is simply identity +emptyAppendLeftR3 :: VLRule BottomUpProps +emptyAppendLeftR3 q = + $(dagPatMatch 'q "(R3 ((q1) Append (q2))) PropRename (qv)" + [| do + predicate =<< ((&&) <$> (isEmpty $(v "q1")) <*> (not <$> isEmpty $(v "q2"))) + + return $ do + logRewrite "Empty.Append.Left.R3" q + replace q $(v "qv") |]) +-} + +emptyAppendRightR1 :: VLRule BottomUpProps +emptyAppendRightR1 q = + $(dagPatMatch 'q "R1 ((q1) [Append | AppendS] (q2))" + [| do + predicate =<< ((&&) <$> (isEmpty $(v "q2")) <*> (not <$> isEmpty $(v "q1"))) + return $ do + logRewrite "Empty.Append.Right.R1" q + replace q $(v "q1") |]) + +{- +-- If the right input is empty, renaming will make the inner vector +-- empty as well. +emptyAppendRightR3 :: VLRule BottomUpProps +emptyAppendRightR3 q = + $(dagPatMatch 'q "(R3 ((q1) Append (q2))) PropRename (qv)" + [| do + predicate =<< ((&&) <$> (not <$> isEmpty $(v "q1")) <*> (isEmpty $(v "q2"))) + VProp (ValueVector w) <- vectorTypeProp <$> properties $(v "qv") + + return $ do + logRewrite "Empty.Append.Right.R3" q + void $ replaceWithNew q $ NullaryOp $ Empty w |]) + +-- If the right input is empty, the rename vector for the left inner +-- vectors is simply identity +emptyAppendRightR2 :: VLRule BottomUpProps +emptyAppendRightR2 q = + $(dagPatMatch 'q "(R2 ((q1) Append (q2))) PropRename (qv)" + [| do + predicate =<< ((&&) <$> (isEmpty $(v "q2")) <*> (not <$> isEmpty $(v "q1"))) + return $ do + logRewrite "Empty.Append.Right.R2" q + void $ replace q $(v "qv") |]) +-} diff --git a/src/Database/DSH/Optimizer/VL/Rewrite/Redundant.hs b/src/Database/DSH/Optimizer/VL/Rewrite/Redundant.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Rewrite/Redundant.hs @@ -0,0 +1,965 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Optimizer.VL.Rewrite.Redundant (removeRedundancy) where + +import Debug.Trace + +import Control.Applicative +import Control.Monad + +import Database.Algebra.Dag.Common + +import Database.DSH.Common.Lang +import Database.DSH.Impossible +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Properties.VectorType +import Database.DSH.Optimizer.VL.Rewrite.Common +import Database.DSH.Optimizer.VL.Rewrite.Expressions +import Database.DSH.Optimizer.VL.Rewrite.Aggregation +import Database.DSH.Optimizer.VL.Rewrite.Window +import Database.DSH.VL.Lang + +removeRedundancy :: VLRewrite Bool +removeRedundancy = + iteratively $ sequenceRewrites [ cleanup + , applyToAll noProps redundantRules + , applyToAll inferBottomUp redundantRulesBottomUp + , applyToAll inferProperties redundantRulesAllProps + , groupingToAggregation + ] + +cleanup :: VLRewrite Bool +cleanup = iteratively $ sequenceRewrites [ optExpressions ] + +redundantRules :: VLRuleSet () +redundantRules = [ pullProjectPropRename + , pullProjectPropReorder + , pullProjectSelectPos1S + , pullProjectPropFilter + , pullProjectUnboxRename + , pullProjectAggrS + , scalarConditional + ] + +redundantRulesBottomUp :: VLRuleSet BottomUpProps +redundantRulesBottomUp = [ cartProdConstant + , sameInputZip + , sameInputZipProject + , sameInputZipProjectLeft + , sameInputZipProjectRight + , zipProjectLeft + , zipProjectRight + , distLiftProjectLeft + , distLiftProjectRight + , distLiftNestProduct + , distLiftNestJoin + , distLiftStacked + , distLiftSelect + , alignedDistLift + , selectConstPos + , selectConstPosS + , zipConstLeft + , zipConstRight + , alignConstLeft + , alignConstRight + , zipZipLeft + , zipWinLeft + , zipWinRight + , zipWinRightPush + , zipUnboxScalarRight + , zipUnboxScalarLeft + , alignCartProdRight + , propProductCard1Right + , runningAggWin + , inlineWinAggrProject + , pullProjectNumber + , constDistLift + , nestJoinChain + , pullProjectUnboxScalarLeft + , pullProjectUnboxScalarRight + , pullProjectNestJoinLeft + , pullProjectNestJoinRight + , selectCartProd + ] + +redundantRulesAllProps :: VLRuleSet Properties +redundantRulesAllProps = [ unreferencedDistLift + , firstValueWin + , notReqNumber + ] + +-------------------------------------------------------------------------------- +-- + +-- | Replace a 'CartProduct' operator with a projection if its right +-- input is constant and has cardinality one. +cartProdConstant :: VLRule BottomUpProps +cartProdConstant q = + $(dagPatMatch 'q "R1 ((q1) CartProduct (q2))" + [| do + qvProps <- properties $(v "q2") + + VProp True <- return $ card1Prop qvProps + VProp (DBVConst _ cols) <- return $ constProp qvProps + constProjs <- mapM (constVal Constant) cols + + -- Preserve columns from the left input + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + let proj = map Column [1..w1] ++ constProjs + + return $ do + logRewrite "Redundant.CartProduct.Constant" q + void $ replaceWithNew q $ UnOp (Project proj) $(v "q1") |]) + +unwrapConstVal :: ConstPayload -> VLMatch p VLVal +unwrapConstVal (ConstPL val) = return val +unwrapConstVal NonConstPL = fail "not a constant" + +-- | If the left input of an distLift is constant, a normal projection +-- can be used because the DistLift operator keeps the shape of the right +-- input. +constDistLift :: VLRule BottomUpProps +constDistLift q = + $(dagPatMatch 'q "R1 ((q1) DistLift (q2))" + [| do + VProp (DBVConst _ constCols) <- constProp <$> properties $(v "q1") + VProp (ValueVector w) <- vectorTypeProp <$> properties $(v "q2") + constVals <- mapM unwrapConstVal constCols + + return $ do + logRewrite "Redundant.Const.DistLift" q + let proj = map Constant constVals ++ map Column [1..w] + void $ replaceWithNew q $ UnOp (Project proj) $(v "q2") |]) + +-- | If a vector is distributed over an inner vector in a segmented +-- way, check if the vector's columns are actually referenced/required +-- downstream. If not, we can remove the DistLift altogether, as the +-- shape of the inner vector is not changed by DistLift. +unreferencedDistLift :: VLRule Properties +unreferencedDistLift q = + $(dagPatMatch 'q "R1 ((q1) DistLift (q2))" + [| do + VProp (Just reqCols) <- reqColumnsProp <$> td <$> properties q + VProp (ValueVector w1) <- vectorTypeProp <$> bu <$> properties $(v "q1") + VProp (ValueVector w2) <- vectorTypeProp <$> bu <$> properties $(v "q2") + + -- Check that only columns from the right input are required + predicate $ all (> w1) reqCols + + return $ do + logRewrite "Redundant.Unreferenced.DistLift" q + + -- FIXME HACKHACKHACK + let padProj = [ Constant $ VLInt 0xdeadbeef | _ <- [1..w1] ] + ++ + [ Column i | i <- [1..w2] ] + + void $ replaceWithNew q $ UnOp (Project padProj) $(v "q2") |]) + +-- | Remove a DistLift if the outer vector is aligned with a +-- NestProduct that uses the same outer vector. +distLiftNestProduct :: VLRule BottomUpProps +distLiftNestProduct q = + $(dagPatMatch 'q "R1 ((qo) DistLift (R1 ((qo1) NestProduct (qi))))" + [| do + predicate $ $(v "qo") == $(v "qo1") + + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "qo") + w2 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "qi") + + return $ do + logRewrite "Redundant.DistLift.NestProduct" q + -- Preserve the original schema + let proj = map Column $ [1..w1] ++ [1..w1] ++ [w1+1..w1+w2] + prodNode <- insert $ BinOp NestProduct $(v "qo") $(v "qi") + r1Node <- insert $ UnOp R1 prodNode + void $ replaceWithNew q $ UnOp (Project proj) r1Node |]) + +-- | Remove a DistLift if the outer vector is aligned with a +-- NestJoin that uses the same outer vector. +distLiftNestJoin :: VLRule BottomUpProps +distLiftNestJoin q = + $(dagPatMatch 'q "R1 ((qo) DistLift (R1 ((qo1) NestJoin p (qi))))" + [| do + predicate $ $(v "qo") == $(v "qo1") + + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "qo") + w2 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "qi") + + return $ do + logRewrite "Redundant.DistLift.NestJoin" q + -- Preserve the original schema + let proj = map Column $ [1..w1] ++ [1..w1] ++ [w1+1..w1+w2] + prodNode <- insert $ BinOp (NestJoin $(v "p")) $(v "qo") $(v "qi") + r1Node <- insert $ UnOp R1 prodNode + void $ replaceWithNew q $ UnOp (Project proj) r1Node |]) + +distLiftProjectLeft :: VLRule BottomUpProps +distLiftProjectLeft q = + $(dagPatMatch 'q "R1 ((Project ps1 (q1)) DistLift (q2))" + [| do + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + w2 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q2") + + return $ do + logRewrite "Redundant.DistLift.Project.Left" q + -- Take the projection expressions from the left and the + -- shifted columns from the right. + let proj = $(v "ps1") ++ [ Column $ c + w1 | c <- [1 .. w2]] + distNode <- insert $ BinOp DistLift $(v "q1") $(v "q2") + r1Node <- insert $ UnOp R1 distNode + void $ replaceWithNew q $ UnOp (Project proj) r1Node |]) + +distLiftProjectRight :: VLRule BottomUpProps +distLiftProjectRight q = + $(dagPatMatch 'q "R1 ((q1) DistLift (Project p2 (q2)))" + [| do + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + + return $ do + logRewrite "Redundant.DistLift.Project.Right" q + -- Take the columns from the left and the expressions from + -- the right projection. Since expressions are applied after + -- the zip, their column references have to be shifted. + let proj = [Column c | c <- [1..w1]] ++ [ mapExprCols (+ w1) e | e <- $(v "p2") ] + distNode <- insert $ BinOp DistLift $(v "q1") $(v "q2") + r1Node <- insert $ UnOp R1 distNode + void $ replaceWithNew q $ UnOp (Project proj) r1Node |]) + +-- If the same outer vector is propagated twice to an inner vector, +-- one DistLift can be removed. Reasoning: DistLift does not change +-- the shape of the inner vector. +distLiftStacked :: VLRule BottomUpProps +distLiftStacked q = + $(dagPatMatch 'q "R1 ((q1) DistLift (r1=R1 ((q11) DistLift (q2))))" + [| do + predicate $ $(v "q1") == $(v "q11") + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + w2 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q2") + + return $ do + logRewrite "Redundant.DistLift.Stacked" q + let proj = map Column $ [1..w1] ++ [1..w1] ++ [w1+1..w1+w2] + void $ replaceWithNew q $ UnOp (Project proj) $(v "r1") |]) + +-- | Pull a selection through a DistLift. The reasoning for +-- correctness is simple: It does not matter wether an element of an +-- inner segment is removed before or after DistLift (on relational +-- level, DistLift maps to join which commutes with selection). The +-- "use case" for this rewrite is not well thought-through yet: We +-- want to push down DistLift to eliminate it or merge it with other +-- operators (e.g. DistLift.Stacked). The usual wisdom would suggest +-- to push selections down, though. +distLiftSelect :: VLRule BottomUpProps +distLiftSelect q = + $(dagPatMatch 'q "R1 ((q1) DistLift (R1 (Select p (q2))))" + [| do + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + return $ do + logRewrite "Redundant.DistLift.Select" q + let p' = shiftExprCols w1 $(v "p") + distNode <- insert $ BinOp DistLift $(v "q1") $(v "q2") + distR1 <- insert $ UnOp R1 distNode + selNode <- insert $ UnOp (Select p') distR1 + void $ replaceWithNew q $ UnOp R1 selNode |]) + +-- | When a DistLift result is aligned with the right (inner) DistLift +-- input, we can eliminate the Align. Reasoning: DistLift does not +-- change the shape of the vector, only adds columns from its right +-- input. +alignedDistLift :: VLRule BottomUpProps +alignedDistLift q = + $(dagPatMatch 'q "(q21) Align (qr1=R1 ((q1) DistLift (q22)))" + [| do + predicate $ $(v "q21") == $(v "q22") + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + w2 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q21") + + return $ do + logRewrite "Redundant.DistLift.Align" q + let proj = map Column $ + [w1+1..w1+w2] + ++ + [1..w1] + ++ + [w1+1..w1+w2] + void $ replaceWithNew q $ UnOp (Project proj) $(v "qr1") |]) + +-------------------------------------------------------------------------------- +-- Zip and Align rewrites. + +-- Note that the rewrites valid for Zip are a subset of the rewrites +-- valid for Align. In the case of Align, we statically know that both +-- inputs have the same length and can be positionally aligned without +-- discarding elements. + +-- | Replace a Zip operator with a projection if both inputs are the +-- same. +sameInputZip :: VLRule BottomUpProps +sameInputZip q = + $(dagPatMatch 'q "(q1) [Zip | Align] (q2)" + [| do + predicate $ $(v "q1") == $(v "q2") + w <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + + return $ do + logRewrite "Redundant.Zip/Align.Self" q + let ps = map Column [1 .. w] + void $ replaceWithNew q $ UnOp (Project (ps ++ ps)) $(v "q1") |]) + +sameInputZipProject :: VLRule BottomUpProps +sameInputZipProject q = + $(dagPatMatch 'q "(Project ps1 (q1)) [Zip | Align] (Project ps2 (q2))" + [| do + predicate $ $(v "q1") == $(v "q2") + + return $ do + logRewrite "Redundant.Zip/Align.Self.Project" q + void $ replaceWithNew q $ UnOp (Project ($(v "ps1") ++ $(v "ps2"))) $(v "q1") |]) + +sameInputZipProjectLeft :: VLRule BottomUpProps +sameInputZipProjectLeft q = + $(dagPatMatch 'q "(Project ps1 (q1)) [Zip | Align] (q2)" + [| do + predicate $ $(v "q1") == $(v "q2") + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + + return $ do + logRewrite "Redundant.Zip/Align.Self.Project.Left" q + let proj = $(v "ps1") ++ (map Column [1..w1]) + void $ replaceWithNew q $ UnOp (Project proj) $(v "q1") |]) + +sameInputZipProjectRight :: VLRule BottomUpProps +sameInputZipProjectRight q = + $(dagPatMatch 'q "(q1) [Zip | Align] (Project ps2 (q2))" + [| do + predicate $ $(v "q1") == $(v "q2") + w <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + + return $ do + logRewrite "Redundant.Zip/Align.Self.Project.Right" q + let proj = (map Column [1 .. w]) ++ $(v "ps2") + void $ replaceWithNew q $ UnOp (Project proj) $(v "q1") |]) + +zipProjectLeft :: VLRule BottomUpProps +zipProjectLeft q = + $(dagPatMatch 'q "(Project ps1 (q1)) [Zip | Align]@op (q2)" + [| do + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + w2 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q2") + + return $ do + logRewrite "Redundant.Zip/Align.Project.Left" q + -- Take the projection expressions from the left and the + -- shifted columns from the right. + let proj = $(v "ps1") ++ [ Column $ c + w1 | c <- [1 .. w2]] + zipNode <- insert $ BinOp $(v "op") $(v "q1") $(v "q2") + void $ replaceWithNew q $ UnOp (Project proj) zipNode |]) + +zipProjectRight :: VLRule BottomUpProps +zipProjectRight q = + $(dagPatMatch 'q "(q1) [Zip | Align]@op (Project p2 (q2))" + [| do + w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1") + + return $ do + logRewrite "Redundant.Zip/Align.Project.Right" q + -- Take the columns from the left and the expressions from + -- the right projection. Since expressions are applied after + -- the zip, their column references have to be shifted. + let proj = [Column c | c <- [1..w1]] ++ [ mapExprCols (+ w1) e | e <- $(v "p2") ] + zipNode <- insert $ BinOp $(v "op") $(v "q1") $(v "q2") + void $ replaceWithNew q $ UnOp (Project proj) zipNode |]) + +fromConst :: Monad m => ConstPayload -> m VLVal +fromConst (ConstPL val) = return val +fromConst NonConstPL = fail "not a constant" + +-- | This rewrite is valid because we statically know that both +-- vectors have the same length. +alignConstLeft :: VLRule BottomUpProps +alignConstLeft q = + $(dagPatMatch 'q "(q1) Align (q2)" + [| do + VProp (DBVConst _ ps) <- constProp <$> properties $(v "q1") + w2 <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2") + + vals <- mapM fromConst ps + + return $ do + logRewrite "Redundant.Align.Constant.Left" q + let proj = map Constant vals ++ map Column [1..w2] + void $ replaceWithNew q $ UnOp (Project proj) $(v "q2") |]) + +alignConstRight :: VLRule BottomUpProps +alignConstRight q = + $(dagPatMatch 'q "(q1) Align (q2)" + [| do + w1 <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + VProp (DBVConst _ ps) <- constProp <$> properties $(v "q2") + + + vals <- mapM fromConst ps + + return $ do + logRewrite "Redundant.Align.Constant.Right" q + let proj = map Column [1..w1] ++ map Constant vals + void $ replaceWithNew q $ UnOp (Project proj) $(v "q1") |]) + +-- | In contrast to the 'Align' version ('alignConstLeft') this +-- rewrite is only valid if we can statically determine that both +-- input vectors have the same length. If the constant vector was +-- shorter, overhanging elements from the non-constant vector would +-- need to be discarded. In general, we can only determine equal +-- length for the special case of length one. +zipConstLeft :: VLRule BottomUpProps +zipConstLeft q = + $(dagPatMatch 'q "(q1) Zip (q2)" + [| do + prop1 <- properties $(v "q1") + VProp card1 <- return $ card1Prop prop1 + VProp (DBVConst _ ps) <- return $ constProp prop1 + + prop2 <- properties $(v "q2") + VProp card2 <- return $ card1Prop prop2 + w2 <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2") + + vals <- mapM fromConst ps + predicate $ card1 && card2 + + return $ do + logRewrite "Redundant.Zip.Constant.Left" q + let proj = map Constant vals ++ map Column [1..w2] + void $ replaceWithNew q $ UnOp (Project proj) $(v "q2") |]) + +zipConstRight :: VLRule BottomUpProps +zipConstRight q = + $(dagPatMatch 'q "(q1) Zip (q2)" + [| do + prop1 <- properties $(v "q1") + VProp card1 <- return $ card1Prop prop1 + w1 <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + prop2 <- properties $(v "q2") + VProp card2 <- return $ card1Prop prop2 + VProp (DBVConst _ ps) <- return $ constProp prop2 + + + vals <- mapM fromConst ps + predicate $ card1 && card2 + + return $ do + logRewrite "Redundant.Zip.Constant.Right" q + let proj = map Column [1..w1] ++ map Constant vals + void $ replaceWithNew q $ UnOp (Project proj) $(v "q1") |]) + +zipZipLeft :: VLRule BottomUpProps +zipZipLeft q = + $(dagPatMatch 'q "(q1) Zip (qz=(q11) [Zip | Align] (_))" + [| do + predicate $ $(v "q1") == $(v "q11") + + w1 <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + wz <- vectorWidth <$> vectorTypeProp <$> properties $(v "qz") + + return $ do + logRewrite "Redundant.Zip/Align.Zip.Left" q + let proj = map Column $ [1..w1] ++ [1..wz] + void $ replaceWithNew q $ UnOp (Project proj) $(v "qz") |]) + +zipWinRight :: VLRule BottomUpProps +zipWinRight q = + $(dagPatMatch 'q "(q1) [Zip | Align] (qw=WinFun _ (q2))" + [| do + predicate $ $(v "q1") == $(v "q2") + + w <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + return $ do + logRewrite "Redundant.Zip.Self.Win.Right" q + -- We get all columns from the left input. The WinAggr + -- operator produces the input column followed the window + -- function result. + let proj = map Column $ [1 .. w] ++ [1 .. w] ++ [w+1] + logGeneral ("zipWinRight " ++ show proj) + void $ replaceWithNew q $ UnOp (Project proj) $(v "qw") |]) + +zipWinLeft :: VLRule BottomUpProps +zipWinLeft q = + $(dagPatMatch 'q "(qw=WinFun _ (q1)) [Zip | Align] (q2)" + [| do + predicate $ $(v "q1") == $(v "q2") + + w <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + return $ do + logRewrite "Redundant.Zip.Self.Win.Left" q + -- We get all input columns plus the window function + -- output from the left. From the right we get all input + -- columns. + let proj = map Column $ [1 .. w] ++ [w+1] ++ [1 .. w] + void $ replaceWithNew q $ UnOp (Project proj) $(v "qw") |]) + +isPrecedingFrameSpec :: FrameSpec -> Bool +isPrecedingFrameSpec fs = + case fs of + FAllPreceding -> True + FNPreceding _ -> True + +zipWinRightPush :: VLRule BottomUpProps +zipWinRightPush q = + $(dagPatMatch 'q "(q1) Zip (WinFun args (q2))" + [| do + let (winFun, frameSpec) = $(v "args") + predicate $ isPrecedingFrameSpec frameSpec + w1 <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + return $ do + logRewrite "Redundant.Zip.Win.Right" q + zipNode <- insert $ BinOp Zip $(v "q1") $(v "q2") + let winFun' = mapWinFun (mapExprCols (\c -> c + w1)) winFun + args' = (winFun', frameSpec) + void $ replaceWithNew q $ UnOp (WinFun args') zipNode |]) + +-- | If singleton scalar elements in an inner vector (with singleton +-- segments) are unboxed using an outer vector and then zipped with +-- the same outer vector, we can eliminate the zip, because the +-- positional alignment is implicitly performed by the UnboxScalar +-- operator. We exploit the fact that UnboxScalar is only a +-- specialized join which nevertheless produces payload columns from +-- both inputs. +zipUnboxScalarRight :: VLRule BottomUpProps +zipUnboxScalarRight q = + $(dagPatMatch 'q "(q11) Align (qu=(q12) UnboxScalar (q2))" + [| do + predicate $ $(v "q11") == $(v "q12") + + leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q11") + rightWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2") + + return $ do + logRewrite "Redundant.Align.UnboxScalar.Right" q + + + -- Keep the original schema intact by duplicating columns + -- from the left input (UnboxScalar produces columns from + -- its left and right inputs). + let outputCols = -- Two times the left input columns + [1..leftWidth] ++ [1..leftWidth] + -- Followed by the right input columns + ++ [ leftWidth+1..rightWidth+leftWidth ] + proj = map Column outputCols + + -- Keep only the unboxing operator, together with a + -- projection that keeps the original output schema + -- intact. + void $ replaceWithNew q $ UnOp (Project proj) $(v "qu") |]) + +-- | See Align.UnboxScalar.Right +zipUnboxScalarLeft :: VLRule BottomUpProps +zipUnboxScalarLeft q = + $(dagPatMatch 'q "(qu=(q11) UnboxScalar (q2)) Align (q12)" + [| do + predicate $ $(v "q11") == $(v "q12") + + leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q11") + rightWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2") + + return $ do + logRewrite "Redundant.Align.UnboxScalar.Left" q + + + -- Keep the original schema intact by duplicating columns + -- from the left input (UnboxScalar produces columns from + -- its left and right inputs). + let outputCols = -- The left (outer) columns + [1..leftWidth] + -- Followed by the right (inner) input columns + ++ [ leftWidth+1..rightWidth+leftWidth ] + -- Followed by the left (outer columns) again + -- (originally produced by Align) + ++ [1..leftWidth] + proj = map Column outputCols + + -- Keep only the unboxing operator, together with a + -- projection that keeps the original output schema + -- intact. + void $ replaceWithNew q $ UnOp (Project proj) $(v "qu") |]) + +-- | A CartProduct output is aligned with some other vector. If one of +-- the CartProduct inputs has cardinality one, the other CartProduct +-- input determines the length of the result vector. From the original +-- structure we can derive that 'q11' and the CartProduct result are +-- aligned. Consequentially, 'q11 and 'q12' (the left CartProduct +-- input) must be aligned as well. +alignCartProdRight :: VLRule BottomUpProps +alignCartProdRight q = + $(dagPatMatch 'q "(q11) Align (R1 ((q12) CartProduct (q2)))" + [| do + VProp True <- card1Prop <$> properties $(v "q2") + return $ do + logRewrite "Redundant.Align.CartProduct.Card1.Right" q + alignNode <- insert $ BinOp Align $(v "q11") $(v "q12") + prodNode <- insert $ BinOp CartProduct alignNode $(v "q2") + void $ replaceWithNew q $ UnOp R1 prodNode |]) + +-------------------------------------------------------------------------------- +-- Scalar conditionals + +-- | Under a number of conditions, a combination of Combine and Select +-- (Restrict) operators implements a scalar conditional that can be +-- simply mapped to an 'if' expression evaluated on the input vector. +scalarConditional :: VLRule () +scalarConditional q = + $(dagPatMatch 'q "R1 (Combine (Project predProj (q1)) (Project thenProj (R1 (Select pred2 (q2)))) (Project elseProj (R1 (Select negPred (q3)))))" + [| do + -- All branches must work on the same input vector + predicate $ $(v "q1") == $(v "q2") && $(v "q1") == $(v "q3") + + -- The condition projection as well as the projections for + -- then and else branches must produce single columns. + [predExpr] <- return $(v "predProj") + [thenExpr] <- return $(v "thenProj") + [elseExpr] <- return $(v "elseProj") + + -- The condition for the boolean vector must be the same as + -- the selection condition for the then-branch. + predicate $ predExpr == $(v "pred2") + + -- The selection condition must be the negated form of the + -- then-condition. + predicate $ (UnApp (SUBoolOp Not) predExpr) == $(v "negPred") + + return $ do + logRewrite "Redundant.ScalarConditional" q + void $ replaceWithNew q $ UnOp (Project [If predExpr thenExpr elseExpr]) $(v "q1") |]) + +------------------------------------------------------------------------------ +-- Projection pullup + +inlineJoinPredLeft :: [(DBCol, Expr)] -> JoinPredicate Expr -> JoinPredicate Expr +inlineJoinPredLeft env (JoinPred conjs) = JoinPred $ fmap inlineLeft conjs + where + inlineLeft :: JoinConjunct Expr -> JoinConjunct Expr + inlineLeft (JoinConjunct le op re) = JoinConjunct (mergeExpr env le) op re + +inlineJoinPredRight :: [(DBCol, Expr)] -> JoinPredicate Expr -> JoinPredicate Expr +inlineJoinPredRight env (JoinPred conjs) = JoinPred $ fmap inlineRight conjs + where + inlineRight :: JoinConjunct Expr -> JoinConjunct Expr + inlineRight (JoinConjunct le op re) = JoinConjunct le op (mergeExpr env re) + +pullProjectNestJoinLeft :: VLRule BottomUpProps +pullProjectNestJoinLeft q = + $(dagPatMatch 'q "R1 ((Project proj (q1)) NestJoin p (q2))" + [| do + leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + rightWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2") + + return $ do + logRewrite "Redundant.Project.NestJoin.Left" q + let proj' = $(v "proj") ++ map Column [leftWidth + 1 .. leftWidth + rightWidth] + p' = inlineJoinPredLeft (zip [1..] $(v "proj")) $(v "p") + + joinNode <- insert $ BinOp (NestJoin p') $(v "q1") $(v "q2") + r1Node <- insert $ UnOp R1 joinNode + void $ replaceWithNew q $ UnOp (Project proj') r1Node + + -- FIXME relink R2 and R3 parents + |]) + +pullProjectNestJoinRight :: VLRule BottomUpProps +pullProjectNestJoinRight q = + $(dagPatMatch 'q "R1 ((q1) NestJoin p (Project proj (q2)))" + [| do + leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + return $ do + logRewrite "Redundant.Project.NestJoin.Right" q + let proj' = map Column [1..leftWidth] ++ map (shiftExprCols leftWidth) $(v "proj") + p' = inlineJoinPredRight (zip [1..] $(v "proj")) $(v "p") + + joinNode <- insert $ BinOp (NestJoin p') $(v "q1") $(v "q2") + r1Node <- insert $ UnOp R1 joinNode + void $ replaceWithNew q $ UnOp (Project proj') r1Node + + -- FIXME relink R2 and R3 parents + |]) + + +pullProjectNumber :: VLRule BottomUpProps +pullProjectNumber q = + $(dagPatMatch 'q "Number (Project proj (q1))" + [| do + w <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + return $ do + logRewrite "Redundant.Project.Number" q + + -- We have to preserve the numbering column in the + -- pulled-up projection. + let proj' = $(v "proj") ++ [Column $ w + 1] + numberNode <- insert $ UnOp Number $(v "q1") + void $ replaceWithNew q $ UnOp (Project proj') numberNode |]) + +-- Motivation: In order to eliminate or pull up sorting operations in +-- VL rewrites or subsequent stages, payload columns which might +-- induce sort order should be available as long as possible. We +-- assume that the cost of having unrequired columns around is +-- negligible (best case: column store). + +pullProjectPropRename :: VLRule () +pullProjectPropRename q = + $(dagPatMatch 'q "(qp) PropRename (Project proj (qv))" + [| do + return $ do + logRewrite "Redundant.Project.PropRename" q + renameNode <- insert $ BinOp PropRename $(v "qp") $(v "qv") + void $ replaceWithNew q $ UnOp (Project $(v "proj")) renameNode |]) + +pullProjectUnboxScalarLeft :: VLRule BottomUpProps +pullProjectUnboxScalarLeft q = + $(dagPatMatch 'q "(Project proj (q1)) UnboxScalar (q2)" + [| do + leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + rightWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2") + + return $ do + logRewrite "Redundant.Project.UnboxScalar" q + + -- Employ projection expressions on top of the unboxing + -- operator, add right input columns. + let proj' = $(v "proj") ++ map Column [ leftWidth + 1 .. leftWidth + rightWidth ] + unboxNode <- insert $ BinOp UnboxScalar $(v "q1") $(v "q2") + + void $ replaceWithNew q $ UnOp (Project proj') unboxNode |]) + +pullProjectUnboxScalarRight :: VLRule BottomUpProps +pullProjectUnboxScalarRight q = + $(dagPatMatch 'q "(q1) UnboxScalar (Project proj (q2))" + [| do + leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + return $ do + logRewrite "Redundant.Project.UnboxScalar" q + + -- Preserve left input columns on top of the unboxing + -- operator and add right input expressions with shifted + -- columns. + let proj' = map Column [1..leftWidth] + ++ + [ mapExprCols (+ leftWidth) e | e <- $(v "proj") ] + + unboxNode <- insert $ BinOp UnboxScalar $(v "q1") $(v "q2") + + void $ replaceWithNew q $ UnOp (Project proj') unboxNode |]) + +pullProjectPropReorder :: VLRule () +pullProjectPropReorder q = + $(dagPatMatch 'q "R1 ((qp) PropReorder (Project proj (qv)))" + [| do + return $ do + logRewrite "Redundant.Project.Reorder" q + reorderNode <- insert $ BinOp PropReorder $(v "qp") $(v "qv") + r1Node <- insert $ UnOp R1 reorderNode + void $ replaceWithNew q $ UnOp (Project $(v "proj")) r1Node |]) + +pullProjectSelectPos1S :: VLRule () +pullProjectSelectPos1S q = + $(dagPatMatch 'q "R1 (qs=SelectPos1S args (Project proj (q1)))" + [| do + return $ do + logRewrite "Redundant.Project.SelectPos1S" q + selectNode <- insert $ UnOp (SelectPos1S $(v "args")) $(v "q1") + r1Node <- insert $ UnOp R1 selectNode + void $ replaceWithNew q $ UnOp (Project $(v "proj")) r1Node |]) + +pullProjectPropFilter :: VLRule () +pullProjectPropFilter q = + $(dagPatMatch 'q "R1 ((q1) PropFilter (Project proj (q2)))" + [| do + return $ do + logRewrite "Redundant.Project.PropFilter" q + filterNode <- insert $ BinOp PropFilter $(v "q1") $(v "q2") + r1Node <- insert $ UnOp R1 filterNode + void $ replaceWithNew q $ UnOp (Project $(v "proj")) r1Node |]) + +pullProjectUnboxRename :: VLRule () +pullProjectUnboxRename q = + $(dagPatMatch 'q "UnboxRename (Project _ (q1))" + [| do + return $ do + logRewrite "Redundant.Project.UnboxRename" q + void $ replaceWithNew q $ UnOp UnboxRename $(v "q1") |]) + +-- | Any projections on the left input of AggrS are irrelevant, as +-- only the segment information are required from the vector. +pullProjectAggrS :: VLRule () +pullProjectAggrS q = + $(dagPatMatch 'q "(Project _ (q1)) AggrS args (q2)" + [| do + return $ do + logRewrite "Redundant.Project.AggrS" q + void $ replaceWithNew q $ BinOp (AggrS $(v "args")) $(v "q1") $(v "q2") |]) + +-------------------------------------------------------------------------------- +-- Positional selection on constants + +selectConstPos :: VLRule BottomUpProps +selectConstPos q = + $(dagPatMatch 'q "(q1) SelectPos op (qp)" + [| do + VProp (DBVConst _ constCols) <- constProp <$> properties $(v "qp") + pos <- case constCols of + [ConstPL (VLInt p)] -> return p + [NonConstPL] -> fail "no match" + _ -> $impossible + + return $ do + logRewrite "Redundant.SelectPos.Constant" q + void $ replaceWithNew q $ UnOp (SelectPos1 ($(v "op"), pos)) $(v "q1") |]) + +selectConstPosS :: VLRule BottomUpProps +selectConstPosS q = + $(dagPatMatch 'q "(q1) SelectPosS op (qp)" + [| do + VProp (DBVConst _ constCols) <- constProp <$> properties $(v "qp") + pos <- case constCols of + [ConstPL (VLInt p)] -> return p + [NonConstPL] -> fail "no match" + _ -> $impossible + + return $ do + logRewrite "Redundant.SelectPosS.Constant" q + void $ replaceWithNew q $ UnOp (SelectPos1S ($(v "op"), pos)) $(v "q1") |]) + +-------------------------------------------------------------------------------- +-- Rewrites that deal with nested structures and propagation vectors. + +-- | When the right input of a cartesian product has cardinality one, +-- the cardinality of the right input does not change and the +-- propagation vector for the left input is a NOOP. +propProductCard1Right :: VLRule BottomUpProps +propProductCard1Right q = + $(dagPatMatch 'q "R1 ((R2 ((_) CartProduct (q2))) PropReorder (qi))" + [| do + VProp True <- card1Prop <$> properties $(v "q2") + + return $ do + logRewrite "Redundant.Prop.CartProduct.Card1.Right" q + void $ replace q $(v "qi") |]) + +-- | Turn a right-deep nestjoin tree into a left-deep one. +-- +-- A comprehension of the form +-- @ +-- [ [ [ e x y z | z <- zs, p2 y z ] +-- | y <- ys +-- , p1 x y +-- ] +-- | x <- xs +-- ] +-- @ +-- +-- is first rewritten into a right-deep chain of nestjoins: 'xs △ (ys △ zs)'. +-- Bottom-up compilation of this expression to VL (vectorization) results in +-- a rather awkward plan, though: The inner nestjoin is computed independent +-- of values of 'x'. The join result is then re-shaped using the propagation +-- vector from the nestjoin of the outer relations 'xs' and 'ys'. This pattern +-- is problematic for multiple reasons: PropReorder is an expensive operation as +-- it involves re-ordering semantically, leading to a hard-to-eliminate rownum. +-- On the plan level, we do not get a left- or right-deep join tree of thetajoins, +-- but two independent joins between the two pairs of input relations whose results +-- are connected using an additional join (PropReorder). This means that the two +-- base joins will be executed on the full base tables, without being able to profit +-- from a reduced cardinality in one of the join results. +-- +-- NestJoin does not exhibit useful algebraic properties, most notably it is neither +-- associate nor commutative. It turns out however that we can turn the pattern +-- described above into a proper left-deep sequence of nestjoins if we consider +-- the flat (vectorized) representation. The output of 'xs △ ys' is nestjoined +-- with the innermost input 'zs'. This gives us exactly the representation of +-- the nested output that we need. Semantically, 'zs' is not joined with all +-- tuples in 'ys', but only with those that survive the (outer) join with 'xs'. +-- As usual, a proper join tree should give the engine the freedom to re-arrange +-- the joins and drive them in a pipelined manner. +nestJoinChain :: VLRule BottomUpProps +nestJoinChain q = + $(dagPatMatch 'q "R1 ((R3 (lj=(xs) NestJoin _ (ys))) PropReorder (R1 ((ys1) NestJoin p (zs))))" + [| do + xsWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "xs") + ysWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "ys") + zsWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "zs") + + predicate $ $(v "ys") == $(v "ys1") + return $ do + logRewrite "Redundant.Prop.NestJoinChain" q + + + let innermostCols = map Column [ xsWidth + 1 .. xsWidth + ysWidth + zsWidth ] + + -- As the left input of the top nestjoin now includes the + -- columns from xs, we have to shift column references in + -- the left predicate side. + JoinPred conjs = $(v "p") + p' = JoinPred $ fmap (shiftJoinPredCols xsWidth 0) conjs + + -- The R1 node on the left nest join might already exist, but + -- we simply rely on hash consing. + leftJoinR1 <- insert $ UnOp R1 $(v "lj") + rightJoin <- insert $ BinOp (NestJoin p') leftJoinR1 $(v "zs") + rightJoinR1 <- insert $ UnOp R1 rightJoin + + -- Because the original produced only the columns of ys and + -- zs in the PropReorder output, we have to remove the xs + -- columns from the top NestJoin. + void $ replaceWithNew q $ UnOp (Project innermostCols) rightJoinR1 |]) + +shiftJoinPredCols :: Int -> Int -> JoinConjunct Expr -> JoinConjunct Expr +shiftJoinPredCols leftOffset rightOffset (JoinConjunct leftExpr op rightExpr) = + JoinConjunct (shiftExprCols leftOffset leftExpr) op (shiftExprCols rightOffset rightExpr) + +-------------------------------------------------------------------------------- +-- Eliminating operators whose output is not required + +notReqNumber :: VLRule Properties +notReqNumber q = + $(dagPatMatch 'q "Number (q1)" + [| do + w <- vectorWidth <$> vectorTypeProp <$> bu <$> properties $(v "q1") + VProp (Just reqCols) <- reqColumnsProp <$> td <$> properties $(v "q") + + -- The number output in column w + 1 must not be required + predicate $ all (<= w) reqCols + + return $ do + logRewrite "Redundant.Req.Number" q + -- Add a dummy column instead of the number output to keep + -- column references intact. + let proj = map Column [1..w] ++ [Constant $ VLInt 0xdeadbeef] + void $ replaceWithNew q $ UnOp (Project proj) $(v "q1") |]) + +-------------------------------------------------------------------------------- +-- Classical relational algebra rewrites + +-- | Merge a selection that refers to both sides of a cartesian +-- product operators' inputs into a join. +selectCartProd :: VLRule BottomUpProps +selectCartProd q = + $(dagPatMatch 'q "R1 (Select p (R1 ((q1) CartProduct (q2))))" + [| do + wl <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + BinApp (SBRelOp op) (Column lc) (Column rc) <- return $(v "p") + + -- The left operand column has to be from the left input, the + -- right operand from the right input. + predicate $ lc <= wl + predicate $ rc > wl + + return $ do + logRewrite "Redundant.Relational.Join" q + let joinPred = singlePred $ JoinConjunct (Column lc) op (Column $ rc - wl) + joinNode <- insert $ BinOp (ThetaJoin joinPred) $(v "q1") $(v "q2") + void $ replaceWithNew q $ UnOp R1 joinNode |]) diff --git a/src/Database/DSH/Optimizer/VL/Rewrite/Unused.hs b/src/Database/DSH/Optimizer/VL/Rewrite/Unused.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Rewrite/Unused.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} + +{- Based on the ReqColumns property, remove columns or entire operators which +produce value vectors but whose payload output is not needed downstream. This +is of course only sound if the operator in question does not change the vertical +layout. -} + +module Database.DSH.Optimizer.VL.Rewrite.Unused where + +{- +import Control.Applicative + +import Database.Algebra.Dag.Common +import Database.Algebra.VL.Data + +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Rewrite.Common + +pruneUnused :: VLRewrite Bool +pruneUnused = applyToAll inferTopDown [ {- unusedProject -} ] + +-} + +{- + +FIXME seems a bit fishy + +unusedProject :: VLRule TopDownProps +unusedProject q = + $(pattern 'q "[ProjectL | Project] _ (q1)" + [| do + -- Don't remove top-level projections. They ensure that all required + -- columns required for the result type are actually there. + predicate =<< not <$> elem q <$> getRootNodes + + reqColumns <- reqColumnsProp <$> properties q + + case reqColumns of + VProp (Just []) -> return () + VProp (Just _) -> fail "no match" + p -> error ("Unused.Project: " ++ show p) + + + return $ do + logRewrite "Unused.Project" q + replace q $(v "q1") |]) +-} diff --git a/src/Database/DSH/Optimizer/VL/Rewrite/Window.hs b/src/Database/DSH/Optimizer/VL/Rewrite/Window.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Optimizer/VL/Rewrite/Window.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +module Database.DSH.Optimizer.VL.Rewrite.Window where + +import Control.Applicative +import Control.Monad +import Data.List.NonEmpty (NonEmpty (..)) + +import Database.Algebra.Dag.Common + +import Database.DSH.Common.Lang +import Database.DSH.Optimizer.Common.Rewrite +import Database.DSH.Optimizer.VL.Properties.ReqColumns +import Database.DSH.Optimizer.VL.Properties.Types +import Database.DSH.Optimizer.VL.Properties.VectorType +import Database.DSH.Optimizer.VL.Rewrite.Common +import Database.DSH.VL.Lang + +pattern SingleJoinPred e1 op e2 = JoinPred ((JoinConjunct e1 op e2) :| []) +pattern DoubleJoinPred e11 op1 e12 e21 op2 e22 = JoinPred ((JoinConjunct e11 op1 e12) + :| + [JoinConjunct e21 op2 e22]) +pattern AddExpr e1 e2 = BinApp (SBNumOp Add) e1 e2 +pattern SubExpr e1 e2 = BinApp (SBNumOp Sub) e1 e2 + +aggrToWinFun :: AggrFun -> WinFun +aggrToWinFun (AggrSum _ e) = WinSum e +aggrToWinFun (AggrMin e) = WinMin e +aggrToWinFun (AggrMax e) = WinMax e +aggrToWinFun (AggrAvg e) = WinAvg e +aggrToWinFun (AggrAll e) = WinAll e +aggrToWinFun (AggrAny e) = WinAny e +aggrToWinFun AggrCount = WinCount + +-- Turn a running aggregate based on a self-join into a window operator. +runningAggWin :: VLRule BottomUpProps +runningAggWin q = + $(dagPatMatch 'q "(qo) UnboxScalar ((_) AggrS afun (R1 ((qn=Number (q1)) NestJoin p (Number (q2)))))" + [| do + predicate $ $(v "q1") == $(v "q2") + predicate $ $(v "qo") == $(v "qn") + + w <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + -- We require a range predicate on the positions generated by + -- Number. + -- FIXME allow other forms of window specifications + SingleJoinPred (Column nrCol) GtE (Column nrCol') <- return $(v "p") + predicate $ nrCol == w + 1 && nrCol' == w + 1 + + -- The aggregate should only reference columns from the right + -- ThetaJoin input, i.e. columns from the partition generated + -- for a input tuple. + let isWindowColumn c = c >= w + 2 && c <= 2 * w + 1 + predicate $ all isWindowColumn (aggrReqCols $(v "afun")) + + return $ do + logRewrite "Window.RunningAggr" q + -- Shift column references in aggregate functions so that + -- they are applied to partition columns. + let afun' = aggrToWinFun $ mapAggrFun (mapExprCols (\c -> c - (w + 1))) $(v "afun") + + void $ replaceWithNew q $ UnOp (WinFun (afun', FAllPreceding)) $(v "qn") |]) + +-- | Employ a window function that maps to SQL's first_value when the +-- 'head' combinator is employed on a nestjoin-generated window. +-- +-- FIXME this rewrite is currently extremely ugly and fragile: We map +-- directly to first_value which produces only one value, but start +-- with head one potentially broader inputs. To bring them into sync, +-- we demand that only one column is required downstream and produce +-- that column. This involves too much fiddling with column +-- offsets. It would be less dramatic if we had name-based columns +-- (which we should really do). +firstValueWin :: VLRule Properties +firstValueWin q = + $(dagPatMatch 'q "(UnboxRename (Number (q1))) PropRename (R1 (SelectPos1S selectArgs (R1 ((Number (q2)) NestJoin joinPred (Number (q3))))))" + [| do + predicate $ $(v "q1") == $(v "q2") && $(v "q1") == $(v "q3") + + inputWidth <- vectorWidth <$> vectorTypeProp <$> bu <$> properties $(v "q1") + resWidth <- vectorWidth <$> vectorTypeProp <$> bu <$> properties $(v "q1") + + VProp (Just [resCol]) <- reqColumnsProp <$> td <$> properties $(v "q") + + -- Perform a sanity check (because this rewrite is rather + -- insane): the required column must originate from the inner + -- window created by the nestjoin and must not be the + -- numbering column. + predicate $ resCol > inputWidth + 1 + predicate $ resCol < 2 * inputWidth + 2 + + -- The evaluation of first_value produces only a single value + -- for each input column. To employ first_value, the input has + -- to consist of a single column. + + -- We expect the VL representation of 'head' + (SBRelOp Eq, 1) <- return $(v "selectArgs") + + -- We expect a window specification that for each element + -- includes its predecessor (if there is one) and the element + -- itself. + DoubleJoinPred e11 op1 e12 e21 op2 e22 <- return $(v "joinPred") + (SubExpr (Column nrCol) frameOffset, LtE, Column nrCol') <- return (e11, op1, e12) + (Column nrCol'', GtE, Column nrCol''') <- return (e21, op2, e22) + Constant (VLInt offset) <- return frameOffset + + -- Check that all (assumed) numbering columns are actually the + -- column added by the Number operator. + predicate $ all (== (inputWidth + 1)) [nrCol, nrCol', nrCol'', nrCol'''] + + return $ do + logRewrite "Window.FirstValue" q + let -- The input column for FirstValue is the column in + -- the inner window mapped to the input vector's + -- layout. + inputCol = resCol - (inputWidth + 1) + winArgs = (WinFirstValue $ Column inputCol, (FNPreceding offset)) + placeHolders = repeat $ Constant $ VLInt 0xdeadbeef + + -- Now comes the ugly stuff: to keep the schema intact + -- (since columns are referred to by offset), we have + -- to keep columns that are not required in place and + -- replace them with placeholders. + proj = -- Unreferenced columns in front of the + -- required column + take (resCol - 1) placeHolders + -- The required column (which is added + -- by WinFun to the input columns + ++ [Column (inputWidth + 1)] + -- Unrefeferenced columns after the + -- required column + ++ take (resWidth - resCol) placeHolders + winNode <- insert $ UnOp (WinFun winArgs) $(v "q1") + void $ replaceWithNew q $ UnOp (Project proj) winNode |]) + +inlineWinAggrProject :: VLRule BottomUpProps +inlineWinAggrProject q = + $(dagPatMatch 'q "WinFun args (Project proj (q1))" + [| do + w <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1") + + return $ do + logRewrite "Window.RunningAggr.Project" q + + let (afun, frameSpec) = $(v "args") + env = zip [1..] $(v "proj") + -- Inline column expressions from the projection into + -- the window function. + afun' = mapWinFun (mergeExpr env) afun + + -- WinAggr /adds/ the window function output to the + -- input columns. We have to provide the schema of the + -- input projection to which the window function + -- output is added. + proj' = $(v "proj") ++ [Column $ w + 1] + + winNode <- insert $ UnOp (WinFun (afun', frameSpec)) $(v "q1") + void $ replaceWithNew q $ UnOp (Project proj') winNode |]) diff --git a/src/Database/DSH/TH.hs b/src/Database/DSH/TH.hs deleted file mode 100644 --- a/src/Database/DSH/TH.hs +++ /dev/null @@ -1,453 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Database.DSH.TH ( deriveDSH - , deriveQA - , deriveTupleRangeQA - , deriveTA - , deriveTupleRangeTA - , deriveView - , deriveTupleRangeView - , deriveElim - , deriveSmartConstructors - , deriveTupleRangeSmartConstructors - ) where - -import qualified Database.DSH.Internals as DSH -import qualified Database.DSH.Impossible as DSH - -import Language.Haskell.TH -import Control.Monad -import Data.Char - ------------------------------------------ --- Deriving all DSH-relevant instances -- ------------------------------------------ - -deriveDSH :: Name -> Q [Dec] -deriveDSH n = do - qaDecs <- deriveQA n - elimDecs <- deriveElim n - cc <- countConstructors n - viewDecs <- if cc == 1 - then deriveView n - else return [] - scDecs <- deriveSmartConstructors n - return (qaDecs ++ elimDecs ++ viewDecs ++ scDecs) - ------------------ --- Deriving QA -- ------------------ - -deriveQA :: Name -> Q [Dec] -deriveQA name = do - info <- reify name - case info of - TyConI (DataD _cxt name1 tyVarBndrs cons _names) -> - deriveTyConQA name1 tyVarBndrs cons - TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> - deriveTyConQA name1 tyVarBndrs [con] - _ -> fail errMsgExoticType - -deriveTupleRangeQA :: Int -> Int -> Q [Dec] -deriveTupleRangeQA x y = fmap concat (mapM (deriveQA . tupleTypeName) [x .. y]) - -deriveTyConQA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] -deriveTyConQA name tyVarBndrs cons = do - let context = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) - tyVarBndrs - let typ = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) - let instanceHead = AppT (ConT ''DSH.QA) typ - let repDec = deriveRep typ cons - toExpDec <- deriveToExp cons - frExpDec <- deriveFrExp cons - return [InstanceD context instanceHead [repDec,toExpDec,frExpDec]] - --- Deriving the Rep type function - -deriveRep :: Type -> [Con] -> Dec -deriveRep typ cons = TySynInstD ''DSH.Rep [typ] (deriveRepCons cons) - -deriveRepCons :: [Con] -> Type -deriveRepCons [] = error errMsgExoticType -deriveRepCons [c] = deriveRepCon c -deriveRepCons cs = foldr1 (AppT . AppT (ConT ''(,))) - (map (AppT (ConT ''[]) . deriveRepCon) cs) - -deriveRepCon :: Con -> Type -deriveRepCon con = case conToTypes con of - [] -> ConT ''() - ts -> foldr1 (AppT . AppT (ConT ''(,))) - (map (AppT (ConT ''DSH.Rep)) ts) - --- Deriving the toExp function of the QA class - -deriveToExp :: [Con] -> Q Dec -deriveToExp [] = fail errMsgExoticType -deriveToExp cons = do - clauses <- sequence (zipWith3 deriveToExpClause (repeat (length cons)) [0 .. ] cons) - return (FunD 'DSH.toExp clauses) - -deriveToExpClause :: Int -- Total number of constructors - -> Int -- Index of the constructor - -> Con - -> Q Clause -deriveToExpClause 0 _ _ = fail errMsgExoticType -deriveToExpClause 1 _ con = do - (pat1,names1) <- conToPattern con - let exp1 = deriveToExpMainExp names1 - let body1 = NormalB exp1 - return (Clause [pat1] body1 []) -deriveToExpClause n i con = do - (pat1,names1) <- conToPattern con - let exp1 = deriveToExpMainExp names1 - expList1 <- [| DSH.ListE [ $(return exp1) ] |] - expEmptyList <- [| DSH.ListE [] |] - let lists = concat [ replicate i expEmptyList - , [expList1] - , replicate (n - i - 1) expEmptyList] - let exp2 = foldr1 (AppE . AppE (ConE 'DSH.PairE)) lists - let body1 = NormalB exp2 - return (Clause [pat1] body1 []) - -deriveToExpMainExp :: [Name] -> Exp -deriveToExpMainExp [] = ConE 'DSH.UnitE -deriveToExpMainExp [name] = AppE (VarE 'DSH.toExp) (VarE name) -deriveToExpMainExp names = foldr1 (AppE . AppE (ConE 'DSH.PairE)) - (map (AppE (VarE 'DSH.toExp) . VarE) names) --- Deriving to frExp function of the QA class - -deriveFrExp :: [Con] -> Q Dec -deriveFrExp cons = do - clauses <- sequence (zipWith3 deriveFrExpClause (repeat (length cons)) [0 .. ] cons) - imp <- DSH.impossible - let lastClause = Clause [WildP] (NormalB imp) [] - return (FunD 'DSH.frExp (clauses ++ [lastClause])) - -deriveFrExpClause :: Int -- Total number of constructors - -> Int -- Index of the constructor - -> Con - -> Q Clause -deriveFrExpClause 1 _ con = do - (_,names1) <- conToPattern con - let pat1 = deriveFrExpMainPat names1 - let exp1 = foldl AppE - (ConE (conToName con)) - (map (AppE (VarE 'DSH.frExp) . VarE) names1) - let body1 = NormalB exp1 - return (Clause [pat1] body1 []) -deriveFrExpClause n i con = do - (_,names1) <- conToPattern con - let pat1 = deriveFrExpMainPat names1 - let patList1 = ConP 'DSH.ListE [ConP '(:) [pat1,WildP]] - let lists = replicate i WildP ++ [patList1] ++ replicate (n - i - 1) WildP - let pat2 = foldr1 (\p1 p2 -> ConP 'DSH.PairE [p1,p2]) lists - let exp1 = foldl AppE - (ConE (conToName con)) - (map (AppE (VarE 'DSH.frExp) . VarE) names1) - let body1 = NormalB exp1 - return (Clause [pat2] body1 []) - -deriveFrExpMainPat :: [Name] -> Pat -deriveFrExpMainPat [] = ConP 'DSH.UnitE [] -deriveFrExpMainPat [name] = VarP name -deriveFrExpMainPat names = foldr1 (\p1 p2 -> ConP 'DSH.PairE [p1,p2]) (map VarP names) - ------------------ --- Deriving TA -- ------------------ - -deriveTA :: Name -> Q [Dec] -deriveTA name = do - info <- reify name - case info of - TyConI (DataD _cxt name1 tyVarBndrs cons _names) -> - deriveTyConTA name1 tyVarBndrs cons - TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> - deriveTyConTA name1 tyVarBndrs [con] - _ -> fail errMsgExoticType - -deriveTupleRangeTA :: Int -> Int -> Q [Dec] -deriveTupleRangeTA x y = fmap concat (mapM (deriveTA . tupleTypeName) [x .. y]) - -deriveTyConTA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] -deriveTyConTA name tyVarBndrs _cons = do - let context = map (\tv -> ClassP ''DSH.BasicType [VarT (tyVarBndrToName tv)]) - tyVarBndrs - let typ = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) - let instanceHead = AppT (ConT ''DSH.TA) typ - return [InstanceD context instanceHead []] - -------------------- --- Deriving View -- -------------------- - -deriveView :: Name -> Q [Dec] -deriveView name = do - info <- reify name - case info of - TyConI (DataD _cxt name1 tyVarBndrs [con] _names) -> - deriveTyConView name1 tyVarBndrs con - TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> - deriveTyConView name1 tyVarBndrs con - _ -> fail errMsgExoticType - -deriveTupleRangeView :: Int -> Int -> Q [Dec] -deriveTupleRangeView x y = fmap concat (mapM (deriveView . tupleTypeName) [x .. y]) - -deriveTyConView :: Name -> [TyVarBndr] -> Con -> Q [Dec] -deriveTyConView name tyVarBndrs con = do - let context = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs - let typ1 = AppT (ConT ''DSH.Q) - (foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs)) - let instanceHead = AppT (ConT ''DSH.View) typ1 - let typs = conToTypes con - let typ2 = if null typs - then AppT (ConT ''DSH.Q) (ConT ''()) - else foldl AppT (TupleT (length typs)) (map (AppT (ConT ''DSH.Q)) typs) - let toViewDecTF = TySynInstD ''DSH.ToView [typ1] typ2 - viewDec <- deriveToView (length typs) - return [InstanceD context instanceHead [toViewDecTF, viewDec]] - -deriveToView :: Int -> Q Dec -deriveToView n = do - en <- newName "e" - let ep = VarP en - let pat1 = ConP 'DSH.Q [ep] - - let fAux 0 e1 = [AppE (ConE 'DSH.Q) e1] - fAux 1 e1 = [AppE (ConE 'DSH.Q) e1] - fAux n1 e1 = let fste = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Fst)) e1 - snde = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Snd)) e1 - in AppE (ConE 'DSH.Q) fste : fAux (n1 - 1) snde - - let body1 = TupE (fAux n (VarE en)) - let clause1 = Clause [pat1] (NormalB body1) [] - return (FunD 'DSH.view [clause1]) - -------------------- --- Deriving Elim -- -------------------- - -deriveElim :: Name -> Q [Dec] -deriveElim name = do - info <- reify name - case info of - TyConI (DataD _cxt name1 tyVarBndrs cons _names) -> - deriveTyConElim name1 tyVarBndrs cons - TyConI (NewtypeD _cxt name1 tyVarBndrs con _names) -> - deriveTyConElim name1 tyVarBndrs [con] - _ -> fail errMsgExoticType - -deriveTyConElim :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] -deriveTyConElim name tyVarBndrs cons = do - resultTyName <- newName "r" - let resTy = VarT resultTyName - let ty = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) - let context = ClassP ''DSH.QA [resTy] : - map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs - let instanceHead = AppT (AppT (ConT ''DSH.Elim) ty) resTy - let eliminatorDec = deriveEliminator ty resTy cons - elimDec <- deriveElimFun cons - return [InstanceD context instanceHead [eliminatorDec,elimDec]] - --- Deriving the Eliminator type function - -deriveEliminator :: Type -> Type -> [Con] -> Dec -deriveEliminator typ resTy cons = - TySynInstD ''DSH.Eliminator [typ,resTy] (deriveEliminatorCons resTy cons) - -deriveEliminatorCons :: Type -> [Con] -> Type -deriveEliminatorCons _ [] = error errMsgExoticType -deriveEliminatorCons resTy cs = - foldr (AppT . AppT ArrowT . deriveEliminatorCon resTy) - (AppT (ConT ''DSH.Q) resTy) - cs - -deriveEliminatorCon :: Type -> Con -> Type -deriveEliminatorCon resTy con = - foldr (AppT . AppT ArrowT . AppT (ConT ''DSH.Q)) - (AppT (ConT ''DSH.Q) resTy) - (conToTypes con) - --- Deriving the elim function of the Elim type class - -deriveElimFun :: [Con] -> Q Dec -deriveElimFun cons = do - clause1 <- deriveElimFunClause cons - return (FunD 'DSH.elim [clause1]) - -deriveElimFunClause :: [Con] -> Q Clause -deriveElimFunClause cons = do - en <- newName "e" - fns <- mapM (\ _ -> newName "f") cons - let fes = map VarE fns - let pats1 = ConP 'DSH.Q [VarP en] : map VarP fns - - fes2 <- zipWithM deriveElimToLamExp fes (map (length . conToTypes) cons) - - let e = VarE en - let liste = AppE (ConE 'DSH.ListE) (ListE (deriveElimFunClauseExp e fes2)) - let concate = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Concat)) liste - let heade = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Head)) concate - let qe = AppE (ConE 'DSH.Q) heade - return (Clause pats1 (NormalB qe) []) - -deriveElimToLamExp :: Exp -> Int -> Q Exp -deriveElimToLamExp f 0 = - return (AppE (VarE 'const) (AppE (VarE 'DSH.unQ) f)) -deriveElimToLamExp f 1 = do - xn <- newName "x" - let xe = VarE xn - let xp = VarP xn - let qe = AppE (ConE 'DSH.Q) xe - let fappe = AppE f qe - let unqe = AppE (VarE 'DSH.unQ) fappe - return (LamE [xp] unqe) -deriveElimToLamExp f n = do - xn <- newName "x" - let xe = VarE xn - let xp = VarP xn - let fste = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Fst)) xe - let snde = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Snd)) xe - let qe = AppE (ConE 'DSH.Q) fste - let fappe = AppE f qe - f' <- deriveElimToLamExp fappe (n - 1) - return (LamE [xp] (AppE f' snde)) - -deriveElimFunClauseExp :: Exp -> [Exp] -> [Exp] -deriveElimFunClauseExp _ [] = error errMsgExoticType -deriveElimFunClauseExp e [f] = [AppE (ConE 'DSH.ListE) (ListE [AppE f e])] -deriveElimFunClauseExp e fs = go e fs - where - go :: Exp -> [Exp] -> [Exp] - go _ [] = error errMsgExoticType - go e1 [f1] = - let paire = AppE (AppE (ConE 'DSH.PairE) (AppE (ConE 'DSH.LamE) f1)) e1 - in [AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Map)) paire] - go e1 (f1 : fs1) = - let fste = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Fst)) e1 - snde = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Snd)) e1 - paire = AppE (AppE (ConE 'DSH.PairE) (AppE (ConE 'DSH.LamE) f1)) fste - mape = AppE (AppE (ConE 'DSH.AppE) (ConE 'DSH.Map)) paire - in mape : go snde fs1 - ---------------------------------- --- Deriving Smart Constructors -- ---------------------------------- - -deriveSmartConstructors :: Name -> Q [Dec] -deriveSmartConstructors name = do - info <- reify name - case info of - TyConI (DataD _cxt typConName tyVarBndrs cons _names) -> do - decss <- zipWithM (deriveSmartConstructor typConName tyVarBndrs (length cons)) - [0 .. ] - cons - return (concat decss) - TyConI (NewtypeD _cxt typConName tyVarBndrs con _names) -> - deriveSmartConstructor typConName tyVarBndrs 1 0 con - _ -> fail errMsgExoticType - -deriveTupleRangeSmartConstructors :: Int -> Int -> Q [Dec] -deriveTupleRangeSmartConstructors x y = - fmap concat (mapM (deriveSmartConstructors . tupleTypeName) [x .. y]) - -deriveSmartConstructor :: Name -> [TyVarBndr] -> Int -> Int -> Con -> Q [Dec] -deriveSmartConstructor typConName tyVarBndrs n i con = do - let smartConName = toSmartConName (conToName con) - - let boundTyps = map (VarT . tyVarBndrToName) tyVarBndrs - - let resTyp = AppT (ConT ''DSH.Q) (foldl AppT (ConT typConName) boundTyps) - - let smartConContext = map (ClassP ''DSH.QA . return) boundTyps - - let smartConTyp = foldr (AppT . AppT ArrowT . AppT (ConT ''DSH.Q)) - resTyp - (conToTypes con) - - let smartConDec = SigD smartConName (ForallT tyVarBndrs smartConContext smartConTyp) - - ns <- mapM (\_ -> newName "e") (conToTypes con) - let es = map VarE ns - - let smartConPat = map (ConP 'DSH.Q . return . VarP) ns - - let smartConExp = if null es - then (ConE 'DSH.UnitE) - else foldr1 (AppE . AppE (ConE 'DSH.PairE)) es - smartConBody <- deriveSmartConBody n i smartConExp - let smartConClause = Clause smartConPat (NormalB smartConBody) [] - - let funDec = FunD smartConName [smartConClause] - - return [smartConDec,funDec] - -deriveSmartConBody :: Int -- Total number of constructors - -> Int -- Index of the constructor - -> Exp - -> Q Exp -deriveSmartConBody 0 _ _ = fail errMsgExoticType -deriveSmartConBody 1 _ e = return (AppE (ConE 'DSH.Q) e) -deriveSmartConBody n i e = do - listExp <- [| DSH.ListE [ $(return e) ] |] - emptyListExp <- [| DSH.ListE [] |] - let lists = concat [ replicate i emptyListExp - , [listExp] - , replicate (n - i - 1) emptyListExp - ] - let pairExp = foldr1 (AppE . AppE (ConE 'DSH.PairE)) lists - return (AppE (ConE 'DSH.Q) pairExp) - -toSmartConName :: Name -> Name -toSmartConName name1 = case nameBase name1 of - "()" -> mkName "unit" - '(' : cs -> mkName ("tuple" ++ show (length (filter (== ',') cs) + 1)) - c : cs | isAlpha c -> mkName (toLower c : cs) - cs -> mkName (':' : cs) - --- Helper Functions - -conToTypes :: Con -> [Type] -conToTypes (NormalC _name strictTypes) = map snd strictTypes -conToTypes (RecC _name varStrictTypes) = map (\(_,_,t) -> t) varStrictTypes -conToTypes (InfixC st1 _name st2) = [snd st1,snd st2] -conToTypes (ForallC _tyVarBndrs _cxt con) = conToTypes con - -tyVarBndrToName :: TyVarBndr -> Name -tyVarBndrToName (PlainTV name) = name -tyVarBndrToName (KindedTV name _kind) = name - -conToPattern :: Con -> Q (Pat,[Name]) -conToPattern (NormalC name strictTypes) = do - ns <- mapM (\ _ -> newName "x") strictTypes - return (ConP name (map VarP ns),ns) -conToPattern (RecC name varStrictTypes) = do - ns <- mapM (\ _ -> newName "x") varStrictTypes - return (ConP name (map VarP ns),ns) -conToPattern (InfixC st1 name st2) = do - ns <- mapM (\ _ -> newName "x") [st1,st2] - return (ConP name (map VarP ns),ns) -conToPattern (ForallC _tyVarBndr _cxt con) = conToPattern con - -conToName :: Con -> Name -conToName (NormalC name _) = name -conToName (RecC name _) = name -conToName (InfixC _ name _) = name -conToName (ForallC _ _ con) = conToName con - -countConstructors :: Name -> Q Int -countConstructors name = do - info <- reify name - case info of - TyConI (DataD _ _ _ cons _) -> return (length cons) - TyConI (NewtypeD {}) -> return 1 - _ -> fail errMsgExoticType - --- Error messages - -errMsgExoticType :: String -errMsgExoticType = - "Automatic derivation of DSH related type class instances only works for Haskell 98\ - \ types. Derivation of View patters is only supported for single-constructor data\ - \ types." diff --git a/src/Database/DSH/Tools/VLDotGen.hs b/src/Database/DSH/Tools/VLDotGen.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Tools/VLDotGen.hs @@ -0,0 +1,83 @@ +module Main where + +import System.IO +import System.Exit +import System.Environment +import System.Console.GetOpt + +import Data.ByteString.Lazy.Char8 (pack) + +import Data.Maybe + +import Database.DSH.VL.Render.JSON +import Database.DSH.VL.Render.Dot + +data Options = Options { optInput :: IO String + , optReuse :: Bool + , optRootNodes :: Maybe [Int] + , optProperties :: Bool + } + +startOptions :: Options +startOptions = Options { optInput = getContents + , optReuse = False + , optRootNodes = Nothing + , optProperties = False + } + +options :: [OptDescr (Options -> IO Options)] +options = + [ Option "i" ["input"] + (ReqArg (\arg opt -> return opt { optInput = readFile arg }) + "FILE") + "Input file" + , Option "n" ["rootnodes"] + (ReqArg (\arg opt -> return opt { optRootNodes = Just $ read arg }) + "ROOTNODES") + "List of root nodes to use (must be in Haskell list syntax)" + , Option "p" ["properties"] + (NoArg (\opt -> return opt { optProperties = True })) + "Infer properties and display them" + , Option "h" ["help"] + (NoArg + (\_ -> do + prg <- getProgName + hPutStrLn stderr (usageInfo prg options) + exitWith ExitSuccess)) + "Show help" + ] + +{- +propertyTags :: [AlgNode] -> NodeMap X100Algebra -> NodeMap [Tag] -> NodeMap [Tag] +propertyTags rs nm tags = + let dag = normalizePlan $ mkDag nm rs + topsorted = topsort dag + bu = inferBottomUpProperties topsorted dag + td = inferTopDownProperties bu topsorted dag + buDocs = M.map renderBottomUpProps bu + tdDocs = M.map renderTopDownProps td + tagDocs = M.map (vcat . ((map text) . nub)) tags + propsRendered = M.map render $ M.unionWith ($$) tagDocs $ M.unionWith ($$) buDocs tdDocs + in M.map (\s -> [s]) propsRendered +-} + +main :: IO () +main = do + args <- getArgs + let (actions, _, _) = getOpt RequireOrder options args + opts <- foldl (>>=) (return startOptions) actions + let Options { optInput = input + , optRootNodes = mRootNodes } = opts + + plan <- input + + let (tags, rs, m) = deserializePlan $ pack plan + + let rs' = fromMaybe rs mRootNodes + {- + tags' = if printProperties + then propertyTags rs' m tags + else tags +-} + + putStr $ renderVLDot tags rs' m diff --git a/src/Database/DSH/Translate/Algebra2Query.hs b/src/Database/DSH/Translate/Algebra2Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Translate/Algebra2Query.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.Translate.Algebra2Query + ( generateSqlQueries + ) where + +import Database.DSH.Impossible + +import Database.Algebra.Dag +import Database.Algebra.SQL.Compatibility +import Database.Algebra.SQL.Materialization.CTE +import Database.Algebra.SQL.Util +import Database.Algebra.Table.Lang + +import Database.DSH.Common.QueryPlan +import Database.DSH.Execute.Sql +import Database.DSH.VL.Vector + +-- | In a query shape, render each root node for the algebraic plan +-- into a separate SQL query. + +-- FIXME use materialization "prelude" +generateSqlQueries :: QueryPlan TableAlgebra NDVec -> Shape (BackendCode SqlBackend) +generateSqlQueries taPlan = renderQueryCode $ queryShape taPlan + where + roots = rootNodes $ queryDag taPlan + (_sqlShared, sqlQueries) = renderOutputDSHWith PostgreSQL materialize (queryDag taPlan) + nodeToQuery = zip roots sqlQueries + lookupNode n = maybe $impossible SqlCode $ lookup n nodeToQuery + + renderQueryCode :: Shape NDVec -> Shape (BackendCode SqlBackend) + renderQueryCode shape = + case shape of + SShape (ADVec r _) lyt -> SShape (lookupNode r) (convertLayout lyt) + VShape (ADVec r _) lyt -> VShape (lookupNode r) (convertLayout lyt) + + convertLayout :: Layout NDVec -> Layout (BackendCode SqlBackend) + convertLayout lyt = + case lyt of + LCol i -> LCol i + LNest (ADVec r _) clyt -> LNest (lookupNode r) (convertLayout clyt) + LTuple lyts -> LTuple $ map convertLayout lyts diff --git a/src/Database/DSH/Translate/CL2NKL.hs b/src/Database/DSH/Translate/CL2NKL.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Translate/CL2NKL.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} + +module Database.DSH.Translate.CL2NKL + ( desugarComprehensions ) where + +#ifdef DEBUGCOMP +import Debug.Trace +import Database.DSH.Common.Pretty +#endif + +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as N +import qualified Data.Foldable as F +import Control.Monad.Reader +import Control.Applicative + +import Database.DSH.Impossible + +import Database.DSH.Common.Type +import Database.DSH.Common.Lang + +import Database.DSH.CL.Lang (toList) +import qualified Database.DSH.CL.Lang as CL +import qualified Database.DSH.NKL.Primitives as P +import qualified Database.DSH.NKL.Lang as NKL +import Database.DSH.NKL.Rewrite + +-------------------------------------------------------------------------------- +-- Conversion of primitive operators + +prim1 :: Type -> CL.Prim1 -> CL.Expr -> NameEnv NKL.Expr +prim1 t p e = mkApp t <$> expr e + where + mkApp = + case p of + CL.Singleton -> mkPrim1 NKL.Singleton + CL.Length -> mkPrim1 NKL.Length + CL.Concat -> mkPrim1 NKL.Concat + -- Null in explicit form is useful during CL optimization + -- to easily recognize universal/existential patterns. In + -- backend implementations however, there currently is no + -- need to store it explicitly. Therefore, we implement it + -- using length in NKL. + CL.Null -> nklNull + CL.Sum -> mkPrim1 NKL.Sum + CL.Avg -> mkPrim1 NKL.Avg + CL.The -> mkPrim1 NKL.The + CL.Head -> mkPrim1 NKL.Head + CL.Minimum -> mkPrim1 NKL.Minimum + CL.Maximum -> mkPrim1 NKL.Maximum + CL.Tail -> mkPrim1 NKL.Tail + CL.Reverse -> mkPrim1 NKL.Reverse + CL.And -> mkPrim1 NKL.And + CL.Or -> mkPrim1 NKL.Or + CL.Init -> mkPrim1 NKL.Init + CL.Last -> mkPrim1 NKL.Last + CL.Nub -> mkPrim1 NKL.Nub + CL.Number -> mkPrim1 NKL.Number + (CL.Reshape n) -> mkPrim1 $ NKL.Reshape n + CL.Transpose -> mkPrim1 NKL.Transpose + CL.TupElem i -> mkPrim1 $ NKL.TupElem i + CL.Guard -> $impossible + + nklNull _ ne = NKL.BinOp boolT + (SBRelOp Eq) + (NKL.Const intT $ IntV 0) + (NKL.AppE1 intT NKL.Length ne) + + mkPrim1 nop nt ne = NKL.AppE1 nt nop ne + + +-- | Transform applications of binary primitives. Regular primitives +-- are mapped to their direct NKL equivalent. Higher-order primitives +-- (concatMap, map, filter, sortWith, groupWith) are mapped to their +-- first-order NKL equivalent combined with a single-generator +-- comprehension. +prim2 :: Type -> CL.Prim2 -> CL.Expr -> CL.Expr -> NameEnv NKL.Expr +prim2 t o e1 e2 = mkApp2 + where + mkApp2 = + case o of + CL.Append -> mkPrim2 NKL.Append + CL.Index -> mkPrim2 NKL.Index + CL.Zip -> mkPrim2 NKL.Zip + CL.CartProduct -> mkPrim2 NKL.CartProduct + CL.NestProduct -> mkPrim2 NKL.NestProduct + CL.ThetaJoin p -> mkPrim2 $ NKL.ThetaJoin p + CL.NestJoin p -> mkPrim2 $ NKL.NestJoin p + CL.SemiJoin p -> mkPrim2 $ NKL.SemiJoin p + CL.AntiJoin p -> mkPrim2 $ NKL.AntiJoin p + CL.Sort -> mkPrim2 $ NKL.Sort + CL.Group -> mkPrim2 $ NKL.Group + + mkPrim2 :: NKL.Prim2 -> NameEnv NKL.Expr + mkPrim2 nop = NKL.AppE2 t nop <$> expr e1 <*> expr e2 + +-------------------------------------------------------------------------------- +-- Generator environments + +-- | Access a component of a tuple variable +type TupleAccessor = Type -> Ident -> NKL.Expr + +type EnvEntry = (Ident, Type, TupleAccessor) + +-- | A generator environment stores generator variables that have +-- already been handled in the traversal of the qualifier list. For +-- each variable, we store it's type and an expression that projects +-- the variables' value out of the constructed tuple. +type GenEnv = N.NonEmpty EnvEntry + +-- | Construct an environment from one generator variable +-- => (x, t, \n t -> Var t n) +mkEnv :: (Ident, Type) -> GenEnv +mkEnv (x, xt) = (x, xt, \n t -> NKL.Var n t) N.:| [] + +-- | Account for a new pair that has been added at the top of the +-- constructed tuple +updateEnvEntry :: EnvEntry -> EnvEntry +updateEnvEntry (x, t, ta) = (x, t, \n t' -> P.fst $ ta n t') + +-- | Extend an environment with an additional generator variable. +extendEnv :: GenEnv -> (Ident, NKL.Expr) -> GenEnv +extendEnv entries (y, ys) = entry N.<| fmap updateEnvEntry entries + where + entry = (y, elemT $ typeOf ys, \n t -> P.snd $ NKL.Var n t) + +addGensToEnv :: NonEmpty (Ident, NKL.Expr) -> GenEnv -> GenEnv +addGensToEnv gens env = F.foldl' extendEnv env gens + +-------------------------------------------------------------------------------- +-- Conversion of CL expressions to NKL expressions + +type NameEnv a = Reader [Ident] a + +freshName :: NameEnv Ident +freshName = do + boundNames <- ask + return $ tryName 0 boundNames + + where + tryName :: Int -> [Ident] -> Ident + tryName i ns = if mkName i `elem` ns + then tryName (i + 1) ns + else mkName i + + mkName i = "f" ++ show i + +-- | Map a CL expression to its NKL equivalent by desugaring all +-- comprehensions. +expr :: CL.Expr -> NameEnv NKL.Expr +expr (CL.MkTuple t es) = NKL.MkTuple t <$> mapM expr es +expr (CL.Table t s cs ks) = return $ NKL.Table t s cs ks +expr (CL.AppE1 t p e) = prim1 t p e +expr (CL.AppE2 t p e1 e2) = prim2 t p e1 e2 +expr (CL.BinOp t o e1 e2) = NKL.BinOp t o <$> expr e1 <*> expr e2 +expr (CL.UnOp t o e) = NKL.UnOp t o <$> expr e +expr (CL.If t c th el) = NKL.If t <$> expr c <*> expr th <*> expr el +expr (CL.Lit t v) = return $ NKL.Const t v +expr (CL.Var t v) = return $ NKL.Var t v +expr (CL.Comp t e qs) = desugarComprehension t e (toList qs) +expr (CL.Let t x e1 e2) = NKL.Let t x <$> expr e1 <*> local (x :) (expr e2) + +-------------------------------------------------------------------------------- +-- Desugaring of comprehensions +-- +-- We do not use a general desugaring scheme for monad comprehensions +-- but deal only with list comprehensions. The motivation for now is +-- to avoid inefficient patterns (e.g. the handling of guards via +-- 'if') already by construction. +-- +-- In the current qualifier list, we consider the longest prefix of +-- generators. The cartesian product of those generators is +-- computed. We compute the cartesian product using nested +-- concatMaps. This is necessary because a generator expression might +-- depend on a preceding generator variable. If a guard follows a +-- sequence of generators, it is turned into a filter applied to the +-- cartesian product of all preceding generators. +-- +-- Example: +-- +-- [ e x y z | x <- xs, y <- ys, p1 x y, z <- zs, p2 y z ] +-- => +-- map (\t -> e [x/fst (fst t)] [y/snd (fst t)] [z/snd t]) +-- (filter (\t -> p2[y/snd (fst t)][z/snd t]) +-- (concatMap (\t -> concatMap (\z -> [pair t z]) zs[x/fst t][y/snd t]) +-- (filter (\t -> p1[x/fst t][y/snd t]) +-- (concatMap (\t -> concatMap (\y -> pair t y) ys[x/t]) +-- xs + +-- | Split a qualifier list into a prefix of generators and the +-- remaining qualifiers. +takeGens :: [CL.Qual] -> ([(Ident, CL.Expr)], [CL.Qual]) +takeGens (CL.BindQ x xs : qs) = let (binds, rest) = takeGens qs in ((x, xs) : binds, rest) +takeGens qs = ([], qs) + +-- | Generate an identifier that does not occur in the list provided. +freshIdent :: [Ident] -> NameEnv Ident +freshIdent names = do + visibleNames <- ask + return $ checkCollision (0 :: Int) (names ++ visibleNames) + where + checkCollision i ns = if mkName i `elem` ns + then checkCollision (i + 1) ns + else mkName i + + mkName i = "v" ++ show i + +-- | Construct a left-deep tuple from a list of expressions +mkTuple :: NonEmpty NKL.Expr -> NKL.Expr +mkTuple xs = F.foldl1 P.pair xs + +-- | Produce the nested concatMaps from a sequence of generators. The +-- body of the innermost generator constructs the tuple of generator +-- variables. +-- x <- xs, y <- ys, z <- zs +-- => +-- concatMap (\x -> concatMap (\y -> concatMap (\z -> (((t, x), y), z)) zs) ys) xs +-- where t is the binding variable for the base expression. +nestQualifiers :: NKL.Expr -> [(Ident, NKL.Expr)] -> NKL.Expr +nestQualifiers tupConst ((x, xs) : qs) = P.concat $ NKL.Iterator (listT bodyType) compHead x xs + where + compHead = nestQualifiers tupConst qs + bodyType = typeOf compHead +nestQualifiers tupConst [] = tupConst + +-- | Desugar a sequence of generators. +desugarGens :: GenEnv -> NKL.Expr -> NonEmpty (Ident, NKL.Expr) -> NameEnv NKL.Expr +desugarGens env baseExpr qs = do + -- Avoid all names that are bound by enclosing binders and the + -- ones bound in the current generator list. + visibleNames <- (++) (map fst $ N.toList qs) <$> ask + + -- Avoid all names that are bound in the generator expressions in + -- which we will substitute. + let boundNames = concatMap (boundVars . snd) $ N.toList qs + avoidNames = boundNames ++ visibleNames + + outerName <- freshIdent $ visibleNames ++ boundNames + + let baseElemType = elemT $ typeOf baseExpr + + -- Generator expressions might reference variables bound by + -- preceding generators. These variables go out of scope during + -- desugaring. To eliminate them, we have to replace references to + -- generator variables in generator expressions by the appropriate + -- tuple accessors for the outer concatMap variable. + substGenExpr (n, e) = (n, substTupleAccesses avoidNames (outerName, baseElemType) env e) + + let qs' = fmap substGenExpr qs + + tupConst = P.sng $ mkTuple $ fmap mkVar ((outerName, baseExpr) N.<| qs') + mkVar (x, xs) = NKL.Var (elemT $ typeOf xs) x + gensExpr = nestQualifiers tupConst (N.toList qs') + compTy = (listT $ typeOf tupConst) + return $ P.concat $ NKL.Iterator compTy gensExpr outerName baseExpr + +-- | Replace every occurence of a generator variable with the +-- corresponding tuple access expression. +substTupleAccesses :: [Ident] -> (Ident, Type) -> GenEnv -> NKL.Expr -> NKL.Expr +substTupleAccesses visibleNames (n, t) env e = F.foldr substTupleAccess e env + where + substTupleAccess (x, _, xta) e' = subst (n : visibleNames) x (xta t n) e' + +qualVar :: CL.Qual -> [Ident] +qualVar (CL.BindQ x _) = [x] +qualVar (CL.GuardQ _) = [] + +-- | Transform a list of generator expressions to NKL +-- expressions. Every expression is transformed in the name +-- environment enriched with the current prefix of the generators. +genExprs :: NonEmpty (Ident, CL.Expr) -> NameEnv (NonEmpty (Ident, NKL.Expr)) +genExprs ((n, e) :| []) = do + e' <- expr e + return $ (n, e') :| [] +genExprs ((n, e) :| (q : qs)) = do + e' <- expr e + qs' <- local (n :) (genExprs $ q :| qs) + return $ (n, e') N.<| qs' + +-- | Desugar a list of qualifiers. +desugarQualsRec :: GenEnv -> NKL.Expr -> [CL.Qual] -> NameEnv (GenEnv, NKL.Expr) +-- If we encounter a generator, we produce the cartesian product of +-- the generator prefix of the current qualifier list. +desugarQualsRec env baseSrc (CL.BindQ x xs : qs) = do + let (gens, remQuals) = takeGens qs + genNames = map fst gens + nklGens <- genExprs ((x, xs) :| gens) + baseSrc' <- desugarGens env baseSrc nklGens + let env' = addGensToEnv nklGens env + + local (++ genNames) $ desugarQualsRec env' baseSrc' remQuals + +-- A guard is desugared by filtering the cartesian product of the +-- generators that have been encountered so far. +desugarQualsRec env baseSrc (CL.GuardQ p : qs) = do + p' <- expr p + visibleNames <- ask + + filterName <- freshIdent $ visibleNames ++ boundVars p' + srcName <- freshName + let srcVar = NKL.Var (typeOf baseSrc) srcName + + let elemType = elemT $ typeOf baseSrc + filterExpr = substTupleAccesses visibleNames (filterName, elemType) env p' + predComp = NKL.Iterator (listT boolT) filterExpr filterName srcVar + filterSrc = P.let_ srcName baseSrc (P.restrict srcVar predComp) + + desugarQualsRec env filterSrc qs + +desugarQualsRec env baseSrc [] = return (env, baseSrc) + +-- | Kick off the recursive traversal of the qualifier list. +desugarQuals :: [CL.Qual] -> NameEnv (GenEnv, NKL.Expr, NKL.Expr -> NKL.Expr) +desugarQuals [] = $impossible +-- If the first qualifier is a guard, employ an if with a [] else +-- branch. +desugarQuals (CL.GuardQ p : qs) = do + (env, genExpr, _) <- desugarQuals qs + p' <- expr p + let wrapIf iter = P.if_ p' iter (NKL.Const (typeOf iter) (ListV [])) + return (env, genExpr, wrapIf) +-- If the first qualifier is a generator, it becomes the base source +-- expression. +desugarQuals (CL.BindQ x xs : qs) = do + let xt = elemT $ typeOf xs + let env = mkEnv (x, xt) + xs' <- expr xs + (env', genExpr) <- desugarQualsRec env xs' qs + return (env', genExpr, id) + +-- | Desugaring of comprehensions happens in two steps: Desugaring the +-- qualifiers leads to an expression that produces the (properly +-- filtered) cartesian product of all qualifiers. The head expression +-- ist then simply mapped over the resulting list. +desugarComprehension:: Type -> CL.Expr -> [CL.Qual] -> NameEnv NKL.Expr +desugarComprehension _ e qs = do + -- Desugar the qualifiers + (env, genExpr, wrapHead) <- desugarQuals qs + + let genNames = concatMap qualVar qs + + e' <- local (++ genNames) (expr e) + -- All names that are bound in enclosing scopes, including names + -- bound by local generators + visibleNames <- (++) genNames <$> ask + + -- Avoid all visible names + n <- freshIdent $ visibleNames ++ boundVars e' + + let t = elemT $ typeOf genExpr + + -- In the head expression, turn references to generator + -- variables into references to the (freshly chosen) map + -- variable. For substitution in the expression, we avoid all + -- names that are currently visible, including generator names + -- that are by now no longer visible. This should not hurt + -- though, as the information is only used for alpha-conversion + -- on lambdas during substitution. + e'' = substTupleAccesses visibleNames (n, t) env e' + + return $ wrapHead $ NKL.Iterator (listT $ typeOf e') e'' n genExpr + +-- | Express comprehensions through NKL iteration constructs map and +-- concatMap and filter. +desugarComprehensions :: CL.Expr -> NKL.Expr +desugarComprehensions e = +#ifdef DEBUGCOMP + trace (debugPrint eo) eo + + where + eo = runReader (expr e) [] + + padSep :: String -> String + padSep s = "\n" ++ s ++ " " ++ replicate (100 - length s) '=' ++ "\n" + + debugPrint :: NKL.Expr -> String + debugPrint e' = padSep "Desugared NKL" ++ pp e' ++ padSep "" +#else + runReader (expr e) [] +#endif + diff --git a/src/Database/DSH/Translate/FKL2VL.hs b/src/Database/DSH/Translate/FKL2VL.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Translate/FKL2VL.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Database.DSH.Translate.FKL2VL (specializeVectorOps) where + +import Control.Applicative hiding (Const) + +import Control.Monad.Reader + +import Database.Algebra.Dag.Build +import qualified Database.Algebra.Dag.Common as Alg + +import Database.DSH.Common.Lang +import Database.DSH.Common.QueryPlan +import Database.DSH.Common.Type +import Database.DSH.FKL.Lang +import Database.DSH.Impossible +import Database.DSH.VL.Render.JSON () +import Database.DSH.VL.Vector +import qualified Database.DSH.VL.Lang as VL +import Database.DSH.VL.Render.JSON () +import qualified Database.DSH.VL.Vectorize as V +import Database.DSH.VL.Primitives + +-------------------------------------------------------------------------------- +-- Extend the DAG builder monad with an environment for compiled VL +-- DAGs. + +type Env = [(String, Shape VLDVec)] + +type EnvBuild = ReaderT Env (Build VL.VL) + +-- FIXME might need those when let-expressions have been introduced. +lookupEnv :: String -> EnvBuild (Shape VLDVec) +lookupEnv n = ask >>= \env -> case lookup n env of + Just r -> return r + Nothing -> $impossible + +bind :: Ident -> Shape VLDVec -> Env -> Env +bind n e env = (n, e) : env + +-------------------------------------------------------------------------------- +-- Compilation from FKL expressions to a VL DAG. + +fkl2VL :: FExpr -> EnvBuild (Shape VLDVec) +fkl2VL expr = + case expr of + Var _ n -> lookupEnv n + Let _ n e1 e -> do + e1' <- fkl2VL e1 + local (bind n e1') $ fkl2VL e + Table _ n cs hs -> lift $ V.dbTable n cs hs + Const t v -> lift $ V.mkLiteral t v + BinOp _ o NotLifted e1 e2 -> do + SShape p1 lyt <- fkl2VL e1 + SShape p2 _ <- fkl2VL e2 + p <- lift $ vlBinExpr o p1 p2 + return $ SShape p lyt + BinOp _ o Lifted e1 e2 -> do + VShape p1 lyt <- fkl2VL e1 + VShape p2 _ <- fkl2VL e2 + p <- lift $ vlBinExpr o p1 p2 + return $ VShape p lyt + UnOp _ o NotLifted e1 -> do + SShape p1 lyt <- fkl2VL e1 + p <- lift $ vlUnExpr o p1 + return $ SShape p lyt + UnOp _ o Lifted e1 -> do + VShape p1 lyt <- fkl2VL e1 + p <- lift $ vlUnExpr o p1 + return $ VShape p lyt + If _ eb e1 e2 -> do + eb' <- fkl2VL eb + e1' <- fkl2VL e1 + e2' <- fkl2VL e2 + lift $ V.ifList eb' e1' e2' + PApp1 t f l arg -> do + arg' <- fkl2VL arg + lift $ papp1 t f l arg' + PApp2 _ f l arg1 arg2 -> do + arg1' <- fkl2VL arg1 + arg2' <- fkl2VL arg2 + lift $ papp2 f l arg1' arg2' + PApp3 _ p l arg1 arg2 arg3 -> do + arg1' <- fkl2VL arg1 + arg2' <- fkl2VL arg2 + arg3' <- fkl2VL arg3 + lift $ papp3 p l arg1' arg2' arg3' + Ext (Forget n _ arg) -> do + arg' <- fkl2VL arg + return $ V.forget n arg' + Ext (Imprint n _ arg1 arg2) -> do + arg1' <- fkl2VL arg1 + arg2' <- fkl2VL arg2 + return $ V.imprint n arg1' arg2' + MkTuple _ Lifted args -> do + args' <- mapM fkl2VL args + lift $ V.tupleL args' + MkTuple _ NotLifted args -> do + args' <- mapM fkl2VL args + lift $ V.tuple args' + +papp3 :: Prim3 -> Lifted -> Shape VLDVec -> Shape VLDVec -> Shape VLDVec -> Build VL.VL (Shape VLDVec) +papp3 Combine Lifted = V.combineL +papp3 Combine NotLifted = V.combine + +papp1 :: Type -> Prim1 -> Lifted -> Shape VLDVec -> Build VL.VL (Shape VLDVec) +papp1 t f Lifted = + case f of + Singleton -> V.singletonL + Length -> V.lengthL + Concat -> V.concatL + The -> V.theL + Tail -> V.tailL + Reverse -> V.reverseL + Init -> V.initL + Last -> V.lastL + Nub -> V.nubL + Number -> V.numberL + Transpose -> V.transposeL + Reshape n -> V.reshapeL n + And -> V.aggrL VL.AggrAll + Or -> V.aggrL VL.AggrAny + Minimum -> V.aggrL VL.AggrMin + Maximum -> V.aggrL VL.AggrMax + Sum -> V.aggrL $ VL.AggrSum $ typeToScalarType $ elemT t + Avg -> V.aggrL VL.AggrAvg + TupElem i -> V.tupElemL i + +papp1 t f NotLifted = + case f of + Singleton -> V.singleton + Length -> V.length_ + Reshape n -> V.reshape n + Transpose -> V.transpose + Number -> V.number + Nub -> V.nub + Last -> V.last + Init -> V.init + Reverse -> V.reverse + Tail -> V.tail + Concat -> V.concat + The -> V.the + Sum -> V.aggr $ VL.AggrSum $ typeToScalarType t + Avg -> V.aggr VL.AggrAvg + Or -> V.aggr VL.AggrAny + And -> V.aggr VL.AggrAll + Maximum -> V.aggr VL.AggrMax + Minimum -> V.aggr VL.AggrMin + TupElem i -> V.tupElem i + +papp2 :: Prim2 -> Lifted -> Shape VLDVec -> Shape VLDVec -> Build VL.VL (Shape VLDVec) +papp2 f Lifted = + case f of + Dist -> V.distL + Group -> V.groupL + Sort -> V.sortL + Restrict -> V.restrictL + Append -> V.appendL + Index -> V.indexL + Zip -> V.zipL + CartProduct -> V.cartProductL + NestProduct -> V.nestProductL + ThetaJoin p -> V.thetaJoinL p + NestJoin p -> V.nestJoinL p + SemiJoin p -> V.semiJoinL p + AntiJoin p -> V.antiJoinL p + +papp2 f NotLifted = + case f of + Dist -> V.dist + Group -> V.group + Sort -> V.sort + Restrict -> V.restrict + Append -> V.append + Index -> V.index + Zip -> V.zip + CartProduct -> V.cartProduct + NestProduct -> V.nestProduct + ThetaJoin p -> V.thetaJoin p + NestJoin p -> V.nestJoin p + SemiJoin p -> V.semiJoin p + AntiJoin p -> V.antiJoin p + +-- For each top node, determine the number of columns the vector has and insert +-- a dummy projection which just copies those columns. This is to ensure that +-- columns which are required from the top are not pruned by optimizations. +insertTopProjections :: Build VL.VL (Shape VLDVec) -> Build VL.VL (Shape VLDVec) +insertTopProjections g = g >>= traverseShape + + where + traverseShape :: Shape VLDVec -> Build VL.VL (Shape VLDVec) + traverseShape (VShape (VLDVec q) lyt) = + insertProj lyt q VL.Project VLDVec VShape + traverseShape (SShape (VLDVec q) lyt) = + insertProj lyt q VL.Project VLDVec SShape + + traverseLayout :: (Layout VLDVec) -> Build VL.VL (Layout VLDVec) + traverseLayout (LCol c) = return $ LCol c + traverseLayout (LTuple lyts) = LTuple <$> mapM traverseLayout lyts + traverseLayout (LNest (VLDVec q) lyt) = + insertProj lyt q VL.Project VLDVec LNest + + insertProj + :: Layout VLDVec -- ^ The node's layout + -> Alg.AlgNode -- ^ The top node to consider + -> ([VL.Expr] -> VL.UnOp) -- ^ Constructor for the projection op + -> (Alg.AlgNode -> v) -- ^ Vector constructor + -> (v -> (Layout VLDVec) -> t) -- ^ Layout/Shape constructor + -> Build VL.VL t + insertProj lyt q project vector describe = do + let width = columnsInLayout lyt + cols = [1 .. width] + qp <- insert $ Alg.UnOp (project $ map VL.Column cols) q + lyt' <- traverseLayout lyt + return $ describe (vector qp) lyt' + +-- | Compile a FKL expression into a query plan of vector operators (VL) +specializeVectorOps :: FExpr -> QueryPlan VL.VL VLDVec +specializeVectorOps e = mkQueryPlan opMap shape tagMap + where + (opMap, shape, tagMap) = runBuild (insertTopProjections $ runReaderT (fkl2VL e) []) diff --git a/src/Database/DSH/Translate/Frontend2CL.hs b/src/Database/DSH/Translate/Frontend2CL.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Translate/Frontend2CL.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Translate DSH frontend expressions (implicitly typed through +-- GADT) into explicitly typed DSH backend expressions. +module Database.DSH.Translate.Frontend2CL (toComprehensions) where + +import Database.DSH.Impossible + +import qualified Database.DSH.CL.Lang as CL +import qualified Database.DSH.CL.Primitives as CP +import qualified Database.DSH.Common.Lang as L +import qualified Database.DSH.Common.Type as T + +import Data.Text (unpack) +import Database.DSH.Frontend.Funs +import Database.DSH.Frontend.TupleTypes +import Database.DSH.Frontend.Internals + +import qualified Data.Map as M + +import Control.Applicative +import Control.Monad +import Control.Monad.State + +import Text.Printf + +import GHC.Exts (sortWith) + +-- | For each column, we need the name of the column, a string +-- description of the type for error messsages and a function to check +-- a DSH base type for compability with the column. +type TableInfo = [(String, String, (T.Type -> Bool))] + +type TableInfoCache = M.Map String TableInfo + +type QueryTableInfo = String -> IO TableInfo + +-- In the state, we store a counter for fresh variable names, the +-- cache for table information and the backend-specific IO function +-- that retrieves not-yet-cached table information. +type CompileState = (Integer, TableInfoCache, QueryTableInfo) + +-- | The Compile monad provides fresh variable names, allows to +-- retrieve information about tables from the database backend and +-- caches table information. +type Compile = StateT CompileState IO + +-- | Lookup information that describes a table. If the information is +-- not present in the state then the connection is used to retrieve +-- the table information from the Database. +tableInfo :: String -> Compile TableInfo +tableInfo tableName = do + (i, env, f) <- get + case M.lookup tableName env of + Nothing -> do + inf <- getTableInfoFun tableName + put (i, M.insert tableName inf env, f) + return inf + Just v -> return v + +-- | Provide a fresh identifier name during compilation +freshVar :: Compile Integer +freshVar = do + (i, m, f) <- get + put (i + 1, m, f) + return i + +prefixVar :: Integer -> String +prefixVar i = "v" ++ show i + +getTableInfoFun :: String -> Compile TableInfo +getTableInfoFun tableName = do + (_, _, queryTableInfo) <- get + lift $ queryTableInfo tableName + +-- | Translate a DSH frontend expression into the internal +-- comprehension-based language. 'queryTableInfo' abstracts asking a +-- database for information about tables, which might be performed +-- using one of the existing backends (X100, SQL). +toComprehensions :: QueryTableInfo -> Exp a -> IO CL.Expr +toComprehensions queryTableInfo e = runCompile queryTableInfo $ translate e + +-- | Execute the transformation computation. During compilation table +-- information can be retrieved from the database, therefore the result +-- is wrapped in the IO Monad. +runCompile :: QueryTableInfo -> Compile a -> IO a +runCompile f = liftM fst . flip runStateT (1, M.empty, f) + +lamBody :: forall a b.(Reify a, Reify b) => (Exp a -> Exp b) -> Compile (L.Ident, Exp b) +lamBody f = do + v <- freshVar + return (prefixVar v, f (VarE v :: Exp a)) + +-- | Translate a frontend HOAS AST to a FOAS AST in Comprehension +-- Language (CL). +translate :: forall a. Exp a -> Compile CL.Expr +translate (TupleConstE tc) = let translateTupleConst = $(mkTranslateTupleTerm 16) + in translateTupleConst tc +translate UnitE = return $ CP.unit +translate (BoolE b) = return $ CP.bool b +translate (CharE c) = return $ CP.string [c] +translate (IntegerE i) = return $ CP.int (fromInteger i) +translate (DoubleE d) = return $ CP.double d +translate (TextE t) = return $ CP.string (unpack t) +translate (VarE i) = do + let ty = reify (undefined :: a) + return $ CP.var (translateType ty) (prefixVar i) +translate (ListE es) = do + let ty = reify (undefined :: a) + CP.list (translateType ty) <$> mapM translate es +-- We expect the query language to be first order. Lambdas must only +-- occur as an argument to higher-order built-in combinators (map, +-- concatMap, sortWith, ...). If lambdas occur in other places that +-- have not been eliminated by inlining in the frontend, additional +-- normalization rules or defunctionalization should be employed. +translate (LamE _) = $impossible +translate (TableE (TableDB tableName hints)) = do + -- Reify the type of the table expression + let ty = reify (undefined :: a) + + -- Extract the column types from the frontend type + let ts = T.tupleElemTypes $ T.elemT $ translateType ty + + -- Fetch the actual type of the table from the database + -- backend. Since we can't refer to columns by name from the + -- Haskell side, we sort the columns by name to get a canonical + -- order. + tableDescr <- sortWith (\(n, _, _) -> n) <$> tableInfo tableName + + let tableTypeError = printf "DSH type and type of table %s are incompatible:\nDSH: %s\nDatabase: %s" + tableName + (show ts) + (show $ map (\(n, t, _) -> (n, t)) tableDescr) + + -- The DSH record/tuple type must match the number of columns in + -- the database table + if length tableDescr == length ts + then return () + else error tableTypeError + + let matchTypes :: (String, String, T.Type -> Bool) -> T.Type -> (L.ColName, T.Type) + matchTypes (colName, _, typesCompatible) dshType = + if typesCompatible dshType + then (L.ColName colName, dshType) + else error tableTypeError + + let cols = zipWith matchTypes tableDescr ts + + return $ CP.table (translateType ty) tableName cols (compileHints hints) + +translate (AppE f args) = translateApp f args + +compileHints :: TableHints -> L.TableHints +compileHints hints = L.TableHints { L.keysHint = keys $ keysHint hints + , L.nonEmptyHint = ne $ nonEmptyHint hints + } + where + keys :: [Key] -> [L.Key] + keys ks = [ L.Key [ L.ColName c | c <- k ] | Key k <- ks ] + + ne :: Emptiness -> L.Emptiness + ne NonEmpty = L.NonEmpty + ne PossiblyEmpty = L.PossiblyEmpty + + +translateApp3 :: (CL.Expr -> CL.Expr -> CL.Expr -> CL.Expr) -> Exp (a, b, c) -> Compile CL.Expr +translateApp3 f (TupleConstE (Tuple3E e1 e2 e3)) = f <$> translate e1 <*> translate e2 <*> translate e3 +translateApp3 _ _ = $impossible + +translateApp2 :: (CL.Expr -> CL.Expr -> CL.Expr) -> Exp (a, b) -> Compile CL.Expr +translateApp2 f (TupleConstE (Tuple2E e1 e2)) = f <$> translate e1 <*> translate e2 +translateApp2 _ _ = $impossible + +translateApp1 :: (CL.Expr -> CL.Expr) -> Exp a -> Compile CL.Expr +translateApp1 f e = f <$> translate e + +-- | Translate DSH frontend types into backend types. +translateType :: Type a -> T.Type +translateType UnitT = T.unitT +translateType BoolT = T.boolT +translateType CharT = T.stringT +translateType IntegerT = T.intT +translateType DoubleT = T.doubleT +translateType TextT = T.stringT +translateType (ListT t) = T.listT (translateType t) +translateType (TupleT tupTy) = let translateTupleType = $(mkTranslateType 16) + in translateTupleType tupTy +translateType (ArrowT t1 t2) = $impossible + +-- | From the type of a table (a list of base records represented as +-- right-deep nested tuples) extract the types of the individual +-- fields. + +translateApp :: Fun a b -> Exp a -> Compile CL.Expr +translateApp f args = + case f of + -- Builtin functions with arity three + Cond -> translateApp3 CP.cond args + + -- Builtin functions with arity two + Add -> translateApp2 CP.add args + Mul -> translateApp2 CP.mul args + Sub -> translateApp2 CP.sub args + Div -> translateApp2 CP.div args + Mod -> translateApp2 CP.mod args + Index -> translateApp2 CP.index args + Cons -> translateApp2 CP.cons args + + -- Map to a comprehension + Map -> + case args of + TupleConstE (Tuple2E (LamE lam) xs) -> do + xs' <- translate xs + (boundVar, bodyExp) <- lamBody lam + bodyExp' <- translate bodyExp + return $ CP.singleGenComp bodyExp' boundVar xs' + _ -> $impossible + + -- Map to a comprehension and concat + ConcatMap -> + case args of + TupleConstE (Tuple2E (LamE lam) xs) -> do + xs' <- translate xs + (boundVar, bodyExp) <- lamBody lam + bodyExp' <- translate bodyExp + return $ CP.concat $ CP.singleGenComp bodyExp' boundVar xs' + _ -> $impossible + + -- Map to a first-order combinator 'sort' + SortWith -> + case args of + TupleConstE (Tuple2E (LamE lam) xs) -> do + xs' <- translate xs + (boundVar, bodyExp) <- lamBody lam + bodyExp' <- translate bodyExp + genName <- prefixVar <$> freshVar + + let genVar = CL.Var (T.typeOf xs') genName + ss = CP.singleGenComp bodyExp' boundVar genVar + return $ CP.let_ genName xs' (CP.sort genVar ss) + _ -> $impossible + + -- Map to a comprehension with a guard + Filter -> + case args of + TupleConstE (Tuple2E (LamE lam) xs) -> do + xs' <- translate xs + (boundVar, bodyExp) <- lamBody lam + bodyExp' <- translate bodyExp + let xt = T.typeOf xs' + quals = CL.BindQ boundVar xs' CL.:* (CL.S $ CL.GuardQ bodyExp') + return $ CL.Comp xt (CL.Var xt boundVar) quals + _ -> $impossible + + -- Map to a first-order combinator 'group' + GroupWithKey -> + case args of + TupleConstE (Tuple2E (LamE lam) xs) -> do + xs' <- translate xs + (boundVar, bodyExp) <- lamBody lam + bodyExp' <- translate bodyExp + genName <- prefixVar <$> freshVar + + let genVar = CL.Var (T.typeOf xs') genName + ss = CP.singleGenComp bodyExp' boundVar genVar + return $ CP.let_ genName xs' (CP.group genVar ss) + _ -> $impossible + + Append -> translateApp2 CP.append args + Zip -> translateApp2 CP.zip args + Equ -> translateApp2 CP.eq args + NEq -> translateApp2 CP.neq args + Conj -> translateApp2 CP.conj args + Disj -> translateApp2 CP.disj args + Lt -> translateApp2 CP.lt args + Lte -> translateApp2 CP.lte args + Gte -> translateApp2 CP.gte args + Gt -> translateApp2 CP.gt args + Like -> translateApp2 CP.like args + + -- Builtin functions with arity one + SubString f t -> translateApp1 (CP.substring f t) args + IntegerToDouble -> translateApp1 CP.castDouble args + Not -> translateApp1 CP.not args + Sin -> translateApp1 CP.sin args + Cos -> translateApp1 CP.cos args + Tan -> translateApp1 CP.tan args + ASin -> translateApp1 CP.asin args + ACos -> translateApp1 CP.acos args + ATan -> translateApp1 CP.atan args + Sqrt -> translateApp1 CP.sqrt args + Log -> translateApp1 CP.log args + Exp -> translateApp1 CP.exp args + Fst -> translateApp1 CP.fst args + Snd -> translateApp1 CP.snd args + Head -> translateApp1 CP.head args + Tail -> translateApp1 CP.tail args + Minimum -> translateApp1 CP.minimum args + Maximum -> translateApp1 CP.maximum args + Concat -> translateApp1 CP.concat args + Sum -> translateApp1 CP.sum args + Avg -> translateApp1 CP.avg args + And -> translateApp1 CP.and args + Or -> translateApp1 CP.or args + Reverse -> translateApp1 CP.reverse args + Number -> translateApp1 CP.number args + Length -> translateApp1 CP.length args + Null -> translateApp1 CP.null args + Init -> translateApp1 CP.init args + Last -> translateApp1 CP.last args + Nub -> translateApp1 CP.nub args + Guard -> translateApp1 CP.guard args + Transpose -> translateApp1 CP.transpose args + Reshape n -> translateApp1 (CP.reshape n) args + TupElem te -> let compileTupElem = $(mkTupElemCompile 16) + in compileTupElem te args diff --git a/src/Database/DSH/Translate/NKL2FKL.hs b/src/Database/DSH/Translate/NKL2FKL.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Translate/NKL2FKL.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | The Flattening Transformation +module Database.DSH.Translate.NKL2FKL (flatTransform) where + +-- FIXME use more let bindings to avoid term replication, e.g. in if conditionals +-- FIXME make sure that no wrong shadowing occurs while lifting or restricting the environment. + +import Control.Monad.State +import Control.Monad.Reader +import Control.Applicative + +import Database.DSH.Impossible +import Database.DSH.Common.Lang +import Database.DSH.Common.Nat +import Database.DSH.Common.Type +import qualified Database.DSH.FKL.Lang as F +import qualified Database.DSH.FKL.Primitives as P +import Database.DSH.FKL.Rewrite +import qualified Database.DSH.NKL.Lang as N + +-- | Transform an expression in the Nested Kernel Language into its +-- equivalent Flat Kernel Language expression by means of the +-- flattening transformation. +flatTransform :: N.Expr -> F.FExpr +flatTransform expr = optimizeFKL "FKL" + $ normalize + $ optimizeFKL "FKL Intermediate" + $ runFlat initEnv (flatten expr) + +-------------------------------------------------------------------------------- +-- The Flattening Transformation + +-------------------------------------------------------------------------------- +-- Translation of built-in combinators. Combinators are lifted +-- according to the iteration depth at which they are encountered. + +prim1 :: N.Prim1 -> F.LExpr -> Nat -> F.LExpr +prim1 p = + case p of + N.Singleton -> P.sng + N.Length -> P.length + N.Concat -> P.concat + N.Sum -> P.sum + N.Avg -> P.avg + N.The -> P.the + N.TupElem n -> P.tupElem n + N.Head -> P.head + N.Tail -> P.tail + N.Minimum -> P.minimum + N.Maximum -> P.maximum + N.Reverse -> P.reverse + N.And -> P.and + N.Or -> P.or + N.Init -> P.init + N.Last -> P.last + N.Nub -> P.nub + N.Number -> P.number + N.Reshape n -> P.reshape n + N.Transpose -> P.transpose + +prim2 :: N.Prim2 -> F.LExpr -> F.LExpr -> Nat -> F.LExpr +prim2 p = + case p of + N.Group -> P.group + N.Sort -> P.sort + N.Restrict -> P.restrict + N.Append -> P.append + N.Index -> P.index + N.Zip -> P.zip + N.CartProduct -> P.cartProduct + N.NestProduct -> P.nestProduct + N.ThetaJoin jp -> P.thetaJoin jp + N.NestJoin jp -> P.nestJoin jp + N.SemiJoin jp -> P.semiJoin jp + N.AntiJoin jp -> P.antiJoin jp + +-------------------------------------------------------------------------------- +-- Flattening environment + +type Flatten a = Reader Env a + +runFlat :: Env -> Flatten a -> a +runFlat env ma = runReader ma env + +envVar :: (Ident, Type) -> F.LExpr +envVar (n, t) = F.Var t n + +-- | The environment stores all variables which are currently in scope and the current iteration depth. +data Env = Env + { -- | All bindings which are currently in scope and need to be + -- lifted to the current iteration context. + inScope :: [(Ident, Type)] + + -- | The current iteration depth + , frameDepth :: Nat + } + +initEnv :: Env +initEnv = Env { inScope = [], frameDepth = Zero } + +bindEnv :: Ident -> Type -> Env -> Env +bindEnv n t e = e { inScope = (n, t) : inScope e } + +-- | Update the environment to express the descent into a +-- comprehension that binds the name 'x'. This involves binding 'x' in +-- the current environment frame and increasing the frame depth. +descendEnv :: (Ident, Type) -> Env -> Env +descendEnv x env = env { inScope = x : inScope env + , frameDepth = Succ $ frameDepth env + } + +frameDepthM :: Flatten Nat +frameDepthM = asks frameDepth + +-- | Restrict all environment entries according to a boolean vector +-- ('then' or 'else' branch). +restrictEnv :: [(Ident, Type)] -> Nat -> F.LExpr -> F.LExpr -> F.LExpr +restrictEnv env d1 bs branchExpr = mkRestrictLet env + where + mkRestrictLet :: [(Ident, Type)] -> F.LExpr + mkRestrictLet [] = $impossible + mkRestrictLet (e : []) = + P.let_ (fst e) + (P.restrict (envVar e) bs d1) + branchExpr + mkRestrictLet (e : (e2 : es)) = + P.let_ (fst e) + (P.restrict (envVar e) bs d1) + (mkRestrictLet (e2 : es)) + +-- | Lift all names bound in the environment: the value is replicated +-- for each element of the current context. The chain of 'let's is +-- terminated by the flattened head expression of the current +-- iterator. +liftEnv :: (Ident, Type) -> Nat -> F.LExpr -> [(Ident, Type)] -> F.LExpr +liftEnv ctx d headExpr env = mkLiftingLet env + where + mkLiftingLet :: [(Ident, Type)] -> F.LExpr + mkLiftingLet [] = headExpr + mkLiftingLet (e : []) = + P.let_ (fst e) (P.dist (envVar e) cv d) headExpr + mkLiftingLet (e : (e2 : es)) = + P.let_ (fst e) (P.dist (envVar e) cv d) (mkLiftingLet (e2 : es)) + + cv :: F.LExpr + cv = envVar ctx + + +-------------------------------------------------------------------------------- + +-- | Transform top-level expressions which are not nested in an +-- iterator. +flatten :: N.Expr -> Flatten F.LExpr +flatten (N.Table t n cs hs) = return $ F.Table t n cs hs +flatten (N.UnOp t op e1) = P.un t op <$> flatten e1 <*> pure Zero +flatten (N.BinOp t op e1 e2) = P.bin t op <$> flatten e1 <*> flatten e2 <*> pure Zero +flatten (N.Const t v) = return $ F.Const t v +flatten (N.Var t v) = return $ F.Var t v +flatten (N.If t ce te ee) = F.If t <$> flatten ce <*> flatten te <*> flatten ee +flatten (N.AppE1 _ p e) = prim1 p <$> flatten e <*> pure Zero +flatten (N.AppE2 _ p e1 e2) = prim2 p <$> flatten e1 <*> flatten e2 <*> pure Zero +flatten (N.Let _ x xs e) = P.let_ x <$> flatten xs <*> local (bindEnv x (typeOf xs)) (flatten e) +flatten (N.MkTuple _ es) = P.tuple <$> mapM flatten es <*> pure Zero +flatten (N.Iterator _ h x xs) = do + -- Prepare an environment in which the current generator is the + -- context + let initCtx = (x, typeOf xs) + + -- In this environment, transform the iterator head + flatHead <- local (descendEnv initCtx) (deepFlatten initCtx h) + + P.let_ x <$> flatten xs <*> (liftEnv initCtx Zero flatHead <$> asks inScope) + +-------------------------------------------------------------------------------- + +-- | Compile expressions nested in an iterator. +deepFlatten :: (Ident, Type) -> N.Expr -> Flatten F.LExpr +deepFlatten _ (N.Var t v) = frameDepthM >>= \d -> return $ F.Var (liftTypeN d t) v +deepFlatten ctx (N.Table t n cs hs) = P.broadcast (F.Table t n cs hs) (envVar ctx) <$> frameDepthM +deepFlatten ctx (N.Const t v) = P.broadcast (F.Const t v) (envVar ctx) <$> frameDepthM +deepFlatten ctx (N.UnOp t op e1) = P.un t op <$> deepFlatten ctx e1 <*> frameDepthM +deepFlatten ctx (N.BinOp t op e1 e2) = P.bin t op <$> deepFlatten ctx e1 <*> deepFlatten ctx e2 <*> frameDepthM +deepFlatten ctx (N.MkTuple _ es) = frameDepthM >>= \d -> P.tuple <$> mapM (deepFlatten ctx) es <*> pure d +deepFlatten ctx (N.AppE1 _ p e) = prim1 p <$> deepFlatten ctx e <*> frameDepthM +deepFlatten ctx (N.AppE2 _ p e1 e2) = prim2 p <$> deepFlatten ctx e1 <*> deepFlatten ctx e2 <*> frameDepthM + +deepFlatten ctx (N.Let _ x xs e) = P.let_ x <$> deepFlatten ctx xs + <*> local (bindEnv x (typeOf xs)) (deepFlatten ctx e) + +deepFlatten ctx (N.If _ ce te ee) = do + Succ d1 <- frameDepthM + + -- Lift the condition + bs <- deepFlatten ctx ce + + -- Lift the THEN branch. Note that although the environment record + -- does not change, all environment variables are re-bound to a + -- restricted environment by 'restrictEnv'. + thenExpr <- deepFlatten ctx te + + -- Lift the ELSE branch. See comment above. + elseExpr <- deepFlatten ctx ee + + env <- asks inScope + + -- Construct the restricted environments in which the THEN and + -- ELSE branches are evaluated. + let notL xs = P.un boolT (SUBoolOp Not) xs (Succ d1) + + thenRes = restrictEnv env d1 bs thenExpr + + elseRes = restrictEnv env d1 (notL bs) elseExpr + + return $ P.combine bs thenRes elseRes d1 + +-- FIXME lift types in the environment (add one list type constructor) +deepFlatten ctx (N.Iterator _ h x xs) = do + d <- frameDepthM + env <- asks inScope + let ctx' = (x, liftTypeN (Succ d) (typeOf xs)) + headExpr <- local (descendEnv ctx') $ deepFlatten ctx' h + + xs' <- deepFlatten ctx xs + + return $ P.let_ x xs' (liftEnv ctx' d headExpr env) + + +-------------------------------------------------------------------------------- +-- Normalization of intermediate flat expressions into the final +-- form. This step eliminates higher-lifted occurences of built-in +-- combinators. + +type Supply = Int + +type NormFlat a = State Supply a + +freshNameN :: NormFlat Ident +freshNameN = do + i <- get + put $ i + 1 + return $ "nf" ++ show i + +normalize :: F.LExpr -> F.FExpr +normalize e = evalState (normLifting e) 0 + +implementBroadcast :: F.BroadcastExt -> NormFlat F.FExpr +implementBroadcast (F.Broadcast d _ e1 e2) = do + e1' <- normLifting e1 + e2' <- normLifting e2 + case d of + Zero -> $impossible + Succ Zero -> return $ P.fdist e1' e2' + -- FIXME use let-binding + Succ d1@(Succ _) -> return $ P.imprint d1 e2' (P.fdist e1' (P.forget d1 e2')) + +-- | Reduce all higher-lifted occurences of primitive combinators and +-- operators to singly lifted variants by flattening the arguments and +-- restoring the original list shape on the result. +normLifting :: F.LExpr -> NormFlat F.FExpr +normLifting (F.Table t n cs hs) = return $ F.Table t n cs hs +normLifting (F.If t ce te ee) = F.If t <$> normLifting ce <*> normLifting te <*> normLifting ee +normLifting (F.Const t v) = return $ F.Const t v +normLifting (F.Var t n) = return $ F.Var t n +normLifting (F.Let t x e1 e2) = F.Let t x <$> normLifting e1 <*> normLifting e2 +normLifting (F.Ext b) = implementBroadcast b +normLifting (F.MkTuple t l es) = + case l of + F.LiftedN Zero -> F.MkTuple t F.NotLifted <$> mapM normLifting es + F.LiftedN (Succ Zero) -> F.MkTuple t F.Lifted <$> mapM normLifting es + F.LiftedN (Succ d) -> do + e1' : es' <- mapM normLifting es + n <- freshNameN + let v = F.Var (typeOf e1') n + app = F.MkTuple (unliftTypeN d t) F.Lifted (P.forget d v : map (P.forget d) es') + return $ P.let_ n e1' $ P.imprint d v app + +normLifting (F.UnOp t op l e) = + case l of + F.LiftedN Zero -> F.UnOp t op F.NotLifted <$> normLifting e + F.LiftedN (Succ Zero) -> F.UnOp t op F.Lifted <$> normLifting e + F.LiftedN (Succ d) -> do + e' <- normLifting e + n <- freshNameN + let v = F.Var (typeOf e') n + app = F.UnOp (unliftTypeN d t) op F.Lifted (P.forget d v) + return $ P.let_ n e' $ P.imprint d v app + +normLifting (F.BinOp t op l e1 e2) = + case l of + F.LiftedN Zero -> F.BinOp t op F.NotLifted + <$> normLifting e1 + <*> normLifting e2 + F.LiftedN (Succ Zero) -> F.BinOp t op F.Lifted + <$> normLifting e1 + <*> normLifting e2 + F.LiftedN (Succ d) -> do + e1' <- normLifting e1 + e2' <- normLifting e2 + n <- freshNameN + let v = F.Var (typeOf e1') n + app = F.BinOp (unliftTypeN d t) op F.Lifted (P.forget d v) (P.forget d e2') + return $ P.let_ n e1' $ P.imprint d v app + +normLifting (F.PApp1 t p l e) = + case l of + F.LiftedN Zero -> F.PApp1 t p F.NotLifted <$> normLifting e + F.LiftedN (Succ Zero) -> F.PApp1 t p F.Lifted <$> normLifting e + F.LiftedN (Succ d) -> do + e' <- normLifting e + n <- freshNameN + let v = F.Var (typeOf e') n + app = F.PApp1 (unliftTypeN d t) p F.Lifted (P.forget d v) + return $ P.let_ n e' (P.imprint d v app) + +normLifting (F.PApp2 t p l e1 e2) = + case l of + F.LiftedN Zero -> F.PApp2 t p F.NotLifted + <$> normLifting e1 + <*> normLifting e2 + F.LiftedN (Succ Zero) -> F.PApp2 t p F.Lifted + <$> normLifting e1 + <*> normLifting e2 + F.LiftedN (Succ d) -> do + e1' <- normLifting e1 + e2' <- normLifting e2 + n <- freshNameN + let v = F.Var (typeOf e1') n + app = F.PApp2 (unliftTypeN d t) p F.Lifted (P.forget d v) (P.forget d e2') + return $ P.let_ n e1' $ P.imprint d v app + +normLifting (F.PApp3 t p l e1 e2 e3) = + case l of + F.LiftedN Zero -> F.PApp3 t p F.NotLifted + <$> normLifting e1 + <*> normLifting e2 + <*> normLifting e3 + F.LiftedN (Succ Zero) -> F.PApp3 t p F.Lifted + <$> normLifting e1 + <*> normLifting e2 + <*> normLifting e3 + F.LiftedN (Succ d) -> do + e1' <- normLifting e1 + e2' <- normLifting e2 + e3' <- normLifting e3 + n <- freshNameN + let v = F.Var (typeOf e1') n + app = F.PApp3 (unliftTypeN d t) p F.Lifted (P.forget d v) + (P.forget d e2') + (P.forget d e3') + return $ P.let_ n e1' $ P.imprint d v app diff --git a/src/Database/DSH/Translate/VL2Algebra.hs b/src/Database/DSH/Translate/VL2Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/Translate/VL2Algebra.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} + +module Database.DSH.Translate.VL2Algebra + ( implementVectorOpsPF + ) where + +import qualified Data.IntMap as IM +import Data.List +import qualified Data.Map as M +import Data.Maybe + +import Control.Applicative +import Control.Monad.State + +import qualified Database.Algebra.Dag as D +import qualified Database.Algebra.Dag.Build as B +import Database.Algebra.Dag.Common +import qualified Database.Algebra.Table.Lang as TA + +import Database.DSH.Impossible +import Database.DSH.Common.QueryPlan +import Database.DSH.Translate.FKL2VL () +import Database.DSH.VL.Vector +import qualified Database.DSH.VL.Lang as V +import Database.DSH.VL.VectorAlgebra +import Database.DSH.VL.VectorAlgebra.TA () + +-- | A layer on top of the DAG builder monad that caches the +-- translation result of VL nodes. +type VecBuild a v = StateT (M.Map AlgNode (Res v)) (B.Build a) + +runVecBuild :: VectorAlgebra v a => VecBuild a v r -> (D.AlgebraDag a, r, NodeMap [Tag]) +runVecBuild c = B.runBuild $ fst <$> runStateT c M.empty + +data Res v = Prop AlgNode + | Rename AlgNode + | RDVec v + | RLPair (Res v) (Res v) + | RTriple (Res v) (Res v) (Res v) + deriving Show + +fromDict :: VectorAlgebra v a => AlgNode -> VecBuild a v (Maybe (Res v)) +fromDict n = do + dict <- get + return $ M.lookup n dict + +insertTranslation :: VectorAlgebra v a => AlgNode -> Res v -> VecBuild a v () +insertTranslation n res = modify (M.insert n res) + +fromPVec :: PVec -> Res v +fromPVec (PVec p) = Prop p + +toPVec :: Res v -> PVec +toPVec (Prop p) = PVec p +toPVec _ = error "toPVec: Not a prop vector" + +fromRVec :: RVec -> Res v +fromRVec (RVec r) = Rename r + +toRVec :: Res v -> RVec +toRVec (Rename r) = RVec r +toRVec _ = error "toRVec: Not a rename vector" + +fromDVec :: v -> Res v +fromDVec v = RDVec v + +toDVec :: Res v -> v +toDVec (RDVec v) = v +toDVec _ = error "toDVec: Not a NDVec" + +refreshLyt :: VectorAlgebra v a => Layout VLDVec -> VecBuild a v (Layout v) +refreshLyt (LCol c) = return $ LCol c +refreshLyt (LNest (VLDVec n) lyt) = do + Just n' <- fromDict n + lyt' <- refreshLyt lyt + return $ LNest (toDVec n') lyt' +refreshLyt (LTuple lyts) = LTuple <$> mapM refreshLyt lyts + +refreshShape :: VectorAlgebra v a => Shape VLDVec -> VecBuild a v (Shape v) +refreshShape (VShape (VLDVec n) lyt) = do + mv <- fromDict n + case mv of + Just v -> do + lyt' <- refreshLyt lyt + return $ VShape (toDVec v) lyt' + _ -> $impossible +refreshShape (SShape (VLDVec n) lyt) = do + mv <- fromDict n + case mv of + Just (RDVec v) -> do + lyt' <- refreshLyt lyt + return $ SShape v lyt' + _ -> $impossible + +translate :: VectorAlgebra v a => NodeMap V.VL -> AlgNode -> VecBuild a v (Res v) +translate vlNodes n = do + r <- fromDict n + + case r of + -- The VL node has already been encountered and translated. + Just res -> return $ res + + -- The VL node has not been translated yet. + Nothing -> do + let vlOp = getVL n vlNodes + r' <- case vlOp of + TerOp t c1 c2 c3 -> do + c1' <- translate vlNodes c1 + c2' <- translate vlNodes c2 + c3' <- translate vlNodes c3 + lift $ translateTerOp t c1' c2' c3' + BinOp b c1 c2 -> do + c1' <- translate vlNodes c1 + c2' <- translate vlNodes c2 + lift $ translateBinOp b c1' c2' + UnOp u c1 -> do + c1' <- translate vlNodes c1 + lift $ translateUnOp u c1' + NullaryOp o -> lift $ translateNullary o + + insertTranslation n r' + return r' + +getVL :: AlgNode -> NodeMap V.VL -> V.VL +getVL n vlNodes = case IM.lookup n vlNodes of + Just op -> op + Nothing -> error $ "getVL: node " ++ (show n) ++ " not in VL nodes map " ++ (pp vlNodes) + +pp :: NodeMap V.VL -> String +pp m = intercalate ",\n" $ map show $ IM.toList m + +vl2Algebra :: VectorAlgebra v a => NodeMap V.VL -> Shape VLDVec -> VecBuild a v (Shape v) +vl2Algebra vlNodes plan = do + mapM_ (translate vlNodes) roots + + refreshShape plan + where + roots :: [AlgNode] + roots = shapeNodes plan + +translateTerOp :: VectorAlgebra v a => V.TerOp -> Res v -> Res v -> Res v -> B.Build a (Res v) +translateTerOp t c1 c2 c3 = + case t of + V.Combine -> do + (d, r1, r2) <- vecCombine (toDVec c1) (toDVec c2) (toDVec c3) + return $ RTriple (fromDVec d) (fromRVec r1) (fromRVec r2) + +translateBinOp :: VectorAlgebra v a => V.BinOp -> Res v -> Res v -> B.Build a (Res v) +translateBinOp b c1 c2 = case b of + V.DistLift -> do + (v, p) <- vecDistLift (toDVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromPVec p) + + V.PropRename -> fromDVec <$> vecPropRename (toRVec c1) (toDVec c2) + + V.PropFilter -> do + (v, r) <- vecPropFilter (toRVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromRVec r) + + V.PropReorder -> do + (v, p) <- vecPropReorder (toPVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromPVec p) + + V.UnboxNested -> do + (v, r) <- vecUnboxNested (toRVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromRVec r) + + V.UnboxScalar -> RDVec <$> vecUnboxScalar (toDVec c1) (toDVec c2) + + V.Append -> do + (v, r1, r2) <- vecAppend (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromRVec r1) (fromRVec r2) + + V.AppendS -> do + (v, r1, r2) <- vecAppendS (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromRVec r1) (fromRVec r2) + + V.AggrS a -> fromDVec <$> vecAggrS a (toDVec c1) (toDVec c2) + + + V.SelectPos o -> do + (v, r, ru) <- vecSelectPos (toDVec c1) o (toDVec c2) + return $ RTriple (fromDVec v) (fromRVec r) (fromRVec ru) + + V.SelectPosS o -> do + (v, rp, ru) <- vecSelectPosS (toDVec c1) o (toDVec c2) + return $ RTriple (fromDVec v) (fromRVec rp) (fromRVec ru) + + V.Zip -> fromDVec <$> vecZip (toDVec c1) (toDVec c2) + V.Align -> fromDVec <$> vecZip (toDVec c1) (toDVec c2) + + V.ZipS -> do + (v, r1 ,r2) <- vecZipS (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromRVec r1) (fromRVec r2) + + V.CartProduct -> do + (v, p1, p2) <- vecCartProduct (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2) + + V.CartProductS -> do + (v, p1, p2) <- vecCartProductS (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2) + + V.NestProductS -> do + (v, p2) <- vecNestProductS (toDVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromPVec p2) + + V.ThetaJoin p -> do + (v, p1, p2) <- vecThetaJoin p (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2) + + V.NestProduct -> do + (v, p1, p2) <- vecNestProduct (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2) + + V.NestJoin p -> do + (v, p1, p2) <- vecNestJoin p (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2) + + V.ThetaJoinS p -> do + (v, p1, p2) <- vecThetaJoinS p (toDVec c1) (toDVec c2) + return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2) + + V.NestJoinS p -> do + (v, p2) <- vecNestJoinS p (toDVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromPVec p2) + + V.SemiJoin p -> do + (v, r) <- vecSemiJoin p (toDVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromRVec r) + + V.SemiJoinS p -> do + (v, r) <- vecSemiJoinS p (toDVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromRVec r) + + V.AntiJoin p -> do + (v, r) <- vecAntiJoin p (toDVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromRVec r) + + V.AntiJoinS p -> do + (v, r) <- vecAntiJoinS p (toDVec c1) (toDVec c2) + return $ RLPair (fromDVec v) (fromRVec r) + + V.TransposeS -> do + (qo, qi) <- vecTransposeS (toDVec c1) (toDVec c2) + return $ RLPair (fromDVec qo) (fromDVec qi) + +translateUnOp :: VectorAlgebra v a => V.UnOp -> Res v -> B.Build a (Res v) +translateUnOp unop c = case unop of + V.AggrNonEmptyS a -> fromDVec <$> vecAggrNonEmptyS a (toDVec c) + V.UniqueS -> fromDVec <$> vecUniqueS (toDVec c) + V.Number -> fromDVec <$> vecNumber (toDVec c) + V.NumberS -> fromDVec <$> vecNumberS (toDVec c) + V.UnboxRename -> fromRVec <$> descToRename (toDVec c) + V.Segment -> fromDVec <$> vecSegment (toDVec c) + V.Unsegment -> fromDVec <$> vecUnsegment (toDVec c) + V.Aggr a -> fromDVec <$> vecAggr a (toDVec c) + V.WinFun (a, w) -> fromDVec <$> vecWinFun a w (toDVec c) + V.AggrNonEmpty as -> fromDVec <$> vecAggrNonEmpty as (toDVec c) + V.Select e -> do + (d, r) <- vecSelect e (toDVec c) + return $ RLPair (fromDVec d) (fromRVec r) + V.SortS es -> do + (d, p) <- vecSortS es (toDVec c) + return $ RLPair (fromDVec d) (fromPVec p) + V.GroupS es -> do + (qo, qi, p) <- vecGroupS es (toDVec c) + return $ RTriple (fromDVec qo) (fromDVec qi) (fromPVec p) + V.Project cols -> fromDVec <$> vecProject cols (toDVec c) + V.Reverse -> do + (d, p) <- vecReverse (toDVec c) + return $ RLPair (fromDVec d) (fromPVec p) + V.ReverseS -> do + (d, p) <- vecReverseS (toDVec c) + return $ RLPair (fromDVec d) (fromPVec p) + V.SelectPos1 (op, pos) -> do + (d, p, u) <- vecSelectPos1 (toDVec c) op pos + return $ RTriple (fromDVec d) (fromRVec p) (fromRVec u) + V.SelectPos1S (op, pos) -> do + (d, p, u) <- vecSelectPos1S (toDVec c) op pos + return $ RTriple (fromDVec d) (fromRVec p) (fromRVec u) + V.GroupAggr (g, as) -> fromDVec <$> vecGroupAggr g as (toDVec c) + + V.Reshape n -> do + (qo, qi) <- vecReshape n (toDVec c) + return $ RLPair (fromDVec qo) (fromDVec qi) + V.ReshapeS n -> do + (qo, qi) <- vecReshapeS n (toDVec c) + return $ RLPair (fromDVec qo) (fromDVec qi) + V.Transpose -> do + (qo, qi) <- vecTranspose (toDVec c) + return $ RLPair (fromDVec qo) (fromDVec qi) + V.R1 -> case c of + (RLPair c1 _) -> return c1 + (RTriple c1 _ _) -> return c1 + _ -> error "R1: Not a tuple" + V.R2 -> case c of + (RLPair _ c2) -> return c2 + (RTriple _ c2 _) -> return c2 + _ -> error "R2: Not a tuple" + V.R3 -> case c of + (RTriple _ _ c3) -> return c3 + _ -> error "R3: Not a tuple" + +translateNullary :: VectorAlgebra v a => V.NullOp -> B.Build a (Res v) +translateNullary V.SingletonDescr = fromDVec <$> singletonDescr +translateNullary (V.Lit (_, tys, vals)) = fromDVec <$> vecLit tys vals +translateNullary (V.TableRef (n, tys, hs)) = fromDVec <$> vecTableRef n tys hs + +-- | 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 :: VecBuild TA.TableAlgebra NDVec (Shape NDVec) + -> VecBuild TA.TableAlgebra NDVec (Shape NDVec) +insertSerialize g = g >>= traverseShape + + where + traverseShape :: Shape NDVec -> VecBuild TA.TableAlgebra NDVec (Shape NDVec) + traverseShape (VShape dvec lyt) = do + mLyt' <- traverseLayout lyt + case mLyt' of + Just lyt' -> do + dvec' <- insertOp dvec noDescr needAbsPos + return $ VShape dvec' lyt' + Nothing -> do + dvec' <- insertOp dvec noDescr needRelPos + return $ VShape dvec' lyt + + traverseShape (SShape dvec lyt) = do + mLyt' <- traverseLayout lyt + case mLyt' of + Just lyt' -> do + dvec' <- insertOp dvec noDescr needAbsPos + return $ SShape dvec' lyt' + Nothing -> do + dvec' <- insertOp dvec noDescr noPos + return $ SShape dvec' lyt + + traverseLayout :: (Layout NDVec) -> VecBuild TA.TableAlgebra NDVec (Maybe (Layout NDVec)) + 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 needDescr needAbsPos + return $ Just $ LNest dvec' lyt' + Nothing -> do + dvec' <- insertOp dvec needDescr needRelPos + return $ Just $ LNest dvec' lyt + + + -- | Insert a Serialize node for the given vector + insertOp :: NDVec -> Maybe TA.DescrCol -> TA.SerializeOrder -> VecBuild TA.TableAlgebra NDVec NDVec + insertOp (ADVec q cols) descr pos = do + let cs = map (TA.PayloadCol . ("item" ++) . show) cols + op = TA.Serialize (descr, pos, cs) + + qp <- lift $ B.insert $ UnOp op q + return $ ADVec qp cols + + needDescr = Just (TA.DescrCol "descr") + noDescr = Nothing + + needAbsPos = TA.AbsPos "pos" + needRelPos = TA.RelPos ["pos"] + noPos = TA.NoPos + +implementVectorOpsPF :: QueryPlan V.VL VLDVec -> QueryPlan TA.TableAlgebra NDVec +implementVectorOpsPF vlPlan = mkQueryPlan dag shape tagMap + where + taPlan = vl2Algebra (D.nodeMap $ queryDag vlPlan) (queryShape vlPlan) + serializedPlan = insertSerialize taPlan + (dag, shape, tagMap) = runVecBuild serializedPlan diff --git a/src/Database/DSH/VL/Lang.hs b/src/Database/DSH/VL/Lang.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/VL/Lang.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Database.DSH.VL.Lang where + +import qualified Data.List.NonEmpty as N +import Data.Aeson.TH + +import Database.Algebra.Dag (Operator, opChildren, replaceOpChild) +import Database.Algebra.Dag.Common + +import qualified Database.DSH.Common.Lang as L + +data ScalarType = Int + | Bool + | Double + | String + | Unit + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''ScalarType) + +type VLColumn = (L.ColName, ScalarType) +type DBCol = Int + +data VLVal = VLInt Int + | VLBool Bool + | VLString String + | VLDouble Double + | VLUnit + deriving (Eq, Ord, Show, Read) + +$(deriveJSON defaultOptions ''VLVal) + +data Expr = BinApp L.ScalarBinOp Expr Expr + | UnApp L.ScalarUnOp Expr + | Column DBCol + | Constant VLVal + | If Expr Expr Expr + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''Expr) + +-- | Helper function: Shift all column indexes in an expression by a certain offset. +shiftExprCols :: Int -> Expr -> Expr +shiftExprCols o (BinApp op e1 e2) = BinApp op (shiftExprCols o e1) + (shiftExprCols o e2) +shiftExprCols o (UnApp op e) = UnApp op (shiftExprCols o e) +shiftExprCols o (Column c) = Column $ c + o +shiftExprCols _ (Constant v) = Constant v +shiftExprCols o (If c t e) = If (shiftExprCols o c) + (shiftExprCols o t) + (shiftExprCols o e) + +data AggrFun = AggrSum ScalarType Expr + | AggrMin Expr + | AggrMax Expr + | AggrAvg Expr + | AggrAll Expr + | AggrAny Expr + | AggrCount + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''AggrFun) + +data WinFun = WinSum Expr + | WinMin Expr + | WinMax Expr + | WinAvg Expr + | WinAll Expr + | WinAny Expr + | WinFirstValue Expr + | WinCount + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''WinFun) + + +-- | Specification of a window for the window aggregate operator. +data FrameSpec = -- | All elements up to and including the current + -- element are in the window + FAllPreceding + -- | All n preceding elements up to and including the + -- current one. + | FNPreceding Int + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''FrameSpec) + +-------------------------------------------------------------------------------- +-- Vector Language operators. Documentation can be found in module +-- VectorPrimitives. + +data NullOp = SingletonDescr + | Lit (L.Emptiness, [ScalarType], [[VLVal]]) + | TableRef (String, [VLColumn], L.TableHints) + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''NullOp) + +data UnOp = UnboxRename + | Segment + | Unsegment + + | R1 + | R2 + | R3 + + | Project [Expr] + | Select Expr + + | GroupAggr ([Expr], N.NonEmpty AggrFun) + | Aggr AggrFun + | AggrNonEmpty (N.NonEmpty AggrFun) + | AggrNonEmptyS (N.NonEmpty AggrFun) + + | Number + | NumberS + | UniqueS + | Reverse + | ReverseS + | SelectPos1 (L.ScalarBinOp, Int) + | SelectPos1S (L.ScalarBinOp, Int) + | SortS [Expr] + | GroupS [Expr] + | WinFun (WinFun, FrameSpec) + + | Reshape Integer + | ReshapeS Integer + | Transpose + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''UnOp) + +data BinOp = DistLift + + | PropRename + | PropFilter + | PropReorder + + | UnboxNested + | UnboxScalar + | Align + + | AggrS AggrFun + | Append + | AppendS + | SelectPos L.ScalarBinOp + | SelectPosS L.ScalarBinOp + | Zip + | ZipS + | CartProduct + | CartProductS + | ThetaJoin (L.JoinPredicate Expr) + | ThetaJoinS (L.JoinPredicate Expr) + | SemiJoin (L.JoinPredicate Expr) + | SemiJoinS (L.JoinPredicate Expr) + | AntiJoin (L.JoinPredicate Expr) + | AntiJoinS (L.JoinPredicate Expr) + | NestJoin (L.JoinPredicate Expr) + | NestJoinS (L.JoinPredicate Expr) + | NestProduct + | NestProductS + | TransposeS + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''BinOp) + +data TerOp = Combine -- (DBV, RenameVector, RenameVector) + deriving (Eq, Ord, Show) + +$(deriveJSON defaultOptions ''TerOp) + +type VL = Algebra TerOp BinOp UnOp NullOp AlgNode + +checkRep :: Eq a => a -> a -> a -> a +checkRep orig new x = if x == orig then new else x + +instance Operator VL where + opChildren (TerOp _ c1 c2 c3) = [c1, c2, c3] + opChildren (BinOp _ c1 c2) = [c1, c2] + opChildren (UnOp _ c) = [c] + opChildren (NullaryOp _) = [] + + replaceOpChild oper old new = replaceChild old new oper + where + replaceChild :: forall t b u n c. Eq c => c -> c -> Algebra t b u n c -> Algebra t b u n c + replaceChild o n (TerOp op c1 c2 c3) = TerOp op (checkRep o n c1) (checkRep o n c2) (checkRep o n c3) + replaceChild o n (BinOp op c1 c2) = BinOp op (checkRep o n c1) (checkRep o n c2) + replaceChild o n (UnOp op c) = UnOp op (checkRep o n c) + replaceChild _ _ (NullaryOp op) = NullaryOp op diff --git a/src/Database/DSH/VL/Primitives.hs b/src/Database/DSH/VL/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/VL/Primitives.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Database.DSH.VL.Primitives where + +import Database.DSH.Common.Nat +import qualified Database.DSH.Common.Lang as L +import qualified Database.DSH.Common.Type as Ty +import Database.DSH.VL.Vector + +import Database.DSH.Impossible + +import Database.Algebra.Dag.Build +import Database.Algebra.Dag.Common +import Database.DSH.VL.Lang hiding (DBCol) +import qualified Database.DSH.VL.Lang as D + +-------------------------------------------------------------------------------- +-- Construct different types of vectors from algebraic nodes + +type VecConst r v = Build VL AlgNode -> Build VL v + +dvec :: VecConst r VLDVec +dvec = fmap VLDVec + +pvec :: Build a AlgNode -> Build a PVec +pvec = fmap PVec + +rvec :: Build a AlgNode -> Build a RVec +rvec = fmap RVec + +-------------------------------------------------------------------------------- +-- Insert VL operators and appropriate R1/R2/R3 nodes + +vec :: VL -> VecConst r a -> Build VL a +vec op mkVec = mkVec $ insert op + +pairVec :: VL -> VecConst r a -> VecConst r b -> Build VL (a, b) +pairVec op mkVec1 mkVec2 = do + r <- insert op + r1 <- mkVec1 $ insert $ UnOp R1 r + r2 <- mkVec2 $ insert $ UnOp R2 r + return (r1, r2) + +tripleVec :: VL + -> VecConst r a + -> VecConst r b + -> VecConst r c + -> Build VL (a, b ,c) +tripleVec op mkVec1 mkVec2 mkVec3 = do + r <- insert op + r1 <- mkVec1 $ insert $ UnOp R1 r + r2 <- mkVec2 $ insert $ UnOp R2 r + r3 <- mkVec3 $ insert $ UnOp R3 r + return (r1, r2, r3) + +-------------------------------------------------------------------------------- + +mapSnd :: (b -> c) -> (a, b) -> (a, c) +mapSnd f (a, b) = (a, f b) + +pVal :: L.Val -> VLVal +pVal (L.IntV i) = VLInt i +pVal (L.BoolV b) = VLBool b +pVal (L.StringV s) = VLString s +pVal (L.DoubleV d) = VLDouble d +pVal L.UnitV = VLUnit +pVal _ = error "pVal: Not a supported value" + +typeToScalarType :: Ty.Type -> ScalarType +typeToScalarType t = case t of + Ty.IntT -> D.Int + Ty.BoolT -> D.Bool + Ty.StringT -> D.String + Ty.UnitT -> D.Unit + Ty.DoubleT -> D.Double + Ty.ListT _ -> $impossible + Ty.TupleT _ -> $impossible + +---------------------------------------------------------------------------------- +-- Convert join expressions into regular VL expressions + +-- | Determine the horizontal relational schema width of a type +recordWidth :: Ty.Type -> Int +recordWidth t = + case t of + Ty.IntT -> 1 + Ty.BoolT -> 1 + Ty.DoubleT -> 1 + Ty.StringT -> 1 + Ty.UnitT -> 1 + Ty.TupleT ts -> sum $ map recordWidth ts + Ty.ListT _ -> 0 + +data ColExpr = Offset Int | Expr Expr + +-- | If the child expressions are tuple operators which only give the +-- column offset, convert it into a proper expression first. +offsetExpr :: ColExpr -> Expr +offsetExpr (Offset o) = Column $ o + 1 +offsetExpr (Expr e) = e + +addOffset :: Int -> ColExpr -> ColExpr +addOffset _ (Expr _) = $impossible +addOffset i (Offset o) = Offset $ o + i + +toGeneralBinOp :: L.JoinBinOp -> L.ScalarBinOp +toGeneralBinOp (L.JBNumOp o) = L.SBNumOp o +toGeneralBinOp (L.JBStringOp o) = L.SBStringOp o + +toGeneralUnOp :: L.JoinUnOp -> L.ScalarUnOp +toGeneralUnOp (L.JUNumOp o) = L.SUNumOp o +toGeneralUnOp (L.JUCastOp o) = L.SUCastOp o +toGeneralUnOp (L.JUTextOp o) = L.SUTextOp o + +toVLjoinConjunct :: L.JoinConjunct L.JoinExpr -> L.JoinConjunct Expr +toVLjoinConjunct (L.JoinConjunct e1 o e2) = + L.JoinConjunct (joinExpr e1) o (joinExpr e2) + +toVLJoinPred :: L.JoinPredicate L.JoinExpr -> L.JoinPredicate Expr +toVLJoinPred (L.JoinPred cs) = L.JoinPred $ fmap toVLjoinConjunct cs + +-- | Convert join expressions into VL expressions. The main challenge +-- here is to convert sequences of tuple accessors (fst/snd) into VL +-- column indices. +joinExpr :: L.JoinExpr -> Expr +joinExpr expr = offsetExpr $ aux expr + where + -- Construct expressions in a bottom-up way. For a given join + -- expression, return the following: + -- pair accessors -> column offset in the flat relational representation + -- scalar operation -> corresponding VL expression + aux :: L.JoinExpr -> ColExpr + -- FIXME VL joins should include join expressions! + aux (L.JBinOp _ op e1 e2) = Expr $ BinApp (toGeneralBinOp op) + (offsetExpr $ aux e1) + (offsetExpr $ aux e2) + aux (L.JUnOp _ op e) = Expr $ UnApp (toGeneralUnOp op) (offsetExpr $ aux e) + aux (L.JTupElem _ i e) = + case Ty.typeOf e of + -- Compute the record width of all preceding tuple elements in the type + Ty.TupleT ts -> addOffset (sum $ map recordWidth $ take (tupleIndex i - 1) ts) (aux e) + _ -> $impossible + aux (L.JLit _ v) = Expr $ Constant $ pVal v + aux (L.JInput _) = Offset 0 + + +---------------------------------------------------------------------------------- +-- DAG constructor functions for VL operators + +vlUniqueS :: VLDVec -> Build VL VLDVec +vlUniqueS (VLDVec c) = vec (UnOp UniqueS c) dvec + +vlNumber :: VLDVec -> Build VL VLDVec +vlNumber (VLDVec c) = vec (UnOp Number c) dvec + +vlNumberS :: VLDVec -> Build VL VLDVec +vlNumberS (VLDVec c) = vec (UnOp NumberS c) dvec + +vlGroupS :: [Expr] -> VLDVec -> Build VL (VLDVec, VLDVec, PVec) +vlGroupS groupExprs (VLDVec c) = tripleVec (UnOp (GroupS groupExprs) c) dvec dvec pvec + +vlSortS :: [Expr] -> VLDVec -> Build VL (VLDVec, PVec) +vlSortS sortExprs (VLDVec c1) = pairVec (UnOp (SortS sortExprs) c1) dvec pvec + +vlAggr :: AggrFun -> VLDVec -> Build VL VLDVec +vlAggr aFun (VLDVec c) = vec (UnOp (Aggr aFun) c) dvec + +vlAggrS :: AggrFun -> VLDVec -> VLDVec -> Build VL VLDVec +vlAggrS aFun (VLDVec c1) (VLDVec c2) = vec (BinOp (AggrS aFun) c1 c2) dvec + +vlUnboxRename :: VLDVec -> Build VL RVec +vlUnboxRename (VLDVec c) = vec (UnOp UnboxRename c) rvec + +vlNestProduct :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec) +vlNestProduct (VLDVec c1) (VLDVec c2) = tripleVec (BinOp NestProduct c1 c2) dvec pvec pvec + +vlDistLift :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec) +vlDistLift (VLDVec c1) (VLDVec c2) = pairVec (BinOp DistLift c1 c2) dvec pvec + +vlPropRename :: RVec -> VLDVec -> Build VL VLDVec +vlPropRename (RVec c1) (VLDVec c2) = vec (BinOp PropRename c1 c2) dvec + +vlUnboxNested :: RVec -> VLDVec -> Build VL (VLDVec, RVec) +vlUnboxNested (RVec c1) (VLDVec c2) = pairVec (BinOp UnboxNested c1 c2) dvec rvec + +vlUnboxScalar :: VLDVec -> VLDVec -> Build VL VLDVec +vlUnboxScalar (VLDVec c1) (VLDVec c2) = vec (BinOp UnboxScalar c1 c2) dvec + +vlPropFilter :: RVec -> VLDVec -> Build VL (VLDVec, RVec) +vlPropFilter (RVec c1) (VLDVec c2) = pairVec (BinOp PropFilter c1 c2) dvec rvec + +vlPropReorder :: PVec -> VLDVec -> Build VL (VLDVec, PVec) +vlPropReorder (PVec c1) (VLDVec c2) = pairVec (BinOp PropReorder c1 c2) dvec pvec + +vlSingletonDescr :: Build VL VLDVec +vlSingletonDescr = vec (NullaryOp SingletonDescr) dvec + +vlAppend :: VLDVec -> VLDVec -> Build VL (VLDVec, RVec, RVec) +vlAppend (VLDVec c1) (VLDVec c2) = tripleVec (BinOp Append c1 c2) dvec rvec rvec + +vlAppendS :: VLDVec -> VLDVec -> Build VL (VLDVec, RVec, RVec) +vlAppendS (VLDVec c1) (VLDVec c2) = tripleVec (BinOp AppendS c1 c2) dvec rvec rvec + +vlSegment :: VLDVec -> Build VL VLDVec +vlSegment (VLDVec c) = vec (UnOp Segment c) dvec + +vlUnsegment :: VLDVec -> Build VL VLDVec +vlUnsegment (VLDVec c) = vec (UnOp Unsegment c) dvec + +vlCombine :: VLDVec -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec, RVec) +vlCombine (VLDVec c1) (VLDVec c2) (VLDVec c3) = + tripleVec (TerOp Combine c1 c2 c3) dvec rvec rvec + +vlLit :: L.Emptiness -> [Ty.Type] -> [[VLVal]] -> Build VL VLDVec +vlLit em tys vals = vec (NullaryOp $ Lit (em, map typeToScalarType tys, vals)) dvec + +vlTableRef :: String -> [VLColumn] -> L.TableHints -> Build VL VLDVec +vlTableRef n tys hs = vec (NullaryOp $ TableRef (n, tys, hs)) dvec + +vlUnExpr :: L.ScalarUnOp -> VLDVec -> Build VL VLDVec +vlUnExpr o (VLDVec c) = vec (UnOp (Project [UnApp o (Column 1)]) c) dvec + +vlBinExpr :: L.ScalarBinOp -> VLDVec -> VLDVec -> Build VL VLDVec +vlBinExpr o (VLDVec c1) (VLDVec c2) = do + z <- insert $ BinOp Align c1 c2 + r <- dvec $ insert $ UnOp (Project [BinApp o (Column 1) (Column 2)]) z + return r + +vlSelect :: Expr -> VLDVec -> Build VL (VLDVec, RVec) +vlSelect p (VLDVec c) = pairVec (UnOp (Select p) c) dvec rvec + +vlSelectPos :: VLDVec -> L.ScalarBinOp -> VLDVec -> Build VL (VLDVec, RVec, RVec) +vlSelectPos (VLDVec c1) op (VLDVec c2) = tripleVec (BinOp (SelectPos op) c1 c2) dvec rvec rvec + +vlSelectPos1 :: VLDVec -> L.ScalarBinOp -> Int -> Build VL (VLDVec, RVec, RVec) +vlSelectPos1 (VLDVec c1) op posConst = + tripleVec (UnOp (SelectPos1 (op, posConst)) c1) dvec rvec rvec + +vlSelectPosS :: VLDVec -> L.ScalarBinOp -> VLDVec -> Build VL (VLDVec, RVec, RVec) +vlSelectPosS (VLDVec c1) op (VLDVec c2) = do + tripleVec (BinOp (SelectPosS op) c1 c2) dvec rvec rvec + +vlSelectPos1S :: VLDVec -> L.ScalarBinOp -> Int -> Build VL (VLDVec, RVec, RVec) +vlSelectPos1S (VLDVec c1) op posConst = + tripleVec (UnOp (SelectPos1S (op, posConst)) c1) dvec rvec rvec + +vlProject :: [Expr] -> VLDVec -> Build VL VLDVec +vlProject projs (VLDVec c) = dvec $ insert $ UnOp (Project projs) c + +vlZip :: VLDVec -> VLDVec -> Build VL VLDVec +vlZip (VLDVec c1) (VLDVec c2) = vec (BinOp Zip c1 c2) dvec + +vlAlign :: VLDVec -> VLDVec -> Build VL VLDVec +vlAlign (VLDVec c1) (VLDVec c2) = vec (BinOp Align c1 c2) dvec + +vlZipS :: VLDVec -> VLDVec -> Build VL (VLDVec, RVec, RVec) +vlZipS (VLDVec c1) (VLDVec c2) = + tripleVec (BinOp ZipS c1 c2) dvec rvec rvec + +vlCartProduct :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec) +vlCartProduct (VLDVec c1) (VLDVec c2) = + tripleVec (BinOp CartProduct c1 c2) dvec pvec pvec + +vlCartProductS :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec) +vlCartProductS (VLDVec c1) (VLDVec c2) = + tripleVec (BinOp CartProductS c1 c2) dvec pvec pvec + +vlThetaJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec) +vlThetaJoin joinPred (VLDVec c1) (VLDVec c2) = + tripleVec (BinOp (ThetaJoin joinPred') c1 c2) dvec pvec pvec + where + joinPred' = toVLJoinPred joinPred + +vlNestJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec) +vlNestJoin joinPred (VLDVec c1) (VLDVec c2) = + tripleVec (BinOp (NestJoin joinPred') c1 c2) dvec pvec pvec + where + joinPred' = toVLJoinPred joinPred + +vlThetaJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec) +vlThetaJoinS joinPred (VLDVec c1) (VLDVec c2) = + tripleVec (BinOp (ThetaJoinS joinPred') c1 c2) dvec pvec pvec + where + joinPred' = toVLJoinPred joinPred + +vlNestJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, PVec) +vlNestJoinS joinPred (VLDVec c1) (VLDVec c2) = + pairVec (BinOp (NestJoinS joinPred') c1 c2) dvec pvec + where + joinPred' = toVLJoinPred joinPred + +vlNestProductS :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec) +vlNestProductS (VLDVec c1) (VLDVec c2) = do + pairVec (BinOp NestProductS c1 c2) dvec pvec + +vlSemiJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec) +vlSemiJoin joinPred (VLDVec c1) (VLDVec c2) = do + pairVec (BinOp (SemiJoin joinPred') c1 c2) dvec rvec + where + joinPred' = toVLJoinPred joinPred + +vlSemiJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec) +vlSemiJoinS joinPred (VLDVec c1) (VLDVec c2) = do + pairVec (BinOp (SemiJoinS joinPred') c1 c2) dvec rvec + where + joinPred' = toVLJoinPred joinPred + +vlAntiJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec) +vlAntiJoin joinPred (VLDVec c1) (VLDVec c2) = do + pairVec (BinOp (AntiJoin joinPred') c1 c2) dvec rvec + where + joinPred' = toVLJoinPred joinPred + +vlAntiJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec) +vlAntiJoinS joinPred (VLDVec c1) (VLDVec c2) = do + pairVec (BinOp (AntiJoinS joinPred') c1 c2) dvec rvec + where + joinPred' = toVLJoinPred joinPred + +vlReverse :: VLDVec -> Build VL (VLDVec, PVec) +vlReverse (VLDVec c) = pairVec (UnOp Reverse c) dvec pvec + +vlReverseS :: VLDVec -> Build VL (VLDVec, PVec) +vlReverseS (VLDVec c) = pairVec (UnOp ReverseS c) dvec pvec + +vlTranspose :: VLDVec -> Build VL (VLDVec, VLDVec) +vlTranspose (VLDVec c) = pairVec (UnOp Transpose c) dvec dvec + +vlTransposeS :: VLDVec -> VLDVec -> Build VL (VLDVec, VLDVec) +vlTransposeS (VLDVec c1) (VLDVec c2) = do + pairVec (BinOp TransposeS c1 c2) dvec dvec + +vlReshape :: Integer -> VLDVec -> Build VL (VLDVec, VLDVec) +vlReshape n (VLDVec c) = do + pairVec (UnOp (Reshape n) c) dvec dvec + +vlReshapeS :: Integer -> VLDVec -> Build VL (VLDVec, VLDVec) +vlReshapeS n (VLDVec c) = do + pairVec (UnOp (ReshapeS n) c) dvec dvec diff --git a/src/Database/DSH/VL/Render/Dot.hs b/src/Database/DSH/VL/Render/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/VL/Render/Dot.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.VL.Render.Dot(renderVLDot, renderTblVal) where + +import qualified Data.IntMap as Map +import qualified Data.List.NonEmpty as N +import Data.List + +import Text.PrettyPrint + +import qualified Database.Algebra.Dag as Dag +import Database.Algebra.Dag.Common as C + +import Database.DSH.Common.Pretty +import Database.DSH.Common.Lang +import Database.DSH.VL.Lang + +nodeToDoc :: AlgNode -> Doc +nodeToDoc n = (text "id:") <+> (int n) + +tagsToDoc :: [Tag] -> Doc +tagsToDoc ts = vcat $ map text ts + +labelToDoc :: AlgNode -> String -> Doc -> [Tag] -> Doc +labelToDoc n s as ts = (nodeToDoc n) $$ ((text s) <> (parens as)) $$ (tagsToDoc $ nub ts) + +lookupTags :: AlgNode -> NodeMap [Tag] -> [Tag] +lookupTags n m = Map.findWithDefault [] n m + +renderFun :: Doc -> [Doc] -> Doc +renderFun name args = name <> parens (hsep $ punctuate comma args) + +renderFrameSpec :: FrameSpec -> Doc +renderFrameSpec FAllPreceding = text "allprec" +renderFrameSpec (FNPreceding n) = int n <+> text "prec" + +renderAggrFun :: AggrFun -> Doc +renderAggrFun (AggrSum t c) = renderFun (text "sum" <> char '_' <> renderColumnType t) + [renderExpr c] +renderAggrFun (AggrMin c) = renderFun (text "min") [renderExpr c] +renderAggrFun (AggrMax c) = renderFun (text "max") [renderExpr c] +renderAggrFun (AggrAvg c) = renderFun (text "avg") [renderExpr c] +renderAggrFun (AggrAny c) = renderFun (text "any") [renderExpr c] +renderAggrFun (AggrAll c) = renderFun (text "all") [renderExpr c] +renderAggrFun AggrCount = renderFun (text "count") [] + +renderWinFun :: WinFun -> Doc +renderWinFun (WinSum c) = renderFun (text "sum") [renderExpr c] +renderWinFun (WinMin c) = renderFun (text "min") [renderExpr c] +renderWinFun (WinMax c) = renderFun (text "max") [renderExpr c] +renderWinFun (WinAvg c) = renderFun (text "avg") [renderExpr c] +renderWinFun (WinAny c) = renderFun (text "any") [renderExpr c] +renderWinFun (WinAll c) = renderFun (text "all") [renderExpr c] +renderWinFun (WinFirstValue c) = renderFun (text "first_value") [renderExpr c] +renderWinFun WinCount = renderFun (text "count") [] + +renderColumnType :: ScalarType -> Doc +renderColumnType = text . show + +renderData :: [[VLVal]] -> Doc +renderData [] = brackets empty +renderData xs = (flip (<>) semi . sep . punctuate semi . map renderRow) xs + +renderRow :: [VLVal] -> Doc +renderRow = hcat . punctuate comma . map renderTblVal + +renderTblVal :: VLVal -> Doc +renderTblVal (VLInt i) = integer $ fromIntegral i +renderTblVal (VLBool b) = text $ show b +renderTblVal (VLString s) = doubleQuotes $ text $ escape s +renderTblVal (VLDouble d) = double d +renderTblVal VLUnit = text "()" + +escape :: String -> String +escape (x@'\\':xs) = '\\':'\\':'\\':x:escape xs +escape (x@'\'':xs) = '\\':x:escape xs +escape (x@'"':xs) = '\\':'\\':x:escape xs +escape (x:xs) = x:escape xs +escape [] = [] + +bracketList :: (a -> Doc) -> [a] -> Doc +bracketList f = brackets . hsep . punctuate comma . map f + +renderColName :: ColName -> Doc +renderColName (ColName c) = text c + +renderTableType :: VLColumn -> Doc +renderTableType (c, t) = renderColName c <> text "::" <> renderColumnType t + +renderTableHints :: TableHints -> Doc +renderTableHints hs = renderTableKeys (keysHint hs) <> renderEmptiness (nonEmptyHint hs) + +renderEmptiness :: Emptiness -> Doc +renderEmptiness NonEmpty = text " NONEMPTY" +renderEmptiness PossiblyEmpty = empty + +renderTableKeys :: [Key] -> Doc +renderTableKeys [x] = renderTableKey x +renderTableKeys (x:xs) = renderTableKey x $$ renderTableKeys xs +renderTableKeys [] = empty + + +renderTableKey :: Key -> Doc +renderTableKey (Key ks) = hsep $ punctuate comma $ map renderColName ks + +renderProj :: Doc -> Expr -> Doc +renderProj d e = d <> colon <> renderExpr e + +renderJoinConjunct :: JoinConjunct Expr -> Doc +renderJoinConjunct (JoinConjunct e1 o e2) = + parenthize1 e1 <+> (text $ show o) <+> (parenthize1 e2) + +renderJoinPred :: JoinPredicate Expr -> Doc +renderJoinPred (JoinPred conjs) = brackets + $ hsep + $ punctuate (text "&&") + $ map renderJoinConjunct $ N.toList conjs + +renderExpr :: Expr -> Doc +renderExpr (BinApp op e1 e2) = (parenthize1 e1) <+> (text $ pp op) <+> (parenthize1 e2) +renderExpr (UnApp op e) = (text $ pp op) <+> (parens $ renderExpr e) +renderExpr (Constant val) = renderTblVal val +renderExpr (Column c) = text "col" <> int c +renderExpr (If c t e) = text "if" + <+> renderExpr c + <+> text "then" + <+> renderExpr t + <+> text "else" + <+> renderExpr e + +parenthize1 :: Expr -> Doc +parenthize1 e@(Constant _) = renderExpr e +parenthize1 e@(Column _) = renderExpr e +parenthize1 e@(BinApp _ _ _) = parens $ renderExpr e +parenthize1 e@(UnApp _ _) = parens $ renderExpr e +parenthize1 e@(If _ _ _) = renderExpr e + +-- | Create the node label from an operator description +opDotLabel :: NodeMap [Tag] -> AlgNode -> VL -> Doc +opDotLabel tm i (UnOp (WinFun (wfun, wspec)) _) = labelToDoc i "WinAggr" + (renderWinFun wfun <> comma <+> renderFrameSpec wspec) + (lookupTags i tm) +opDotLabel tm i (NullaryOp (SingletonDescr)) = labelToDoc i "SingletonDescr" empty (lookupTags i tm) +opDotLabel tm i (NullaryOp (Lit (em, tys, vals))) = labelToDoc i "LIT" + (renderEmptiness em <+> bracketList renderColumnType tys <> comma + $$ renderData vals) (lookupTags i tm) +opDotLabel tm i (NullaryOp (TableRef (n, tys, hs))) = labelToDoc i "TableRef" + (quotes (text n) <> comma <+> bracketList (\t -> renderTableType t <> text "\n") tys <> comma $$ renderTableHints hs) + (lookupTags i tm) +opDotLabel tm i (UnOp UniqueS _) = labelToDoc i "UniqueS" empty (lookupTags i tm) +opDotLabel tm i (UnOp Number _) = labelToDoc i "Number" empty (lookupTags i tm) +opDotLabel tm i (UnOp NumberS _) = labelToDoc i "NumberS" empty (lookupTags i tm) +opDotLabel tm i (UnOp UnboxRename _) = labelToDoc i "UnboxRename" empty (lookupTags i tm) +opDotLabel tm i (UnOp Segment _) = labelToDoc i "Segment" empty (lookupTags i tm) +opDotLabel tm i (UnOp Unsegment _) = labelToDoc i "Unsegment" empty (lookupTags i tm) +opDotLabel tm i (UnOp Reverse _) = labelToDoc i "Reverse" empty (lookupTags i tm) +opDotLabel tm i (UnOp ReverseS _) = labelToDoc i "ReverseS" empty (lookupTags i tm) +opDotLabel tm i (UnOp R1 _) = labelToDoc i "R1" empty (lookupTags i tm) +opDotLabel tm i (UnOp R2 _) = labelToDoc i "R2" empty (lookupTags i tm) +opDotLabel tm i (UnOp R3 _) = labelToDoc i "R3" empty (lookupTags i tm) +opDotLabel tm i (UnOp (Project pCols) _) = + labelToDoc i "Project" pLabel (lookupTags i tm) + where pLabel = valCols + valCols = bracketList (\(j, p) -> renderProj (itemLabel j) p) $ zip ([1..] :: [Int]) pCols + itemLabel j = (text "i") <> (int j) +opDotLabel tm i (UnOp (Select e) _) = labelToDoc i "Select" (renderExpr e) (lookupTags i tm) +opDotLabel tm i (UnOp (SelectPos1 (o, p)) _) = labelToDoc i "SelectPos1" ((text $ show o) <+> int p) (lookupTags i tm) +opDotLabel tm i (UnOp (SelectPos1S (o, p)) _) = labelToDoc i "SelectPos1S" ((text $ show o) <+> int p) (lookupTags i tm) +opDotLabel tm i (UnOp (GroupAggr (g, as)) _) = labelToDoc i "GroupAggr" (bracketList renderExpr g <+> bracketList renderAggrFun (N.toList as)) (lookupTags i tm) +opDotLabel tm i (UnOp (Aggr a) _) = labelToDoc i "Aggr" (renderAggrFun a) (lookupTags i tm) +opDotLabel tm i (UnOp (Reshape n) _) = + labelToDoc i "Reshape" (integer n) (lookupTags i tm) +opDotLabel tm i (BinOp (AggrS a) _ _) = labelToDoc i "AggrS" (renderAggrFun a) (lookupTags i tm) +opDotLabel tm i (UnOp (AggrNonEmpty as) _) = labelToDoc i "AggrNonEmpty" (bracketList renderAggrFun (N.toList as)) (lookupTags i tm) +opDotLabel tm i (UnOp (AggrNonEmptyS as) _) = labelToDoc i "AggrNonEmptyS" (bracketList renderAggrFun (N.toList as)) (lookupTags i tm) +opDotLabel tm i (UnOp (SortS cols) _) = labelToDoc i "Sort" (bracketList renderExpr cols) (lookupTags i tm) +opDotLabel tm i (UnOp (GroupS cols) _) = labelToDoc i "GroupS" (bracketList renderExpr cols) (lookupTags i tm) +opDotLabel tm i (BinOp NestProduct _ _) = labelToDoc i "NestProduct" empty (lookupTags i tm) +opDotLabel tm i (BinOp DistLift _ _) = labelToDoc i "DistLift" empty (lookupTags i tm) +opDotLabel tm i (BinOp PropRename _ _) = labelToDoc i "PropRename" empty (lookupTags i tm) +opDotLabel tm i (BinOp UnboxNested _ _) = labelToDoc i "UnboxNested" empty (lookupTags i tm) +opDotLabel tm i (BinOp UnboxScalar _ _) = labelToDoc i "UnboxScalar" empty (lookupTags i tm) +opDotLabel tm i (BinOp PropFilter _ _) = labelToDoc i "PropFilter" empty (lookupTags i tm) +opDotLabel tm i (BinOp PropReorder _ _) = labelToDoc i "PropReorder" empty (lookupTags i tm) +opDotLabel tm i (BinOp Append _ _) = labelToDoc i "Append" empty (lookupTags i tm) +opDotLabel tm i (BinOp AppendS _ _) = labelToDoc i "AppendS" empty (lookupTags i tm) +opDotLabel tm i (BinOp (SelectPos o) _ _) = labelToDoc i "SelectPos" (text $ show o) (lookupTags i tm) +opDotLabel tm i (BinOp (SelectPosS o) _ _) = labelToDoc i "SelectPosS" (text $ show o) (lookupTags i tm) +opDotLabel tm i (BinOp Zip _ _) = labelToDoc i "Zip" empty (lookupTags i tm) +opDotLabel tm i (BinOp Align _ _) = labelToDoc i "Align" empty (lookupTags i tm) +opDotLabel tm i (BinOp ZipS _ _) = labelToDoc i "ZipS" empty (lookupTags i tm) +opDotLabel tm i (BinOp CartProduct _ _) = labelToDoc i "CartProduct" empty (lookupTags i tm) +opDotLabel tm i (BinOp CartProductS _ _) = labelToDoc i "CartProductS" empty (lookupTags i tm) +opDotLabel tm i (BinOp NestProductS _ _) = labelToDoc i "NestProductS" empty (lookupTags i tm) +opDotLabel tm i (BinOp (ThetaJoin p) _ _) = + labelToDoc i "ThetaJoin" (renderJoinPred p) (lookupTags i tm) +opDotLabel tm i (BinOp (NestJoin p) _ _) = + labelToDoc i "NestJoin" (renderJoinPred p) (lookupTags i tm) +opDotLabel tm i (BinOp (ThetaJoinS p) _ _) = + labelToDoc i "ThetaJoinS" (renderJoinPred p) (lookupTags i tm) +opDotLabel tm i (BinOp (NestJoinS p) _ _) = + labelToDoc i "NestJoinS" (renderJoinPred p) (lookupTags i tm) +opDotLabel tm i (BinOp (SemiJoin p) _ _) = + labelToDoc i "SemiJoin" (renderJoinPred p) (lookupTags i tm) +opDotLabel tm i (BinOp (SemiJoinS p) _ _) = + labelToDoc i "SemiJoinS" (renderJoinPred p) (lookupTags i tm) +opDotLabel tm i (BinOp (AntiJoin p) _ _) = + labelToDoc i "AntiJoin" (renderJoinPred p) (lookupTags i tm) +opDotLabel tm i (BinOp (AntiJoinS p) _ _) = + labelToDoc i "AntiJoinS" (renderJoinPred p) (lookupTags i tm) +opDotLabel tm i (UnOp (ReshapeS n) _) = + labelToDoc i "ReshapeS" (integer n) (lookupTags i tm) +opDotLabel tm i (UnOp Transpose _) = labelToDoc i "Transpose" empty (lookupTags i tm) +opDotLabel tm i (TerOp Combine _ _ _) = labelToDoc i "Combine" empty (lookupTags i tm) +opDotLabel tm i (BinOp TransposeS _ _) = labelToDoc i "TransposeS" empty (lookupTags i tm) + +opDotColor :: VL -> DotColor +opDotColor (BinOp NestProduct _ _) = DCRed +opDotColor (BinOp CartProduct _ _) = DCRed +opDotColor (BinOp CartProductS _ _) = DCRed +opDotColor (BinOp NestProductS _ _) = DCRed +opDotColor (BinOp (ThetaJoin _) _ _) = DCGreen +opDotColor (BinOp (NestJoin _) _ _) = DCGreen +opDotColor (BinOp (ThetaJoinS _) _ _) = DCGreen +opDotColor (BinOp (NestJoinS _) _ _) = DCGreen +opDotColor (BinOp (SemiJoin _) _ _) = DCGreen +opDotColor (BinOp (SemiJoinS _) _ _) = DCGreen +opDotColor (BinOp (AntiJoin _) _ _) = DCGreen +opDotColor (BinOp (AntiJoinS _) _ _) = DCGreen +opDotColor (BinOp Zip _ _) = DCYelloGreen +opDotColor (UnOp (SortS _) _) = DCTomato +opDotColor (UnOp (GroupS _) _) = DCTomato +opDotColor (BinOp PropRename _ _) = DCTan +opDotColor (BinOp UnboxNested _ _) = DCTan +opDotColor (BinOp UnboxScalar _ _) = DCTan +opDotColor (BinOp PropReorder _ _) = DCTan +opDotColor (BinOp DistLift _ _) = DCTan +opDotColor (BinOp Align _ _) = DCTan +opDotColor (TerOp Combine _ _ _) = DCDodgerBlue +opDotColor (UnOp (Select _) _) = DCLightSkyBlue +opDotColor (UnOp (Aggr _) _) = DCCrimson +opDotColor (BinOp (AggrS _) _ _) = DCCrimson +opDotColor (UnOp (WinFun _) _) = DCTomato +opDotColor (UnOp (AggrNonEmpty _) _) = DCCrimson +opDotColor (UnOp (AggrNonEmptyS _) _) = DCCrimson +opDotColor (UnOp (GroupAggr (_, _)) _) = DCTomato +opDotColor (UnOp (Project _) _) = DCLightSkyBlue +opDotColor (UnOp Transpose _) = DCHotPink +opDotColor (BinOp TransposeS _ _) = DCHotPink +opDotColor (UnOp (ReshapeS _) _) = DCHotPink +opDotColor (UnOp (Reshape _) _) = DCHotPink +opDotColor _ = DCGray + +-- Dot colors +data DotColor = DCTomato + | DCSalmon + | DCGray + | DimDCGray + | DCGold + | DCTan + | DCRed + | DCCrimson + | DCGreen + | DCSeaGreen + | DCYelloGreen + | DCSienna + | DCBeige + | DCDodgerBlue + | DCLightSkyBlue + | DCHotPink + +renderColor :: DotColor -> Doc +renderColor DCTomato = text "tomato" +renderColor DCSalmon = text "salmon" +renderColor DCGray = text "gray" +renderColor DimDCGray = text "dimgray" +renderColor DCGold = text "gold" +renderColor DCTan = text "tan" +renderColor DCRed = text "red" +renderColor DCCrimson = text "crimson" +renderColor DCGreen = text "green" +renderColor DCSeaGreen = text "seagreen" +renderColor DCYelloGreen = text "yellowgreen" +renderColor DCSienna = text "sienna" +renderColor DCBeige = text "beige" +renderColor DCDodgerBlue = text "dodgerblue" +renderColor DCLightSkyBlue = text "lightskyblue" +renderColor DCHotPink = text "hotpink" + +escapeLabel :: String -> String +escapeLabel s = concatMap escapeChar s + +escapeChar :: Char -> [Char] +escapeChar '\n' = ['\\', 'n'] +escapeChar '\\' = ['\\', '\\'] +escapeChar '\"' = ['\\', '"'] +escapeChar c = [c] + +-- Type of Dot style options +data DotStyle = Dashed + +-- label of Dot nodes +type DotLabel = String + +-- id of Dot nodes +type DotNodeID = Int + +-- Type of Dot nodes +data DotNode = DotNode DotNodeID DotLabel DotColor (Maybe DotStyle) + +-- Type of Dot edges +data DotEdge = DotEdge DotNodeID DotNodeID + +-- Generate the preamble of a Dot file +preamble :: Doc +preamble = graphAttributes $$ nodeAttributes + where nodeAttributes = text "node" <+> (brackets $ text "style=filled" <> comma <+> text "shape=box") <> semi + graphAttributes = text "ordering=out;" + +renderDotNode :: DotNode -> Doc +renderDotNode (DotNode n l c s) = + int n + <+> (brackets $ (((text "label=") <> (doubleQuotes $ text l)) + <> comma + <+> (text "color=") <> (renderColor c) + <> styleDoc)) + <> semi + where styleDoc = + case s of + Just Dashed -> comma <+> text "style=dashed" + Nothing -> empty + +renderDotEdge :: DotEdge -> Doc +renderDotEdge (DotEdge u v) = int u <+> text "->" <+> int v <> semi + +-- | Render a Dot document from the preamble, nodes and edges +renderDot :: [DotNode] -> [DotEdge] -> Doc +renderDot ns es = text "digraph" <> (braces $ preamble $$ nodeSection $$ edgeSection) + where nodeSection = vcat $ map renderDotNode ns + edgeSection = vcat $ map renderDotEdge es + +-- | Create an abstract Dot node from an X100 operator description +constructDotNode :: [AlgNode] -> NodeMap [Tag] -> (AlgNode, VL) -> DotNode +constructDotNode rootNodes ts (n, op) = + if elem n rootNodes then + DotNode n l c (Just Dashed) + else + DotNode n l c Nothing + where l = escapeLabel $ render $ opDotLabel ts n op + c = opDotColor op + +-- | Create an abstract Dot edge +constructDotEdge :: (AlgNode, AlgNode) -> DotEdge +constructDotEdge = uncurry DotEdge + +-- | extract the operator descriptions and list of edges from a DAG +-- FIXME no apparent reason to use topological ordering here +extractGraphStructure :: Dag.AlgebraDag VL + -> ([(AlgNode, VL)], [(AlgNode, AlgNode)]) +extractGraphStructure d = (operators, childs) + where nodes = Dag.topsort d + operators = zip nodes $ map (flip Dag.operator d) nodes + childs = concat $ map (\(n, op) -> zip (repeat n) (Dag.opChildren op)) operators + +-- | Render an VL plan into a dot file (GraphViz). +renderVLDot :: NodeMap [Tag] -> [AlgNode] -> NodeMap VL -> String +renderVLDot ts roots m = render $ renderDot dotNodes dotEdges + where (opLabels, edges) = extractGraphStructure d + d = Dag.mkDag m roots + dotNodes = map (constructDotNode roots ts) opLabels + dotEdges = map constructDotEdge edges diff --git a/src/Database/DSH/VL/Render/JSON.hs b/src/Database/DSH/VL/Render/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/VL/Render/JSON.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Database.DSH.VL.Render.JSON + ( serializePlan + , deserializePlan + , planToFile + , planFromFile + ) where + +import Control.Monad +import qualified Data.IntMap as M + +import Data.Aeson (decode, encode) +import Data.Aeson.TH +import qualified Data.ByteString.Lazy.Char8 as BL + +import Database.Algebra.Dag.Common + +import Database.DSH.VL.Lang + +data Plan = Plan { tags :: [(AlgNode, [Tag])] + , roots :: [AlgNode] + , graph :: [(AlgNode, VL)] + } + +$(deriveJSON defaultOptions ''Plan) + +serializePlan :: (NodeMap [Tag], [AlgNode], NodeMap VL) -> BL.ByteString +serializePlan (ts, rs, g) = let tags' = M.toList ts + graph' = M.toList g + in encode $ Plan {tags = tags', roots = rs, graph = graph'} + +deserializePlan :: BL.ByteString -> (NodeMap [Tag], [AlgNode], NodeMap VL) +deserializePlan s = let Just (Plan ts rs g) = decode s + in (M.fromList ts, rs, M.fromList g) + +planToFile :: FilePath -> (NodeMap [Tag], [AlgNode], NodeMap VL) -> IO () +planToFile f t = BL.writeFile f $ serializePlan t + +planFromFile :: FilePath -> IO (NodeMap [Tag], [AlgNode], NodeMap VL) +planFromFile f = liftM deserializePlan $ BL.readFile f diff --git a/src/Database/DSH/VL/Vector.hs b/src/Database/DSH/VL/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/VL/Vector.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | This module defines the kinds of vectors that occur in VL +-- programs. +module Database.DSH.VL.Vector + ( DBCol + , DagVector + , vectorNodes + , updateVector + , ADVec(..) + , VLDVec(..) + , NDVec + , PVec(..) + , RVec(..) + ) where + +import Data.Aeson.TH + +import Database.Algebra.Dag.Common + +import Database.DSH.VL.Lang + +-- | Common properties of data vectors +class DagVector v where + -- | Return all graph nodes which represent the vector. + vectorNodes :: v -> [AlgNode] + + -- | Replace a node in the vector + updateVector :: AlgNode -> AlgNode -> v -> v + +-- | Data vectors. A data vector references a result in an algebra DAG +-- and stores the number of payload columns that it has. 'ADVec' +-- abstracts over the type of references into the graph. +data ADVec r = ADVec r [DBCol] + deriving (Show, Read) + +-- | Data vectors that reference single nodes in an algebra graph +-- (used for table algebra and X100 with an n-ary storage model). +type NDVec = ADVec AlgNode + +instance DagVector NDVec where + vectorNodes (ADVec q _) = [q] + + updateVector n1 n2 (ADVec q cols) + | q == n1 = ADVec n2 cols + | otherwise = ADVec q cols + +-- | A VL data vector references an operator in a VL DAG. +newtype VLDVec = VLDVec AlgNode + deriving (Show, Read) + +instance DagVector VLDVec where + vectorNodes (VLDVec q) = [q] + + updateVector n1 n2 (VLDVec q) + | q == n1 = VLDVec n2 + | otherwise = VLDVec q + + +-- | Propagation vectors. A @PVec@ simply references a node in an +-- algebra Dag. +data PVec = PVec AlgNode + +-- | Rename vectors. A @RVec@ simply references a node in an algebra +-- Dag. +data RVec = RVec AlgNode + +$(deriveJSON defaultOptions ''ADVec) +$(deriveJSON defaultOptions ''PVec) +$(deriveJSON defaultOptions ''RVec) diff --git a/src/Database/DSH/VL/VectorAlgebra.hs b/src/Database/DSH/VL/VectorAlgebra.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/VL/VectorAlgebra.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Database.DSH.VL.VectorAlgebra where + +import qualified Data.List.NonEmpty as N +import Database.DSH.Common.Lang +import Database.DSH.VL.Vector +import Database.DSH.VL.Lang +import Database.Algebra.Dag.Build + +class VectorAlgebra v a where + -- | A vector with one segment + singletonDescr :: Build a v + + -- | A vector representing a literal list. + vecLit :: [ScalarType] -> [[VLVal]] -> Build a v + + -- | A reference to a database-resident table. + vecTableRef :: String -> [VLColumn] -> TableHints -> Build a v + + -- | Perform duplicate elimination per segment. + vecUniqueS :: v -> Build a v + + -- | /Materialize/ vector positions. The operator adds an item + -- column that contains the dense positions of the vector's + -- elements. + vecNumber :: v -> Build a v + + -- | /Materialize/ vector positions per segment. The operator adds + -- an item column that contains the dense positions of the + -- vector's elements in each segment. + vecNumberS :: v -> Build a v + + descToRename :: v -> Build a RVec + + -- | From a vector with only one segment, create a segmented + -- version in which every value in the original segment inhabits + -- its own segment. + vecSegment :: v -> Build a v + + vecUnsegment :: v -> Build a v + + vecAggr :: AggrFun -> v -> Build a v + vecAggrS :: AggrFun -> v -> v -> Build a v + vecAggrNonEmpty :: N.NonEmpty AggrFun -> v -> Build a v + vecAggrNonEmptyS :: N.NonEmpty AggrFun -> v -> Build a v + + vecWinFun :: WinFun -> FrameSpec -> v -> Build a v + + -- | SelectPos filters a vector positionally as specified by the + -- comparison operator and the position value from the right + -- input. Next to the filtered value vector it produces two rename + -- vectors: + -- + -- * Mapping old to new positions (for re-aligning inner vectors) + -- * Mapping old positions to segment descriptors (for unboxing one + -- inner segment) + -- FIXME should be restricted to RelOp! + vecSelectPos :: v -> ScalarBinOp -> v -> Build a (v, RVec, RVec) + + -- | Filter a vector positionally /by segment/. The right input + -- vector provides a position offset /for each segment/. The + -- operator produces the same triple of vectors as its non-segmented + -- variant. + vecSelectPosS :: v -> ScalarBinOp -> v -> Build a (v, RVec, RVec) + + -- | Filter a vector positionally on a /constant/ position. + vecSelectPos1 :: v -> ScalarBinOp -> Int -> Build a (v, RVec, RVec) + + -- | Filter a vector positionally based on a /constant + -- position/. The operator filters by segment, but the constant + -- position argument is the same for all segments. + vecSelectPos1S :: v -> ScalarBinOp -> Int -> Build a (v, RVec, RVec) + + -- | Reverse a vector. + vecReverse :: v -> Build a (v, PVec) + + -- | Reverse each segment of a vector individually. + vecReverseS :: v -> Build a (v, PVec) + + -- | Filter a vector by applying a scalar boolean predicate. + vecSelect:: Expr -> v -> Build a (v, RVec) + + -- | Segmented sorting of a vector. + vecSortS :: [Expr] -> v -> Build a (v, PVec) + + vecGroupS :: [Expr] -> v -> Build a (v, v, PVec) + + -- | The VL aggregation operator groups the input vector by the + -- given columns and then performs the list of aggregations + -- described by the second argument. The result is a flat vector, + -- since all groups are reduced via aggregation. The operator + -- operates segmented, i.e. always groups by descr first. This + -- operator must be used with care: It does not determine the + -- complete set of descr value to check for empty inner lists. + -- The output payload columns are the grouping columns followed by + -- the aggregation results. + vecGroupAggr :: [Expr] -> N.NonEmpty AggrFun -> v -> Build a v + + + -- | Construct a new vector as the result of a list of scalar + -- expressions per result column. + vecProject :: [Expr] -> v -> Build a v + + -- FIXME is distprim really necessary? could maybe be replaced by distdesc + vecDistDesc :: v -> v -> Build a (v, PVec) + vecDistLift :: v -> v -> Build a (v, PVec) + + -- | propRename uses a propagation vector to rename a vector (no + -- filtering or reordering). + vecPropRename :: RVec -> v -> Build a v + + -- | propFilter uses a propagation vector to rename and filter a + -- vector (no reordering). + vecPropFilter :: RVec -> v -> Build a (v, RVec) + + -- | propReorder uses a propagation vector to rename, filter and + -- reorder a vector. + vecPropReorder :: PVec -> v -> Build a (v, PVec) + + -- | Specialized unbox operator that merges DescrToRename + -- and PropRename. It takes an inner and outer vector, and + -- pulls the segment that is referenced by the outer vector + -- into the outer segment. Notice that there must be + -- /exactly one/ segment referenced by the outer + -- vector. Inner segments that are not referenced are + -- silently discarded. + -- + -- Output: @(DVec r, RVec)@ + vecUnboxNested :: RVec -> v -> Build a (v, RVec) + + vecUnboxScalar :: v -> v -> Build a v + + vecAppend :: v -> v -> Build a (v, RVec, RVec) + vecAppendS :: v -> v -> Build a (v, RVec, RVec) + + -- | Align two vectors positionally. However, in contrast to + -- 'vecZip', these are not arbitrary vectors, but vectors which + -- are guaranteed to have the same length because they are + -- operands to lifted operators. + vecAlign :: v -> v -> Build a v + + -- | Positionally align two vectors. Basically: @zip xs ys@ + vecZip :: v -> v -> Build a v + + -- | Positionally align two vectors per segment: @map zip xss + -- yss@. + vecZipS :: v -> v -> Build a (v, RVec, RVec) + + vecCartProduct :: v -> v -> Build a (v, PVec, PVec) + vecCartProductS :: v -> v -> Build a (v, PVec, PVec) + vecNestProduct :: v -> v -> Build a (v, PVec, PVec) + -- FIXME inner result vector contains the outer values. Produce a + -- propagation vector to align the layout. + vecNestProductS :: v -> v -> Build a (v, PVec) + + vecThetaJoin :: JoinPredicate Expr -> v -> v -> Build a (v, PVec, PVec) + vecNestJoin :: JoinPredicate Expr -> v -> v -> Build a (v, PVec, PVec) + vecThetaJoinS :: JoinPredicate Expr -> v -> v -> Build a (v, PVec, PVec) + vecNestJoinS :: JoinPredicate Expr -> v -> v -> Build a (v, PVec) + + vecSemiJoin :: JoinPredicate Expr -> v -> v -> Build a (v, RVec) + vecSemiJoinS :: JoinPredicate Expr -> v -> v -> Build a (v, RVec) + + vecAntiJoin :: JoinPredicate Expr -> v -> v -> Build a (v, RVec) + vecAntiJoinS :: JoinPredicate Expr -> v -> v -> Build a (v, RVec) + + vecCombine :: v -> v -> v -> Build a (v, RVec, RVec) + + -- | Experimental: @reshape m@ partitions a vector of length @n*m@ + -- into @n@ vectors of length @m@. + -- + -- reshapeS can be computed only on the inner vector. As its + -- result is one list nesting level deeper, it computes the new + -- innermost vector from the old inner vector and then derives + -- from that a 'middle' descriptor vector which represents lists + -- at nesting depth 1. + vecReshape :: Integer -> v -> Build a (v, v) + + -- | Experimental: segmented version of reshape. + vecReshapeS :: Integer -> v -> Build a (v, v) + + -- | Experimental: Matrix transposition + vecTranspose :: v -> Build a (v, v) + + -- | Experimental: Segmented matrix transposition + vecTransposeS :: v -> v -> Build a (v, v) + diff --git a/src/Database/DSH/VL/VectorAlgebra/TA.hs b/src/Database/DSH/VL/VectorAlgebra/TA.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/VL/VectorAlgebra/TA.hs @@ -0,0 +1,908 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Implementation of vector primitives in terms of table algebra +-- operators. +module Database.DSH.VL.VectorAlgebra.TA () where + +import Control.Applicative hiding (Const) +import qualified Data.List.NonEmpty as N +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 Database.DSH.Impossible +import Database.DSH.VL.Vector +import qualified Database.DSH.VL.Lang as VL +import Database.DSH.VL.VectorAlgebra + + +-------------------------------------------------------------------------------- +-- Some general helpers + +-- | Results are stored in column: +pos, item', item, descr, descr', descr'', pos', pos'', pos''', posold, posnew, ordCol, resCol, absPos, descri, descro, posi, poso:: Attr +pos = "pos" +item = "item1" +item' = "itemtmp" +descr = "descr" +descr' = "descr1" +descr'' = "descr2" +pos' = "pos1" +pos'' = "pos2" +pos''' = "pos3" +posold = "posold" +posnew = "posnew" +ordCol = "ord" +resCol = "res" +absPos = "abspos" +descro = "descro" +descri = "descri" +poso = "poso" +posi = "posi" + +itemi :: Int -> Attr +itemi i = "item" ++ show i + +itemi' :: Int -> Attr +itemi' i = "itemtmp" ++ show i + +algVal :: VL.VLVal -> AVal +algVal (VL.VLInt i) = int (fromIntegral i) +algVal (VL.VLBool t) = bool t +algVal VL.VLUnit = int (-1) +algVal (VL.VLString s) = string s +algVal (VL.VLDouble d) = double d + +algTy :: VL.ScalarType -> ATy +algTy (VL.Int) = intT +algTy (VL.Double) = doubleT +algTy (VL.Bool) = boolT +algTy (VL.String) = stringT +algTy (VL.Unit) = intT + +cP :: Attr -> Proj +cP a = (a, ColE a) + +eP :: Attr -> Expr -> Proj +eP = (,) + +mP :: Attr -> Attr -> Proj +mP n o = (n, ColE o) + +projAddCols :: [DBCol] -> [Proj] -> AlgNode -> Build TableAlgebra AlgNode +projAddCols cols projs q = proj ([cP descr, cP pos] ++ map (cP . itemi) cols ++ projs) q + +itemProj :: [DBCol] -> [Proj] -> [Proj] +itemProj cols projs = projs ++ [ cP $ itemi i | i <- cols ] + +binOp :: L.ScalarBinOp -> BinFun +binOp (L.SBNumOp L.Add) = Plus +binOp (L.SBNumOp L.Sub) = Minus +binOp (L.SBNumOp L.Div) = Div +binOp (L.SBNumOp L.Mul) = Times +binOp (L.SBNumOp L.Mod) = Modulo +binOp (L.SBRelOp L.Eq) = Eq +binOp (L.SBRelOp L.NEq) = NEq +binOp (L.SBRelOp L.Gt) = Gt +binOp (L.SBRelOp L.GtE) = GtE +binOp (L.SBRelOp L.Lt) = Lt +binOp (L.SBRelOp L.LtE) = LtE +binOp (L.SBBoolOp L.Conj) = And +binOp (L.SBBoolOp L.Disj) = Or +binOp (L.SBStringOp L.Like) = Like + +unOp :: L.ScalarUnOp -> UnFun +unOp (L.SUBoolOp L.Not) = Not +unOp (L.SUCastOp (L.CastDouble)) = Cast doubleT +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 = $unimplemented + +taExprOffset :: Int -> VL.Expr -> Expr +taExprOffset o (VL.BinApp op e1 e2) = BinAppE (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 $ itemi $ 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 + +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 = Count + +-- Common building blocks + +-- | For a segmented aggregate operator, apply the aggregate +-- function's default value for the empty segments. The first argument +-- specifies the outer descriptor vector, while the second argument +-- specifies the result vector of the aggregate. +segAggrDefault :: AlgNode -> AlgNode -> AVal -> Build TableAlgebra AlgNode +segAggrDefault qo qa dv = + return qa + `unionM` + projM [cP descr, eP item (ConstE dv)] + (differenceM + (proj [mP descr pos] qo) + (proj [cP descr] qa)) + +-- | If an aggregate's input is empty, add the aggregate functions +-- default value. The first argument 'q' is the original input vector, +-- whereas the second argument 'qa' is the aggregate's output. +aggrDefault :: AlgNode -> AlgNode -> AVal -> Build TableAlgebra AlgNode +aggrDefault q qa dv = do + -- If the input is empty, produce a tuple with the default value. + qd <- projM [eP descr (ConstE $ nat 2), eP pos (ConstE $ nat 1), eP item (ConstE dv)] + $ (litTable (nat 1) descr ANat) + `differenceM` + (proj [cP descr] q) + + -- For an empty input, there will be two tuples in + -- the union result: the aggregate output with NULL + -- and the default value. + qu <- qa `union` qd + + -- Perform an argmax on the descriptor to get either + -- the sum output (for a non-empty input) or the + -- default value (which has a higher descriptor). + projM [eP descr (ConstE $ nat 1), cP pos, cP item] + $ eqJoinM descr' descr + (aggr [(Max $ ColE descr, descr')] [] qu) + (return qu) + + +-- | The default value for sums over empty lists for all possible +-- numeric input types. +sumDefault :: VL.ScalarType -> (ATy, AVal) +sumDefault VL.Int = (AInt, int 0) +sumDefault VL.Double = (ADouble, double 0) +sumDefault _ = $impossible + +doZip :: (AlgNode, [DBCol]) -> (AlgNode, [DBCol]) -> Build TableAlgebra (AlgNode, [DBCol]) +doZip (q1, cols1) (q2, cols2) = do + let offset = length cols1 + let cols' = cols1 ++ map (+offset) cols2 + r <- projM (cP descr : cP pos : map (cP . itemi) cols') + $ eqJoinM pos pos' + (return q1) + (proj ((mP pos' pos):[ mP (itemi $ i + offset) (itemi i) | i <- cols2 ]) q2) + return (r, cols') + +joinPredicate :: Int -> L.JoinPredicate VL.Expr -> [(Expr, Expr, JoinRel)] +joinPredicate o (L.JoinPred conjs) = N.toList $ fmap joinConjunct conjs + where + joinConjunct :: L.JoinConjunct VL.Expr -> (Expr, Expr, JoinRel) + joinConjunct (L.JoinConjunct e1 op e2) = (taExpr e1, taExprOffset o e2, joinOp op) + + 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 VectorAlgebra instance for TA algebra + +instance VectorAlgebra NDVec TableAlgebra where + vecAlign (ADVec q1 cols1) (ADVec q2 cols2) = do + (r, cols') <- doZip (q1, cols1) (q2, cols2) + return $ ADVec r cols' + + vecZip (ADVec q1 cols1) (ADVec q2 cols2) = do + (r, cols') <- doZip (q1, cols1) (q2, cols2) + return $ ADVec r cols' + + vecLit tys vs = do + qr <- flip litTable' ((descr, natT):(pos, natT):[(itemi i, algTy t) | (i, t) <- zip [1..] tys]) + $ map (map algVal) vs + return $ ADVec qr [1..length tys] + + vecPropRename (RVec q1) (ADVec q2 cols) = do + q <- tagM "propRename" + $ projM (itemProj cols [mP descr posnew, cP pos]) + $ eqJoin posold descr q1 q2 + return $ ADVec q cols + + vecPropFilter (RVec q1) (ADVec q2 cols) = do + q <- rownumM pos' [posnew, pos] [] $ eqJoin posold descr q1 q2 + qr1 <- flip ADVec cols <$> proj (itemProj cols [mP descr posnew, mP pos pos']) q + qr2 <- RVec <$> proj [mP posold pos, mP posnew pos'] q + return $ (qr1, qr2) + + -- For TA algebra, the filter and reorder cases are the same, since + -- numbering to generate positions is done with a rownum and involves sorting. + vecPropReorder (PVec q1) e2 = do + (p, (RVec r)) <- vecPropFilter (RVec q1) e2 + return (p, PVec r) + + vecUnboxNested (RVec qu) (ADVec qi cols) = do + -- Perform a segment join between inner vector and outer unboxing + -- rename vector. This implicitly discards any unreferenced + -- segments in qi. + q <- projM (itemProj cols [mP descr posnew, cP pos, mP posold pos']) + $ rownumM pos [pos'] [] + $ eqJoinM posold descr' + (return qu) + (proj (itemProj cols [mP descr' descr, mP pos' pos]) qi) + + -- The unboxed vector containing one segment from the inner vector. + qv <- proj (itemProj cols [cP descr, cP pos]) q + -- A rename vector in case the inner vector has inner vectors as + -- well. + qr <- proj [mP posnew pos, cP posold] q + + return (ADVec qv cols, RVec qr) + + vecCombine (ADVec qb _) (ADVec q1 cols) (ADVec q2 _) = do + d1 <- projM [cP pos', cP pos] + $ rownumM pos' [pos] [] + $ select (ColE item) qb + d2 <- projM [cP pos', cP pos] + $ rownumM pos' [pos] [] + $ select (UnAppE Not (ColE item)) qb + q <- eqJoinM pos' posold + (return d1) + (proj (itemProj cols [mP posold pos, cP descr]) q1) + `unionM` + eqJoinM pos' posold + (return d2) + (proj (itemProj cols [mP posold pos, cP descr]) q2) + qr <- proj (itemProj cols [cP descr, cP pos]) q + qp1 <- proj [mP posnew pos, mP posold pos'] d1 + qp2 <- proj [mP posnew pos, mP posold pos'] d2 + return $ (ADVec qr cols, RVec qp1, RVec qp2) + + vecSegment (ADVec q cols) = do + flip ADVec cols <$> proj (itemProj cols [mP descr pos, cP pos]) q + + vecUnsegment (ADVec q cols) = do + qr <- proj (itemProj cols [cP pos, eP descr (ConstE $ nat 1)]) q + return $ ADVec qr cols + + vecDistDesc (ADVec q1 cols) (ADVec q2 _) = do + q <- projM (itemProj cols [mP descr pos, mP pos pos'', cP posold]) + $ rownumM pos'' [pos, pos'] [] + $ crossM + (proj [cP pos] q2) + (proj (itemProj cols [mP pos' pos, mP posold pos]) q1) + qr1 <- flip ADVec cols <$> proj (itemProj cols [cP descr, cP pos]) q + qr2 <- PVec <$> proj [cP posold, mP posnew pos] q + return $ (qr1, qr2) + + vecDistLift (ADVec q1 cols1) (ADVec q2 cols2) = do + let cols2' = [ i + length cols1 | i <- cols2 ] + shiftProj = [ mP (itemi i') (itemi i) | i <- cols2 | i' <- cols2' ] + resCols = cols1 ++ cols2' + q <- eqJoinM pos' descr + (proj (itemProj cols1 [mP pos' pos]) q1) + (proj ([cP descr, cP pos] ++ shiftProj) q2) + + qr1 <- proj (itemProj resCols [cP descr, cP pos]) q + qr2 <- proj [mP posold pos', mP posnew pos] q + return (ADVec qr1 resCols, PVec qr2) + + vecWinFun a w (ADVec q cols1) = do + let wfun = windowFunction a + frameSpec = frameSpecification w + winCol = itemi $ length cols1 + 1 + qw <- winFun (winCol, wfun) [] [(ColE pos, Asc)] (Just frameSpec) q + return $ ADVec qw (cols1 ++ [length cols1 + 1]) + + vecAggr a (ADVec q _) = do + -- The aggr operator itself + qa <- projM [eP descr (ConstE $ nat 1), eP pos (ConstE $ nat 1), cP item] + $ aggr [(aggrFun a, item)] [] q + -- For sum, add the default value for empty inputs + qd <- case a of + VL.AggrSum t _ -> aggrDefault q qa (snd $ sumDefault t) + VL.AggrAll _ -> aggrDefault q qa (bool True) + VL.AggrAny _ -> aggrDefault q qa (bool False) + _ -> return qa + + return $ ADVec qd [1] + + vecAggrNonEmpty as (ADVec q _) = do + let resCols = [1 .. N.length as] + + let aggrFuns = [ (aggrFun a, itemi i) + | a <- N.toList as + | i <- resCols + ] + + qa <- projM (itemProj resCols [eP descr (ConstE $ nat 1), eP pos (ConstE $ nat 1)]) + $ aggr aggrFuns [] q + + return $ ADVec qa resCols + + + vecAggrS a (ADVec qo _) (ADVec qi _) = do + qa <- aggr [(aggrFun a, item)] [(descr, ColE descr)] qi + qd <- case a of + VL.AggrSum t _ -> segAggrDefault qo qa (snd $ sumDefault t) + VL.AggrAny _ -> segAggrDefault qo qa (bool False) + VL.AggrAll _ -> segAggrDefault qo qa (bool True) + + VL.AggrCount -> segAggrDefault qo qa (int 0) + _ -> return qa + + qr <- rownum' pos [(ColE descr, Asc)] [] qd + + return $ ADVec qr [1] + + vecAggrNonEmptyS as (ADVec q _) = do + let resCols = [1 .. N.length as] + + let aggrFuns = [ (aggrFun a, itemi i) + | a <- N.toList as + | i <- resCols + ] + + -- Compute aggregate output per segment and new positions + qa <- projM (itemProj resCols [cP descr, cP pos]) + $ rownumM pos [descr] [] + $ aggr aggrFuns [(descr, ColE descr)] q + + return $ ADVec qa resCols + + vecReverse (ADVec q cols) = do + q' <- rownum' pos' [(ColE pos, Desc)] [] q + r <- proj (itemProj cols [cP descr, mP pos pos']) q' + p <- proj [mP posold pos, mP posnew pos'] q' + return (ADVec r cols, PVec p) + + vecReverseS (ADVec q cols) = do + q' <- rownum' pos' [(ColE descr, Asc), (ColE pos, Desc)] [] q + r <- proj (itemProj cols [cP descr, mP pos pos']) q' + p <- proj [mP posold pos, mP posnew pos'] q' + return (ADVec r cols, PVec p) + + vecUniqueS (ADVec q cols) = do + let groupCols = map (\c -> (c, ColE c)) (descr : map itemi cols) + qr <- rownumM pos [pos] [] + $ aggr [(Min (ColE pos), pos)] groupCols q + return $ ADVec qr cols + + descToRename (ADVec q1 _) = RVec <$> proj [mP posnew descr, mP posold pos] q1 + + singletonDescr = do + q <- litTable' [[nat 1, nat 1]] [(descr, natT), (pos, natT)] + return $ ADVec q [] + + vecAppend (ADVec q1 cols) (ADVec q2 _) = do + q <- rownumM posnew [ordCol, pos] [] + $ projAddCols cols [eP ordCol (ConstE (nat 1))] q1 + `unionM` + projAddCols cols [eP ordCol (ConstE (nat 2))] q2 + qv <- tagM "append r" (proj (itemProj cols [mP pos posnew, cP descr]) q) + qp1 <- tagM "append r1" + $ projM [mP posold pos, cP posnew] + $ select (BinAppE Eq (ColE ordCol) (ConstE $ nat 1)) q + qp2 <- tagM "append r2" + $ projM [mP posold pos, cP posnew] + $ select (BinAppE Eq (ColE ordCol) (ConstE $ nat 2)) q + return $ (ADVec qv cols, RVec qp1, RVec qp2) + + vecAppendS (ADVec q1 cols) (ADVec q2 _) = do + q <- rownumM posnew [descr, ordCol, pos] [] + $ projAddCols cols [eP ordCol (ConstE (nat 1))] q1 + `unionM` + projAddCols cols [eP ordCol (ConstE (nat 2))] q2 + qv <- tagM "append r" (proj (itemProj cols [mP pos posnew, cP descr]) q) + qp1 <- tagM "append r1" + $ projM [mP posold pos, cP posnew] + $ select (BinAppE Eq (ColE ordCol) (ConstE $ nat 1)) q + qp2 <- tagM "append r2" + $ projM [mP posold pos, cP posnew] + $ select (BinAppE Eq (ColE ordCol) (ConstE $ nat 2)) q + return $ (ADVec qv cols, RVec qp1, RVec qp2) + + vecSelect expr (ADVec q cols) = do + qs <- rownumM posnew [pos] [] + $ select (taExpr expr) q + qv <- proj (itemProj cols [cP descr, mP pos posnew]) qs + qr <- proj [mP posold pos, cP posnew] qs + return (ADVec qv cols, RVec qr) + + vecTableRef tableName columns hints = do + q <- -- generate the pos column + rownumM pos orderCols [] + -- map table columns to item columns, add constant descriptor + $ projM (eP descr (ConstE (nat 1)) : [ mP (itemi i) c | (c, i) <- numberedColNames ]) + $ dbTable tableName taColumns (map Key taKeys) + return $ ADVec q (map snd numberedColNames) + + where + numberedColNames = zipWith (\((L.ColName c), _) i -> (c, i)) columns [1..] + + taColumns = [ (c, algTy t) | (L.ColName c, t) <- columns ] + + taKeys = [ [ itemi $ colIndex c | L.ColName c <- k ] | L.Key k <- L.keysHint hints ] + + colIndex :: Attr -> Int + colIndex n = + case lookup n numberedColNames of + Just i -> i + Nothing -> $impossible + + -- the initial table order is generated as follows: + -- * if there are known keys for the table, we take the shortest one, in the hope + -- that it will be the primary key. A sorting operation then might be able to + -- use a primary key index. + -- * without a key, we just take an arbitrary column (here, the first). + orderCols = case sortWith length taKeys of + k : _ -> k + [] -> [itemi 1] + + vecGroupS groupExprs (ADVec q1 cols1) = do + -- apply the grouping expressions and compute surrogate values + -- from the grouping values + let groupProjs = [ eP (itemi' i) (taExpr e) | e <- groupExprs | i <- [1..] ] + groupCols = map fst groupProjs + qg <- rowrankM resCol [ (ColE c, Asc) | c <- (descr : groupCols) ] + $ proj (itemProj cols1 ([cP descr, cP pos] ++ groupProjs)) q1 + + -- Create the outer vector, containing surrogate values and the + -- grouping values + qo <- distinctM + $ proj ([cP descr, mP pos resCol] + ++ [ mP (itemi i) c | c <- groupCols | i <- [1..] ]) qg + + -- Create new positions for the inner vector + qp <- rownum posnew [resCol, pos] [] qg + + -- Create the inner vector, containing the actual groups + qi <- proj (itemProj cols1 [mP descr resCol, mP pos posnew]) qp + + qprop <- proj [mP posold pos, cP posnew] qp + + return (ADVec qo [1 .. length groupExprs], ADVec qi cols1, PVec qprop) + + vecCartProduct (ADVec q1 cols1) (ADVec q2 cols2) = do + let itemProj1 = map (cP . itemi) cols1 + cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + itemProj2 = map (cP . itemi) cols2' + + q <- projM ([cP descr, cP pos, cP pos', cP pos''] ++ itemProj1 ++ itemProj2) + $ rownumM pos [pos', pos''] [] + $ crossM + (proj ([cP descr, mP pos' pos] ++ itemProj1) q1) + (proj ((mP pos'' pos) : shiftProj2) q2) + + qv <- proj ([cP descr, cP pos] ++ itemProj1 ++ itemProj2) q + qp1 <- proj [mP posold pos', mP posnew pos] q + qp2 <- proj [mP posold pos'', mP posnew pos] q + return (ADVec qv (cols1 ++ cols2'), PVec qp1, PVec qp2) + + vecCartProductS (ADVec q1 cols1) (ADVec q2 cols2) = do + let itemProj1 = map (cP . itemi) cols1 + cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + itemProj2 = map (cP . itemi) cols2' + q <- projM ([cP descr, cP pos, cP pos', cP pos''] ++ itemProj1 ++ itemProj2) + $ rownumM pos [descr, descr', pos', pos''] [] + $ eqJoinM descr descr' + (proj ([cP descr, mP pos' pos] ++ itemProj1) q1) + (proj ([mP descr' descr, mP pos'' pos] ++ shiftProj2) q2) + qv <- proj ([cP descr, cP pos] ++ itemProj1 ++ itemProj2) q + qp1 <- proj [mP posold pos', mP posnew pos] q + qp2 <- proj [mP posold pos'', mP posnew pos] q + return (ADVec qv (cols1 ++ cols2'), PVec qp1, PVec qp2) + + vecNestProduct (ADVec q1 cols1) (ADVec q2 cols2) = do + let itemProj1 = map (cP . itemi) cols1 + cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + itemProj2 = map (cP . itemi) cols2' + + q <- projM ([mP descr pos', cP pos, cP pos', cP pos''] ++ itemProj1 ++ itemProj2) + $ rownumM pos [pos', pos''] [] + $ crossM + (proj ([cP descr, mP pos' pos] ++ itemProj1) q1) + (proj ((mP pos'' pos) : shiftProj2) q2) + + qv <- proj ([cP descr, cP pos] ++ itemProj1 ++ itemProj2) q + qp1 <- proj [mP posold pos', mP posnew pos] q + qp2 <- proj [mP posold pos'', mP posnew pos] q + return (ADVec qv (cols1 ++ cols2'), PVec qp1, PVec qp2) + + -- FIXME merge common parts of vecCartProductS and vecNestProductS + vecNestProductS (ADVec q1 cols1) (ADVec q2 cols2) = do + let itemProj1 = map (cP . itemi) cols1 + cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + itemProj2 = map (cP . itemi) cols2' + + q <- projM ([mP descr pos', cP pos, cP pos', cP pos''] ++ itemProj1 ++ itemProj2) + $ rownumM pos [descr, pos', pos''] [] + $ eqJoinM descr descr' + (proj ([cP descr, mP pos' pos] ++ itemProj1) q1) + (proj ([mP descr' descr, mP pos'' pos] ++ shiftProj2) q2) + qv <- proj ([cP descr, cP pos] ++ itemProj1 ++ itemProj2) q + qp2 <- proj [mP posold pos'', mP posnew pos] q + return (ADVec qv (cols1 ++ cols2'), PVec qp2) + + vecThetaJoin joinPred (ADVec q1 cols1) (ADVec q2 cols2) = do + let itemProj1 = map (cP . itemi) cols1 + cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + itemProj2 = map (cP . itemi) cols2' + + q <- projM ([cP descr, cP pos, cP pos', cP pos''] ++ itemProj1 ++ itemProj2) + $ rownumM pos [pos', pos''] [] + $ thetaJoinM (joinPredicate (length cols1) joinPred) + (proj ([ cP descr + , mP pos' pos + ] ++ itemProj1) q1) + (proj ([ mP pos'' pos + ] ++ shiftProj2) q2) + + qv <- tagM "eqjoin/1" $ proj ([cP descr, cP pos] ++ itemProj1 ++ itemProj2) q + qp1 <- proj [mP posold pos', mP posnew pos] q + qp2 <- proj [mP posold pos'', mP posnew pos] q + return (ADVec qv (cols1 ++ cols2'), PVec qp1, PVec qp2) + + vecNestJoin joinPred (ADVec q1 cols1) (ADVec q2 cols2) = do + let itemProj1 = map (cP . itemi) cols1 + cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + itemProj2 = map (cP . itemi) cols2' + + q <- projM ([cP pos, cP pos', cP pos''] ++ itemProj1 ++ itemProj2) + $ rownumM pos [pos', pos''] [] + $ thetaJoinM (joinPredicate (length cols1) joinPred) + (proj ([ mP pos' pos + ] ++ itemProj1) q1) + (proj ([ mP pos'' pos + ] ++ shiftProj2) q2) + + qv <- tagM "eqjoin/1" $ proj ([mP descr pos', cP pos] ++ itemProj1 ++ itemProj2) q + qp1 <- proj [mP posold pos', mP posnew pos] q + qp2 <- proj [mP posold pos'', mP posnew pos] q + return (ADVec qv (cols1 ++ cols2'), PVec qp1, PVec qp2) + + vecThetaJoinS joinPred (ADVec q1 cols1) (ADVec q2 cols2) = do + let itemProj1 = map (cP . itemi) cols1 + cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + itemProj2 = map (cP . itemi) cols2' + + q <- projM ([cP descr, cP pos, cP pos', cP pos''] ++ itemProj1 ++ itemProj2) + $ rownumM pos [pos', pos''] [] + $ thetaJoinM ((ColE descr, ColE descr', EqJ) : joinPredicate (length cols1) joinPred) + (proj ([ cP descr + , mP pos' pos + ] ++ itemProj1) q1) + (proj ([ mP descr' descr + , mP pos'' pos + ] ++ shiftProj2) q2) + + qv <- proj ([cP descr, cP pos] ++ itemProj1 ++ itemProj2) q + qp1 <- proj [mP posold pos', mP posnew pos] q + qp2 <- proj [mP posold pos'', mP posnew pos] q + return (ADVec qv (cols1 ++ cols2'), PVec qp1, PVec qp2) + + -- There is only one difference between EquiJoinS and NestJoinS. For + -- NestJoinS, we 'segment' after the join, i.e. use the left input + -- positions as the result descriptor. + -- FIXME merge the common parts. + vecNestJoinS joinPred (ADVec q1 cols1) (ADVec q2 cols2) = do + let itemProj1 = map (cP . itemi) cols1 + cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + itemProj2 = map (cP . itemi) cols2' + + q <- projM ([mP descr pos', cP pos, cP pos', cP pos''] ++ itemProj1 ++ itemProj2) + $ rownumM pos [descr, pos', pos''] [] + $ thetaJoinM ((ColE descr, ColE descr', EqJ) : joinPredicate (length cols1) joinPred) + (proj ([ cP descr + , mP pos' pos + ] ++ itemProj1) q1) + (proj ([ mP descr' descr + , mP pos'' pos + ] ++ shiftProj2) q2) + + qv <- proj ([cP descr, cP pos] ++ itemProj1 ++ itemProj2) q + qp2 <- proj [mP posold pos'', mP posnew pos] q + return (ADVec qv (cols1 ++ cols2'), PVec qp2) + + vecUnboxScalar (ADVec qo colso) (ADVec qi colsi) = do + let colsi' = [((length colso) + 1) .. ((length colso) + (length colsi))] + shiftProji = zipWith mP (map itemi colsi') (map itemi colsi) + itemProji = map (cP . itemi) colsi' + + qu <- projM ([cP descr, cP pos] ++ (map (cP . itemi) colso) ++ itemProji) + $ eqJoinM pos descr' + (return qo) + (proj ([mP descr' descr] ++ shiftProji) qi) + return $ ADVec qu (colso ++ colsi') + + vecSelectPos (ADVec qe cols) op (ADVec qi _) = do + qs <- selectM (BinAppE (binOp op) (ColE pos) (UnAppE (Cast natT) (ColE item'))) + $ crossM + (return qe) + (proj [mP item' item] qi) + + q' <- case op of + -- If we select positions from the beginning, we can re-use the old + -- positions + (L.SBRelOp L.Lt) -> projAddCols cols [mP posnew pos] qs + (L.SBRelOp L.LtE) -> projAddCols cols [mP posnew pos] qs + -- Only if selected positions don't start at the beginning (i.e. 1) + -- do we have to recompute them. + _ -> rownum posnew [pos] [] qs + + qr <- proj (itemProj cols [cP descr, mP pos posnew]) q' + -- A regular rename vector for re-aligning inner vectors + qp <- proj [ mP posold pos, cP posnew ] q' + -- An unboxing rename vector + qu <- proj [ mP posold pos, mP posnew descr ] q' + return $ (ADVec qr cols, RVec qp, RVec qu) + + vecSelectPosS (ADVec qe cols) op (ADVec qi _) = do + qs <- rownumM posnew [pos] [] + $ selectM (BinAppE (binOp op) (ColE absPos) (UnAppE (Cast natT) (ColE item'))) + $ eqJoinM descr pos' + (rownum absPos [pos] [ColE descr] qe) + (proj [mP pos' pos, mP item' item] qi) + + qr <- proj (itemProj cols [cP descr, mP pos posnew]) qs + qp <- proj [ mP posold pos, cP posnew ] qs + qu <- proj [ mP posnew descr, mP posold pos] qs + return $ (ADVec qr cols, RVec qp, RVec qu) + + vecSelectPos1 (ADVec qe cols) op posConst = do + let posConst' = VNat $ fromIntegral posConst + qs <- select (BinAppE (binOp op) (ColE pos) (ConstE posConst')) qe + + q' <- case op of + -- If we select positions from the beginning, we can re-use the old + -- positions + (L.SBRelOp L.Lt) -> projAddCols cols [mP posnew pos] qs + (L.SBRelOp L.LtE) -> projAddCols cols [mP posnew pos] qs + -- Only if selected positions don't start at the beginning (i.e. 1) + -- do we have to recompute them. + _ -> rownum posnew [pos] [] qs + + qr <- proj (itemProj cols [cP descr, mP pos posnew]) q' + qp <- proj [ mP posold pos, cP posnew ] q' + qu <- proj [ mP posold pos, mP posnew descr ] q' + return $ (ADVec qr cols, RVec qp, RVec qu) + + -- If we select positions in a lifted way, we need to recompute + -- positions in any case. + vecSelectPos1S (ADVec qe cols) op posConst = do + let posConst' = VNat $ fromIntegral posConst + qs <- rownumM posnew [pos] [] + $ selectM (BinAppE (binOp op) (ColE absPos) (ConstE posConst')) + $ rownum absPos [pos] [ColE descr] qe + + qr <- proj (itemProj cols [cP descr, mP pos posnew]) qs + qp <- proj [ mP posold pos, cP posnew ] qs + qu <- proj [ mP posold pos, mP posnew descr ] qs + return $ (ADVec qr cols, RVec qp, RVec qu) + + vecProject projs (ADVec q _) = do + let projs' = zipWith (\i e -> (itemi i, taExpr e)) [1 .. length projs] projs + qr <- proj ([cP descr, cP pos] ++ projs') q + return $ ADVec qr [1 .. (length projs)] + + vecZipS (ADVec q1 cols1) (ADVec q2 cols2) = do + q1' <- rownum pos'' [pos] [ColE descr] q1 + q2' <- rownum pos''' [pos] [ColE descr] q2 + let offset = length cols1 + cols2' = map (+ offset) cols2 + allCols = cols1 ++ cols2' + allColsProj = map (cP . itemi) allCols + shiftProj = zipWith mP (map itemi cols2') (map itemi cols2) + qz <- rownumM posnew [descr, pos''] [] + $ projM ([cP pos', cP pos, cP descr] ++ allColsProj) + $ thetaJoinM [(ColE descr, ColE descr', EqJ), (ColE pos'', ColE pos''', EqJ)] + (return q1') + (proj ([mP descr' descr, mP pos' pos, cP pos'''] ++ shiftProj) q2') + + r1 <- proj [mP posold pos'', cP posnew] qz + r2 <- proj [mP posold pos''', cP posnew] qz + qr <- proj ([cP descr, mP pos posnew] ++ allColsProj) qz + return (ADVec qr allCols, RVec r1, RVec r2) + + vecGroupAggr groupExprs aggrFuns (ADVec q _) = do + let partAttrs = (descr, cP descr) + : + [ (itemi i, eP (itemi i) (taExpr e)) | e <- groupExprs | i <- [1..] ] + + pw = length groupExprs + + pfAggrFuns = [ (aggrFun a, itemi $ pw + i) | a <- N.toList aggrFuns | i <- [1..] ] + + -- GroupAggr(e, f) has to mimic the behaviour of GroupS(e) + + -- AggrS(f) exactly. GroupScalarS determines the order of the + -- groups by the sort order of the grouping keys (implicitly via + -- RowRank). GroupAggr has to provide the aggregated groups in the + -- same order to be aligned. Therefore, we sort by /all/ grouping + -- attributes. + qa <- rownumM pos (map fst partAttrs) [] + $ aggr pfAggrFuns (map snd partAttrs) q + + return $ ADVec qa [1 .. length groupExprs + N.length aggrFuns] + + vecNumber (ADVec q cols) = do + let nrIndex = length cols + 1 + nrItem = itemi nrIndex + qr <- projAddCols cols [eP nrItem (UnAppE (Cast natT) (ColE pos))] q + return $ ADVec qr (cols ++ [nrIndex]) + + -- The TA implementation of lifted number does not come for + -- free: To generate the absolute numbers for every sublist + -- (i.e. descriptor partition), we have to use a partitioned + -- rownumber. + vecNumberS (ADVec q cols) = do + let nrIndex = length cols + 1 + nrItem = itemi nrIndex + qr <- rownum nrItem [pos] [ColE descr] q + return $ ADVec qr (cols ++ [nrIndex]) + + vecSemiJoin joinPred (ADVec q1 cols1) (ADVec q2 cols2) = do + let cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + + q <- rownumM pos [posold] [] + $ projM (itemProj cols1 [cP descr, mP posold pos]) + $ semiJoinM (joinPredicate (length cols1) joinPred) + (proj (itemProj cols1 [cP descr, cP pos]) q1) + (proj shiftProj2 q2) + qj <- tagM "semijoin/1" $ proj (itemProj cols1 [cP descr, cP pos]) q + r <- proj [cP posold, mP posold posnew] q + return $ (ADVec qj cols1, RVec r) + + vecSemiJoinS joinPred (ADVec q1 cols1) (ADVec q2 cols2) = do + let cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + + q <- rownumM pos [descr, posold] [] + $ projM (itemProj cols1 [cP descr, mP posold pos]) + $ semiJoinM ((ColE descr, ColE descr', EqJ) : joinPredicate (length cols1) joinPred) + (proj (itemProj cols1 [cP descr, cP pos]) q1) + (proj ([mP descr' descr] ++ shiftProj2) q2) + qj <- tagM "semijoinLift/1" $ proj (itemProj cols1 [cP descr, cP pos]) q + r <- proj [cP posold, mP posold posnew] q + return $ (ADVec qj cols1, RVec r) + + vecAntiJoin joinPred (ADVec q1 cols1) (ADVec q2 cols2) = do + let cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + + q <- rownumM pos [posold] [] + $ projM (itemProj cols1 [cP descr, mP posold pos]) + $ antiJoinM (joinPredicate (length cols1) joinPred) + (proj (itemProj cols1 [cP descr, cP pos]) q1) + (proj shiftProj2 q2) + qj <- tagM "antijoin/1" $ proj (itemProj cols1 [cP descr, cP pos]) q + r <- proj [cP posold, mP posold posnew] q + return $ (ADVec qj cols1, RVec r) + + vecAntiJoinS joinPred (ADVec q1 cols1) (ADVec q2 cols2) = do + let cols2' = [((length cols1) + 1) .. ((length cols1) + (length cols2))] + shiftProj2 = zipWith mP (map itemi cols2') (map itemi cols2) + + q <- rownumM pos [descr, posold] [] + $ projM (itemProj cols1 [cP descr, mP posold pos]) + $ antiJoinM ((ColE descr, ColE descr', EqJ) : joinPredicate (length cols1) joinPred) + (proj (itemProj cols1 [cP descr, cP pos]) q1) + (proj ([mP descr' descr] ++ shiftProj2) q2) + qj <- tagM "antijoinLift/1" $ proj (itemProj cols1 [cP descr, cP pos]) q + r <- proj [cP posold, mP posold posnew] q + return $ (ADVec qj cols1, RVec r) + + vecSortS sortExprs (ADVec q1 cols1) = do + let sortProjs = zipWith (\i e -> (itemi' i, taExpr e)) [1..] sortExprs + -- Including positions de facto implements stable sorting + qs <- rownumM pos' ([descr] ++ map fst sortProjs ++ [pos]) [] + $ projAddCols cols1 sortProjs q1 + + qr1 <- proj (itemProj cols1 [cP descr, mP pos pos']) qs + qr2 <- proj [mP posold pos, mP posnew pos'] qs + + return (ADVec qr1 cols1, PVec qr2) + + -- FIXME none of vecReshape, vecReshapeS, vecTranspose and + -- vecTransposeS deal with empty inner inputs correctly! + vecReshape n (ADVec q cols) = do + let dExpr = BinAppE Div (BinAppE Minus (ColE pos) (ConstE $ int 1)) (ConstE $ int $ n + 1) + qi <- proj (itemProj cols [cP pos, eP descr dExpr]) q + qo <- projM [eP descr (ConstE $ nat 1), cP pos] + $ distinctM + $ proj [mP pos descr] qi + return (ADVec qo [], ADVec qi cols) + + vecReshapeS n (ADVec q cols) = do + let dExpr = BinAppE Div (BinAppE Minus (ColE absPos) (ConstE $ int 1)) (ConstE $ int $ n + 1) + qr <- -- Make the new descriptors valid globally + -- FIXME need a rowrank instead! + rownumM descr'' [descr, descr'] [] + -- Assign the inner list elements to sublists. Generated + -- descriptors are _per_ inner list! + $ projM (itemProj cols [cP descr, cP pos, eP descr' dExpr]) + -- Generate absolute positions for the inner lists + $ rownum absPos [pos] [ColE descr] q + + -- We can compute the 'middle' descriptor vector from the original + -- inner vector. + qm <- distinctM $ proj [cP descr, mP pos descr''] qr + + qi <- proj (itemProj cols [mP descr descr'', cP pos]) qr + + return (ADVec qm [], ADVec qi cols) + + vecTranspose (ADVec q cols) = do + qi <- projM (itemProj cols [mP descr descr', mP pos pos']) + -- Generate new positions. We use absolute positions as the + -- new descriptor here. This implements the swapping of row + -- and column ids (here: descr and pos) that is the core of + -- transposition. + $ rownumM pos' [descr', pos] [] + -- Generate absolute positions for the inner lists + $ rownum descr' [pos] [ColE descr] q + + qo <- projM [eP descr (ConstE $ nat 1), cP pos] + $ distinctM + $ proj [mP pos descr] qi + + return (ADVec qo [], ADVec qi cols) + + vecTransposeS (ADVec qo _) (ADVec qi cols) = do + qr <- -- Generate new globally valid positions for the inner vector + rownumM pos' [descr', absPos] [] + -- Absolute positions form the new inner descriptor. However, so + -- far they are relative to the outer descriptor. Here, make them + -- "globally" valid. + $ rowrankM descr' [(ColE descro, Asc), (ColE absPos, Asc)] + -- As usual, generate absolute positions + $ rownumM absPos [posi] [ColE descri] + -- Join middle and inner vector because we need to know to which + -- outer list each leaf element belongs + $ eqJoinM poso descri + (proj [mP descro descr, mP poso pos] qo) + (proj (itemProj cols [mP descri descr, mP posi pos]) qi) + + qi' <- proj (itemProj cols [mP descr descr', mP pos pos']) qr + qm <- distinctM $ proj [mP descr descro, mP pos descr'] qr + + return (ADVec qm [], ADVec qi' cols) diff --git a/src/Database/DSH/VL/Vectorize.hs b/src/Database/DSH/VL/Vectorize.hs new file mode 100644 --- /dev/null +++ b/src/Database/DSH/VL/Vectorize.hs @@ -0,0 +1,861 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ParallelListComp #-} + +-- | Vectorising constructor functions that implement FKL primitives +-- using VL operators. +module Database.DSH.VL.Vectorize where + +import Debug.Trace + +import Control.Applicative +import qualified Data.List as List +import Prelude hiding (reverse, zip) +import qualified Prelude as P + +import Database.Algebra.Dag.Build + +import qualified Database.DSH.Common.Lang as L +import Database.DSH.Common.Nat +import Database.DSH.Common.QueryPlan +import Database.DSH.Common.Type +import Database.DSH.Impossible +import Database.DSH.VL.Lang (AggrFun (..), Expr (..), VL (), + VLVal (..)) +import Database.DSH.VL.Primitives +import Database.DSH.VL.Vector + +-------------------------------------------------------------------------------- +-- Construction of not-lifted primitives + +zip :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +zip (VShape q1 lyt1) (VShape q2 lyt2) = do + q' <- vlZip q1 q2 + return $ VShape q' $ zipLayout lyt1 lyt2 +zip _ _ = $impossible + +cartProduct :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +cartProduct (VShape q1 lyt1) (VShape q2 lyt2) = do + (q', p1, p2) <- vlCartProduct q1 q2 + lyt1' <- chainReorder p1 lyt1 + lyt2' <- chainReorder p2 lyt2 + return $ VShape q' $ zipLayout lyt1' lyt2' +cartProduct _ _ = $impossible + +nestProduct :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +nestProduct (VShape q1 lyt1) (VShape q2 lyt2) = do + (q', p1, p2) <- vlNestProduct q1 q2 + lyt1' <- chainReorder p1 lyt1 + lyt2' <- chainReorder p2 lyt2 + return $ VShape q1 (LTuple [lyt1, LNest q' (zipLayout lyt1' lyt2')]) +nestProduct _ _ = $impossible + +thetaJoin :: L.JoinPredicate L.JoinExpr -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +thetaJoin joinPred (VShape q1 lyt1) (VShape q2 lyt2) = do + (q', p1, p2) <- vlThetaJoin joinPred q1 q2 + lyt1' <- chainReorder p1 lyt1 + lyt2' <- chainReorder p2 lyt2 + return $ VShape q' $ zipLayout lyt1' lyt2' +thetaJoin _ _ _ = $impossible + +nestJoin :: L.JoinPredicate L.JoinExpr -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +nestJoin joinPred (VShape q1 lyt1) (VShape q2 lyt2) = do + (q', p1, p2) <- vlNestJoin joinPred q1 q2 + lyt1' <- chainReorder p1 lyt1 + lyt2' <- chainReorder p2 lyt2 + return $ VShape q1 (LTuple [lyt1, LNest q' (zipLayout lyt1' lyt2')]) +nestJoin _ _ _ = $impossible + +semiJoin :: L.JoinPredicate L.JoinExpr -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +semiJoin joinPred (VShape q1 lyt1) (VShape q2 _) = do + (qj, r) <- vlSemiJoin joinPred q1 q2 + lyt1' <- chainRenameFilter r lyt1 + return $ VShape qj lyt1' +semiJoin _ _ _ = $impossible + +antiJoin :: L.JoinPredicate L.JoinExpr -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +antiJoin joinPred (VShape q1 lyt1) (VShape q2 _) = do + (qj, r) <- vlAntiJoin joinPred q1 q2 + lyt1' <- chainRenameFilter r lyt1 + return $ VShape qj lyt1' +antiJoin _ _ _ = $impossible + +nub :: Shape VLDVec -> Build VL (Shape VLDVec) +nub (VShape q lyt) = VShape <$> vlUniqueS q <*> pure lyt +nub _ = $impossible + +number :: Shape VLDVec -> Build VL (Shape VLDVec) +number (VShape q lyt) = + VShape <$> vlNumber q <*> (pure $ zipLayout lyt (LCol 1)) +number _ = $impossible + +init :: Shape VLDVec -> Build VL (Shape VLDVec) +init (VShape q lyt) = do + i <- vlAggr AggrCount q + (q', r, _) <- vlSelectPos q (L.SBRelOp L.Lt) i + lyt' <- chainRenameFilter r lyt + return $ VShape q' lyt' +init _ = $impossible + +last :: Shape VLDVec -> Build VL (Shape VLDVec) +last (VShape qs lyt@(LNest _ _)) = do + i <- vlAggr AggrCount qs + (q, r, _) <- vlSelectPos qs (L.SBRelOp L.Eq) i + (LNest qr lyt') <- chainRenameFilter r lyt + re <- vlUnboxRename q + renameOuter re $ VShape qr lyt' +last (VShape qs lyt) = do + i <- vlAggr AggrCount qs + (q, r, _) <- vlSelectPos qs (L.SBRelOp L.Eq) i + lyt' <- chainRenameFilter r lyt + return $ SShape q lyt' +last _ = $impossible + +index :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +index (VShape qs (LNest qi lyti)) (SShape i _) = do + one <- literal intT (VLInt 1) + i' <- vlBinExpr (L.SBNumOp L.Add) i one + -- Use the unboxing rename vector + (_, _, r) <- vlSelectPos qs (L.SBRelOp L.Eq) i' + (qu, ri) <- vlUnboxNested r qi + lyti' <- chainRenameFilter ri lyti + return $ VShape qu lyti' +index (VShape qs lyt) (SShape i _) = do + one <- literal intT (VLInt 1) + i' <- vlBinExpr (L.SBNumOp L.Add) i one + (q, r, _) <- vlSelectPos qs (L.SBRelOp L.Eq) i' + lyt' <- chainRenameFilter r lyt + return $ SShape q lyt' +index _ _ = $impossible + +append :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +append (VShape q1 lyt1) (VShape q2 lyt2) = do + -- Append the current vectors + (v, p1, p2) <- vlAppend q1 q2 + -- Propagate position changes to descriptors of any inner vectors + lyt1' <- renameOuterLyt p1 lyt1 + lyt2' <- renameOuterLyt p2 lyt2 + -- Append the layouts, i.e. actually append all inner vectors + lyt' <- appendLayout lyt1' lyt2' + return $ VShape v lyt' +appendVec _ _ = $impossible + +-- FIXME looks fishy, there should be an unboxing join. +the :: Shape VLDVec -> Build VL (Shape VLDVec) +the (VShape d lyt@(LNest _ _)) = do + (_, prop, _) <- vlSelectPos1 d (L.SBRelOp L.Eq) 1 + (LNest q' lyt') <- chainRenameFilter prop lyt + return $ VShape q' lyt' +the (VShape d lyt) = do + (q', prop, _) <- vlSelectPos1 d (L.SBRelOp L.Eq) 1 + lyt' <- chainRenameFilter prop lyt + return $ SShape q' lyt' +the _ = $impossible + +reverse :: Shape VLDVec -> Build VL (Shape VLDVec) +reverse (VShape d lyt) = do + (d', p) <- vlReverse d + lyt' <- chainReorder p lyt + return (VShape d' lyt') +reverse _ = $impossible + +tail :: Shape VLDVec -> Build VL (Shape VLDVec) +tail (VShape d lyt) = do + p <- literal intT (VLInt 1) + (q', r, _) <- vlSelectPos d (L.SBRelOp L.Gt) p + lyt' <- chainRenameFilter r lyt + return $ VShape q' lyt' +tail _ = $impossible + +sort :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +sort (VShape q1 lyt1) (VShape q2 lyt2) = do + let leftWidth = columnsInLayout lyt1 + rightWidth = columnsInLayout lyt2 + + sortExprs = map Column [leftWidth+1..leftWidth+rightWidth] + + -- Sort by all columns from the right vector + (sortedVec, propVec) <- vlSortS sortExprs =<< vlAlign q1 q2 + + -- After sorting, discard the sorting criteria columns from the + -- right vector + resVec <- vlProject (map Column [1..leftWidth]) sortedVec + lyt1' <- chainReorder propVec lyt1 + return $ VShape resVec lyt1' +sort _e1 _e2 = $impossible + +-- | The right input contains the grouping columns. +group :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +group (VShape q1 lyt1) (VShape q2 lyt2) = do + let leftWidth = columnsInLayout lyt1 + rightWidth = columnsInLayout lyt2 + + groupExprs = map Column [leftWidth+1..leftWidth+rightWidth] + + (outerVec, innerVec, propVec) <- vlGroupS groupExprs =<< vlAlign q1 q2 + + -- Discard the grouping columns in the inner vector + innerVec' <- vlProject (map Column [1..leftWidth]) innerVec + + lyt1' <- chainReorder propVec lyt1 + return $ VShape outerVec (LTuple [lyt2, LNest innerVec' lyt1']) +group _e1 _e2 = $impossible + +length_ :: Shape VLDVec -> Build VL (Shape VLDVec) +length_ (VShape q _) = do + v <- vlAggr AggrCount q + return $ SShape v (LCol 1) + +restrict :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +restrict(VShape q1 lyt) (VShape q2 (LCol 1)) = do + -- The right input vector has only one boolean column which + -- defines wether the tuple at the same position in the left input + -- is preserved. + let leftWidth = columnsInLayout lyt + predicate = Column $ leftWidth + 1 + + -- Filter the vector according to the boolean column + (filteredVec, renameVec) <- vlSelect predicate =<< vlAlign q1 q2 + + -- After the selection, discard the boolean column from the right + resVec <- vlProject (map Column [1..leftWidth]) filteredVec + + -- Filter any inner vectors + lyt' <- chainRenameFilter renameVec lyt + return $ VShape resVec lyt' +restrict _e1 _e2 = $impossible + +combine :: Shape VLDVec -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +combine (VShape qb (LCol 1)) (VShape q1 lyt1) (VShape q2 lyt2) = do + (v, p1, p2) <- vlCombine qb q1 q2 + lyt1' <- renameOuterLyt p1 lyt1 + lyt2' <- renameOuterLyt p2 lyt2 + lyt' <- appendLayout lyt1' lyt2' + return $ VShape v lyt' +combine l1 l2 l3 = trace (show l1 ++ " " ++ show l2 ++ " " ++ show l3) $ $impossible + +-- | Distribute a single value in vector 'q2' over an arbitrary shape. +-- FIXME accepting a scalar shape makes no sense here. we can only distribute over a list. +distSingleton :: Shape VLDVec -> VLDVec -> Layout VLDVec -> Build VL (Shape VLDVec) +distSingleton shape1 q2 lyt2 = do + let (shapeCon, q1, lyt1) = unwrapShape shape1 + + leftWidth = columnsInLayout lyt1 + rightWidth = columnsInLayout lyt2 + proj = map Column [leftWidth+1..leftWidth+rightWidth] + + (prodVec, _, propVec) <- q1 `vlCartProduct` q2 + resVec <- vlProject proj prodVec + + lyt' <- chainReorder propVec lyt2 + return $ shapeCon resVec lyt' + +dist :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +-- Distributing a single value is implemented using a cartesian +-- product. After the product, we discard columns from the vector that +-- we distributed over. Vectors are swapped because CartProduct uses +-- the descriptor of its left input and that is what we want. +dist (SShape q lyt) v = distSingleton v q lyt +dist (VShape q lyt) (VShape qo lyto) = do + let leftWidth = columnsInLayout lyto + rightWidth = columnsInLayout lyt + innerProj = map Column [leftWidth+1..leftWidth+rightWidth] + + (prodVec, _, propVec) <- vlNestProduct qo q + innerVec <- vlProject innerProj prodVec + + -- The outer vector does not have columns, it only describes the + -- shape. + outerVec <- vlProject [] qo + + -- Replicate any inner vectors + lyt' <- chainReorder propVec lyt + + return $ VShape outerVec (LNest innerVec lyt') +dist _ _ = $impossible + +aggr :: (Expr -> AggrFun) -> Shape VLDVec -> Build VL (Shape VLDVec) +aggr afun (VShape q (LCol 1)) = + SShape <$> vlAggr (afun (Column 1)) q <*> (pure $ LCol 1) +aggr _ _ = $impossible + +ifList :: Shape VLDVec -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +ifList (SShape qb lytb) (VShape q1 lyt1) (VShape q2 lyt2) = do + let leftWidth = columnsInLayout lyt1 + predicate = Column $ leftWidth + 1 + + VShape trueSelVec _ <- distSingleton (VShape q1 lyt1) qb lytb + (trueVec, trueRenameVec) <- vlSelect predicate + =<< vlAlign q1 trueSelVec + trueVec' <- vlProject (map Column [1..leftWidth]) trueVec + + let predicate' = UnApp (L.SUBoolOp L.Not) predicate + + VShape falseSelVec _ <- distSingleton (VShape q2 lyt2) qb lytb + (falseVec, falseRenameVec) <- vlSelect predicate' + =<< vlAlign q2 falseSelVec + falseVec' <- vlProject (map Column [1..leftWidth]) falseVec + + lyt1' <- renameOuterLyt trueRenameVec lyt1 + lyt2' <- renameOuterLyt falseRenameVec lyt2 + lyt' <- appendLayout lyt1' lyt2' + + (bothBranches, _, _) <- vlAppend trueVec' falseVec' + + return $ VShape bothBranches lyt' +ifList qb (SShape q1 lyt1) (SShape q2 lyt2) = do + (VShape q lyt) <- ifList qb (VShape q1 lyt1) (VShape q2 lyt2) + return $ SShape q lyt +ifList _ _ _ = $impossible + +tuple :: [Shape VLDVec] -> Build VL (Shape VLDVec) +tuple shapes@(_ : _) = do + (q, lyts) <- tupleVectors shapes + let lyts' = zipLayouts lyts + return $ SShape q (LTuple lyts') +tuple _ = $impossible + +tupElem :: TupleIndex -> Shape VLDVec -> Build VL (Shape VLDVec) +tupElem i (SShape q (LTuple lyts)) = + case lyts !! (tupleIndex i - 1) of + LNest qi lyt -> return $ VShape qi lyt + lyt -> do + let (lyt', cols) = projectFromPos lyt + proj <- vlProject (map Column cols) q + return $ SShape proj lyt' +tupElem _ _ = $impossible + +transpose :: Shape VLDVec -> Build VL (Shape VLDVec) +transpose (VShape _ (LNest qi lyt)) = do + (qo', qi') <- vlTranspose qi + return $ VShape qo' (LNest qi' lyt) +transpose _ = $impossible + + +reshape :: Integer -> Shape VLDVec -> Build VL (Shape VLDVec) +reshape n (VShape q lyt) = do + (qo, qi) <- vlReshape n q + return $ VShape qo (LNest qi lyt) +reshape _ _ = $impossible + +concat :: Shape VLDVec -> Build VL (Shape VLDVec) +concat (VShape _ (LNest q lyt)) = VShape <$> vlUnsegment q <*> pure lyt +concat _e = $impossible + +-------------------------------------------------------------------------------- +-- Construction of lifted primitives + +restrictL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +restrictL (VShape qo (LNest qi lyt)) (VShape _ (LNest qb (LCol 1))) = do + VShape qi' lyt' <- restrict (VShape qi lyt) (VShape qb (LCol 1)) + return $ VShape qo (LNest qi' lyt') +restrictL l1 l2 = + trace (show l1 ++ " " ++ show l2) $ $impossible + +combineL :: Shape VLDVec -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +combineL (VShape qo (LNest qb (LCol 1))) + (VShape _ (LNest qi1 lyt1)) + (VShape _ (LNest qi2 lyt2)) = do + VShape qi' lyt' <- combine (VShape qb (LCol 1)) (VShape qi1 lyt1) (VShape qi2 lyt2) + return $ VShape qo (LNest qi' lyt') +combineL _ _ _ = $impossible + +zipL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +zipL (VShape d1 (LNest q1 lyt1)) (VShape _ (LNest q2 lyt2)) = do + (q', r1, r2) <- vlZipS q1 q2 + lyt1' <- chainRenameFilter r1 lyt1 + lyt2' <- chainRenameFilter r2 lyt2 + return $ VShape d1 (LNest q' $ zipLayout lyt1' lyt2') +zipL _ _ = $impossible + +cartProductL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +cartProductL (VShape d1 (LNest q1 lyt1)) (VShape _ (LNest q2 lyt2)) = do + (q', p1, p2) <- vlCartProductS q1 q2 + lyt1' <- chainReorder p1 lyt1 + lyt2' <- chainReorder p2 lyt2 + return $ VShape d1 (LNest q' $ zipLayout lyt1' lyt2') +cartProductL _ _ = $impossible + +nestProductL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +nestProductL (VShape qd1 (LNest qv1 lyt1)) (VShape _qd2 (LNest qv2 lyt2)) = do + (qj, qp2) <- vlNestProductS qv1 qv2 + lyt2' <- chainReorder qp2 lyt2 + let lytJ = zipLayout lyt1 lyt2' + return $ VShape qd1 (LNest qv1 (LTuple [lyt1, (LNest qj lytJ)])) +nestProductL _ _ = $impossible + +thetaJoinL :: L.JoinPredicate L.JoinExpr -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +thetaJoinL joinPred (VShape d1 (LNest q1 lyt1)) (VShape _ (LNest q2 lyt2)) = do + (q', p1, p2) <- vlThetaJoinS joinPred q1 q2 + lyt1' <- chainReorder p1 lyt1 + lyt2' <- chainReorder p2 lyt2 + return $ VShape d1 (LNest q' $ zipLayout lyt1' lyt2') +thetaJoinL _ _ _ = $impossible + +-- △^L :: [[a]] -> [[b]] -> [[(a, [(a, b)])]] + +-- For the unlifted nestjoin, we could segment the left (outer) input +-- and then use the regular thetajoin implementation. This trick does +-- not work here, as the lifted thetajoin joins on the +-- descriptors. Therefore, we have to 'segment' **after** the join, +-- i.e. use the left input positions as descriptors +nestJoinL :: L.JoinPredicate L.JoinExpr -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +nestJoinL joinPred (VShape qd1 (LNest qv1 lyt1)) (VShape _qd2 (LNest qv2 lyt2)) = do + (qj, qp2) <- vlNestJoinS joinPred qv1 qv2 + lyt2' <- chainReorder qp2 lyt2 + let lytJ = zipLayout lyt1 lyt2' + return $ VShape qd1 (LNest qv1 (LTuple [lyt1,(LNest qj lytJ)])) +nestJoinL _ _ _ = $impossible + +semiJoinL :: L.JoinPredicate L.JoinExpr -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +semiJoinL joinPred (VShape d1 (LNest q1 lyt1)) (VShape _ (LNest q2 _)) = do + (qj, r) <- vlSemiJoinS joinPred q1 q2 + lyt1' <- chainRenameFilter r lyt1 + return $ VShape d1 (LNest qj lyt1') +semiJoinL _ _ _ = $impossible + +antiJoinL :: L.JoinPredicate L.JoinExpr -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +antiJoinL joinPred (VShape d1 (LNest q1 lyt1)) (VShape _ (LNest q2 _)) = do + (qj, r) <- vlAntiJoinS joinPred q1 q2 + lyt1' <- chainRenameFilter r lyt1 + return $ VShape d1 (LNest qj lyt1') +antiJoinL _ _ _ = $impossible + + + +nubL :: Shape VLDVec -> Build VL (Shape VLDVec) +nubL (VShape d (LNest q lyt)) = VShape d <$> (LNest <$> vlUniqueS q <*> pure lyt) +nubL _ = $impossible + +numberL :: Shape VLDVec -> Build VL (Shape VLDVec) +numberL (VShape d (LNest q lyt)) = + VShape d <$> (LNest <$> vlNumberS q + <*> (pure $ zipLayout lyt (LCol 1))) +numberL _ = $impossible + +initL :: Shape VLDVec -> Build VL (Shape VLDVec) +initL (VShape qs (LNest q lyt)) = do + is <- vlAggrS AggrCount qs q + (q', r, _) <- vlSelectPosS q (L.SBRelOp L.Lt) is + lyt' <- chainRenameFilter r lyt + return $ VShape qs (LNest q' lyt') +initL _ = $impossible + +lastL :: Shape VLDVec -> Build VL (Shape VLDVec) +lastL (VShape d (LNest qs lyt@(LNest _ _))) = do + is <- vlAggrS AggrCount d qs + (qs', r, _) <- vlSelectPosS qs (L.SBRelOp L.Eq) is + lyt' <- chainRenameFilter r lyt + re <- vlUnboxRename qs' + VShape d <$> renameOuterLyt re lyt' +lastL (VShape d (LNest qs lyt)) = do + is <- vlAggrS AggrCount d qs + (qs', r, _) <- vlSelectPosS qs (L.SBRelOp L.Eq) is + lyt' <- chainRenameFilter r lyt + re <- vlUnboxRename d + renameOuter re (VShape qs' lyt') +lastL _ = $impossible + +indexL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +indexL (VShape d (LNest qs (LNest qi lyti))) (VShape idxs (LCol 1)) = do + idxs' <- vlProject [BinApp (L.SBNumOp L.Add) (Column 1) (Constant $ VLInt 1)] idxs + (_, _, u) <- vlSelectPosS qs (L.SBRelOp L.Eq) idxs' + (qu, ri) <- vlUnboxNested u qi + lyti' <- chainRenameFilter ri lyti + return $ VShape d (LNest qu lyti') +indexL (VShape d (LNest qs lyt)) (VShape idxs (LCol 1)) = do + idxs' <- vlProject [BinApp (L.SBNumOp L.Add) (Column 1) (Constant $ VLInt 1)] idxs + (qs', r, _) <- vlSelectPosS qs (L.SBRelOp L.Eq) idxs' + lyt' <- chainRenameFilter r lyt + re <- vlUnboxRename d + renameOuter re (VShape qs' lyt') +indexL _ _ = $impossible + +appendL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +appendL (VShape d lyt1) (VShape _ lyt2) = do + VShape d <$> appendLayout lyt1 lyt2 +appendL _ _ = $impossible + +reverseL :: Shape VLDVec -> Build VL (Shape VLDVec) +reverseL (VShape d (LNest d1 lyt)) = do + (d1', p) <- vlReverseS d1 + lyt' <- chainReorder p lyt + return (VShape d (LNest d1' lyt')) +reverseL _ = $impossible + +theL :: Shape VLDVec -> Build VL (Shape VLDVec) +theL (VShape d (LNest q lyt)) = do + (v, p2, _) <- vlSelectPos1S q (L.SBRelOp L.Eq) 1 + prop <- vlUnboxRename d + lyt' <- chainRenameFilter p2 lyt + v' <- vlPropRename prop v + return $ VShape v' lyt' +theL _ = $impossible + +tailL :: Shape VLDVec -> Build VL (Shape VLDVec) +tailL (VShape d (LNest q lyt)) = do + p <- vlProject [Constant $ VLInt 1] d + (v, p2, _) <- vlSelectPosS q (L.SBRelOp L.Gt) p + lyt' <- chainRenameFilter p2 lyt + return $ VShape d (LNest v lyt') +tailL _ = $impossible + +sortL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +sortL (VShape _ (LNest v1 lyt1)) (VShape d2 (LNest v2 lyt2)) = do + VShape innerVec lyt <- sort (VShape v1 lyt1) (VShape v2 lyt2) + return $ VShape d2 (LNest innerVec lyt) +sortL _ _ = $impossible + +groupL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +groupL (VShape _ (LNest v1 lyt1)) (VShape d2 (LNest v2 lyt2)) = do + let flatRes = group (VShape v1 lyt1) (VShape v2 lyt2) + (VShape middleVec (LTuple [groupLyt, LNest innerVec innerLyt])) <- flatRes + return $ VShape d2 (LNest middleVec (LTuple [groupLyt, LNest innerVec innerLyt])) +groupL _ _ = $impossible + +concatL :: Shape VLDVec -> Build VL (Shape VLDVec) +concatL (VShape d (LNest d' vs)) = do + p <- vlUnboxRename d' + vs' <- renameOuterLyt p vs + return $ VShape d vs' +concatL _ = $impossible + +lengthL :: Shape VLDVec -> Build VL (Shape VLDVec) +lengthL (VShape q (LNest qi _)) = do + ls <- vlAggrS AggrCount q qi + lsu <- vlUnboxScalar q ls + return $ VShape lsu (LCol 1) +lengthL s = trace (show s) $ $impossible + +outer :: Shape VLDVec -> Build VL VLDVec +outer (SShape _ _) = $impossible +outer (VShape q _) = return q + +aggrL :: (Expr -> AggrFun) -> Shape VLDVec -> Build VL (Shape VLDVec) +aggrL afun (VShape d (LNest q (LCol 1))) = do + qr <- vlAggrS (afun (Column 1)) d q + qu <- vlUnboxScalar d qr + return $ VShape qu (LCol 1) +aggrL _ _ = $impossible + +distL :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +distL (VShape q1 lyt1) (VShape d (LNest q2 lyt2)) = do + (qa, p) <- vlDistLift q1 q2 + lyt1' <- chainReorder p lyt1 + let lyt = zipLayout lyt1' lyt2 + VShape qf lytf <- tupElemL First $ VShape qa lyt + return $ VShape d (LNest qf lytf) +distL _e1 _e2 = $impossible + +tupleL :: [Shape VLDVec] -> Build VL (Shape VLDVec) +tupleL shapes@(_ : _) = do + (q, lyts) <- zipVectors shapes + let lyts' = zipLayouts lyts + return $ VShape q (LTuple lyts') +tupleL _ = $impossible + +tupElemL :: TupleIndex -> Shape VLDVec -> Build VL (Shape VLDVec) +tupElemL i (VShape q (LTuple lyts)) = do + let (lyt', cols) = projectFromPos $ lyts !! (tupleIndex i - 1) + proj <- vlProject (map Column cols) q + return $ VShape proj lyt' +tupElemL i s = trace (show i ++ " " ++ show s) $impossible + +transposeL :: Shape VLDVec -> Build VL (Shape VLDVec) +transposeL (VShape qo (LNest qm (LNest qi lyt))) = do + (qm', qi') <- vlTransposeS qm qi + return $ VShape qo (LNest qm' (LNest qi' lyt)) +transposeL _ = $impossible + +reshapeL :: Integer -> Shape VLDVec -> Build VL (Shape VLDVec) +reshapeL n (VShape qo (LNest qi lyt)) = do + (qm, qi') <- vlReshapeS n qi + return $ VShape qo (LNest qm (LNest qi' lyt)) +reshapeL _ _ = $impossible + +-- | Create a projection list that extracts only those columns +-- referenced in the sub-layout passed as argument, and shift column +-- names in the sub-layout to the beginning. +projectFromPos :: Layout VLDVec -> (Layout VLDVec , [DBCol]) +projectFromPos = (\(x,y,_) -> (x,y)) . (projectFromPosWork 1) + where + projectFromPosWork :: Int -> Layout VLDVec -> (Layout VLDVec, [DBCol], Int) + projectFromPosWork c (LCol i) = (LCol c, [i], c + 1) + projectFromPosWork c (LNest q l) = (LNest q l, [], c) + projectFromPosWork c (LTuple lyts) = (LTuple psRes, colsRes, cRes) + where + (psRes, colsRes, cRes) = List.foldl' tupleWorker ([], [], c) lyts + + tupleWorker (psAcc, colsAcc, cAcc) lyt = (psAcc ++ [lyt'], colsAcc ++ cols, c') + where + (lyt', cols, c') = projectFromPosWork cAcc lyt + +singleton :: Shape VLDVec -> Build VL (Shape VLDVec) +singleton (VShape q lyt) = do + VLDVec d <- vlSingletonDescr + return $ VShape (VLDVec d) (LNest q lyt) +singleton (SShape q1 lyt) = return $ VShape q1 lyt + +singletonL :: Shape VLDVec -> Build VL (Shape VLDVec) +singletonL (VShape q lyt) = do + innerVec <- vlSegment q + outerVec <- vlProject [] q + return $ VShape outerVec (LNest innerVec lyt) +singletonL _ = $impossible + +-------------------------------------------------------------------------------- +-- Construction of base tables and literal tables + +-- | Create a VL reference to a base table. +dbTable :: String -> [L.Column] -> L.TableHints -> Build VL (Shape VLDVec) +dbTable n cs ks = do + t <- vlTableRef n (map (mapSnd typeToScalarType) cs) ks + return $ VShape t (LTuple [LCol i | i <- [1..length cs]]) + +-- | Create a VL representation of a literal value. +mkLiteral :: Type -> L.Val -> Build VL (Shape VLDVec) +-- Translate an outer list +mkLiteral t@(ListT _) (L.ListV es) = do + ((tabTys, tabCols), lyt, _) <- toPlan (mkDescriptor [P.length es]) t 1 es + let emptinessFlag = case es of + [] -> L.PossiblyEmpty + _ : _ -> L.NonEmpty + litNode <- vlLit emptinessFlag (P.reverse tabTys) $ map P.reverse tabCols + return $ VShape litNode lyt +-- Translate a non-list value, i.e. scalar or tuple +mkLiteral t e = do + -- There is only one element in the outermost vector + ((tabTys, [tabCols]), layout, _) <- toPlan (mkDescriptor [1]) (ListT t) 1 [e] + litNode <- vlLit L.NonEmpty (P.reverse tabTys) [(P.reverse tabCols)] + return $ SShape litNode layout + +type Table = ([Type], [[VLVal]]) + +-- | Add values to a vector. If necessary (i.e. inner lists are +-- encountered), create new inner vectors. 'toPlan' receives a +-- descriptor that has enough space for all elements of the list that +-- are currently encoded. + +-- FIXME Check if inner list literals are nonempty and flag VL +-- literals appropriately. +toPlan :: Table -> Type -> Int -> [L.Val] -> Build VL (Table, Layout VLDVec, Int) +toPlan (tabTys, tabCols) (ListT t) nextCol es = + -- Inspect the element type of the list to be encoded + case t of + ListT _ -> do + let vs = map listElems es + -- Create a vector with one entry for each element of an inner list + d = mkDescriptor $ map P.length vs + -- Add the inner list elements to the vector + ((innerTabTys, innerTabCols), lyt, _) <- toPlan d t 1 (P.concat vs) + n <- vlLit L.PossiblyEmpty (P.reverse innerTabTys) (map P.reverse innerTabCols) + return ((tabTys, tabCols), LNest n lyt, nextCol) + + TupleT elemTys -> do + -- We add tuple elements column-wise. If the list to be + -- encoded is empty, create an empty list for each column. + let colsVals = case es of + [] -> map (const []) elemTys + _ -> List.transpose $ map tupleElems es + mkTupleTable (tabTys, tabCols) nextCol [] colsVals elemTys + + _ -> let (hd, vs) = mkColumn t es + in return ((hd:tabTys, zipWith (:) vs tabCols), (LCol nextCol), nextCol + 1) + +toPlan (tabTys, tabCols) t c v = + let (hd, v') = mkColumn t v + in return $ ((hd:tabTys, zipWith (:) v' tabCols), (LCol c), c + 1) + +-- | Construct the literal table for a list of tuples. +mkTupleTable :: Table -- ^ The literal table so far. + -> Int -- ^ The next available column offset + -> [Layout VLDVec] -- ^ The layouts of the tuple elements constructed so far + -> [[L.Val]] -- ^ Values for the tuple elements + -> [Type] -- ^ Types for the tuple elements + -> Build VL (Table, Layout VLDVec, Int) +mkTupleTable tab nextCol lyts (colVals : colsVals) (t : ts) = do + (tab', lyt, nextCol') <- toPlan tab (ListT t) nextCol colVals + mkTupleTable tab' nextCol' (lyt : lyts) colsVals ts +mkTupleTable tab nextCol lyts [] [] = do + return $ (tab, LTuple $ P.reverse lyts, nextCol) +mkTupleTable _ _ _ _ _ = $impossible + +literal :: Type -> VLVal -> Build VL VLDVec +literal t v = vlLit L.NonEmpty [t] [[VLInt 1, VLInt 1, v]] + +listElems :: L.Val -> [L.Val] +listElems (L.ListV es) = es +listElems _ = $impossible + +tupleElems :: L.Val -> [L.Val] +tupleElems (L.TupleV es) = es +tupleElems _ = $impossible + +mkColumn :: Type -> [L.Val] -> (Type, [VLVal]) +mkColumn t vs = (t, [pVal v | v <- vs]) + +mkDescriptor :: [Int] -> Table +mkDescriptor lengths = + let header = [] + body = [ [VLInt $ fromInteger p, VLInt $ fromInteger d] + | d <- P.concat [ replicate l p | p <- [1..] | l <- lengths ] + | p <- [1..] + ] + in (header, body) + +-------------------------------------------------------------------------------- +-- Helper functions for zipping/tuple construction + +zipLayout :: Layout VLDVec -> Layout VLDVec -> Layout VLDVec +zipLayout l1 l2 = let offSet = columnsInLayout l1 + l2' = incrementPositions offSet l2 + in LTuple [l1, l2'] + +incrementPositions :: Int -> Layout VLDVec -> Layout VLDVec +incrementPositions i (LCol n) = LCol $ n + i +incrementPositions _i v@(LNest _ _) = v +incrementPositions i (LTuple lyts) = LTuple $ map (incrementPositions i) lyts + +zipLayouts :: [Layout VLDVec] -> [Layout VLDVec] +zipLayouts layouts = go 0 layouts + + where + go :: Int -> [Layout VLDVec] -> [Layout VLDVec] + go 0 (lyt : lyts) = lyt : go (columnsInLayout lyt) lyts + go o (lyt : lyts) = incrementPositions o lyt : go (o + columnsInLayout lyt) lyts + go _ [] = [] + +zipVectors :: [Shape VLDVec] -> Build VL (VLDVec, [Layout VLDVec]) +zipVectors (VShape q1 lyt1 : []) = return (q1, [lyt1]) +zipVectors (VShape q1 lyt1 : shapes) = do + (q, lyts) <- zipVectors shapes + qz' <- vlAlign q1 q + return (qz', lyt1 : lyts) +zipVectors _ = $impossible + +tupleVectors :: [Shape VLDVec] -> Build VL (VLDVec, [Layout VLDVec]) +tupleVectors (SShape q1 lyt1 : []) = return (q1, [lyt1]) +tupleVectors (VShape q1 lyt1 : []) = do + qo <- vlSingletonDescr + qi <- vlUnsegment q1 + return (qo, [LNest qi lyt1]) +tupleVectors (SShape q1 lyt1 : shapes) = do + (q, lyts) <- tupleVectors shapes + qz' <- vlAlign q1 q + return (qz', lyt1 : lyts) +tupleVectors (VShape q1 lyt1 : shapes) = do + (q, lyts) <- tupleVectors shapes + q1' <- vlUnsegment q1 + return (q, LNest q1' lyt1 : lyts) +tupleVectors s = error $ show s + +-------------------------------------------------------------------------------- +-- Compile-time operations that implement higher-lifted primitives. + +-- | Remove the 'n' outer layers of nesting from a nested list +-- (Prins/Palmer: 'extract'). +forget :: Nat -> Shape VLDVec -> Shape VLDVec +forget Zero _ = $impossible +forget (Succ Zero) (VShape _ (LNest q lyt)) = VShape q lyt +forget (Succ n) (VShape _ lyt) = extractInnerVec n lyt +forget _ _ = $impossible + +extractInnerVec :: Nat -> Layout VLDVec -> Shape VLDVec +extractInnerVec (Succ Zero) (LNest _ (LNest q lyt)) = VShape q lyt +extractInnerVec (Succ n) (LNest _ lyt) = extractInnerVec n lyt +extractInnerVec n l = trace (show n ++ " " ++ show l) $impossible + +-- | Prepend the 'n' outer layers of nesting from the first input to +-- the second input (Prins/Palmer: 'insert'). +imprint :: Nat -> Shape VLDVec -> Shape VLDVec -> Shape VLDVec +imprint (Succ Zero) (VShape d _) (VShape vi lyti) = + VShape d (LNest vi lyti) +imprint (Succ n) (VShape d lyt) (VShape vi lyti) = + VShape d (implantInnerVec n lyt vi lyti) +imprint _ _ _ = + $impossible + +implantInnerVec :: Nat -> Layout VLDVec -> VLDVec -> Layout VLDVec -> Layout VLDVec +implantInnerVec (Succ Zero) (LNest d _) vi lyti = + LNest d $ LNest vi lyti +implantInnerVec (Succ n) (LNest d lyt) vi lyti = + LNest d $ implantInnerVec n lyt vi lyti +implantInnerVec _ _ _ _ = + $impossible + +-------------------------------------------------------------------------------- +-- Vectorization Helper Functions + +-- | Take a shape apart by extracting the vector, the layout and the +-- shape constructor itself. +unwrapShape :: Shape VLDVec -> (VLDVec -> Layout VLDVec -> Shape VLDVec, VLDVec, Layout VLDVec) +unwrapShape (VShape q lyt) = (VShape, q, lyt) +unwrapShape (SShape q lyt) = (SShape, q, lyt) + +fromLayout :: Layout VLDVec -> [DBCol] +fromLayout (LCol i) = [i] +fromLayout (LNest _ _) = [] +fromLayout (LTuple lyts) = concatMap fromLayout lyts + +-- | chainRenameFilter renames and filters a vector according to a rename vector +-- and propagates these changes to all inner vectors. No reordering is applied, +-- that is the propagation vector must not change the order of tuples. +chainRenameFilter :: RVec -> Layout VLDVec -> Build VL (Layout VLDVec) +chainRenameFilter _ l@(LCol _) = return l +chainRenameFilter r (LNest q lyt) = do + (q', r') <- vlPropFilter r q + lyt' <- chainRenameFilter r' lyt + return $ LNest q' lyt' +chainRenameFilter r (LTuple lyts) = + LTuple <$> mapM (chainRenameFilter r) lyts + +-- | chainReorder renames and filters a vector according to a propagation vector +-- and propagates these changes to all inner vectors. The propagation vector +-- may change the order of tuples. +chainReorder :: PVec -> Layout VLDVec -> Build VL (Layout VLDVec) +chainReorder _ l@(LCol _) = return l +chainReorder p (LNest q lyt) = do + (q', p') <- vlPropReorder p q + lyt' <- chainReorder p' lyt + return $ LNest q' lyt' +chainReorder p (LTuple lyts) = + LTuple <$> mapM (chainReorder p) lyts + +-- | renameOuter renames and filters a vector according to a rename +-- vector. Changes are not propagated to inner vectors. +renameOuter :: RVec -> Shape VLDVec -> Build VL (Shape VLDVec) +renameOuter p (VShape q lyt) = flip VShape lyt <$> vlPropRename p q +renameOuter _ _ = error "renameOuter: Not possible" + +renameOuterLyt :: RVec -> Layout VLDVec -> Build VL (Layout VLDVec) +renameOuterLyt _ l@(LCol _) = return l +renameOuterLyt r (LNest q lyt) = flip LNest lyt <$> vlPropRename r q +renameOuterLyt r (LTuple lyts) = LTuple <$> mapM (renameOuterLyt r) lyts + +-- | Append two inner vectors (segment-wise). +appendInnerVec :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec) +appendInnerVec (VShape q1 lyt1) (VShape q2 lyt2) = do + -- Append the current vectors + (v, p1, p2) <- vlAppendS q1 q2 + -- Propagate position changes to descriptors of any inner vectors + lyt1' <- renameOuterLyt p1 lyt1 + lyt2' <- renameOuterLyt p2 lyt2 + -- Append the layouts, i.e. actually append all inner vectors + lyt' <- appendLayout lyt1' lyt2' + return $ VShape v lyt' +appendInnerVec _ _ = $impossible + +-- | Traverse a layout and append all nested vectors that are +-- encountered. +appendLayout :: Layout VLDVec -> Layout VLDVec -> Build VL (Layout VLDVec) +appendLayout (LCol i1) (LCol i2) + | i1 == i2 = return $ LCol i1 + | otherwise = error "appendR': Incompatible vectors" +-- Append two nested vectors +appendLayout (LNest q1 lyt1) (LNest q2 lyt2) = do + a <- appendInnerVec (VShape q1 lyt1) (VShape q2 lyt2) + case a of + VShape q lyt -> return $ LNest q lyt + _ -> $impossible +appendLayout (LTuple lyts1) (LTuple lyts2) = + LTuple <$> (sequence $ zipWith appendLayout lyts1 lyts2) +appendLayout _ _ = $impossible diff --git a/tests/CombinatorTests.hs b/tests/CombinatorTests.hs new file mode 100644 --- /dev/null +++ b/tests/CombinatorTests.hs @@ -0,0 +1,1241 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} + +module CombinatorTests + ( tests_types + , tests_boolean + , tests_tuples + , tests_numerics + , tests_maybe + , tests_either + , tests_lists + , tests_lifted + , tests_combinators_hunit + ) where + +import Common + +import qualified Database.DSH as Q + +import Test.QuickCheck +import Test.HUnit(Assertion) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit +-- import Data.DeriveTH + +import Data.Char +import Data.Text (Text) +import qualified Data.Text as Text + +import Data.List +import Data.Maybe +import Data.Either +import GHC.Exts + +{- +data D0 = C01 deriving (Eq,Ord,Show) + +derive makeArbitrary ''D0 +Q.deriveDSH ''D0 + +data D1 a = C11 a deriving (Eq,Ord,Show) + +derive makeArbitrary ''D1 +Q.deriveDSH ''D1 + +data D2 a b = C21 a b b a deriving (Eq,Ord,Show) + +derive makeArbitrary ''D2 +Q.deriveDSH ''D2 + +data D3 = C31 + | C32 + deriving (Eq,Ord,Show) + +derive makeArbitrary ''D3 +Q.deriveDSH ''D3 + +data D4 a = C41 a + | C42 + deriving (Eq,Ord,Show) + +derive makeArbitrary ''D4 +Q.deriveDSH ''D4 + +data D5 a = C51 a + | C52 + | C53 a a + | C54 a a a + deriving (Eq,Ord,Show) + +derive makeArbitrary ''D5 +Q.deriveDSH ''D5 + +data D6 a b c d e = C61 { c611 :: a, c612 :: (a,b,c,d) } + | C62 + | C63 a b + | C64 (a,b,c) + | C65 a b c d e + deriving (Eq,Ord,Show) + +derive makeArbitrary ''D6 +Q.deriveDSH ''D6 + +-} + +tests_types :: Test +tests_types = testGroup "Supported Types" + [ testProperty "()" $ prop_unit + , testProperty "Bool" $ prop_bool + , testProperty "Char" $ prop_char + , testProperty "Text" $ prop_text + , testProperty "Integer" $ prop_integer + , testProperty "Double" $ prop_double + , testProperty "[Integer]" $ prop_list_integer_1 + , testProperty "[[Integer]]" $ prop_list_integer_2 + , testProperty "[[[Integer]]]" $ prop_list_integer_3 + , testProperty "[(Integer, Integer)]" $ prop_list_tuple_integer + , testProperty "([], [])" $ prop_tuple_list_integer + , testProperty "(,[])" $ prop_tuple_integer_list + , testProperty "(,[],)" $ prop_tuple_integer_list_integer + , testProperty "Maybe Integer" $ prop_maybe_integer + , testProperty "Either Integer Integer" $ prop_either_integer + , testProperty "(Int, Int, Int, Int)" $ prop_tuple4 + , testProperty "(Int, Int, Int, Int, Int)" $ prop_tuple5 +{- + , testProperty "D0" $ prop_d0 + , testProperty "D1" $ prop_d1 + , testProperty "D2" $ prop_d2 + , testProperty "D3" $ prop_d3 + , testProperty "D4" $ prop_d4 + , testProperty "D5" $ prop_d5 + , testProperty "D6" $ prop_d6 +-} + ] + +tests_boolean :: Test +tests_boolean = testGroup "Equality, Boolean Logic and Ordering" + [ testProperty "&&" $ prop_infix_and + , testProperty "||" $ prop_infix_or + , testProperty "not" $ prop_not + , testProperty "eq" $ prop_eq + , testProperty "neq" $ prop_neq + , testProperty "cond" $ prop_cond + , testProperty "cond tuples" $ prop_cond_tuples + , testProperty "cond ([[Integer]], [[Integer]])" $ prop_cond_list_tuples + , testProperty "lt" $ prop_lt + , testProperty "lte" $ prop_lte + , testProperty "gt" $ prop_gt + , testProperty "gte" $ prop_gte + , testProperty "min_integer" $ prop_min_integer + , testProperty "min_double" $ prop_min_double + , testProperty "max_integer" $ prop_max_integer + , testProperty "max_double" $ prop_max_double + ] + +tests_tuples :: Test +tests_tuples = testGroup "Tuples" + [ testProperty "fst" $ prop_fst + , testProperty "snd" $ prop_snd + , testProperty "fst ([], [])" prop_fst_nested + , testProperty "snd ([], [])" prop_snd_nested + , testProperty "tup3_1" prop_tup3_1 + , testProperty "tup3_2" prop_tup3_2 + , testProperty "tup3_3" prop_tup3_3 + , testProperty "tup4_2" prop_tup4_2 + , testProperty "tup4_4" prop_tup4_4 + , testProperty "tup3_nested" prop_tup3_nested + , testProperty "tup4_tup3" prop_tup4_tup3 + ] + +tests_numerics :: Test +tests_numerics = testGroup "Numerics" + [ testProperty "add_integer" $ prop_add_integer + , testProperty "add_double" $ prop_add_double + , testProperty "mul_integer" $ prop_mul_integer + , testProperty "mul_double" $ prop_mul_double + , testProperty "div_double" $ prop_div_double + , testProperty "integer_to_double" $ prop_integer_to_double + , testProperty "integer_to_double_+" $ prop_integer_to_double_arith + , testProperty "abs_integer" $ prop_abs_integer + , testProperty "abs_double" $ prop_abs_double + , testProperty "signum_integer" $ prop_signum_integer + , testProperty "signum_double" $ prop_signum_double + , testProperty "negate_integer" $ prop_negate_integer + , testProperty "negate_double" $ prop_negate_double + , testProperty "trig_sin" $ prop_trig_sin + , testProperty "trig_cos" $ prop_trig_cos + , testProperty "trig_tan" $ prop_trig_tan + , testProperty "trig_asin" $ prop_trig_asin + , testProperty "trig_acos" $ prop_trig_acos + , testProperty "trig_atan" $ prop_trig_atan + , testProperty "sqrt" $ prop_sqrt + , testProperty "log" $ prop_log + , testProperty "exp" $ prop_exp + ] + +tests_maybe :: Test +tests_maybe = testGroup "Maybe" + [ testProperty "maybe" $ prop_maybe + , testProperty "just" $ prop_just + , testProperty "isJust" $ prop_isJust + , testProperty "isNothing" $ prop_isNothing + , testProperty "fromJust" $ prop_fromJust + , testProperty "fromMaybe" $ prop_fromMaybe + , testProperty "listToMaybe" $ prop_listToMaybe + , testProperty "maybeToList" $ prop_maybeToList + , testProperty "catMaybes" $ prop_catMaybes + , testProperty "mapMaybe" $ prop_mapMaybe + ] + +tests_either :: Test +tests_either = testGroup "Either" + [ testProperty "left" $ prop_left + , testProperty "right" $ prop_right + , testProperty "isLeft" $ prop_isLeft + , testProperty "isRight" $ prop_isRight + , testProperty "either" $ prop_either + , testProperty "lefts" $ prop_lefts + , testProperty "rights" $ prop_rights + , testProperty "partitionEithers" $ prop_partitionEithers + ] + +tests_lists :: Test +tests_lists = testGroup "Lists" + [ testProperty "singleton" prop_singleton + , testProperty "head" $ prop_head + , testProperty "tail" $ prop_tail + , testProperty "cons" $ prop_cons + , testProperty "snoc" $ prop_snoc + , testProperty "take" $ prop_take + , testProperty "drop" $ prop_drop + , testProperty "take ++ drop" $ prop_takedrop + , testProperty "map" $ prop_map + , testProperty "filter" $ prop_filter + , testProperty "filter > 42" $ prop_filter_gt + , testProperty "filter > 42 (,[])" $ prop_filter_gt_nested + , testProperty "the" $ prop_the + , testProperty "last" $ prop_last + , testProperty "init" $ prop_init + , testProperty "null" $ prop_null + , testProperty "length" $ prop_length + , testProperty "length tuple list" $ prop_length_tuple + , testProperty "index [Integer]" $ prop_index + , testProperty "index [(Integer, [Integer])]" $ prop_index_pair + , testProperty "index [[]]" $ prop_index_nest + , testProperty "reverse" $ prop_reverse + , testProperty "reverse [[]]" $ prop_reverse_nest + , testProperty "append" $ prop_append + , testProperty "append nest" $ prop_append_nest + , testProperty "groupWith" $ prop_groupWith + , testProperty "groupWithKey" $ prop_groupWithKey + , testProperty "groupWith length" $ prop_groupWith_length + , testProperty "groupWithKey length" $ prop_groupWithKey_length + , testProperty "sortWith" $ prop_sortWith + , testProperty "sortWith [(,)]" $ prop_sortWith_pair + , testProperty "sortWith [(,[])]" $ prop_sortWith_nest + , testProperty "and" $ prop_and + , testProperty "or" $ prop_or + , testProperty "any_zero" $ prop_any_zero + , testProperty "all_zero" $ prop_all_zero + , testProperty "sum_integer" $ prop_sum_integer + , testProperty "sum_double" $ prop_sum_double + , testProperty "avg_integer" $ prop_avg_integer + , testProperty "avg_double" $ prop_avg_double + , testProperty "concat" $ prop_concat + , testProperty "concatMap" $ prop_concatMap + , testProperty "maximum" $ prop_maximum + , testProperty "minimum" $ prop_minimum + , testProperty "splitAt" $ prop_splitAt + , testProperty "takeWhile" $ prop_takeWhile + , testProperty "dropWhile" $ prop_dropWhile + , testProperty "span" $ prop_span + , testProperty "break" $ prop_break + , testProperty "elem" $ prop_elem + , testProperty "notElem" $ prop_notElem + , testProperty "lookup" $ prop_lookup + , testProperty "zip" $ prop_zip + , testProperty "zip3" $ prop_zip3 + , testProperty "zipWith" $ prop_zipWith + , testProperty "zipWith3" $ prop_zipWith3 + , testProperty "unzip" $ prop_unzip + , testProperty "unzip3" $ prop_unzip3 + , testProperty "nub" $ prop_nub + , testProperty "number" $ prop_number + , testProperty "reshape" $ prop_reshape + , testProperty "reshape2" $ prop_reshape2 + , testProperty "transpose" $ prop_transpose + ] + +tests_lifted :: Test +tests_lifted = testGroup "Lifted operations" + [ testProperty "Lifted &&" $ prop_infix_map_and + , testProperty "Lifted ||" $ prop_infix_map_or + , testProperty "Lifted not" $ prop_map_not + , testProperty "Lifted eq" $ prop_map_eq + , testProperty "Lifted neq" $ prop_map_neq + , testProperty "Lifted cond" $ prop_map_cond + , testProperty "Lifted cond tuples" $ prop_map_cond_tuples + , testProperty "Lifted cond + concat" $ prop_concatmapcond + , testProperty "Lifted lt" $ prop_map_lt + , testProperty "Lifted lte" $ prop_map_lte + , testProperty "Lifted gt" $ prop_map_gt + , testProperty "Lifted gte" $ prop_map_gte + , testProperty "Lifted cons" $ prop_map_cons + , testProperty "Lifted concat" $ prop_map_concat + , testProperty "Lifted fst" $ prop_map_fst + , testProperty "Lifted snd" $ prop_map_snd + , testProperty "Lifted the" $ prop_map_the + --, testProperty "Lifed and" $ prop_map_and + , testProperty "map (map (*2))" $ prop_map_map_mul + , testProperty "map (map (map (*2)))" $ prop_map_map_map_mul + , testProperty "map (\\x -> map (\\y -> x + y) ..) .." $ prop_map_map_add + , testProperty "Lifted groupWith" $ prop_map_groupWith + , testProperty "Lifted groupWithKey" $ prop_map_groupWithKey + , testProperty "Lifted sortWith" $ prop_map_sortWith + , testProperty "Lifted sortWith [(,)]" $ prop_map_sortWith_pair + , testProperty "Lifted sortWith [(,[])]" $ prop_map_sortWith_nest + , testProperty "Lifted sortWith length" $ prop_map_sortWith_length + , testProperty "Lifted groupWithKey length" $ prop_map_groupWithKey_length + , testProperty "Lifted length" $ prop_map_length + , testProperty "Lifted length on [[(a,b)]]" $ prop_map_length_tuple + , testProperty "Sortwith length nested" $ prop_sortWith_length_nest + , testProperty "GroupWithKey length nested" $ prop_groupWithKey_length_nest + , testProperty "Lift minimum" $ prop_map_minimum + , testProperty "map (map minimum)" $ prop_map_map_minimum + , testProperty "Lift maximum" $ prop_map_maximum + , testProperty "map (map maximum)" $ prop_map_map_maximum + , testProperty "map integer_to_double" $ prop_map_integer_to_double + , testProperty "map tail" $ prop_map_tail + , testProperty "map unzip" $ prop_map_unzip + , testProperty "map reverse" $ prop_map_reverse + , testProperty "map reverse [[]]" $ prop_map_reverse_nest + , testProperty "map and" $ prop_map_and + , testProperty "map (map and)" $ prop_map_map_and + , testProperty "map sum" $ prop_map_sum + , testProperty "map avg" $ prop_map_avg + , testProperty "map (map sum)" $ prop_map_map_sum + , testProperty "map or" $ prop_map_or + , testProperty "map (map or)" $ prop_map_map_or + , testProperty "map any zero" $ prop_map_any_zero + , testProperty "map all zero" $ prop_map_all_zero + , testProperty "map filter" $ prop_map_filter + , testProperty "map filter > 42" $ prop_map_filter_gt + , testProperty "map filter > 42 (,[])" $ prop_map_filter_gt_nested + , testProperty "map append" $ prop_map_append + , testProperty "map index" $ prop_map_index + , testProperty "map index [[]]" $ prop_map_index_nest + , testProperty "map init" $ prop_map_init + , testProperty "map last" $ prop_map_last + , testProperty "map null" $ prop_map_null + , testProperty "map nub" $ prop_map_nub + , testProperty "map snoc" $ prop_map_snoc + , testProperty "map take" $ prop_map_take + , testProperty "map drop" $ prop_map_drop + , testProperty "map zip" $ prop_map_zip + , testProperty "map takeWhile" $ prop_map_takeWhile + , testProperty "map dropWhile" $ prop_map_dropWhile + , testProperty "map span" $ prop_map_span + , testProperty "map break" $ prop_map_break + , testProperty "map number" $ prop_map_number + , testProperty "map reshape" $ prop_map_reshape + , testProperty "map reshape2" $ prop_map_reshape2 + -- , testProperty "map transpose" $ prop_map_transpose + , testProperty "map sin" $ prop_map_trig_sin + , testProperty "map cos" $ prop_map_trig_cos + , testProperty "map tan" $ prop_map_trig_tan + , testProperty "map asin" $ prop_map_trig_asin + , testProperty "map acos" $ prop_map_trig_acos + , testProperty "map atan" $ prop_map_trig_atan + , testProperty "map log" $ prop_map_log + , testProperty "map exp" $ prop_map_exp + , testProperty "map sqrt" $ prop_map_sqrt + ] + +tests_combinators_hunit :: Test +tests_combinators_hunit = testGroup "HUnit combinators" + [ testCase "hnegative_sum" hnegative_sum + , testCase "hnegative_map_sum" hnegative_map_sum + , testCase "hmap_transpose" hmap_transpose + ] + +-- * Supported Types + +prop_unit :: () -> Property +prop_unit = makeProp id id + +prop_bool :: Bool -> Property +prop_bool = makeProp id id + +prop_integer :: Integer -> Property +prop_integer = makeProp id id + +prop_double :: Double -> Property +prop_double = makePropDouble id id + +prop_char :: Char -> Property +prop_char c = isPrint c ==> makeProp id id c + +prop_text :: Text -> Property +prop_text t = Text.all isPrint t ==> makeProp id id t + +prop_list_integer_1 :: [Integer] -> Property +prop_list_integer_1 = makeProp id id + +prop_list_integer_2 :: [[Integer]] -> Property +prop_list_integer_2 = makeProp id id + +prop_list_integer_3 :: [[[Integer]]] -> Property +prop_list_integer_3 = makeProp id id + +prop_list_tuple_integer :: [(Integer, Integer)] -> Property +prop_list_tuple_integer = makeProp id id + +prop_maybe_integer :: Maybe Integer -> Property +prop_maybe_integer = makeProp id id + +prop_tuple_list_integer :: ([Integer], [Integer]) -> Property +prop_tuple_list_integer = makeProp id id + +prop_tuple_integer_list :: (Integer, [Integer]) -> Property +prop_tuple_integer_list = makeProp id id + +prop_tuple_integer_list_integer :: (Integer, [Integer], Integer) -> Property +prop_tuple_integer_list_integer = makeProp id id + +prop_either_integer :: Either Integer Integer -> Property +prop_either_integer = makeProp id id + +prop_tuple4 :: [(Integer, Integer, Integer, Integer)] -> Property +prop_tuple4 = makeProp (Q.map (\(Q.view -> (a, b, c, d)) -> Q.tup4 (a + c) (b - d) b d)) + (map (\(a, b, c, d) -> (a + c, b - d, b, d))) + +prop_tuple5 :: [(Integer, Integer, Integer, Integer, Integer)] -> Property +prop_tuple5 = makeProp (Q.map (\(Q.view -> (a, _, c, _, e)) -> Q.tup3 a c e)) + (map (\(a, _, c, _, e) -> (a, c, e))) + +{- + +prop_d0 :: D0 -> Property +prop_d0 = makeProp id id + +prop_d1 :: D1 Integer -> Property +prop_d1 = makeProp id id + +prop_d2 :: D2 Integer Integer -> Property +prop_d2 = makeProp id id + +prop_d3 :: D3 -> Property +prop_d3 = makeProp id id + +prop_d4 :: D4 Integer -> Property +prop_d4 = makeProp id id + +prop_d5 :: D5 Integer -> Property +prop_d5 = makeProp id id + +prop_d6 :: D6 Integer Integer Integer Integer Integer -> Property +prop_d6 = makeProp id id + +-} + +-- * Equality, Boolean Logic and Ordering + +prop_infix_and :: (Bool,Bool) -> Property +prop_infix_and = makeProp (uncurryQ (Q.&&)) (uncurry (&&)) + +prop_infix_map_and :: (Bool, [Bool]) -> Property +prop_infix_map_and = makeProp (\x -> Q.map ((Q.fst x) Q.&&) $ Q.snd x) (\(x,xs) -> map (x &&) xs) + +prop_infix_or :: (Bool,Bool) -> Property +prop_infix_or = makeProp (uncurryQ (Q.||)) (uncurry (||)) + +prop_infix_map_or :: (Bool, [Bool]) -> Property +prop_infix_map_or = makeProp (\x -> Q.map ((Q.fst x) Q.||) $ Q.snd x) (\(x,xs) -> map (x ||) xs) + +prop_not :: Bool -> Property +prop_not = makeProp Q.not not + +prop_map_not :: [Bool] -> Property +prop_map_not = makeProp (Q.map Q.not) (map not) + +prop_eq :: (Integer,Integer) -> Property +prop_eq = makeProp (uncurryQ (Q.==)) (uncurry (==)) + +prop_map_eq :: (Integer, [Integer]) -> Property +prop_map_eq = makeProp (\x -> Q.map ((Q.fst x) Q.==) $ Q.snd x) (\(x,xs) -> map (x ==) xs) + +prop_neq :: (Integer,Integer) -> Property +prop_neq = makeProp (uncurryQ (Q./=)) (uncurry (/=)) + +prop_map_neq :: (Integer, [Integer]) -> Property +prop_map_neq = makeProp (\x -> Q.map ((Q.fst x) Q./=) $ Q.snd x) (\(x,xs) -> map (x /=) xs) + +prop_cond :: Bool -> Property +prop_cond = makeProp (\b -> Q.cond b 0 1) (\b -> if b then (0 :: Integer) else 1) + +prop_cond_tuples :: (Bool, (Integer, Integer)) -> Property +prop_cond_tuples = makeProp (\b -> Q.cond (Q.fst b) + (Q.pair (Q.fst $ Q.snd b) (Q.fst $ Q.snd b)) + (Q.pair (Q.snd $ Q.snd b) (Q.snd $ Q.snd b))) + (\b -> if fst b + then (fst $ snd b, fst $ snd b) + else (snd $ snd b, snd $ snd b)) + +prop_cond_list_tuples :: (Bool, ([[Integer]], [[Integer]])) -> Property +prop_cond_list_tuples = makeProp (\b -> Q.cond (Q.fst b) + (Q.pair (Q.fst $ Q.snd b) (Q.fst $ Q.snd b)) + (Q.pair (Q.snd $ Q.snd b) (Q.snd $ Q.snd b))) + (\b -> if fst b + then (fst $ snd b, fst $ snd b) + else (snd $ snd b, snd $ snd b)) + +prop_map_cond :: [Bool] -> Property +prop_map_cond = makeProp (Q.map (\b -> Q.cond b (0 :: Q.Q Integer) 1)) + (map (\b -> if b then 0 else 1)) + +prop_map_cond_tuples :: [Bool] -> Property +prop_map_cond_tuples = makeProp (Q.map (\b -> Q.cond b + (Q.toQ (0, 10) :: Q.Q (Integer, Integer)) + (Q.toQ (1, 11)))) + (map (\b -> if b + then (0, 10) + else (1, 11))) + +prop_concatmapcond :: [Integer] -> Property +prop_concatmapcond l1 = + -- FIXME remove precondition as soon as X100 is fixed + (not $ null l1) + ==> + makeProp q n l1 + where q l = Q.concatMap (\x -> Q.cond ((Q.>) x (Q.toQ 0)) (x Q.<| el) el) l + n l = concatMap (\x -> if x > 0 then [x] else []) l + el = Q.toQ [] + +prop_lt :: (Integer, Integer) -> Property +prop_lt = makeProp (uncurryQ (Q.<)) (uncurry (<)) + +prop_map_lt :: (Integer, [Integer]) -> Property +prop_map_lt = makeProp (\x -> Q.map ((Q.fst x) Q.<) $ Q.snd x) (\(x,xs) -> map (x <) xs) + +prop_lte :: (Integer, Integer) -> Property +prop_lte = makeProp (uncurryQ (Q.<=)) (uncurry (<=)) + +prop_map_lte :: (Integer, [Integer]) -> Property +prop_map_lte = makeProp (\x -> Q.map ((Q.fst x) Q.<=) $ Q.snd x) (\(x,xs) -> map (x <=) xs) + +prop_gt :: (Integer, Integer) -> Property +prop_gt = makeProp (uncurryQ (Q.>)) (uncurry (>)) + +prop_map_gt :: (Integer, [Integer]) -> Property +prop_map_gt = makeProp (\x -> Q.map ((Q.fst x) Q.>) $ Q.snd x) (\(x,xs) -> map (x >) xs) + +prop_gte :: (Integer, Integer) -> Property +prop_gte = makeProp (uncurryQ (Q.>=)) (uncurry (>=)) + +prop_map_gte :: (Integer, [Integer]) -> Property +prop_map_gte = makeProp (\x -> Q.map ((Q.fst x) Q.>=) $ Q.snd x) (\(x,xs) -> map (x >=) xs) + +prop_min_integer :: (Integer,Integer) -> Property +prop_min_integer = makeProp (uncurryQ Q.min) (uncurry min) + +prop_max_integer :: (Integer,Integer) -> Property +prop_max_integer = makeProp (uncurryQ Q.max) (uncurry max) + +prop_min_double :: (Double,Double) -> Property +prop_min_double = makePropDouble (uncurryQ Q.min) (uncurry min) + +prop_max_double :: (Double,Double) -> Property +prop_max_double = makePropDouble (uncurryQ Q.max) (uncurry max) + +-- * Maybe + +prop_maybe :: (Integer, Maybe Integer) -> Property +prop_maybe = makeProp (\a -> Q.maybe (Q.fst a) id (Q.snd a)) (\(i,mi) -> maybe i id mi) + +prop_just :: Integer -> Property +prop_just = makeProp Q.just Just + +prop_isJust :: Maybe Integer -> Property +prop_isJust = makeProp Q.isJust isJust + +prop_isNothing :: Maybe Integer -> Property +prop_isNothing = makeProp Q.isNothing isNothing + +prop_fromJust :: Maybe Integer -> Property +prop_fromJust mi = isJust mi ==> makeProp Q.fromJust fromJust mi + +prop_fromMaybe :: (Integer,Maybe Integer) -> Property +prop_fromMaybe = makeProp (uncurryQ Q.fromMaybe) (uncurry fromMaybe) + +prop_listToMaybe :: [Integer] -> Property +prop_listToMaybe = makeProp Q.listToMaybe listToMaybe + +prop_maybeToList :: Maybe Integer -> Property +prop_maybeToList = makeProp Q.maybeToList maybeToList + +prop_catMaybes :: [Maybe Integer] -> Property +prop_catMaybes = makeProp Q.catMaybes catMaybes + +prop_mapMaybe :: [Maybe Integer] -> Property +prop_mapMaybe = makeProp (Q.mapMaybe id) (mapMaybe id) + +-- * Either + +prop_left :: Integer -> Property +prop_left = makeProp (Q.left :: Q.Q Integer -> Q.Q (Either Integer Integer)) Left + +prop_right :: Integer -> Property +prop_right = makeProp (Q.right :: Q.Q Integer -> Q.Q (Either Integer Integer)) Right + +prop_isLeft :: Either Integer Integer -> Property +prop_isLeft = makeProp Q.isLeft (\e -> case e of {Left _ -> True; Right _ -> False;}) + +prop_isRight :: Either Integer Integer -> Property +prop_isRight = makeProp Q.isRight (\e -> case e of {Left _ -> False; Right _ -> True;}) + +prop_either :: Either Integer Integer -> Property +prop_either = makeProp (Q.either id id) (either id id) + +prop_lefts :: [Either Integer Integer] -> Property +prop_lefts = makeProp Q.lefts lefts + +prop_rights :: [Either Integer Integer] -> Property +prop_rights = makeProp Q.rights rights + +prop_partitionEithers :: [Either Integer Integer] -> Property +prop_partitionEithers = makeProp Q.partitionEithers partitionEithers + +-- * Lists + +prop_cons :: (Integer, [Integer]) -> Property +prop_cons = makeProp (uncurryQ (Q.<|)) (uncurry (:)) + +prop_map_cons :: (Integer, [[Integer]]) -> Property +prop_map_cons = makeProp (\x -> Q.map ((Q.fst x) Q.<|) $ Q.snd x) + (\(x,xs) -> map (x:) xs) + +prop_snoc :: ([Integer], Integer) -> Property +prop_snoc = makeProp (uncurryQ (Q.|>)) (\(a,b) -> a ++ [b]) + +prop_map_snoc :: ([Integer], [Integer]) -> Property +prop_map_snoc = makeProp (\z -> Q.map ((Q.fst z) Q.|>) (Q.snd z)) (\(a,b) -> map (\z -> a ++ [z]) b) + +prop_singleton :: Integer -> Property +prop_singleton = makeProp Q.singleton (: []) + +prop_head :: [Integer] -> Property +prop_head = makePropNotNull Q.head head + +prop_tail :: [Integer] -> Property +prop_tail = makePropNotNull Q.tail tail + +prop_last :: [Integer] -> Property +prop_last = makePropNotNull Q.last last + +prop_map_last :: [[Integer]] -> Property +prop_map_last ps = and (map ((>0) . length) ps) ==> makeProp (Q.map Q.last) (map last) ps + +prop_init :: [Integer] -> Property +prop_init = makePropNotNull Q.init init + +prop_map_init :: [[Integer]] -> Property +prop_map_init ps = and (map ((>0) . length) ps) + ==> + makeProp (Q.map Q.init) (map init) ps + +prop_the :: (Int, Integer) -> Property +prop_the (n, i) = + n > 0 + ==> + let l = replicate n i in makeProp Q.head the l + +prop_map_the :: [(Int, Integer)] -> Property +prop_map_the ps = + let ps' = filter ((>0) . fst) ps in + (length ps') > 0 + ==> + let xss = map (\(n, i) -> replicate n i) ps' in + makeProp (Q.map Q.head) (map the) xss + +prop_map_tail :: [[Integer]] -> Property +prop_map_tail ps = + and [length p > 0 | p <- ps] + ==> + makeProp (Q.map Q.tail) (map tail) ps + +prop_index :: ([Integer], Integer) -> Property +prop_index (l, i) = + i > 0 && i < fromIntegral (length l) + ==> makeProp (uncurryQ (Q.!!)) + (\(a,b) -> a !! fromIntegral b) + (l, i) + +prop_index_pair :: ([(Integer, [Integer])], Integer) -> Property +prop_index_pair (l, i) = + i > 0 && i < fromIntegral (length l) + ==> makeProp (uncurryQ (Q.!!)) + (\(a,b) -> a !! fromIntegral b) + (l, i) + +prop_index_nest :: ([[Integer]], Integer) -> Property +prop_index_nest (l, i) = + i > 0 && i < fromIntegral (length l) + ==> makeProp (uncurryQ (Q.!!)) + (\(a,b) -> a !! fromIntegral b) + (l, i) + +prop_map_index :: ([Integer], [Integer]) -> Property +prop_map_index (l, is) = + and [i >= 0 && i < 2 * fromIntegral (length l) | i <- is] + ==> makeProp (\z -> Q.map (((Q.fst z) Q.++ (Q.fst z) Q.++ (Q.fst z)) Q.!!) (Q.snd z)) + (\(a,b) -> map ((a ++ a ++ a) !!) (map fromIntegral b)) + (l, is) + +prop_map_index_nest :: ([[Integer]], [Integer]) -> Property +prop_map_index_nest (l, is) = + and [i >= 0 && i < 3 * fromIntegral (length l) | i <- is] + ==> makeProp (\z -> Q.map (((Q.fst z) Q.++ (Q.fst z) Q.++ (Q.fst z)) Q.!!) (Q.snd z)) + (\(a,b) -> map ((a ++ a ++ a) !!) (map fromIntegral b)) + (l, is) + +prop_take :: (Integer, [Integer]) -> Property +prop_take = makeProp (uncurryQ Q.take) (\(n,l) -> take (fromIntegral n) l) + +prop_map_take :: (Integer, [[Integer]]) -> Property +prop_map_take = makeProp (\z -> Q.map (Q.take $ Q.fst z) $ Q.snd z) (\(n,l) -> map (take (fromIntegral n)) l) + +prop_drop :: (Integer, [Integer]) -> Property +prop_drop = makeProp (uncurryQ Q.drop) (\(n,l) -> drop (fromIntegral n) l) + +prop_map_drop :: (Integer, [[Integer]]) -> Property +prop_map_drop = makeProp (\z -> Q.map (Q.drop $ Q.fst z) $ Q.snd z) (\(n,l) -> map (drop (fromIntegral n)) l) + +prop_takedrop :: (Integer, [Integer]) -> Property +prop_takedrop = makeProp takedrop_q takedrop + where takedrop_q = \p -> Q.append ((Q.take (Q.fst p)) (Q.snd p)) ((Q.drop (Q.fst p)) (Q.snd p)) + takedrop (n, l) = (take (fromIntegral n) l) ++ (drop (fromIntegral n) l) + +prop_map :: [Integer] -> Property +prop_map = makeProp (Q.map id) (map id) + +prop_map_map_mul :: [[Integer]] -> Property +prop_map_map_mul = makeProp (Q.map (Q.map (*2))) (map (map (*2))) + +prop_map_map_add :: ([Integer], [Integer]) -> Property +prop_map_map_add = makeProp (\z -> Q.map (\x -> (Q.map (\y -> x + y) $ Q.snd z)) $ Q.fst z) (\(l,r) -> map (\x -> map (\y -> x + y) r) l) + +prop_map_map_map_mul :: [[[Integer]]] -> Property +prop_map_map_map_mul = makeProp (Q.map (Q.map (Q.map (*2)))) (map (map (map (*2)))) + +prop_append :: ([Integer], [Integer]) -> Property +prop_append = makeProp (uncurryQ (Q.++)) (uncurry (++)) + +prop_append_nest :: ([[Integer]], [[Integer]]) -> Property +prop_append_nest = makeProp (uncurryQ (Q.append)) (\(a,b) -> a ++ b) + +prop_map_append :: ([Integer], [[Integer]]) -> Property +prop_map_append = makeProp (\z -> Q.map (Q.fst z Q.++) (Q.snd z)) (\(a,b) -> map (a ++) b) + +prop_filter :: [Integer] -> Property +prop_filter = makeProp (Q.filter (const $ Q.toQ True)) (filter $ const True) + +prop_filter_gt :: [Integer] -> Property +prop_filter_gt = makeProp (Q.filter (Q.> 42)) (filter (> 42)) + +prop_filter_gt_nested :: [(Integer, [Integer])] -> Property +prop_filter_gt_nested = makeProp (Q.filter ((Q.> 42) . Q.fst)) (filter ((> 42) . fst)) + +prop_map_filter :: [[Integer]] -> Property +prop_map_filter = makeProp (Q.map (Q.filter (const $ Q.toQ True))) (map (filter $ const True)) + +prop_map_filter_gt :: [[Integer]] -> Property +prop_map_filter_gt = makeProp (Q.map (Q.filter (Q.> 42))) (map (filter (> 42))) + +prop_map_filter_gt_nested :: [[(Integer, [Integer])]] -> Property +prop_map_filter_gt_nested = makeProp (Q.map (Q.filter ((Q.> 42) . Q.fst))) (map (filter ((> 42) . fst))) + +prop_groupWith :: [Integer] -> Property +prop_groupWith = makeProp (Q.groupWith id) (groupWith id) + +groupWithKey :: Ord b => (a -> b) -> [a] -> [(b, [a])] +groupWithKey p as = map (\g -> (the $ map p g, g)) $ groupWith p as + +prop_groupWithKey :: [Integer] -> Property +prop_groupWithKey = makeProp (Q.groupWithKey id) (groupWithKey id) + +prop_map_groupWith :: [[Integer]] -> Property +prop_map_groupWith = makeProp (Q.map (Q.groupWith id)) (map (groupWith id)) + +prop_map_groupWithKey :: [[Integer]] -> Property +prop_map_groupWithKey = makeProp (Q.map (Q.groupWithKey id)) (map (groupWithKey id)) + +prop_groupWith_length :: [[Integer]] -> Property +prop_groupWith_length = makeProp (Q.groupWith Q.length) (groupWith length) + +prop_groupWithKey_length :: [[Integer]] -> Property +prop_groupWithKey_length = makeProp (Q.groupWithKey Q.length) (groupWithKey (fromIntegral . length)) + +prop_sortWith :: [Integer] -> Property +prop_sortWith = makeProp (Q.sortWith id) (sortWith id) + +prop_sortWith_pair :: [(Integer, Integer)] -> Property +prop_sortWith_pair = makeProp (Q.sortWith Q.fst) (sortWith fst) + +prop_sortWith_nest :: [(Integer, [Integer])] -> Property +prop_sortWith_nest = makeProp (Q.sortWith Q.fst) (sortWith fst) + +prop_map_sortWith :: [[Integer]] -> Property +prop_map_sortWith = makeProp (Q.map (Q.sortWith id)) (map (sortWith id)) + +prop_map_sortWith_pair :: [[(Integer, Integer)]] -> Property +prop_map_sortWith_pair = makeProp (Q.map (Q.sortWith Q.fst)) (map (sortWith fst)) + +prop_map_sortWith_nest :: [[(Integer, [Integer])]] -> Property +prop_map_sortWith_nest = makeProp (Q.map (Q.sortWith Q.fst)) (map (sortWith fst)) + +prop_map_sortWith_length :: [[[Integer]]] -> Property +prop_map_sortWith_length = makeProp (Q.map (Q.sortWith Q.length)) (map (sortWith length)) + +prop_map_groupWith_length :: [[[Integer]]] -> Property +prop_map_groupWith_length = makeProp (Q.map (Q.groupWith Q.length)) (map (groupWith length)) + +prop_map_groupWithKey_length :: [[[Integer]]] -> Property +prop_map_groupWithKey_length = makeProp (Q.map (Q.groupWithKey Q.length)) (map (groupWithKey (fromIntegral . length))) + +prop_sortWith_length_nest :: [[[Integer]]] -> Property +prop_sortWith_length_nest = makeProp (Q.sortWith Q.length) (sortWith length) + +prop_groupWith_length_nest :: [[[Integer]]] -> Property +prop_groupWith_length_nest = makeProp (Q.groupWith Q.length) (groupWith length) + +prop_groupWithKey_length_nest :: [[[Integer]]] -> Property +prop_groupWithKey_length_nest = makeProp (Q.groupWithKey Q.length) (groupWithKey (fromIntegral . length)) + +prop_null :: [Integer] -> Property +prop_null = makeProp Q.null null + +prop_map_null :: [[Integer]] -> Property +prop_map_null = makeProp (Q.map Q.null) (map null) + +prop_length :: [Integer] -> Property +prop_length = makeProp Q.length ((fromIntegral :: Int -> Integer) . length) + +prop_length_tuple :: [(Integer, Integer)] -> Property +prop_length_tuple = makeProp Q.length (fromIntegral . length) + +prop_map_length :: [[Integer]] -> Property +prop_map_length = makeProp (Q.map Q.length) (map (fromIntegral . length)) + +prop_map_minimum :: [[Integer]] -> Property +prop_map_minimum ps = and (map (\p -> length p > 0) ps) + ==> + makeProp (Q.map Q.minimum) (map (fromIntegral . minimum)) ps + +prop_map_maximum :: [[Integer]] -> Property +prop_map_maximum ps = and (map (\p -> length p > 0) ps) + ==> + makeProp (Q.map Q.maximum) (map (fromIntegral . maximum)) ps + +prop_map_map_minimum :: [[[Integer]]] -> Property +prop_map_map_minimum ps = and (map (and . map (\p -> length p > 0)) ps) + ==> + makeProp (Q.map (Q.map Q.minimum)) (map (map(fromIntegral . minimum))) ps + +prop_map_map_maximum :: [[[Integer]]] -> Property +prop_map_map_maximum ps = and (map (and . map (\p -> length p > 0)) ps) + ==> + makeProp (Q.map (Q.map Q.maximum)) (map (map(fromIntegral . maximum))) ps + + +prop_map_length_tuple :: [[(Integer, Integer)]] -> Property +prop_map_length_tuple = makeProp (Q.map Q.length) (map (fromIntegral . length)) + +prop_reverse :: [Integer] -> Property +prop_reverse = makeProp Q.reverse reverse + +prop_reverse_nest :: [[Integer]] -> Property +prop_reverse_nest = makeProp Q.reverse reverse + +prop_map_reverse :: [[Integer]] -> Property +prop_map_reverse = makeProp (Q.map Q.reverse) (map reverse) + +prop_map_reverse_nest :: [[[Integer]]] -> Property +prop_map_reverse_nest = makeProp (Q.map Q.reverse) (map reverse) + +prop_and :: [Bool] -> Property +prop_and = makeProp Q.and and + +prop_map_and :: [[Bool]] -> Property +prop_map_and = makeProp (Q.map Q.and) (map and) + +prop_map_map_and :: [[[Bool]]] -> Property +prop_map_map_and = makeProp (Q.map (Q.map Q.and)) (map (map and)) + +prop_or :: [Bool] -> Property +prop_or = makeProp Q.or or + +prop_map_or :: [[Bool]] -> Property +prop_map_or = makeProp (Q.map Q.or) (map or) + +prop_map_map_or :: [[[Bool]]] -> Property +prop_map_map_or = makeProp (Q.map (Q.map Q.or)) (map (map or)) + +prop_any_zero :: [Integer] -> Property +prop_any_zero = makeProp (Q.any (Q.== 0)) (any (== 0)) + +prop_map_any_zero :: [[Integer]] -> Property +prop_map_any_zero = makeProp (Q.map (Q.any (Q.== 0))) (map (any (== 0))) + +prop_all_zero :: [Integer] -> Property +prop_all_zero = makeProp (Q.all (Q.== 0)) (all (== 0)) + +prop_map_all_zero :: [[Integer]] -> Property +prop_map_all_zero = makeProp (Q.map (Q.all (Q.== 0))) (map (all (== 0))) + +prop_sum_integer :: [Integer] -> Property +prop_sum_integer = makeProp Q.sum sum + +avgInt :: [Integer] -> Double +avgInt is = (realToFrac $ sum is) / (fromIntegral $ length is) + +prop_avg_integer :: [Integer] -> Property +prop_avg_integer is = (not $ null is) ==> makeProp Q.avg avgInt is + +prop_map_sum :: [[Integer]] -> Property +prop_map_sum = makeProp (Q.map Q.sum) (map sum) + +prop_map_avg :: [[Integer]] -> Property +prop_map_avg is = (not $ any null is) ==> makeProp (Q.map Q.avg) (map avgInt) is + +prop_map_map_sum :: [[[Integer]]] -> Property +prop_map_map_sum = makeProp (Q.map (Q.map Q.sum)) (map (map sum)) + +prop_map_map_avg :: [[[Integer]]] -> Property +prop_map_map_avg is = (not $ any (any null) is) ==> makeProp (Q.map (Q.map Q.avg)) (map (map avgInt)) + +prop_sum_double :: [Double] -> Property +prop_sum_double = makePropDouble Q.sum sum + +avgDouble :: [Double] -> Double +avgDouble ds = sum ds / (fromIntegral $ length ds) + +prop_avg_double :: [Double] -> Property +prop_avg_double ds = (not $ null ds) ==> makePropDouble Q.avg avgDouble ds + +prop_concat :: [[Integer]] -> Property +prop_concat = makeProp Q.concat concat + +prop_map_concat :: [[[Integer]]] -> Property +prop_map_concat = makeProp (Q.map Q.concat) (map concat) + +prop_concatMap :: [Integer] -> Property +prop_concatMap = makeProp (Q.concatMap Q.singleton) (concatMap (: [])) + +prop_maximum :: [Integer] -> Property +prop_maximum = makePropNotNull Q.maximum maximum + +prop_minimum :: [Integer] -> Property +prop_minimum = makePropNotNull Q.minimum minimum + +prop_splitAt :: (Integer, [Integer]) -> Property +prop_splitAt = makeProp (uncurryQ Q.splitAt) (\(a,b) -> splitAt (fromIntegral a) b) + +prop_takeWhile :: (Integer, [Integer]) -> Property +prop_takeWhile = makeProp (uncurryQ $ Q.takeWhile . (Q.==)) + (uncurry $ takeWhile . (==)) + +prop_dropWhile :: (Integer, [Integer]) -> Property +prop_dropWhile = makeProp (uncurryQ $ Q.dropWhile . (Q.==)) + (uncurry $ dropWhile . (==)) + +prop_map_takeWhile :: (Integer, [[Integer]]) -> Property +prop_map_takeWhile = makeProp (\z -> Q.map (Q.takeWhile (Q.fst z Q.==)) (Q.snd z)) + (\z -> map (takeWhile (fst z ==)) (snd z)) + +prop_map_dropWhile :: (Integer, [[Integer]]) -> Property +prop_map_dropWhile = makeProp (\z -> Q.map (Q.dropWhile (Q.fst z Q.==)) (Q.snd z)) + (\z -> map (dropWhile (fst z ==)) (snd z)) + +prop_span :: (Integer, [Integer]) -> Property +prop_span = makeProp (uncurryQ $ Q.span . (Q.==)) + (uncurry $ span . (==) . fromIntegral) + +prop_map_span :: (Integer, [[Integer]]) -> Property +prop_map_span = makeProp (\z -> Q.map (Q.span ((Q.fst z) Q.==)) (Q.snd z)) + (\z -> map (span (fst z ==)) (snd z)) + +prop_break :: (Integer, [Integer]) -> Property +prop_break = makeProp (uncurryQ $ Q.break . (Q.==)) + (uncurry $ break . (==) . fromIntegral) + +prop_map_break :: (Integer, [[Integer]]) -> Property +prop_map_break = makeProp (\z -> Q.map (Q.break ((Q.fst z) Q.==)) (Q.snd z)) + (\z -> map (break (fst z ==)) (snd z)) + +prop_elem :: (Integer, [Integer]) -> Property +prop_elem = makeProp (uncurryQ Q.elem) + (uncurry elem) + +prop_notElem :: (Integer, [Integer]) -> Property +prop_notElem = makeProp (uncurryQ Q.notElem) + (uncurry notElem) + +prop_lookup :: (Integer, [(Integer,Integer)]) -> Property +prop_lookup = makeProp (uncurryQ Q.lookup) + (uncurry lookup) + +prop_zip :: ([Integer], [Integer]) -> Property +prop_zip = makeProp (uncurryQ Q.zip) (uncurry zip) + +prop_map_zip :: ([Integer], [[Integer]]) -> Property +prop_map_zip = makeProp (\z -> Q.map (Q.zip $ Q.fst z) $ Q.snd z) (\(x, y) -> map (zip x) y) + +prop_zipWith :: ([Integer], [Integer]) -> Property +prop_zipWith = makeProp (uncurryQ $ Q.zipWith (+)) (uncurry $ zipWith (+)) + +prop_unzip :: [(Integer, Integer)] -> Property +prop_unzip = makeProp Q.unzip unzip + +prop_map_unzip :: [[(Integer, Integer)]] -> Property +prop_map_unzip = makeProp (Q.map Q.unzip) (map unzip) + +prop_zip3 :: ([Integer], [Integer],[Integer]) -> Property +prop_zip3 = makeProp (\q -> (case Q.view q of (as,bs,cs) -> Q.zip3 as bs cs)) + (\(as,bs,cs) -> zip3 as bs cs) + +prop_zipWith3 :: ([Integer], [Integer],[Integer]) -> Property +prop_zipWith3 = makeProp (\q -> (case Q.view q of (as,bs,cs) -> Q.zipWith3 (\a b c -> a + b + c) as bs cs)) + (\(as,bs,cs) -> zipWith3 (\a b c -> a + b + c) as bs cs) + +prop_unzip3 :: [(Integer, Integer, Integer)] -> Property +prop_unzip3 = makeProp Q.unzip3 unzip3 + +prop_nub :: [Integer] -> Property +prop_nub = makeProp Q.nub nub + +prop_map_nub :: [[(Integer, Integer)]] -> Property +prop_map_nub = makeProp (Q.map Q.nub) (map nub) + +-- * Tuples + +prop_fst :: (Integer, Integer) -> Property +prop_fst = makeProp Q.fst fst + +prop_fst_nested :: ([Integer], [Integer]) -> Property +prop_fst_nested = makeProp Q.fst fst + +prop_map_fst :: [(Integer, Integer)] -> Property +prop_map_fst = makeProp (Q.map Q.fst) (map fst) + +prop_snd :: (Integer, Integer) -> Property +prop_snd = makeProp Q.snd snd + +prop_map_snd :: [(Integer, Integer)] -> Property +prop_map_snd = makeProp (Q.map Q.snd) (map snd) + +prop_snd_nested :: ([Integer], [Integer]) -> Property +prop_snd_nested = makeProp Q.snd snd + +prop_tup3_1 :: (Integer, Integer, Integer) -> Property +prop_tup3_1 = makeProp (\q -> case Q.view q of (a, _, _) -> a) (\(a, _, _) -> a) + +prop_tup3_2 :: (Integer, Integer, Integer) -> Property +prop_tup3_2 = makeProp (\q -> case Q.view q of (_, b, _) -> b) (\(_, b, _) -> b) + +prop_tup3_3 :: (Integer, Integer, Integer) -> Property +prop_tup3_3 = makeProp (\q -> case Q.view q of (_, _, c) -> c) (\(_, _, c) -> c) + +prop_tup4_2 :: (Integer, Integer, Integer, Integer) -> Property +prop_tup4_2 = makeProp (\q -> case Q.view q of (_, b, _, _) -> b) (\(_, b, _, _) -> b) + +prop_tup4_4 :: (Integer, Integer, Integer, Integer) -> Property +prop_tup4_4 = makeProp (\q -> case Q.view q of (_, _, _, d) -> d) (\(_, _, _, d) -> d) + +prop_tup3_nested :: (Integer, [Integer], Integer) -> Property +prop_tup3_nested = makeProp (\q -> case Q.view q of (_, b, _) -> b) (\(_, b, _) -> b) + +prop_tup4_tup3 :: (Integer, Integer, Integer, Integer) -> Property +prop_tup4_tup3 = makeProp (\q -> case Q.view q of (a, b, _, d) -> Q.tup3 a b d) + (\(a, b, _, d) -> (a, b, d)) + +-- * Numerics + +prop_add_integer :: (Integer,Integer) -> Property +prop_add_integer = makeProp (uncurryQ (+)) (uncurry (+)) + +prop_add_double :: (Double,Double) -> Property +prop_add_double = makePropDouble (uncurryQ (+)) (uncurry (+)) + +prop_mul_integer :: (Integer,Integer) -> Property +prop_mul_integer = makeProp (uncurryQ (*)) (uncurry (*)) + +prop_mul_double :: (Double,Double) -> Property +prop_mul_double = makePropDouble (uncurryQ (*)) (uncurry (*)) + +prop_div_double :: (Double,Double) -> Property +prop_div_double (x,y) = + y /= 0 + ==> makePropDouble (uncurryQ (/)) (uncurry (/)) (x,y) + +prop_integer_to_double :: Integer -> Property +prop_integer_to_double = makePropDouble Q.integerToDouble fromInteger + +prop_integer_to_double_arith :: (Integer, Double) -> Property +prop_integer_to_double_arith = makePropDouble (\x -> (Q.integerToDouble (Q.fst x)) + (Q.snd x)) + (\(i, d) -> fromInteger i + d) + +prop_map_integer_to_double :: [Integer] -> Property +prop_map_integer_to_double = makePropListDouble (Q.map Q.integerToDouble) (map fromInteger) + +prop_abs_integer :: Integer -> Property +prop_abs_integer = makeProp Q.abs abs + +prop_abs_double :: Double -> Property +prop_abs_double = makePropDouble Q.abs abs + +prop_signum_integer :: Integer -> Property +prop_signum_integer = makeProp Q.signum signum + +prop_signum_double :: Double -> Property +prop_signum_double = makePropDouble Q.signum signum + +prop_negate_integer :: Integer -> Property +prop_negate_integer = makeProp Q.negate negate + +prop_negate_double :: Double -> Property +prop_negate_double = makePropDouble Q.negate negate + +prop_trig_sin :: Double -> Property +prop_trig_sin = makePropDouble Q.sin sin + +prop_trig_cos :: Double -> Property +prop_trig_cos = makePropDouble Q.cos cos + +prop_trig_tan :: Double -> Property +prop_trig_tan = makePropDouble Q.tan tan + +prop_exp :: Double -> Property +prop_exp = makePropDouble Q.exp exp + +prop_log :: Double -> Property +prop_log d = d > 0 ==> makePropDouble Q.log log d + +prop_sqrt :: Double -> Property +prop_sqrt d = d > 0 ==> makePropDouble Q.sqrt sqrt d + +arc :: Double -> Bool +arc d = d >= -1 && d <= 1 + +prop_trig_asin :: Double -> Property +prop_trig_asin d = arc d ==> makePropDouble Q.asin asin d + +prop_trig_acos :: Double -> Property +prop_trig_acos d = arc d ==> makePropDouble Q.acos acos d + +prop_trig_atan :: Double -> Property +prop_trig_atan = makePropDouble Q.atan atan + +prop_number :: [Integer] -> Property +prop_number = makeProp (Q.map Q.snd . Q.number) (\xs -> map snd $ zip xs [1..]) + +prop_map_number :: [[Integer]] -> Property +prop_map_number = makeProp (Q.map (Q.map Q.snd . Q.number)) + (map (\xs -> map snd $ zip xs [1..])) + +prop_transpose :: [[Integer]] -> Property +prop_transpose = makeProp Q.transpose transpose + +{- +prop_map_transpose :: [[[Integer]]] -> Property +prop_map_transpose xss = + (all (not . null) (xss :: [[[Integer]]]) + && + and (map (all (not . null)) xss)) + ==> makeProp (Q.map Q.transpose) (map transpose) +-} + +reshape :: Int -> [a] -> [[a]] +reshape _ [] = [] +reshape i xs = take i xs : reshape i (drop i xs) + +prop_reshape :: [Integer] -> Property +prop_reshape = makeProp (Q.reshape 5) (reshape 5) + +prop_reshape2 :: [Integer] -> Property +prop_reshape2 = makeProp (Q.reshape 2) (reshape 2) + +prop_map_reshape :: [[Integer]] -> Property +prop_map_reshape = makeProp (Q.map (Q.reshape 8)) (map (reshape 8)) + +prop_map_reshape2 :: [[Integer]] -> Property +prop_map_reshape2 = makeProp (Q.map (Q.reshape 2)) (map (reshape 2)) + +prop_map_trig_sin :: [Double] -> Property +prop_map_trig_sin = makePropListDouble (Q.map Q.sin) (map sin) + +prop_map_trig_cos :: [Double] -> Property +prop_map_trig_cos = makePropListDouble (Q.map Q.cos) (map cos) + +prop_map_trig_tan :: [Double] -> Property +prop_map_trig_tan = makePropListDouble (Q.map Q.tan) (map tan) + +prop_map_trig_asin :: [Double] -> Property +prop_map_trig_asin ds = all arc ds ==> makePropListDouble (Q.map Q.asin) (map asin) ds + +prop_map_trig_acos :: [Double] -> Property +prop_map_trig_acos ds = all arc ds ==> makePropListDouble (Q.map Q.acos) (map acos) ds + +prop_map_trig_atan :: [Double] -> Property +prop_map_trig_atan = makePropListDouble (Q.map Q.atan) (map atan) + +prop_map_exp :: [Double] -> Property +prop_map_exp = makePropListDouble (Q.map Q.exp) (map exp) + +prop_map_log :: [Double] -> Property +prop_map_log ds = all (> 0) ds ==> makePropListDouble (Q.map Q.log) (map log) ds + +prop_map_sqrt :: [Double] -> Property +prop_map_sqrt ds = all (> 0) ds ==> makePropListDouble (Q.map Q.sqrt) (map sqrt) ds + + +hnegative_sum :: Assertion +hnegative_sum = makeEqAssertion "hnegative_sum" (Q.sum (Q.toQ xs)) (sum xs) + where + xs :: [Integer] + xs = [-1, -4, -5, 2] + +hnegative_map_sum :: Assertion +hnegative_map_sum = makeEqAssertion "hnegative_map_sum" + (Q.map Q.sum (Q.toQ xss)) + (map sum xss) + where + xss :: [[Integer]] + xss = [[10, 20, 30], [-10, -20, -30], [], [0]] + +hmap_transpose :: Assertion +hmap_transpose = makeEqAssertion "hmap_transpose" (Q.map Q.transpose (Q.toQ xss)) res + where + xss :: [[[Integer]]] + xss = [ [ [10, 20, 30] + , [40, 50, 60]] + , [ [100, 200] + , [300, 400] + , [500, 600]] + ] + + res :: [[[Integer]]] + res = [ [ [10, 40] + , [20, 50] + , [30, 60] + ] + , [ [100, 300, 500] + , [200, 400, 600] + ] + ] diff --git a/tests/ComprehensionTests.hs b/tests/ComprehensionTests.hs new file mode 100644 --- /dev/null +++ b/tests/ComprehensionTests.hs @@ -0,0 +1,526 @@ +module ComprehensionTests where + +import Common +import qualified DSHComprehensions as C + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion) +import Test.QuickCheck + +tests_comprehensions :: Test +tests_comprehensions = testGroup "Comprehensions" + [ testProperty "cartprod" prop_cartprod + , testProperty "eqjoin" prop_eqjoin + , testProperty "eqjoinproj" prop_eqjoinproj + , testProperty "eqjoinpred" prop_eqjoinpred + , testProperty "eqjointuples" prop_eqjointuples + , testProperty "thetajoin_eq" prop_thetajoin_eq + , testProperty "thetajoin_neq" prop_thetajoin_neq + , testProperty "eqjoin3" prop_eqjoin3 + , testProperty "eqjoin_nested_left" prop_eqjoin_nested_left + , testProperty "eqjoin_nested_right" prop_eqjoin_nested_right + , testProperty "eqjoin_nested_both" prop_eqjoin_nested_both + , testProperty "nestjoin" prop_nestjoin + , testProperty "nestjoin3" prop_nestjoin3 + , testProperty "antijoin class12" prop_aj_class12 + , testProperty "antijoin class15" prop_aj_class15 + , testProperty "antijoin class16" prop_aj_class16 + , testProperty "backdep1" prop_backdep + , testProperty "backdep_filter" prop_backdep_filter + , testProperty "backdep2" prop_backdep2 + , testProperty "backdep3" prop_backdep3 + , testProperty "backdep4" prop_backdep4 + , testProperty "backdep5" prop_backdep5 + , testProperty "deep" prop_deep_iter + ] + +tests_join_hunit :: Test +tests_join_hunit = testGroup "HUnit joins" + [ testCase "heqjoin_nested1" heqjoin_nested1 + , testCase "hsemijoin" hsemijoin + , testCase "hsemijoin_range" hsemijoin_range + , testCase "hsemijoin_quant" hsemijoin_quant + , testCase "hsemijoin_not_null" hsemijoin_not_null + , testCase "hantijoin" hantijoin + , testCase "hantijoin_range" hantijoin_range + , testCase "hantijoin_null" hantijoin_null + , testCase "hantijoin_class12" hantijoin_class12 + , testCase "hantijoin_class15" hantijoin_class15 + , testCase "hantijoin_class16" hantijoin_class16 + , testCase "hfrontguard" hfrontguard + ] + +tests_nest_head_hunit :: Test +tests_nest_head_hunit = testGroup "HUnit head nesting" + [ testCase "hnj1" hnj1 + , testCase "hnj2" hnj2 + , testCase "hnj3" hnj3 + , testCase "hnj4" hnj4 + , testCase "hnj5" hnj5 + , testCase "hnj6" hnj6 + , testCase "hnj7" hnj7 + , testCase "hnj8" hnj8 + , testCase "hnj9" hnj9 + , testCase "hnj10" hnj10 + , testCase "hnj11" hnj11 + , testCase "hnj12" hnj12 + , testCase "hnp1" hnp1 + , testCase "hnp2" hnp2 + , testCase "hnp3" hnp3 + , testCase "hnp4" hnp4 + ] + +tests_nest_guard_hunit :: Test +tests_nest_guard_hunit = testGroup "HUnit guard nesting" + [ testCase "hnjg1" hnjg1 + , testCase "hnjg2" hnjg2 + , testCase "hnjg3" hnjg3 + , testCase "hnjg4" hnjg4 + , testCase "hnjg5" hnjg5 + ] + +--------------------------------------------------------------------------------- +-- QuickCheck properties for comprehensions + +prop_cartprod :: ([Integer], [Integer]) -> Property +prop_cartprod = makeProp C.cartprod cartprod_native + where + cartprod_native (xs, ys) = [ (x, y) | x <- xs, y <- ys] + +prop_eqjoin :: ([Integer], [Integer]) -> Property +prop_eqjoin = makeProp C.eqjoin eqjoin_native + where + eqjoin_native (xs, ys) = [ (x, y) | x <- xs , y <- ys , x == y ] + +prop_eqjoinproj :: ([Integer], [Integer]) -> Property +prop_eqjoinproj = makeProp C.eqjoinproj eqjoinproj_native + where + eqjoinproj_native (xs, ys) = [ (x, y) | x <- xs , y <- ys , (2 * x) == y ] + +prop_eqjoinpred :: (Integer, [Integer], [Integer]) -> Property +prop_eqjoinpred = makeProp C.eqjoinpred eqjoinpred_native + where + eqjoinpred_native (x', xs, ys) = [ (x, y) | x <- xs , y <- ys , x == y , x > x'] + +prop_eqjointuples :: ([(Integer, Integer)], [(Integer, Integer)]) -> Property +prop_eqjointuples = makeProp C.eqjointuples eqjointuples_native + where + eqjointuples_native (xs, ys) = [ (x1 * x2, y1, y2) + | (x1, x2) <- xs + , (y1, y2) <- ys + , x1 == y2 + ] + +prop_thetajoin_eq :: ([(Integer, Integer)], [(Integer, Integer)]) -> Property +prop_thetajoin_eq = makeProp C.thetajoin_eq thetajoin_eq_native + where + thetajoin_eq_native (xs, ys) = [ (x1 * x2, y1, y2) + | (x1, x2) <- xs + , (y1, y2) <- ys + , x1 == y2 + , y1 == x2 + ] + +prop_thetajoin_neq :: ([(Integer, Integer)], [(Integer, Integer)]) -> Property +prop_thetajoin_neq = makeProp C.thetajoin_neq thetajoin_neq_native + where + thetajoin_neq_native (xs, ys) = [ (x1 * x2, y1, y2) + | (x1, x2) <- xs + , (y1, y2) <- ys + , x1 == y2 + , y1 /= x2 + ] + + +prop_eqjoin3 :: ([Integer], [Integer], [Integer]) -> Property +prop_eqjoin3 = makeProp C.eqjoin3 eqjoin3_native + where + eqjoin3_native (xs, ys, zs) = [ (x, y, z) | x <- xs , y <- ys , z <- zs , x == y , y == z] + +prop_eqjoin_nested_left :: ([(Integer, [Integer])], [Integer]) -> Property +prop_eqjoin_nested_left = makeProp C.eqjoin_nested_left eqjoin_nested_left_native + where + eqjoin_nested_left_native (xs, ys) = [ (x, y) | x <- xs , y <- ys , fst x == y] + +prop_eqjoin_nested_right :: ([Integer], [(Integer, [Integer])]) -> Property +prop_eqjoin_nested_right = makeProp C.eqjoin_nested_right eqjoin_nested_right_native + where + eqjoin_nested_right_native (xs, ys) = [ (x, y) | x <- xs , y <- ys , x == fst y] + +prop_eqjoin_nested_both :: ([(Integer, [Integer])], [(Integer, [Integer])]) -> Property +prop_eqjoin_nested_both = makeProp C.eqjoin_nested_both eqjoin_nested_both_native + where + eqjoin_nested_both_native (xs, ys) = [ (x, y) | x <- xs , y <- ys , fst x == fst y] + +prop_nestjoin :: ([Integer], [Integer]) -> Property +prop_nestjoin = makeProp C.nestjoin nestjoin_native + where + nestjoin_native (xs, ys) = [ (x, [ y | y <- ys, x == y ]) | x <- xs] + +prop_nestjoin3 :: ([Integer], [Integer], [Integer]) -> Property +prop_nestjoin3 = makeProp C.nestjoin3 nestjoin3_native + where + nestjoin3_native (njxs, njys, njzs) = + [ [ [ (x,y,z) | z <- njzs, y == z ] + | y <- njys + , x == y + ] + | x <- njxs + ] + +prop_aj_class12 :: ([Integer], [Integer]) -> Property +prop_aj_class12 = makeProp C.aj_class12 aj_class12_native + where + aj_class12_native (ajxs, ajys) = [ x + | x <- ajxs + , and [ x == y | y <- ajys, y > 10 ] + ] + +prop_aj_class15 :: ([Integer], [Integer]) -> Property +prop_aj_class15 = makeProp C.aj_class15 aj_class15_native + where + aj_class15_native (ajxs, ajys) = [ x + | x <- ajxs + , and [ y `mod` 4 == 0 | y <- ajys, x < y ] + ] + +prop_aj_class16 :: ([Integer], [Integer]) -> Property +prop_aj_class16 = makeProp C.aj_class16 aj_class16_native + where + aj_class16_native (ajxs, ajys) = [ x + | x <- ajxs + , and [ y <= 2 * x | y <- ajys, x < y ] + ] + +prop_backdep :: [[Integer]] -> Property +prop_backdep = makeProp C.backdep backdep_native + where + backdep_native xss = [x | xs <- xss, x <- xs] + +prop_backdep_filter :: [[Integer]] -> Property +prop_backdep_filter = makeProp C.backdep_filter backdep_filter_native + where + backdep_filter_native xss = [x | xs <- xss, x <- xs, fromIntegral (length xs) > x] + +prop_backdep2 :: [[Integer]] -> Property +prop_backdep2 = makeProp C.backdep2 backdep2 + where + backdep2 xss = [ [ x * 42 | x <- xs ] | xs <- xss ] + +prop_backdep3 :: [[Integer]] -> Property +prop_backdep3 = makeProp C.backdep3 backdep3 + where + backdep3 xss = [ [ x + fromIntegral (length xs) | x <- xs ] | xs <- xss ] + +prop_backdep4 :: [[[Integer]]] -> Property +prop_backdep4 = makeProp C.backdep4 backdep4 + where + backdep4 xsss = [ [ [ x + fromIntegral (length xs) + fromIntegral (length xss) + | x <- xs + ] + | xs <- xss + ] + | xss <- xsss + ] + +prop_backdep5 :: [[Integer]] -> Property +prop_backdep5 = makeProp C.backdep5 backdep5 + where + backdep5 xss = [ [ x + fromIntegral (length xs) + | x <- take (length xs - 3) xs ] + | xs <- xss ] + + + +----------------------------------------------------------------------- +-- HUnit tests for comprehensions + +heqjoin_nested1 :: Assertion +heqjoin_nested1 = makeEqAssertion "heqjoin_nested" C.eqjoin_nested1 res + where + res = [ ((20, ['b']), 20) + , ((30, ['c', 'd']), 30) + , ((30, ['c', 'd']), 30) + , ((40, []), 40) + ] + +hsemijoin :: Assertion +hsemijoin = makeEqAssertion "hsemijoin" C.semijoin res + where + res = [2, 4, 6, 7] + +hsemijoin_range :: Assertion +hsemijoin_range = makeEqAssertion "hsemijoin_range" C.semijoin_range res + where + res = [2, 4] + +hsemijoin_not_null :: Assertion +hsemijoin_not_null = makeEqAssertion "hsemijoin_range" C.semijoin_not_null res + where + res = [2, 4, 6, 7] + +hsemijoin_quant :: Assertion +hsemijoin_quant = makeEqAssertion "hsemijoin_quant" C.semijoin_quant res + where + res = [6,7] + +hantijoin :: Assertion +hantijoin = makeEqAssertion "hantijoin" C.antijoin res + where + res = [1, 3, 5] + +hantijoin_range :: Assertion +hantijoin_range = makeEqAssertion "hantijoin_range" C.antijoin_range res + where + res = [1, 3, 5, 6, 7] + +hantijoin_null :: Assertion +hantijoin_null = makeEqAssertion "hantijoin_range" C.antijoin_null res + where + res = [1, 3, 5] + +hantijoin_class12 :: Assertion +hantijoin_class12 = makeEqAssertion "hantijoin_class12" C.antijoin_class12 res + where + res = [6,7,8,9,10] + +hantijoin_class15 :: Assertion +hantijoin_class15 = makeEqAssertion "hantijoin_class15" C.antijoin_class15 res + where + res = [5,6,7,8] + +hantijoin_class16 :: Assertion +hantijoin_class16 = makeEqAssertion "hantijoin_class16" C.antijoin_class16 res + where + res = [4,5,6] + +hfrontguard :: Assertion +hfrontguard = makeEqAssertion "hfrontguard" C.frontguard res + where + res = [[],[1,2],[1,2]] + +----------------------------------------------------------------------- +-- HUnit tests for nestjoin/nestproduct + +njxs1 :: [Integer] +njxs1 = [1,2,3,4,5,6] + +njys1 :: [Integer] +njys1 = [3,4,5,6,3,6,4,1,1,1] + +hnj1 :: Assertion +hnj1 = makeEqAssertion "hnj1" (C.nj1 njxs1 njys1) (nj1 njxs1 njys1) + +hnj2 :: Assertion +hnj2 = makeEqAssertion "hnj2" (C.nj2 njxs1 njys1) (nj2 njxs1 njys1) + +hnj3 :: Assertion +hnj3 = makeEqAssertion "hnj3" (C.nj3 njxs1 njys1) (nj3 njxs1 njys1) + +hnj4 :: Assertion +hnj4 = makeEqAssertion "hnj4" (C.nj4 njxs1 njys1) (nj4 njxs1 njys1) + +hnj5 :: Assertion +hnj5 = makeEqAssertion "hnj5" (C.nj5 njxs1 njys1) (nj5 njxs1 njys1) + +hnj6 :: Assertion +hnj6 = makeEqAssertion "hnj6" (C.nj6 njxs1 njys1) (nj6 njxs1 njys1) + +hnj7 :: Assertion +hnj7 = makeEqAssertion "hnj7" (C.nj7 njxs1 njys1) (nj7 njxs1 njys1) + +hnj8 :: Assertion +hnj8 = makeEqAssertion "hnj8" (C.nj8 njxs1 njys1) (nj8 njxs1 njys1) + +hnj9 :: Assertion +hnj9 = makeEqAssertion "hnj9" (C.nj9 njxs1 njys1) (nj9 njxs1 njys1) + +hnj10 :: Assertion +hnj10 = makeEqAssertion "hnj10" (C.nj10 njxs1 njys1) (nj10 njxs1 njys1) + +hnj11 :: Assertion +hnj11 = makeEqAssertion "hnj11" (C.nj11 njxs1 njys1) (nj11 njxs1 njys1) + +-- Test data for testcase hnj12 +njxs2, njys2, njzs2 :: [Integer] +njxs2 = [1,2,3,4,5,5,2] +njys2 = [2,1,0,5,4,4,4] +njzs2 = [6,1,1,3,2,5] + +hnj12 :: Assertion +hnj12 = makeEqAssertion "hnj12" (C.nj12 njxs2 njys2 njzs2) (nj12 njxs2 njys2 njzs2) + +hnp1 :: Assertion +hnp1 = makeEqAssertion "hnp1" (C.np1 njxs1 njys1) (np1 njxs1 njys1) + +hnp2 :: Assertion +hnp2 = makeEqAssertion "hnp2" (C.np2 njxs1 njys1) (np2 njxs1 njys1) + +hnp3 :: Assertion +hnp3 = makeEqAssertion "hnp3" (C.np3 njxs1 njys1) (np3 njxs1 njys1) + +hnp4 :: Assertion +hnp4 = makeEqAssertion "hnp4" (C.np4 njxs1 njys1) (np4 njxs1 njys1) + +hnjg1 :: Assertion +hnjg1 = makeEqAssertion "hnjg1" (C.njg1 njgxs1 njgzs1) (njg1 njgxs1 njgzs1) + +hnjg2 :: Assertion +hnjg2 = makeEqAssertion "hnjg2" (C.njg2 njgxs1 njgys1) (njg2 njgxs1 njgys1) + +hnjg3 :: Assertion +hnjg3 = makeEqAssertion "hnjg3" (C.njg3 njgxs1 njgys1 njgzs1) (njg3 njgxs1 njgys1 njgzs1) + +hnjg4 :: Assertion +hnjg4 = makeEqAssertion "hnjg4" (C.njg4 njgxs1 njgys1 njgzs1) (njg4 njgxs1 njgys1 njgzs1) + +hnjg5 :: Assertion +hnjg5 = makeEqAssertion "hnjg5" (C.njg5 njgxs1 njgys1) (njg5 njgxs1 njgys1) + +pair :: a -> b -> (a, b) +pair = (,) + +-- Head/NestJoin +nj1 :: [Integer] -> [Integer] -> [[Integer]] +nj1 njxs njys = + [ [ y | y <- njys, x == y ] + | x <- njxs + ] + +nj2 :: [Integer] -> [Integer] -> [(Integer, [Integer])] +nj2 njxs njys = + [ pair x [ y | y <- njys, x == y ] + | x <- njxs + ] + +nj3 :: [Integer] -> [Integer] -> [(Integer, [Integer])] +nj3 njxs njys = + [ pair x ([ y | y <- njys, x == y ] ++ ([100, 200, 300])) + | x <- njxs + ] + +nj4 :: [Integer] -> [Integer] -> [(Integer, [Integer])] +nj4 njxs njys = + [ pair x ([ y | y <- njys, x == y ] ++ [ z | z <- njys, x == z ]) + | x <- njxs + ] + +nj5 :: [Integer] -> [Integer] -> [(Integer, [Integer])] +nj5 njxs njys = + [ pair x [ y | y <- njys, x + y > 15 ] + | x <- njxs + ] + +nj6 :: [Integer] -> [Integer] -> [(Integer, [Integer])] +nj6 njxs njys = + [ pair x [ y | y <- njys, x + y > 10, y < 7 ] + | x <- njxs + ] + +nj7 :: [Integer] -> [Integer] -> [[Integer]] +nj7 njxs njys = + [ [ x + y | y <- njys, x + 2 == y ] | x <- njxs ] + +nj8 :: [Integer] -> [Integer] -> [[Integer]] +nj8 njxs njys = [ [ x + y | y <- njys, x == y, y < 5 ] | x <- njxs, x > 3 ] + +nj9 :: [Integer] -> [Integer] -> [[Integer]] +nj9 njxs njys = [ [ x + y | y <- njys, x + 1 == y, y > 2, x < 6 ] | x <- njxs ] + +nj10 :: [Integer] -> [Integer] -> [Integer] +nj10 njxs njys = [ x + sum [ x * y | y <- njys, x == y ] | x <- njxs ] + +nj11 :: [Integer] -> [Integer] -> [[Integer]] +nj11 njxs njys = [ [ x + y | y <- njys, x > y, x < y * 2 ] | x <- njxs ] + +nj12 :: [Integer] -> [Integer] -> [Integer] -> [[[(Integer, Integer, Integer)]]] +nj12 njxs njys njzs = + [ [ [ (x,y,z) | z <- njzs, y == z ] + | y <- njys + , x == y + ] + | x <- njxs + ] + +-- Head/NestProduct +np1 :: [Integer] -> [Integer] -> [[Integer]] +np1 njxs njys = [ [ x * y * 2 | y <- njys ] | x <- njxs ] + +np2 :: [Integer] -> [Integer] -> [(Integer, [Integer])] +np2 njxs njys = [ pair x [ y * 2 | y <- njys ] | x <- njxs ] + +np3 :: [Integer] -> [Integer] -> [[Integer]] +np3 njxs njys = [ [ x + y | y <- njys ] | x <- njxs ] + +np4 :: [Integer] -> [Integer] -> [[Integer]] +np4 njxs njys = [ [ y | y <- njys, x > y ] | x <- njxs ] + +-- Guard/NestJoin + +njgxs1 :: [Integer] +njgxs1 = [1,2,3,4,5,6,7,8,12] + +njgys1 :: [Integer] +njgys1 = [2,3,2,4,5,5,9,12,2,2,13] + +njgzs1 :: [(Integer, Integer)] +njgzs1 = [(2, 20), (5, 60), (3, 30), (3, 80), (4, 40), (5, 10), (5, 30), (12, 120)] + +njg1 :: [Integer] -> [(Integer, Integer)] -> [Integer] +njg1 njgxs njgzs = + [ x + | x <- njgxs + , x < 8 + , sum [ snd z | z <- njgzs, fst z == x ] > 100 + ] + +njg2 :: [Integer] -> [Integer] -> [Integer] +njg2 njgxs njgys = + [ x + | x <- njgxs + , and [ y > 1 | y <- njgys, x == y ] + , x < 8 + ] + +njg3 :: [Integer] -> [Integer] -> [(Integer, Integer)] -> [(Integer, Integer)] +njg3 njgxs njgys njgzs = + [ pair x y + | x <- njgxs + , y <- njgys + , length [ () | z <- njgzs, fst z == x ] > 2 + ] + +njg4 :: [Integer] -> [Integer] -> [(Integer, Integer)] -> [Integer] +njg4 njgxs njgys njgzs = + [ x + | x <- njgxs + , length [ () | y <- njgys, x == y ] + > length [ () | z <- njgzs, fst z == x ] + ] + +njg5 :: [Integer] -> [Integer] -> [Integer] +njg5 njgxs njgys = + [ x + | x <- njgxs + , sum [ y | y <- njgys, x < y, y > 5 ] < 10 + ] + +-------------------------------------------------------------------------------- +-- + +prop_deep_iter :: ([Integer], [Integer], [Integer], [Integer], [Integer]) -> Property +prop_deep_iter = makeProp C.deep_iter deep_iter_native + where + deep_iter_native (ws1, ws2, xs, ys, zs) = + [ [ [ [ w1 * 23 - y | w1 <- ws1 ] + ++ + [ w2 + 42 - y | w2 <- ws2 ] + | z <- zs + , z > x + ] + | y <- ys + ] + | x <- xs + ] diff --git a/tests/DSHComprehensions.hs b/tests/DSHComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/DSHComprehensions.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MonadComprehensions #-} + +-- | This module contains testcases for monad comprehensions. We store them in a +-- separate module because they rely on RebindableSyntax and hidden Prelude. + +module DSHComprehensions where + +import qualified Prelude as P +import Database.DSH + +--------------------------------------------------------------- +-- Comprehensions for quickcheck tests + +cartprod :: Q ([Integer], [Integer]) -> Q [(Integer, Integer)] +cartprod (view -> (xs, ys)) = + [ tup2 x y + | x <- xs + , y <- ys + ] + +eqjoin :: Q ([Integer], [Integer]) -> Q [(Integer, Integer)] +eqjoin (view -> (xs, ys)) = + [ tup2 x y + | x <- xs + , y <- ys + , x == y + ] + + +eqjoinproj :: Q ([Integer], [Integer]) -> Q [(Integer, Integer)] +eqjoinproj (view -> (xs, ys)) = + [ tup2 x y + | x <- xs + , y <- ys + , (2 * x) == y + ] + +eqjoinpred :: Q (Integer, [Integer], [Integer]) -> Q [(Integer, Integer)] +eqjoinpred (view -> (x', xs, ys)) = + [ tup2 x y + | x <- xs + , y <- ys + , x == y + , x > x' + ] + +eqjointuples :: Q ([(Integer, Integer)], [(Integer, Integer)]) -> Q [(Integer, Integer, Integer)] +eqjointuples (view -> (xs, ys)) = + [ tup3 (x1 * x2) y1 y2 + | (view -> (x1, x2)) <- xs + , (view -> (y1, y2)) <- ys + , x1 == y2 + ] + +thetajoin_eq :: Q ([(Integer, Integer)], [(Integer, Integer)]) -> Q [(Integer, Integer, Integer)] +thetajoin_eq (view -> (xs, ys)) = + [ tup3 (x1 * x2) y1 y2 + | (view -> (x1, x2)) <- xs + , (view -> (y1, y2)) <- ys + , x1 == y2 + , y1 == x2 + ] + +thetajoin_neq :: Q ([(Integer, Integer)], [(Integer, Integer)]) -> Q [(Integer, Integer, Integer)] +thetajoin_neq (view -> (xs, ys)) = + [ tup3 (x1 * x2) y1 y2 + | (view -> (x1, x2)) <- xs + , (view -> (y1, y2)) <- ys + , x1 == y2 + , y1 /= x2 + ] + +eqjoin3 :: Q ([Integer], [Integer], [Integer]) -> Q [(Integer, Integer, Integer)] +eqjoin3 (view -> (xs, ys, zs)) = + [ tup3 x y z + | x <- xs + , y <- ys + , z <- zs + , x == y + , y == z + ] + +eqjoin_nested_left :: Q ([(Integer, [Integer])], [Integer]) -> Q [((Integer, [Integer]), Integer)] +eqjoin_nested_left args = + [ pair x y + | x <- fst args + , y <- snd args + , fst x == y + ] + +eqjoin_nested_right :: Q ([Integer], [(Integer, [Integer])]) -> Q [(Integer, (Integer, [Integer]))] +eqjoin_nested_right args = + [ pair x y + | x <- fst args + , y <- snd args + , x == fst y + ] + +eqjoin_nested_both :: Q ([(Integer, [Integer])], [(Integer, [Integer])]) + -> Q [((Integer, [Integer]), (Integer, [Integer]))] +eqjoin_nested_both args = + [ pair x y + | x <- fst args + , y <- snd args + , fst x == fst y + ] + +nestjoin :: Q ([Integer], [Integer]) -> Q [(Integer, [Integer])] +nestjoin (view -> (xs, ys)) = + [ tup2 x [ y | y <- ys, x == y] + | x <- xs + ] + +nestjoin3 :: Q ([Integer], [Integer], [Integer]) -> Q [[[(Integer, Integer, Integer)]]] +nestjoin3 (view -> (xs, ys, zs)) = + [ [ [ tup3 x y z | z <- zs, y == z ] + | y <- ys + , x == y + ] + | x <- xs + ] + +-------------------------------------------------------------- +-- Comprehensions for HUnit tests + +eqjoin_nested1 :: Q [((Integer, [Char]), Integer)] +eqjoin_nested1 = + [ pair x y + | x <- (toQ ([(10, ['a']), (20, ['b']), (30, ['c', 'd']), (40, [])] :: [(Integer, [Char])])) + , y <- (toQ [20, 30, 30, 40, 50]) + , fst x == y + ] + +semijoin :: Q [Integer] +semijoin = + let xs = (toQ [1, 2, 3, 4, 5, 6, 7] :: Q [Integer]) + ys = (toQ [2, 4, 6, 7] :: Q [Integer]) + in [ x | x <- xs , x `elem` ys ] + +semijoin_range :: Q [Integer] +semijoin_range = + let xs = (toQ [1, 2, 3, 4, 5, 6, 7] :: Q [Integer]) + ys = (toQ [2, 4, 6] :: Q [Integer]) + in [ x | x <- xs , x `elem` [ y | y <- ys, y < 6 ] ] + +semijoin_quant :: Q [Integer] +semijoin_quant = + let xs = (toQ [1, 2, 3, 4, 5, 6, 7] :: Q [Integer]) + ys = (toQ [2, 4, 6, 7] :: Q [Integer]) + in [ x | x <- xs, or [ y > 5 | y <- ys, x == y ] ] + +semijoin_not_null :: Q [Integer] +semijoin_not_null = + let xs = (toQ [1, 2, 3, 4, 5, 6, 7] :: Q [Integer]) + ys = (toQ [2, 4, 6, 7] :: Q [Integer]) + in [ x | x <- xs, not $ null [ y | y <- ys, x == y] ] + + +antijoin :: Q [Integer] +antijoin = + let xs = (toQ [1, 2, 3, 4, 5, 6, 7] :: Q [Integer]) + ys = (toQ [2, 4, 6, 7] :: Q [Integer]) + in [ x | x <- xs , not $ x `elem` ys ] + +antijoin_null :: Q [Integer] +antijoin_null = + let xs = (toQ [1, 2, 3, 4, 5, 6, 7] :: Q [Integer]) + ys = (toQ [2, 4, 6, 7] :: Q [Integer]) + in [ x | x <- xs, null [ y | y <- ys, x == y] ] + +antijoin_range :: Q [Integer] +antijoin_range = + let xs = (toQ [1, 2, 3, 4, 5, 6, 7] :: Q [Integer]) + ys = (toQ [2, 4, 6, 7] :: Q [Integer]) + in [ x | x <- xs , not $ x `elem` [ y | y <- ys, y < 5 ] ] + +antijoin_class12 :: Q [Integer] +antijoin_class12 = + let xs = toQ ([6,7,8,9,10,12] :: [Integer]) + ys = toQ ([8,9,12,13,15,16] :: [Integer]) + in [ x | x <- xs, and [ x < y | y <- ys, y > 10 ]] + +antijoin_class15 :: Q [Integer] +antijoin_class15 = + let xs = toQ ([3,4,5,6,7,8] :: [Integer]) + ys = toQ ([4,5,8,16] :: [Integer]) + in [ x | x <- xs, and [ y `mod` 4 == 0 | y <- ys, x < y ]] + +antijoin_class16 :: Q [Integer] +antijoin_class16 = + let xs = toQ ([3,4,5,6] :: [Integer]) + ys = toQ ([1,2,3,4,5,6,7,8] :: [Integer]) + in [ x | x <- xs, and [ y <= 2 * x | y <- ys, x < y ]] + +frontguard :: Q [[Integer]] +frontguard = + [ [ y | x > 13, y <- toQ ([1,2,3,4] :: [Integer]), y < 3 ] + | x <- toQ ([10, 20, 30] :: [Integer]) + ] + +---------------------------------------------------------------------- +-- Comprehensions for HUnit NestJoin/NestProduct tests + +nj1 :: [Integer] -> [Integer] -> Q [[Integer]] +nj1 njxs njys = + [ [ y | y <- toQ njys, x == y ] + | x <- toQ njxs + ] + +nj2 :: [Integer] -> [Integer] -> Q [(Integer, [Integer])] +nj2 njxs njys = + [ pair x [ y | y <- toQ njys, x == y ] + | x <- toQ njxs + ] + +nj3 :: [Integer] -> [Integer] -> Q [(Integer, [Integer])] +nj3 njxs njys = + [ pair x ([ y | y <- toQ njys, x == y ] ++ (toQ [100, 200, 300])) + | x <- toQ njxs + ] + +nj4 :: [Integer] -> [Integer] -> Q [(Integer, [Integer])] +nj4 njxs njys = + [ pair x ([ y | y <- toQ njys, x == y ] ++ [ z | z <- toQ njys, x == z ]) + | x <- toQ njxs + ] + +-- Code incurs DistSeg for the literal 15. +nj5 :: [Integer] -> [Integer] -> Q [(Integer, [Integer])] +nj5 njxs njys = + [ pair x [ y | y <- toQ njys, x + y > 15 ] + | x <- toQ njxs + ] + +nj6 :: [Integer] -> [Integer] -> Q [(Integer, [Integer])] +nj6 njxs njys = + [ pair x [ y | y <- toQ njys, x + y > 10, y < 7 ] + | x <- toQ njxs + ] + +nj7 :: [Integer] -> [Integer] -> Q [[Integer]] +nj7 njxs njys = + [ [ x + y | y <- toQ njys, x + 2 == y ] | x <- toQ njxs ] + +nj8 :: [Integer] -> [Integer] -> Q [[Integer]] +nj8 njxs njys = [ [ x + y | y <- toQ njys, x == y, y < 5 ] | x <- toQ njxs, x > 3 ] + +nj9 :: [Integer] -> [Integer] -> Q [[Integer]] +nj9 njxs njys = [ [ x + y | y <- toQ njys, x + 1 == y, y > 2, x < 6 ] | x <- toQ njxs ] + +nj10 :: [Integer] -> [Integer] -> Q [Integer] +nj10 njxs njys = [ x + sum [ x * y | y <- toQ njys, x == y ] | x <- toQ njxs ] + +nj11 :: [Integer] -> [Integer] -> Q [[Integer]] +nj11 njxs njys = [ [ x + y | y <- toQ njys, x > y, x < y * 2 ] | x <- toQ njxs ] + +nj12 :: [Integer] -> [Integer] -> [Integer] -> Q [[[(Integer, Integer, Integer)]]] +nj12 njxs njys njzs = + [ [ [ tup3 x y z | z <- toQ njzs, y == z ] + | y <- toQ njys + , x == y + ] + | x <- toQ njxs + ] + +np1 :: [Integer] -> [Integer] -> Q [[Integer]] +np1 njxs njys = [ [ x * y * 2 | y <- toQ njys ] | x <- toQ njxs ] + + +np2 :: [Integer] -> [Integer] -> Q [(Integer, [Integer])] +np2 njxs njys = [ pair x [ y * 2 | y <- toQ njys ] | x <- toQ njxs ] + +np3 :: [Integer] -> [Integer] -> Q [[Integer]] +np3 njxs njys = [ [ x + y | y <- toQ njys ] | x <- toQ njxs ] + +np4 :: [Integer] -> [Integer] -> Q [[Integer]] +np4 njxs njys = [ [ y | y <- toQ njys, x > y ] | x <- toQ njxs ] + +njg1 :: [Integer] -> [(Integer, Integer)] -> Q [Integer] +njg1 njgxs njgzs = + [ x + | x <- toQ njgxs + , x < 8 + , sum [ snd z | z <- toQ njgzs, fst z == x ] > 100 + ] + +njg2 :: [Integer] -> [Integer] -> Q [Integer] +njg2 njgxs njgys = + [ x + | x <- toQ njgxs + , and [ y > 1 | y <- toQ njgys, x == y ] + , x < 8 + ] + +njg3 :: [Integer] -> [Integer] -> [(Integer, Integer)] -> Q [(Integer, Integer)] +njg3 njgxs njgys njgzs = + [ pair x y + | x <- toQ njgxs + , y <- toQ njgys + , length [ toQ () | z <- toQ njgzs, fst z == x ] > 2 + ] + +njg4 :: [Integer] -> [Integer] -> [(Integer, Integer)] -> Q [Integer] +njg4 njgxs njgys njgzs = + [ x + | x <- toQ njgxs + , length [ toQ () | y <- toQ njgys, x == y ] + > length [ toQ () | z <- toQ njgzs, fst z == x ] + ] + +njg5 :: [Integer] -> [Integer] -> Q [Integer] +njg5 njgxs njgys = + [ x + | x <- toQ njgxs + , sum [ y | y <- toQ njgys, x < y, y > 5 ] < 10 + ] + +-------------------------------------------------------------------------------- +-- Comprehensions for QuickCheck antijoin/semijoin tests + +aj_class12 :: Q ([Integer], [Integer]) -> Q [Integer] +aj_class12 (view -> (xs, ys)) = + [ x + | x <- xs + , and [ x == y | y <- ys, y > 10 ] + ] + +aj_class15 :: Q ([Integer], [Integer]) -> Q [Integer] +aj_class15 (view -> (xs, ys)) = + [ x + | x <- xs + , and [ y `mod` 4 == 0 | y <- ys, x < y ] + ] + +aj_class16 :: Q ([Integer], [Integer]) -> Q [Integer] +aj_class16 (view -> (xs, ys)) = + [ x + | x <- xs + , and [ y <= 2 * x | y <- ys, x < y ] + ] + + + +-------------------------------------------------------------------------------- +-- Comprehensions for + +backdep :: Q [[Integer]] -> Q [Integer] +backdep xss = [ x | xs <- xss, x <- xs ] + +backdep_filter :: Q [[Integer]] -> Q [Integer] +backdep_filter xss = [ x | xs <- xss, x <- xs, length xs > x ] + +backdep2 :: Q [[Integer]] -> Q [[Integer]] +backdep2 xss = [ [ x * 42 | x <- xs ] | xs <- xss ] + +backdep3 :: Q [[Integer]] -> Q [[Integer]] +backdep3 xss = [ [ x + length xs | x <- xs ] | xs <- xss ] + +backdep4 :: Q [[[Integer]]] -> Q [[[Integer]]] +backdep4 xsss = [ [ [ x + length xs + length xss + | x <- xs + ] + | xs <- xss + ] + | xss <- xsss + ] + +backdep5 :: Q [[Integer]] -> Q [[Integer]] +backdep5 xss = [ [ x + length xs | x <- take (length xs - 3) xs ] | xs <- xss ] + +deep_iter :: Q ([Integer], [Integer], [Integer], [Integer], [Integer]) -> Q [[[[Integer]]]] +deep_iter (view -> (ws1, ws2, xs, ys, zs)) = + [ [ [ [ w1 * 23 - y | w1 <- ws1 ] + ++ + [ w2 + 42 - y | w2 <- ws2 ] + | z <- zs + , z > x + ] + | y <- ys + ] + | x <- xs + ] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,694 +1,60 @@ -{-# LANGUAGE TemplateHaskell, GADTs, TypeFamilies, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -Wall -O3 -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wall -O3 -fno-warn-orphans -fno-warn-overlapping-patterns #-} module Main where + +import ComprehensionTests +import CombinatorTests -import qualified Database.DSH as Q -import Database.DSH (Q, QA) +#ifdef TESTSQL +import Database.HDBC.PostgreSQL +#endif --- import Database.DSH.Interpreter (fromQ) -import Database.DSH.Compiler (fromQ) +import System.Environment +import Test.Framework (Test, defaultMainWithArgs) +import Test.QuickCheck -import qualified Database.HDBC as HDBC -import Database.HDBC.PostgreSQL +import Data.List -import Test.QuickCheck -import Test.QuickCheck.Monadic -import Data.DeriveTH - -import Data.List -import Data.Maybe -import Data.Either -import GHC.Exts - -import Data.Text (Text) -import qualified Data.Text as Text - -import Data.Char - -instance Arbitrary Text where - arbitrary = fmap Text.pack arbitrary - -data D0 = C01 deriving (Eq,Ord,Show) -derive makeArbitrary ''D0 -Q.deriveDSH ''D0 - -data D1 a = C11 a deriving (Eq,Ord,Show) -derive makeArbitrary ''D1 -Q.deriveDSH ''D1 - -data D2 a b = C21 a b b a deriving (Eq,Ord,Show) -derive makeArbitrary ''D2 -Q.deriveDSH ''D2 - -data D3 = C31 | C32 deriving (Eq,Ord,Show) -derive makeArbitrary ''D3 -Q.deriveDSH ''D3 - -data D4 a = C41 a | C42 deriving (Eq,Ord,Show) -derive makeArbitrary ''D4 -Q.deriveDSH ''D4 - -data D5 a = C51 a | C52 | C53 a a | C54 a a a deriving (Eq,Ord,Show) -derive makeArbitrary ''D5 -Q.deriveDSH ''D5 - -data D6 a b c d e = C61 { c611 :: a, c612 :: (a,b,c,d) } | C62 | C63 a b | C64 (a,b,c) | C65 a b c d e deriving (Eq,Ord,Show) -derive makeArbitrary ''D6 -Q.deriveDSH ''D6 - +#ifdef TESTSQL getConn :: IO Connection -getConn = connectPostgreSQL "user = 'giorgidz' password = '' host = 'localhost' dbname = 'giorgidz'" +getConn = connectPostgreSQL "user = 'au' password = 'foobar' host = 'localhost' dbname = 'test'" +#endif -qc:: Testable prop => prop -> IO () +qc :: Testable prop => prop -> IO () qc = quickCheckWith stdArgs{maxSuccess = 100, maxSize = 5} putStrPad :: String -> IO () putStrPad s = putStr (s ++ replicate (32 - length s) ' ' ) + main :: IO () main = do - putStrLn "Supprted Types" - putStrLn "--------------" - putStrPad "()" - qc prop_unit - putStrPad "Bool" - qc prop_bool - putStrPad "Char" - qc prop_char - putStrPad "Text" - qc prop_text - putStrPad "Integer" - qc prop_integer - putStrPad "Double" - qc prop_double - putStrPad "[Integer]" - qc prop_list_integer_1 - putStrPad "[[Integer]]" - qc prop_list_integer_2 - putStrPad "[[[Integer]]]" - qc prop_list_integer_3 - putStrPad "Maybe Integer" - qc prop_maybe_integer - putStrPad "Either Integer Integer: " - qc prop_either_integer - putStrPad "D0: " - qc prop_d0 - putStrPad "D1: " - qc prop_d1 - putStrPad "D2: " - qc prop_d2 - putStrPad "D3: " - qc prop_d3 - putStrPad "D4: " - qc prop_d4 - putStrPad "D5: " - qc prop_d5 - putStrPad "D6: " - qc prop_d6 - - putStrLn "" - putStrLn "Equality, Boolean Logic and Ordering" - putStrLn "------------------------------------" - putStrPad "&&" - qc prop_infix_and - putStrPad "||" - qc prop_infix_or - putStrPad "not" - qc prop_not - putStrPad "eq" - qc prop_eq - putStrPad "neq" - qc prop_neq - putStrPad "cond" - qc prop_cond - putStrPad "lt" - qc prop_lt - putStrPad "lte" - qc prop_lte - putStrPad "gt" - qc prop_gt - putStrPad "gte" - qc prop_gte - putStrPad "min_integer" - qc prop_min_integer - putStrPad "min_double" - qc prop_min_double - putStrPad "max_integer" - qc prop_max_integer - putStrPad "max_double" - qc prop_max_double - - putStrLn "" - putStrLn "Tuples" - putStrLn "------" - putStrPad "fst" - qc prop_fst - putStrPad "snd" - qc prop_snd - - putStrLn "" - putStrLn "Numerics:" - putStrLn "-----------" - putStrPad "add_integer" - qc prop_add_integer - putStrPad "add_double" - qc prop_add_double - putStrPad "mul_integer" - qc prop_mul_integer - putStrPad "mul_double" - qc prop_mul_double - putStrPad "div_double" - qc prop_div_double - putStrPad "integer_to_double: " - qc prop_integer_to_double - putStrPad "abs_integer" - qc prop_abs_integer - putStrPad "abs_double" - qc prop_abs_double - putStrPad "signum_integer: " - qc prop_signum_integer - putStrPad "signum_double" - qc prop_signum_double - putStrPad "negate_integer: " - qc prop_negate_integer - putStrPad "negate_double" - qc prop_negate_double - - putStrLn "" - putStrLn "Maybe" - putStrLn "-----" - putStrPad "maybe" - qc prop_maybe - putStrPad "just" - qc prop_just - putStrPad "isJust" - qc prop_isJust - putStrPad "isNothing" - qc prop_isNothing - putStrPad "fromJust" - qc prop_fromJust - putStrPad "fromMaybe" - qc prop_fromMaybe - putStrPad "listToMaybe" - qc prop_listToMaybe - putStrPad "maybeToList" - qc prop_maybeToList - putStrPad "catMaybes" - qc prop_catMaybes - putStrPad "mapMaybe" - qc prop_mapMaybe - - putStrLn "" - putStrLn "Either" - putStrLn "-----" - putStrPad "left" - qc prop_left - putStrPad "right" - qc prop_right - putStrPad "isLeft" - qc prop_isLeft - putStrPad "isRight" - qc prop_isRight - putStrPad "either" - qc prop_either - putStrPad "lefts" - qc prop_lefts - putStrPad "rights" - qc prop_rights - putStrPad "partitionEithers" - qc prop_partitionEithers - - putStrLn "" - putStrLn "Lists" - putStrLn "-----" - putStrPad "head" - qc prop_head - putStrPad "tail" - qc prop_tail - putStrPad "cons" - qc prop_cons - putStrPad "snoc" - qc prop_snoc - putStrPad "take" - qc prop_take - putStrPad "drop" - qc prop_drop - putStrPad "map" - qc prop_map - putStrPad "filter" - qc prop_filter - putStrPad "last" - qc prop_last - putStrPad "init" - qc prop_init - putStrPad "null" - qc prop_null - putStrPad "length" - qc prop_length - putStrPad "index" - qc prop_index - putStrPad "reverse" - qc prop_reverse - putStrPad "append" - qc prop_append - putStrPad "groupWith" - qc prop_groupWith - putStrPad "sortWith" - qc prop_sortWith - putStrPad "and" - qc prop_and - putStrPad "or" - qc prop_or - putStrPad "any_zero" - qc prop_any_zero - putStrPad "all_zero" - qc prop_all_zero - putStrPad "sum_integer" - qc prop_sum_integer - putStrPad "sum_double" - qc prop_sum_double - putStrPad "concat" - qc prop_concat - putStrPad "concatMap" - qc prop_concatMap - putStrPad "maximum" - qc prop_maximum - putStrPad "minimum" - qc prop_minimum - putStrPad "splitAt" - qc prop_splitAt - putStrPad "takeWhile" - qc prop_takeWhile - putStrPad "dropWhile" - qc prop_dropWhile - putStrPad "span" - qc prop_span - putStrPad "break" - qc prop_break - putStrPad "elem" - qc prop_elem - putStrPad "notElem" - qc prop_notElem - putStrPad "lookup" - qc prop_lookup - putStrPad "zip" - qc prop_zip - putStrPad "zip3" - qc prop_zip3 - putStrPad "zipWith" - qc prop_zipWith - putStrPad "zipWith3" - qc prop_zipWith3 - putStrPad "unzip" - qc prop_unzip - putStrPad "unzip3" - qc prop_unzip3 - putStrPad "nub" - qc prop_nub - -makeProp :: (Eq b, QA a, QA b, Show a, Show b) - => (Q a -> Q b) - -> (a -> b) - -> a - -> Property -makeProp f1 f2 arg = monadicIO $ do - c <- run getConn - db <- run $ fromQ c $ f1 (Q.toQ arg) - run (HDBC.disconnect c) - let hs = f2 arg - assert (db == hs) - -makePropNotNull :: (Eq b, QA a, QA b, Show a, Show b) - => (Q [a] -> Q b) - -> ([a] -> b) - -> [a] - -> Property -makePropNotNull q f arg = not (null arg) ==> makeProp q f arg - -makePropDouble :: (QA a, Show a) - => (Q a -> Q Double) - -> (a -> Double) - -> a - -> Property -makePropDouble f1 f2 arg = monadicIO $ do - c <- run getConn - db <- run $ fromQ c $ f1 (Q.toQ arg) - run $ HDBC.disconnect c - let hs = f2 arg - let eps = 1.0E-8 :: Double; - assert (abs (db - hs) < eps) - -uncurryQ :: (QA a, QA b) => (Q a -> Q b -> Q c) -> Q (a,b) -> Q c -uncurryQ f = uncurry f . Q.view - --- * Supported Types - -prop_unit :: () -> Property -prop_unit = makeProp id id - -prop_bool :: Bool -> Property -prop_bool = makeProp id id - -prop_integer :: Integer -> Property -prop_integer = makeProp id id - -prop_double :: Double -> Property -prop_double = makePropDouble id id - -prop_char :: Char -> Property -prop_char c = isPrint c ==> makeProp id id c - -prop_text :: Text -> Property -prop_text t = Text.all isPrint t ==> makeProp id id t - -prop_list_integer_1 :: [Integer] -> Property -prop_list_integer_1 = makeProp id id - -prop_list_integer_2 :: [[Integer]] -> Property -prop_list_integer_2 = makeProp id id - -prop_list_integer_3 :: [[[Integer]]] -> Property -prop_list_integer_3 = makeProp id id - -prop_maybe_integer :: Maybe Integer -> Property -prop_maybe_integer = makeProp id id - -prop_either_integer :: Either Integer Integer -> Property -prop_either_integer = makeProp id id - -prop_d0 :: D0 -> Property -prop_d0 = makeProp id id - -prop_d1 :: D1 Integer -> Property -prop_d1 = makeProp id id - -prop_d2 :: D2 Integer Integer -> Property -prop_d2 = makeProp id id - -prop_d3 :: D3 -> Property -prop_d3 = makeProp id id - -prop_d4 :: D4 Integer -> Property -prop_d4 = makeProp id id - -prop_d5 :: D5 Integer -> Property -prop_d5 = makeProp id id - -prop_d6 :: D6 Integer Integer Integer Integer Integer -> Property -prop_d6 = makeProp id id - --- * Equality, Boolean Logic and Ordering - -prop_infix_and :: (Bool,Bool) -> Property -prop_infix_and = makeProp (uncurryQ (Q.&&)) (uncurry (&&)) - -prop_infix_or :: (Bool,Bool) -> Property -prop_infix_or = makeProp (uncurryQ (Q.||)) (uncurry (||)) - -prop_not :: Bool -> Property -prop_not = makeProp Q.not not - -prop_eq :: (Integer,Integer) -> Property -prop_eq = makeProp (uncurryQ (Q.==)) (uncurry (==)) - -prop_neq :: (Integer,Integer) -> Property -prop_neq = makeProp (uncurryQ (Q./=)) (uncurry (/=)) - -prop_cond :: Bool -> Property -prop_cond = makeProp (\b -> Q.cond b 0 1) (\b -> if b then (0 :: Integer) else 1) - -prop_lt :: (Integer, Integer) -> Property -prop_lt = makeProp (uncurryQ (Q.<)) (uncurry (<)) - -prop_lte :: (Integer, Integer) -> Property -prop_lte = makeProp (uncurryQ (Q.<=)) (uncurry (<=)) - -prop_gt :: (Integer, Integer) -> Property -prop_gt = makeProp (uncurryQ (Q.>)) (uncurry (>)) - -prop_gte :: (Integer, Integer) -> Property -prop_gte = makeProp (uncurryQ (Q.>=)) (uncurry (>=)) - -prop_min_integer :: (Integer,Integer) -> Property -prop_min_integer = makeProp (uncurryQ Q.min) (uncurry min) - -prop_max_integer :: (Integer,Integer) -> Property -prop_max_integer = makeProp (uncurryQ Q.max) (uncurry max) - -prop_min_double :: (Double,Double) -> Property -prop_min_double = makePropDouble (uncurryQ Q.min) (uncurry min) - -prop_max_double :: (Double,Double) -> Property -prop_max_double = makePropDouble (uncurryQ Q.max) (uncurry max) - --- * Maybe - -prop_maybe :: (Integer, Maybe Integer) -> Property -prop_maybe = makeProp (\a -> Q.maybe (Q.fst a) id (Q.snd a)) (\(i,mi) -> maybe i id mi) - -prop_just :: Integer -> Property -prop_just = makeProp Q.just Just - -prop_isJust :: Maybe Integer -> Property -prop_isJust = makeProp Q.isJust isJust - -prop_isNothing :: Maybe Integer -> Property -prop_isNothing = makeProp Q.isNothing isNothing - -prop_fromJust :: Maybe Integer -> Property -prop_fromJust mi = isJust mi ==> makeProp Q.fromJust fromJust mi - -prop_fromMaybe :: (Integer,Maybe Integer) -> Property -prop_fromMaybe = makeProp (uncurryQ Q.fromMaybe) (uncurry fromMaybe) - -prop_listToMaybe :: [Integer] -> Property -prop_listToMaybe = makeProp Q.listToMaybe listToMaybe - -prop_maybeToList :: Maybe Integer -> Property -prop_maybeToList = makeProp Q.maybeToList maybeToList - -prop_catMaybes :: [Maybe Integer] -> Property -prop_catMaybes = makeProp Q.catMaybes catMaybes - -prop_mapMaybe :: [Maybe Integer] -> Property -prop_mapMaybe = makeProp (Q.mapMaybe id) (mapMaybe id) - --- * Either - -prop_left :: Integer -> Property -prop_left = makeProp (Q.left :: Q Integer -> Q (Either Integer Integer)) Left - -prop_right :: Integer -> Property -prop_right = makeProp (Q.right :: Q Integer -> Q (Either Integer Integer)) Right - -prop_isLeft :: Either Integer Integer -> Property -prop_isLeft = makeProp Q.isLeft (\e -> case e of {Left _ -> True; Right _ -> False;}) - -prop_isRight :: Either Integer Integer -> Property -prop_isRight = makeProp Q.isRight (\e -> case e of {Left _ -> False; Right _ -> True;}) - -prop_either :: Either Integer Integer -> Property -prop_either = makeProp (Q.either id id) (either id id) - -prop_lefts :: [Either Integer Integer] -> Property -prop_lefts = makeProp Q.lefts lefts - -prop_rights :: [Either Integer Integer] -> Property -prop_rights = makeProp Q.rights rights - -prop_partitionEithers :: [Either Integer Integer] -> Property -prop_partitionEithers = makeProp Q.partitionEithers partitionEithers - --- * Lists - -prop_cons :: (Integer, [Integer]) -> Property -prop_cons = makeProp (uncurryQ (Q.<|)) (uncurry (:)) - -prop_snoc :: ([Integer], Integer) -> Property -prop_snoc = makeProp (uncurryQ (Q.|>)) (\(a,b) -> a ++ [b]) - -prop_singleton :: Integer -> Property -prop_singleton = makeProp Q.singleton (: []) - -prop_head :: [Integer] -> Property -prop_head = makePropNotNull Q.head head - -prop_tail :: [Integer] -> Property -prop_tail = makePropNotNull Q.tail tail - -prop_last :: [Integer] -> Property -prop_last = makePropNotNull Q.last last - -prop_init :: [Integer] -> Property -prop_init = makePropNotNull Q.init init - -prop_index :: ([Integer], Integer) -> Property -prop_index (l, i) = - i > 0 && i < fromIntegral (length l) - ==> makeProp (uncurryQ (Q.!!)) - (\(a,b) -> a !! fromIntegral b) - (l, i) - -prop_take :: (Integer, [Integer]) -> Property -prop_take = makeProp (uncurryQ Q.take) (\(n,l) -> take (fromIntegral n) l) - -prop_drop :: (Integer, [Integer]) -> Property -prop_drop = makeProp (uncurryQ Q.drop) (\(n,l) -> drop (fromIntegral n) l) - -prop_map :: [Integer] -> Property -prop_map = makeProp (Q.map id) (map id) - -prop_append :: ([Integer], [Integer]) -> Property -prop_append = makeProp (uncurryQ (Q.++)) (uncurry (++)) - -prop_filter :: [Integer] -> Property -prop_filter = makeProp (Q.filter (const $ Q.toQ True)) (filter $ const True) - -prop_groupWith :: [Integer] -> Property -prop_groupWith = makeProp (Q.groupWith id) (groupWith id) - -prop_sortWith :: [Integer] -> Property -prop_sortWith = makeProp (Q.sortWith id) (sortWith id) - -prop_null :: [Integer] -> Property -prop_null = makeProp Q.null null - -prop_length :: [Integer] -> Property -prop_length = makeProp Q.length ((fromIntegral :: Int -> Integer) . length) - -prop_reverse :: [Integer] -> Property -prop_reverse = makeProp Q.reverse reverse - -prop_and :: [Bool] -> Property -prop_and = makeProp Q.and and - -prop_or :: [Bool] -> Property -prop_or = makeProp Q.or or - -prop_any_zero :: [Integer] -> Property -prop_any_zero = makeProp (Q.any (Q.== 0)) (any (== 0)) - -prop_all_zero :: [Integer] -> Property -prop_all_zero = makeProp (Q.all (Q.== 0)) (all (== 0)) - -prop_sum_integer :: [Integer] -> Property -prop_sum_integer = makeProp Q.sum sum - -prop_sum_double :: [Double] -> Property -prop_sum_double = makePropDouble Q.sum sum - -prop_concat :: [[Integer]] -> Property -prop_concat = makeProp Q.concat concat - -prop_concatMap :: [Integer] -> Property -prop_concatMap = makeProp (Q.concatMap Q.singleton) (concatMap (: [])) - -prop_maximum :: [Integer] -> Property -prop_maximum = makePropNotNull Q.maximum maximum - -prop_minimum :: [Integer] -> Property -prop_minimum = makePropNotNull Q.minimum minimum - -prop_splitAt :: (Integer, [Integer]) -> Property -prop_splitAt = makeProp (uncurryQ Q.splitAt) (\(a,b) -> splitAt (fromIntegral a) b) - -prop_takeWhile :: (Integer, [Integer]) -> Property -prop_takeWhile = makeProp (uncurryQ $ Q.takeWhile . (Q.==)) - (uncurry $ takeWhile . (==)) - -prop_dropWhile :: (Integer, [Integer]) -> Property -prop_dropWhile = makeProp (uncurryQ $ Q.dropWhile . (Q.==)) - (uncurry $ dropWhile . (==)) - -prop_span :: (Integer, [Integer]) -> Property -prop_span = makeProp (uncurryQ $ Q.span . (Q.==)) - (uncurry $ span . (==) . fromIntegral) - -prop_break :: (Integer, [Integer]) -> Property -prop_break = makeProp (uncurryQ $ Q.break . (Q.==)) - (uncurry $ break . (==) . fromIntegral) - -prop_elem :: (Integer, [Integer]) -> Property -prop_elem = makeProp (uncurryQ Q.elem) - (uncurry elem) - -prop_notElem :: (Integer, [Integer]) -> Property -prop_notElem = makeProp (uncurryQ Q.notElem) - (uncurry notElem) - -prop_lookup :: (Integer, [(Integer,Integer)]) -> Property -prop_lookup = makeProp (uncurryQ Q.lookup) - (uncurry lookup) - -prop_zip :: ([Integer], [Integer]) -> Property -prop_zip = makeProp (uncurryQ Q.zip) (uncurry zip) - -prop_zipWith :: ([Integer], [Integer]) -> Property -prop_zipWith = makeProp (uncurryQ $ Q.zipWith (+)) (uncurry $ zipWith (+)) - -prop_unzip :: [(Integer, Integer)] -> Property -prop_unzip = makeProp Q.unzip unzip - -prop_zip3 :: ([Integer], [Integer],[Integer]) -> Property -prop_zip3 = makeProp (\q -> (case Q.view q of (as,bs,cs) -> Q.zip3 as bs cs)) - (\(as,bs,cs) -> zip3 as bs cs) - -prop_zipWith3 :: ([Integer], [Integer],[Integer]) -> Property -prop_zipWith3 = makeProp (\q -> (case Q.view q of (as,bs,cs) -> Q.zipWith3 (\a b c -> a + b + c) as bs cs)) - (\(as,bs,cs) -> zipWith3 (\a b c -> a + b + c) as bs cs) - -prop_unzip3 :: [(Integer, Integer, Integer)] -> Property -prop_unzip3 = makeProp Q.unzip3 unzip3 - -prop_nub :: [Integer] -> Property -prop_nub = makeProp Q.nub nub - --- * Tuples - -prop_fst :: (Integer, Integer) -> Property -prop_fst = makeProp Q.fst fst - -prop_snd :: (Integer, Integer) -> Property -prop_snd = makeProp Q.snd snd - --- * Numerics - -prop_add_integer :: (Integer,Integer) -> Property -prop_add_integer = makeProp (uncurryQ (+)) (uncurry (+)) - -prop_add_double :: (Double,Double) -> Property -prop_add_double = makePropDouble (uncurryQ (+)) (uncurry (+)) - -prop_mul_integer :: (Integer,Integer) -> Property -prop_mul_integer = makeProp (uncurryQ (*)) (uncurry (*)) - -prop_mul_double :: (Double,Double) -> Property -prop_mul_double = makePropDouble (uncurryQ (*)) (uncurry (*)) - -prop_div_double :: (Double,Double) -> Property -prop_div_double (x,y) = - y /= 0 - ==> makePropDouble (uncurryQ (/)) (uncurry (/)) (x,y) - -prop_integer_to_double :: Integer -> Property -prop_integer_to_double = makePropDouble Q.integerToDouble fromInteger - -prop_abs_integer :: Integer -> Property -prop_abs_integer = makeProp Q.abs abs - -prop_abs_double :: Double -> Property -prop_abs_double = makePropDouble Q.abs abs - -prop_signum_integer :: Integer -> Property -prop_signum_integer = makeProp Q.signum signum - -prop_signum_double :: Double -> Property -prop_signum_double = makePropDouble Q.signum signum - -prop_negate_integer :: Integer -> Property -prop_negate_integer = makeProp Q.negate negate + args <- getArgs + let args' = if or $ map (isPrefixOf "-s") args + then args + else "-s5":args + defaultMainWithArgs tests args' -prop_negate_double :: Double -> Property -prop_negate_double = makePropDouble Q.negate negate +tests :: [Test] +tests = + [ tests_types + , tests_tuples + , tests_join_hunit + , tests_nest_head_hunit + , tests_nest_guard_hunit + , tests_combinators_hunit + , tests_comprehensions + , tests_boolean + , tests_numerics + , tests_maybe + , tests_either + , tests_lists + , tests_lifted + ] diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 --- a/tests/Makefile +++ /dev/null @@ -1,12 +0,0 @@ -all: cabal - ghc --make Main.hs -o Main - ./Main - -cabal: clean - cabal install quickcheck - cabal install hdbc-postgresql - cabal install derive - cd ..; cabal install; cd tests; - -clean: - rm -rf tmp .hpc *.html *.tix *.o *.hi Main diff --git a/tests/Manual.hs b/tests/Manual.hs new file mode 100644 --- /dev/null +++ b/tests/Manual.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where + + +import qualified Prelude as P +import Database.DSH +import Database.DSH.Compiler + +import Database.HDBC.PostgreSQL + +import qualified Data.Text as T + +import TPCH + +data Foo = Foo { foo1 :: Integer, foo2 :: Text, foo3 :: Integer } + +deriveDSH ''Foo +deriveTA ''Foo +generateTableSelectors ''Foo + +getConn :: IO Connection +getConn = connectPostgreSQL "user = 'au' password = 'foobar' host = 'localhost' port = '5432' dbname = 'tpch'" + +xs :: Q [(Integer, Integer)] +xs = toQ [(3,5),(4,6),(5,7),(6,9)] + +ys :: Q [Integer] +ys = toQ [1,2,3,4] + +bar :: Q [(Integer, Integer, Integer)] +bar = [ triple a c 42 | (view -> (a, b, c)) <- toQ ([(1,2,3), (4,5,6), (7,8,9)] :: [(Integer, Integer, Integer)]) ] + +{- +li :: Q [(Integer, Text, Double)] +li = [ tup3 (l_linenumberQ l) (l_returnflagQ l) (l_discountQ l) + | l <- lineitems + , l_taxQ l > 5.0 + ] +-} + +data Range = Range { start :: Integer, end :: Integer } + +deriveDSH ''Range + +avgBalance :: Q [Customer] -> Q Double +avgBalance cs = + avg [ c_acctbalQ c | c <- cs, c_acctbalQ c > 0.0 ] + +ordersOf :: Q Customer -> Q [Order] +ordersOf c = + [ o | o <- orders, o_custkeyQ o == c_custkeyQ c ] + +potentialCustomers :: Q [Customer] -> Q [Customer] +potentialCustomers cs = + [ c | c <- cs, + c_acctbalQ c > avgBalance cs, length (ordersOf c) == 0 ] + +countryCodeOf :: Q Customer -> Q Text +countryCodeOf c = subString 1 2 (c_phoneQ c) + +livesIn :: Q Customer -> [Text] -> Q Bool +livesIn c countries = countryCodeOf c `elem` toQ countries + +q22 :: [Text] -> Q [(Text, Integer, Double)] +q22 countries = + sortWith (\(view -> (country, _, _)) -> country) + [ tup3 country (length custs) (sum (map c_acctbalQ custs)) | + (view -> (country, custs)) <- groupWithKey countryCodeOf pots ] + where + pots = potentialCustomers [ c | c <- customers, + c `livesIn` countries ] + +minSupplyCost :: Q Integer -> Q Double +minSupplyCost partkey = + minimum $ + [ ps_supplycostQ ps + | ps <- partsupps + , s <- suppliers + , n <- nations + , r <- regions + , partkey == ps_partkeyQ ps + , s_suppkeyQ s == ps_suppkeyQ ps + , s_nationkeyQ s == n_nationkeyQ n + , n_regionkeyQ n == r_regionkeyQ r + , r_nameQ r == (toQ "EUROPE") + ] + +sortingCriteria + :: Q (Double, Text, Text, Integer, Text, Text, Text, Text) + -> Q (Double, Text, Text, Integer) +sortingCriteria (view -> (b, sn, nn, pk, _, _, _, _)) = + tup4 (b * (toQ $ -1.0)) nn sn pk + +q2 :: Q [(Double, Text, Text, Integer, Text, Text, Text, Text)] +q2 = + sortWith sortingCriteria $ + [ tup8 (s_acctbalQ s) + (s_nameQ s) + (n_nameQ n) + (p_partkeyQ p) + (p_mfgrQ p) + (s_addressQ s) + (s_phoneQ s) + (s_commentQ s) + | p <- parts + , ps <- partsupps + , s <- suppliers + , n <- nations + , r <- regions + , p_partkeyQ p == ps_partkeyQ ps + , s_suppkeyQ s == ps_suppkeyQ ps + , p_sizeQ p == (toQ 15) + , p_typeQ p `like` (toQ "%BRASS") + , s_nationkeyQ s == n_nationkeyQ n + , n_regionkeyQ n == r_regionkeyQ r + , r_nameQ r == (toQ "EUROPE") + , ps_supplycostQ ps == minSupplyCost (p_partkeyQ p) + ] + +orderQuantity :: Q [LineItem] -> Q Double +orderQuantity lis = sum $ map l_quantityQ lis + +jan_q7a :: Q [LineItem] +jan_q7a = snd $ head $ sortWith (orderQuantity . snd) $ groupWithKey l_orderkeyQ lineitems + +-------------------------------------------------------------------------------- +-- Query written from a database viewpoint + +-- List the lineitems of the order with the most parts. +sumPerOrder :: Q [(Integer, Double)] +sumPerOrder = map (\(view -> (ok, lis)) -> pair ok (sum $ map l_quantityQ lis)) + $ groupWithKey l_orderkeyQ lineitems + +jan_q7b :: Q [LineItem] +jan_q7b = + [ l + | l <- lineitems + , (view -> (ok, nrItems)) <- sumPerOrder + , l_orderkeyQ l == ok + , nrItems == maximum(map snd sumPerOrder) + ] + +q :: Q [[Integer]] +q = map init (toQ ([] :: [[Integer]])) + +data Trade = Trade + { t_price :: Double + , t_tid :: Integer + , t_timestamp :: Integer + , t_tradeDate :: Integer + } + +deriveDSH ''Trade +deriveTA ''Trade +generateTableSelectors ''Trade + +data Portfolio = Portfolio + { po_pid :: Integer + , po_tid :: Integer + , po_tradedSince :: Integer + } + +deriveDSH ''Portfolio +deriveTA ''Portfolio +generateTableSelectors ''Portfolio + +trades :: Q [Trade] +trades = table "trades" $ TableHints [ Key ["t_tid", "t_timestamp"] ] NonEmpty + +portfolios :: Q [Portfolio] +portfolios = table "portfolio" $ TableHints [Key ["po_pid"] ] NonEmpty + +-------------------------------------------------------------------------------- +-- For a given date and stock, compute the best profit obtained by +-- buying the stock and selling it later. + +-- | For each list element, compute the minimum of all elements up to +-- the current one. +mins :: (Ord a, QA a, TA a) => Q [a] -> Q [a] +mins as = [ minimum [ a' | (view -> (a', i')) <- nas, i' <= i ] + | let nas = number as + , (view -> (a, i)) <- nas + ] + +{- + +Being able to write the query using a parallel comprehension would be +nice: + +maximum [ t_priceQ t - minPrice + | t <- trades' + | minPrice <- mins $ map t_priceQ trades' + ] + + +-} + + + +bestProfit :: Integer -> Integer -> Q Double +bestProfit stock date = + maximum [ t_priceQ t - minPrice + | (view -> (t, minPrice)) <- zip trades' (mins $ map t_priceQ trades') + ] + where + trades' = filter (\t -> t_tidQ t == toQ stock && t_tradeDateQ t == toQ date) + $ sortWith t_timestampQ trades + +hasNationality :: Q Customer -> Text -> Q Bool +hasNationality c nn = + or [ n_nameQ n == toQ nn && n_nationkeyQ n == c_nationkeyQ c + | n <- nations + ] + +ordersWithStatus :: Text -> Q Customer -> Q [Order] +ordersWithStatus status c = + [ o | o <- ordersOf c, o_orderstatusQ o == toQ status ] + +revenue :: Q Order -> Q Double +revenue o = sum [ l_extendedpriceQ l * (1 - l_discountQ l) + | l <- lineitems + , l_orderkeyQ l == o_orderkeyQ o + ] + +expectedRevenueFor :: Text -> Q [(Text, [(Integer, Double)])] +expectedRevenueFor nation = + [ pair (c_nameQ c) [ pair (o_orderdateQ o) (revenue o) + | o <- ordersWithStatus "P" c ] + | c <- customers + , c `hasNationality` nation + ] + +foobar = take 10 $ sortWith id $ map revenue orders + +njg3 :: [Integer] -> [Integer] -> [(Integer, Integer)] -> Q [(Integer, Integer)] +njg3 njgxs njgys njgzs = + [ pair x y + | x <- toQ njgxs + , y <- toQ njgys + , length [ toQ () | z <- toQ njgzs, fst z == x ] > 2 + ] + +njgxs1 :: [Integer] +njgxs1 = [1,2] + +njgys1 :: [Integer] +njgys1 = [2,3] + +njgzs1 :: [(Integer, Integer)] +njgzs1 = [(2, 20), (5, 60), (3, 30)] + +backdep5 :: Q [[Integer]] +backdep5 = [ [ x + length xs | x <- take (length xs - 3) xs ] | xs <- toQ ([[1,2,3], [], [4,5,6]] :: [[Integer]]) ] + +foo42 :: Q [Integer] +foo42 = filter (const $ toQ True) (toQ ([1,2,3,45] :: [Integer])) + +revenue2 :: Integer -> Q [(Integer, Double)] +revenue2 intervalFrom = + [ pair supplier_no (sum [ ep * (1 - discount) + | (view -> (_, ep, discount)) <- g + ]) + | (view -> (supplier_no, g)) <- groupWithKey (\(view -> (a, b, c)) -> a) intervalItems + ] + + where + intervalItems = [ tup3 (l_suppkeyQ l) + (l_extendedpriceQ l) + (l_discountQ l) + | l <- lineitems + , l_shipdateQ l >= toQ intervalFrom + , l_shipdateQ l <= (toQ intervalFrom) + 23 + ] + +q15 :: Integer -> Q [(Integer, (Text, Text, Text, Double))] +q15 intervalFrom = + sortWith fst + [ pair (s_suppkeyQ s) + (tup4 (s_nameQ s) + (s_addressQ s) + (s_phoneQ s) + total_rev) + | s <- suppliers + , (view -> (supplier_no, total_rev)) <- revenue2 intervalFrom + , s_suppkeyQ s == supplier_no + , total_rev == (maximum $ map snd $ revenue2 intervalFrom) + ] + +cartprod :: Q ([Integer], [Integer]) -> Q [(Integer, Integer)] +cartprod (view -> (xs, ys)) = + [ tup2 x y + | x <- xs + , y <- ys + , x == y + ] + +tup :: Q [(Integer, Integer, Integer, Integer)] +tup = map (\(view -> (a, b, c, d)) -> tup4 (a + c) (b - d) b d) (toQ ([(0,0,0,0)] :: [(Integer, Integer, Integer, Integer)])) + +frontguard :: Q [[Integer]] +frontguard = + [ [ y | x > 13, y <- toQ ([1,2,3,4] :: [Integer]), y < 3 ] + | x <- toQ ([10, 20, 30] :: [Integer]) + ] + +njxs1 :: [Integer] +njxs1 = [1,2,3,4,5,6] + +njys1 :: [Integer] +njys1 = [3,4,5,6,3,6,4,1,1,1] + +nj6 :: [Integer] -> [Integer] -> Q [(Integer, [Integer])] +nj6 njxs njys = + [ pair x [ y | y <- toQ njys, x + y > 10, y < 7 ] + | x <- toQ njxs + ] + +nj9 :: [Integer] -> [Integer] -> Q [[Integer]] +nj9 njxs njys = [ [ x + y | y <- toQ njys, x + 1 == y, y > 2, x < 6 ] | x <- toQ njxs ] + +backdep3 :: Q [[Integer]] -> Q [[Integer]] +backdep3 xss = [ [ x + length xs | x <- xs ] | xs <- xss ] + +backdep4 :: Q [[[Integer]]] -> Q [[[Integer]]] +backdep4 xsss = [ [ [ x + length xs + length xss + | x <- xs + ] + | xs <- xss + ] + | xss <- xsss + ] + +q23 :: [[[Integer]]] -> Q [[(Integer, [[Integer]])]] +q23 xsss = map (groupWithKey length) (toQ xsss) + +-- Test data for testcase hnj12 +njxs2, njys2, njzs2 :: [Integer] +njxs2 = [1,2,3,4,5,5,2] +njys2 = [2,1,0,5,4,4,4] +njzs2 = [6,1,1,3,2,5] + +nj12 :: [Integer] -> [Integer] -> [Integer] -> Q [[[(Integer, Integer, Integer)]]] +nj12 njxs njys njzs = + [ [ [ tup3 x y z | z <- toQ njzs, y == z ] + | y <- toQ njys + , x == y + ] + | x <- toQ njxs + ] + +main :: IO () +main = getConn P.>>= \c -> debugQ "q" c (nj12 njxs2 njys2 njzs2) P.>>= \r -> putStrLn (show r) +-- main = runQX100 x100Conn q P.>>= \r -> putStrLn $ show r +--main = debugQX100 "q" x100Conn q