packages feed

DSH 0.8.2.3 → 0.10.0.0

raw patch · 113 files changed

+22237/−3180 lines, 113 filesdep +DSHdep +HDBC-postgresqldep +HUnitdep −FerryCoredep −HaXmldep −Pathfinderdep ~basedep ~bytestringdep ~containersnew-component:exe:manualnew-component:exe:vldotnew-uploader

Dependencies added: DSH, HDBC-postgresql, HUnit, QuickCheck, aeson, algebra-dag, algebra-sql, ansi-wl-pprint, dlist, either, kure, pretty, semigroups, set-monad, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependencies removed: FerryCore, HaXml, Pathfinder, array, csv

Dependency ranges changed: base, bytestring, containers, template-haskell, text

Files

DSH.cabal view
@@ -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. <http://db.inf.uni-tuebingen.de/files/giorgidze/ifl2010.pdf>+  Please read the release notes in 'README.md'.   .-  2. <http://db.inf.uni-tuebingen.de/files/giorgidze/haskell2011.pdf>+  1. <http://db.inf.uni-tuebingen.de/staticfiles/publications/ferryhaskell.pdf>   .-  3. <http://db.inf.uni-tuebingen.de/files/giorgidze/adtq.pdf>+  2. <http://db.inf.uni-tuebingen.de/staticfiles/publications/haskell2011.pdf>  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
examples/Example01.hs view
@@ -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
examples/Example02.hs view
@@ -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
examples/Example03.hs view
@@ -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+-- <http://www.tpc.org/tpch/>. 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)                   ]
− examples/Makefile 
@@ -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
+ examples/dshify-tpch.sql view
@@ -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;
src/Database/DSH.hs view
@@ -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   )
+ src/Database/DSH/CL/Kure.hs view
@@ -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 (<*>) #-}
+ src/Database/DSH/CL/Lang.hs view
@@ -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++
+ src/Database/DSH/CL/Opt.hs view
@@ -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
+ src/Database/DSH/CL/Opt/AntiJoin.hs view
@@ -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)
+ src/Database/DSH/CL/Opt/Auxiliary.hs view
@@ -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"
+ src/Database/DSH/CL/Opt/CompNormalization.hs view
@@ -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
+ src/Database/DSH/CL/Opt/FlatJoin.hs view
@@ -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+
+ src/Database/DSH/CL/Opt/LoopInvariant.hs view
@@ -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'
+ src/Database/DSH/CL/Opt/NestJoin.hs view
@@ -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
+ src/Database/DSH/CL/Opt/Normalize.hs view
@@ -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+
+ src/Database/DSH/CL/Opt/PartialEval.hs view
@@ -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"
+ src/Database/DSH/CL/Opt/PostProcess.hs view
@@ -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'
+ src/Database/DSH/CL/Opt/PredPushdown.hs view
@@ -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
+ src/Database/DSH/CL/Opt/Resugar.hs view
@@ -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"
+ src/Database/DSH/CL/Opt/SemiJoin.hs view
@@ -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)
+ src/Database/DSH/CL/Opt/ThetaJoin.hs view
@@ -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')
+ src/Database/DSH/CL/Primitives.hs view
@@ -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)+
− src/Database/DSH/CSV.hs 
@@ -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 ++ "'")
+ src/Database/DSH/Common/Kure.hs view
@@ -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+
+ src/Database/DSH/Common/Lang.hs view
@@ -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
+ src/Database/DSH/Common/Nat.hs view
@@ -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
+ src/Database/DSH/Common/Pretty.hs view
@@ -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) ""
+ src/Database/DSH/Common/QueryPlan.hs view
@@ -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 +            }
+ src/Database/DSH/Common/RewriteM.hs view
@@ -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+-}
+ src/Database/DSH/Common/Type.hs view
@@ -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
− src/Database/DSH/Compile.hs 
@@ -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)
src/Database/DSH/Compiler.hs view
@@ -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
+ src/Database/DSH/Execute/Backend.hs view
@@ -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
+ src/Database/DSH/Execute/Sql.hs view
@@ -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
+ src/Database/DSH/Execute/TH.hs view
@@ -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<n>' <- execNested conn lyt<n> ty<n>'+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<n>], Tuple<n>T ty1 ... ty<n>)'+    let pat = TupP [ ListP $ map VarP lytNames+                   , ConP (tupTyConstName width) (map VarP tyNames)+                   ]++    -- 'return $ TTuple $ TTuple<n> ty lyt1 ... lyt<n>'+    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<n>], Tuple<n>T ty1 ... ty<n>) -> do+--          lyt1' <- execNested conn lyt1 ty1+--          ...+--          lyt<n>' <- execNested conn lyt<n> ty<n>+--          return $ TTuple $ TTuple<n> ty lyt1 ... lyt<n>+-- @+-- +-- 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<n>)+        tupTy            = foldl' AppT (TupleT width)+                           $ map VarT tupElemTyNames+    +        -- a ~ (t1, ..., t<n>)+        tupConstraint    = EqualP (VarT tupTyName) tupTy++        -- Reify t1, ..., Reify t<n>+        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<n>+        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<n>) => Type (t1, ..., t<n>) +--                                            -> TabLayout t1 +--                                            -> ... +--                                            -> TabLayout t<n> +--                                            -> TabTuple (t1, ..., t<n>)+-- @+-- +-- Because TH does not directly support GADT syntax, we have to+-- emulate it using explicit universal quantification:+-- +-- @+-- data TabTuple a =+--     forall t1, ..., t<n>. a ~ (t1, ..., t<n>),+--                           Reify t1,+--                           ...+--                           Reify t<n> =>+--                           Type a -> TabLayout t1 -> ... -> TabLayout t<n>+-- @+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<n> ty tlyt1 ... tlyt<n>) = STuple<n> ty (segmentLayout tlyt1) +--                                                   ...+--                                                   (segmentLayout tlyt<n>)+-- @+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
+ src/Database/DSH/Export.hs view
@@ -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
− src/Database/DSH/Externals.hs 
@@ -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---}
+ src/Database/DSH/FKL/Kure.hs view
@@ -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 (<*>) #-}+
+ src/Database/DSH/FKL/Lang.hs view
@@ -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+
+ src/Database/DSH/FKL/Primitives.hs view
@@ -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)
+ src/Database/DSH/FKL/Rewrite.hs view
@@ -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
+ src/Database/DSH/Frontend/Externals.hs view
@@ -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++-}
+ src/Database/DSH/Frontend/Funs.hs view
@@ -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
+ src/Database/DSH/Frontend/Internals.hs view
@@ -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
+ src/Database/DSH/Frontend/Schema.hs view
@@ -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)
+ src/Database/DSH/Frontend/TH.hs view
@@ -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."
+ src/Database/DSH/Frontend/TupleTypes.hs view
@@ -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 (Tuple<n>E (toExp v1) ... (toExp vn))+--   frExp (TupleConstE (Tuple<n>E 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<n> :: (QA t1, ...,QA tn) => Q t1 -> ... -> Q tn -> Q (t1, ..., tn)+-- tup<n> (Q v1) ... (Q vn)= Q (TupleConstE (Tuple<n>E 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<n>)+        tupTy            = foldl' AppT (TupleT width)+                           $ map VarT tupElemTyNames+    +        -- a ~ (t1, ..., t<n>)+        tupConstraint    = EqualP (VarT tupTyName) tupTy++        -- Reify t1, ..., Reify t<n>+        reifyConstraints = map (\n -> ClassP (mkName "Reify") [VarT n]) tupElemTyNames++        constraints      = tupConstraint : reifyConstraints ++    let -- '(Exp/Type t1) ... (Exp/Type t<n>)'+        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+--     Tuple<n>E :: (Reify t1, ..., Reify t<n>) => Exp t1 +--                                              -> ... +--                                              -> Exp t<n> +--                                              -> TupleConst (t1, ..., t<n>)+-- @+-- +-- Because TH does not directly support GADT syntax, we have to+-- emulate it using explicit universal quantification:+-- +-- @+-- data TupleConst a =+--     forall t1, ..., t<n>. a ~ (t1, ..., t<n>),+--                           Reify t1,+--                           ...+--                           Reify t<n> =>+--                           Exp t1 -> ... -> Exp t<n>+-- @+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
src/Database/DSH/Impossible.hs view
@@ -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)))
− src/Database/DSH/Internals.hs 
@@ -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
− src/Database/DSH/Interpreter.hs 
@@ -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
+ src/Database/DSH/NKL/Kure.hs view
@@ -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 (<*>) #-}+
+ src/Database/DSH/NKL/Lang.hs view
@@ -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)
+ src/Database/DSH/NKL/Primitives.hs view
@@ -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_"
+ src/Database/DSH/NKL/Rewrite.hs view
@@ -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+
+ src/Database/DSH/Optimizer/Common/Auxiliary.hs view
@@ -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)
+ src/Database/DSH/Optimizer/Common/Rewrite.hs view
@@ -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
+ src/Database/DSH/Optimizer/TA/OptimizeTA.hs view
@@ -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 }
+ src/Database/DSH/Optimizer/TA/Properties/Auxiliary.hs view
@@ -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
+ src/Database/DSH/Optimizer/TA/Properties/BottomUp.hs view
@@ -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
+ src/Database/DSH/Optimizer/TA/Properties/Card1.hs view
@@ -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+
+ src/Database/DSH/Optimizer/TA/Properties/Cols.hs view
@@ -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+++
+ src/Database/DSH/Optimizer/TA/Properties/Const.hs view
@@ -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+
+ src/Database/DSH/Optimizer/TA/Properties/Empty.hs view
@@ -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
+ src/Database/DSH/Optimizer/TA/Properties/ICols.hs view
@@ -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
+ src/Database/DSH/Optimizer/TA/Properties/Keys.hs view
@@ -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++
+ src/Database/DSH/Optimizer/TA/Properties/Order.hs view
@@ -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+
+ src/Database/DSH/Optimizer/TA/Properties/TopDown.hs view
@@ -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++
+ src/Database/DSH/Optimizer/TA/Properties/Types.hs view
@@ -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
+ src/Database/DSH/Optimizer/TA/Properties/Use.hs view
@@ -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
+ src/Database/DSH/Optimizer/TA/Rewrite/Basic.hs view
@@ -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)
+ src/Database/DSH/Optimizer/TA/Rewrite/Common.hs view
@@ -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
+ src/Database/DSH/Optimizer/VL/OptimizeVL.hs view
@@ -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
+ src/Database/DSH/Optimizer/VL/Properties/BottomUp.hs view
@@ -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
+ src/Database/DSH/Optimizer/VL/Properties/Card.hs view
@@ -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
+ src/Database/DSH/Optimizer/VL/Properties/Common.hs view
@@ -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+
+ src/Database/DSH/Optimizer/VL/Properties/Const.hs view
@@ -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+
+ src/Database/DSH/Optimizer/VL/Properties/Empty.hs view
@@ -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+
+ src/Database/DSH/Optimizer/VL/Properties/NonEmpty.hs view
@@ -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+
+ src/Database/DSH/Optimizer/VL/Properties/ReqColumns.hs view
@@ -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)
+ src/Database/DSH/Optimizer/VL/Properties/TopDown.hs view
@@ -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+
+ src/Database/DSH/Optimizer/VL/Properties/Types.hs view
@@ -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)
+ src/Database/DSH/Optimizer/VL/Properties/VectorType.hs view
@@ -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))
+ src/Database/DSH/Optimizer/VL/Rewrite/Aggregation.hs view
@@ -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 |])+                     +
+ src/Database/DSH/Optimizer/VL/Rewrite/Common.hs view
@@ -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)
+ src/Database/DSH/Optimizer/VL/Rewrite/Expressions.hs view
@@ -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") |])
+ src/Database/DSH/Optimizer/VL/Rewrite/PruneEmpty.hs view
@@ -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") |])+-}
+ src/Database/DSH/Optimizer/VL/Rewrite/Redundant.hs view
@@ -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 |])
+ src/Database/DSH/Optimizer/VL/Rewrite/Unused.hs view
@@ -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") |])+-}
+ src/Database/DSH/Optimizer/VL/Rewrite/Window.hs view
@@ -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 |])
− src/Database/DSH/TH.hs 
@@ -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."
+ src/Database/DSH/Tools/VLDotGen.hs view
@@ -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
+ src/Database/DSH/Translate/Algebra2Query.hs view
@@ -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
+ src/Database/DSH/Translate/CL2NKL.hs view
@@ -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+
+ src/Database/DSH/Translate/FKL2VL.hs view
@@ -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) [])
+ src/Database/DSH/Translate/Frontend2CL.hs view
@@ -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
+ src/Database/DSH/Translate/NKL2FKL.hs view
@@ -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
+ src/Database/DSH/Translate/VL2Algebra.hs view
@@ -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
+ src/Database/DSH/VL/Lang.hs view
@@ -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
+ src/Database/DSH/VL/Primitives.hs view
@@ -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
+ src/Database/DSH/VL/Render/Dot.hs view
@@ -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
+ src/Database/DSH/VL/Render/JSON.hs view
@@ -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
+ src/Database/DSH/VL/Vector.hs view
@@ -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)
+ src/Database/DSH/VL/VectorAlgebra.hs view
@@ -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)+
+ src/Database/DSH/VL/VectorAlgebra/TA.hs view
@@ -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)
+ src/Database/DSH/VL/Vectorize.hs view
@@ -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
+ tests/CombinatorTests.hs view
@@ -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]+            ]+          ]
+ tests/ComprehensionTests.hs view
@@ -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+      ]
+ tests/DSHComprehensions.hs view
@@ -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+  ]
tests/Main.hs view
@@ -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+    ]
− tests/Makefile 
@@ -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
+ tests/Manual.hs view
@@ -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