DSH 0.10.0.2 → 0.12.0.0
raw patch · 129 files changed
+9968/−12429 lines, 129 filesdep +Decimaldep +hashabledep +processdep −DSHdep −HDBCdep −HDBC-postgresqldep ~QuickCheckdep ~algebra-dagdep ~ansi-wl-pprint
Dependencies added: Decimal, hashable, process, random, time, unordered-containers, vector
Dependencies removed: DSH, HDBC, HDBC-postgresql, algebra-sql, pretty, set-monad
Dependency ranges changed: QuickCheck, algebra-dag, ansi-wl-pprint, base, test-framework, test-framework-quickcheck2, text
Files
- DSH.cabal +115/−135
- README.md +36/−33
- src/Database/DSH.hs +14/−13
- src/Database/DSH/Backend.hs +130/−0
- src/Database/DSH/CL/Kure.hs +96/−108
- src/Database/DSH/CL/Lang.hs +94/−110
- src/Database/DSH/CL/Opt.hs +7/−11
- src/Database/DSH/CL/Opt/AntiJoin.hs +10/−10
- src/Database/DSH/CL/Opt/Auxiliary.hs +5/−4
- src/Database/DSH/CL/Opt/CompNormalization.hs +5/−6
- src/Database/DSH/CL/Opt/FlatJoin.hs +0/−1
- src/Database/DSH/CL/Opt/LoopInvariant.hs +5/−6
- src/Database/DSH/CL/Opt/NestJoin.hs +78/−53
- src/Database/DSH/CL/Opt/Normalize.hs +15/−15
- src/Database/DSH/CL/Opt/PartialEval.hs +4/−4
- src/Database/DSH/CL/Opt/PredPushdown.hs +14/−17
- src/Database/DSH/CL/Opt/SemiJoin.hs +6/−6
- src/Database/DSH/CL/Primitives.hs +93/−90
- src/Database/DSH/Common/Impossible.hs +19/−0
- src/Database/DSH/Common/Kure.hs +2/−1
- src/Database/DSH/Common/Lang.hs +94/−30
- src/Database/DSH/Common/Nat.hs +11/−1
- src/Database/DSH/Common/Opt.hs +86/−0
- src/Database/DSH/Common/Pretty.hs +115/−3
- src/Database/DSH/Common/QueryPlan.hs +58/−36
- src/Database/DSH/Common/RewriteM.hs +10/−26
- src/Database/DSH/Common/TH.hs +15/−0
- src/Database/DSH/Common/Type.hs +73/−45
- src/Database/DSH/Common/Vector.hs +106/−0
- src/Database/DSH/Compiler.hs +184/−101
- src/Database/DSH/Execute.hs +241/−0
- src/Database/DSH/Execute/Backend.hs +0/−183
- src/Database/DSH/Execute/Sql.hs +0/−83
- src/Database/DSH/Execute/TH.hs +40/−36
- src/Database/DSH/Export.hs +0/−37
- src/Database/DSH/FKL/Kure.hs +57/−83
- src/Database/DSH/FKL/Lang.hs +99/−83
- src/Database/DSH/FKL/Primitives.hs +38/−74
- src/Database/DSH/FKL/Rewrite.hs +145/−28
- src/Database/DSH/Frontend/Builtins.hs +78/−0
- src/Database/DSH/Frontend/Externals.hs +275/−189
- src/Database/DSH/Frontend/Funs.hs +0/−74
- src/Database/DSH/Frontend/Internals.hs +64/−42
- src/Database/DSH/Frontend/Schema.hs +0/−44
- src/Database/DSH/Frontend/TH.hs +83/−77
- src/Database/DSH/Frontend/TupleTypes.hs +95/−80
- src/Database/DSH/Impossible.hs +0/−19
- src/Database/DSH/NKL/Kure.hs +48/−61
- src/Database/DSH/NKL/Lang.hs +80/−83
- src/Database/DSH/NKL/Primitives.hs +14/−13
- src/Database/DSH/NKL/Rewrite.hs +72/−23
- src/Database/DSH/Optimizer/Common/Auxiliary.hs +0/−11
- src/Database/DSH/Optimizer/Common/Rewrite.hs +0/−74
- src/Database/DSH/Optimizer/TA/OptimizeTA.hs +0/−52
- src/Database/DSH/Optimizer/TA/Properties/Auxiliary.hs +0/−73
- src/Database/DSH/Optimizer/TA/Properties/BottomUp.hs +0/−93
- src/Database/DSH/Optimizer/TA/Properties/Card1.hs +0/−39
- src/Database/DSH/Optimizer/TA/Properties/Cols.hs +0/−157
- src/Database/DSH/Optimizer/TA/Properties/Const.hs +0/−71
- src/Database/DSH/Optimizer/TA/Properties/Empty.hs +0/−37
- src/Database/DSH/Optimizer/TA/Properties/ICols.hs +0/−107
- src/Database/DSH/Optimizer/TA/Properties/Keys.hs +0/−170
- src/Database/DSH/Optimizer/TA/Properties/Order.hs +0/−102
- src/Database/DSH/Optimizer/TA/Properties/TopDown.hs +0/−113
- src/Database/DSH/Optimizer/TA/Properties/Types.hs +0/−48
- src/Database/DSH/Optimizer/TA/Properties/Use.hs +0/−96
- src/Database/DSH/Optimizer/TA/Rewrite/Basic.hs +0/−562
- src/Database/DSH/Optimizer/TA/Rewrite/Common.hs +0/−38
- src/Database/DSH/Optimizer/VL/OptimizeVL.hs +0/−56
- src/Database/DSH/Optimizer/VL/Properties/BottomUp.hs +0/−100
- src/Database/DSH/Optimizer/VL/Properties/Card.hs +0/−102
- src/Database/DSH/Optimizer/VL/Properties/Common.hs +0/−19
- src/Database/DSH/Optimizer/VL/Properties/Const.hs +0/−492
- src/Database/DSH/Optimizer/VL/Properties/Empty.hs +0/−115
- src/Database/DSH/Optimizer/VL/Properties/NonEmpty.hs +0/−139
- src/Database/DSH/Optimizer/VL/Properties/ReqColumns.hs +0/−418
- src/Database/DSH/Optimizer/VL/Properties/TopDown.hs +0/−185
- src/Database/DSH/Optimizer/VL/Properties/Types.hs +0/−127
- src/Database/DSH/Optimizer/VL/Properties/VectorType.hs +0/−164
- src/Database/DSH/Optimizer/VL/Rewrite/Aggregation.hs +0/−218
- src/Database/DSH/Optimizer/VL/Rewrite/Common.hs +0/−115
- src/Database/DSH/Optimizer/VL/Rewrite/Expressions.hs +0/−119
- src/Database/DSH/Optimizer/VL/Rewrite/PruneEmpty.hs +0/−108
- src/Database/DSH/Optimizer/VL/Rewrite/Redundant.hs +0/−965
- src/Database/DSH/Optimizer/VL/Rewrite/Unused.hs +0/−48
- src/Database/DSH/Optimizer/VL/Rewrite/Window.hs +0/−159
- src/Database/DSH/Tests.hs +47/−0
- src/Database/DSH/Tests/CombinatorTests.hs +1237/−0
- src/Database/DSH/Tests/Common.hs +108/−0
- src/Database/DSH/Tests/ComprehensionTests.hs +606/−0
- src/Database/DSH/Tests/DSHComprehensions.hs +415/−0
- src/Database/DSH/Tests/LawTests.hs +49/−0
- src/Database/DSH/Tools/VLDotGen.hs +31/−29
- src/Database/DSH/Translate/Algebra2Query.hs +0/−42
- src/Database/DSH/Translate/CL2NKL.hs +68/−86
- src/Database/DSH/Translate/FKL2VL.hs +30/−50
- src/Database/DSH/Translate/Frontend2CL.hs +142/−175
- src/Database/DSH/Translate/NKL2FKL.hs +42/−41
- src/Database/DSH/Translate/VL2Algebra.hs +154/−198
- src/Database/DSH/VL.hs +11/−0
- src/Database/DSH/VL/Lang.hs +31/−56
- src/Database/DSH/VL/Opt/OptimizeVL.hs +56/−0
- src/Database/DSH/VL/Opt/Properties/BottomUp.hs +91/−0
- src/Database/DSH/VL/Opt/Properties/Card.hs +93/−0
- src/Database/DSH/VL/Opt/Properties/Common.hs +19/−0
- src/Database/DSH/VL/Opt/Properties/Const.hs +375/−0
- src/Database/DSH/VL/Opt/Properties/Empty.hs +104/−0
- src/Database/DSH/VL/Opt/Properties/ReqColumns.hs +416/−0
- src/Database/DSH/VL/Opt/Properties/TopDown.hs +196/−0
- src/Database/DSH/VL/Opt/Properties/Types.hs +94/−0
- src/Database/DSH/VL/Opt/Properties/VectorType.hs +170/−0
- src/Database/DSH/VL/Opt/Rewrite/Aggregation.hs +231/−0
- src/Database/DSH/VL/Opt/Rewrite/Common.hs +114/−0
- src/Database/DSH/VL/Opt/Rewrite/Expressions.hs +119/−0
- src/Database/DSH/VL/Opt/Rewrite/PruneEmpty.hs +112/−0
- src/Database/DSH/VL/Opt/Rewrite/Redundant.hs +1050/−0
- src/Database/DSH/VL/Opt/Rewrite/Unused.hs +48/−0
- src/Database/DSH/VL/Opt/Rewrite/Window.hs +158/−0
- src/Database/DSH/VL/Primitives.hs +104/−132
- src/Database/DSH/VL/Render/Dot.hs +112/−141
- src/Database/DSH/VL/Render/JSON.hs +0/−41
- src/Database/DSH/VL/Vector.hs +0/−72
- src/Database/DSH/VL/VectorAlgebra.hs +79/−112
- src/Database/DSH/VL/VectorAlgebra/TA.hs +0/−908
- src/Database/DSH/VL/Vectorize.hs +327/−466
- tests/CombinatorTests.hs +0/−1241
- tests/ComprehensionTests.hs +0/−526
- tests/DSHComprehensions.hs +0/−384
- tests/Main.hs +0/−60
DSH.cabal view
@@ -1,50 +1,57 @@ Name: DSH-Version: 0.10.0.2+Version: 0.12.0.0 Synopsis: Database Supported Haskell Description:- This is a Haskell library for database-supported program execution. Using- this library a relational database management system (RDBMS) can be used as- a coprocessor for the Haskell programming language, especially for those- program fragments that carry out data-intensive and data-parallel- computations.+ This is a Haskell library for database-supported program+ execution. Using DSH, a relational database management+ system (RDBMS) can be used as a coprocessor for the Haskell+ programming language, especially for those program fragments that+ carry out data-intensive and data-parallel computations. . Database executable program fragments can be written using the monad- comprehension notation [2] and list processing combinators from the Haskell- list prelude. Note that rather than embedding a relational language into- Haskell, we turn idiomatic Haskell programs into SQL queries.+ comprehension notation [2] and list processing combinators from the+ Haskell list prelude. Note that rather than embedding a relational+ language into Haskell, we turn idiomatic Haskell programs into SQL+ queries. .- DSH faithfully represents list order and nesting, and compiles the list- processing combinators into relational queries. The implementation avoids- unnecessary data transfer and context switching between the database- coprocessor and the Haskell runtime by ensuring that the number of generated- relational queries is only determined by the program fragment's type and not- by the database size.+ DSH faithfully represents list order and nesting, and compiles the+ list processing combinators into relational queries. The+ implementation avoids unnecessary data transfer and context+ switching between the database coprocessor and the Haskell runtime+ by ensuring that the number of generated relational queries is only+ determined by the program fragment's type and not by the database+ size. .- DSH can be used to allow existing Haskell programs to operate on large scale- data (e.g., larger than the available heap) or query existing database- resident data with Haskell.+ DSH can be used to allow existing Haskell programs to operate on+ large scale data (e.g., larger than the available heap) or query+ existing database resident data with Haskell. .- Note that this package is flagged experimental and therefore is not suited- 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.+ Note that this package is flagged experimental and therefore is not+ suited for production use (we mean it!). This is a proof of concept+ implementation only. To learn more about DSH, our paper "The+ Flatter, the Better — Query Compilation Based on the Flattening+ Transformation." [1] is a recommended reading. The package includes+ a couple of examples that demonstrate how to use DSH. .- 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.+ The current release does not rely anymore on the loop-lifting+ compilation technique and 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. .+ To generate actual code for a relational backend, an additional+ backend package needs to be installed. Currently, the package+ 'dsh-sql' on Hackage provides SQL code generation for PostgreSQL.+ . Please read the release notes in 'README.md'. .- 1. <http://db.inf.uni-tuebingen.de/staticfiles/publications/ferryhaskell.pdf>+ 1. <http://db.inf.uni-tuebingen.de/publications/TheFlatter-theBetter-QueryCompilationBasedontheFlatteningTransformation.html> . 2. <http://db.inf.uni-tuebingen.de/staticfiles/publications/haskell2011.pdf> License: BSD3 License-file: LICENSE-Author: George Giorgidze, Alexander Ulrich, Nils Schweinsberg and Jeroen Weijers+Author: Alexander Ulrich, George Giorgidze, Jeroen Weijers, Nils Schweinsberg Maintainer: alex@etc-network.de Stability: Experimental Category: Database@@ -54,10 +61,6 @@ examples/Example02.hs examples/Example03.hs examples/dshify-tpch.sql- tests/Main.hs- tests/ComprehensionTests.hs- tests/DSHComprehensions.hs- tests/CombinatorTests.hs README.md Cabal-version: >= 1.8@@ -67,62 +70,75 @@ Default: False Flag debuggraph- Description: Print debugging information for graph rewrites (VL, TA)+ Description: Print debugging information for graph rewrites Default: False Library Extensions: CPP- Build-depends: base >= 4.7 && < 5,- template-haskell >= 2.9,- containers >= 0.5,- mtl >= 2.1,- bytestring >= 0.10,- text >= 1.1,- HDBC >= 2.3,- 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,+ Build-depends: base >= 4.8 && < 5,+ random >= 1.1,+ process >= 1.2,+ template-haskell >= 2.9,+ containers >= 0.5,+ mtl >= 2.1,+ time >= 1.4,+ bytestring >= 0.10,+ text >= 1.2,+ aeson >= 0.8,+ kure >= 2.16,+ either >= 4.0,+ semigroups >= 0.16,+ ansi-wl-pprint >= 0.6.7.2,+ dlist >= 0.7,+ Decimal >= 0.4,+ QuickCheck >= 2.7,+ HUnit >= 1.2,+ test-framework >= 0.8,+ test-framework-quickcheck2 >= 0.3,+ test-framework-hunit >= 0.3,+ vector >= 0.10,+ hashable >= 1.2,+ unordered-containers >= 0.2, - algebra-dag >= 0.1,- algebra-sql >= 0.1- + algebra-dag >= 0.1.1+ Hs-source-dirs: src if flag(debugcomp) CPP-Options: -DDEBUGCOMP- + if flag(debuggraph) CPP-Options: -DDEBUGGRAPH - GHC-Options: -Wall -fno-warn-orphans+ GHC-Options: -Wall -fno-warn-orphans -fprof-auto -O2 Exposed-modules: Database.DSH Database.DSH.Compiler+ Database.DSH.Backend+ Database.DSH.Tests+ Database.DSH.VL+ Database.DSH.Common.QueryPlan+ Database.DSH.Common.Opt+ Database.DSH.Common.Type+ Database.DSH.Common.Vector+ Database.DSH.Common.Lang+ Database.DSH.Common.Impossible 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.Frontend.Builtins Database.DSH.Translate.Frontend2CL Database.DSH.Execute.TH- Database.DSH.Execute.Sql- Database.DSH.Execute.Backend+ Database.DSH.Execute+ 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.Common.TH+ Database.DSH.CL.Lang Database.DSH.CL.Kure Database.DSH.CL.Primitives@@ -148,7 +164,6 @@ 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@@ -156,89 +171,54 @@ 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.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.VL.Opt.Properties.BottomUp+ Database.DSH.VL.Opt.Properties.Card+ Database.DSH.VL.Opt.Properties.Common+ Database.DSH.VL.Opt.Properties.Const+ Database.DSH.VL.Opt.Properties.Empty+ Database.DSH.VL.Opt.Properties.ReqColumns+ Database.DSH.VL.Opt.Properties.TopDown+ Database.DSH.VL.Opt.Properties.Types+ Database.DSH.VL.Opt.Properties.VectorType+ Database.DSH.VL.Opt.OptimizeVL+ Database.DSH.VL.Opt.Rewrite.Common+ Database.DSH.VL.Opt.Rewrite.Expressions+ Database.DSH.VL.Opt.Rewrite.PruneEmpty+ Database.DSH.VL.Opt.Rewrite.Redundant+ Database.DSH.VL.Opt.Rewrite.Aggregation+ Database.DSH.VL.Opt.Rewrite.Window+ Database.DSH.VL.Opt.Rewrite.Unused - 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+ Database.DSH.Tests.Common+ Database.DSH.Tests.ComprehensionTests+ Database.DSH.Tests.LawTests+ Database.DSH.Tests.CombinatorTests+ Database.DSH.Tests.DSHComprehensions 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, + build-depends: base >= 4.8 && < 5,+ mtl >= 2.1,+ aeson >= 0.8,+ time >= 1.4, containers >= 0.5,- template-haskell >= 2.9, + template-haskell >= 2.9, bytestring >= 0.10,- ansi-wl-pprint >= 0.6,+ Decimal >= 0.4,+ ansi-wl-pprint >= 0.6.7.2, semigroups >= 0.16,+ text >= 1.2,+ vector >= 0.10, - algebra-dag >= 0.1,- algebra-sql >= 0.1+ algebra-dag >= 0.1 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+source-repository head+ type: git+ location: https://github.com/ulricha/dsh
README.md view
@@ -1,45 +1,48 @@ # Database-Supported Haskell (DSH) -This is a Haskell library for database-supported program execution. Using-this library a relational database management system (RDBMS) can be used as-a coprocessor for the Haskell programming language, especially for those-program fragments that carry out data-intensive and data-parallel-computations.+This is a Haskell library for database-supported program+execution. Using DSH, a relational database management system (RDBMS)+can be used as a coprocessor for the Haskell programming language,+especially for those program fragments that carry out data-intensive+and data-parallel computations. Database executable program fragments can be written using the monad-comprehension notation [2] and list processing combinators from the Haskell-list prelude. Note that rather than embedding a relational language into-Haskell, we turn idiomatic Haskell programs into SQL queries.+comprehension notation [2] and list processing combinators from the+Haskell list prelude. Note that rather than embedding a relational+language into Haskell, we turn idiomatic Haskell programs into SQL+queries. -DSH faithfully represents list order and nesting, and compiles the list-processing combinators into relational queries. The implementation avoids-unnecessary data transfer and context switching between the database-coprocessor and the Haskell runtime by ensuring that the number of generated-relational queries is only determined by the program fragment's type and not-by the database size.+DSH faithfully represents list order and nesting, and compiles the+list processing combinators into relational queries. The+implementation avoids unnecessary data transfer and context switching+between the database coprocessor and the Haskell runtime by ensuring+that the number of generated relational queries is only determined by+the program fragment's type and not by the database size. -DSH can be used to allow existing Haskell programs to operate on large scale-data (e.g., larger than the available heap) or query existing database-resident data with Haskell.+DSH can be used to allow existing Haskell programs to operate on large+scale data (e.g., larger than the available heap) or query existing+database 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.+Note that this package is flagged experimental and therefore is not+suited for production use (we mean it!). This is a proof of concept+implementation only. To learn more about DSH, our paper "The Flatter,+the Better — Query Compilation Based on the Flattening+Transformation." [1] is a recommended reading. The package includes a+couple of examples that demonstrate how to use DSH. -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.+The current release does not rely anymore on the loop-lifting+compilation technique and 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/staticfiles/publications/ferryhaskell.pdf](Grust- et al. Haskell Boards the Ferry. Database-Supported Program- Execution for Haskell. IFL 2010)-2. [http://db.inf.uni-tuebingen.de/staticfiles/publications/haskell2011.pdf](Grust- et al. Bringing Back Monad Comprehensions. Haskell Symposium 2011).+To generate actual code for a relational backend, an additional+backend package needs to be installed. Currently, the package+`dsh-sql` on Hackage provides SQL code generation for PostgreSQL.+++1. [Ulrich, Grust. The Flatter, the Better - Query Compilation Based on the Flattening Transformation. Proc. SIGMOD 2015](http://db.inf.uni-tuebingen.de/publications/TheFlatter-theBetter-QueryCompilationBasedontheFlatteningTransformation.html).+2. [Grust et al. Bringing Back Monad Comprehensions. Haskell Symposium 2011](http://db.inf.uni-tuebingen.de/staticfiles/publications/haskell2011.pdf). # Release Notes
src/Database/DSH.hs view
@@ -1,5 +1,4 @@--- | --- This module is intended to be imported @qualified@, to avoid name clashes+-- | This module is intended to be imported @qualified@, to avoid name clashes -- with "Prelude" functions. For example: -- -- > import qualified Database.DSH as Q@@ -14,15 +13,15 @@ -- by Database.DSH. module Database.DSH- ( 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- , module Prelude- )- where+ ( 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 Data.Decimal+ , module Data.Time.Calendar+ , module Prelude+ ) where import Database.DSH.Frontend.Externals import Database.DSH.Frontend.Internals (Q,QA,TA,Elim,elim,View,view,Key(..),TableHints(..), Emptiness(..))@@ -30,7 +29,8 @@ import Data.String (IsString,fromString) import Data.Text (Text)-import Database.HDBC+import Data.Decimal (Decimal)+import Data.Time.Calendar (Day) import Prelude hiding ( not , (&&)@@ -87,5 +87,6 @@ , return , (>>=) , (>>)- , div+ , quot+ , rem )
+ src/Database/DSH/Backend.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module provides an abstraction over flat relational backends+-- with respect to code generation and query execution.+module Database.DSH.Backend+ ( -- * Backend-indepdent composite keys+ KeyVal(..)+ , CompositeKey(..)+ -- * Backend Functionality Classes+ , Backend(..)+ , Row(..)+ -- * Literal scalar value expressions+ , doubleE+ , unitE+ , integerE+ , boolE+ , charE+ , textE+ , decimalE+ , dayE+ ) where++import Data.Decimal+import Data.Hashable+import Data.Text (Text)+import Data.ByteString (ByteString)+import qualified Data.Time.Calendar as C+import GHC.Generics (Generic)++import Database.DSH.Common.QueryPlan+import Database.DSH.Common.Vector+import qualified Database.DSH.Frontend.Internals as F+import Database.DSH.VL.Lang (VL)++--------------------------------------------------------------------------------+-- Backend-independent composite keys++data KeyVal = KInteger !Integer+ | KByteString !ByteString+ | KDay !C.Day+ deriving (Eq, Generic)++newtype CompositeKey = CompositeKey { unCKey :: [KeyVal] }+ deriving (Eq, Generic)++instance Hashable C.Day where+ hashWithSalt s d = s `hashWithSalt` (C.toGregorian d)++instance Hashable KeyVal where++instance Hashable CompositeKey where++--------------------------------------------------------------------------------++-- | An abstract backend for which we can generate code and on which+-- flat queries can be executed.+class (RelationalVector (BackendCode c), Row (BackendRow c)) => Backend c where+ data BackendRow c+ data BackendCode c+ data BackendPlan c++ -- | Execute a flat query on the backend.+ execFlatQuery :: c -> BackendCode c -> IO [BackendRow c]++ -- | Implement vector operations using the backend-specific+ -- algebra.+ generatePlan :: QueryPlan VL VLDVec -> BackendPlan c++ -- | Optimize the algebra plan and generate serialized backend+ -- code+ generateCode :: BackendPlan c -> Shape (BackendCode c)++ -- | Dump versions of the plan in JSON form to the specified file.+ dumpPlan :: String -> Bool -> BackendPlan c -> IO FilePath++ transactionally :: c -> (c -> IO a) -> IO a++--------------------------------------------------------------------------------++-- | 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++ boolVal :: Scalar r -> F.Exp Bool+ integerVal :: Scalar r -> F.Exp Integer+ doubleVal :: Scalar r -> F.Exp Double+ charVal :: Scalar r -> F.Exp Char+ textVal :: Scalar r -> F.Exp Text+ unitVal :: Scalar r -> F.Exp ()+ decimalVal :: Scalar r -> F.Exp Decimal+ dayVal :: Scalar r -> F.Exp C.Day++ keyVal :: Scalar r -> KeyVal++--------------------------------------------------------------------------------+-- Constructors for literal scalar type expressions. Backends need+-- those to construct result expressions from rows.++doubleE :: Double -> F.Exp Double+doubleE = F.DoubleE++unitE :: F.Exp ()+unitE = F.UnitE++integerE :: Integer -> F.Exp Integer+integerE = F.IntegerE++boolE :: Bool -> F.Exp Bool+boolE = F.BoolE++charE :: Char -> F.Exp Char+charE = F.CharE++textE :: Text -> F.Exp Text+textE = F.TextE++dayE :: C.Day -> F.Exp C.Day+dayE = F.DayE++decimalE :: Decimal -> F.Exp Decimal+decimalE = F.DecimalE
src/Database/DSH/CL/Kure.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE InstanceSigs #-} -- | Infrastructure for KURE-based rewrites on CL expressions- + module Database.DSH.CL.Kure ( -- * Re-export relevant KURE modules module Language.KURE@@ -12,10 +12,10 @@ -- * 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 @@ -29,26 +29,25 @@ , 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 @@ -92,13 +91,13 @@ type PathC = Path CrumbC -- | The context for KURE-based CL rewrites-data CompCtx = CompCtx { cl_bindings :: M.Map L.Ident Type +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 @@ -113,7 +112,7 @@ 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 @@ -149,56 +148,56 @@ -------------------------------------------------------------------------------- -- Congruence combinators for CL expressions -tableT :: Monad m => (Type -> String -> [L.Column] -> L.TableHints -> b)+tableT :: Monad m => (Type -> String -> L.BaseTableSchema -> 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 #-} - + Table ty n schema -> return $ f ty n schema+ _ -> 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 + AppE1 ty p e -> f ty p <$> applyT t (c@@AppE1Arg) e _ -> fail "not a unary primitive application"-{-# INLINE appe1T #-} - +{-# INLINE appe1T #-}+ appe1R :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Expr appe1R t = appe1T t AppE1-{-# INLINE appe1R #-} - +{-# 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 + 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 #-} +{-# 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 #-} - +{-# 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 + 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 #-} +{-# 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 #-} +{-# INLINE binopR #-} unopT :: Monad m => Transform CompCtx m Expr a -> (Type -> L.ScalarUnOp -> a -> b)@@ -211,61 +210,61 @@ 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 + 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 #-} - +{-# 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 #-} - +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 #-} - +{-# INLINE litT #-}+ litR :: Monad m => Rewrite CompCtx m Expr litR = litT Lit-{-# INLINE litR #-} - +{-# 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 #-} - +{-# INLINE varT #-}+ varR :: Monad m => Rewrite CompCtx m Expr varR = varT Var-{-# INLINE varR #-} +{-# 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 + 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 #-} - +{-# 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 #-} +compR t1 t2 = compT t1 t2 Comp+{-# INLINE compR #-} mkTupleT :: Monad m => Transform CompCtx m Expr a -> (Type -> [a] -> b)@@ -280,119 +279,119 @@ letT :: Monad m => Transform CompCtx m Expr a1 -> Transform CompCtx m Expr a2- -> (Type -> L.Ident -> a1 -> a2 -> b) + -> (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 + 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 +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) +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 #-} - +{-# INLINE bindQualT #-}+ bindQualR :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Qual bindQualR t = bindQualT t BindQ-{-# INLINE bindQualR #-} +{-# INLINE bindQualR #-} -guardQualT :: Monad m => Transform CompCtx m Expr a - -> (a -> b) +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 #-} - +{-# INLINE guardQualT #-}+ guardQualR :: Monad m => Rewrite CompCtx m Expr -> Rewrite CompCtx m Qual guardQualR t = guardQualT t GuardQ-{-# INLINE guardQualR #-} +{-# 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) + -> (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 + q :* qs -> f <$> applyT t1 (ctx@@QualsHead) q <*> applyT t2 (bindQual (ctx@@QualsTail) q) qs S _ -> fail "not a nonempty cons"-{-# INLINE qualsT #-} - +{-# 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 #-} +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 #-} - +{-# INLINE qualsemptyT #-}+ qualsemptyR :: Monad m => Rewrite CompCtx m Qual -> Rewrite CompCtx m (NL Qual)-qualsemptyR t = qualsemptyT t S -{-# INLINE qualsemptyR #-} +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 = + 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)@@ -417,45 +416,34 @@ 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) +{-# INLINE consT #-}++consR :: Monad m => Rewrite CompCtx m (NL Qual) -> Rewrite CompCtx m (NL Qual)-consR t = consT t (:*) -{-# INLINE consR #-} +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 #-} - +{-# INLINE singletonT #-}+ singletonR :: Monad m => Rewrite CompCtx m (NL Qual)-singletonR = singletonT S -{-# INLINE singletonR #-} - +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
@@ -1,9 +1,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE PatternSynonyms #-} module Database.DSH.CL.Lang ( module Database.DSH.Common.Type@@ -15,21 +15,19 @@ , Prim2(..) ) where -import Control.Applicative hiding (empty)+import qualified Data.Foldable as F+import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.Traversable as T -import qualified Data.Foldable as F-import qualified Data.Traversable as T-import Data.List.NonEmpty (NonEmpty((:|)))+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))-import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Printf +import Database.DSH.Common.Impossible+import qualified Database.DSH.Common.Lang as L 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+import Database.DSH.Common.Type -------------------------------------------------------------------------------- -- A simple type of nonempty lists, used for comprehension@@ -95,80 +93,78 @@ -- CL primitives data Prim1 = Singleton- | Length + | Only+ | Length | Concat | Null- | Sum - | Avg - | The - | Head - | Tail- | Minimum + | Sum+ | Avg+ | Minimum | Maximum- | Reverse - | And + | Reverse+ | And | Or- | Init - | Last | Nub- | Number + | Number+ | Sort+ | Group | Guard- | Reshape Integer- | Transpose | TupElem TupleIndex- deriving (Eq)+ deriving (Eq, Show) -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+instance Pretty Prim1 where+ pretty Sort = combinator $ text "sort"+ pretty Group = combinator $ text "group"+ pretty Singleton = combinator $ text "sng"+ pretty Only = combinator $ text "only"+ pretty Length = combinator $ text "length"+ pretty Concat = combinator $ text "concat"+ pretty Null = combinator $ text "null"+ pretty Sum = combinator $ text "sum"+ pretty Avg = combinator $ text "avg"+ pretty Minimum = combinator $ text "minimum"+ pretty Maximum = combinator $ text "maximum"+ pretty Reverse = combinator $ text "reverse"+ pretty And = combinator $ text "and"+ pretty Or = combinator $ text "or"+ pretty Nub = combinator $ text "nub"+ pretty Number = combinator $ text "number"+ pretty Guard = combinator $ text "guard" -- tuple access is pretty-printed in a special way- show TupElem{} = $impossible+ pretty TupElem{} = $impossible -data Prim2 = Sort- | Group- | Append- | Index- | Zip +data Prim2 = Append+ | 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)+ deriving (Eq, Show) -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)+isJoinOp :: Prim2 -> Bool+isJoinOp op =+ case op of+ CartProduct -> True+ NestProduct -> True+ ThetaJoin{} -> True+ NestJoin{} -> True+ SemiJoin{} -> True+ AntiJoin{} -> True+ Append -> False+ Zip -> False +instance Pretty Prim2 where+ pretty Append = combinator $ text "append"+ pretty Zip = combinator $ text "zip"+ pretty CartProduct = join $ text "cartproduct"+ pretty NestProduct = join $ text "nestproduct"+ pretty (ThetaJoin p) = join $ text $ printf "thetajoin{%s}" (pp p)+ pretty (NestJoin p) = join $ text $ printf "nestjoin{%s}" (pp p)+ pretty (SemiJoin p) = join $ text $ printf "semijoin{%s}" (pp p)+ pretty (AntiJoin p) = join $ text $ printf "antijoin{%s}" (pp p)+ -------------------------------------------------------------------------------- -- CL expressions @@ -184,7 +180,7 @@ isBind (GuardQ _) = False isBind (BindQ _ _) = True -data Expr = Table Type String [L.Column] L.TableHints+data Expr = Table Type String L.BaseTableSchema | AppE1 Type Prim1 Expr | AppE2 Type Prim2 Expr Expr | BinOp Type L.ScalarBinOp Expr Expr@@ -198,69 +194,59 @@ deriving (Show) instance Pretty Expr where- pretty (AppE1 _ (TupElem n) e1) = + 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 (MkTuple _ es) = prettyTuple $ map pretty es+ pretty (Table _ n _) = kw (text "table") <> parens (text n)+ pretty (AppE1 _ p1 e) = pretty p1 <+> (parenthize e)+ pretty (AppE2 _ p2 e1 e2)+ | isJoinOp p2 = prettyJoin (pretty p2) (parenthize e1) (parenthize e2)+ | otherwise = prettyApp2 (pretty p2) (parenthize e1) (parenthize e2)+ pretty (BinOp _ o e1 e2)+ | L.isBinInfixOp o = prettyInfixBinOp (pretty o)+ (parenthize e1)+ (parenthize e2)+ | otherwise = prettyPrefixBinOp (pretty o)+ (parenthize e1)+ (parenthize e2)+ pretty (UnOp _ o e) = prettyUnOp (pretty o) (pretty e)+ pretty (If _ c t e) = prettyIf (pretty c) (pretty t) (pretty 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+ pretty (Comp _ e qs) = prettyComp (pretty e) (map pretty $ toList qs)+ pretty (Let _ x e1 e) = prettyLet (text x) (pretty e1) (pretty e) parenthize :: Expr -> Doc parenthize e = case e of Var _ _ -> pretty e Lit _ _ -> pretty e- Table _ _ _ _ -> 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 (BindQ i e) = text i <+> comp (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+-- -- 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 (Table t _ _) = t typeOf (AppE1 t _ _) = t typeOf (AppE2 t _ _ _) = t typeOf (If t _ _ _) = t@@ -271,5 +257,3 @@ typeOf (Comp t _ _) = t typeOf (MkTuple t _) = t typeOf (Let t _ _ _) = t--
src/Database/DSH/CL/Opt.hs view
@@ -27,7 +27,7 @@ -- | Comprehension normalization rules 1 to 3. compNormEarlyR :: RewriteC CL-compNormEarlyR = m_norm_1R +compNormEarlyR = m_norm_1R <+ m_norm_2R <+ m_norm_3R -- Does not lead to good code. See lablog entry (24.11.2014)@@ -35,12 +35,6 @@ <+ 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.@@ -107,8 +101,10 @@ repeatR applyOptimizationsR >+> postProcessR +-- | Apply the default set of unnesting and decorrelation rewrites to+-- a CL query. optimizeComprehensions :: Expr -> Expr-optimizeComprehensions expr = debugOpt "CL" expr optimizedExpr- where- optimizedExpr = applyExpr (optimizeR >>> projectT) expr- -- optimizedExpr = applyExpr projectT expr+optimizeComprehensions expr =+ case applyExpr (optimizeR >>> projectT) expr of+ Left _ -> expr+ Right expr' -> expr'
src/Database/DSH/CL/Opt/AntiJoin.hs view
@@ -45,8 +45,8 @@ -- 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 +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@@ -76,16 +76,16 @@ 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 +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 @@ -138,7 +138,7 @@ return $ S $ antijoinGen _ -> fail "no and pattern" -mkUniversalRangeAntiJoinT :: (Ident, Expr) +mkUniversalRangeAntiJoinT :: (Ident, Expr) -> (Ident, Expr) -> NL Qual -> Expr@@ -192,7 +192,7 @@ -- Filter the inner source with the range -- predicates. Additionally, filter it with the non-correlated- -- predicates extracted from the quantifier predicate. + -- predicates extracted from the quantifier predicate. -- [ y | y <- ys, ps ++ nonCorrPreds ] let innerPreds = case nonCorrPreds of c : cs -> appendNL ps (fromListSafe c cs)@@ -226,7 +226,7 @@ mkClass16AntiJoinT :: (Ident, Expr) -> (Ident, Expr)- -> NonEmpty (JoinConjunct JoinExpr) + -> NonEmpty (JoinConjunct JoinExpr) -> NonEmpty (JoinConjunct JoinExpr) -> [Expr] -> TransformC (NL Qual) (Qual)
src/Database/DSH/CL/Opt/Auxiliary.hs view
@@ -56,7 +56,7 @@ import Database.DSH.Common.Lang import Database.DSH.Common.Nat import Database.DSH.Common.RewriteM-import Database.DSH.Impossible+import Database.DSH.Common.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@@ -80,13 +80,14 @@ 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"+toJoinBinOp (SBDateOp _) = fail "toJoinBinOp: join expressions can't contain date 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+toJoinUnOp (SUDateOp _) = fail "toJoinUnOp: join expressions can't contain date ops" toJoinExpr :: Ident -> TransformC Expr JoinExpr toJoinExpr n = do@@ -271,7 +272,7 @@ tupleVars :: Ident -> Type -> Type -> (Expr, Expr) tupleVars n t1 t2 = (v1Rep, v2Rep) where v = Var pt n- pt = pairT t1 t2+ pt = PPairT t1 t2 v1Rep = AppE1 t1 (TupElem First) v v2Rep = AppE1 t2 (TupElem (Next First)) v @@ -293,7 +294,7 @@ 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) = + 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
src/Database/DSH/CL/Opt/CompNormalization.hs view
@@ -18,7 +18,6 @@ , identityCompR ) where -import Control.Applicative import Control.Arrow import Data.Either import qualified Data.Map as M@@ -30,7 +29,7 @@ import qualified Database.DSH.CL.Primitives as P import Database.DSH.Common.Kure import Database.DSH.Common.Lang-import Database.DSH.Impossible+import Database.DSH.Common.Impossible ------------------------------------------------------------------ -- Classical Monad Comprehension Normalization rules (Grust)@@ -186,8 +185,8 @@ 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@@ -202,9 +201,9 @@ -- preparation, we push guards towards the front of the qualifier -- list. invariantguardR :: RewriteC CL-invariantguardR = - tryR guardpushfrontR - >>> +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)
src/Database/DSH/CL/Opt/FlatJoin.hs view
@@ -8,7 +8,6 @@ ( flatjoinsR ) where -import Control.Applicative import Control.Arrow import qualified Data.Map as M import qualified Data.Set as S
src/Database/DSH/CL/Opt/LoopInvariant.hs view
@@ -2,17 +2,16 @@ {-# 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.Impossible import Database.DSH.Common.Lang import Database.DSH.Common.Kure import Database.DSH.Common.Pretty@@ -32,8 +31,8 @@ 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. - -- + -- 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"@@ -47,7 +46,7 @@ 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.
src/Database/DSH/CL/Opt/NestJoin.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-}- + -- | Deal with nested comprehensions by introducing explicit nesting -- operators (NestJoin, NestProduct). module Database.DSH.CL.Opt.NestJoin@@ -12,7 +12,6 @@ , nestingGenR ) where -import Control.Applicative((<$>)) import Control.Arrow import Control.Monad @@ -22,11 +21,11 @@ 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@@ -65,6 +64,30 @@ p <- snocPathToPath <$> absPathT return (p, NestedComp t h (y, ys) guards) +-- | Search through the qualifiers of a comprehension that itself was+-- not fit for unnesting. This traversal takes care not to touch any+-- generator expressions that depend on preceding generators.+searchCompQuals :: Ident -> [Ident] -> TransformC CL (PathC, NestedComp)+searchCompQuals x qualBoundVars =+ readerT $ \qs -> case qs of+ QualsCL ((BindQ y ys) :* _) ->+ (guardM (null $ (freeVars ys) `intersect` qualBoundVars)+ >>+ pathT [QualsHead, BindQualExpr] (searchNestedCompT x))+ <++ childT QualsTail (searchCompQuals x (y : qualBoundVars))+ QualsCL (S (BindQ _ _)) ->+ pathT [QualsSingleton, BindQualExpr]+ (searchNestedCompT x)+ -- We don't traverse into guard expressions for now. In+ -- principle we could, but the guard would have to be+ -- loop-invariant (i.e. do not depend on any local generators)+ -- and that's rather unlikely.+ QualsCL ((GuardQ _) :* _) ->+ childT QualsTail (searchCompQuals x qualBoundVars)+ QualsCL (S (GuardQ _)) -> fail "don't search in guard expressions"+ _ -> fail "only consider qualifier lists here"+ -- | Traverse though an expression and search for a comprehension that -- is eligible for unnesting. searchNestedCompT :: Ident -> TransformC CL (PathC, NestedComp)@@ -74,7 +97,9 @@ -- 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 Comp{} -> (tryR guardpushbackR >>> nestedCompT x)+ <++ childT CompQuals (searchCompQuals x []) ExprCL _ -> oneT $ searchNestedCompT x _ -> fail "only traverse through expressions" @@ -104,7 +129,7 @@ -- Generators have to be indepedent guardM $ x `notElem` freeVars ys - let (joinPredCandidates, nonJoinPreds) = partition (isThetaJoinPred x y) + let (joinPredCandidates, nonJoinPreds) = partition (isThetaJoinPred x y) (hGuards headComp) -- Determine which operator to use to implement the nesting. If@@ -118,7 +143,7 @@ -- 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@@ -129,21 +154,21 @@ -- 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))+ tupType = PPairT xt (ListT (PPairT 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)+ Just ps -> Comp (ListT yt) (Var yt y) (BindQ y ys :* fmap GuardQ ps) Nothing -> ys - -- the nesting operator combining xs and ys: + -- the nesting operator combining xs and ys: -- xs nj(p) ys- let xs' = AppE2 (listT tupType) nestOp xs ys'+ let xs' = AppE2 (ListT tupType) nestOp xs ys' innerVar <- freshNameT [] @@ -187,15 +212,15 @@ -- 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) +-- [ 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 +--+-- 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@@ -218,13 +243,13 @@ -- 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@@ -236,25 +261,25 @@ -- 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 (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] | +-- [ e[fst x/x] | -- | qs -- , x <- xs nestjoin(jp) ys -- , p (fst x) [ f (fst y) (snd y) | y <- snd x ]@@ -276,7 +301,7 @@ 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 + (headCompPath, headComp) <- withLocalPathT $ constNodeT guardExpr >>> searchNestedCompT x -- Forbid the generator of a comprehension we want to unnest to@@ -291,17 +316,17 @@ (headComp', nestOp, tuplifyOuterR) <- unnestWorkerT headComp (x, xs) -- Tuplify occurences of 'x' in the guard.- ExprCL tuplifiedGuardExpr <- constNodeT guardExpr + ExprCL tuplifiedGuardExpr <- constNodeT guardExpr >>> tryR tuplifyOuterR -- Insert the new inner comprehension into the original guard -- expression- ExprCL simplifiedGuardExpr <- constNodeT tuplifiedGuardExpr + 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)@@ -309,8 +334,8 @@ 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 - >>> + (tuplifyHeadR, xs', p') <- liftstateT $ constNodeT p+ >>> unnestGuardT localGenVars (x, xs) p constT $ modify (\(r, _) -> (r >>> tuplifyHeadR, Just p')) qs' <- liftstateT $ constNodeT qs >>> tuplifyHeadR >>> projectT@@ -318,8 +343,8 @@ -- At the end of a qualifier list BindQ x xs :* (S (GuardQ p)) -> do- (tuplifyHeadR, xs', p') <- liftstateT $ constNodeT p - >>> + (tuplifyHeadR, xs', p') <- liftstateT $ constNodeT p+ >>> unnestGuardT localGenVars (x, xs) p constT $ modify (\(r, _) -> (r >>> tuplifyHeadR, Just p')) return $ S $ BindQ x xs'@@ -328,7 +353,7 @@ -- | 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@@ -336,11 +361,11 @@ -- success. unnestGuardR :: [Expr] -> [Expr] -> TransformC CL (CL, [Expr], [Expr]) unnestGuardR candGuards failedGuards = do- Comp t _ qs <- promoteT idR + 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@@ -373,7 +398,7 @@ -- 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@@ -385,7 +410,7 @@ -- Other forms of unnesting isComplexExpr :: Expr -> Bool-isComplexExpr e = +isComplexExpr e = case e of Comp{} -> True If{} -> True@@ -407,7 +432,7 @@ 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@@ -415,22 +440,22 @@ -- 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 ] ] --- +--+-- [ [ 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. --- +-- 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 ++ let fvs = freeVars e guardM $ x `elem` fvs && y `elem` fvs guardM $ x `elem` freeVars f@@ -440,9 +465,9 @@ z <- freshNameT [y] - let genComp = Comp (listT $ typeOf f) f (S $ BindQ x xs)+ let genComp = Comp (ListT $ typeOf f) f (S $ BindQ x xs) zipGen = P.zip xs genComp- zt = elemT $ typeOf zipGen + zt = elemT $ typeOf zipGen zv = Var zt z ExprCL f' <- constNodeT e >>> substR x (P.fst zv)@@ -459,14 +484,14 @@ -- 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@@ -475,7 +500,7 @@ 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@@ -489,7 +514,7 @@ let gty = typeOf g let innerComp = Comp ti e (S (BindQ y (Var gty z)))- genComp = Comp (listT gty) g (S (BindQ x xs))+ 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
@@ -3,11 +3,11 @@ {-# 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 + ( normalizeOnceR , normalizeExprR ) where @@ -16,8 +16,8 @@ import qualified Data.Foldable as F import qualified Data.Traversable as T import Data.Monoid- -import Database.DSH.Impossible++import Database.DSH.Common.Impossible import Database.DSH.Common.Lang import Database.DSH.CL.Lang import Database.DSH.CL.Kure@@ -39,15 +39,15 @@ 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. @@ -77,7 +77,7 @@ 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 @@ -94,22 +94,22 @@ -- 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+ PEq (PLength xs) (Lit _ (ScalarV (IntV 0))) -> return $ inject $ P.null xs+ PEq (Lit _ (ScalarV (IntV 0))) (PLength xs) -> return $ inject $ P.null xs _ -> fail "no match" --- null [ _ | x <- xs, p1, p2, ... ] +-- 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)+ return $ inject $ P.and $ Comp (ListT PBoolT) conjPred (S $ BindQ x xs) -- not $ null [ _ | x <- xs, ps ] -- =>@@ -119,7 +119,7 @@ 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)))+ return $ inject $ P.or (Comp (ListT PBoolT) p (S (BindQ x xs))) -------------------------------------------------------------------------------- -- Inline let bindings@@ -156,7 +156,7 @@ ExprCL (Var _ n) | n == v -> return 1 ExprCL (Var _ _) | otherwise -> return 0 - ExprCL (Let _ n _ _) | n == v -> promoteT $ letT (constT $ 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)
src/Database/DSH/CL/Opt/PartialEval.hs view
@@ -2,12 +2,12 @@ {-# 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@@ -21,7 +21,7 @@ -- pair (fst x) (snd x) => x identityPairR :: RewriteC CL identityPairR = do- MkTuple _ [ AppE1 _ (TupElem First) v@(Var tupleTy x) + MkTuple _ [ AppE1 _ (TupElem First) v@(Var tupleTy x) , AppE1 _ (TupElem (Next First)) (Var _ x') ] <- promoteT idR @@ -71,7 +71,7 @@ return $ inject xs partialEvalR :: RewriteC CL-partialEvalR = +partialEvalR = readerT $ \cl -> case cl of ExprCL AppE1{} -> tupleElemR <+ literalSingletonR ExprCL MkTuple{} -> identityPairR <+ literalTupleR
src/Database/DSH/CL/Opt/PredPushdown.hs view
@@ -8,16 +8,16 @@ ( predpushdownR ) where -import Control.Applicative import Control.Arrow-import qualified Data.List.NonEmpty as N-import qualified Data.Set as S+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+import qualified Database.DSH.CL.Primitives as P+import Database.DSH.Common.Lang+import Database.DSH.Common.Nat -------------------------------------------------------------------------------- -- Auxiliary functions@@ -163,21 +163,18 @@ -- 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+ AppE1 t Sort 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+ genVar = Var xt 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))+ ExprCL p' <- constT (return $ inject p) >>> substR x (P.fst genVar) - return $ inject $ AppE2 t Sort xsFiltered ssFiltered+ let restrictedInput = Comp xst genVar (BindQ x xs :* S (GuardQ p')) + return $ inject $ AppE1 t Sort restrictedInput+ -------------------------------------------------------------------------- -- Take remaining comprehension guards and try to push them into the -- generator. This might be accomplished by either merging it into a@@ -208,7 +205,7 @@ ExprCL (AppE2 _ (AntiJoin _) _ _) -> pushLeftR x p -- Sorting commutes with selection- ExprCL (AppE2 _ Sort _ _) -> pushSortInputR x p+ ExprCL (AppE1 _ Sort _) -> pushSortInputR x p _ -> fail "expression does not allow predicate pushing" pushQualsR :: RewriteC CL
src/Database/DSH/CL/Opt/SemiJoin.hs view
@@ -20,7 +20,7 @@ -- Introduce semi joins (existential quantification) pattern POr xs <- AppE1 _ Or xs-pattern PTrue = Lit BoolT (BoolV True)+pattern PTrue = Lit PBoolT (ScalarV (BoolV True)) existentialQualR :: RewriteC (NL Qual) existentialQualR = readerT $ \quals -> case quals of@@ -59,7 +59,7 @@ 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@@ -80,7 +80,7 @@ _ -> fail "no match" -mkExistentialSemiJoinT :: (Ident, Expr) +mkExistentialSemiJoinT :: (Ident, Expr) -> (Ident, Expr) -> Maybe Expr -> Maybe (NL Qual)@@ -102,10 +102,10 @@ -- 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]) + let (innerGuards, corrGuards) = partition (\e -> freeVars e == [y]) allExprs let ys' = case innerGuards of@@ -118,7 +118,7 @@ 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)
src/Database/DSH/CL/Primitives.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} -- | Smart constructors for CL primitives@@ -5,14 +6,16 @@ import qualified Prelude as P +import Data.Decimal import qualified Data.List as List+import qualified Data.Text as T+import qualified Data.Time.Calendar as C 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@@ -21,7 +24,7 @@ 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+if_ c t e = if PBoolT P.== typeOf c then If (typeOf t) c t e else tyErr "if_" @@ -32,27 +35,27 @@ length :: Expr -> Expr length e = let t = typeOf e in if isList t- then AppE1 intT Length e+ then AppE1 PIntT Length e else tyErr "length" null :: Expr -> Expr null e = if isList t- then AppE1 boolT Null e+ then AppE1 PBoolT 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+ in if ListT PBoolT P.== t+ then AppE1 PBoolT 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+ in if ListT PBoolT P.== t+ then AppE1 PBoolT Or e else tyErr "or" concat :: Expr -> Expr@@ -61,29 +64,18 @@ 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"+avg e = case typeOf e of+ ListT PDoubleT -> AppE1 PDoubleT Avg e+ ListT PDecimalT -> AppE1 PDecimalT Avg e+ _ -> tyErr "avg" minimum :: Expr -> Expr minimum e = let (ListT t) = typeOf e@@ -97,36 +89,16 @@ 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+ in AppE1 (ListT (PPairT t PIntT )) 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+guard e = AppE1 (ListT PUnitT) Guard e tupElem :: TupleIndex -> Expr -> Expr tupElem f e =@@ -142,16 +114,16 @@ singleGenComp :: Expr -> L.Ident -> Expr -> Expr singleGenComp bodyExp v gen = let bodyTy = typeOf bodyExp- in Comp (listT bodyTy) bodyExp (S P.$ BindQ v gen)+ 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+group :: Expr -> Expr+group xs = let ListT (TupleT [xt, grt]) = typeOf xs+ rt = ListT (TupleT [grt, ListT xt])+ in AppE1 rt Group xs -sort :: Expr -> Expr -> Expr-sort xs ss = AppE2 (typeOf xs) Sort xs ss+sort :: Expr -> Expr+sort xs = let ListT (TupleT [xt, _]) = typeOf xs+ in AppE1 (ListT xt) Sort xs pair :: Expr -> Expr -> Expr pair a b = tuple [a, b]@@ -169,32 +141,28 @@ 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+sng e = AppE1 (ListT P.$ typeOf e) Singleton e +only :: Expr -> Expr+only e = AppE1 (elemT (typeOf e)) Only 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+ in AppE2 (ListT P.$ PPairT t1' t2') Zip e1 e2 var :: Type -> P.String -> Expr var = Var -table :: Type -> P.String -> [L.Column] -> L.TableHints -> Expr+table :: Type -> P.String -> L.BaseTableSchema -> 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+ in if tb P.== PBoolT P.&& tt P.== te then If te eb et ee else tyErr "cond" @@ -207,19 +175,19 @@ cartproduct :: Expr -> Expr -> Expr cartproduct xs ys = AppE2 resType CartProduct xs ys where- resType = listT P.$ pairT (elemT P.$ typeOf xs) (typeOf ys)+ resType = ListT P.$ PPairT (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)+ resType = ListT P.$ PPairT (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))+ rt = ListT (PPairT (elemT xst) (elemT yst)) semijoin :: Expr -> Expr -> L.JoinPredicate L.JoinExpr -> Expr semijoin xs ys p = AppE2 xst (SemiJoin p) xs ys@@ -235,20 +203,26 @@ -- Literal value constructors unit :: Expr-unit = Lit unitT L.UnitV+unit = Lit PUnitT (L.ScalarV L.UnitV) int :: P.Int -> Expr-int i = Lit intT (L.IntV i)+int i = Lit PIntT (L.ScalarV (L.IntV i)) bool :: P.Bool -> Expr-bool b = Lit boolT (L.BoolV b)+bool b = Lit PBoolT (L.ScalarV (L.BoolV b)) -string :: P.String -> Expr-string s = Lit stringT (L.StringV s)+string :: T.Text -> Expr+string s = Lit PStringT (L.ScalarV (L.StringV s)) double :: P.Double -> Expr-double d = Lit doubleT (L.DoubleV d)+double d = Lit PDoubleT (L.ScalarV (L.DoubleV d)) +decimal :: Decimal -> Expr+decimal d = Lit PDecimalT (L.ScalarV (L.DecimalV d))++day :: C.Day -> Expr+day d = Lit PDateT (L.ScalarV (L.DateV d))+ nil :: Type -> Expr nil t = Lit t (L.ListV []) @@ -266,17 +240,30 @@ 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+ (L.SUNumOp _, PDoubleT) -> UnOp t op e+ (L.SUBoolOp _, PBoolT) -> UnOp PBoolT op e+ (L.SUCastOp L.CastDouble, _) | isNum t -> UnOp PDoubleT op e+ (L.SUCastOp L.CastDecimal, _) | isNum t -> UnOp PDecimalT op e+ (L.SUTextOp L.SubString{}, PStringT) -> UnOp PStringT op e+ (L.SUDateOp _, PDateT) -> UnOp PIntT op e+ (_, _) -> P.error err where err = printf "CL.Primitives.scalarUnOp: %s" (P.show (op, t)) castDouble :: Expr -> Expr castDouble = scalarUnOp (L.SUCastOp L.CastDouble) +castDecimal :: Expr -> Expr+castDecimal = scalarUnOp (L.SUCastOp L.CastDecimal)++dateDay :: Expr -> Expr+dateDay = scalarUnOp (L.SUDateOp L.DateDay)++dateMonth :: Expr -> Expr+dateMonth = scalarUnOp (L.SUDateOp L.DateMonth)++dateYear :: Expr -> Expr+dateYear = scalarUnOp (L.SUDateOp L.DateYear)+ not :: Expr -> Expr not = scalarUnOp (L.SUBoolOp L.Not) @@ -310,20 +297,36 @@ substring :: P.Integer -> P.Integer -> Expr -> Expr substring f t = scalarUnOp (L.SUTextOp P.$ L.SubString f t) ----------------------------------------------------------------------------------------+--------------------------------------------------------------------------------- -- Smart constructors for scalar binary operators +-- | Type checking for 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))+ 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 PBoolT op e1 e2+ (L.SBBoolOp _, PBoolT, PBoolT) -> BinOp PBoolT op e1 e2+ (L.SBStringOp L.Like, PStringT, PStringT) -> BinOp PBoolT op e1 e2+ (L.SBDateOp L.AddDays, PIntT, PDateT) -> BinOp PDateT op e1 e2+ (L.SBDateOp L.SubDays, PIntT, PDateT) -> BinOp PDateT op e1 e2+ (L.SBDateOp L.DiffDays, PDateT, PDateT) -> BinOp PIntT op e1 e2+ _ ->+ P.error P.$ printf "CL.Primitives.scalarBinOp: %s" (P.show (op, t1, t2))+ where+ t1 = typeOf e1+ t2 = typeOf e2++addDays :: Expr -> Expr -> Expr+addDays = scalarBinOp (L.SBDateOp L.AddDays)++subDays :: Expr -> Expr -> Expr+subDays = scalarBinOp (L.SBDateOp L.SubDays)++diffDays :: Expr -> Expr -> Expr+diffDays = scalarBinOp (L.SBDateOp L.DiffDays) add :: Expr -> Expr -> Expr add = scalarBinOp (L.SBNumOp L.Add)
+ src/Database/DSH/Common/Impossible.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Common.Impossible (impossible, unimplemented) where++import qualified Language.Haskell.TH as TH++impossible :: TH.ExpQ+impossible = do+ loc <- TH.location+ let pos = (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))+ 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/Common/Kure.hs view
@@ -48,8 +48,8 @@ #endif debugOpt :: Pretty e => String -> e -> Either String e -> e-debugOpt stage origExpr mExpr = #ifdef DEBUGCOMP+debugOpt stage origExpr mExpr = trace (showOrig origExpr) $ either (flip trace origExpr) (\e -> trace (showOpt e) e) mExpr @@ -63,6 +63,7 @@ showOpt :: Pretty e => e -> String showOpt e = padSep (printf "Optimized Query (%s)" stage) ++ pp e ++ padSep "" #else+debugOpt _stage origExpr mExpr = either (const origExpr) id mExpr #endif
src/Database/DSH/Common/Lang.hs view
@@ -1,18 +1,21 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-} module Database.DSH.Common.Lang where import Data.Aeson import Data.Aeson.TH+import Data.Decimal import qualified Data.List.NonEmpty as N-import Text.PrettyPrint.ANSI.Leijen+import qualified Data.Text as T+import qualified Data.Time.Calendar as C+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) import Text.Printf -import Database.DSH.Common.Type-import Database.DSH.Impossible- import Database.DSH.Common.Nat+import Database.DSH.Common.Type instance ToJSON a => ToJSON (N.NonEmpty a) where toJSON (n N.:| nl) = toJSON (n, nl)@@ -24,25 +27,43 @@ -- 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)+data Val = ListV [Val]+ | TupleV [Val]+ | ScalarV ScalarVal+ deriving (Eq, Ord, Show) +instance ToJSON Decimal where+ toJSON = toJSON . show++instance FromJSON Decimal where+ parseJSON s = read <$> parseJSON s++instance FromJSON C.Day where+ parseJSON o = (\(y, m, d) -> C.fromGregorian y m d) <$> parseJSON o++instance ToJSON C.Day where+ toJSON = toJSON . C.toGregorian++data ScalarVal = IntV Int+ | BoolV Bool+ | StringV T.Text+ | DoubleV Double+ | DecimalV Decimal+ | DateV C.Day+ | UnitV+ deriving (Eq, Ord, Show)++$(deriveJSON defaultOptions ''ScalarVal)+ newtype ColName = ColName String deriving (Eq, Ord, Show) $(deriveJSON defaultOptions ''ColName) -- | Typed table columns-type Column = (ColName, Type)+type Column = (ColName, ScalarType) -- | Table keys-newtype Key = Key [ColName] deriving (Eq, Ord, Show)+newtype Key = Key (N.NonEmpty ColName) deriving (Eq, Ord, Show) $(deriveJSON defaultOptions ''Key) @@ -53,13 +74,14 @@ $(deriveJSON defaultOptions ''Emptiness) --- | Catalog information hints that users may give to DSH-data TableHints = TableHints- { keysHint :: [Key]- , nonEmptyHint :: Emptiness+-- | Information about base tables+data BaseTableSchema = BaseTableSchema+ { tableCols :: N.NonEmpty Column+ , tableKeys :: N.NonEmpty Key+ , tableNonEmpty :: Emptiness } deriving (Eq, Ord, Show) -$(deriveJSON defaultOptions ''TableHints)+$(deriveJSON defaultOptions ''BaseTableSchema) -- | Identifiers type Ident = String@@ -69,6 +91,7 @@ -- Scalar operators data UnCastOp = CastDouble+ | CastDecimal deriving (Show, Eq, Ord) $(deriveJSON defaultOptions ''UnCastOp)@@ -96,11 +119,18 @@ $(deriveJSON defaultOptions ''UnTextOp) +data UnDateOp = DateDay+ | DateMonth+ | DateYear+ deriving (Show, Eq, Ord)++$(deriveJSON defaultOptions ''UnDateOp)+ data ScalarUnOp = SUNumOp UnNumOp | SUBoolOp UnBoolOp | SUCastOp UnCastOp | SUTextOp UnTextOp- | SUDateOp+ | SUDateOp UnDateOp deriving (Show, Eq, Ord) $(deriveJSON defaultOptions ''ScalarUnOp)@@ -135,11 +165,19 @@ $(deriveJSON defaultOptions ''BinStringOp) +data BinDateOp = AddDays+ | SubDays+ | DiffDays+ deriving (Show, Eq, Ord)++$(deriveJSON defaultOptions ''BinDateOp)+ -- FIXME this would be a good fit for PatternSynonyms data ScalarBinOp = SBNumOp BinNumOp | SBRelOp BinRelOp | SBBoolOp BinBoolOp | SBStringOp BinStringOp+ | SBDateOp BinDateOp deriving (Show, Eq, Ord) $(deriveJSON defaultOptions ''ScalarBinOp)@@ -206,12 +244,17 @@ instance Pretty Val where pretty (ListV xs) = list $ map pretty xs+ pretty (TupleV vs) = tupled $ map pretty vs+ pretty (ScalarV v) = pretty v++instance Pretty ScalarVal where pretty (IntV i) = int i pretty (BoolV b) = bool b- pretty (StringV s) = dquotes $ string s+ pretty (StringV t) = dquotes $ string $ T.unpack t pretty (DoubleV d) = double d+ pretty (DecimalV d) = text $ show d pretty UnitV = text "()"- pretty (TupleV vs) = tupled $ map pretty vs+ pretty (DateV d) = text $ C.showGregorian d instance Pretty BinRelOp where pretty Eq = text "=="@@ -235,6 +278,21 @@ pretty Conj = text "&&" pretty Disj = text "||" ++instance Pretty BinDateOp where+ pretty AddDays = text "addDays"+ pretty SubDays = text "subDays"+ pretty DiffDays = text "diffDays"++isBinInfixOp :: ScalarBinOp -> Bool+isBinInfixOp op =+ case op of+ SBNumOp{} -> True+ SBRelOp{} -> True+ SBBoolOp{} -> True+ SBStringOp{} -> False+ SBDateOp{} -> False+ instance Pretty UnNumOp where pretty Sin = text "sin" pretty Cos = text "cos"@@ -247,8 +305,14 @@ pretty ATan = text "atan" instance Pretty UnCastOp where- pretty CastDouble = text "double"+ pretty CastDouble = text "double"+ pretty CastDecimal = text "decimal" +instance Pretty UnDateOp where+ pretty DateDay = text "dateDay"+ pretty DateMonth = text "dateMonth"+ pretty DateYear = text "dateYear"+ instance Pretty JoinUnOp where pretty (JUNumOp o) = pretty o pretty (JUCastOp o) = pretty o@@ -267,17 +331,17 @@ 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+ pretty (JoinConjunct e1 op e2) = pretty e1 <+> pretty op <+> pretty e2 instance Pretty e => Pretty (JoinPredicate e) where- pretty (JoinPred ps) = list $ map pretty $ N.toList ps-+ pretty (JoinPred ps) = hcat $ punctuate (text " && ") $ 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+ pretty (SBDateOp o) = pretty o instance Pretty UnBoolOp where pretty Not = text "not"@@ -286,7 +350,7 @@ pretty (SUNumOp op) = pretty op pretty (SUBoolOp op) = pretty op pretty (SUCastOp op) = pretty op- pretty SUDateOp = $unimplemented+ pretty (SUDateOp op) = pretty op pretty (SUTextOp op) = pretty op instance Pretty UnTextOp where
src/Database/DSH/Common/Nat.hs view
@@ -5,6 +5,16 @@ -- | Natural numbers that encode lifting levels data Nat = Zero | Succ Nat deriving (Show, Eq) +instance Ord Nat where+ Zero <= Succ _ = True+ Succ n1 <= Succ n2 = n1 <= n2+ _ <= _ = False++(.-) :: Nat -> Nat -> Maybe Nat+n1 .- Zero = Just n1+Succ n1 .- Succ n2 = n1 .- n2+Zero .- Succ _ = Nothing+ intFromNat :: Nat -> Int intFromNat Zero = 0 intFromNat (Succ n) = 1 + intFromNat n@@ -16,7 +26,7 @@ tupleIndex First = 1 tupleIndex (Next f) = 1 + tupleIndex f -intIndex :: Int -> TupleIndex +intIndex :: Int -> TupleIndex intIndex i = assert (i >= 1) $ if i > 1 then Next $ (intIndex $ i - 1)
+ src/Database/DSH/Common/Opt.hs view
@@ -0,0 +1,86 @@+-- | Common code for DAG-based algebra optimizers.+module Database.DSH.Common.Opt+ ( 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+ , lookupUnsafe+ ) where++import qualified Data.IntMap as M++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.Common.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++--------------------------------------------------------------------------------++-- | 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/Common/Pretty.hs view
@@ -1,9 +1,121 @@-module Database.DSH.Common.Pretty +module Database.DSH.Common.Pretty ( pp , Pretty, pretty+ , combinator, join, comp, super, sub, forget, kw, dist, restrict+ , prettyJoin, prettyComp, prettyApp2, prettyUnOp+ , prettyInfixBinOp, prettyPrefixBinOp, prettyLet, prettyIf+ , prettyTuple ) where -import Text.PrettyPrint.ANSI.Leijen+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))+import qualified Text.PrettyPrint.ANSI.Leijen as P pp :: Pretty a => a -> String-pp a = (displayS $ renderPretty 0.9 120 $ pretty a) ""+pp a = (displayS $ renderPretty 0.9 140 $ pretty a) ""++--------------------------------------------------------------------------------+-- Highlighting of various syntactical elements++combinator :: Doc -> Doc+combinator = dullyellow++kw :: Doc -> Doc+kw = bold++join :: Doc -> Doc+join = yellow++comp :: Doc -> Doc+comp = red++tuple :: Doc -> Doc+tuple = green++super :: Doc -> Doc+super = red++sub :: Doc -> Doc+sub = red++forget :: Doc -> Doc+forget = blue++restrict :: Doc -> Doc+restrict = magenta++dist :: Doc -> Doc+dist = cyan++--------------------------------------------------------------------------------+-- Pretty-printing of various syntactical elements++prettyIf :: Doc -> Doc -> Doc -> Doc+prettyIf c t e =+ group $ align $ kw (text "if") <+> c+ P.<$> kw (text "then") <+> t+ P.<$> kw (text "else") <+> e++prettyLet :: Doc -> Doc -> Doc -> Doc+prettyLet x e1 e2 =+ group $ align $ (kw (text "let") <+> x <+> kw (char '=') <+> e1)+ P.<$>+ kw (text "in") <+> e2+++prettyTuple :: [Doc] -> Doc+prettyTuple es =+ case es of+ [] -> left <+> right+ [e] -> left <+> e <+> right+ (e1:e2:es') ->+ align $ cat $ [left <+> e1]+ +++ (map (tuple comma <+>) $ init (e2 : es'))+ +++ [tuple comma <+> last (e2 : es') <> space]+ +++ [right]++ where+ left = tuple lparen+ right = tuple rparen++prettyComp :: Doc -> [Doc] -> Doc+prettyComp headExpr quals+ = case quals of+ [] -> left <+> headExpr <+> right+ (q:qs) ->+ -- We have to insert spaces after the head expression (for+ -- '|') and after the last qualifier (for '|') for the+ -- case of the comprehension being rendered on one line.+ let qsDocs = comp (char '|') <+> q : map (comp comma <+>) qs+ in align $ cat $ (left <+> headExpr <> space)+ :+ (init qsDocs)+ +++ [last qsDocs <> space]+ +++ [right]+ where+ left = comp lbracket+ right = comp rbracket++prettyJoin :: Doc -> Doc -> Doc -> Doc+prettyJoin op xs ys =+ group $ hang 4 $ op P.<$> (vsep [xs, ys])++prettyApp2 :: Doc -> Doc -> Doc -> Doc+prettyApp2 op xs ys =+ group $ op <+> (align $ xs P.<$> ys)++prettyUnOp :: Doc -> Doc -> Doc+prettyUnOp op x =+ op <+> x++prettyInfixBinOp :: Doc -> Doc -> Doc -> Doc+prettyInfixBinOp op x y =+ group $ (align $ x P.<$> op P.<$> y)++prettyPrefixBinOp :: Doc -> Doc -> Doc -> Doc+prettyPrefixBinOp op x y =+ group $ op <+> (align $ x P.<$> y)
src/Database/DSH/Common/QueryPlan.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE TemplateHaskell #-} -- | A QueryPlan describes the computation of the top-level query@@ -5,81 +6,102 @@ -- result's structure is encoded by the individual queries. module Database.DSH.Common.QueryPlan where +import Data.Aeson import Data.Aeson.TH+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Foldable as F+import qualified Data.Traversable as T import Database.Algebra.Dag import Database.Algebra.Dag.Common -import Database.DSH.VL.Vector+import Database.DSH.Common.Vector -- | A Layout describes the tuple structure of values encoded by -- one particular query from a bundle.-data Layout q = LCol Int+data Layout q = LCol | LNest q (Layout q) | LTuple [Layout q] deriving (Show, Read) +instance Functor Layout where+ fmap _ LCol = LCol+ fmap f (LNest q lyt) = LNest (f q) (fmap f lyt)+ fmap f (LTuple lyts) = LTuple (fmap (fmap f) lyts)++instance F.Foldable Layout where+ foldr _ z LCol = z+ foldr f z (LNest q lyt) = f q (F.foldr f z lyt)+ foldr f z (LTuple lyts) = F.foldr (\l b -> F.foldr f b l) z lyts++instance T.Traversable Layout where+ traverse _ LCol = pure LCol+ traverse f (LNest q lyt) = LNest <$> f q <*> T.traverse f lyt+ traverse f (LTuple lyts) = LTuple <$> T.traverse (T.traverse f) lyts+ -- | 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+data Shape q = VShape q (Layout q) -- ^ A regular vector shape+ | SShape q (Layout q) -- ^ A shape for a singleton vector deriving (Show, Read) +instance Functor Shape where+ fmap f (VShape q lyt) = VShape (f q) (fmap f lyt)+ fmap f (SShape q lyt) = SShape (f q) (fmap f lyt)++instance F.Foldable Shape where+ foldr f z (VShape q lyt) = f q (F.foldr f z lyt)+ foldr f z (SShape q lyt) = f q (F.foldr f z lyt)++instance T.Traversable Shape where+ traverse f (VShape q lyt) = VShape <$> f q <*> T.traverse f lyt+ traverse f (SShape q lyt) = SShape <$> f q <*> T.traverse f lyt+ $(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+shapeNodes shape = F.foldMap (\v -> vectorNodes v) shape -- | 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+updateShape old new shape = fmap (updateVector old new) shape +-- | Determine the number of relational attributes needed in a vector. columnsInLayout :: Layout q -> Int-columnsInLayout (LCol _) = 1+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]- }+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] +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 + , queryTags = tagMap }++-- | Export a query plan to two files. One file (.plan) contains the+-- DAG for compability with algebra-* dot generators. The other file+-- contains the shape information.+exportPlan :: (ToJSON a, ToJSON v) => String -> QueryPlan a v -> IO ()+exportPlan prefix plan = do+ BL.writeFile (prefix ++ ".plan") (encode $ queryDag plan)+ BL.writeFile (prefix ++ ".shape") (encode $ queryShape plan)
src/Database/DSH/Common/RewriteM.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE InstanceSigs #-} +-- | The Rewrite monad for KURE-based rewriting systems in DSH. module Database.DSH.Common.RewriteM ( RewriteM , RewriteStateM@@ -15,9 +16,7 @@ , liftstate ) where -import Control.Applicative import Control.Monad- import Language.KURE import Database.DSH.Common.Lang@@ -41,17 +40,17 @@ 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 #-} - +{-# INLINE bindM #-}+ failM :: String -> RewriteM s a failM msg = RewriteM (\n -> (n, Left msg)) {-# INLINE failM #-}@@ -63,7 +62,7 @@ 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 #-} +{-# INLINE catchRewriteM #-} instance Functor (RewriteM s) where@@ -84,7 +83,7 @@ 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))) @@ -93,7 +92,7 @@ if v `elem` vs then freshNameS vs else return v- + get :: RewriteStateM s s get = RewriteM $ \(i, s) -> ((i, s), Right s) {-# INLINE get #-}@@ -107,26 +106,11 @@ {-# INLINE modify #-} stateful :: s -> RewriteStateM s a -> RewriteM Int (s, a)-stateful s ma = RewriteM $ \i -> +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/TH.hs view
@@ -0,0 +1,15 @@+-- | Helper functions for TH code+module Database.DSH.Common.TH+ ( nameTyApp+ , equalConstrTy+ ) where++import Language.Haskell.TH++-- | Apply a named type constructor to a type+nameTyApp :: Name -> Type -> Type+nameTyApp className tyVar = AppT (ConT className) tyVar++-- | Construct a type that expresses an equality constraint.+equalConstrTy :: Type -> Type -> Type+equalConstrTy t1 t2 = AppT (AppT EqualityT t1) t2
src/Database/DSH/Common/Type.hs view
@@ -2,9 +2,12 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-} -module Database.DSH.Common.Type +-- | Types for backend languages.+module Database.DSH.Common.Type ( isNum+ , scalarType , isList , elemT , tupleElemT@@ -18,75 +21,92 @@ , liftType , liftTypeN , Type(..)- , intT- , boolT- , unitT- , stringT- , doubleT- , listT- , pairT+ , ScalarType(..)+ , pattern PIntT+ , pattern PBoolT+ , pattern PUnitT+ , pattern PStringT+ , pattern PDoubleT+ , pattern PDecimalT+ , pattern PDateT+ , pattern PPairT , Typed (..) ) where +import Debug.Trace++import Data.Aeson.TH+ import Text.PrettyPrint.ANSI.Leijen -import Database.DSH.Impossible+import Database.DSH.Common.Impossible import Database.DSH.Common.Pretty import Database.DSH.Common.Nat- -instance Pretty Type where ++instance Pretty Type where+ pretty (ListT t) = brackets $ pretty t+ pretty (TupleT ts) = tupled $ map pretty ts+ pretty (ScalarT t) = pretty t++instance Pretty ScalarType where pretty IntT = text "Int"+ pretty DecimalT = text "Decimal" 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+ pretty DateT = text "Date" -- | We use the following type language to type the various -- intermediate languages.-data Type = IntT - | BoolT - | DoubleT- | StringT - | UnitT - | ListT Type+data Type = ListT Type | TupleT [Type]+ | ScalarT ScalarType deriving (Show, Eq, Ord) ++data ScalarType = IntT+ | BoolT+ | DoubleT+ | StringT+ | UnitT+ | DecimalT+ | DateT+ deriving (Show, Eq, Ord)+++-- | Is the (scalar) type numeric? 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+isNum (ScalarT IntT) = True+isNum (ScalarT DoubleT) = True+isNum (ScalarT DecimalT) = True+isNum (ScalarT BoolT) = False+isNum (ScalarT StringT) = False+isNum (ScalarT UnitT) = False+isNum (ScalarT DateT) = False -boolT :: Type-boolT = BoolT+scalarType :: Type -> Maybe ScalarType+scalarType (ScalarT t) = Just t+scalarType _ = Nothing -unitT :: Type-unitT = UnitT+--------------------------------------------------------------------------------+-- Smart constructors and deconstructors. -listT :: Type -> Type-listT = ListT+pattern PIntT = ScalarT IntT+pattern PStringT = ScalarT StringT+pattern PDoubleT = ScalarT DoubleT+pattern PDecimalT = ScalarT DecimalT+pattern PBoolT = ScalarT BoolT+pattern PDateT = ScalarT DateT+pattern PUnitT = ScalarT UnitT -pairT :: Type -> Type -> Type-pairT t1 t2 = TupleT [t1, t2]+pattern PPairT t1 t2 = TupleT [t1, t2] isList :: Type -> Bool isList (ListT _) = True-isList _ = False+isList _ = False elemT :: Type -> Type elemT (ListT t) = t@@ -98,7 +118,7 @@ tupleElemTypes :: Type -> [Type] tupleElemTypes (TupleT ts) = ts-tupleElemTypes _ = $impossible+tupleElemTypes t = trace (show t) $ $impossible listDepth :: Type -> Int listDepth (ListT t1) = 1 + listDepth t1@@ -113,7 +133,7 @@ sndT _ = error "Type is not a pair type" extractShape :: Type -> Type -> Type-extractShape (ListT t1) = \x -> listT $ extractShape t1 x+extractShape (ListT t1) = \x -> ListT $ extractShape t1 x extractShape _ = \x -> x liftTypeN :: Nat -> Type -> Type@@ -121,7 +141,7 @@ liftTypeN (Succ n) t = liftTypeN n $ liftType t liftType :: Type -> Type-liftType t = listT t +liftType t = ListT t unliftTypeN :: Nat -> Type -> Type unliftTypeN Zero t = t@@ -131,5 +151,13 @@ unliftType (ListT t1) = t1 unliftType t = error $ "Type: " ++ pp t ++ " cannot be unlifted." +--------------------------------------------------------------------------------++-- | Typed terms class Typed a where typeOf :: a -> Type++--------------------------------------------------------------------------------+-- Aeson instances for JSON serialization++$(deriveJSON defaultOptions ''ScalarType)
+ src/Database/DSH/Common/Vector.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | This module defines the kinds of vectors that occur in VL+-- programs.+module Database.DSH.Common.Vector+ ( DBCol+ , ColName+ , RelationalVector(..)+ , DagVector+ , vectorNodes+ , updateVector+ , ADVec(..)+ , VLDVec(..)+ , NDVec+ , VLRVec(..)+ , VLKVec(..)+ , VLSVec(..)+ , VLFVec(..)+ ) where++import Data.Aeson.TH+import qualified Data.Vector as V++import Database.Algebra.Dag.Common++import Database.DSH.VL.Lang++type ColName = String++--------------------------------------------------------------------------------+-- Abstractions over data vectors++-- | Concrete encodings of data vectors explicitly represent ordering+-- and segment information in relational columns.+class RelationalVector v where+ rvKeyCols :: v -> [ColName]+ rvRefCols :: v -> [ColName]+ rvItemCols :: v -> V.Vector ColName++-- | Common properties of data vectors that are represented by a DAG+-- plan of operators.+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++--------------------------------------------------------------------------------+-- Simple data vectors++-- | 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 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++--------------------------------------------------------------------------------+-- Abstract vector types for vectorization++-- | 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++-- | Replication vectors. A @NRVec@ simply references a node in an+-- algebra Dag.+newtype VLRVec = VLRVec AlgNode++-- | Rekeying vectors. A @NKVec@ simply references a node in an algebra+-- Dag.+newtype VLKVec = VLKVec AlgNode++-- | Filtering vectors. A @NFVec@ simply references a node in an algebra+-- Dag.+newtype VLFVec = VLFVec AlgNode++-- | Sorting vectors. A @NSVec@ simply references a node in an algebra+-- Dag.+newtype VLSVec = VLSVec AlgNode++$(deriveJSON defaultOptions ''ADVec)+$(deriveJSON defaultOptions ''VLRVec)+$(deriveJSON defaultOptions ''VLKVec)+$(deriveJSON defaultOptions ''VLSVec)+$(deriveJSON defaultOptions ''VLFVec)+$(deriveJSON defaultOptions ''VLDVec)
src/Database/DSH/Compiler.hs view
@@ -1,132 +1,215 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} -- | Compilation, execution and introspection of queries module Database.DSH.Compiler- ( -- * Executing queries- runQ- -- * Debug functions- , debugQ- , debugVL- , debugVLOpt- , debugTA- , debugTAOpt- , runPrint- ) where+ ( -- * Executing queries+ runQ+ -- * Debugging and benchmarking queries+ , debugQ+ , codeQ+ , vectorPlanQ+ , showComprehensionsQ+ , showComprehensionsOptQ+ , showDesugaredQ+ , showDesugaredOptQ+ , showLiftedQ+ , showLiftedOptQ+ , showFlattenedQ+ , showFlattenedOptQ+ , showVectorizedQ+ , showVectorizedOptQ+ ) where -import Control.Applicative import Control.Arrow-import qualified Database.HDBC.PostgreSQL as H+import Control.Monad+import qualified Data.Foldable as F+import System.Process+import System.Random+import Text.Printf import Database.DSH.Translate.Frontend2CL-import Database.DSH.Execute.Sql -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.Backend+import qualified Database.DSH.CL.Lang as CL import Database.DSH.CL.Opt+import Database.DSH.Common.Pretty import Database.DSH.Common.QueryPlan-import Database.DSH.Export+import Database.DSH.Common.Vector+import Database.DSH.Execute+import Database.DSH.FKL.Rewrite 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.NKL.Rewrite import Database.DSH.Translate.CL2NKL import Database.DSH.Translate.FKL2VL import Database.DSH.Translate.NKL2FKL-import Database.DSH.Translate.VL2Algebra+import qualified Database.DSH.VL.Lang as VL+import Database.DSH.VL.Opt.OptimizeVL ----------------------------------------------------------------------------------- Different versions of the flattening compiler pipeline --- | Backend-agnostic part of the pipeline.-commonPipeline :: CL.Expr -> QueryPlan VL.VL VLDVec-commonPipeline =- optimizeComprehensions- >>> desugarComprehensions- >>> optimizeNKL- >>> flatTransform- >>> specializeVectorOps+-- | The backend-independent part of the compiler.+compileQ :: CL.Expr -> QueryPlan VL.VL VLDVec+compileQ = optimizeComprehensions >>>+ desugarComprehensions >>>+ optimizeNKL >>>+ flatTransform >>>+ specializeVectorOps -nkl2Sql :: CL.Expr -> Shape (BackendCode SqlBackend)-nkl2Sql =- commonPipeline- >>> optimizeVLDefault- >>> implementVectorOpsPF- >>> optimizeTA- >>> generateSqlQueries+-- | Compile a query and execute it on a given backend connection.+runQ :: forall a c.+ (Backend c,QA a)+ => c -> Q a -> IO a+runQ c (Q q) = do+ let ty = reify (undefined :: Rep a)+ let cl = toComprehensions q+ let vl = compileQ cl+ let bp = generatePlan $ optimizeVLDefault vl+ let bc = generateCode bp+ frExp <$> execQueryBundle c bc ty -nkl2TAFile :: String -> CL.Expr -> IO ()-nkl2TAFile prefix =- commonPipeline- >>> optimizeVLDefault- >>> implementVectorOpsPF- >>> (exportTAPlan prefix)+-------------------------------------------------------------------------------- -nkl2TAFileOpt :: String -> CL.Expr -> IO ()-nkl2TAFileOpt prefix =- commonPipeline- >>> optimizeVLDefault- >>> implementVectorOpsPF- >>> optimizeTA- >>> exportTAPlan (prefix ++ "_opt")+-- | Compile a query and dump intermediate plans to files.+debugQ :: forall a c.(Backend c, QA a)+ => String+ -> c+ -> Q a+ -> IO ()+debugQ prefix _ (Q q) = do+ let cl = toComprehensions q+ let vl = compileQ cl+ let vlOpt = optimizeVLDefault vl+ exportPlan (prefix ++ "_vl") vl+ exportPlan (prefix ++ "_vl_opt") vlOpt+ let bp = generatePlan vlOpt :: BackendPlan c+ void $ dumpPlan prefix False bp+ void $ dumpPlan prefix True bp -nkl2VLFile :: String -> CL.Expr -> IO ()-nkl2VLFile prefix = commonPipeline >>> exportVLPlan prefix+vectorPlanQ :: forall a. QA a+ => Q a+ -> QueryPlan VL.VL VLDVec+vectorPlanQ (Q q) =+ optimizeVLDefault $ compileQ $ toComprehensions q -nkl2VLFileOpt :: String -> CL.Expr -> IO ()-nkl2VLFileOpt prefix =- commonPipeline- >>> optimizeVLDefault- >>> exportVLPlan (prefix ++ "_opt")+-- | Compile a query to the actual backend code that will be executed+-- (for benchmarking purposes).+codeQ :: forall a c.(Backend c, QA a)+ => c+ -> Q a+ -> [BackendCode c]+codeQ _ (Q q) =+ let vl = optimizeVLDefault $ compileQ $ toComprehensions q+ plan = generatePlan vl :: BackendPlan c+ shape = generateCode plan :: Shape (BackendCode c)+ in F.foldr (:) [] shape ----------------------------------------------------------------------------------- Functions for executing and debugging DSH queries via the Flattening backend --- | 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+decorate :: String -> String+decorate msg = sepLine ++ msg ++ "\n" ++ sepLine+ where+ sepLine = replicate 80 '-' ++ "\n" --- | 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'+-- | Show unoptimized comprehensions (CL)+showComprehensionsQ :: forall a.QA a => Q a -> IO ()+showComprehensionsQ (Q q) = do+ let cl = toComprehensions q+ putStrLn $ decorate $ pp cl --- | 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'+-- | Show optimized comprehensions (CL)+showComprehensionsOptQ :: forall a. QA a => Q a -> IO ()+showComprehensionsOptQ (Q q) = do+ let cl = optimizeComprehensions $ toComprehensions q+ putStrLn $ decorate $ pp cl --- | 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'+-- | Show unoptimized desugared iterators (CL)+showDesugaredQ :: forall a. QA a => Q a -> IO ()+showDesugaredQ (Q q) = do+ let nkl = desugarComprehensions+ $ optimizeComprehensions+ $ toComprehensions q+ putStrLn $ decorate $ pp nkl --- | 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'+-- | Show optimized desugared iterators (CL)+showDesugaredOptQ :: forall a. QA a => Q a -> IO ()+showDesugaredOptQ (Q q) = do+ let nkl = optimizeNKL+ $ desugarComprehensions+ $ optimizeComprehensions+ $ toComprehensions q+ putStrLn $ decorate $ pp nkl --- | 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+-- | Show unoptimized lifted operators (FKL intermediate)+showLiftedQ :: forall a. QA a => Q a -> IO ()+showLiftedQ (Q q) = do+ let fkl = liftOperators+ $ optimizeNKL+ $ desugarComprehensions+ $ optimizeComprehensions+ $ toComprehensions q+ putStrLn $ decorate $ pp fkl --- | 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+-- | Show optimized lifted operators (FKL intermediate)+showLiftedOptQ :: forall a. QA a => Q a -> IO ()+showLiftedOptQ (Q q) = do+ let fkl = optimizeFKL+ $ liftOperators+ $ optimizeNKL+ $ desugarComprehensions+ $ optimizeComprehensions+ $ toComprehensions q+ putStrLn $ decorate $ pp fkl++-- | Show unoptimized flattened query (FKL)+showFlattenedQ :: forall a. QA a => Q a -> IO ()+showFlattenedQ (Q q) = do+ let fkl = normalizeLifted+ $ optimizeFKL+ $ liftOperators+ $ optimizeNKL+ $ desugarComprehensions+ $ optimizeComprehensions+ $ toComprehensions q+ putStrLn $ decorate $ pp fkl++-- | Show optimized flattened query (FKL)+showFlattenedOptQ :: forall a. QA a => Q a -> IO ()+showFlattenedOptQ (Q q) = do+ let fkl = optimizeNormFKL+ $ normalizeLifted+ $ optimizeFKL+ $ liftOperators+ $ optimizeNKL+ $ desugarComprehensions+ $ optimizeComprehensions+ $ toComprehensions q+ putStrLn $ decorate $ pp fkl++fileId :: IO String+fileId = sequence $ replicate 8 $ (randomRIO ('a', 'z'))++-- | Show unoptimized vector plan (VL)+showVectorizedQ :: forall a. QA a => Q a -> IO ()+showVectorizedQ (Q q) = do+ let cl = toComprehensions q+ let vl = compileQ cl+ h <- fileId+ let fileName = "q_vl_" ++ h+ exportPlan fileName vl+ void $ runCommand $ printf ".cabal-sandbox/bin/vldot -i %s.plan | dot -Tpdf -o %s.pdf" fileName fileName+ void $ runCommand $ printf "evince %s.pdf" fileName++-- | Show optimized vector plan (VL)+showVectorizedOptQ :: forall a. QA a => Q a -> IO ()+showVectorizedOptQ (Q q) = do+ let cl = toComprehensions q+ let vl = optimizeVLDefault $ compileQ cl+ h <- fileId+ let fileName = "q_vl_" ++ h+ exportPlan fileName vl+ void $ runCommand $ printf ".cabal-sandbox/bin/vldot -i %s.plan | dot -Tpdf -o %s.pdf" fileName fileName+ void $ runCommand $ printf "evince %s.pdf" fileName+
+ src/Database/DSH/Execute.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.Execute+ ( execQueryBundle+ ) where++import Control.Monad.State+import qualified Data.DList as D+import qualified Data.HashMap.Lazy as M+import Data.List+import qualified Data.Vector as V+import Text.Printf++import Database.DSH.Common.Pretty+import Database.DSH.Common.QueryPlan+import Database.DSH.Common.Vector++import Database.DSH.Backend+import Database.DSH.Common.Impossible+import Database.DSH.Execute.TH+import qualified Database.DSH.Frontend.Internals as F++------------------------------------------------------------------------------+-- 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+-- FIXME use newtypes to keep key and ref columns apart+data TabLayout a where+ TCol :: F.Type a -> ColName -> TabLayout a+ TNest :: (F.Reify a, Backend c)+ => F.Type [a]+ -> [BackendRow c]+ -> [ColName]+ -> [ColName]+ -> 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 = M.HashMap CompositeKey (F.Exp a)++-- | Row layout with nesting data in the form of segment maps+data SegLayout a where+ SCol :: F.Type a -> ColName -> SegLayout a+ SNest :: F.Reify a => F.Type [a] -> SegMap [a] -> SegLayout [a]+ STuple :: SegTuple a -> SegLayout a++--------------------------------------------------------------------------------+-- Turn layouts into layouts with explicit column names++data ColLayout q = CCol ColName+ | CNest q (ColLayout q)+ | CTuple [ColLayout q]++-- | Annotate every column reference with its column index in a flat+-- column layout.+columnIndexes :: RelationalVector v => V.Vector ColName -> Layout v -> ColLayout v+columnIndexes itemCols lyt = evalState (numberCols itemCols lyt) 1++numberCols :: RelationalVector v => V.Vector ColName -> Layout v -> State Int (ColLayout v)+numberCols itemCols LCol = currentCol >>= \i -> return (CCol $ itemCols V.! (i - 1))+numberCols itemCols (LTuple lyts) = CTuple <$> mapM (numberCols itemCols) lyts+numberCols _ (LNest q lyt) = CNest q <$> posBracket (numberCols (rvItemCols q) lyt)++currentCol :: State Int Int+currentCol = do+ i <- get+ put $ i + 1+ return i++posBracket :: State Int (ColLayout q) -> State Int (ColLayout q)+posBracket ma = do+ c <- get+ put 1+ a <- ma+ put c+ return a++--------------------------------------------------------------------------------+-- Execute flat queries and construct result values++execQueryBundle :: Backend c+ => c+ -> Shape (BackendCode c)+ -> F.Type a+ -> IO (F.Exp a)+execQueryBundle conn shape ty =+ transactionally conn $ \conn' ->+ case (shape, ty) of+ (VShape q lyt, F.ListT ety) -> do+ tab <- execFlatQuery conn' q+ tlyt <- execNested conn' (columnIndexes (rvItemCols q) lyt) ety+ return $ fromVector tab (rvKeyCols q) tlyt+ (SShape q lyt, _) -> do+ tab <- execFlatQuery conn' q+ tlyt <- execNested conn' (columnIndexes (rvItemCols q) lyt) ty+ return $ fromPrim tab (rvKeyCols q) tlyt+ _ -> $impossible++-- | Traverse the layout and execute all subqueries for nested vectors+execNested :: Backend c+ => c -> ColLayout (BackendCode c)+ -> F.Type a+ -> IO (TabLayout a)+execNested conn lyt ty =+ case (lyt, ty) of+ (CCol i, t) -> return $ TCol t i+ (CNest q clyt, F.ListT t) -> do+ tab <- execFlatQuery conn q+ clyt' <- execNested conn clyt t+ return $ TNest ty tab (rvKeyCols q) (rvRefCols q) clyt'+ (CTuple lyts, F.TupleT tupTy) -> let execTuple = $(mkExecTuple 16)+ in execTuple lyts tupTy+ (_, _) ->+ error $ printf "Type does not match query structure: %s" (pp ty)++------------------------------------------------------------------------------+-- Construct result value terms from raw tabular results++-- | Construct a list from an outer vector+fromVector :: (F.Reify a, Row r) => [r] -> [ColName] -> TabLayout a -> F.Exp [a]+fromVector tab keyCols tlyt =+ let slyt = segmentLayout tlyt+ in F.ListE $ D.toList $ foldl' (vecIter keyCols slyt) D.empty tab++-- | Construct one element value of the result list from a single row+-- of the outer vector.+vecIter :: Row r+ => [ColName]+ -> SegLayout a+ -> D.DList (F.Exp a)+ -> r+ -> D.DList (F.Exp a)+vecIter keyCols slyt vals row =+ let val = constructVal keyCols slyt row+ in D.snoc vals val++-- | Construct a single value from an outer vector+fromPrim :: Row r => [r] -> [ColName] -> TabLayout a -> F.Exp a+fromPrim tab keyCols tlyt =+ let slyt = segmentLayout tlyt+ in case tab of+ [row] -> constructVal keyCols 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 i -> SCol ty i+ TNest ty tab keyCols refCols clyt ->+ let slyt = segmentLayout clyt+ in SNest ty (mkSegMap keyCols refCols tab slyt)+ TTuple tup ->+ let segmentTuple = $(mkSegmentTupleFun 16)+ in STuple $ segmentTuple tup++data SegAcc a = SegAcc+ { saCurrSeg :: CompositeKey+ , saSegMap :: SegMap [a]+ , saCurrVec :: D.DList (F.Exp a)+ }++-- | Construct a segment map from a segmented vector+mkSegMap :: (F.Reify a, Row r)+ => [ColName]+ -> [ColName]+ -> [r]+ -> SegLayout a+ -> SegMap [a]+mkSegMap keyCols refCols tab slyt =+ let -- FIXME using the empty list as the starting key is not exactly nice+ initialAcc = SegAcc { saCurrSeg = (CompositeKey [])+ , saSegMap = M.empty+ , saCurrVec = D.empty+ }+ finalAcc = foldl' (segIter keyCols refCols slyt) initialAcc tab+ in M.insert (saCurrSeg finalAcc)+ (F.ListE $ D.toList $ saCurrVec finalAcc)+ (saSegMap finalAcc)++-- | Fold iterator that constructs a map from segment descriptor to+-- the list value that is represented by that segment+segIter :: (F.Reify a, Row r)+ => [ColName]+ -> [ColName]+ -> SegLayout a+ -> SegAcc a+ -> r+ -> SegAcc a+segIter keyCols refCols lyt acc row =+ let val = constructVal keyCols lyt row+ ref = mkCKey row refCols+ in if ref == saCurrSeg acc+ then acc { saCurrVec = D.snoc (saCurrVec acc) val }+ else acc { saCurrSeg = ref+ , saSegMap = M.insert (saCurrSeg acc)+ (F.ListE $ D.toList $ saCurrVec acc)+ (saSegMap acc)+ , saCurrVec = D.singleton val+ }++------------------------------------------------------------------------------+-- Construct values from table rows++mkCKey :: Row r => r -> [ColName] -> CompositeKey+mkCKey r cs = CompositeKey $ map (keyVal . flip col r) cs++-- | Construct a value from a vector row according to the given layout+constructVal :: Row r => [ColName] -> SegLayout a -> r -> F.Exp a+constructVal keyCols lyt row =+ case lyt of+ STuple stup -> let constructTuple = $(mkConstructTuple 16)+ in constructTuple keyCols stup row+ SNest _ segMap -> case M.lookup (mkCKey row keyCols) segMap of+ Just v -> v+ Nothing -> F.ListE []+ SCol F.DoubleT c -> doubleVal (col c row)+ SCol F.IntegerT c -> integerVal (col c row)+ SCol F.BoolT c -> boolVal (col c row)+ SCol F.CharT c -> charVal (col c row)+ SCol F.TextT c -> textVal (col c row)+ SCol F.UnitT c -> unitVal (col c row)+ SCol F.DayT c -> dayVal (col c row)+ SCol F.DecimalT c -> decimalVal (col c row)+ SCol _ _ -> $impossible++--------------------------------------------------------------------------------
− src/Database/DSH/Execute/Backend.hs
@@ -1,183 +0,0 @@-{-# 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
@@ -1,83 +0,0 @@-{-# 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
@@ -8,13 +8,13 @@ , mkConstructTuple ) where -import Control.Applicative import Language.Haskell.TH import Data.List import Text.Printf -import Database.DSH.Impossible+import Database.DSH.Common.Impossible+import Database.DSH.Common.TH import Database.DSH.Frontend.TupleTypes import qualified Database.DSH.Frontend.Internals as DSH @@ -43,7 +43,7 @@ mkExecNestedStmt :: Name -> Name -> Name -> Stmt mkExecNestedStmt tyName lytName resLytName = let execNested = VarE $ mkName "execNested"- conn = VarE $ mkName "conn" + conn = VarE $ mkName "conn" callE = AppE (AppE (AppE execNested conn) (VarE lytName)) (VarE tyName) in BindS (VarP resLytName) callE@@ -56,18 +56,18 @@ -- '([lyt1, ..., lyt<n>], Tuple<n>T ty1 ... ty<n>)' let pat = TupP [ ListP $ map VarP lytNames- , ConP (tupTyConstName width) (map VarP tyNames)+ , ConP (tupTyConstName "F" 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 + $ 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@@ -81,7 +81,7 @@ -- 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.@@ -116,14 +116,14 @@ -- (t1, ..., t<n>) tupTy = foldl' AppT (TupleT width) $ map VarT tupElemTyNames- + -- a ~ (t1, ..., t<n>)- tupConstraint = EqualP (VarT tupTyName) tupTy+ tupConstraint = equalConstrTy (VarT tupTyName) tupTy -- Reify t1, ..., Reify t<n>- reifyConstraints = map (\n -> ClassP ''DSH.Reify [VarT n]) tupElemTyNames+ reifyConstraints = map (\n -> nameTyApp ''DSH.Reify (VarT n)) tupElemTyNames - constraints = tupConstraint : reifyConstraints + constraints = tupConstraint : reifyConstraints let -- 'Type a' dshTypeTy = (NotStrict, AppT (ConT ''DSH.Type) (VarT tupTyName))@@ -131,8 +131,8 @@ elemLytTys = [ (NotStrict, lytTyCons (VarT t)) -- AppT (ConT $ mkName "TabLayout") (VarT t)) | t <- tupElemTyNames ]- argTys = dshTypeTy : elemLytTys - + argTys = dshTypeTy : elemLytTys+ return $ ForallC tyVarBinders constraints $ NormalC (conName width) {- (tabTupleConsName width) -} argTys @@ -140,16 +140,16 @@ -- tabular query results. -- @ -- data TabTuple a where--- TTuple3 :: (Reify t1, ..., Reify t<n>) => Type (t1, ..., t<n>) --- -> TabLayout t1 --- -> ... --- -> TabLayout t<n> +-- 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>),@@ -162,7 +162,7 @@ mkTupleLyt tyName lytTyCons conName maxWidth = do tupTyName <- newName "a" cons <- mapM (mkTupleLytCons tupTyName lytTyCons conName) [2..maxWidth]- + return $ [DataD [] tyName [PlainTV tupTyName] cons []] --------------------------------------------------------------------------------@@ -199,22 +199,22 @@ let tuplePat = ConP (tabTupleConsName width) (VarP tyName : map VarP lytNames) let segFun = VarE $ mkName "segmentLayout"- segLyts = map ((AppE segFun) . VarE) lytNames+ segLyts = map (\l -> AppE segFun (VarE l)) lytNames - let bodyExp = foldl' AppE (ConE $ segTupleConsName width) + 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 -> +--+-- \keyCols lyt -> -- case lyt of -- ...--- (TTuple<n> ty tlyt1 ... tlyt<n>) = STuple<n> ty (segmentLayout tlyt1) +-- (TTuple<n> ty tlyt1 ... tlyt<n>) = STuple<n> ty (segmentLayout keyCols tlyt1) -- ...--- (segmentLayout tlyt<n>)+-- (segmentLayout keyCols tlyt<n>) -- @ mkSegmentTupleFun :: Int -> Q Exp mkSegmentTupleFun maxWidth = do@@ -228,27 +228,31 @@ -- Generate the constructor function from a segmap tuple layout to a -- tuple value -mkConstructTupleMatch :: Name -> Int -> Q Match-mkConstructTupleMatch rowName width = do+mkConstructTupleMatch :: Name -> Name -> Int -> Q Match+mkConstructTupleMatch keysName 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)+ let constructFun = VarE $ mkName "constructVal"+ constructArgs l = [VarE keysName, VarE l, VarE rowName ]+ resultElemExps = [ foldl' AppE constructFun (constructArgs l)+ | l <- lytNames+ ]+ tupleConstE = ConE $ innerConst "F" width+ resultValExp = AppE (ConE $ mkName "F.TupleConstE")+ (foldl' AppE tupleConstE resultElemExps) return $ Match tuplePat (NormalB resultValExp) [] mkConstructTuple :: Int -> Q Exp mkConstructTuple maxWidth = do+ keysName <- newName "keyCols" lytName <- newName "lyt" rowName <- newName "row" - tupMatches <- mapM (mkConstructTupleMatch rowName) [2..maxWidth]+ tupMatches <- mapM (mkConstructTupleMatch keysName rowName)+ [2..maxWidth] let lamBody = CaseE (TupE [VarE lytName]) tupMatches - return $ LamE [VarP lytName, VarP rowName] lamBody+ return $ LamE [VarP keysName, VarP lytName, VarP rowName] lamBody
− src/Database/DSH/Export.hs
@@ -1,37 +0,0 @@--- | 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/FKL/Kure.hs view
@@ -12,10 +12,10 @@ -- * 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 @@ -33,23 +33,22 @@ , 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 @@ -93,10 +92,10 @@ 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 @@ -137,14 +136,14 @@ -------------------------------------------------------------------------------- -- Congruence combinators for FKL lexpressions -tableT :: Monad m => (Type -> String -> [Column] -> TableHints -> b)+tableT :: Monad m => (Type -> String -> BaseTableSchema -> 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 #-} + Table ty n schema -> return $ f ty n schema+ _ -> fail "not a table node"+{-# INLINE tableT #-} - + tableR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) tableR = tableT Table {-# INLINE tableR #-}@@ -155,30 +154,18 @@ -> (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 + 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 #-} - +{-# 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 #-} --}+ifR t1 t2 t3 = ifT t1 t2 t3 If+{-# INLINE ifR #-} binopT :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 -> Transform FlatCtx m (ExprTempl l e) a2@@ -187,11 +174,11 @@ 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 #-} +{-# 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 #-} +{-# INLINE binopR #-} unopT :: Monad m => Transform FlatCtx m (ExprTempl l e) a -> (Type -> ScalarUnOp -> l -> a -> b)@@ -204,18 +191,18 @@ 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 + PApp1 ty p l e -> f ty p l <$> applyT t (c@@PApp1Arg) e _ -> fail "not a unary primitive application"-{-# INLINE papp1T #-} - +{-# INLINE papp1T #-}+ papp1R :: Monad m => Rewrite FlatCtx m (ExprTempl l e) -> Rewrite FlatCtx m (ExprTempl l e) papp1R t = papp1T t PApp1-{-# INLINE papp1R #-} +{-# INLINE papp1R #-} papp2T :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 -> Transform FlatCtx m (ExprTempl l e) a2@@ -224,11 +211,11 @@ 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 #-} +{-# 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 #-} +{-# INLINE papp2R #-} papp3T :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 -> Transform FlatCtx m (ExprTempl l e) a2@@ -237,43 +224,43 @@ -> 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 t1 (c@@PApp3Arg1) e1 <*> applyT t2 (c@@PApp3Arg2) e2 <*> applyT t3 (c@@PApp3Arg3) e3 _ -> fail "not a ternary primitive application"-{-# INLINE papp3T #-} +{-# INLINE papp3T #-} -papp3R :: Monad m - => Rewrite FlatCtx m (ExprTempl l e) - -> Rewrite FlatCtx m (ExprTempl l e) - -> Rewrite FlatCtx m (ExprTempl l e) +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 #-} +{-# 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 #-} - +{-# INLINE constExprT #-}+ constExprR :: Monad m => Rewrite FlatCtx m (ExprTempl l e) constExprR = constExprT Const-{-# INLINE constExprR #-} +{-# INLINE constExprR #-} letT :: Monad m => Transform FlatCtx m (ExprTempl l e) a1 -> Transform FlatCtx m (ExprTempl l e) a2- -> (Type -> Ident -> a1 -> a2 -> b) + -> (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 + 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) +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 #-} @@ -302,7 +289,7 @@ -> (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 + Ext e -> f <$> applyT t (c@@ExtExpr) e _ -> fail "not an extension mode" {-# INLINE extT #-} @@ -317,27 +304,27 @@ -> (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 + 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 +{-# INLINE forgetT #-}++forgetR :: Monad m => Rewrite FlatCtx m FExpr -> Rewrite FlatCtx m ShapeExt forgetR t = forgetT t Forget-{-# INLINE forgetR #-} +{-# 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 + 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 #-} +{-# INLINE imprintT #-} -imprintR :: Monad m => Rewrite FlatCtx m FExpr -> Rewrite FlatCtx m FExpr -> Rewrite FlatCtx m ShapeExt +imprintR :: Monad m => Rewrite FlatCtx m FExpr -> Rewrite FlatCtx m FExpr -> Rewrite FlatCtx m ShapeExt imprintR t1 t2 = imprintT t1 t2 Imprint-{-# INLINE imprintR #-} +{-# INLINE imprintR #-} -------------------------------------------------------------------------------- @@ -350,8 +337,8 @@ <*> applyT t2 (c@@BroadcastArg2) e2 {-# INLINE broadcastT #-} -broadcastR :: Monad m => Rewrite FlatCtx m LExpr - -> Rewrite FlatCtx m LExpr +broadcastR :: Monad m => Rewrite FlatCtx m LExpr+ -> Rewrite FlatCtx m LExpr -> Rewrite FlatCtx m BroadcastExt broadcastR r1 r2 = broadcastT r1 r2 Broadcast {-# INLINE broadcastR #-}@@ -390,12 +377,12 @@ project (ExtFKL s) = Just s project _ = Nothing- + -------------------------------------------------------------------------------- instance Walker FlatCtx (FKL Lifted ShapeExt) where- allR r = + allR r = rewrite $ \c fkl -> case fkl of ExprFKL expr -> inject <$> applyT (allRExpr r) c expr ExtFKL o -> inject <$> applyT allRShape c o@@ -406,7 +393,7 @@ Forget{} -> forgetR (extractR r) instance Walker FlatCtx (FKL LiftedN BroadcastExt) where- allR r = + allR r = rewrite $ \c fkl -> case fkl of ExprFKL expr -> inject <$> applyT (allRExpr r) c expr ExtFKL o -> inject <$> applyT allRBC c o@@ -431,16 +418,3 @@ 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
@@ -4,10 +4,11 @@ module Database.DSH.FKL.Lang where +import Prelude hiding ((<$>)) import Text.PrettyPrint.ANSI.Leijen import Text.Printf -import Database.DSH.Impossible+import Database.DSH.Common.Impossible import Database.DSH.Common.Pretty import Database.DSH.Common.Nat import qualified Database.DSH.Common.Lang as L@@ -23,7 +24,7 @@ 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+data ExprTempl l e = Table Type String L.BaseTableSchema | 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)@@ -57,25 +58,19 @@ | Avg | Minimum | Maximum- | The- | Tail | Reverse | And | Or- | Init- | Last | Nub | Number+ | Sort+ | Restrict+ | Group | Singleton- | Transpose- | Reshape Integer+ | Only deriving (Show, Eq) -data Prim2 = Group- | Sort- | Restrict- | Append- | Index+data Prim2 = Append | Zip | CartProduct | NestProduct@@ -86,13 +81,26 @@ | Dist deriving (Show, Eq) +isJoinOp :: Prim2 -> Bool+isJoinOp op =+ case op of+ CartProduct -> True+ NestProduct -> True+ ThetaJoin{} -> True+ NestJoin{} -> True+ SemiJoin{} -> True+ AntiJoin{} -> True+ Append -> False+ Zip -> False+ Dist -> False+ 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 (Table t _ _) = t typeOf (PApp1 t _ _ _) = t typeOf (PApp2 t _ _ _ _) = t typeOf (PApp3 t _ _ _ _ _) = t@@ -114,85 +122,91 @@ -- Pretty-printing of FKL dialects superscript :: Int -> Doc+superscript 0 = char '⁰' superscript 1 = char '¹' superscript 2 = char '²' superscript 3 = char '³' superscript 4 = char '⁴' superscript 5 = char '⁵' superscript 6 = char '⁶'+superscript 7 = char '⁷'+superscript 8 = char '⁸' superscript n = char '^' <> int n +subscript :: Int -> Doc+subscript 1 = char '₁'+subscript 2 = char '₂'+subscript 3 = char '₃'+subscript 4 = char '₄'+subscript 5 = char '₅'+subscript 6 = char '₆'+subscript 7 = char '₇'+subscript 8 = char '₈'+subscript n = char '_' <> int n+ instance Pretty Lifted where- pretty Lifted = text "ᴸ"- pretty NotLifted = empty+ pretty Lifted = super $ text "¹"+ pretty NotLifted = super $ text "⁰" instance Pretty LiftedN where- pretty (LiftedN Zero) = empty- pretty (LiftedN n) = superscript (intFromNat n)+ pretty (LiftedN n) = super $ 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 Length = combinator $ text "length"+ pretty Concat = combinator $ text "concat"+ pretty Sum = combinator $ text "sum"+ pretty Avg = combinator $ text "avg"+ pretty Minimum = combinator $ text "minimum"+ pretty Maximum = combinator $ text "maximum"+ pretty Reverse = combinator $ text "reverse"+ pretty And = combinator $ text "and"+ pretty Or = combinator $ text "or"+ pretty Nub = combinator $ text "nub"+ pretty Number = combinator $ text "number"+ pretty Sort = combinator $ text "sort"+ pretty Restrict = restrict $ text "restrict"+ pretty Group = combinator $ text "group"+ pretty Singleton = combinator $ text "sng"+ pretty Only = combinator $ text "only" 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)+ pretty Dist = dist $ text "dist"+ pretty Append = combinator $ text "append"+ pretty Zip = combinator $ text "zip"+ pretty CartProduct = join $ text "cartproduct"+ pretty NestProduct = join $ text "nestproduct"+ pretty (ThetaJoin p) = join $ text $ printf "thetajoin{%s}" (pp p)+ pretty (NestJoin p) = join $ text $ printf "nestjoin{%s}" (pp p)+ pretty (SemiJoin p) = join $ text $ printf "semijoin{%s}" (pp p)+ pretty (AntiJoin p) = join $ text $ printf "antijoin{%s}" (pp p) instance Pretty Prim3 where- pretty Combine = text "combine"+ pretty Combine = combinator $ text "combine" instance (Pretty l, Pretty e) => Pretty (ExprTempl l e) where- pretty (MkTuple _ l es) = (tupled $ map pretty es) <> pretty l-+ pretty (MkTuple _ l es) = (prettyTuple $ 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) = + pretty (Let _ x e1 e) = prettyLet (text x) (pretty e1) (pretty e)+ pretty (Table _ n _) = kw (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 f <> pretty l <+> parenthize e1 - pretty (PApp2 _ f l e1 e2) =- pretty f <> pretty l <+> (align $ (parenthize e1) </> (parenthize e2))+ pretty (PApp2 _ p2 l e1 e2)+ | isJoinOp p2 = prettyJoin (pretty p2 <> pretty l)+ (parenthize e1)+ (parenthize e2)+ | otherwise = prettyApp2 (pretty p2 <> pretty l)+ (parenthize e1)+ (parenthize e2) pretty (PApp3 _ f l e1 e2 e3) = pretty f <> pretty l- <+> (align $ (parenthize e1) - </> (parenthize e2) + <+> (align $ (parenthize e1)+ </> (parenthize e2) </> (parenthize e3)) pretty (If _ e1 e2 e3) = let e1' = pretty e1@@ -202,34 +216,36 @@ </> (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 (BinOp _ o l e1 e2)+ | L.isBinInfixOp o = prettyInfixBinOp (pretty o <> pretty l)+ (parenthize e1)+ (parenthize e2)+ | otherwise = prettyPrefixBinOp (pretty o <> pretty l)+ (parenthize e1)+ (parenthize e2) - pretty (UnOp _ o l e) =- pretty o <> pretty l <> parens (pretty e)+ pretty (UnOp _ o l e) = prettyUnOp (pretty o <> pretty l) (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)+ pretty (Forget n _ e) =+ forget (text "forget")+ <> (forget $ subscript $ intFromNat n) <+> (parenthize e) - pretty (Imprint n _ e1 e2) = - text "imprint" - <> (angles $ int $ intFromNat n) - <+> (align $ (parenthize e1) - </> (parenthize e2))- + pretty (Imprint n _ e1 e2) =+ prettyApp2 (forget (text "imprint") <> (forget $ subscript $ intFromNat n))+ (parenthize e1)+ (parenthize e2)+ instance Pretty BroadcastExt where- pretty (Broadcast n _ e1 e2) = - text "forget" - <> (angles $ int $ intFromNat n)- <+> (align $ (parenthize e1)- </> (parenthize e2))+ pretty (Broadcast n _ e1 e2) =+ prettyApp2 (forget (text "broadcast") <> (forget $ subscript $ intFromNat n))+ (parenthize e1)+ (parenthize e2) parenthize :: (Pretty l, Pretty e) => ExprTempl l e -> Doc parenthize e =
src/Database/DSH/FKL/Primitives.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE PatternSynonyms #-} -- | Smart constructors for FKL functions and operators module Database.DSH.FKL.Primitives where@@ -12,42 +13,32 @@ import Database.DSH.Common.Pretty import Database.DSH.Common.Type import Database.DSH.FKL.Lang-import Database.DSH.Impossible+import Database.DSH.Common.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+group :: LExpr -> Nat -> LExpr+group xs d =+ let ListT (TupleT [xt, gt]) = unliftTypeN d $ typeOf xs+ rt = ListT (PPairT gt (ListT xt))+ in PApp1 (liftTypeN d rt) Group (LiftedN d) xs --- 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+sort :: LExpr -> Nat -> LExpr+sort xs d =+ let ListT (TupleT [xt, _]) = unliftTypeN d $ typeOf xs+ in PApp1 (liftTypeN d (ListT xt)) Sort (LiftedN d) xs sng :: LExpr -> Nat -> LExpr sng e d = let t = unliftTypeN d $ typeOf e in PApp1 (liftTypeN d t) Singleton (LiftedN d) e +only :: LExpr -> Nat -> LExpr+only e1 d =+ let ListT t1 = unliftTypeN d $ typeOf e1+ in PApp1 (liftTypeN d t1) Only (LiftedN d) e1+ tuple :: [LExpr] -> Nat -> LExpr tuple es d = let ts = map (unliftTypeN d . typeOf) es@@ -59,33 +50,33 @@ 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+ in PApp2 (liftTypeN d $ ListT (PPairT 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+ in PApp2 (liftTypeN d $ ListT (PPairT 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)))+ rt = ListT (PPairT xt (ListT (PPairT 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+ in PApp2 (liftTypeN d $ ListT (PPairT 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)))+ rt = ListT (PPairT xt (ListT (PPairT xt yt))) in PApp2 (liftTypeN d rt) (NestJoin p) (LiftedN d) xs ys semiJoin :: JoinPredicate JoinExpr -> LExpr -> LExpr -> Nat -> LExpr@@ -103,33 +94,8 @@ 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+length e1 d = PApp1 (liftTypeN d PIntT) Length (LiftedN d) e1 nub :: LExpr -> Nat -> LExpr nub e1 d =@@ -139,24 +105,19 @@ number :: LExpr -> Nat -> LExpr number e1 d = let ListT t = unliftTypeN d $ typeOf e1- rt = (ListT (pairT t IntT ))+ rt = (ListT (PPairT t PIntT )) 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+and e1 d = PApp1 (liftTypeN d PBoolT) And (LiftedN d) e1 or :: LExpr -> Nat -> LExpr-or e1 d = PApp1 (liftTypeN d BoolT) Or (LiftedN d) e1+or e1 d = PApp1 (liftTypeN d PBoolT) Or (LiftedN d) e1 sum :: LExpr -> Nat -> LExpr sum e1 d =@@ -164,7 +125,10 @@ in PApp1 (liftTypeN d t) Sum (LiftedN d) e1 avg :: LExpr -> Nat -> LExpr-avg e1 d = PApp1 (liftTypeN d DoubleT) Avg (LiftedN d) e1+avg e1 d = case unliftTypeN d $ typeOf e1 of+ ListT PDoubleT -> PApp1 (liftTypeN d PDoubleT) Avg (LiftedN d) e1+ ListT PDecimalT -> PApp1 (liftTypeN d PDecimalT) Avg (LiftedN d) e1+ _ -> $impossible minimum :: LExpr -> Nat -> LExpr minimum e1 d =@@ -184,12 +148,12 @@ dist :: LExpr -> LExpr -> Nat -> LExpr dist e1 e2 d = let t1 = typeOf e1- in PApp2 (listT t1) Dist (LiftedN d) e1 e2+ 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+restrict :: LExpr -> Nat -> LExpr+restrict xs d =+ let ListT (TupleT [xt, PBoolT]) = unliftTypeN d $ typeOf xs+ in PApp1 (liftTypeN d (ListT xt)) Restrict (LiftedN d) xs -- combine :: [Bool] -> [a] -> [a] -> [a] combine :: LExpr -> LExpr -> LExpr -> Nat -> LExpr@@ -198,13 +162,13 @@ in PApp3 (liftTypeN d xst) Combine (LiftedN d) e1 e2 e3 tupElem :: TupleIndex -> LExpr -> Nat -> LExpr-tupElem f e d = +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)+ let (PBoolT, 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)@@ -243,11 +207,11 @@ wrapListType :: Nat -> Type -> Type wrapListType Zero t = t-wrapListType (Succ n') t = wrapListType n' (listT 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+fdist e1 e2 = PApp2 (ListT $ typeOf e1) Dist NotLifted e1 e2 -------------------------------------------------------------------------------- -- Smart constructors for special forms in the flat FKL dialect
src/Database/DSH/FKL/Rewrite.hs view
@@ -1,21 +1,29 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} module Database.DSH.FKL.Rewrite ( optimizeFKL+ , optimizeNormFKL ) 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 +import Control.Arrow+import Data.List+import Data.Monoid+++import Database.DSH.Common.Lang+import Database.DSH.Common.Nat++import Database.DSH.Common.RewriteM+import Database.DSH.Common.Type+import Database.DSH.FKL.Kure+import Database.DSH.FKL.Lang++import qualified Database.DSH.FKL.Primitives as P+ -- | 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@@ -24,10 +32,10 @@ -------------------------------------------------------------------------------- -- Computation of free and bound variables -freeVarsT :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e)) +freeVarsT :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e)) => TransformF (FKL l e) [Ident]-freeVarsT = fmap nub - $ crushbuT +freeVarsT = fmap nub+ $ crushbuT $ do (ctx, ExprFKL (Var _ v)) <- exposeT guardM (v `freeIn` ctx) return [v]@@ -66,8 +74,8 @@ 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+ ExprFKL (Let _ x _ _) | v == x -> tryR $ childR LetBind (substR v s)+ _ -> anyR $ substR v s -------------------------------------------------------------------------------- -- Simple optimizations@@ -89,7 +97,7 @@ -- | Remove a let-binding that is not referenced.-unusedBindingR :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e)) +unusedBindingR :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e)) => RewriteF (FKL l e) unusedBindingR = do ExprFKL (Let _ x _ e2) <- idR@@ -98,7 +106,10 @@ -- | Inline a let-binding that is only referenced once.-referencedOnceR :: (Injection (ExprTempl l e) (FKL l e), Walker FlatCtx (FKL l e), Typed e)+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@@ -112,24 +123,130 @@ 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)+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)+--------------------------------------------------------------------------------+-- Rewrites that remove redundant combinations of shape operators+-- (forget and imprint)++pattern ImprintP d e1 e2 <- Ext (Imprint d _ e1 e2)+pattern ForgetP d e <- Ext (Forget d _ e)++-- | Remove nested occurences of 'imprint':+--+-- imprint_d (imprint_d e1 _) e2+-- =>+-- imprint_d e1 e2+--+-- The reasoning is simple: The inner 'imprint' attaches the outer 'd'+-- layers of 'e1' onto 'e2'. The outer 'imprint' takes exactly these+-- 'd' outer layers and attaches it to 'e2'. Therefore, we can use the+-- outer 'd' layers of 'e1' directly without the inner 'imprint'.+nestedimprintR :: RewriteF (FKL Lifted ShapeExt)+nestedimprintR = do+ ExprFKL (ImprintP d (ImprintP d' e1 _) e2) <- idR+ guardM $ d == d'+ return $ ExprFKL (P.imprint d' e1 e2)++-- | Remove combinations of forget and imprint that cancel each+-- other out.+forgetimprintR :: RewriteF (FKL Lifted ShapeExt)+forgetimprintR = do+ ExprFKL (ForgetP d (ImprintP d' _ xs)) <- idR+ guardM $ d == d'+ return $ ExprFKL xs++-- | If 'forget' removes /strictly more/ nesting than the nested 'imprint' adds,+-- we can remove the 'imprint' and 'forget' only the difference.+forgetimprintlargerR :: RewriteF (FKL Lifted ShapeExt)+forgetimprintlargerR = do+ ExtFKL (Forget d1 t (Ext (Imprint d2 _ _ xs))) <- idR+ guardM $ d1 > d2+ case d1 .- d2 of+ Just dd -> return $ ExtFKL (Forget dd t xs)+ Nothing -> fail "depths are not compatible"++-- | If 'forget' removes /strictly less/ nesting than the nested 'imprint'+-- adds, we can not remove one of the shape combinators. However, we+-- can decrease the depth of shape operations. 'imprint' adds the 'd2'+-- outer layers of 'e1' to 'e2'. Of those 'd2' outer layers, 'forget'+-- removes the outermost 'd1' (which are less than 'd2'). Effectively,+-- only the vectors 'd1' to 'd2' of 'e1' are added to+-- 'e2'. Consequentially, we can apply 'forget' first and only+-- 'imprint' the inner vectors.+--+-- forget_d1 (imprint_d2 e1 e2)+-- =>+-- imprint_(d_2 - d_1) (forget_d1 e1) e2+--+-- This rewrite does not immediately lead to a reduction of term+-- size. However, it decreases the depth of vectors that are+-- applied/forgotten. That might be a good thing on its own (but+-- propably irrelevant, because shape operations crucially do not have+-- runtime cost). Additionally, it can expose other rewrite+-- opportunities. This is very true e.g. in query 'expectedRevenueFor'+-- (dsh-tpch-other).+forgetimprintsmallerR :: RewriteF (FKL Lifted ShapeExt)+forgetimprintsmallerR = do+ ExprFKL (ForgetP d1 (ImprintP d2 e1 e2)) <- idR+ guardM $ d2 > d1+ case d2 .- d1 of+ Just dd -> return $ ExprFKL $ P.imprint dd (P.forget d1 e1) e2+ Nothing -> fail "depths are not compatible"++-- | 'forget'/'imprint' combinations are often obscured by+-- 'let'-bindings. This rewrite inlines a binding and succeeds if+-- other rewrites succeed in the resulting term.+boundforgetimprintR :: RewriteF (FKL Lifted ShapeExt)+boundforgetimprintR = do+ ExprFKL (Let _ x e1 _) <- idR+ childT LetBody (substR x e1 >>> anybuR rewrites)++ where+ rewrites = forgetimprintR+ <+ nestedimprintR+ <+ forgetimprintlargerR+ <+ forgetimprintsmallerR++--------------------------------------------------------------------------------++fklOptimizations :: ( Injection (ExprTempl l e) (FKL l e)+ , Walker FlatCtx (FKL l e)+ , Typed e+ ) => RewriteF (FKL l e)-fklOptimizations = anybuR $ unusedBindingR +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'+fklNormOptimizations :: RewriteF (FKL Lifted ShapeExt)+fklNormOptimizations = repeatR $ anybuR rewrites where- expr' = applyExpr (fklOptimizations >>> projectT) expr+ rewrites = unusedBindingR+ <+ referencedOnceR+ <+ simpleBindingR+ <+ forgetimprintR+ <+ forgetimprintlargerR+ <+ boundforgetimprintR+ <+ nestedimprintR+ <+ forgetimprintsmallerR++optimizeNormFKL :: FExpr -> FExpr+optimizeNormFKL expr =+ case applyExpr (fklNormOptimizations >>> projectT) expr of+ Left _ -> expr+ Right expr' -> expr'++optimizeFKL :: LExpr -> LExpr+optimizeFKL expr =+ case applyExpr (fklOptimizations >>> projectT) expr of+ Left _ -> expr+ Right expr' -> expr'
+ src/Database/DSH/Frontend/Builtins.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Definition of (typed) DSH builtins+module Database.DSH.Frontend.Builtins+ ( Fun(..)+ , TupElem(..)+ ) where++import Data.Decimal+import Data.Text (Text)+import Data.Time.Calendar (Day)++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+ IntegerToDecimal :: Fun Integer Decimal+ And :: Fun [Bool] Bool+ Or :: Fun [Bool] Bool+ Concat :: Fun [[a]] [a]+ Null :: Fun [a] Bool+ Length :: Fun [a] Integer+ Only :: Fun [a] a+ 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] a+ 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]+ 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+ 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+ AddDays :: Fun (Integer, Day) Day+ SubDays :: Fun (Integer, Day) Day+ DiffDays :: Fun (Day, Day) Integer+ DayDay :: Fun Day Integer+ DayMonth :: Fun Day Integer+ DayYear :: Fun Day Integer+ TupElem :: TupElem a b -> Fun a b
src/Database/DSH/Frontend/Externals.hs view
@@ -6,118 +6,137 @@ {-# 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 Prelude (Bool (..), Char, Double,+ Either (..), Eq,+ Floating (..),+ Fractional (..), Integer,+ Maybe (..), Num (..), Ord,+ id, ($), (.))+import qualified Prelude as P -import Data.String-import Data.Text (Text)-import qualified Data.Text as T+import Data.Decimal+import Data.List.NonEmpty (NonEmpty)+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time.Calendar (Day) +import Database.DSH.Common.Impossible+import Database.DSH.Frontend.Builtins+import Database.DSH.Frontend.Internals+import Database.DSH.Frontend.TupleTypes++ -- QA Instances instance QA () where- type Rep () = ()- toExp () = UnitE- frExp UnitE = ()- frExp _ = $impossible+ type Rep () = ()+ toExp () = UnitE+ frExp UnitE = ()+ frExp _ = $impossible instance QA Bool where- type Rep Bool = Bool- toExp = BoolE- frExp (BoolE b) = b- frExp _ = $impossible+ 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+ 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+ 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+ 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+ type Rep Text = Text+ toExp = TextE+ frExp (TextE t) = t+ frExp _ = $impossible++instance QA Decimal where+ type Rep Decimal = Decimal+ toExp = DecimalE+ frExp (DecimalE d) = d+ frExp _ = $impossible++instance QA Day where+ type Rep Day = Day+ toExp = DayE+ frExp (DayE d) = d 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+ 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+ 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+ 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+ 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)))+ 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+ 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+ 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+ 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+ 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)+ 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+ 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+ 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 @@ -127,6 +146,8 @@ instance BasicType Integer where instance BasicType Double where instance BasicType Text where+instance BasicType Decimal where+instance BasicType Day where -- TA instances @@ -136,135 +157,168 @@ instance TA Integer where instance TA Double where instance TA Text where+instance TA Decimal where+instance TA Day where --- Num and Fractional instances+-- Numerical 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)+ (+) e1 e2 = AppE Add (pairE e1 e2)+ (*) e1 e2 = AppE Mul (pairE e1 e2)+ (-) e1 e2 = AppE Sub (pairE e1 e2) - fromInteger = IntegerE+ fromInteger = IntegerE - abs e = let c = AppE Lt (pairE e 0)- in AppE Cond (tripleE c (negate e) e)+ 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')+ 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)+ (+) e1 e2 = AppE Add (pairE e1 e2)+ (*) e1 e2 = AppE Mul (pairE e1 e2)+ (-) e1 e2 = AppE Sub (pairE e1 e2) - fromInteger = DoubleE . fromInteger+ fromInteger = DoubleE . fromInteger - abs e = let c = AppE Lt (pairE e 0)- in AppE Cond (tripleE c (negate e) e)+ 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')+ 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 Num (Exp Decimal) where+ (+) e1 e2 = AppE Add (pairE e1 e2)+ (*) e1 e2 = AppE Mul (pairE e1 e2)+ (-) e1 e2 = AppE Sub (pairE e1 e2)++ fromInteger = DecimalE . 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)+ c2 = AppE Equ (pairE e 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+ (/) e1 e2 = AppE Div (pairE e1 e2)+ fromRational = DoubleE . fromRational +instance Fractional (Exp Decimal) where+ (/) e1 e2 = AppE Div (pairE e1 e2)+ fromRational = DecimalE . fromRational++instance Fractional (Q Decimal) where+ (/) (Q e1) (Q e2) = Q (e1 / e2)+ fromRational = Q . 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+ 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)+ (+) (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)+ (+) (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 Num (Q Decimal) where+ (+) (Q e1) (Q e2) = Q (e1 + e2)+ (*) (Q e1) (Q e2) = Q (e1 * e2)+ (-) (Q e1) (Q e2) = Q (e1 - e2)+ fromInteger = Q . DecimalE . 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+ (/) (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+ 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+ type ToView (Q ()) = Q ()+ view = id instance View (Q Bool) where- type ToView (Q Bool) = Q Bool- view = id+ type ToView (Q Bool) = Q Bool+ view = id instance View (Q Char) where- type ToView (Q Char) = Q Char- view = id+ type ToView (Q Char) = Q Char+ view = id instance View (Q Integer) where- type ToView (Q Integer) = Q Integer- view = id+ type ToView (Q Integer) = Q Integer+ view = id instance View (Q Double) where- type ToView (Q Double) = Q Double- view = id+ type ToView (Q Double) = Q Double+ view = id instance View (Q Text) where- type ToView (Q Text) = Q Text- view = id+ type ToView (Q Text) = Q Text+ view = id -- IsString instances instance IsString (Q Text) where- fromString = Q . TextE . T.pack+ fromString = Q . TextE . T.pack -- * Referring to persistent tables -defaultHints :: TableHints-defaultHints = TableHints [] PossiblyEmpty+defaultHints :: NonEmpty Key -> TableHints+defaultHints keys = TableHints keys PossiblyEmpty -table :: (QA a, TA a) => String -> TableHints -> Q [a]-table name hints = Q (TableE (TableDB name hints))+table :: (QA a, TA a) => String -> NonEmpty ColName -> TableHints -> Q [a]+table name schema hints = Q (TableE (TableDB name schema hints)) -- * toQ @@ -336,13 +390,15 @@ 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))+-- | Remainder of division.+rem :: Q Integer -> Q Integer -> Q Integer+rem (Q a) (Q b) = Q (AppE Mod (pairE a b)) +-- | Integer division truncated towards zero.+quot :: Q Integer -> Q Integer -> Q Integer+quot (Q a) (Q b) = Q (AppE Div (pairE a b))+ -- * Conditionals bool :: (QA a) => Q a -> Q a -> Q Bool -> Q a@@ -414,8 +470,8 @@ 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))+ 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)@@ -431,9 +487,6 @@ 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)) @@ -451,12 +504,24 @@ -- * List Operations +only :: QA a => Q [a] -> Q a+only (Q as) = Q (AppE Only as)+ head :: (QA a) => Q [a] -> Q a-head (Q as) = Q (AppE Head as)+head as = only $ map fst $ filter (\xp -> snd xp == 1) $ number as tail :: (QA a) => Q [a] -> Q [a]-tail (Q as) = Q (AppE Tail as)+tail as = map fst $ filter (\xp -> snd xp > 1) $ number as +last :: (QA a) => Q [a] -> Q a+last as = only $ map fst $ filter (\xp -> snd xp == length as) $ number as++init :: (QA a) => Q [a] -> Q [a]+init as = map fst $ filter (\xp -> snd xp < length as) $ number as++index :: (QA a) => Q [a] -> Q Integer -> Q a+index as i = only $ map fst $ filter (\xp -> snd xp == i + 1) $ number as + take :: (QA a) => Q Integer -> Q [a] -> Q [a] take i xs = map fst $ filter (\xp -> snd xp <= i) $ number xs @@ -483,24 +548,29 @@ 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))+-- | Group a list and apply an aggregate.+groupAggr :: (QA a, QA b, QA c, QA k, Ord k, TA k)+ => (Q a -> Q k) -- ^ The grouping key+ -> (Q a -> Q b) -- ^ The aggregate input+ -> (Q [b] -> Q c) -- ^ The aggregate function+ -> Q [a] -- ^ The input list+ -> Q [(k, c)]+groupAggr k p agg as =+ map (\kg -> pair (fst kg) (agg $ map p $ snd kg)) (groupWithKey k 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)+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)) null :: (QA a) => Q [a] -> Q Bool null (Q as) = Q (AppE Null as) +empty :: QA a => Q [a] -> Q Bool+empty = null+ 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 @@ -527,7 +597,7 @@ 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 :: (QA a, Fractional a) => Q [a] -> Q a avg (Q as) = Q (AppE Avg as) concat :: (QA a) => Q [[a]] -> Q [a]@@ -549,18 +619,18 @@ -- FIXME might be implemented using non-dense numbering! takeWhile :: (QA a) => (Q a -> Q Bool) -> Q [a] -> Q [a]-takeWhile p xs = +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) ++ 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 = +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@@ -623,27 +693,43 @@ integerToDouble :: Q Integer -> Q Double integerToDouble (Q i) = Q (AppE IntegerToDouble i) +integerToDecimal :: Q Integer -> Q Decimal+integerToDecimal (Q i) = Q (AppE IntegerToDecimal 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.+-- 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)) +notLike :: Q Text -> Q Text -> Q Bool+notLike t p = not (like t p)+ subString :: Integer -> Integer -> Q Text -> Q Text subString from to (Q t) = Q (AppE (SubString from to) t) --- * Matrix/Vector-like operators+-- * Date and Time Combinators --- | Transpose a matrix in nested-list representation-transpose :: QA a => Q [[a]] -> Q [[a]]-transpose (Q ass) = Q (AppE Transpose ass)+addDays :: Q Integer -> Q Day -> Q Day+addDays (Q i) (Q d) = Q (AppE AddDays (pairE i d)) --- | 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)+subDays :: Q Integer -> Q Day -> Q Day+subDays (Q i) (Q d) = Q (AppE SubDays (pairE i d))++diffDays :: Q Day -> Q Day -> Q Integer+diffDays (Q d1) (Q d2) = Q (AppE DiffDays (pairE d1 d2))++toGregorian :: Q Day -> Q (Integer, Integer, Integer)+toGregorian (Q d) = Q $ tripleE (AppE DayYear d)+ (AppE DayMonth d)+ (AppE DayDay d)++dateYear :: Q Day -> Q Integer+dateYear d = let (view -> (year, _, _)) = toGregorian d+ in year -- * Rebind Monadic Combinators
− src/Database/DSH/Frontend/Funs.hs
@@ -1,74 +0,0 @@-{-# 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
@@ -1,17 +1,22 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} module Database.DSH.Frontend.Internals where +import Data.Decimal+import Data.List.NonEmpty (NonEmpty) import Data.Text (Text)+import Data.Time.Calendar (Day) import Text.PrettyPrint.ANSI.Leijen -import Database.DSH.Impossible-import Database.DSH.Frontend.Funs+import Database.DSH.Common.Impossible+import Database.DSH.Frontend.Builtins import Database.DSH.Frontend.TupleTypes --------------------------------------------------------------------------------@@ -22,29 +27,33 @@ $(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+ UnitE :: Exp ()+ BoolE :: Bool -> Exp Bool+ CharE :: Char -> Exp Char+ IntegerE :: Integer -> Exp Integer+ DoubleE :: Double -> Exp Double+ TextE :: Text -> Exp Text+ DecimalE :: Decimal -> Exp Decimal+ DayE :: Day -> Exp Day+ 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+ UnitT :: Type ()+ BoolT :: Type Bool+ CharT :: Type Char+ IntegerT :: Type Integer+ DoubleT :: Type Double+ TextT :: Type Text+ DecimalT :: Type Decimal+ DayT :: Type Day+ 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 "()"@@ -53,6 +62,8 @@ pretty IntegerT = text "Integer" pretty DoubleT = text "Double" pretty TextT = text "Text"+ pretty DecimalT = text "Decimal"+ pretty DayT = text "Day" pretty (ListT t) = brackets $ pretty t pretty (ArrowT t1 t2) = parens $ pretty t1 <+> text "->" <+> pretty t2 pretty (TupleT t) = pretty t@@ -66,24 +77,24 @@ -- Classes class Reify a where- reify :: a -> Type a+ reify :: a -> Type a class (Reify (Rep a)) => QA a where- type Rep a- toExp :: a -> Exp (Rep a)- frExp :: Exp (Rep a) -> a+ 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+ 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+ type ToView a+ view :: a -> ToView a newtype Q a = Q (Exp (Rep a)) @@ -93,47 +104,58 @@ 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) +--------------------------------------------------------------------------------+-- Definition of database-resident tables+ -- | A combination of column names that form a candidate key-newtype Key = Key [String] deriving (Eq, Ord, Show)+newtype Key = Key (NonEmpty String) deriving (Eq, Ord, Show) -- | Is the table guaranteed to be not empty? data Emptiness = NonEmpty | PossiblyEmpty deriving (Eq, Ord, Show) +type ColName = String+ -- | Catalog information hints that users may give to DSH data TableHints = TableHints- { keysHint :: [Key]+ { keysHint :: NonEmpty Key , nonEmptyHint :: Emptiness } deriving (Eq, Ord, Show) -data Table = TableDB String TableHints+data Table = TableDB String (NonEmpty ColName) TableHints -- Reify instances instance Reify () where- reify _ = UnitT+ reify _ = UnitT instance Reify Bool where- reify _ = BoolT+ reify _ = BoolT instance Reify Char where- reify _ = CharT+ reify _ = CharT instance Reify Integer where- reify _ = IntegerT+ reify _ = IntegerT instance Reify Double where- reify _ = DoubleT+ reify _ = DoubleT +instance Reify Decimal where+ reify _ = DecimalT+ instance Reify Text where- reify _ = TextT+ reify _ = TextT +instance Reify Day where+ reify _ = DayT+ instance (Reify a) => Reify [a] where- reify _ = ListT (reify (undefined :: a))+ reify _ = ListT (reify (undefined :: a)) instance (Reify a, Reify b) => Reify (a -> b) where- reify _ = ArrowT (reify (undefined :: a)) (reify (undefined :: b))+ reify _ = ArrowT (reify (undefined :: a)) (reify (undefined :: b)) -- Utility functions
− src/Database/DSH/Frontend/Schema.hs
@@ -1,44 +0,0 @@-{-# 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
@@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -module Database.DSH.Frontend.TH +module Database.DSH.Frontend.TH ( deriveDSH , deriveQA , deriveTA@@ -16,7 +16,6 @@ ) where import Control.Monad-import Control.Applicative import Data.Char import Data.List @@ -25,8 +24,9 @@ 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+import qualified Database.DSH.Frontend.Builtins as F+import Database.DSH.Common.Impossible+import Database.DSH.Common.TH -----------------------------------------@@ -61,7 +61,7 @@ deriveTyConQA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] deriveTyConQA name tyVarBndrs cons = do- let context = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)])+ let context = map (\tv -> nameTyApp ''DSH.QA (VarT (tyVarBndrToName tv))) tyVarBndrs let typ = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) let instanceHead = AppT (ConT ''DSH.QA) typ@@ -130,7 +130,7 @@ return (Clause [pat1] body1 []) -- FIXME adapt code for types with multiple constructors to new tuple -- regime.-deriveToExpClause n i con = $unimplemented+deriveToExpClause _n _i _con = $unimplemented {- (pat1,names1) <- conToPattern con let exp1 = deriveToExpMainExp names1@@ -172,7 +172,7 @@ return (Clause [pat1] body1 []) -- FIXME adapt code for types with multiple constructors to new tuple -- regime.-deriveFrExpClause n i con = $unimplemented+deriveFrExpClause _n _i _con = $unimplemented {- (_,names1) <- conToPattern con let pat1 = deriveFrExpMainPat names1@@ -207,7 +207,7 @@ deriveTyConTA :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] deriveTyConTA name tyVarBndrs _cons = do- let context = map (\tv -> ClassP ''DSH.BasicType [VarT (tyVarBndrToName tv)])+ let context = map (\tv -> nameTyApp ''DSH.BasicType (VarT (tyVarBndrToName tv))) tyVarBndrs let typ = foldl AppT (ConT name) (map (VarT . tyVarBndrToName) tyVarBndrs) let instanceHead = AppT (ConT ''DSH.TA) typ@@ -229,7 +229,8 @@ deriveTyConView :: Name -> [TyVarBndr] -> Con -> Q [Dec] deriveTyConView name tyVarBndrs con = do- let context = map (\tv -> ClassP ''DSH.QA [VarT (tyVarBndrToName tv)]) tyVarBndrs+ let context = map (\tv -> nameTyApp ''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@@ -276,8 +277,9 @@ 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 context = nameTyApp ''DSH.QA (resTy) :+ map (\tv -> nameTyApp ''DSH.QA (VarT (tyVarBndrToName tv)))+ tyVarBndrs let instanceHead = AppT (AppT (ConT ''DSH.Elim) ty) resTy let eliminatorDec = deriveEliminator ty resTy cons elimDec <- deriveElimFun cons@@ -315,57 +317,58 @@ 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+deriveElimFunClause = $unimplemented+-- 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)+-- 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) [])+-- 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))+-- 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+-- 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 --@@ -392,7 +395,7 @@ let resTyp = AppT (ConT ''DSH.Q) (foldl AppT (ConT typConName) boundTyps) - let smartConContext = map (ClassP ''DSH.QA . return) boundTyps+ let smartConContext = map (nameTyApp ''DSH.QA) boundTyps let smartConTyp = foldr (AppT . AppT ArrowT . AppT (ConT ''DSH.Q)) resTyp@@ -408,7 +411,7 @@ -- FIXME PairE -> TupleE smartConExp <- if null es then return $ ConE 'DSH.UnitE- else mkTupConstTerm es + else mkTupConstTerm es smartConBody <- deriveSmartConBody n i smartConExp let smartConClause = Clause smartConPat (NormalB smartConBody) [] @@ -438,11 +441,11 @@ '(' : 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@@ -458,38 +461,40 @@ 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+ 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)++ 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@@ -501,7 +506,8 @@ -- TupleE (Tuple3E a b) -> ... -- @ mkTuplePat :: [Name] -> Pat-mkTuplePat names = ConP 'DSH.TupleConstE [ConP (innerConst $ length names) (map VarP names)]+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@@ -533,10 +539,10 @@ conToPattern (ForallC _tyVarBndr _cxt con) = conToPattern con conToName :: Con -> Name-conToName (NormalC name _) = name-conToName (RecC name _) = name+conToName (NormalC name _) = name+conToName (RecC name _) = name conToName (InfixC _ name _) = name-conToName (ForallC _ _ con) = conToName con+conToName (ForallC _ _ con) = conToName con countConstructors :: Name -> Q Int countConstructors name = do
src/Database/DSH/Frontend/TupleTypes.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} + -- | Generate AST types, functions and instances for tuples. module Database.DSH.Frontend.TupleTypes ( -- * Generate tuple types, functions and instances@@ -22,13 +23,13 @@ , tupTyConstName ) where -import Control.Applicative import Data.List import Text.Printf import Language.Haskell.TH -import Database.DSH.Impossible+import Database.DSH.Common.Impossible+import Database.DSH.Common.TH import Database.DSH.Common.Nat import qualified Database.DSH.Common.Type as T import qualified Database.DSH.CL.Primitives as CP@@ -45,8 +46,8 @@ mkTupType :: Int -> Int -> [Name] -> Name -> Type mkTupType elemIdx width boundTyVars bTyVar =- let elemTys = map VarT $ take (elemIdx - 1) boundTyVars - ++ [bTyVar] + let elemTys = map VarT $ take (elemIdx - 1) boundTyVars+ ++ [bTyVar] ++ drop (elemIdx - 1) boundTyVars in foldl' AppT (TupleT width) elemTys @@ -55,30 +56,30 @@ let binders = map PlainTV boundTyVars let tupTy = mkTupType elemIdx width boundTyVars bTyVar let con = tupAccName width elemIdx- let ctx = [EqualP (VarT aTyVar) tupTy]+ let ctx = [equalConstrTy (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 +-- 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@@ -95,34 +96,43 @@ 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 |]+-- TupElem a b -> Exp a -> Compile CL.Expr+-- \te e ->+-- case te of+-- Tup{2}_{1} -> CP.tupElem (indIndex 1) <$> translate e+-- Tup{2}_{k} -> CP.tupElem (indIndex k) <$> translate e+-- Tup{3}_{1} -> CP.tupElem (indIndex 1) <$> translate e+-- ...+-- Tup{n}_{j} -> CP.tupElem (indIndex j) <$> translate e++-- FIXME mkTupElemCompile does not depend on 'translate'+-- anymore. Therefore, we could inject a regular global binding for+-- the function instead of a lambda.++mkCompileMatch :: (Name, Int) -> Q Match+mkCompileMatch (con, elemIdx) = do+ let idxLit = return $ LitE $ IntegerL $ fromIntegral elemIdx+ bodyExp <- [| CP.tupElem (intIndex $idxLit) |] 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] + | idx <- [1..width]+ ]+ | width <- [2..maxWidth] ] - exprName <- newName "e" opName <- newName "te"-- matches <- mapM (mkCompileMatch exprName) cons+ matches <- mapM mkCompileMatch cons let lamBody = CaseE (VarE opName) matches- return $ LamE [VarP opName, VarP exprName] lamBody+ return $ LamE [VarP opName] lamBody -------------------------------------------------------------------------------- -- Reify instances for tuple types@@ -133,16 +143,16 @@ mkReifyFun :: [Name] -> Dec mkReifyFun tyNames = let argTys = map reifyType tyNames- body = AppE (ConE $ mkName "TupleT") - $ foldl' AppE (ConE $ tupTyConstName $ length tyNames) argTys+ 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- + reifyCxt = map (\tyName -> nameTyApp (mkName "Reify") (VarT tyName)) tyNames+ in InstanceD reifyCxt instTy [mkReifyFun tyNames] mkReifyInstances :: Int -> Q [Dec]@@ -155,16 +165,18 @@ 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+ 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+ 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]@@ -172,7 +184,7 @@ mkRep :: Int -> [Name] -> Type -> Dec mkRep width tyNames tupTyPat = let resTy = foldl' AppT (TupleT width)- $ map (AppT $ ConT $ mkName "Rep") + $ map (AppT $ ConT $ mkName "Rep") $ map VarT tyNames in TySynInstD (mkName "Rep") (TySynEqn [tupTyPat] resTy) @@ -181,14 +193,14 @@ 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+ qaCxt = map (\tyName -> nameTyApp (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)@@ -207,11 +219,11 @@ 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+ taCxt = map (\tyName -> nameTyApp (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 -- @@@ -235,13 +247,13 @@ 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+ qaConstr = map (\n -> nameTyApp (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)+ 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) []]@@ -249,7 +261,7 @@ -- | 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))@@ -281,12 +293,12 @@ subTermNames = map mkName names transTermNames = map (mkName . (++ "'")) names transBinds = zipWith mkTransBind subTermNames transTermNames- + transTerms = listE $ map varE transTermNames- conStmt <- NoBindS <$> + conStmt <- NoBindS <$> [| return $ CL.MkTuple (T.TupleT $ map T.typeOf $transTerms) $transTerms |] let matchBody = DoE $ transBinds ++ [conStmt]- matchPat = ConP (innerConst width) (map VarP subTermNames)+ matchPat = ConP (innerConst "" width) (map VarP subTermNames) return $ Match matchPat (NormalB matchBody) [] -- | Generate the lambda expression that translates frontend tuple@@ -311,11 +323,11 @@ 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)+ 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@@ -351,10 +363,10 @@ qPat = ConP qName [VarP expName] viewBodyExp <- TupE <$> mapM (\idx -> appE (conE qName) $ mkTupElemTerm width idx expVar)- [1..width] + [1..width] let viewClause = Clause [qPat] (NormalB viewBodyExp) []- + return $ FunD (mkName "view") [viewClause] mkViewInstance :: Int -> Q Dec@@ -363,7 +375,7 @@ tupTy = tupleType $ map VarT names instTy = AppT (ConT $ mkName "View") (AppT (ConT qName) tupTy) - viewCxt = map (\n -> ClassP (mkName "QA") [VarT n]) names+ viewCxt = map (\n -> nameTyApp (mkName "QA") (VarT n)) names toViewDec = mkToView names tupTy viewDec <- mkViewFun width return $ InstanceD viewCxt instTy [toViewDec, viewDec]@@ -388,39 +400,39 @@ -- (t1, ..., t<n>) tupTy = foldl' AppT (TupleT width) $ map VarT tupElemTyNames- + -- a ~ (t1, ..., t<n>)- tupConstraint = EqualP (VarT tupTyName) tupTy+ tupConstraint = equalConstrTy (VarT tupTyName) tupTy -- Reify t1, ..., Reify t<n>- reifyConstraints = map (\n -> ClassP (mkName "Reify") [VarT n]) tupElemTyNames+ reifyConstraints = map (\n -> nameTyApp (mkName "Reify") (VarT n)) tupElemTyNames - constraints = tupConstraint : reifyConstraints + 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 +-- | 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> +-- 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>),@@ -433,20 +445,20 @@ 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+ 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+ mkTupleASTTy (mkName "TupleType") expCon (tupTyConstName "") maxWidth where expCon = AppT $ ConT $ mkName "Type" @@ -460,21 +472,24 @@ -- | The name of the constructor that constructs a tuple construction -- term.-outerConst :: Name-outerConst = mkName "TupleConstE"+outerConst :: String -> Name+outerConst "" = mkName "TupleConstE"+outerConst m = mkName $ printf "%s.TupleConstE" m -- | The name of the constructor for a given tuple width.-innerConst :: Int -> Name-innerConst width = mkName $ printf "Tuple%dE" width+innerConst :: String -> Int -> Name+innerConst "" width = mkName $ printf "Tuple%dE" width+innerConst m width = mkName $ printf "%s.Tuple%dE" m 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+tupTyConstName :: String -> Int -> Name+tupTyConstName "" width = mkName $ printf "Tuple%dT" width+tupTyConstName m width = mkName $ printf "%s.Tuple%dT" m width -- | tupleType :: [Type] -> Type@@ -493,7 +508,7 @@ -- | 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+mkTupConstTerm ts+ | length ts <= 16 = return $ AppE (ConE $ mkName "TupleConstE")+ $ foldl' AppE (ConE $ innerConst "" $ length ts) ts | otherwise = impossible
− src/Database/DSH/Impossible.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Database.DSH.Impossible (impossible, unimplemented) where--import qualified Language.Haskell.TH as TH--impossible :: TH.ExpQ-impossible = do- loc <- TH.location- let pos = (TH.loc_filename loc, fst (TH.loc_start loc), snd (TH.loc_start loc))- 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/NKL/Kure.hs view
@@ -11,10 +11,10 @@ -- * 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 @@ -25,21 +25,20 @@ -- * 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 @@ -74,10 +73,10 @@ 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 @@ -118,13 +117,13 @@ -------------------------------------------------------------------------------- -- Congruence combinators for CL expressions -tableT :: Monad m => (Type -> String -> [Column] -> TableHints -> b)+tableT :: Monad m => (Type -> String -> BaseTableSchema -> 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 #-} - + Table ty n schema -> return $ f ty n schema+ _ -> fail "not a table node"+{-# INLINE tableT #-}+ tableR :: Monad m => Rewrite NestedCtx m Expr tableR = tableT Table {-# INLINE tableR #-}@@ -134,8 +133,8 @@ -> (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 + 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 #-}@@ -143,46 +142,46 @@ 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 + AppE1 ty p e -> f ty p <$> applyT t (c@@AppE1Arg) e _ -> fail "not a unary primitive application"-{-# INLINE appe1T #-} - +{-# INLINE appe1T #-}+ appe1R :: Monad m => Rewrite NestedCtx m Expr -> Rewrite NestedCtx m Expr appe1R t = appe1T t AppE1-{-# INLINE appe1R #-} - +{-# 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 + 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 #-} +{-# 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 #-} - +{-# 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 + 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 #-} +{-# 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 #-} +{-# INLINE binopR #-} unopT :: Monad m => Transform NestedCtx m Expr a -> (Type -> ScalarUnOp -> a -> b)@@ -195,58 +194,58 @@ 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 + 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 #-} - +{-# 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 #-} - +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 #-} - +{-# INLINE constExprT #-}+ litR :: Monad m => Rewrite NestedCtx m Expr litR = constExprT Const-{-# INLINE litR #-} - +{-# 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 #-} - +{-# INLINE varT #-}+ varR :: Monad m => Rewrite NestedCtx m Expr varR = varT Var-{-# INLINE varR #-} +{-# INLINE varR #-} letT :: Monad m => Transform NestedCtx m Expr a1 -> Transform NestedCtx m Expr a2- -> (Type -> Ident -> a1 -> a2 -> b) + -> (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 + 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 +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@@ -262,7 +261,7 @@ --------------------------------------------------------------------------------- + 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@@ -277,15 +276,3 @@ 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
@@ -14,14 +14,14 @@ 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.Impossible+import qualified Database.DSH.Common.Lang as L import Database.DSH.Common.Nat-import Database.DSH.Common.Type (Type, Typed, typeOf)+import Database.DSH.Common.Pretty+import Database.DSH.Common.Type (Type, Typed, typeOf) -- | Nested Kernel Language (NKL) expressions-data Expr = Table Type String [L.Column] L.TableHints+data Expr = Table Type String L.BaseTableSchema | AppE1 Type Prim1 Expr | AppE2 Type Prim2 Expr Expr | BinOp Type L.ScalarBinOp Expr Expr@@ -35,7 +35,7 @@ deriving (Show) instance Typed Expr where- typeOf (Table t _ _ _) = t+ typeOf (Table t _ _) = t typeOf (AppE1 t _ _) = t typeOf (AppE2 t _ _ _) = t typeOf (If t _ _ _) = t@@ -48,91 +48,79 @@ typeOf (MkTuple t _) = t instance Pretty Expr where- pretty (MkTuple _ es) = tupled $ map pretty es- pretty (AppE1 _ (TupElem n) e1) = + pretty (MkTuple _ es) = prettyTuple $ 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 (Table _ n _) = kw (text "table") <> parens (text n)+ pretty (AppE1 _ p1 e) = pretty p1 <+> (parenthize e)+ pretty (AppE2 _ p2 e1 e2)+ | isJoinOp p2 = prettyJoin (pretty p2) (parenthize e1) (parenthize e2)+ | otherwise = prettyApp2 (pretty p2) (parenthize e1) (parenthize e2)+ pretty (UnOp _ o e) = prettyUnOp (pretty o) (pretty e)+ pretty (BinOp _ o e1 e2)+ | L.isBinInfixOp o = prettyInfixBinOp (pretty o)+ (parenthize e1)+ (parenthize e2)+ | otherwise = prettyPrefixBinOp (pretty o)+ (parenthize e1)+ (parenthize e2)+ pretty (If _ c t e) = prettyIf (pretty c) (pretty t) (pretty 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+ pretty (Iterator _ e x xs) =+ prettyComp (pretty e) [text x <+> comp (text "<-") <+> pretty xs]+ pretty (Let _ x e1 e) = prettyLet (text x) (pretty e1) (pretty e) parenthize :: Expr -> Doc parenthize e = case e of Var _ _ -> pretty e Const _ _ -> pretty e- Table _ _ _ _ -> pretty e+ Table _ _ _ -> pretty e Iterator _ _ _ _ -> pretty e AppE1 _ (TupElem _) _ -> pretty e _ -> parens $ pretty e data Prim1 = Singleton- | Length + | Only+ | Length | Concat- | Sum - | Avg - | The - | Head- | Tail- | Minimum + | Sum+ | Avg+ | Minimum | Maximum- | Reverse - | And + | Reverse+ | And | Or- | Init - | Last | Nub | Number- | Reshape Integer- | Transpose+ | Sort+ | Group+ | Restrict | TupElem TupleIndex- deriving (Eq)+ deriving (Eq, Show) -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+instance Pretty Prim1 where+ pretty Singleton = combinator $ text "sng"+ pretty Only = combinator $ text "only"+ pretty Length = combinator $ text "length"+ pretty Concat = combinator $ text "concat"+ pretty Sum = combinator $ text "sum"+ pretty Avg = combinator $ text "avg"+ pretty Minimum = combinator $ text "minimum"+ pretty Maximum = combinator $ text "maximum"+ pretty Reverse = combinator $ text "reverse"+ pretty And = combinator $ text "and"+ pretty Or = combinator $ text "or"+ pretty Nub = combinator $ text "nub"+ pretty Number = combinator $ text "number"+ pretty Sort = combinator $ text "sort"+ pretty Restrict = restrict $ text "restrict"+ pretty Group = combinator $ text "group" -- tuple access is pretty-printed in a special way- show TupElem{} = $impossible- -data Prim2 = Group- | Sort- | Restrict- | Append- | Index+ pretty TupElem{} = $impossible++data Prim2 = Append | Zip | CartProduct | NestProduct@@ -140,18 +128,27 @@ | NestJoin (L.JoinPredicate L.JoinExpr) | SemiJoin (L.JoinPredicate L.JoinExpr) | AntiJoin (L.JoinPredicate L.JoinExpr)- deriving (Eq)+ deriving (Eq, Show) -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)+isJoinOp :: Prim2 -> Bool+isJoinOp op =+ case op of+ CartProduct -> True+ NestProduct -> True+ ThetaJoin{} -> True+ NestJoin{} -> True+ SemiJoin{} -> True+ AntiJoin{} -> True+ Append -> False+ Zip -> False++instance Pretty Prim2 where+ pretty Append = combinator $ text "append"+ pretty Zip = combinator $ text "zip"++ pretty CartProduct = join $ text "cartproduct"+ pretty NestProduct = join $ text "nestproduct"+ pretty (ThetaJoin p) = join $ text $ printf "thetajoin{%s}" (pp p)+ pretty (NestJoin p) = join $ text $ printf "nestjoin{%s}" (pp p)+ pretty (SemiJoin p) = join $ text $ printf "semijoin{%s}" (pp p)+ pretty (AntiJoin p) = join $ text $ printf "antijoin{%s}" (pp p)
src/Database/DSH/NKL/Primitives.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PatternSynonyms #-}+ -- | Smart constructors for NKL combinators module Database.DSH.NKL.Primitives where @@ -24,7 +26,7 @@ -- Smart constructors tupElem :: TupleIndex -> Expr -> Expr-tupElem f e = +tupElem f e = let t = tupleElemT (typeOf e) f in AppE1 t (TupElem f) e @@ -44,7 +46,7 @@ in MkTuple rt es sng :: Expr -> Expr-sng x = AppE1 (listT $ typeOf x) Singleton x+sng x = AppE1 (ListT $ typeOf x) Singleton x concat :: Expr -> Expr concat e = let t = typeOf e@@ -52,23 +54,22 @@ 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+restrict :: Expr -> Expr+restrict xs = let ListT (TupleT [xt, PBoolT]) = typeOf xs+ in AppE1 (ListT xt) Restrict xs -sort :: Expr -> Expr -> Expr-sort vs ss = let vst@(ListT _) = typeOf vs- in AppE2 vst Sort vs ss+sort :: Expr -> Expr+sort xs = let ListT (TupleT [xt, _]) = typeOf xs+ in AppE1 (ListT xt) Sort xs --- FIXME type is not correct-group :: Expr -> Expr -> Expr-group vs gs = let vst@(ListT _) = typeOf vs- in AppE2 vst Group vs gs+group :: Expr -> Expr+group xs = let ListT (TupleT [xt, gt]) = typeOf xs+ in AppE1 (ListT (TupleT [gt, ListT xt])) Group xs 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+if_ c t e = if PBoolT == typeOf c then If (typeOf t) c t e else tyErr "if_"
src/Database/DSH/NKL/Rewrite.hs view
@@ -9,18 +9,19 @@ , optimizeNKL ) where -import Control.Arrow-import Data.List-import Data.Monoid+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+import Database.DSH.Common.Impossible +import Database.DSH.Common.Lang+import Database.DSH.Common.RewriteM+import Database.DSH.Common.Type+import Database.DSH.NKL.Kure+import Database.DSH.NKL.Lang+import qualified Database.DSH.NKL.Primitives as P+ -- | 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)@@ -56,12 +57,12 @@ subst nameCtx x s e = either (const e) id $ applyExpr nameCtx (substR x s) e alphaCompR :: [Ident] -> RewriteN Expr-alphaCompR avoidNames = do +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 + iteratorT (tryR $ substR x (Var varTy x'))+ idR (\_ h' _ xs' -> Iterator compTy h' x' xs') alphaLetR :: [Ident] -> RewriteN Expr@@ -129,8 +130,9 @@ _ -> anyR $ inlineBindingR v s pattern ConcatP t xs <- AppE1 t Concat xs-pattern SingletonP e <- AppE1 _ Singleton e - +pattern SingletonP e <- AppE1 _ Singleton e+pattern RestrictP e <- AppE1 _ Restrict e+ -- concatMap (\x -> [e x]) xs -- concat [ [ e x ] | x <- xs ] -- =>@@ -147,7 +149,7 @@ Var _ n | n == v -> return 1 Var _ _ | otherwise -> return 0 - Let _ n _ _ | n == v -> letT (constT $ return 0) + Let _ n _ _ | n == v -> letT (constT $ return 0) (countVarRefT v) (\_ _ c1 c2 -> c1 + c2) Let _ _ _ _ | otherwise -> letT (countVarRefT v)@@ -197,15 +199,62 @@ Let _ x e1 _ <- idR guardM $ simpleExpr e1 childT LetBody $ substR x e1- ++-- | Eliminate an iterator that does not perform any work.+identityIteratorR :: RewriteN Expr+identityIteratorR = do+ Iterator _ (Var _ x) x' xs <- idR+ guardM $ x == x'+ return xs++-- | Push an iterator expression into a Sort operator to get a more+-- compact NKL expression. Note: Effectively, this rewrite pulls up+-- sorting in the plan. For sorting, this is propably OK. For+-- Restrict, though, that would not be a good idea.+--+-- [ f x | x <- sort [ (g y, h y) | y <- ys ] ]+-- =>+-- sort [ (f [g y/x], h y) | y <- ys ]+mergeSortIteratorR :: RewriteN Expr+mergeSortIteratorR = do+ Iterator _ f x (AppE1 _ Sort (Iterator _ (MkTuple _ [g, h]) y ys)) <- idR+ g' <- constT (return f) >>> substR x g+ let ft = typeOf f+ pt = TupleT [ft, PBoolT]+ return $ AppE1 (ListT ft) Sort (Iterator (ListT pt) (MkTuple pt [g', h]) y ys)++-- | Merge two adjacent restricts into one.+--+-- restrict [ (x, p1 x) | x <- restrict [ (y, p2 y) | y <- ys ] ]+-- =>+-- restrict [ (y, p1[y/x] y && p2 y) | y <- ys ]+mergeRestrictR :: RewriteN Expr+mergeRestrictR = do+ RestrictP (Iterator _ (MkTuple _ [Var _ x', p1])+ x+ (RestrictP (Iterator _ (MkTuple _ [Var _ y', p2])+ y+ ys))) <- idR+ guardM $ x == x'+ guardM $ y == y'+ let yt = elemT $ typeOf ys+ yst = ListT yt+ p1' <- constT (return p1) >>> substR x (Var yt y)+ let p = BinOp PBoolT (SBBoolOp Conj) p1' p2+ return $ P.restrict (Iterator yst (P.tuple [Var yt y, p]) y ys)+ nklOptimizations :: RewriteN Expr-nklOptimizations = anybuR $ singletonHeadR - <+ unusedBindingR +nklOptimizations = anybuR $ singletonHeadR+ <+ unusedBindingR <+ referencedOnceR <+ simpleBindingR+ <+ identityIteratorR+ <+ mergeSortIteratorR+ <+ mergeRestrictR optimizeNKL :: Expr -> Expr-optimizeNKL expr = debugOpt "NKL" expr optimizedExpr- where- optimizedExpr = applyExpr [] nklOptimizations expr- +optimizeNKL expr =+ case applyExpr [] nklOptimizations expr of+ Left _ -> expr+ Right expr' -> expr'+
− src/Database/DSH/Optimizer/Common/Auxiliary.hs
@@ -1,11 +0,0 @@-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
@@ -1,74 +0,0 @@-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
@@ -1,52 +0,0 @@-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
@@ -1,73 +0,0 @@--- | 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
@@ -1,93 +0,0 @@-{-# 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
@@ -1,39 +0,0 @@-{-# 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
@@ -1,157 +0,0 @@-{-# 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
@@ -1,71 +0,0 @@-{-# 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
@@ -1,37 +0,0 @@-{-# 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
@@ -1,107 +0,0 @@-{-# 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
@@ -1,170 +0,0 @@--- 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
@@ -1,102 +0,0 @@-{-# 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
@@ -1,113 +0,0 @@-{-# 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
@@ -1,48 +0,0 @@-{-# 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
@@ -1,96 +0,0 @@-{-# 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
@@ -1,562 +0,0 @@-{-# 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
@@ -1,38 +0,0 @@-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
@@ -1,56 +0,0 @@-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
@@ -1,100 +0,0 @@-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
@@ -1,102 +0,0 @@--- 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
@@ -1,19 +0,0 @@-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
@@ -1,492 +0,0 @@-{-# 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
@@ -1,115 +0,0 @@-{-# 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
@@ -1,139 +0,0 @@-{-# 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
@@ -1,418 +0,0 @@-{-# 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
@@ -1,185 +0,0 @@-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
@@ -1,127 +0,0 @@-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
@@ -1,164 +0,0 @@-{-# 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
@@ -1,218 +0,0 @@-{-# 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
@@ -1,115 +0,0 @@-{-# 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
@@ -1,119 +0,0 @@-{-# 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
@@ -1,108 +0,0 @@-{-# 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
@@ -1,965 +0,0 @@-{-# 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
@@ -1,48 +0,0 @@-{-# 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
@@ -1,159 +0,0 @@-{-# 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/Tests.hs view
@@ -0,0 +1,47 @@+-- | Generic DSH test queries that can be run by any backend for+-- concrete testing.+module Database.DSH.Tests+ ( defaultTests+ , runTests+ , module Database.DSH.Tests.ComprehensionTests+ , module Database.DSH.Tests.CombinatorTests+ ) where++import qualified Data.List as L+import System.Environment++import Test.Framework++import Database.DSH.Backend+import Database.DSH.Tests.CombinatorTests+import Database.DSH.Tests.ComprehensionTests+import Database.DSH.Tests.LawTests++-- | Convenience function for running tests+runTests :: Backend c => c -> [c -> Test] -> IO ()+runTests conn tests = do+ args <- getArgs+ let args' = if or $ map (L.isPrefixOf "-s") args+ then args+ else "-s5":args+ defaultMainWithArgs (map (\t -> t conn) tests) args'++-- | All available tests in one package.+defaultTests :: Backend c => [c -> Test]+defaultTests =+ [ tests_types+ , tests_tuples+ , tests_join_hunit+ , tests_nest_head_hunit+ , tests_nest_guard_hunit+ , tests_combinators_hunit+ , tests_comprehensions+ , tests_lifted_joins+ , tests_boolean+ , tests_numerics+ , tests_maybe+ , tests_either+ , tests_lists+ , tests_lifted+ , tests_laws+ ]
+ src/Database/DSH/Tests/CombinatorTests.hs view
@@ -0,0 +1,1237 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++-- | Tests on individual query combinators.+module Database.DSH.Tests.CombinatorTests+ ( tests_types+ , tests_boolean+ , tests_tuples+ , tests_numerics+ , tests_maybe+ , tests_either+ , tests_lists+ , tests_lifted+ , tests_combinators_hunit+ ) where+++import qualified Data.Decimal as D+import Data.Either+import Data.List+import Data.Maybe+import Data.Text (Text)+import qualified Data.Time.Calendar as C+import Data.Word+import GHC.Exts++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit+import Test.HUnit (Assertion)+import Test.QuickCheck++import qualified Database.DSH as Q+import Database.DSH.Backend+import Database.DSH.Tests.Common++{-+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 :: Backend c => c -> Test+tests_types conn = testGroup "Supported Types"+ [ testPropertyConn conn "()" prop_unit+ , testPropertyConn conn "Bool" prop_bool+ , testPropertyConn conn "Char" prop_char+ , testPropertyConn conn "Text" prop_text+ , testPropertyConn conn "Day" prop_day+ , testPropertyConn conn "Decimal" prop_decimal+ , testPropertyConn conn "Integer" prop_integer+ , testPropertyConn conn "Double" prop_double+ , testPropertyConn conn "[Integer]" prop_list_integer_1+ , testPropertyConn conn "[[Integer]]" prop_list_integer_2+ , testPropertyConn conn "[[[Integer]]]" prop_list_integer_3+ , testPropertyConn conn "[(Integer, Integer)]" prop_list_tuple_integer+ , testPropertyConn conn "([], [])" prop_tuple_list_integer+ , testPropertyConn conn "(,[])" prop_tuple_integer_list+ , testPropertyConn conn "(,[],)" prop_tuple_integer_list_integer+ , testPropertyConn conn "Maybe Integer" prop_maybe_integer+ , testPropertyConn conn "Either Integer Integer" prop_either_integer+ , testPropertyConn conn "(Int, Int, Int, Int)" prop_tuple4+ , testPropertyConn conn "(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 :: Backend c => c -> Test+tests_boolean conn = testGroup "Equality, Boolean Logic and Ordering"+ [ testPropertyConn conn "&&" prop_infix_and+ , testPropertyConn conn "||" prop_infix_or+ , testPropertyConn conn "not" prop_not+ , testPropertyConn conn "eq" prop_eq+ , testPropertyConn conn "neq" prop_neq+ , testPropertyConn conn "cond" prop_cond+ , testPropertyConn conn "cond tuples" prop_cond_tuples+ , testPropertyConn conn "cond ([[Integer]], [[Integer]])" prop_cond_list_tuples+ , testPropertyConn conn "lt" prop_lt+ , testPropertyConn conn "lte" prop_lte+ , testPropertyConn conn "gt" prop_gt+ , testPropertyConn conn "gte" prop_gte+ , testPropertyConn conn "min_integer" prop_min_integer+ , testPropertyConn conn "min_double" prop_min_double+ , testPropertyConn conn "max_integer" prop_max_integer+ , testPropertyConn conn "max_double" prop_max_double+ ]++tests_tuples :: Backend c => c -> Test+tests_tuples conn = testGroup "Tuples"+ [ testPropertyConn conn "fst" prop_fst+ , testPropertyConn conn "snd" prop_snd+ , testPropertyConn conn "fst ([], [])" prop_fst_nested+ , testPropertyConn conn "snd ([], [])" prop_snd_nested+ , testPropertyConn conn "tup3_1" prop_tup3_1+ , testPropertyConn conn "tup3_2" prop_tup3_2+ , testPropertyConn conn "tup3_3" prop_tup3_3+ , testPropertyConn conn "tup4_2" prop_tup4_2+ , testPropertyConn conn "tup4_4" prop_tup4_4+ , testPropertyConn conn "tup3_nested" prop_tup3_nested+ , testPropertyConn conn "tup4_tup3" prop_tup4_tup3+ ]++tests_numerics :: Backend c => c -> Test+tests_numerics conn = testGroup "Numerics"+ [ testPropertyConn conn "add_integer" prop_add_integer+ , testPropertyConn conn "add_double" prop_add_double+ , testPropertyConn conn "mul_integer" prop_mul_integer+ , testPropertyConn conn "mul_double" prop_mul_double+ , testPropertyConn conn "div_double" prop_div_double+ , testPropertyConn conn "integer_to_double" prop_integer_to_double+ , testPropertyConn conn "integer_to_double_+" prop_integer_to_double_arith+ , testPropertyConn conn "abs_integer" prop_abs_integer+ , testPropertyConn conn "abs_double" prop_abs_double+ , testPropertyConn conn "signum_integer" prop_signum_integer+ , testPropertyConn conn "signum_double" prop_signum_double+ , testPropertyConn conn "negate_integer" prop_negate_integer+ , testPropertyConn conn "negate_double" prop_negate_double+ , testPropertyConn conn "trig_sin" prop_trig_sin+ , testPropertyConn conn "trig_cos" prop_trig_cos+ , testPropertyConn conn "trig_tan" prop_trig_tan+ , testPropertyConn conn "trig_asin" prop_trig_asin+ , testPropertyConn conn "trig_acos" prop_trig_acos+ , testPropertyConn conn "trig_atan" prop_trig_atan+ , testPropertyConn conn "sqrt" prop_sqrt+ , testPropertyConn conn "log" prop_log+ , testPropertyConn conn "exp" prop_exp+ ]++tests_maybe :: Backend c => c -> Test+tests_maybe conn = testGroup "Maybe"+ [ testPropertyConn conn "maybe" prop_maybe+ , testPropertyConn conn "just" prop_just+ , testPropertyConn conn "isJust" prop_isJust+ , testPropertyConn conn "isNothing" prop_isNothing+ , testPropertyConn conn "fromJust" prop_fromJust+ , testPropertyConn conn "fromMaybe" prop_fromMaybe+ , testPropertyConn conn "listToMaybe" prop_listToMaybe+ , testPropertyConn conn "maybeToList" prop_maybeToList+ , testPropertyConn conn "catMaybes" prop_catMaybes+ , testPropertyConn conn "mapMaybe" prop_mapMaybe+ ]++tests_either :: Backend c => c -> Test+tests_either conn = testGroup "Either"+ [ testPropertyConn conn "left" prop_left+ , testPropertyConn conn "right" prop_right+ , testPropertyConn conn "isLeft" prop_isLeft+ , testPropertyConn conn "isRight" prop_isRight+ , testPropertyConn conn "either" prop_either+ , testPropertyConn conn "lefts" prop_lefts+ , testPropertyConn conn "rights" prop_rights+ , testPropertyConn conn "partitionEithers" prop_partitionEithers+ ]++tests_lists :: Backend c => c -> Test+tests_lists conn = testGroup "Lists"+ [ testPropertyConn conn "singleton" prop_singleton+ , testPropertyConn conn "head" prop_head+ , testPropertyConn conn "tail" prop_tail+ , testPropertyConn conn "cons" prop_cons+ , testPropertyConn conn "snoc" prop_snoc+ , testPropertyConn conn "take" prop_take+ , testPropertyConn conn "drop" prop_drop+ , testPropertyConn conn "take ++ drop" prop_takedrop+ , testPropertyConn conn "map" prop_map+ , testPropertyConn conn "filter" prop_filter+ , testPropertyConn conn "filter > 42" prop_filter_gt+ , testPropertyConn conn "filter > 42 (,[])" prop_filter_gt_nested+ , testPropertyConn conn "the" prop_the+ , testPropertyConn conn "last" prop_last+ , testPropertyConn conn "init" prop_init+ , testPropertyConn conn "null" prop_null+ , testPropertyConn conn "length" prop_length+ , testPropertyConn conn "length tuple list" prop_length_tuple+ , testPropertyConn conn "index [Integer]" prop_index+ , testPropertyConn conn "index [(Integer, [Integer])]" prop_index_pair+ , testPropertyConn conn "index [[]]" prop_index_nest+ , testPropertyConn conn "reverse" prop_reverse+ , testPropertyConn conn "reverse [[]]" prop_reverse_nest+ , testPropertyConn conn "append" prop_append+ , testPropertyConn conn "append nest" prop_append_nest+ , testPropertyConn conn "groupWith" prop_groupWith+ , testPropertyConn conn "groupWithKey" prop_groupWithKey+ , testPropertyConn conn "groupWith length" prop_groupWith_length+ , testPropertyConn conn "groupWithKey length" prop_groupWithKey_length+ , testPropertyConn conn "sortWith" prop_sortWith+ , testPropertyConn conn "sortWith [(,)]" prop_sortWith_pair+ , testPropertyConn conn "sortWith [(,[])]" prop_sortWith_nest+ , testPropertyConn conn "and" prop_and+ , testPropertyConn conn "or" prop_or+ , testPropertyConn conn "any_zero" prop_any_zero+ , testPropertyConn conn "all_zero" prop_all_zero+ , testPropertyConn conn "sum_integer" prop_sum_integer+ , testPropertyConn conn "sum_double" prop_sum_double+ , testPropertyConn conn "avg_double" prop_avg_double+ , testPropertyConn conn "concat" prop_concat+ , testPropertyConn conn "concatMap" prop_concatMap+ , testPropertyConn conn "maximum" prop_maximum+ , testPropertyConn conn "minimum" prop_minimum+ , testPropertyConn conn "splitAt" prop_splitAt+ , testPropertyConn conn "takeWhile" prop_takeWhile+ , testPropertyConn conn "dropWhile" prop_dropWhile+ , testPropertyConn conn "span" prop_span+ , testPropertyConn conn "break" prop_break+ , testPropertyConn conn "elem" prop_elem+ , testPropertyConn conn "notElem" prop_notElem+ , testPropertyConn conn "lookup" prop_lookup+ , testPropertyConn conn "zip" prop_zip+ , testPropertyConn conn "zip tuple1" prop_zip_tuple1+ , testPropertyConn conn "zip tuple2" prop_zip_tuple2+ , testPropertyConn conn "zip nested" prop_zip_nested+ , testPropertyConn conn "zip3" prop_zip3+ , testPropertyConn conn "zipWith" prop_zipWith+ , testPropertyConn conn "zipWith3" prop_zipWith3+ , testPropertyConn conn "unzip" prop_unzip+ , testPropertyConn conn "unzip3" prop_unzip3+ , testPropertyConn conn "nub" prop_nub+ , testPropertyConn conn "number" prop_number+ ]++tests_lifted :: Backend c => c -> Test+tests_lifted conn = testGroup "Lifted operations"+ [ testPropertyConn conn "Lifted &&" prop_infix_map_and+ , testPropertyConn conn "Lifted ||" prop_infix_map_or+ , testPropertyConn conn "Lifted not" prop_map_not+ , testPropertyConn conn "Lifted eq" prop_map_eq+ , testPropertyConn conn "Lifted neq" prop_map_neq+ , testPropertyConn conn "Lifted cond" prop_map_cond+ , testPropertyConn conn "Lifted cond tuples" prop_map_cond_tuples+ , testPropertyConn conn "Lifted cond + concat" prop_concatmapcond+ , testPropertyConn conn "Lifted lt" prop_map_lt+ , testPropertyConn conn "Lifted lte" prop_map_lte+ , testPropertyConn conn "Lifted gt" prop_map_gt+ , testPropertyConn conn "Lifted gte" prop_map_gte+ , testPropertyConn conn "Lifted cons" prop_map_cons+ , testPropertyConn conn "Lifted concat" prop_map_concat+ , testPropertyConn conn "Lifted fst" prop_map_fst+ , testPropertyConn conn "Lifted snd" prop_map_snd+ , testPropertyConn conn "Lifted the" prop_map_the+ --, testPropertyConn conn "Lifed and" prop_map_and+ , testPropertyConn conn "map (map (*2))" prop_map_map_mul+ , testPropertyConn conn "map (map (map (*2)))" prop_map_map_map_mul+ , testPropertyConn conn "map (\\x -> map (\\y -> x + y) ..) .." prop_map_map_add+ , testPropertyConn conn "Lifted groupWith" prop_map_groupWith+ , testPropertyConn conn "Lifted groupWithKey" prop_map_groupWithKey+ , testPropertyConn conn "Lifted sortWith" prop_map_sortWith+ , testPropertyConn conn "Lifted sortWith [(,)]" prop_map_sortWith_pair+ , testPropertyConn conn "Lifted sortWith [(,[])]" prop_map_sortWith_nest+ , testPropertyConn conn "Lifted sortWith length" prop_map_sortWith_length+ , testPropertyConn conn "Lifted groupWithKey length" prop_map_groupWithKey_length+ , testPropertyConn conn "Lifted length" prop_map_length+ , testPropertyConn conn "Lifted length on [[(a,b)]]" prop_map_length_tuple+ , testPropertyConn conn "Sortwith length nested" prop_sortWith_length_nest+ , testPropertyConn conn "GroupWithKey length nested" prop_groupWithKey_length_nest+ , testPropertyConn conn "Lift minimum" prop_map_minimum+ , testPropertyConn conn "map (map minimum)" prop_map_map_minimum+ , testPropertyConn conn "Lift maximum" prop_map_maximum+ , testPropertyConn conn "map (map maximum)" prop_map_map_maximum+ , testPropertyConn conn "map integer_to_double" prop_map_integer_to_double+ , testPropertyConn conn "map tail" prop_map_tail+ , testPropertyConn conn "map unzip" prop_map_unzip+ , testPropertyConn conn "map reverse" prop_map_reverse+ , testPropertyConn conn "map reverse [[]]" prop_map_reverse_nest+ , testPropertyConn conn "map and" prop_map_and+ , testPropertyConn conn "map (map and)" prop_map_map_and+ , testPropertyConn conn "map sum" prop_map_sum+ , testPropertyConn conn "map avg" prop_map_avg+ , testPropertyConn conn "map (map sum)" prop_map_map_sum+ , testPropertyConn conn "map or" prop_map_or+ , testPropertyConn conn "map (map or)" prop_map_map_or+ , testPropertyConn conn "map any zero" prop_map_any_zero+ , testPropertyConn conn "map all zero" prop_map_all_zero+ , testPropertyConn conn "map filter" prop_map_filter+ , testPropertyConn conn "map filter > 42" prop_map_filter_gt+ , testPropertyConn conn "map filter > 42 (,[])" prop_map_filter_gt_nested+ , testPropertyConn conn "map append" prop_map_append+ , testPropertyConn conn "map index" prop_map_index+ , testPropertyConn conn "map index [[]]" prop_map_index_nest+ , testPropertyConn conn "map init" prop_map_init+ , testPropertyConn conn "map last" prop_map_last+ , testPropertyConn conn "map null" prop_map_null+ , testPropertyConn conn "map nub" prop_map_nub+ , testPropertyConn conn "map snoc" prop_map_snoc+ , testPropertyConn conn "map take" prop_map_take+ , testPropertyConn conn "map drop" prop_map_drop+ , testPropertyConn conn "map zip" prop_map_zip+ , testPropertyConn conn "map takeWhile" prop_map_takeWhile+ , testPropertyConn conn "map dropWhile" prop_map_dropWhile+ , testPropertyConn conn "map span" prop_map_span+ , testPropertyConn conn "map break" prop_map_break+ , testPropertyConn conn "map number" prop_map_number+ , testPropertyConn conn "map sin" prop_map_trig_sin+ , testPropertyConn conn "map cos" prop_map_trig_cos+ , testPropertyConn conn "map tan" prop_map_trig_tan+ , testPropertyConn conn "map asin" prop_map_trig_asin+ , testPropertyConn conn "map acos" prop_map_trig_acos+ , testPropertyConn conn "map atan" prop_map_trig_atan+ , testPropertyConn conn "map log" prop_map_log+ , testPropertyConn conn "map exp" prop_map_exp+ , testPropertyConn conn "map sqrt" prop_map_sqrt+ ]++tests_combinators_hunit :: Backend c => c -> Test+tests_combinators_hunit conn = testGroup "HUnit combinators"+ [ testCase "hnegative_sum" (hnegative_sum conn)+ , testCase "hnegative_map_sum" (hnegative_map_sum conn)+ ]++-- * Supported Types++prop_unit :: Backend c => () -> c -> Property+prop_unit = makePropEq id id++prop_bool :: Backend c => Bool -> c -> Property+prop_bool = makePropEq id id++prop_integer :: Backend c => Integer -> c -> Property+prop_integer = makePropEq id id++prop_double :: Backend c => Double -> c -> Property+prop_double = makePropDouble id id++prop_char :: Backend c => Char -> c -> Property+prop_char c conn = c /= '\0' ==> makePropEq id id c conn++prop_text :: Backend c => Text -> c -> Property+prop_text t conn = makePropEq id id (filterNullChar t) conn++prop_day :: Backend c => C.Day -> c -> Property+prop_day d conn = makePropEq id id d conn++prop_decimal :: Backend c => (Positive Word8, Integer) -> c -> Property+prop_decimal (p, m) conn = makePropEq id id (D.Decimal (getPositive p) m) conn++prop_list_integer_1 :: Backend c => [Integer] -> c -> Property+prop_list_integer_1 = makePropEq id id++prop_list_integer_2 :: Backend c => [[Integer]] -> c -> Property+prop_list_integer_2 = makePropEq id id++prop_list_integer_3 :: Backend c => [[[Integer]]] -> c -> Property+prop_list_integer_3 = makePropEq id id++prop_list_tuple_integer :: Backend c => [(Integer, Integer)] -> c -> Property+prop_list_tuple_integer = makePropEq id id++prop_maybe_integer :: Backend c => Maybe Integer -> c -> Property+prop_maybe_integer = makePropEq id id++prop_tuple_list_integer :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_tuple_list_integer = makePropEq id id++prop_tuple_integer_list :: Backend c => (Integer, [Integer]) -> c -> Property+prop_tuple_integer_list = makePropEq id id++prop_tuple_integer_list_integer :: Backend c => (Integer, [Integer], Integer) -> c -> Property+prop_tuple_integer_list_integer = makePropEq id id++prop_either_integer :: Backend c => Either Integer Integer -> c -> Property+prop_either_integer = makePropEq id id++prop_tuple4 :: Backend c => [(Integer, Integer, Integer, Integer)] -> c -> Property+prop_tuple4 = makePropEq (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 :: Backend c => [(Integer, Integer, Integer, Integer, Integer)] -> c -> Property+prop_tuple5 = makePropEq (Q.map (\(Q.view -> (a, _, c, _, e)) -> Q.tup3 a c e))+ (map (\(a, _, c, _, e) -> (a, c, e)))++-- {-++-- prop_d0 :: Backend c => D0 -> c -> Property+-- prop_d0 = makePropEq id id++-- prop_d1 :: Backend c => D1 Integer -> c -> Property+-- prop_d1 = makePropEq id id++-- prop_d2 :: Backend c => D2 Integer Integer -> c -> Property+-- prop_d2 = makePropEq id id++-- prop_d3 :: Backend c => D3 -> c -> Property+-- prop_d3 = makePropEq id id++-- prop_d4 :: Backend c => D4 Integer -> c -> Property+-- prop_d4 = makePropEq id id++-- prop_d5 :: Backend c => D5 Integer -> c -> Property+-- prop_d5 = makePropEq id id++-- prop_d6 :: Backend c => D6 Integer Integer Integer Integer Integer -> c -> Property+-- prop_d6 = makePropEq id id++-- -}++-- * Equality, Boolean Logic and Ordering++prop_infix_and :: Backend c => (Bool,Bool) -> c -> Property+prop_infix_and = makePropEq (uncurryQ (Q.&&)) (uncurry (&&))++prop_infix_map_and :: Backend c => (Bool, [Bool]) -> c -> Property+prop_infix_map_and = makePropEq (\x -> Q.map ((Q.fst x) Q.&&) $ Q.snd x) (\(x,xs) -> map (x &&) xs)++prop_infix_or :: Backend c => (Bool,Bool) -> c -> Property+prop_infix_or = makePropEq (uncurryQ (Q.||)) (uncurry (||))++prop_infix_map_or :: Backend c => (Bool, [Bool]) -> c -> Property+prop_infix_map_or = makePropEq (\x -> Q.map ((Q.fst x) Q.||) $ Q.snd x) (\(x,xs) -> map (x ||) xs)++prop_not :: Backend c => Bool -> c -> Property+prop_not = makePropEq Q.not not++prop_map_not :: Backend c => [Bool] -> c -> Property+prop_map_not = makePropEq (Q.map Q.not) (map not)++prop_eq :: Backend c => (Integer,Integer) -> c -> Property+prop_eq = makePropEq (uncurryQ (Q.==)) (uncurry (==))++prop_map_eq :: Backend c => (Integer, [Integer]) -> c -> Property+prop_map_eq = makePropEq (\x -> Q.map ((Q.fst x) Q.==) $ Q.snd x) (\(x,xs) -> map (x ==) xs)++prop_neq :: Backend c => (Integer,Integer) -> c -> Property+prop_neq = makePropEq (uncurryQ (Q./=)) (uncurry (/=))++prop_map_neq :: Backend c => (Integer, [Integer]) -> c -> Property+prop_map_neq = makePropEq (\x -> Q.map ((Q.fst x) Q./=) $ Q.snd x) (\(x,xs) -> map (x /=) xs)++prop_cond :: Backend c => Bool -> c -> Property+prop_cond = makePropEq (\b -> Q.cond b 0 1) (\b -> if b then (0 :: Integer) else 1)++prop_cond_tuples :: Backend c => (Bool, (Integer, Integer)) -> c -> Property+prop_cond_tuples = makePropEq (\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 :: Backend c => (Bool, ([[Integer]], [[Integer]])) -> c -> Property+prop_cond_list_tuples = makePropEq (\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 :: Backend c => [Bool] -> c -> Property+prop_map_cond = makePropEq (Q.map (\b -> Q.cond b (0 :: Q.Q Integer) 1))+ (map (\b -> if b then 0 else 1))++prop_map_cond_tuples :: Backend c => [Bool] -> c -> Property+prop_map_cond_tuples = makePropEq (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 :: Backend c => [Integer] -> c -> Property+prop_concatmapcond l1 conn =+ makePropEq q n l1 conn+ 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 :: Backend c => (Integer, Integer) -> c -> Property+prop_lt = makePropEq (uncurryQ (Q.<)) (uncurry (<))++prop_map_lt :: Backend c => (Integer, [Integer]) -> c -> Property+prop_map_lt = makePropEq (\x -> Q.map ((Q.fst x) Q.<) $ Q.snd x) (\(x,xs) -> map (x <) xs)++prop_lte :: Backend c => (Integer, Integer) -> c -> Property+prop_lte = makePropEq (uncurryQ (Q.<=)) (uncurry (<=))++prop_map_lte :: Backend c => (Integer, [Integer]) -> c -> Property+prop_map_lte = makePropEq (\x -> Q.map ((Q.fst x) Q.<=) $ Q.snd x) (\(x,xs) -> map (x <=) xs)++prop_gt :: Backend c => (Integer, Integer) -> c -> Property+prop_gt = makePropEq (uncurryQ (Q.>)) (uncurry (>))++prop_map_gt :: Backend c => (Integer, [Integer]) -> c -> Property+prop_map_gt = makePropEq (\x -> Q.map ((Q.fst x) Q.>) $ Q.snd x) (\(x,xs) -> map (x >) xs)++prop_gte :: Backend c => (Integer, Integer) -> c -> Property+prop_gte = makePropEq (uncurryQ (Q.>=)) (uncurry (>=))++prop_map_gte :: Backend c => (Integer, [Integer]) -> c -> Property+prop_map_gte = makePropEq (\x -> Q.map ((Q.fst x) Q.>=) $ Q.snd x) (\(x,xs) -> map (x >=) xs)++prop_min_integer :: Backend c => (Integer,Integer) -> c -> Property+prop_min_integer = makePropEq (uncurryQ Q.min) (uncurry min)++prop_max_integer :: Backend c => (Integer,Integer) -> c -> Property+prop_max_integer = makePropEq (uncurryQ Q.max) (uncurry max)++prop_min_double :: Backend c => (Double,Double) -> c -> Property+prop_min_double = makePropDouble (uncurryQ Q.min) (uncurry min)++prop_max_double :: Backend c => (Double,Double) -> c -> Property+prop_max_double = makePropDouble (uncurryQ Q.max) (uncurry max)++-- * Maybe++prop_maybe :: Backend c => (Integer, Maybe Integer) -> c -> Property+prop_maybe = makePropEq (\a -> Q.maybe (Q.fst a) id (Q.snd a)) (\(i,mi) -> maybe i id mi)++prop_just :: Backend c => Integer -> c -> Property+prop_just = makePropEq Q.just Just++prop_isJust :: Backend c => Maybe Integer -> c -> Property+prop_isJust = makePropEq Q.isJust isJust++prop_isNothing :: Backend c => Maybe Integer -> c -> Property+prop_isNothing = makePropEq Q.isNothing isNothing++prop_fromJust :: Backend c => Integer -> c -> Property+prop_fromJust i conn = makePropEq Q.fromJust fromJust (Just i) conn++prop_fromMaybe :: Backend c => (Integer,Maybe Integer) -> c -> Property+prop_fromMaybe = makePropEq (uncurryQ Q.fromMaybe) (uncurry fromMaybe)++prop_listToMaybe :: Backend c => [Integer] -> c -> Property+prop_listToMaybe = makePropEq Q.listToMaybe listToMaybe++prop_maybeToList :: Backend c => Maybe Integer -> c -> Property+prop_maybeToList = makePropEq Q.maybeToList maybeToList++prop_catMaybes :: Backend c => [Maybe Integer] -> c -> Property+prop_catMaybes = makePropEq Q.catMaybes catMaybes++prop_mapMaybe :: Backend c => [Maybe Integer] -> c -> Property+prop_mapMaybe = makePropEq (Q.mapMaybe id) (mapMaybe id)++-- * Either++prop_left :: Backend c => Integer -> c -> Property+prop_left = makePropEq (Q.left :: Q.Q Integer -> Q.Q (Either Integer Integer)) Left++prop_right :: Backend c => Integer -> c -> Property+prop_right = makePropEq (Q.right :: Q.Q Integer -> Q.Q (Either Integer Integer)) Right++prop_isLeft :: Backend c => Either Integer Integer -> c -> Property+prop_isLeft = makePropEq Q.isLeft (\e -> case e of {Left _ -> True; Right _ -> False;})++prop_isRight :: Backend c => Either Integer Integer -> c -> Property+prop_isRight = makePropEq Q.isRight (\e -> case e of {Left _ -> False; Right _ -> True;})++prop_either :: Backend c => Either Integer Integer -> c -> Property+prop_either = makePropEq (Q.either id id) (either id id)++prop_lefts :: Backend c => [Either Integer Integer] -> c -> Property+prop_lefts = makePropEq Q.lefts lefts++prop_rights :: Backend c => [Either Integer Integer] -> c -> Property+prop_rights = makePropEq Q.rights rights++prop_partitionEithers :: Backend c => [Either Integer Integer] -> c -> Property+prop_partitionEithers = makePropEq Q.partitionEithers partitionEithers++-- * Lists++prop_cons :: Backend c => (Integer, [Integer]) -> c -> Property+prop_cons = makePropEq (uncurryQ (Q.<|)) (uncurry (:))++prop_map_cons :: Backend c => (Integer, [[Integer]]) -> c -> Property+prop_map_cons = makePropEq (\x -> Q.map ((Q.fst x) Q.<|) $ Q.snd x)+ (\(x,xs) -> map (x:) xs)++prop_snoc :: Backend c => ([Integer], Integer) -> c -> Property+prop_snoc = makePropEq (uncurryQ (Q.|>)) (\(a,b) -> a ++ [b])++prop_map_snoc :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_map_snoc = makePropEq (\z -> Q.map ((Q.fst z) Q.|>) (Q.snd z)) (\(a,b) -> map (\z -> a ++ [z]) b)++prop_singleton :: Backend c => Integer -> c -> Property+prop_singleton = makePropEq Q.singleton (: [])++prop_head :: Backend c => NonEmptyList Integer -> c -> Property+prop_head (NonEmpty is) = makePropEq Q.head head is++prop_tail :: Backend c => NonEmptyList Integer -> c -> Property+prop_tail (NonEmpty is) = makePropEq Q.tail tail is++prop_last :: Backend c => NonEmptyList Integer -> c -> Property+prop_last (NonEmpty is) = makePropEq Q.last last is++prop_map_last :: Backend c => [NonEmptyList Integer] -> c -> Property+prop_map_last ps =+ makePropEq (Q.map Q.last) (map last) (map getNonEmpty ps)++prop_init :: Backend c => NonEmptyList Integer -> c -> Property+prop_init (NonEmpty is) = makePropEq Q.init init is++prop_map_init :: Backend c => [NonEmptyList Integer] -> c -> Property+prop_map_init ps =+ makePropEq (Q.map Q.init) (map init) (map getNonEmpty ps)++prop_the :: Backend c => (Positive Int, Integer) -> c -> Property+prop_the (n, i) conn =+ let l = replicate (getPositive n) i+ in makePropEq Q.head the l conn++prop_map_the :: Backend c => [(Positive Int, Integer)] -> c -> Property+prop_map_the ps conn =+ let xss = map (\(Positive n, i) -> replicate n i) ps+ in makePropEq (Q.map Q.head) (map the) xss conn++prop_map_tail :: Backend c => [NonEmptyList Integer] -> c -> Property+prop_map_tail ps conn =+ makePropEq (Q.map Q.tail) (map tail) (map getNonEmpty ps) conn++prop_index :: Backend c => ([Integer], NonNegative Integer) -> c -> Property+prop_index (l, NonNegative i) conn =+ i < fromIntegral (length l)+ ==>+ makePropEq (uncurryQ (Q.!!))+ (\(a,b) -> a !! fromIntegral b)+ (l, i)+ conn++prop_index_pair :: Backend c => ([(Integer, [Integer])], NonNegative Integer) -> c -> Property+prop_index_pair (l, NonNegative i) conn =+ i < fromIntegral (length l)+ ==>+ makePropEq (uncurryQ (Q.!!))+ (\(a,b) -> a !! fromIntegral b)+ (l, i)+ conn++prop_index_nest :: Backend c => ([[Integer]], NonNegative Integer) -> c -> Property+prop_index_nest (l, NonNegative i) conn =+ i < fromIntegral (length l)+ ==>+ makePropEq (uncurryQ (Q.!!))+ (\(a,b) -> a !! fromIntegral b)+ (l, i)+ conn++prop_map_index :: Backend c => ([Integer], [NonNegative Integer]) -> c -> Property+prop_map_index (l, is) conn =+ and [i < 3 * fromIntegral (length l) | NonNegative i <- is]+ ==>+ makePropEq (\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, map getNonNegative is)+ conn++prop_map_index_nest :: Backend c => ([[Integer]], [NonNegative Integer]) -> c -> Property+prop_map_index_nest (l, is) conn =+ and [i < 3 * fromIntegral (length l) | NonNegative i <- is]+ ==> makePropEq (\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, map getNonNegative is)+ conn++prop_take :: Backend c => (Integer, [Integer]) -> c -> Property+prop_take = makePropEq (uncurryQ Q.take) (\(n,l) -> take (fromIntegral n) l)++prop_map_take :: Backend c => (Integer, [[Integer]]) -> c -> Property+prop_map_take = makePropEq (\z -> Q.map (Q.take $ Q.fst z) $ Q.snd z)+ (\(n,l) -> map (take (fromIntegral n)) l)++prop_drop :: Backend c => (Integer, [Integer]) -> c -> Property+prop_drop = makePropEq (uncurryQ Q.drop) (\(n,l) -> drop (fromIntegral n) l)++prop_map_drop :: Backend c => (Integer, [[Integer]]) -> c -> Property+prop_map_drop = makePropEq (\z -> Q.map (Q.drop $ Q.fst z) $ Q.snd z)+ (\(n,l) -> map (drop (fromIntegral n)) l)++prop_takedrop :: Backend c => (Integer, [Integer]) -> c -> Property+prop_takedrop = makePropEq 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 :: Backend c => [Integer] -> c -> Property+prop_map = makePropEq (Q.map id) (map id)++prop_map_map_mul :: Backend c => [[Integer]] -> c -> Property+prop_map_map_mul = makePropEq (Q.map (Q.map (*2))) (map (map (*2)))++prop_map_map_add :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_map_map_add = makePropEq (\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 :: Backend c => [[[Integer]]] -> c -> Property+prop_map_map_map_mul = makePropEq (Q.map (Q.map (Q.map (*2)))) (map (map (map (*2))))++prop_append :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_append = makePropEq (uncurryQ (Q.++)) (uncurry (++))++prop_append_nest :: Backend c => ([[Integer]], [[Integer]]) -> c -> Property+prop_append_nest = makePropEq (uncurryQ (Q.append)) (\(a,b) -> a ++ b)++prop_map_append :: Backend c => ([Integer], [[Integer]]) -> c -> Property+prop_map_append = makePropEq (\z -> Q.map (Q.fst z Q.++) (Q.snd z)) (\(a,b) -> map (a ++) b)++prop_filter :: Backend c => [Integer] -> c -> Property+prop_filter = makePropEq (Q.filter (const $ Q.toQ True)) (filter $ const True)++prop_filter_gt :: Backend c => [Integer] -> c -> Property+prop_filter_gt = makePropEq (Q.filter (Q.> 42)) (filter (> 42))++prop_filter_gt_nested :: Backend c => [(Integer, [Integer])] -> c -> Property+prop_filter_gt_nested = makePropEq (Q.filter ((Q.> 42) . Q.fst)) (filter ((> 42) . fst))++prop_map_filter :: Backend c => [[Integer]] -> c -> Property+prop_map_filter = makePropEq (Q.map (Q.filter (const $ Q.toQ True))) (map (filter $ const True))++prop_map_filter_gt :: Backend c => [[Integer]] -> c -> Property+prop_map_filter_gt = makePropEq (Q.map (Q.filter (Q.> 42))) (map (filter (> 42)))++prop_map_filter_gt_nested :: Backend c => [[(Integer, [Integer])]] -> c -> Property+prop_map_filter_gt_nested = makePropEq (Q.map (Q.filter ((Q.> 42) . Q.fst))) (map (filter ((> 42) . fst)))++prop_groupWith :: Backend c => [Integer] -> c -> Property+prop_groupWith = makePropEq (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 :: Backend c => [Integer] -> c -> Property+prop_groupWithKey = makePropEq (Q.groupWithKey id) (groupWithKey id)++prop_map_groupWith :: Backend c => [[Integer]] -> c -> Property+prop_map_groupWith = makePropEq (Q.map (Q.groupWith id)) (map (groupWith id))++prop_map_groupWithKey :: Backend c => [[Integer]] -> c -> Property+prop_map_groupWithKey = makePropEq (Q.map (Q.groupWithKey id)) (map (groupWithKey id))++prop_groupWith_length :: Backend c => [[Integer]] -> c -> Property+prop_groupWith_length = makePropEq (Q.groupWith Q.length) (groupWith length)++prop_groupWithKey_length :: Backend c => [[Integer]] -> c -> Property+prop_groupWithKey_length = makePropEq (Q.groupWithKey Q.length) (groupWithKey (fromIntegral . length))++prop_sortWith :: Backend c => [Integer] -> c -> Property+prop_sortWith = makePropEq (Q.sortWith id) (sortWith id)++prop_sortWith_pair :: Backend c => [(Integer, Integer)] -> c -> Property+prop_sortWith_pair = makePropEq (Q.sortWith Q.fst) (sortWith fst)++prop_sortWith_nest :: Backend c => [(Integer, [Integer])] -> c -> Property+prop_sortWith_nest = makePropEq (Q.sortWith Q.fst) (sortWith fst)++prop_map_sortWith :: Backend c => [[Integer]] -> c -> Property+prop_map_sortWith = makePropEq (Q.map (Q.sortWith id)) (map (sortWith id))++prop_map_sortWith_pair :: Backend c => [[(Integer, Integer)]] -> c -> Property+prop_map_sortWith_pair = makePropEq (Q.map (Q.sortWith Q.fst)) (map (sortWith fst))++prop_map_sortWith_nest :: Backend c => [[(Integer, [Integer])]] -> c -> Property+prop_map_sortWith_nest = makePropEq (Q.map (Q.sortWith Q.fst)) (map (sortWith fst))++prop_map_sortWith_length :: Backend c => [[[Integer]]] -> c -> Property+prop_map_sortWith_length = makePropEq (Q.map (Q.sortWith Q.length)) (map (sortWith length))++-- prop_map_groupWith_length :: Backend c => [[[Integer]]] -> c -> Property+-- prop_map_groupWith_length = makePropEq (Q.map (Q.groupWith Q.length)) (map (groupWith length))++prop_map_groupWithKey_length :: Backend c => [[[Integer]]] -> c -> Property+prop_map_groupWithKey_length = makePropEq (Q.map (Q.groupWithKey Q.length)) (map (groupWithKey (fromIntegral . length)))++prop_sortWith_length_nest :: Backend c => [[[Integer]]] -> c -> Property+prop_sortWith_length_nest = makePropEq (Q.sortWith Q.length) (sortWith length)++-- prop_groupWith_length_nest :: Backend c => [[[Integer]]] -> c -> Property+-- prop_groupWith_length_nest = makePropEq (Q.groupWith Q.length) (groupWith length)++prop_groupWithKey_length_nest :: Backend c => [[[Integer]]] -> c -> Property+prop_groupWithKey_length_nest = makePropEq (Q.groupWithKey Q.length) (groupWithKey (fromIntegral . length))++prop_null :: Backend c => [Integer] -> c -> Property+prop_null = makePropEq Q.null null++prop_map_null :: Backend c => [[Integer]] -> c -> Property+prop_map_null = makePropEq (Q.map Q.null) (map null)++prop_length :: Backend c => [Integer] -> c -> Property+prop_length = makePropEq Q.length ((fromIntegral :: Int -> Integer) . length)++prop_length_tuple :: Backend c => [(Integer, Integer)] -> c -> Property+prop_length_tuple = makePropEq Q.length (fromIntegral . length)++prop_map_length :: Backend c => [[Integer]] -> c -> Property+prop_map_length = makePropEq (Q.map Q.length) (map (fromIntegral . length))++prop_map_minimum :: Backend c => [NonEmptyList Integer] -> c -> Property+prop_map_minimum ps conn =+ makePropEq (Q.map Q.minimum)+ (map (fromIntegral . minimum))+ (map getNonEmpty ps)+ conn++prop_map_maximum :: Backend c => [NonEmptyList Integer] -> c -> Property+prop_map_maximum ps conn =+ makePropEq (Q.map Q.maximum)+ (map (fromIntegral . maximum))+ (map getNonEmpty ps)+ conn++prop_map_map_minimum :: Backend c => [[NonEmptyList Integer]] -> c -> Property+prop_map_map_minimum ps conn =+ makePropEq (Q.map (Q.map Q.minimum))+ (map (map(fromIntegral . minimum)))+ (map (map getNonEmpty) ps)+ conn++prop_map_map_maximum :: Backend c => [[NonEmptyList Integer]] -> c -> Property+prop_map_map_maximum ps conn =+ makePropEq (Q.map (Q.map Q.maximum))+ (map (map(fromIntegral . maximum)))+ (map (map getNonEmpty) ps)+ conn+++prop_map_length_tuple :: Backend c => [[(Integer, Integer)]] -> c -> Property+prop_map_length_tuple = makePropEq (Q.map Q.length) (map (fromIntegral . length))++prop_reverse :: Backend c => [Integer] -> c -> Property+prop_reverse = makePropEq Q.reverse reverse++prop_reverse_nest :: Backend c => [[Integer]] -> c -> Property+prop_reverse_nest = makePropEq Q.reverse reverse++prop_map_reverse :: Backend c => [[Integer]] -> c -> Property+prop_map_reverse = makePropEq (Q.map Q.reverse) (map reverse)++prop_map_reverse_nest :: Backend c => [[[Integer]]] -> c -> Property+prop_map_reverse_nest = makePropEq (Q.map Q.reverse) (map reverse)++prop_and :: Backend c => [Bool] -> c -> Property+prop_and = makePropEq Q.and and++prop_map_and :: Backend c => [[Bool]] -> c -> Property+prop_map_and = makePropEq (Q.map Q.and) (map and)++prop_map_map_and :: Backend c => [[[Bool]]] -> c -> Property+prop_map_map_and = makePropEq (Q.map (Q.map Q.and)) (map (map and))++prop_or :: Backend c => [Bool] -> c -> Property+prop_or = makePropEq Q.or or++prop_map_or :: Backend c => [[Bool]] -> c -> Property+prop_map_or = makePropEq (Q.map Q.or) (map or)++prop_map_map_or :: Backend c => [[[Bool]]] -> c -> Property+prop_map_map_or = makePropEq (Q.map (Q.map Q.or)) (map (map or))++prop_any_zero :: Backend c => [Integer] -> c -> Property+prop_any_zero = makePropEq (Q.any (Q.== 0)) (any (== 0))++prop_map_any_zero :: Backend c => [[Integer]] -> c -> Property+prop_map_any_zero = makePropEq (Q.map (Q.any (Q.== 0))) (map (any (== 0)))++prop_all_zero :: Backend c => [Integer] -> c -> Property+prop_all_zero = makePropEq (Q.all (Q.== 0)) (all (== 0))++prop_map_all_zero :: Backend c => [[Integer]] -> c -> Property+prop_map_all_zero = makePropEq (Q.map (Q.all (Q.== 0))) (map (all (== 0)))++prop_sum_integer :: Backend c => [Integer] -> c -> Property+prop_sum_integer = makePropEq Q.sum sum++prop_map_sum :: Backend c => [[Integer]] -> c -> Property+prop_map_sum = makePropEq (Q.map Q.sum) (map sum)++prop_map_avg :: Backend c => [NonEmptyList Double] -> c -> Property+prop_map_avg is conn =+ makePropDoubles (Q.map Q.avg) (map avgDouble) (map getNonEmpty is) conn++prop_map_map_sum :: Backend c => [[[Integer]]] -> c -> Property+prop_map_map_sum = makePropEq (Q.map (Q.map Q.sum)) (map (map sum))++-- prop_map_map_avg :: Backend c => [[NonEmptyList Integer]] -> c -> Property+-- prop_map_map_avg is conn =+-- makePropEq (Q.map (Q.map Q.avg))+-- (map (map avgInt))+-- (map (map getNonEmpty) is)+-- conn++prop_sum_double :: Backend c => [Double] -> c -> Property+prop_sum_double = makePropDouble Q.sum sum++avgDouble :: [Double] -> Double+avgDouble ds = sum ds / (fromIntegral $ length ds)++prop_avg_double :: Backend c => NonEmptyList Double -> c -> Property+prop_avg_double ds conn = makePropDouble Q.avg avgDouble (getNonEmpty ds) conn++prop_concat :: Backend c => [[Integer]] -> c -> Property+prop_concat = makePropEq Q.concat concat++prop_map_concat :: Backend c => [[[Integer]]] -> c -> Property+prop_map_concat = makePropEq (Q.map Q.concat) (map concat)++prop_concatMap :: Backend c => [Integer] -> c -> Property+prop_concatMap = makePropEq (Q.concatMap Q.singleton) (concatMap (: []))++prop_maximum :: Backend c => NonEmptyList Integer -> c -> Property+prop_maximum (NonEmpty is) = makePropEq Q.maximum maximum is++prop_minimum :: Backend c => NonEmptyList Integer -> c -> Property+prop_minimum (NonEmpty is) = makePropEq Q.minimum minimum is++prop_splitAt :: Backend c => (Integer, [Integer]) -> c -> Property+prop_splitAt = makePropEq (uncurryQ Q.splitAt) (\(a,b) -> splitAt (fromIntegral a) b)++prop_takeWhile :: Backend c => (Integer, [Integer]) -> c -> Property+prop_takeWhile = makePropEq (uncurryQ $ Q.takeWhile . (Q.==))+ (uncurry $ takeWhile . (==))++prop_dropWhile :: Backend c => (Integer, [Integer]) -> c -> Property+prop_dropWhile = makePropEq (uncurryQ $ Q.dropWhile . (Q.==))+ (uncurry $ dropWhile . (==))++prop_map_takeWhile :: Backend c => (Integer, [[Integer]]) -> c -> Property+prop_map_takeWhile = makePropEq (\z -> Q.map (Q.takeWhile (Q.fst z Q.==)) (Q.snd z))+ (\z -> map (takeWhile (fst z ==)) (snd z))++prop_map_dropWhile :: Backend c => (Integer, [[Integer]]) -> c -> Property+prop_map_dropWhile = makePropEq (\z -> Q.map (Q.dropWhile (Q.fst z Q.==)) (Q.snd z))+ (\z -> map (dropWhile (fst z ==)) (snd z))++prop_span :: Backend c => (Integer, [Integer]) -> c -> Property+prop_span = makePropEq (uncurryQ $ Q.span . (Q.==))+ (uncurry $ span . (==) . fromIntegral)++prop_map_span :: Backend c => (Integer, [[Integer]]) -> c -> Property+prop_map_span = makePropEq (\z -> Q.map (Q.span ((Q.fst z) Q.==)) (Q.snd z))+ (\z -> map (span (fst z ==)) (snd z))++prop_break :: Backend c => (Integer, [Integer]) -> c -> Property+prop_break = makePropEq (uncurryQ $ Q.break . (Q.==))+ (uncurry $ break . (==) . fromIntegral)++prop_map_break :: Backend c => (Integer, [[Integer]]) -> c -> Property+prop_map_break = makePropEq (\z -> Q.map (Q.break ((Q.fst z) Q.==)) (Q.snd z))+ (\z -> map (break (fst z ==)) (snd z))++prop_elem :: Backend c => (Integer, [Integer]) -> c -> Property+prop_elem = makePropEq (uncurryQ Q.elem)+ (uncurry elem)++prop_notElem :: Backend c => (Integer, [Integer]) -> c -> Property+prop_notElem = makePropEq (uncurryQ Q.notElem)+ (uncurry notElem)++prop_lookup :: Backend c => (Integer, [(Integer,Integer)]) -> c -> Property+prop_lookup = makePropEq (uncurryQ Q.lookup)+ (uncurry lookup)++prop_zip :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_zip = makePropEq (uncurryQ Q.zip) (uncurry zip)++prop_zip_nested :: Backend c => ([Integer], [(Integer, [Integer])]) -> c -> Property+prop_zip_nested = makePropEq (uncurryQ Q.zip) (uncurry zip)++prop_zip_tuple1 :: Backend c => ([Integer], [(Text, Double)]) -> c -> Property+prop_zip_tuple1 (xs, tds) =+ makePropEq (uncurryQ Q.zip) (uncurry zip) (xs, tds')+ where+ tds' = map (\(t, d) -> (filterNullChar t, d)) tds++prop_zip_tuple2 :: Backend c+ => ([(Integer, Integer)], [(Text, Double)])+ -> c+ -> Property+prop_zip_tuple2 (xs, tds) =+ makePropEq (uncurryQ Q.zip) (uncurry zip) (xs, tds')+ where+ tds' = map (\(t, d) -> (filterNullChar t, d)) tds++prop_map_zip :: Backend c => ([Integer], [[Integer]]) -> c -> Property+prop_map_zip = makePropEq (\z -> Q.map (Q.zip $ Q.fst z) $ Q.snd z) (\(x, y) -> map (zip x) y)++prop_zipWith :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_zipWith = makePropEq (uncurryQ $ Q.zipWith (+)) (uncurry $ zipWith (+))++prop_unzip :: Backend c => [(Integer, Integer)] -> c -> Property+prop_unzip = makePropEq Q.unzip unzip++prop_map_unzip :: Backend c => [[(Integer, Integer)]] -> c -> Property+prop_map_unzip = makePropEq (Q.map Q.unzip) (map unzip)++prop_zip3 :: Backend c => ([Integer], [Integer],[Integer]) -> c -> Property+prop_zip3 = makePropEq (\q -> (case Q.view q of (as,bs,cs) -> Q.zip3 as bs cs))+ (\(as,bs,cs) -> zip3 as bs cs)++prop_zipWith3 :: Backend c => ([Integer], [Integer],[Integer]) -> c -> Property+prop_zipWith3 = makePropEq (\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 :: Backend c => [(Integer, Integer, Integer)] -> c -> Property+prop_unzip3 = makePropEq Q.unzip3 unzip3++prop_nub :: Backend c => [Integer] -> c -> Property+prop_nub = makePropEq Q.nub nub++prop_map_nub :: Backend c => [[(Integer, Integer)]] -> c -> Property+prop_map_nub = makePropEq (Q.map Q.nub) (map nub)++-- * Tuples++prop_fst :: Backend c => (Integer, Integer) -> c -> Property+prop_fst = makePropEq Q.fst fst++prop_fst_nested :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_fst_nested = makePropEq Q.fst fst++prop_map_fst :: Backend c => [(Integer, Integer)] -> c -> Property+prop_map_fst = makePropEq (Q.map Q.fst) (map fst)++prop_snd :: Backend c => (Integer, Integer) -> c -> Property+prop_snd = makePropEq Q.snd snd++prop_map_snd :: Backend c => [(Integer, Integer)] -> c -> Property+prop_map_snd = makePropEq (Q.map Q.snd) (map snd)++prop_snd_nested :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_snd_nested = makePropEq Q.snd snd++prop_tup3_1 :: Backend c => (Integer, Integer, Integer) -> c -> Property+prop_tup3_1 = makePropEq (\q -> case Q.view q of (a, _, _) -> a) (\(a, _, _) -> a)++prop_tup3_2 :: Backend c => (Integer, Integer, Integer) -> c -> Property+prop_tup3_2 = makePropEq (\q -> case Q.view q of (_, b, _) -> b) (\(_, b, _) -> b)++prop_tup3_3 :: Backend c => (Integer, Integer, Integer) -> c -> Property+prop_tup3_3 = makePropEq (\q -> case Q.view q of (_, _, c) -> c) (\(_, _, c) -> c)++prop_tup4_2 :: Backend c => (Integer, Integer, Integer, Integer) -> c -> Property+prop_tup4_2 = makePropEq (\q -> case Q.view q of (_, b, _, _) -> b) (\(_, b, _, _) -> b)++prop_tup4_4 :: Backend c => (Integer, Integer, Integer, Integer) -> c -> Property+prop_tup4_4 = makePropEq (\q -> case Q.view q of (_, _, _, d) -> d) (\(_, _, _, d) -> d)++prop_tup3_nested :: Backend c => (Integer, [Integer], Integer) -> c -> Property+prop_tup3_nested = makePropEq (\q -> case Q.view q of (_, b, _) -> b) (\(_, b, _) -> b)++prop_tup4_tup3 :: Backend c => (Integer, Integer, Integer, Integer) -> c -> Property+prop_tup4_tup3 = makePropEq (\q -> case Q.view q of (a, b, _, d) -> Q.tup3 a b d)+ (\(a, b, _, d) -> (a, b, d))++-- * Numerics++prop_add_integer :: Backend c => (Integer,Integer) -> c -> Property+prop_add_integer = makePropEq (uncurryQ (+)) (uncurry (+))++prop_add_double :: Backend c => (Double,Double) -> c -> Property+prop_add_double = makePropDouble (uncurryQ (+)) (uncurry (+))++prop_mul_integer :: Backend c => (Integer,Integer) -> c -> Property+prop_mul_integer = makePropEq (uncurryQ (*)) (uncurry (*))++prop_mul_double :: Backend c => (Double,Double) -> c -> Property+prop_mul_double = makePropDouble (uncurryQ (*)) (uncurry (*))++prop_div_double :: Backend c => (Double,NonZero Double) -> c -> Property+prop_div_double (x,NonZero y) conn =+ makePropDouble (uncurryQ (/)) (uncurry (/)) (x,y) conn++prop_integer_to_double :: Backend c => Integer -> c -> Property+prop_integer_to_double = makePropDouble Q.integerToDouble fromInteger++prop_integer_to_double_arith :: Backend c => (Integer, Double) -> c -> 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 :: Backend c => [Integer] -> c -> Property+prop_map_integer_to_double = makePropDoubles (Q.map Q.integerToDouble) (map fromInteger)++prop_abs_integer :: Backend c => Integer -> c -> Property+prop_abs_integer = makePropEq Q.abs abs++prop_abs_double :: Backend c => Double -> c -> Property+prop_abs_double = makePropDouble Q.abs abs++prop_signum_integer :: Backend c => Integer -> c -> Property+prop_signum_integer = makePropEq Q.signum signum++prop_signum_double :: Backend c => Double -> c -> Property+prop_signum_double = makePropDouble Q.signum signum++prop_negate_integer :: Backend c => Integer -> c -> Property+prop_negate_integer = makePropEq Q.negate negate++prop_negate_double :: Backend c => Double -> c -> Property+prop_negate_double = makePropDouble Q.negate negate++prop_trig_sin :: Backend c => Double -> c -> Property+prop_trig_sin = makePropDouble Q.sin sin++prop_trig_cos :: Backend c => Double -> c -> Property+prop_trig_cos = makePropDouble Q.cos cos++prop_trig_tan :: Backend c => Double -> c -> Property+prop_trig_tan = makePropDouble Q.tan tan++prop_exp :: Backend c => Double -> c -> Property+prop_exp = makePropDouble Q.exp exp++prop_log :: Backend c => Positive Double -> c -> Property+prop_log (Positive d) conn = makePropDouble Q.log log d conn++prop_sqrt :: Backend c => Positive Double -> c -> Property+prop_sqrt (Positive d) conn = makePropDouble Q.sqrt sqrt d conn++arc :: Double -> Bool+arc d = d >= -1 && d <= 1++prop_trig_asin :: Backend c => Double -> c -> Property+prop_trig_asin d conn = arc d ==> makePropDouble Q.asin asin d conn++prop_trig_acos :: Backend c => Double -> c -> Property+prop_trig_acos d conn = arc d ==> makePropDouble Q.acos acos d conn++prop_trig_atan :: Backend c => Double -> c -> Property+prop_trig_atan = makePropDouble Q.atan atan++prop_number :: Backend c => [Integer] -> c -> Property+prop_number = makePropEq (Q.map Q.snd . Q.number) (\xs -> map snd $ zip xs [1..])++prop_map_number :: Backend c => [[Integer]] -> c -> Property+prop_map_number = makePropEq (Q.map (Q.map Q.snd . Q.number))+ (map (\xs -> map snd $ zip xs [1..]))+++prop_map_trig_sin :: Backend c => [Double] -> c -> Property+prop_map_trig_sin = makePropDoubles (Q.map Q.sin) (map sin)++prop_map_trig_cos :: Backend c => [Double] -> c -> Property+prop_map_trig_cos = makePropDoubles (Q.map Q.cos) (map cos)++prop_map_trig_tan :: Backend c => [Double] -> c -> Property+prop_map_trig_tan = makePropDoubles (Q.map Q.tan) (map tan)++prop_map_trig_asin :: Backend c => [Double] -> c -> Property+prop_map_trig_asin ds conn = all arc ds+ ==>+ makePropDoubles (Q.map Q.asin) (map asin) ds conn++prop_map_trig_acos :: Backend c => [Double] -> c -> Property+prop_map_trig_acos ds conn = all arc ds+ ==>+ makePropDoubles (Q.map Q.acos) (map acos) ds conn++prop_map_trig_atan :: Backend c => [Double] -> c -> Property+prop_map_trig_atan = makePropDoubles (Q.map Q.atan) (map atan)++prop_map_exp :: Backend c => [Double] -> c -> Property+prop_map_exp = makePropDoubles (Q.map Q.exp) (map exp)++prop_map_log :: Backend c => [Positive Double] -> c -> Property+prop_map_log ds conn = noShrinking $+ makePropDoubles (Q.map Q.log) (map log) (map getPositive ds) conn++prop_map_sqrt :: Backend c => [Positive Double] -> c -> Property+prop_map_sqrt ds conn =+ makePropDoubles (Q.map Q.sqrt) (map sqrt) (map getPositive ds) conn++hnegative_sum :: Backend c => c -> Assertion+hnegative_sum conn = makeEqAssertion "hnegative_sum" (Q.sum (Q.toQ xs)) (sum xs) conn+ where+ xs :: [Integer]+ xs = [-1, -4, -5, 2]++hnegative_map_sum :: Backend c => c -> Assertion+hnegative_map_sum conn = makeEqAssertion "hnegative_map_sum"+ (Q.map Q.sum (Q.toQ xss))+ (map sum xss)+ conn+ where+ xss :: [[Integer]]+ xss = [[10, 20, 30], [-10, -20, -30], [], [0]]
+ src/Database/DSH/Tests/Common.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Helpers for the construction of DSH test cases.+module Database.DSH.Tests.Common+ ( makePropEq+ , makePropDouble+ , makePropDoubles+ , makeEqAssertion+ , testPropertyConn+ , uncurryQ+ , filterNullChar+ ) where++import qualified Data.Text as T+import qualified Data.Time.Calendar as C+import qualified Data.Decimal as D++import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.HUnit (Assertion, assertEqual)+import Test.QuickCheck+import Test.QuickCheck.Monadic+++import qualified Database.DSH as Q+import Database.DSH.Backend+import Database.DSH.Compiler++instance Arbitrary T.Text where+ arbitrary = fmap T.pack arbitrary++instance Arbitrary C.Day where+ arbitrary = C.ModifiedJulianDay <$> choose (25000, 80000)++instance Arbitrary D.Decimal where+ arbitrary = D.Decimal <$> choose (1,8) <*> choose (1,10^(6 :: Int))++uncurryQ :: (Q.QA a, Q.QA b) => (Q.Q a -> Q.Q b -> Q.Q c) -> Q.Q (a,b) -> Q.Q c+uncurryQ f = uncurry f . Q.view++filterNullChar :: T.Text -> T.Text+filterNullChar = T.filter (/= '\0')++eps :: Double+eps = 1.0E-3++-- | A simple property that should hold for a DSH query: Given any+-- input, its result should be the same as the corresponding native+-- Haskell code. 'The same' is defined by a predicate.+makeProp :: (Q.QA a, Q.QA b, Show a, Show b, Backend c)+ => (b -> b -> Bool)+ -> (Q.Q a -> Q.Q b)+ -> (a -> b)+ -> a+ -> c+ -> Property+makeProp eq f1 f2 arg conn = monadicIO $ do+ db <- run $ runQ conn $ f1 (Q.toQ arg)+ let hs = f2 arg+ assert $ db `eq` hs++-- | Compare query result and native result by equality.+makePropEq :: (Eq b, Q.QA a, Q.QA b, Show a, Show b, Backend c)+ => (Q.Q a -> Q.Q b)+ -> (a -> b)+ -> a+ -> c+ -> Property+makePropEq f1 f2 arg conn = makeProp (==) f1 f2 arg conn++-- | Compare the double query result and native result.+makePropDouble :: (Q.QA a, Show a, Backend c)+ => (Q.Q a -> Q.Q Double)+ -> (a -> Double)+ -> a+ -> c+ -> Property+makePropDouble f1 f2 arg conn = makeProp delta f1 f2 arg conn+ where+ delta a b = abs (a - b) < eps++makePropDoubles :: (Q.QA a, Show a, Backend c)+ => (Q.Q a -> Q.Q [Double])+ -> (a -> [Double])+ -> a+ -> c+ -> Property+makePropDoubles f1 f2 arg conn = makeProp deltaList f1 f2 arg conn+ where+ delta a b = abs (a - b) < eps+ deltaList as bs = and $ zipWith delta as bs++-- | Equality HUnit assertion+makeEqAssertion :: (Show a, Eq a, Q.QA a, Backend c)+ => String+ -> Q.Q a+ -> a+ -> c+ -> Assertion+makeEqAssertion msg q expRes conn = do+ actualRes <- runQ conn q+ assertEqual msg expRes actualRes++testPropertyConn :: (Show a, Arbitrary a, Backend c)+ => c -> TestName -> (a -> c -> Property) -> Test+testPropertyConn conn name t = testProperty name (\a -> t a conn)
+ src/Database/DSH/Tests/ComprehensionTests.hs view
@@ -0,0 +1,606 @@+-- | Tests on certain aspects of comprehension nesting.+module Database.DSH.Tests.ComprehensionTests+ ( tests_comprehensions+ , tests_lifted_joins+ , tests_join_hunit+ , tests_nest_head_hunit+ , tests_nest_guard_hunit+ ) where++import GHC.Exts++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertion)+import Test.QuickCheck++import Database.DSH.Backend+import Database.DSH.Tests.Common+import qualified Database.DSH.Tests.DSHComprehensions as C+++tests_comprehensions :: Backend c => c -> Test+tests_comprehensions conn = testGroup "Comprehensions"+ [ testProperty "cartprod" (\a -> prop_cartprod a conn)+ , testProperty "eqjoin" (\a -> prop_eqjoin a conn)+ , testProperty "eqjoinproj" (\a -> prop_eqjoinproj a conn)+ , testProperty "eqjoinpred" (\a -> prop_eqjoinpred a conn)+ , testProperty "eqjointuples" (\a -> prop_eqjointuples a conn)+ , testProperty "thetajoin_eq" (\a -> prop_thetajoin_eq a conn)+ , testProperty "thetajoin_neq" (\a -> prop_thetajoin_neq a conn)+ , testProperty "eqjoin3" (\a -> prop_eqjoin3 a conn)+ , testProperty "eqjoin_nested_left" (\a -> prop_eqjoin_nested_left a conn)+ , testProperty "eqjoin_nested_right" (\a -> prop_eqjoin_nested_right a conn)+ , testProperty "eqjoin_nested_both" (\a -> prop_eqjoin_nested_both a conn)+ , testProperty "nestjoin" (\a -> prop_nestjoin a conn)+ , testProperty "nestjoin3" (\a -> prop_nestjoin3 a conn)+ , testProperty "groupjoin_length" (\a -> prop_groupjoin_length a conn)+ , testProperty "groupjoin_sum" (\a -> prop_groupjoin_sum a conn)+ , testProperty "antijoin class12" (\a -> prop_aj_class12 a conn)+ , testProperty "antijoin class15" (\a -> prop_aj_class15 a conn)+ , testProperty "antijoin class16" (\a -> prop_aj_class16 a conn)+ , testProperty "backdep1" (\a -> prop_backdep a conn)+ , testProperty "backdep_filter" (\a -> prop_backdep_filter a conn)+ , testProperty "backdep2" (\a -> prop_backdep2 a conn)+ , testProperty "backdep3" (\a -> prop_backdep3 a conn)+ , testProperty "backdep4" (\a -> prop_backdep4 a conn)+ , testProperty "backdep5" (\a -> prop_backdep5 a conn)+ , testProperty "deep" (\a -> prop_deep_iter a conn)+ , testProperty "only tuple" (\a -> prop_only_tuple a conn)+ ]++tests_lifted_joins :: Backend c => c -> Test+tests_lifted_joins conn = testGroup "Lifted Joins"+ [ testProperty "lifted semijoin" (\a -> prop_liftsemijoin a conn)+ , testProperty "lifted antijoin" (\a -> prop_liftantijoin a conn)+ , testProperty "lifted thetajoin" (\a -> prop_liftthetajoin a conn)+ ]++tests_join_hunit :: Backend c => c -> Test+tests_join_hunit conn = testGroup "HUnit joins"+ [ testCase "heqjoin_nested1" (heqjoin_nested1 conn)+ , testCase "hsemijoin" (hsemijoin conn)+ , testCase "hsemijoin_range" (hsemijoin_range conn)+ , testCase "hsemijoin_quant" (hsemijoin_quant conn)+ , testCase "hsemijoin_not_null" (hsemijoin_not_null conn)+ , testCase "hantijoin" (hantijoin conn)+ , testCase "hantijoin_range" (hantijoin_range conn)+ , testCase "hantijoin_null" (hantijoin_null conn)+ , testCase "hantijoin_class12" (hantijoin_class12 conn)+ , testCase "hantijoin_class15" (hantijoin_class15 conn)+ , testCase "hantijoin_class16" (hantijoin_class16 conn)+ , testCase "hfrontguard" (hfrontguard conn)+ ]++tests_nest_head_hunit :: Backend c => c -> Test+tests_nest_head_hunit conn = testGroup "HUnit head nesting"+ [ testCase "hnj1" (hnj1 conn)+ , testCase "hnj2" (hnj2 conn)+ , testCase "hnj3" (hnj3 conn)+ , testCase "hnj4" (hnj4 conn)+ , testCase "hnj5" (hnj5 conn)+ , testCase "hnj6" (hnj6 conn)+ , testCase "hnj7" (hnj7 conn)+ , testCase "hnj8" (hnj8 conn)+ , testCase "hnj9" (hnj9 conn)+ , testCase "hnj10" (hnj10 conn)+ , testCase "hnj11" (hnj11 conn)+ , testCase "hnj12" (hnj12 conn)+ , testCase "hnp1" (hnp1 conn)+ , testCase "hnp2" (hnp2 conn)+ , testCase "hnp3" (hnp3 conn)+ , testCase "hnp4" (hnp4 conn)+ ]++tests_nest_guard_hunit :: Backend c => c -> Test+tests_nest_guard_hunit conn = testGroup "HUnit guard nesting"+ [ testCase "hnjg1" (hnjg1 conn)+ , testCase "hnjg2" (hnjg2 conn)+ , testCase "hnjg3" (hnjg3 conn)+ , testCase "hnjg4" (hnjg4 conn)+ , testCase "hnjg5" (hnjg5 conn)+ ]++---------------------------------------------------------------------------------+-- QuickCheck properties for comprehensions++prop_cartprod :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_cartprod = makePropEq C.cartprod cartprod_native+ where+ cartprod_native (xs, ys) = [ (x, y) | x <- xs, y <- ys]++prop_eqjoin :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_eqjoin = makePropEq C.eqjoin eqjoin_native+ where+ eqjoin_native (xs, ys) = [ (x, y) | x <- xs , y <- ys , x == y ]++prop_eqjoinproj :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_eqjoinproj = makePropEq C.eqjoinproj eqjoinproj_native+ where+ eqjoinproj_native (xs, ys) = [ (x, y) | x <- xs , y <- ys , (2 * x) == y ]++prop_eqjoinpred :: Backend c => (Integer, [Integer], [Integer]) -> c -> Property+prop_eqjoinpred = makePropEq C.eqjoinpred eqjoinpred_native+ where+ eqjoinpred_native (x', xs, ys) = [ (x, y) | x <- xs , y <- ys , x == y , x > x']++prop_eqjointuples :: Backend c => ([(Integer, Integer)], [(Integer, Integer)]) -> c -> Property+prop_eqjointuples = makePropEq C.eqjointuples eqjointuples_native+ where+ eqjointuples_native (xs, ys) = [ (x1 * x2, y1, y2)+ | (x1, x2) <- xs+ , (y1, y2) <- ys+ , x1 == y2+ ]++prop_thetajoin_eq :: Backend c => ([(Integer, Integer)], [(Integer, Integer)]) -> c -> Property+prop_thetajoin_eq = makePropEq 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 :: Backend c => ([(Integer, Integer)], [(Integer, Integer)]) -> c -> Property+prop_thetajoin_neq = makePropEq 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 :: Backend c => ([Integer], [Integer], [Integer]) -> c -> Property+prop_eqjoin3 = makePropEq 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 :: Backend c => ([(Integer, [Integer])], [Integer]) -> c -> Property+prop_eqjoin_nested_left = makePropEq 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 :: Backend c => ([Integer], [(Integer, [Integer])]) -> c -> Property+prop_eqjoin_nested_right = makePropEq 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 :: Backend c => ([(Integer, [Integer])], [(Integer, [Integer])]) -> c -> Property+prop_eqjoin_nested_both = makePropEq 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 :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_nestjoin = makePropEq C.nestjoin nestjoin_native+ where+ nestjoin_native (xs, ys) = [ (x, [ y | y <- ys, x == y ]) | x <- xs]++prop_nestjoin3 :: Backend c => ([Integer], [Integer], [Integer]) -> c -> Property+prop_nestjoin3 = makePropEq C.nestjoin3 nestjoin3_native+ where+ nestjoin3_native (njxs, njys, njzs) =+ [ [ [ (x,y,z) | z <- njzs, y == z ]+ | y <- njys+ , x == y+ ]+ | x <- njxs+ ]++prop_groupjoin_length :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_groupjoin_length = makePropEq C.groupjoin_length groupjoin_length_native+ where+ groupjoin_length_native (njxs, njys) =+ [ (x, fromIntegral $ length [ y | y <- njys, x == y ]) | x <- njxs ]++prop_groupjoin_sum :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_groupjoin_sum = makePropEq C.groupjoin_sum groupjoin_sum_native+ where+ groupjoin_sum_native (njxs, njys) =+ [ (x, fromIntegral $ sum [ 2 * y | y <- njys, x == y ]) | x <- njxs ]++prop_aj_class12 :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_aj_class12 = makePropEq 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 :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_aj_class15 = makePropEq C.aj_class15 aj_class15_native+ where+ aj_class15_native (ajxs, ajys) = [ x+ | x <- ajxs+ , and [ y `rem` 4 == 0 | y <- ajys, x < y ]+ ]++prop_aj_class16 :: Backend c => ([Integer], [Integer]) -> c -> Property+prop_aj_class16 = makePropEq 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 :: Backend c => [[Integer]] -> c -> Property+prop_backdep = makePropEq C.backdep backdep_native+ where+ backdep_native xss = [x | xs <- xss, x <- xs]++prop_backdep_filter :: Backend c => [[Integer]] -> c -> Property+prop_backdep_filter = makePropEq C.backdep_filter backdep_filter_native+ where+ backdep_filter_native xss = [x | xs <- xss, x <- xs, fromIntegral (length xs) > x]++prop_backdep2 :: Backend c => [[Integer]] -> c -> Property+prop_backdep2 = makePropEq C.backdep2 backdep2+ where+ backdep2 xss = [ [ x * 42 | x <- xs ] | xs <- xss ]++prop_backdep3 :: Backend c => [[Integer]] -> c -> Property+prop_backdep3 = makePropEq C.backdep3 backdep3+ where+ backdep3 xss = [ [ x + fromIntegral (length xs) | x <- xs ] | xs <- xss ]++prop_backdep4 :: Backend c => [[[Integer]]] -> c -> Property+prop_backdep4 = makePropEq C.backdep4 backdep4+ where+ backdep4 xsss = [ [ [ x + fromIntegral (length xs) + fromIntegral (length xss)+ | x <- xs+ ]+ | xs <- xss+ ]+ | xss <- xsss+ ]++prop_backdep5 :: Backend c => [[Integer]] -> c -> Property+prop_backdep5 = makePropEq C.backdep5 backdep5+ where+ backdep5 xss = [ [ x + fromIntegral (length xs)+ | x <- take (length xs - 3) xs ]+ | xs <- xss ]++--------------------------------------------------------------------------------+-- Tests for lifted join operators++prop_liftsemijoin :: Backend c => ([Positive Integer], [Integer]) -> c -> Property+prop_liftsemijoin (xs, ys) = makePropEq C.liftsemijoin liftsemijoin (xs', ys)+ where+ xs' = map getPositive xs++liftsemijoin :: ([Integer], [Integer]) -> [[Integer]]+liftsemijoin (xs, ys) =+ [ [ x | x <- g, x `elem` ys ]+ | g <- groupWith (`rem` 10) xs+ ]++prop_liftantijoin :: Backend c => ([Positive Integer], [Integer]) -> c -> Property+prop_liftantijoin (xs, ys) = makePropEq C.liftantijoin liftantijoin (xs', ys)+ where+ xs' = map getPositive xs++liftantijoin :: ([Integer], [Integer]) -> [[Integer]]+liftantijoin (xs, ys) =+ [ [ x | x <- g, x `notElem` ys ]+ | g <- groupWith (`rem` 10) xs+ ]++prop_liftthetajoin :: Backend c => ([Positive Integer], [Integer]) -> c -> Property+prop_liftthetajoin (xs, ys) = makePropEq C.liftthetajoin liftthetajoin (xs', ys)+ where+ xs' = map getPositive xs++liftthetajoin :: ([Integer], [Integer]) -> [[(Integer, Integer)]]+liftthetajoin (xs, ys) =+ [ [ (x, y) | x <- g, y <- ys, x < y ]+ | g <- groupWith (`rem` 10) xs+ ]++-----------------------------------------------------------------------+-- HUnit tests for comprehensions++heqjoin_nested1 :: Backend c => c -> 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 :: Backend c => c -> Assertion+hsemijoin = makeEqAssertion "hsemijoin" C.semijoin res+ where+ res = [2, 4, 6, 7]++hsemijoin_range :: Backend c => c -> Assertion+hsemijoin_range = makeEqAssertion "hsemijoin_range" C.semijoin_range res+ where+ res = [2, 4]++hsemijoin_not_null :: Backend c => c -> Assertion+hsemijoin_not_null = makeEqAssertion "hsemijoin_range" C.semijoin_not_null res+ where+ res = [2, 4, 6, 7]++hsemijoin_quant :: Backend c => c -> Assertion+hsemijoin_quant = makeEqAssertion "hsemijoin_quant" C.semijoin_quant res+ where+ res = [6,7]++hantijoin :: Backend c => c -> Assertion+hantijoin = makeEqAssertion "hantijoin" C.antijoin res+ where+ res = [1, 3, 5]++hantijoin_range :: Backend c => c -> Assertion+hantijoin_range = makeEqAssertion "hantijoin_range" C.antijoin_range res+ where+ res = [1, 3, 5, 6, 7]++hantijoin_null :: Backend c => c -> Assertion+hantijoin_null = makeEqAssertion "hantijoin_range" C.antijoin_null res+ where+ res = [1, 3, 5]++hantijoin_class12 :: Backend c => c -> Assertion+hantijoin_class12 = makeEqAssertion "hantijoin_class12" C.antijoin_class12 res+ where+ res = [6,7,8,9,10]++hantijoin_class15 :: Backend c => c -> Assertion+hantijoin_class15 = makeEqAssertion "hantijoin_class15" C.antijoin_class15 res+ where+ res = [5,6,7,8]++hantijoin_class16 :: Backend c => c -> Assertion+hantijoin_class16 = makeEqAssertion "hantijoin_class16" C.antijoin_class16 res+ where+ res = [4,5,6]++hfrontguard :: Backend c => c -> 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 :: Backend c => c -> Assertion+hnj1 = makeEqAssertion "hnj1" (C.nj1 njxs1 njys1) (nj1 njxs1 njys1)++hnj2 :: Backend c => c -> Assertion+hnj2 = makeEqAssertion "hnj2" (C.nj2 njxs1 njys1) (nj2 njxs1 njys1)++hnj3 :: Backend c => c -> Assertion+hnj3 = makeEqAssertion "hnj3" (C.nj3 njxs1 njys1) (nj3 njxs1 njys1)++hnj4 :: Backend c => c -> Assertion+hnj4 = makeEqAssertion "hnj4" (C.nj4 njxs1 njys1) (nj4 njxs1 njys1)++hnj5 :: Backend c => c -> Assertion+hnj5 = makeEqAssertion "hnj5" (C.nj5 njxs1 njys1) (nj5 njxs1 njys1)++hnj6 :: Backend c => c -> Assertion+hnj6 = makeEqAssertion "hnj6" (C.nj6 njxs1 njys1) (nj6 njxs1 njys1)++hnj7 :: Backend c => c -> Assertion+hnj7 = makeEqAssertion "hnj7" (C.nj7 njxs1 njys1) (nj7 njxs1 njys1)++hnj8 :: Backend c => c -> Assertion+hnj8 = makeEqAssertion "hnj8" (C.nj8 njxs1 njys1) (nj8 njxs1 njys1)++hnj9 :: Backend c => c -> Assertion+hnj9 = makeEqAssertion "hnj9" (C.nj9 njxs1 njys1) (nj9 njxs1 njys1)++hnj10 :: Backend c => c -> Assertion+hnj10 = makeEqAssertion "hnj10" (C.nj10 njxs1 njys1) (nj10 njxs1 njys1)++hnj11 :: Backend c => c -> 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 :: Backend c => c -> Assertion+hnj12 = makeEqAssertion "hnj12" (C.nj12 njxs2 njys2 njzs2) (nj12 njxs2 njys2 njzs2)++hnp1 :: Backend c => c -> Assertion+hnp1 = makeEqAssertion "hnp1" (C.np1 njxs1 njys1) (np1 njxs1 njys1)++hnp2 :: Backend c => c -> Assertion+hnp2 = makeEqAssertion "hnp2" (C.np2 njxs1 njys1) (np2 njxs1 njys1)++hnp3 :: Backend c => c -> Assertion+hnp3 = makeEqAssertion "hnp3" (C.np3 njxs1 njys1) (np3 njxs1 njys1)++hnp4 :: Backend c => c -> Assertion+hnp4 = makeEqAssertion "hnp4" (C.np4 njxs1 njys1) (np4 njxs1 njys1)++hnjg1 :: Backend c => c -> Assertion+hnjg1 = makeEqAssertion "hnjg1" (C.njg1 njgxs1 njgzs1) (njg1 njgxs1 njgzs1)++hnjg2 :: Backend c => c -> Assertion+hnjg2 = makeEqAssertion "hnjg2" (C.njg2 njgxs1 njgys1) (njg2 njgxs1 njgys1)++hnjg3 :: Backend c => c -> Assertion+hnjg3 = makeEqAssertion "hnjg3" (C.njg3 njgxs1 njgys1 njgzs1) (njg3 njgxs1 njgys1 njgzs1)++hnjg4 :: Backend c => c -> Assertion+hnjg4 = makeEqAssertion "hnjg4" (C.njg4 njgxs1 njgys1 njgzs1) (njg4 njgxs1 njgys1 njgzs1)++hnjg5 :: Backend c => c -> 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 :: Backend c => ([Integer], [Integer], [Integer], [Integer], [Integer]) -> c -> Property+prop_deep_iter = makePropEq 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+ ]++-- | Test non-lifted tuple construction with a singleton extracted+-- from a nested list.+prop_only_tuple :: Backend c+ => (Integer, NonEmptyList Integer, [Integer])+ -> c+ -> Property+prop_only_tuple (x, ys, zs) c =+ makePropEq C.only_tuple only_tuple (x, getNonEmpty ys, zs) c++only_tuple :: (Integer, [Integer], [Integer]) -> (Integer, (Integer, [Integer]))+only_tuple (x, ys, zs) =+ pair x (head [ (y, [ z | z <- zs, x == y ]) | y <- ys ])
+ src/Database/DSH/Tests/DSHComprehensions.hs view
@@ -0,0 +1,415 @@+{-# 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 Database.DSH.Tests.DSHComprehensions where++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+ ]++groupjoin_length :: Q ([Integer], [Integer]) -> Q [(Integer, Integer)]+groupjoin_length (view -> (xs, ys)) =+ [ tup2 x (length [ y | y <- ys, x == y ]) | x <- xs ]++groupjoin_sum :: Q ([Integer], [Integer]) -> Q [(Integer, Integer)]+groupjoin_sum (view -> (xs, ys)) =+ [ tup2 x (sum [ 2 * y | y <- ys, x == y ]) | x <- xs ]++--------------------------------------------------------------------------------+-- Comprehensions for lifted join tests++liftsemijoin :: Q ([Integer], [Integer]) -> Q [[Integer]]+liftsemijoin (view -> (xs, ys)) =+ [ [ x | x <- g, x `elem` ys ]+ | g <- groupWith (`rem` 10) xs+ ]++liftantijoin :: Q ([Integer], [Integer]) -> Q [[Integer]]+liftantijoin (view -> (xs, ys)) =+ [ [ x | x <- g, x `notElem` ys ]+ | g <- groupWith (`rem` 10) xs+ ]++liftthetajoin :: Q ([Integer], [Integer]) -> Q [[(Integer, Integer)]]+liftthetajoin (view -> (xs, ys)) =+ [ [ pair x y | x <- g, y <- ys, x < y ]+ | g <- groupWith (`rem` 10) 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 `rem` 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 `rem` 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+ ]++only_tuple :: Q (Integer, [Integer], [Integer]) -> Q (Integer, (Integer, [Integer]))+only_tuple (view -> (x, ys, zs)) =+ pair x (head [ pair y [ z | z <- zs, x == y ] | y <- ys ])
+ src/Database/DSH/Tests/LawTests.hs view
@@ -0,0 +1,49 @@+module Database.DSH.Tests.LawTests+ ( tests_laws+ ) where++++import Test.Framework (Test, testGroup)+import Test.QuickCheck+import Test.QuickCheck.Monadic++import qualified Database.DSH as Q+import Database.DSH.Backend+import Database.DSH.Compiler+import Database.DSH.Tests.Common++tests_laws :: Backend c => c -> Test+tests_laws conn = testGroup "List Laws"+ [ testPropertyConn conn "takedrop" prop_takedrop+ , testPropertyConn conn "reverse id" prop_reverse_identity+ , testPropertyConn conn "reverse sort" prop_reverse_sort+ , testPropertyConn conn "reverse sort tuple" prop_reverse_sort_tuple+ ]++--------------------------------------------------------------------------------+-- Common list laws++prop_takedrop :: Backend c => (Integer, [Integer]) -> c -> Property+prop_takedrop (i, xs) conn = monadicIO $ do+ let q = Q.take (Q.toQ i) (Q.toQ xs) Q.++ Q.drop (Q.toQ i) (Q.toQ xs)+ res <- run $ runQ conn q+ assert $ res == xs++prop_reverse_identity :: Backend c => [Integer] -> c -> Property+prop_reverse_identity xs conn = monadicIO $ do+ let q = Q.reverse $ Q.reverse (Q.toQ xs)+ res <- run $ runQ conn q+ assert $ res == xs++prop_reverse_sort :: Backend c => OrderedList Integer -> c -> Property+prop_reverse_sort (Ordered xs) conn = monadicIO $ do+ let q = Q.sortWith id $ Q.reverse (Q.toQ xs)+ res <- run $ runQ conn q+ assert $ res == xs++prop_reverse_sort_tuple :: Backend c => OrderedList (Integer, Integer) -> c -> Property+prop_reverse_sort_tuple (Ordered xs) conn = monadicIO $ do+ let q = Q.sortWith id $ Q.reverse (Q.toQ xs)+ res <- run $ runQ conn q+ assert $ res == xs
src/Database/DSH/Tools/VLDotGen.hs view
@@ -1,30 +1,32 @@ module Main where -import System.IO-import System.Exit-import System.Environment-import System.Console.GetOpt+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO -import Data.ByteString.Lazy.Char8 (pack)- -import Data.Maybe+import Data.Aeson+import Data.ByteString.Lazy.Char8 (pack)+import qualified Data.IntMap as M+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+import Database.Algebra.Dag++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"]@@ -37,19 +39,19 @@ "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" + "Infer properties and display them" , Option "h" ["help"] (NoArg- (\_ -> do + (\_ -> do prg <- getProgName hPutStrLn stderr (usageInfo prg options) exitWith ExitSuccess)) "Show help" ]- + {- propertyTags :: [AlgNode] -> NodeMap X100Algebra -> NodeMap [Tag] -> NodeMap [Tag]-propertyTags rs nm tags = +propertyTags rs nm tags = let dag = normalizePlan $ mkDag nm rs topsorted = topsort dag bu = inferBottomUpProperties topsorted dag@@ -60,24 +62,24 @@ propsRendered = M.map render $ M.unionWith ($$) tagDocs $ M.unionWith ($$) buDocs tdDocs in M.map (\s -> [s]) propsRendered -}- + main :: IO () main = do- args <- getArgs + 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++ let dag = fromJust $ decode $ pack plan++ let rs' = fromMaybe (rootNodes dag) mRootNodes {- tags' = if printProperties then propertyTags rs' m tags else tags -}- - putStr $ renderVLDot tags rs' m++ putStr $ renderVLDot M.empty rs' (nodeMap dag)
− src/Database/DSH/Translate/Algebra2Query.hs
@@ -1,42 +0,0 @@-{-# 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
@@ -14,10 +14,9 @@ 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.Impossible+ import Database.DSH.Common.Type import Database.DSH.Common.Lang @@ -29,60 +28,51 @@ -------------------------------------------------------------------------------- -- Conversion of primitive operators- + prim1 :: Type -> CL.Prim1 -> CL.Expr -> NameEnv NKL.Expr prim1 t p e = mkApp t <$> expr e- where - mkApp = + where+ mkApp = case p of CL.Singleton -> mkPrim1 NKL.Singleton- CL.Length -> mkPrim1 NKL.Length - CL.Concat -> mkPrim1 NKL.Concat + CL.Only -> mkPrim1 NKL.Only+ 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.Sum -> mkPrim1 NKL.Sum+ CL.Avg -> mkPrim1 NKL.Avg+ CL.Minimum -> mkPrim1 NKL.Minimum+ CL.Maximum -> mkPrim1 NKL.Maximum+ CL.Reverse -> mkPrim1 NKL.Reverse+ CL.And -> mkPrim1 NKL.And+ CL.Or -> mkPrim1 NKL.Or+ CL.Nub -> mkPrim1 NKL.Nub+ CL.Number -> mkPrim1 NKL.Number CL.TupElem i -> mkPrim1 $ NKL.TupElem i+ CL.Sort -> mkPrim1 NKL.Sort+ CL.Group -> mkPrim1 NKL.Group CL.Guard -> $impossible- - nklNull _ ne = NKL.BinOp boolT ++ nklNull _ ne = NKL.BinOp PBoolT (SBRelOp Eq)- (NKL.Const intT $ IntV 0)- (NKL.AppE1 intT NKL.Length ne)- + (NKL.Const PIntT $ ScalarV $ IntV 0)+ (NKL.AppE1 PIntT 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.++-- | Transform applications of binary primitives. 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@@ -90,8 +80,6 @@ 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@@ -109,7 +97,7 @@ -- 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@@ -134,24 +122,23 @@ type NameEnv a = Reader [Ident] a -freshName :: NameEnv Ident-freshName = do- boundNames <- ask- return $ tryName 0 boundNames-+-- | 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- tryName :: Int -> [Ident] -> Ident- tryName i ns = if mkName i `elem` ns- then tryName (i + 1) ns- else mkName i+ checkCollision i ns = if mkName i `elem` ns+ then checkCollision (i + 1) ns+ else mkName i - mkName i = "f" ++ show i+ mkName i = "v" ++ 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.Table t s schema) = return $ NKL.Table t s schema 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@@ -169,7 +156,7 @@ -- 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@@ -179,7 +166,7 @@ -- 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])@@ -188,25 +175,14 @@ -- (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@@ -219,28 +195,28 @@ -- 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+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. +-- | 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 + 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@@ -251,9 +227,9 @@ let qs' = fmap substGenExpr qs tupConst = P.sng $ mkTuple $ fmap mkVar ((outerName, baseExpr) N.<| qs')- mkVar (x, xs) = NKL.Var (elemT $ typeOf xs) x + mkVar (x, xs) = NKL.Var (elemT $ typeOf xs) x gensExpr = nestQualifiers tupConst (N.toList qs')- compTy = (listT $ typeOf tupConst)+ compTy = (ListT $ typeOf tupConst) return $ P.concat $ NKL.Iterator compTy gensExpr outerName baseExpr -- | Replace every occurence of a generator variable with the@@ -279,7 +255,9 @@ qs' <- local (n :) (genExprs $ q :| qs) return $ (n, e') N.<| qs' --- | Desugar a list of qualifiers.+-- | Desugar a list of qualifiers. The second parameter 'baseSrc' is+-- the (filtered) cartesian product of all generators that have been+-- desugared so far. 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.@@ -288,10 +266,10 @@ genNames = map fst gens nklGens <- genExprs ((x, xs) :| gens) baseSrc' <- desugarGens env baseSrc nklGens- let env' = addGensToEnv nklGens env + 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@@ -299,14 +277,19 @@ 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)+ let elemTy = elemT $ typeOf baseSrc+ filterExpr = substTupleAccesses visibleNames (filterName, elemTy) env p' + predTy = ListT (PPairT elemTy PBoolT)+ predPairConst = P.tuple [NKL.Var elemTy filterName, filterExpr]+ -- Construct an iterator that pairs every input element with+ -- the corresponding result of the predicate:+ --+ -- [ (x, p x) | x <- xs ]+ predIter = NKL.Iterator predTy predPairConst filterName baseSrc+ filterSrc = P.restrict predIter+ desugarQualsRec env filterSrc qs desugarQualsRec env baseSrc [] = return (env, baseSrc)@@ -359,13 +342,13 @@ -- 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- ++ 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 = +desugarComprehensions e = #ifdef DEBUGCOMP trace (debugPrint eo) eo @@ -380,4 +363,3 @@ #else runReader (expr e) [] #endif-
src/Database/DSH/Translate/FKL2VL.hs view
@@ -3,8 +3,6 @@ module Database.DSH.Translate.FKL2VL (specializeVectorOps) where -import Control.Applicative hiding (Const)- import Control.Monad.Reader import Database.Algebra.Dag.Build@@ -13,14 +11,12 @@ import Database.DSH.Common.Lang import Database.DSH.Common.QueryPlan import Database.DSH.Common.Type+import Database.DSH.Common.Vector import Database.DSH.FKL.Lang-import Database.DSH.Impossible-import Database.DSH.VL.Render.JSON ()-import Database.DSH.VL.Vector+import Database.DSH.Common.Impossible 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+import qualified Database.DSH.VL.Vectorize as V -------------------------------------------------------------------------------- -- Extend the DAG builder monad with an environment for compiled VL@@ -49,18 +45,17 @@ Let _ n e1 e -> do e1' <- fkl2VL e1 local (bind n e1') $ fkl2VL e- Table _ n cs hs -> lift $ V.dbTable n cs hs+ Table _ n schema -> do+ lift $ V.dbTable n schema 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+ s1 <- fkl2VL e1+ s2 <- fkl2VL e2+ lift $ V.binOp o s1 s2 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+ s1 <- fkl2VL e1+ s2 <- fkl2VL e2+ lift $ V.binOpL o s1 s2 UnOp _ o NotLifted e1 -> do SShape p1 lyt <- fkl2VL e1 p <- lift $ vlUnExpr o p1@@ -108,17 +103,15 @@ papp1 t f Lifted = case f of Singleton -> V.singletonL+ Only -> V.onlyL 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+ Sort -> V.sortL+ Group -> V.groupL+ Restrict -> V.restrictL And -> V.aggrL VL.AggrAll Or -> V.aggrL VL.AggrAny Minimum -> V.aggrL VL.AggrMin@@ -130,17 +123,15 @@ papp1 t f NotLifted = case f of Singleton -> V.singleton+ Only -> V.only Length -> V.length_- Reshape n -> V.reshape n- Transpose -> V.transpose Number -> V.number+ Sort -> V.sort+ Group -> V.group+ Restrict -> V.restrict 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@@ -153,11 +144,7 @@ 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@@ -169,11 +156,7 @@ 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@@ -191,29 +174,26 @@ where traverseShape :: Shape VLDVec -> Build VL.VL (Shape VLDVec) traverseShape (VShape (VLDVec q) lyt) =- insertProj lyt q VL.Project VLDVec VShape+ insertProj lyt q VShape traverseShape (SShape (VLDVec q) lyt) =- insertProj lyt q VL.Project VLDVec SShape+ insertProj lyt q SShape traverseLayout :: (Layout VLDVec) -> Build VL.VL (Layout VLDVec)- traverseLayout (LCol c) = return $ LCol c+ traverseLayout LCol = return LCol traverseLayout (LTuple lyts) = LTuple <$> mapM traverseLayout lyts traverseLayout (LNest (VLDVec q) lyt) =- insertProj lyt q VL.Project VLDVec LNest+ insertProj lyt q 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+ insertProj :: Layout VLDVec -- ^ The node's layout+ -> Alg.AlgNode -- ^ The top node to consider+ -> (VLDVec -> (Layout VLDVec) -> t) -- ^ Layout/Shape constructor+ -> Build VL.VL t+ insertProj lyt q describe = do let width = columnsInLayout lyt cols = [1 .. width]- qp <- insert $ Alg.UnOp (project $ map VL.Column cols) q+ qp <- insert $ Alg.UnOp (VL.Project $ map VL.Column cols) q lyt' <- traverseLayout lyt- return $ describe (vector qp) lyt'+ return $ describe (VLDVec qp) lyt' -- | Compile a FKL expression into a query plan of vector operators (VL) specializeVectorOps :: FExpr -> QueryPlan VL.VL VLDVec
src/Database/DSH/Translate/Frontend2CL.hs view
@@ -5,91 +5,55 @@ -- | 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+module Database.DSH.Translate.Frontend2CL+ ( toComprehensions+ ) where -import Control.Applicative-import Control.Monad import Control.Monad.State-+import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as N+import qualified Data.Text as T 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)+import qualified Database.DSH.CL.Lang as CL+import qualified Database.DSH.CL.Primitives as CP+import Database.DSH.Common.Impossible+import qualified Database.DSH.Common.Lang as L+import qualified Database.DSH.Common.Type as Ty+import Database.DSH.Frontend.Builtins+import Database.DSH.Frontend.Internals+import Database.DSH.Frontend.TupleTypes --- | 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+-- In the state, we store a counter for fresh variable names.+type CompileState = Integer --- | 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+-- | The Compile monad provides fresh variable names.+type Compile = State CompileState -- | Provide a fresh identifier name during compilation freshVar :: Compile Integer freshVar = do- (i, m, f) <- get- put (i + 1, m, f)+ i <- get+ put $ i + 1 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+-- comprehension-based language.+toComprehensions :: Exp a -> CL.Expr+toComprehensions q = runCompile (translate q) -- | 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)+runCompile :: Compile a -> a+runCompile ma = evalState ma 1 -lamBody :: forall a b.(Reify a, Reify b) => (Exp a -> Exp b) -> Compile (L.Ident, Exp b)+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))@@ -101,10 +65,12 @@ in translateTupleConst tc translate UnitE = return $ CP.unit translate (BoolE b) = return $ CP.bool b-translate (CharE c) = return $ CP.string [c]+translate (CharE c) = return $ CP.string $ T.singleton 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 (TextE t) = return $ CP.string t+translate (DecimalE d) = return $ CP.decimal d+translate (DayE d) = return $ CP.day d translate (VarE i) = do let ty = reify (undefined :: a) return $ CP.var (translateType ty) (prefixVar i)@@ -117,88 +83,84 @@ -- 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+translate (TableE (TableDB tableName colNames 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)+ let colNames' = fmap L.ColName colNames+ let bty = translateType ty - -- 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+ return $ CP.table bty tableName (schema tableName colNames' bty hints) - 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+translate (AppE f args) = translateApp f args - let cols = zipWith matchTypes tableDescr ts+schema :: String -> N.NonEmpty L.ColName -> Ty.Type -> TableHints -> L.BaseTableSchema+schema tableName cols ty hints =+ L.BaseTableSchema { L.tableCols = colTys+ , L.tableKeys = keys (keysHint hints)+ , L.tableNonEmpty = ne $ nonEmptyHint hints+ }+ where+ colTys :: NonEmpty L.Column+ colTys = case Ty.elemT ty of+ Ty.TupleT ts@(_:_) | length ts == N.length cols ->+ case mapM Ty.scalarType ts of+ Just (st : sts) -> N.zip cols (st :| sts)+ _ -> error errMsgScalar+ (Ty.ScalarT st) | N.length cols == 1 ->+ N.zip cols (st :| [])+ _ ->+ error errMsgLen - return $ CP.table (translateType ty) tableName cols (compileHints hints)+ errMsgLen = printf "Type for table %s does not match column specification"+ tableName -translate (AppE f args) = translateApp f args+ errMsgScalar = printf "Non-scalar types in table %s" tableName -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 ]+ keys :: N.NonEmpty Key -> N.NonEmpty L.Key+ keys = fmap (\(Key k) -> L.Key $ fmap L.ColName k) 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 :: (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 :: (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 :: Type a -> Ty.Type+translateType UnitT = Ty.PUnitT+translateType BoolT = Ty.PBoolT+translateType CharT = Ty.PStringT+translateType IntegerT = Ty.PIntT+translateType DoubleT = Ty.PDoubleT+translateType DecimalT = Ty.PDecimalT+translateType TextT = Ty.PStringT+translateType DayT = Ty.PDateT+translateType (ListT t) = Ty.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.+translateType (ArrowT _ _) = $impossible 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+ Cond -> translateApp3 CP.cond args -- Builtin functions with arity two Add -> translateApp2 CP.add args@@ -206,11 +168,10 @@ 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 -> + Map -> case args of TupleConstE (Tuple2E (LamE lam) xs) -> do xs' <- translate xs@@ -220,7 +181,7 @@ _ -> $impossible -- Map to a comprehension and concat- ConcatMap -> + ConcatMap -> case args of TupleConstE (Tuple2E (LamE lam) xs) -> do xs' <- translate xs@@ -228,45 +189,47 @@ bodyExp' <- translate bodyExp return $ CP.concat $ CP.singleGenComp bodyExp' boundVar xs' _ -> $impossible- + -- Map to a first-order combinator 'sort'- SortWith -> + -- sortWith (\x -> f x) xs => sort [ (x, f x) | x <- xs ]+ SortWith -> case args of TupleConstE (Tuple2E (LamE lam) xs) -> do- xs' <- translate xs- (boundVar, bodyExp) <- lamBody lam- bodyExp' <- translate bodyExp- genName <- prefixVar <$> freshVar+ xs' <- translate xs+ -- Get a FOAS representation of the lambda+ (boundName, sortExp) <- lamBody lam+ sortExp' <- translate sortExp - let genVar = CL.Var (T.typeOf xs') genName- ss = CP.singleGenComp bodyExp' boundVar genVar - return $ CP.let_ genName xs' (CP.sort genVar ss)+ let boundVar = CL.Var (Ty.elemT $ Ty.typeOf xs') boundName++ return $ CP.sort $ CP.singleGenComp (CP.pair boundVar sortExp') boundName xs' _ -> $impossible -- Map to a comprehension with a guard- Filter -> + 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'+ let xt = Ty.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 (\x -> f x) xs => group [ (x, f x) | x <- xs ] GroupWithKey -> case args of TupleConstE (Tuple2E (LamE lam) xs) -> do- xs' <- translate xs- (boundVar, bodyExp) <- lamBody lam- bodyExp' <- translate bodyExp- genName <- prefixVar <$> freshVar+ xs' <- translate xs+ (boundName, groupExp) <- lamBody lam+ groupExp' <- translate groupExp - let genVar = CL.Var (T.typeOf xs') genName- ss = CP.singleGenComp bodyExp' boundVar genVar - return $ CP.let_ genName xs' (CP.group genVar ss)+ let boundVar = CL.Var (Ty.elemT $ Ty.typeOf xs') boundName++ return $ CP.group $ CP.singleGenComp (CP.pair boundVar groupExp') boundName xs'+ _ -> $impossible Append -> translateApp2 CP.append args@@ -280,40 +243,44 @@ Gte -> translateApp2 CP.gte args Gt -> translateApp2 CP.gt args Like -> translateApp2 CP.like args+ AddDays -> translateApp2 CP.addDays args+ SubDays -> translateApp2 CP.subDays args+ DiffDays -> translateApp2 CP.diffDays 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+ Only -> translateApp1 CP.only args+ SubString s e -> translateApp1 (CP.substring s e) args+ IntegerToDouble -> translateApp1 CP.castDouble args+ IntegerToDecimal -> translateApp1 CP.castDecimal 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+ DayDay -> translateApp1 CP.dateDay args+ DayMonth -> translateApp1 CP.dateMonth args+ DayYear -> translateApp1 CP.dateYear args+ Fst -> translateApp1 CP.fst args+ Snd -> translateApp1 CP.snd 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+ Nub -> translateApp1 CP.nub args+ Guard -> translateApp1 CP.guard args+ TupElem te -> do+ e' <- translate args+ let tupAcc = $(mkTupElemCompile 16) te+ return $ tupAcc e'
src/Database/DSH/Translate/NKL2FKL.hs view
@@ -1,15 +1,18 @@ {-# LANGUAGE TemplateHaskell #-} -- | The Flattening Transformation-module Database.DSH.Translate.NKL2FKL (flatTransform) where+module Database.DSH.Translate.NKL2FKL+ ( flatTransform+ , normalizeLifted+ , liftOperators+ ) 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.Impossible import Database.DSH.Common.Lang import Database.DSH.Common.Nat import Database.DSH.Common.Type@@ -20,16 +23,21 @@ -- | Transform an expression in the Nested Kernel Language into its -- equivalent Flat Kernel Language expression by means of the--- flattening transformation.+-- flattening transformation. Apply standard optimization rewrites. flatTransform :: N.Expr -> F.FExpr-flatTransform expr = optimizeFKL "FKL" - $ normalize - $ optimizeFKL "FKL Intermediate" +flatTransform expr = optimizeNormFKL+ $ normalizeLifted+ $ optimizeFKL $ runFlat initEnv (flatten expr) -------------------------------------------------------------------------------- -- The Flattening Transformation +-- | The first stage of the flattening transformation: replace+-- iterators by lifted operators.+liftOperators :: N.Expr -> F.LExpr+liftOperators expr = runFlat initEnv (flatten expr)+ -------------------------------------------------------------------------------- -- Translation of built-in combinators. Combinators are lifted -- according to the iteration depth at which they are encountered.@@ -38,34 +46,27 @@ prim1 p = case p of N.Singleton -> P.sng+ N.Only -> P.only 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+ N.Sort -> P.sort+ N.Group -> P.group+ N.Restrict -> P.restrict 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@@ -105,7 +106,7 @@ -- 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 +descendEnv x env = env { inScope = x : inScope env , frameDepth = Succ $ frameDepth env } @@ -121,11 +122,11 @@ mkRestrictLet [] = $impossible mkRestrictLet (e : []) = P.let_ (fst e)- (P.restrict (envVar e) bs d1)+ (P.restrict (P.tuple [envVar e, bs] (Succ d1)) d1) branchExpr- mkRestrictLet (e : (e2 : es)) = + mkRestrictLet (e : (e2 : es)) = P.let_ (fst e)- (P.restrict (envVar e) bs d1)+ (P.restrict (P.tuple [envVar e, bs] (Succ d1)) d1) (mkRestrictLet (e2 : es)) -- | Lift all names bound in the environment: the value is replicated@@ -151,7 +152,7 @@ -- | 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.Table t n schema) = return $ F.Table t n schema 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@@ -165,7 +166,7 @@ -- 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) @@ -176,7 +177,7 @@ -- | 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.Table t n schema) = P.broadcast (F.Table t n schema) (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@@ -184,15 +185,15 @@ 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 +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'.@@ -205,8 +206,8 @@ -- Construct the restricted environments in which the THEN and -- ELSE branches are evaluated.- let notL xs = P.un boolT (SUBoolOp Not) xs (Succ d1) - + let notL xs = P.un PBoolT (SUBoolOp Not) xs (Succ d1)+ thenRes = restrictEnv env d1 bs thenExpr elseRes = restrictEnv env d1 (notL bs) elseExpr@@ -218,7 +219,7 @@ d <- frameDepthM env <- asks inScope let ctx' = (x, liftTypeN (Succ d) (typeOf xs))- headExpr <- local (descendEnv ctx') $ deepFlatten ctx' h + headExpr <- local (descendEnv ctx') $ deepFlatten ctx' h xs' <- deepFlatten ctx xs @@ -240,8 +241,8 @@ put $ i + 1 return $ "nf" ++ show i -normalize :: F.LExpr -> F.FExpr-normalize e = evalState (normLifting e) 0+normalizeLifted :: F.LExpr -> F.FExpr+normalizeLifted e = evalState (normLifting e) 0 implementBroadcast :: F.BroadcastExt -> NormFlat F.FExpr implementBroadcast (F.Broadcast d _ e1 e2) = do@@ -257,7 +258,7 @@ -- 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.Table t n schema) = return $ F.Table t n schema 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@@ -274,7 +275,7 @@ 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) = +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@@ -285,7 +286,7 @@ 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) = +normLifting (F.BinOp t op l e1 e2) = case l of F.LiftedN Zero -> F.BinOp t op F.NotLifted <$> normLifting e1@@ -301,7 +302,7 @@ 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) = +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@@ -312,7 +313,7 @@ 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) = +normLifting (F.PApp2 t p l e1 e2) = case l of F.LiftedN Zero -> F.PApp2 t p F.NotLifted <$> normLifting e1@@ -328,7 +329,7 @@ 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) = +normLifting (F.PApp3 t p l e1 e2 e3) = case l of F.LiftedN Zero -> F.PApp3 t p F.NotLifted <$> normLifting e1@@ -344,7 +345,7 @@ 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') + 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
@@ -2,98 +2,114 @@ {-# LANGUAGE FlexibleContexts #-} module Database.DSH.Translate.VL2Algebra- ( implementVectorOpsPF+ ( VecBuild+ , runVecBuild+ , vl2Algebra ) where import qualified Data.IntMap as IM import Data.List import qualified Data.Map as M-import Data.Maybe+import qualified Data.Traversable as T -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.Impossible import Database.DSH.Common.QueryPlan import Database.DSH.Translate.FKL2VL ()-import Database.DSH.VL.Vector+import Database.DSH.Common.Vector import qualified Database.DSH.VL.Lang as V import Database.DSH.VL.VectorAlgebra-import Database.DSH.VL.VectorAlgebra.TA () +-- FIXME the vector types d r k f s are determined by the algebra a.+-- The only type variable necessary should be a.+type Cache d r k f s = M.Map AlgNode (Res d r k f s)+ -- | 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)+type VecBuild a d r k f s = StateT (Cache d r k f s) (B.Build a) -runVecBuild :: VectorAlgebra v a => VecBuild a v r -> (D.AlgebraDag a, r, NodeMap [Tag])+runVecBuild :: VectorAlgebra a+ => VecBuild a (DVec a) (RVec a) (KVec a) (FVec a) (SVec a) 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+data Res d r k f s+ = RRVec r+ | RKVec k+ | RFVec f+ | RSVec s+ | RDVec d+ | RLPair (Res d r k f s) (Res d r k f s)+ | RTriple (Res d r k f s) (Res d r k f s) (Res d r k f s)+ deriving Show -fromDict :: VectorAlgebra v a => AlgNode -> VecBuild a v (Maybe (Res v))+fromDict :: VectorAlgebra a => AlgNode -> VecBuild a d r k f s (Maybe (Res d r k f s)) fromDict n = do dict <- get return $ M.lookup n dict -insertTranslation :: VectorAlgebra v a => AlgNode -> Res v -> VecBuild a v ()+insertTranslation :: VectorAlgebra a => AlgNode -> Res d r k f s -> VecBuild a d r k f s () 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"+--------------------------------------------------------------------------------+-- Wrappers and unwrappers for vector references -fromRVec :: RVec -> Res v-fromRVec (RVec r) = Rename r+fromRVec :: r -> Res d r k f s+fromRVec p = RRVec p -toRVec :: Res v -> RVec-toRVec (Rename r) = RVec r-toRVec _ = error "toRVec: Not a rename vector"+fromKVec :: k -> Res d r k f s+fromKVec r = RKVec r -fromDVec :: v -> Res v+fromDVec :: d -> Res d r k f s fromDVec v = RDVec v -toDVec :: Res v -> v+fromFVec :: f -> Res d r k f s+fromFVec v = RFVec v++fromSVec :: s -> Res d r k f s+fromSVec v = RSVec v++toDVec :: Res d r k f s -> d 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+toRVec :: Res d r k f s -> r+toRVec (RRVec p) = p+toRVec _ = error "toRVec: Not a replication vector" -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+toKVec :: Res d r k f s -> k+toKVec (RKVec r) = r+toKVec _ = error "toKVec: Not a rekeying vector" -translate :: VectorAlgebra v a => NodeMap V.VL -> AlgNode -> VecBuild a v (Res v)+toFVec :: Res d r k f s -> f+toFVec (RFVec r) = r+toFVec _ = error "toFVec: Not a filtering vector"++toSVec :: Res d r k f s -> s+toSVec (RSVec r) = r+toSVec _ = error "toSVec: Not a filtering vector"++--------------------------------------------------------------------------------++-- | Refresh vectors in a shape from the cache.+refreshShape :: VectorAlgebra a => Shape VLDVec -> VecBuild a d r k f s (Shape d)+refreshShape shape = T.mapM refreshVec shape+ where+ refreshVec (VLDVec n) = do+ mv <- fromDict n+ case mv of+ Just v -> return $ toDVec v+ Nothing -> $impossible++translate :: VectorAlgebra a+ => NodeMap V.VL+ -> AlgNode+ -> VecBuild a (DVec a) (RVec a) (KVec a) (FVec a) (SVec a) (Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)) translate vlNodes n = do r <- fromDict n @@ -130,7 +146,10 @@ 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 :: VectorAlgebra a+ => NodeMap V.VL+ -> Shape VLDVec+ -> VecBuild a (DVec a) (RVec a) (KVec a) (FVec a) (SVec a) (Shape (DVec a)) vl2Algebra vlNodes plan = do mapM_ (translate vlNodes) roots @@ -139,158 +158,165 @@ roots :: [AlgNode] roots = shapeNodes plan -translateTerOp :: VectorAlgebra v a => V.TerOp -> Res v -> Res v -> Res v -> B.Build a (Res v)+translateTerOp :: VectorAlgebra a+ => V.TerOp+ -> Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)+ -> Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)+ -> Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)+ -> B.Build a (Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)) 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)+ return $ RTriple (fromDVec d) (fromKVec r1) (fromKVec r2) -translateBinOp :: VectorAlgebra v a => V.BinOp -> Res v -> Res v -> B.Build a (Res v)+translateBinOp :: VectorAlgebra a+ => V.BinOp+ -> Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)+ -> Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)+ -> B.Build a (Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)) 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)+ return $ RLPair (fromDVec v) (fromRVec p)+ V.DistSng -> do+ (v, p) <- vecDistSng (toDVec c1) (toDVec c2)+ return $ RLPair (fromDVec v) (fromRVec p) - V.PropFilter -> do- (v, r) <- vecPropFilter (toRVec c1) (toDVec c2)- return $ RLPair (fromDVec v) (fromRVec r)+ V.AppKey -> do+ (v, k) <- vecAppKey (toKVec c1) (toDVec c2)+ return $ RLPair (fromDVec v) (fromKVec k) - V.PropReorder -> do- (v, p) <- vecPropReorder (toPVec c1) (toDVec c2)- return $ RLPair (fromDVec v) (fromPVec p)+ V.AppSort -> do+ (v, s) <- vecAppSort (toSVec c1) (toDVec c2)+ return $ RLPair (fromDVec v) (fromSVec s) - V.UnboxNested -> do- (v, r) <- vecUnboxNested (toRVec c1) (toDVec c2)+ V.AppRep -> do+ (v, r) <- vecAppRep (toRVec c1) (toDVec c2) return $ RLPair (fromDVec v) (fromRVec r) - V.UnboxScalar -> RDVec <$> vecUnboxScalar (toDVec c1) (toDVec c2)+ V.AppFilter -> do+ (v, f) <- vecAppFilter (toFVec c1) (toDVec c2)+ return $ RLPair (fromDVec v) (fromFVec f) + V.UnboxSng -> do+ (v, k) <- vecUnboxSng (toDVec c1) (toDVec c2)+ return $ RLPair (fromDVec v) (fromKVec k)+ V.Append -> do (v, r1, r2) <- vecAppend (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromRVec r1) (fromRVec r2)+ return $ RTriple (fromDVec v) (fromKVec r1) (fromKVec r2) V.AppendS -> do (v, r1, r2) <- vecAppendS (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromRVec r1) (fromRVec r2)+ return $ RTriple (fromDVec v) (fromKVec r1) (fromKVec 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 -> do+ (v, f1, f2) <- vecZip (toDVec c1) (toDVec c2)+ return $ RTriple (fromDVec v) (fromKVec f1) (fromKVec f2) - V.Zip -> fromDVec <$> vecZip (toDVec c1) (toDVec c2)- V.Align -> fromDVec <$> vecZip (toDVec c1) (toDVec c2)+ V.Align -> fromDVec <$> vecAlign (toDVec c1) (toDVec c2) V.ZipS -> do (v, r1 ,r2) <- vecZipS (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromRVec r1) (fromRVec r2)+ return $ RTriple (fromDVec v) (fromKVec r1) (fromKVec r2) V.CartProduct -> do (v, p1, p2) <- vecCartProduct (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2)+ return $ RTriple (fromDVec v) (fromRVec p1) (fromRVec p2) V.CartProductS -> do (v, p1, p2) <- vecCartProductS (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2)+ return $ RTriple (fromDVec v) (fromRVec p1) (fromRVec p2) V.NestProductS -> do- (v, p2) <- vecNestProductS (toDVec c1) (toDVec c2)- return $ RLPair (fromDVec v) (fromPVec p2)+ (v, p1, p2) <- vecNestProductS (toDVec c1) (toDVec c2)+ return $ RTriple (fromDVec v) (fromRVec p1) (fromRVec p2) V.ThetaJoin p -> do (v, p1, p2) <- vecThetaJoin p (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2)+ return $ RTriple (fromDVec v) (fromRVec p1) (fromRVec p2) V.NestProduct -> do (v, p1, p2) <- vecNestProduct (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2)+ return $ RTriple (fromDVec v) (fromRVec p1) (fromRVec p2) V.NestJoin p -> do (v, p1, p2) <- vecNestJoin p (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2)+ return $ RTriple (fromDVec v) (fromRVec p1) (fromRVec p2) V.ThetaJoinS p -> do (v, p1, p2) <- vecThetaJoinS p (toDVec c1) (toDVec c2)- return $ RTriple (fromDVec v) (fromPVec p1) (fromPVec p2)+ return $ RTriple (fromDVec v) (fromRVec p1) (fromRVec p2) V.NestJoinS p -> do- (v, p2) <- vecNestJoinS p (toDVec c1) (toDVec c2)- return $ RLPair (fromDVec v) (fromPVec p2)+ (v, p1, p2) <- vecNestJoinS p (toDVec c1) (toDVec c2)+ return $ RTriple (fromDVec v) (fromRVec p1) (fromRVec p2) + V.GroupJoin (p, a) -> fromDVec <$> vecGroupJoin p a (toDVec c1) (toDVec c2)+ V.SemiJoin p -> do (v, r) <- vecSemiJoin p (toDVec c1) (toDVec c2)- return $ RLPair (fromDVec v) (fromRVec r)+ return $ RLPair (fromDVec v) (fromFVec r) V.SemiJoinS p -> do (v, r) <- vecSemiJoinS p (toDVec c1) (toDVec c2)- return $ RLPair (fromDVec v) (fromRVec r)+ return $ RLPair (fromDVec v) (fromFVec r) V.AntiJoin p -> do (v, r) <- vecAntiJoin p (toDVec c1) (toDVec c2)- return $ RLPair (fromDVec v) (fromRVec r)+ return $ RLPair (fromDVec v) (fromFVec 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)+ return $ RLPair (fromDVec v) (fromFVec r) -translateUnOp :: VectorAlgebra v a => V.UnOp -> Res v -> B.Build a (Res v)+translateUnOp :: VectorAlgebra a+ => V.UnOp+ -> Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)+ -> B.Build a (Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)) translateUnOp unop c = case unop of- V.AggrNonEmptyS a -> fromDVec <$> vecAggrNonEmptyS a (toDVec c)+ V.Unique -> fromDVec <$> vecUnique (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.UnboxKey -> fromKVec <$> vecUnboxKey (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.Segment -> do+ (d1, d2) <- vecSegment (toDVec c)+ return $ RLPair (fromDVec d1) (fromDVec d2) V.Select e -> do (d, r) <- vecSelect e (toDVec c)- return $ RLPair (fromDVec d) (fromRVec r)+ return $ RLPair (fromDVec d) (fromFVec r)+ V.Sort es -> do+ (d, p) <- vecSort es (toDVec c)+ return $ RLPair (fromDVec d) (fromSVec p) V.SortS es -> do (d, p) <- vecSortS es (toDVec c)- return $ RLPair (fromDVec d) (fromPVec p)+ return $ RLPair (fromDVec d) (fromSVec p)+ V.Group es -> do+ (qo, qi, p) <- vecGroup es (toDVec c)+ return $ RTriple (fromDVec qo) (fromDVec qi) (fromSVec p) V.GroupS es -> do (qo, qi, p) <- vecGroupS es (toDVec c)- return $ RTriple (fromDVec qo) (fromDVec qi) (fromPVec p)+ return $ RTriple (fromDVec qo) (fromDVec qi) (fromSVec p) V.Project cols -> fromDVec <$> vecProject cols (toDVec c) V.Reverse -> do (d, p) <- vecReverse (toDVec c)- return $ RLPair (fromDVec d) (fromPVec p)+ return $ RLPair (fromDVec d) (fromSVec 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)+ return $ RLPair (fromDVec d) (fromSVec p) 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)+ V.Nest -> do+ (qo, qi) <- vecNest (toDVec c) return $ RLPair (fromDVec qo) (fromDVec qi)+ V.R1 -> case c of (RLPair c1 _) -> return c1 (RTriple c1 _ _) -> return c1@@ -303,78 +329,8 @@ (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 :: VectorAlgebra a+ => V.NullOp+ -> B.Build a (Res (DVec a) (RVec a) (KVec a) (FVec a) (SVec a)) 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+translateNullary (V.TableRef (n, schema)) = fromDVec <$> vecTableRef n schema
+ src/Database/DSH/VL.hs view
@@ -0,0 +1,11 @@+module Database.DSH.VL+ ( module Database.DSH.VL.Lang+ , module Database.DSH.VL.VectorAlgebra+ , module Database.DSH.Translate.VL2Algebra+ ) where++import Database.DSH.Translate.VL2Algebra (VecBuild, runVecBuild, vl2Algebra)+import Database.DSH.VL.Lang (VL, AggrFun (..), DBCol,+ Expr (..), FrameSpec (..),+ WinFun (..), shiftExprCols)+import Database.DSH.VL.VectorAlgebra
src/Database/DSH/VL/Lang.hs view
@@ -1,44 +1,28 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeSynonymInstances #-} module Database.DSH.VL.Lang where -import qualified Data.List.NonEmpty as N import Data.Aeson.TH+import qualified Data.List.NonEmpty as N -import Database.Algebra.Dag (Operator, opChildren, replaceOpChild)+import Database.Algebra.Dag (Operator, opChildren,+ replaceOpChild) import Database.Algebra.Dag.Common -import qualified Database.DSH.Common.Lang as L+import qualified Database.DSH.Common.Lang as L+import Database.DSH.Common.Type -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+ | Constant L.ScalarVal | If Expr Expr Expr deriving (Eq, Ord, Show) @@ -46,13 +30,12 @@ -- | 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 (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 (If c t e) = If (shiftExprCols o c)+ (shiftExprCols o t) (shiftExprCols o e) data AggrFun = AggrSum ScalarType Expr@@ -94,16 +77,15 @@ -- Vector Language operators. Documentation can be found in module -- VectorPrimitives. -data NullOp = SingletonDescr- | Lit (L.Emptiness, [ScalarType], [[VLVal]])- | TableRef (String, [VLColumn], L.TableHints)+data NullOp = Lit (L.Emptiness, [ScalarType], [[L.ScalarVal]])+ | TableRef (String, L.BaseTableSchema) deriving (Eq, Ord, Show) $(deriveJSON defaultOptions ''NullOp) -data UnOp = UnboxRename+data UnOp = UnboxKey | Segment- | Unsegment+ | Nest | R1 | R2@@ -114,42 +96,35 @@ | GroupAggr ([Expr], N.NonEmpty AggrFun) | Aggr AggrFun- | AggrNonEmpty (N.NonEmpty AggrFun)- | AggrNonEmptyS (N.NonEmpty AggrFun)- | Number | NumberS+ | Unique | UniqueS | Reverse | ReverseS- | SelectPos1 (L.ScalarBinOp, Int)- | SelectPos1S (L.ScalarBinOp, Int)+ | Sort [Expr] | SortS [Expr]+ | Group [Expr] | GroupS [Expr] | WinFun (WinFun, FrameSpec)-- | Reshape Integer- | ReshapeS Integer- | Transpose deriving (Eq, Ord, Show) $(deriveJSON defaultOptions ''UnOp) data BinOp = DistLift+ | DistSng - | PropRename- | PropFilter- | PropReorder- - | UnboxNested- | UnboxScalar+ | AppKey+ | AppSort+ | AppFilter+ | AppRep++ | UnboxSng | Align | AggrS AggrFun | Append | AppendS- | SelectPos L.ScalarBinOp- | SelectPosS L.ScalarBinOp | Zip | ZipS | CartProduct@@ -162,9 +137,9 @@ | AntiJoinS (L.JoinPredicate Expr) | NestJoin (L.JoinPredicate Expr) | NestJoinS (L.JoinPredicate Expr)+ | GroupJoin (L.JoinPredicate Expr, AggrFun) | NestProduct | NestProductS- | TransposeS deriving (Eq, Ord, Show) $(deriveJSON defaultOptions ''BinOp)@@ -186,9 +161,9 @@ 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+ 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/Opt/OptimizeVL.hs view
@@ -0,0 +1,56 @@+module Database.DSH.VL.Opt.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.Common.Vector++import Database.DSH.Common.Opt+import Database.DSH.VL.Opt.Rewrite.Expressions+import Database.DSH.VL.Opt.Rewrite.PruneEmpty+import Database.DSH.VL.Opt.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/VL/Opt/Properties/BottomUp.hs view
@@ -0,0 +1,91 @@+module Database.DSH.VL.Opt.Properties.BottomUp where++import Text.Printf++import Database.Algebra.Dag+import Database.Algebra.Dag.Common++import Database.DSH.VL.Lang+import Database.DSH.Common.Opt++import Database.DSH.VL.Opt.Properties.Card+import Database.DSH.VL.Opt.Properties.Const+import Database.DSH.VL.Opt.Properties.Empty+import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.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+ opConst <- inferConstVecNullOp op+ opType <- inferVectorTypeNullOp op+ opCard <- inferCardOneNullOp op+ return $ BUProps { emptyProp = opEmpty+ , constProp = opConst+ , card1Prop = opCard+ , vectorTypeProp = opType }++inferUnOp :: UnOp -> BottomUpProps -> Either String BottomUpProps+inferUnOp op cProps = do+ opEmpty <- inferEmptyUnOp (emptyProp cProps) op+ opType <- inferVectorTypeUnOp (vectorTypeProp cProps) op+ opConst <- inferConstVecUnOp (constProp cProps) op+ opCard <- inferCardOneUnOp (card1Prop cProps) op+ return $ BUProps { emptyProp = opEmpty+ , 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+ 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+ , 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+ 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+ , constProp = opConst+ , card1Prop = opCard+ , vectorTypeProp = opType }++inferBottomUpProperties :: AlgebraDag VL -> NodeMap BottomUpProps+inferBottomUpProperties dag = inferBottomUpGeneral inferWorker dag
+ src/Database/DSH/VL/Opt/Properties/Card.hs view
@@ -0,0 +1,93 @@+-- FIXME complete rules+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.VL.Opt.Properties.Card where++import Database.DSH.VL.Lang++import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.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+ 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+ Unique -> Right c+ UniqueS -> Right c+ Aggr _ -> Right $ VProp True+ WinFun _ -> Right c+ UnboxKey -> Right c+ Segment -> unp c >>= (\uc -> return $ VPropPair uc uc)+ Nest -> unp c >>= (\uc -> return $ VPropPair True uc)+ Project _ -> Right c+ Reverse -> unp c >>= (\uc -> return $ VPropPair uc uc)+ ReverseS -> unp c >>= (\uc -> return $ VPropPair uc uc)+ Select _ -> Right $ VPropPair False False+ Sort _ -> unp c >>= (\uc -> return $ VPropPair uc uc)+ SortS _ -> unp c >>= (\uc -> return $ VPropPair uc uc)+ Group _ -> unp c >>= (\uc -> return $ VPropTriple uc 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++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+ DistSng -> unp c2 >>= (\uc -> return $ VPropPair uc uc)+ AppKey -> return $ VPropPair False False+ AppSort -> return $ VPropPair False False+ AppFilter -> return $ VPropPair False False+ AppRep -> return $ VPropPair False False+ UnboxSng -> return $ VPropPair False 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+ Zip -> (||) <$> unp c1 <*> unp c2 >>= \p -> return $ VPropTriple p p p+ 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+ GroupJoin _ -> return $ VProp False+ SemiJoin _ -> return $ VPropPair False False+ SemiJoinS _ -> return $ VPropPair False False+ AntiJoin _ -> return $ VPropPair False False+ AntiJoinS _ -> 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/VL/Opt/Properties/Common.hs view
@@ -0,0 +1,19 @@+module Database.DSH.VL.Opt.Properties.Common where++import Control.Monad++import Database.DSH.VL.Opt.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/VL/Opt/Properties/Const.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.VL.Opt.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.Common.Impossible+import Database.DSH.VL.Opt.Properties.Common+import Database.DSH.VL.Opt.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 [ConstPayload]+fromDBV (ConstVec pl) = Right pl+fromDBV CNA = Left $ "Properties.Const.fromDBV"++--------------------------------------------------------------------------------+-- Evaluation of constant expressions++-- FIXME finish remaining cases, only integer numeric operations so+-- far.++mkEnv :: [ConstPayload] -> [(DBCol, ScalarVal)]+mkEnv constCols = mapMaybe envEntry $ zip [1..] constCols+ where+ envEntry :: (DBCol, ConstPayload) -> Maybe (DBCol, ScalarVal)+ 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 -> ScalarVal -> ScalarVal -> Maybe ScalarVal+evalBinOp (SBNumOp nop) (IntV i1) (IntV i2) = return $ IntV $ evalNumOp nop i1 i2+evalBinOp (SBNumOp _) (DoubleV _) (DoubleV _) = mzero+evalBinOp (SBNumOp _) (DecimalV _) (DecimalV _) = mzero++evalBinOp (SBRelOp _) (IntV _) (IntV _) = mzero+evalBinOp (SBRelOp _) (DoubleV _) (DoubleV _) = mzero+evalBinOp (SBRelOp _) (DecimalV _) (DecimalV _) = mzero+evalBinOp (SBRelOp _) (StringV _) (StringV _) = mzero+evalBinOp (SBRelOp _) (DateV _) (DateV _) = mzero++evalBinOp (SBBoolOp _) (BoolV _) (BoolV _) = mzero+evalBinOp (SBStringOp _) (StringV _) (StringV _) = mzero+evalBinOp (SBDateOp _) (IntV _) (DateV _) = mzero+evalBinOp (SBDateOp _) (DateV _) (DateV _) = mzero+evalBinOp _ _ _ = $impossible++evalUnOp :: ScalarUnOp -> ScalarVal -> Maybe ScalarVal+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, ScalarVal)]+ env = mkEnv constCols++ eval :: Expr -> Maybe ScalarVal+ 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+ BoolV True -> eval t+ BoolV False -> eval e+ _ -> mzero++--------------------------------------------------------------------------------+-- Stuff++inferConstVecNullOp :: NullOp -> Either String (VectorProp ConstVec)+inferConstVecNullOp op =+ case op of+ -- 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 $ ConstVec $ map (const NonConstPL) colTypes+ else return $ VProp $ ConstVec constCols+ where constCols = map toConstPayload $ drop 2 $ transpose rows++ toConstPayload col@(c : _) = if all (c ==) col+ then ConstPL c+ else NonConstPL+ toConstPayload [] = NonConstPL++ TableRef (_, schema) -> return $ VProp+ $ ConstVec+ $ map (const NonConstPL)+ $ N.toList+ $ tableCols schema++inferConstVecUnOp :: (VectorProp ConstVec) -> UnOp -> Either String (VectorProp ConstVec)+inferConstVecUnOp c op =+ case op of+ Nest -> do+ cols <- unp c >>= fromDBV+ return $ VPropPair (ConstVec []) (ConstVec cols)++ WinFun _ -> do+ cols <- unp c >>= fromDBV+ return $ VProp $ ConstVec (cols ++ [NonConstPL])++ UniqueS -> return c+ Unique -> return c++ Aggr _ -> do+ return $ VProp $ ConstVec [NonConstPL]++ UnboxKey -> return $ VProp CNA++ Segment -> do+ constCols <- unp c >>= fromDBV+ return $ VPropPair (ConstVec []) (ConstVec constCols)++ Reverse -> do+ cs <- unp c >>= fromDBV+ return $ VPropPair (ConstVec cs) CNA++ ReverseS -> do+ cs <- unp c >>= fromDBV+ return $ VPropPair (ConstVec cs) CNA++ Project projExprs -> do+ constCols <- unp c >>= fromDBV+ constCols' <- mapM (constExpr constCols) projExprs+ return $ VProp $ ConstVec constCols'++ Select _ -> do+ cols <- unp c >>= fromDBV+ return $ VPropPair (ConstVec cols) CNA++ GroupAggr (g, as) -> do+ let pl = [ NonConstPL | _ <- [1 .. (length g) + (N.length as)] ]+ return $ VProp $ ConstVec pl++ Number -> do+ cols <- unp c >>= fromDBV+ return $ VProp $ ConstVec (cols ++ [NonConstPL])++ NumberS -> do+ cols <- unp c >>= fromDBV+ return $ VProp $ ConstVec (cols ++ [NonConstPL])++ Sort _ -> do+ cs <- unp c >>= fromDBV+ return $ VPropPair (ConstVec cs) CNA++ SortS _ -> do+ cs <- unp c >>= fromDBV+ return $ VPropPair (ConstVec cs) CNA++ Group es -> do+ cs <- unp c >>= fromDBV+ return $ VPropTriple (ConstVec (map (const NonConstPL) es))+ (ConstVec (map (const NonConstPL) cs))+ CNA++ GroupS es -> do+ cs <- unp c >>= fromDBV+ return $ VPropTriple (ConstVec (map (const NonConstPL) es))+ (ConstVec (map (const NonConstPL) cs))+ CNA++ 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 $ ConstVec [NonConstPL]++ DistLift -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ return $ VPropPair (ConstVec (cols1 ++ cols2)) CNA++ DistSng -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ return $ VPropPair (ConstVec (cols1 ++ cols2)) CNA++ AppKey -> do+ cols <- unp c2 >>= fromDBV+ return $ VPropPair (ConstVec cols) CNA++ AppSort -> do+ cols <- unp c2 >>= fromDBV+ return $ VPropPair (ConstVec cols) CNA++ AppFilter -> do+ cols <- unp c2 >>= fromDBV+ return $ VPropPair (ConstVec cols) CNA++ AppRep -> do+ cols <- unp c2 >>= fromDBV+ return $ VPropPair (ConstVec cols) CNA++ UnboxSng -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ return $ VPropPair (ConstVec (cols1 ++ cols2)) CNA++ Append -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV++ let constCols = map sameConst $ zip cols1 cols2++ sameConst ((ConstPL v1), (ConstPL v2)) | v1 == v2 = ConstPL v1+ sameConst (_, _) = NonConstPL++ return $ VPropTriple (ConstVec constCols) CNA CNA++ AppendS -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV++ let constCols = map sameConst $ zip cols1 cols2++ sameConst ((ConstPL v1), (ConstPL v2)) | v1 == v2 = ConstPL v1+ sameConst (_, _) = NonConstPL++ return $ VPropTriple (ConstVec constCols) CNA CNA++ Align -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let cols = cols1 ++ cols2+ return $ VProp $ ConstVec cols++ Zip -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let cols = cols1 ++ cols2+ return $ VPropTriple (ConstVec cols) CNA CNA++ ZipS -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let cols = cols1 ++ cols2+ return $ VPropTriple (ConstVec cols) CNA CNA++ CartProduct -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let constCols = cols1 ++ cols2+ return $ VPropTriple (ConstVec constCols) CNA CNA++ CartProductS -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let constCols = cols1 ++ cols2+ return $ VPropTriple (ConstVec constCols) CNA CNA++ NestProductS -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let constCols = cols1 ++ cols2+ return $ VPropTriple (ConstVec constCols) CNA CNA++ NestJoin _ -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let constCols = cols1 ++ cols2+ return $ VPropTriple (ConstVec constCols) CNA CNA++ GroupJoin _ -> do+ cols1 <- unp c1 >>= fromDBV+ let constCols = cols1 ++ [NonConstPL]+ return $ VProp (ConstVec constCols)++ NestProduct -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let constCols = cols1 ++ cols2+ return $ VPropTriple (ConstVec constCols) CNA CNA++ ThetaJoin _ -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV++ let constCols = cols1 ++ cols2++ return $ VPropTriple (ConstVec constCols) CNA CNA++ ThetaJoinS _ -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let constCols = cols1 ++ cols2+ return $ VPropTriple (ConstVec constCols) CNA CNA++ NestJoinS _ -> do+ cols1 <- unp c1 >>= fromDBV+ cols2 <- unp c2 >>= fromDBV+ let constCols = cols1 ++ cols2+ return $ VPropTriple (ConstVec constCols) CNA CNA++ SemiJoin _ -> do+ cols1 <- unp c1 >>= fromDBV+ return $ VPropPair (ConstVec cols1) CNA++ SemiJoinS _ -> do+ cols1 <- unp c1 >>= fromDBV+ return $ VPropPair (ConstVec cols1) CNA++ AntiJoin _ -> do+ cols1 <- unp c1 >>= fromDBV+ return $ VPropPair (ConstVec cols1) CNA++ AntiJoinS _ -> do+ cols1 <- unp c1 >>= fromDBV+ return $ VPropPair (ConstVec cols1) CNA++inferConstVecTerOp :: VectorProp ConstVec+ -> VectorProp ConstVec+ -> VectorProp ConstVec+ -> TerOp+ -> Either String (VectorProp ConstVec)+inferConstVecTerOp _c1 c2 c3 op =+ case op of+ Combine -> do+ 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++ return $ VPropTriple (ConstVec constCols) CNA CNA+
+ src/Database/DSH/VL/Opt/Properties/Empty.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.VL.Opt.Properties.Empty where++import Control.Monad++import Database.DSH.VL.Lang++import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.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+ 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+ Nest -> VPropPair False <$> unp e+ WinFun _ -> Right e+ Unique -> Right e+ UniqueS -> Right e+ Aggr _ -> Right $ VProp False+ UnboxKey -> Right e+ Segment -> let ue = unp e in liftM2 VPropPair ue ue+ 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+ Sort _ -> let ue = unp e in liftM2 VPropPair ue ue+ SortS _ -> let ue = unp e in liftM2 VPropPair ue ue+ Group _ -> let ue = unp e in liftM3 VPropTriple ue ue ue+ GroupS _ -> 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++ 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))+ DistSng -> mapUnp e1 e2 (\_ ue2 -> VPropPair ue2 ue2)+ UnboxSng -> mapUnp e1 e2 (\ue1 ue2 -> VPropPair (ue1 || ue2) (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+ Zip -> mapUnp e1 e2 (\ue1 ue2 -> let p = ue1 || ue2 in VPropTriple p p p)+ 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))+ GroupJoin _ -> mapUnp e1 e2 (\ue1 ue2 -> VProp (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)+ AppKey -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropPair p p) (ue1 || ue2))+ AppFilter -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropPair p p) (ue1 || ue2))+ AppSort -> mapUnp e1 e2 (\ue1 ue2 -> (\p -> VPropPair p p) (ue1 || ue2))+ AppRep -> 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/VL/Opt/Properties/ReqColumns.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.VL.Opt.Properties.ReqColumns where++import qualified Data.List as L+import qualified Data.List.NonEmpty as N++import Database.DSH.Common.Lang+import Database.DSH.VL.Opt.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 (VTDataVec 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+ VTDataVec w1 <- fromProp $ vectorTypeProp childBUProps1+ VTDataVec w2 <- fromProp $ vectorTypeProp childBUProps2++ let cols = maybe [] id ownReqCols++ -- If both inputs are VTDataVecs, 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++ Nest -> do+ cols <- snd <$> fromPropPair ownReqColumns+ childReqColumns ∪ VProp cols++ WinFun (wfun, _) -> do+ cs <- (VProp $ Just $ winReqCols wfun)+ ∪+ childReqColumns+ cs ∪ ownReqColumns+ UniqueS -> ownReqColumns ∪ childReqColumns+ Unique -> ownReqColumns ∪ childReqColumns++ Aggr aggrFun -> (VProp $ Just $ aggrReqCols aggrFun)+ ∪+ childReqColumns++ UnboxKey -> none ∪ childReqColumns++ Segment -> do+ cols <- snd <$> fromPropPair ownReqColumns+ VProp cols ∪ 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+ VTDataVec w <- fromProp $ vectorTypeProp childBUProps+ Just cols <- fromProp ownReqColumns+ let cols' = filter (/= w) cols+ VProp (Just cols') ∪ childReqColumns+ NumberS -> do+ VTDataVec 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++ -- 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))++ Sort exprs -> do+ cols <- fst <$> fromPropPair ownReqColumns+ ownReqColumns' <- VProp cols+ ∪+ (VProp $ Just $ L.nub $ concatMap reqExprCols exprs)+ childReqColumns ∪ ownReqColumns'+ SortS exprs -> do+ cols <- fst <$> fromPropPair ownReqColumns+ ownReqColumns' <- VProp cols+ ∪+ (VProp $ Just $ L.nub $ concatMap reqExprCols exprs)+ childReqColumns ∪ ownReqColumns'++ Group exprs -> do+ (_, colsi, _) <- fromPropTriple ownReqColumns+ ownReqColumns' <- VProp colsi+ ∪+ (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'++ 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)++ DistSng -> do+ cols <- fst <$> fromPropPair ownReqColumns+ (ownLeft, ownRight) <- partitionCols childBUProps1 childBUProps2 cols+ (,) <$> (childReqColumns1 ∪ ownLeft) <*> (childReqColumns2 ∪ ownRight)++ AppRep -> do+ cols <- fst <$> fromPropPair ownReqColumns+ fromRight <- childReqColumns2 ∪ VProp cols+ return (na, fromRight)++ AppFilter -> do+ cols <- fst <$> fromPropPair ownReqColumns+ fromRight <- childReqColumns2 ∪ VProp cols+ return (na, fromRight)++ AppSort -> do+ cols <- fst <$> fromPropPair ownReqColumns+ fromRight <- childReqColumns2 ∪ VProp cols+ return (na, fromRight)++ AppKey -> 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)++ 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, _, _) <- fromPropTriple 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')++ UnboxSng -> do+ cols1 <- fst <$> fromPropPair 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, _, _) <- fromPropTriple ownReqColumns+ (leftReqCols, rightReqCols) <- partitionCols childBUProps1 childBUProps2 cols1+ leftReqCols' <- (VProp $ Just $ reqLeftPredCols p) ∪ leftReqCols+ rightReqCols' <- (VProp $ Just $ reqRightPredCols p) ∪ rightReqCols+ (,) <$> (childReqColumns1 ∪ leftReqCols') <*> (childReqColumns2 ∪ rightReqCols')++ GroupJoin (p, a) -> do+ cols <- fromProp ownReqColumns+ let acols = Just $ aggrReqCols a+ -- columns from the left required by the predicate+ let plcols = VProp $ Just $ reqLeftPredCols p+ -- columns from the right required by the predicate+ let prcols = VProp $ Just $ reqRightPredCols p+ -- Columns from left and right sides that are required for+ -- the aggregate.+ (alcols, arcols) <- partitionCols childBUProps1 childBUProps2 acols+ -- columns from the left side that are required downstream+ lcols <- fst <$> partitionCols childBUProps1 childBUProps2 cols+ -- left: plcols, alcols, lcols+ -- right: prcols, arcols+ leftReqCols <- plcols ∪ alcols+ leftReqCols' <- leftReqCols ∪ lcols+ rightReqCols <- prcols ∪ arcols+ return (leftReqCols', 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)++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/VL/Opt/Properties/TopDown.hs view
@@ -0,0 +1,196 @@+module Database.DSH.VL.Opt.Properties.TopDown+ ( inferTopDownProperties+ ) where++import Control.Monad.State+import Text.Printf++import qualified Data.IntMap as M++import qualified Database.Algebra.Dag as D+import Database.Algebra.Dag.Common++import Database.DSH.Common.Opt+import Database.DSH.VL.Lang+import Database.DSH.VL.Opt.Properties.ReqColumns+import Database.DSH.VL.Opt.Properties.Types++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+ Nest -> vPropPairSeed+ WinFun _ -> vPropSeed+ Reverse -> vPropPairSeed+ ReverseS -> vPropPairSeed+ UniqueS -> vPropSeed+ UnboxKey -> vPropSeed+ Unique -> vPropSeed+ Segment -> vPropPairSeed+ Select _ -> vPropPairSeed+ Sort _ -> vPropPairSeed+ SortS _ -> vPropPairSeed+ Group _ -> vPropTripleSeed+ GroupS _ -> vPropTripleSeed+ Project _ -> vPropSeed+ Aggr _ -> vPropSeed+ GroupAggr (_, _) -> vPropSeed+ R1 -> vPropSeed+ R2 -> vPropSeed+ R3 -> vPropSeed+ Number -> vPropSeed+ NumberS -> vPropSeed++seed (BinOp op _ _) =+ case op of+ Append -> vPropTripleSeed+ AppendS -> vPropTripleSeed+ ZipS -> vPropTripleSeed+ DistLift -> vPropPairSeed+ DistSng -> vPropPairSeed+ AppKey -> vPropPairSeed+ AppSort -> vPropPairSeed+ AppFilter -> vPropPairSeed+ AppRep -> vPropPairSeed+ UnboxSng -> vPropPairSeed+ 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 _ -> vPropTripleSeed+ GroupJoin _ -> vPropSeed+ NestProductS -> vPropTripleSeed++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+ -> D.AlgebraDag VL+ -> AlgNode+ -> State InferenceState ()+inferChildProperties buPropMap d n = do+ ownProps <- lookupProps n+ case D.operator n d of+ NullaryOp _ -> return ()+ UnOp op c -> do+ cp <- lookupProps c+ let 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] -> D.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 $ D.nodeMap d)+ in error completeMsg+checkError _ _ _ (Right props) = props++-- | Infer properties during a top-down traversal.+inferTopDownProperties :: NodeMap BottomUpProps+ -> [AlgNode]+ -> D.AlgebraDag VL+ -> NodeMap TopDownProps+inferTopDownProperties buPropMap topOrderedNodes d = execState action initialMap+ where+ action = mapM_ (inferChildProperties buPropMap d) topOrderedNodes+ initialMap = M.map seed $ D.nodeMap d
+ src/Database/DSH/VL/Opt/Properties/Types.hs view
@@ -0,0 +1,94 @@+module Database.DSH.VL.Opt.Properties.Types where++import Prelude hiding ((<$>))+import Text.PrettyPrint.ANSI.Leijen++import Database.DSH.Common.Lang+import Database.DSH.Common.Pretty+import Database.DSH.VL.Lang++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 = VTDataVec Int+ | VTNA+ deriving Show++data Const = Const ScalarVal+ | NoConst+ deriving Show++data ConstPayload = ConstPL ScalarVal+ | NonConstPL+ deriving Show++data ConstVec = ConstVec [ConstPayload]+ | CNA+ deriving (Show)++data BottomUpProps = BUProps { emptyProp :: 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+ }++insertComma :: Doc -> Doc -> Doc+insertComma d1 d2 = d1 <> comma <+> d2++instance Pretty a => Pretty (VectorProp a) where+ pretty (VProp p) = pretty p+ pretty (VPropPair p1 p2) = parens $ (pretty p1) `insertComma` (pretty p2)+ pretty (VPropTriple p1 p2 p3) = parens $ (pretty p1) `insertComma` (pretty p2) `insertComma` (pretty p3)++bracketList :: (a -> Doc) -> [a] -> Doc+bracketList f = brackets . hsep . punctuate comma . map f++isConst :: (Int, ConstPayload) -> [(Int, ScalarVal)] -> [(Int, ScalarVal)]+isConst (_, NonConstPL) vals = vals+isConst (i, (ConstPL v)) vals = (i, v) : vals++renderPL :: Pretty a => (Int, a) -> Doc+renderPL (i, v) = int i <> colon <> pretty v++instance Pretty ConstVec where+ pretty (ConstVec ps) = bracketList id+ $ map renderPL+ $ foldr isConst []+ $ zip [1..] ps+ pretty CNA = text "NA"++instance Pretty VectorType where+ pretty = text . show++instance Pretty BottomUpProps where+ pretty p = text "empty:" <+> (pretty $ emptyProp p)+ <$> text "const:" <+> (pretty $ constProp p)+ <$> text "schema:" <+> (pretty $ vectorTypeProp p)++instance Pretty TopDownProps where+ pretty p = text "reqCols:" <+> (text $ show $ reqColumnsProp p)++-- | Rendering function for the bottom-up properties container.+renderBottomUpProps :: BottomUpProps -> [String]+renderBottomUpProps ps = [pp $ pretty ps]++renderTopDownProps :: TopDownProps -> [String]+renderTopDownProps ps = [pp $ pretty ps]++prettyerties :: Properties -> [String]+prettyerties ps = (renderBottomUpProps $ bu ps) ++ (renderTopDownProps $ td ps)
+ src/Database/DSH/VL/Opt/Properties/VectorType.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE TemplateHaskell #-}++-- FIXME introduce consistency checks for schema inference+module Database.DSH.VL.Opt.Properties.VectorType where++import Control.Monad+import qualified Data.List.NonEmpty as N++import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.Common.Lang++import Database.DSH.VL.Lang++{- Implement more checks: check the input types for correctness -}++vectorWidth :: VectorProp VectorType -> Int+vectorWidth (VProp (VTDataVec w)) = w+vectorWidth _ = error "vectorWidth: non-VTDataVec input"++inferVectorTypeNullOp :: NullOp -> Either String (VectorProp VectorType)+inferVectorTypeNullOp op =+ case op of+ Lit (_, t, _) -> Right $ VProp $ VTDataVec $ length t+ TableRef (_, schema) -> Right $ VProp $ VTDataVec $ N.length (tableCols schema)++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+ Nest -> do+ VTDataVec w <- unpack s+ return $ VPropPair (VTDataVec 0) (VTDataVec w)+ WinFun _ -> do+ VTDataVec w <- unpack s+ return $ VProp $ VTDataVec $ w + 1+ Unique -> VProp <$> unpack s+ UniqueS -> VProp <$> unpack s+ Aggr _ -> Right $ VProp $ VTDataVec 1+ UnboxKey -> Right $ VProp $ VTNA+ Segment -> VPropPair <$> pure (VTDataVec 0) <*> unpack s+ Reverse -> liftM2 VPropPair (unpack s) (Right VTNA)+ ReverseS -> liftM2 VPropPair (unpack s) (Right VTNA)+ 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 $ VTDataVec $ length valProjs++ Select _ -> VPropPair <$> unpack s <*> (Right VTNA)+ Sort _ -> liftM2 VPropPair (unpack s) (Right VTNA)+ SortS _ -> liftM2 VPropPair (unpack s) (Right VTNA)++ Group es ->+ case s of+ VProp t@(VTDataVec _) ->+ Right $ VPropTriple (VTDataVec $ length es) t VTNA+ _ ->+ Left "Input of Group is not a value vector"+ GroupS es ->+ case s of+ VProp t@(VTDataVec _) ->+ Right $ VPropTriple (VTDataVec $ length es) t VTNA+ _ ->+ Left "Input of GroupS is not a value vector"+ GroupAggr (g, as) -> Right $ VProp $ VTDataVec (length g + N.length as)+ Number -> do+ VTDataVec w <- unpack s+ return $ VProp $ VTDataVec (w + 1)+ NumberS -> do+ VTDataVec w <- unpack s+ return $ VProp $ VTDataVec (w + 1)++reqValVectors :: VectorProp VectorType+ -> VectorProp VectorType+ -> (Int -> Int -> VectorProp VectorType)+ -> String+ -> Either String (VectorProp VectorType)+reqValVectors (VProp (VTDataVec w1)) (VProp (VTDataVec w2)) f _ =+ Right $ f w1 w2+reqValVectors _ _ _ e =+ Left $ "Inputs of " ++ e ++ " are not VTDataVecs"++inferVectorTypeBinOp :: VectorProp VectorType -> VectorProp VectorType -> BinOp -> Either String (VectorProp VectorType)+inferVectorTypeBinOp s1 s2 op =+ case op of+ AggrS _ -> return $ VProp $ VTDataVec 1++ DistLift -> do+ VTDataVec w1 <- unpack s1+ VTDataVec w2 <- unpack s2+ return $ VPropPair (VTDataVec $ w1 + w2) VTNA+ DistSng -> do+ VTDataVec w1 <- unpack s1+ VTDataVec w2 <- unpack s2+ return $ VPropPair (VTDataVec $ w1 + w2) VTNA++ AppRep -> liftM2 VPropPair (unpack s2) (Right VTNA)+ AppSort -> liftM2 VPropPair (unpack s2) (Right VTNA)+ AppFilter -> liftM2 VPropPair (unpack s2) (Right VTNA)+ AppKey -> liftM2 VPropPair (unpack s2) (Right VTNA)+ Append ->+ case (s1, s2) of+ (VProp (VTDataVec w1), VProp (VTDataVec w2)) | w1 == w2 ->+ Right $ VPropTriple (VTDataVec w1) VTNA VTNA+ (VProp (VTDataVec w1), VProp (VTDataVec w2)) ->+ Left $ "Inputs of Append do not have the same width " ++ (show w1) ++ " " ++ (show w2)+ v ->+ Left $ "Input of Append is not a VTDataVec " ++ (show v)+ AppendS ->+ case (s1, s2) of+ (VProp (VTDataVec w1), VProp (VTDataVec w2)) | w1 == w2 ->+ Right $ VPropTriple (VTDataVec w1) VTNA VTNA+ (VProp (VTDataVec w1), VProp (VTDataVec w2)) ->+ Left $ "Inputs of Append do not have the same width " ++ (show w1) ++ " " ++ (show w2)+ v ->+ Left $ "Input of Append is not a VTDataVec " ++ (show v)++ Align ->+ case (s1, s2) of+ (VProp (VTDataVec w1), VProp (VTDataVec w2)) -> Right $ VProp $ VTDataVec $ w1 + w2+ _ -> Left "Inputs of Align are not VTDataVecs"+ Zip ->+ case (s1, s2) of+ (VProp (VTDataVec w1), VProp (VTDataVec w2)) ->+ Right $ VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA+ _ ->+ Left "Inputs of PairL are not VTDataVecs"+ ZipS -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "ZipL"+ CartProduct -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "CartProduct"+ CartProductS -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "CartProductS"+ NestProductS -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "NestProductS"+ ThetaJoin _ -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "ThetaJoin"+ UnboxSng -> reqValVectors s1 s2 (\w1 w2 -> VPropPair (VTDataVec $ w1 + w2) VTNA) "UnboxSng"+ NestJoin _ -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "NestJoin"+ NestProduct -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "NestProduct"+ ThetaJoinS _ -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "ThetaJoinS"+ NestJoinS _ -> reqValVectors s1 s2 (\w1 w2 -> VPropTriple (VTDataVec $ w1 + w2) VTNA VTNA) "NestJoinS"+ GroupJoin _ -> do+ VTDataVec w <- unpack s1+ return $ VProp $ VTDataVec $ w + 1+ SemiJoin _ -> liftM2 VPropPair (unpack s1) (Right VTNA)+ SemiJoinS _ -> liftM2 VPropPair (unpack s1) (Right VTNA)+ AntiJoin _ -> liftM2 VPropPair (unpack s1) (Right VTNA)+ AntiJoinS _ -> liftM2 VPropPair (unpack s1) (Right VTNA)++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 (VTDataVec w1), VProp (VTDataVec w2)) | w1 == w2 ->+ Right $ VPropTriple (VTDataVec w1) VTNA VTNA+ (VProp (VTDataVec _), VProp (VTDataVec _)) ->+ Left $ "Inputs of CombineVec do not have the same width"+ _ ->+ Left $ "Inputs of CombineVec are not VTDataVecs/DescrVectors " ++ (show (s2, s3))
+ src/Database/DSH/VL/Opt/Rewrite/Aggregation.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE TemplateHaskell #-}+module Database.DSH.VL.Opt.Rewrite.Aggregation+ ( groupingToAggregation+ ) where++import Control.Monad+import qualified Data.List.NonEmpty as N+import Data.Semigroup++import Database.Algebra.Dag.Common++import Database.DSH.Common.Opt+import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.Rewrite.Common+import Database.DSH.VL.Lang++aggregationRules :: VLRuleSet ()+aggregationRules = [ inlineAggrSProject+ , inlineAggrProject+ , flatGrouping+ -- , mergeNonEmptyAggrs+ , mergeGroupAggr+ , mergeGroupWithGroupAggrLeft+ , mergeGroupWithGroupAggrRight+ , groupJoin+ ]++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 UnboxSngS+-- -- 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") |])++-- We rewrite a combination of Group and aggregation operators into a single+-- GroupAggr operator if the following conditions hold:+--+-- 1. The R2 output of Group is only consumed by an AggrS operator+-- 2. The grouping criteria is a simple column projection from the input vector+flatGrouping :: VLRule ()+flatGrouping q =+ $(dagPatMatch 'q "R1 ((R1 (qg)) UnboxSng ((_) AggrS afun (R2 (qg1=Group 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+ let afuns = $(v "afun") N.:| []+ void $ replaceWithNew q $ UnOp (GroupAggr ($(v "groupExprs"), 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 Group into GroupAggr. If+-- the GroupAggr output is combined with the R1 output of Group on the+-- same input and grouping expressions via Align, the effect is that+-- only the grouping expressions are duplicated.+mergeGroupWithGroupAggrLeft :: VLRule ()+mergeGroupWithGroupAggrLeft q =+ $(dagPatMatch 'q "(R1 (Group 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.MergeGroup.Left" 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 |])++-- | The mirrored dual of rewrite+-- 'Aggregation.Normalize.MergeGroup.Left'.+mergeGroupWithGroupAggrRight :: VLRule ()+mergeGroupWithGroupAggrRight q =+ $(dagPatMatch 'q "(GroupAggr args (q1)) Align (R1 (Group ges (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.MergeGroup.Right" 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+ +++ [ Column $ c + groupWidth | c <- [1..aggrWidth] ]+ +++ groupCols++ groupNode <- insert $ UnOp (GroupAggr (ges', afuns)) $(v "q1")+ void $ replaceWithNew q $ UnOp (Project proj) groupNode |])++-- | Merge nestjoin-based binary grouping and subsequent aggregation+-- into one groupjoin operator.+groupJoin :: VLRule ()+groupJoin q =+ $(dagPatMatch 'q "R1 ((qo) UnboxSng ((qo1) AggrS a (R1 ((qo2) NestJoin p (qi)))))"+ [| do+ predicate $ $(v "qo1") == $(v "qo")+ predicate $ $(v "qo2") == $(v "qo")++ return $ do+ logRewrite "GroupJoin" q+ void $ replaceWithNew q $ BinOp (GroupJoin ($(v "p"), $(v "a"))) $(v "qo") $(v "qi")+ |])
+ src/Database/DSH/VL/Opt/Rewrite/Common.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE TemplateHaskell #-}+module Database.DSH.VL.Opt.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.Common.Lang+import Database.DSH.Common.Opt+import Database.DSH.Common.Vector+import Database.DSH.VL.Lang++import Database.DSH.VL.Opt.Properties.BottomUp+import Database.DSH.VL.Opt.Properties.TopDown+import Database.DSH.VL.Opt.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 = parents q >>= \ps -> filterM isR1 ps+ where+ isR1 :: AlgNode -> VLRewrite Bool+ isR1 q' = do+ o <- operator q'+ case o of+ UnOp R1 _ -> return True+ _ -> return False+++lookupR2Parents :: AlgNode -> VLRewrite [AlgNode]+lookupR2Parents q = parents q >>= \ps -> filterM isR2 ps+ where+ isR2 :: AlgNode -> VLRewrite Bool+ isR2 q' = do+ o <- operator q'+ case o of+ UnOp R2 _ -> return True+ _ -> return False++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 -> error $ show c ++ " " ++ show env+ If c t e -> If (mergeExpr env c) (mergeExpr env t) (mergeExpr env e)+ Constant _ -> expr++-- | Unwrap a constant value+constVal :: Monad m => (ScalarVal -> 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/VL/Opt/Rewrite/Expressions.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.VL.Opt.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 Data.Maybe++import Database.Algebra.Dag.Common++import Database.DSH.Common.Lang+import Database.DSH.Common.Opt+import Database.DSH.VL.Lang+import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.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 (VTDataVec 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, ScalarVal)] -> 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 (ConstVec 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/VL/Opt/Rewrite/PruneEmpty.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.VL.Opt.Rewrite.PruneEmpty(pruneEmpty) where++import Control.Monad++import Database.DSH.Common.Opt+import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.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+ ]++-- FIXME pruning data vectors (R1) alone is not sufficient when+-- dealing with natural keys. We need to treat R2 and R3 outputs as+-- well, because otherwise inner vectors will be re-keyed and no+-- longer be aligned with the outer vector.++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/VL/Opt/Rewrite/Redundant.hs view
@@ -0,0 +1,1050 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.DSH.VL.Opt.Rewrite.Redundant (removeRedundancy) where++import Control.Monad++import Database.Algebra.Dag.Common++import Database.DSH.Common.Lang++import Database.DSH.Common.Opt+import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.Properties.VectorType+import Database.DSH.VL.Opt.Rewrite.Common+import Database.DSH.VL.Opt.Rewrite.Expressions+import Database.DSH.VL.Opt.Rewrite.Aggregation+import Database.DSH.VL.Opt.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 = [ pullProjectAppKey+ , pullProjectAppRep+ , pullProjectAppFilter+ , pullProjectAppSort+ , pullProjectUnboxKey+ , pullProjectAggrS+ , scalarConditional+ ]++redundantRulesBottomUp :: VLRuleSet BottomUpProps+redundantRulesBottomUp = [ sameInputAlign+ , sameInputZip+ -- , sameInputZipProject+ -- , sameInputZipProjectLeft+ -- , sameInputZipProjectRight+ , zipProjectLeft+ , alignProjectLeft+ , zipProjectRight+ , alignProjectRight+ , distLiftProjectLeft+ , distLiftProjectRight+ , distLiftNestProduct+ , distLiftNestJoin+ , distLiftStacked+ , distLiftSelect+ , alignedDistLeft+ , alignedDistRight+ , zipConstLeft+ , zipConstRight+ , alignConstLeft+ , alignConstRight+ , zipZipLeft+ , alignWinLeft+ , alignWinRight+ , alignWinRightPush+ , alignUnboxSngRight+ , alignUnboxSngLeft+ , alignCartProdRight+ , alignGroupJoinLeft+ , alignGroupJoinRight+ -- , runningAggWin+ , inlineWinAggrProject+ , pullProjectNumber+ , constDist+ , nestJoinChain+ , pullProjectUnboxSngLeft+ , pullProjectUnboxSngRight+ , pullProjectNestJoinLeft+ , pullProjectNestJoinRight+ , pullProjectGroupJoinLeft+ , selectCartProd+ ]++redundantRulesAllProps :: VLRuleSet Properties+redundantRulesAllProps = [ unreferencedDistLift+ , notReqNumber+ , unboxNumber+ ]++--------------------------------------------------------------------------------+--++unwrapConstVal :: ConstPayload -> VLMatch p ScalarVal+unwrapConstVal (ConstPL val) = return val+unwrapConstVal NonConstPL = fail "not a constant"++-- | If the left input of a dist operator is constant, a normal projection+-- can be used because the Dist* operators keeps the shape of the+-- right input.+constDist :: VLRule BottomUpProps+constDist q =+ $(dagPatMatch 'q "R1 ((q1) [DistLift | DistSng] (q2))"+ [| do+ VProp (ConstVec constCols) <- constProp <$> properties $(v "q1")+ VProp (VTDataVec 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 (VTDataVec w1) <- vectorTypeProp <$> bu <$> properties $(v "q1")+ VProp (VTDataVec 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 $ IntV 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.+alignedDistRight :: VLRule BottomUpProps+alignedDistRight q =+ $(dagPatMatch 'q "(q21) Align (qr1=R1 ((q1) [DistLift | DistSng] (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.Dist.Align.Right" q+ let proj = map Column $+ [w1+1..w1+w2]+ +++ [1..w1]+ +++ [w1+1..w1+w2]+ void $ replaceWithNew q $ UnOp (Project proj) $(v "qr1") |])++-- | 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.+alignedDistLeft :: VLRule BottomUpProps+alignedDistLeft q =+ $(dagPatMatch 'q "(qr1=R1 ((q1) [DistLift | DistSng] (q21))) Align (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.Dist.Align.Left" q+ let proj = map Column $+ [1..w1]+ +++ [w1+1..w1+w2]+ +++ [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 an Align operator with a projection if both inputs are the+-- same.+sameInputAlign :: VLRule BottomUpProps+sameInputAlign q =+ $(dagPatMatch 'q "(q1) Align (q2)"+ [| do+ predicate $ $(v "q1") == $(v "q2")+ w <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1")++ return $ do+ logRewrite "Redundant.Align.Self" q+ let ps = map Column [1 .. w]+ void $ replaceWithNew q $ UnOp (Project (ps ++ ps)) $(v "q1") |])++-- | Replace an Align operator with a projection if both inputs are the+-- same.+sameInputZip :: VLRule BottomUpProps+sameInputZip q =+ $(dagPatMatch 'q "R1 ((q1) Zip (q2))"+ [| do+ predicate $ $(v "q1") == $(v "q2")+ w <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1")++ return $ do+ logRewrite "Redundant.Zip.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") |])++alignProjectLeft :: VLRule BottomUpProps+alignProjectLeft q =+ $(dagPatMatch 'q "(Project ps1 (q1)) Align (q2)"+ [| do+ w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1")+ w2 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q2")++ return $ do+ logRewrite "Redundant.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]]+ alignNode <- insert $ BinOp Align $(v "q1") $(v "q2")+ void $ replaceWithNew q $ UnOp (Project proj) alignNode |])++zipProjectLeft :: VLRule BottomUpProps+zipProjectLeft q =+ $(dagPatMatch 'q "R1 ((Project ps1 (q1)) Zip (q2))"+ [| do+ w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1")+ w2 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q2")++ return $ do+ logRewrite "Redundant.Zip.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 Zip $(v "q1") $(v "q2")+ r1Node <- insert $ UnOp R1 zipNode+ void $ replaceWithNew q $ UnOp (Project proj) r1Node |])++alignProjectRight :: VLRule BottomUpProps+alignProjectRight q =+ $(dagPatMatch 'q "(q1) Align (Project p2 (q2))"+ [| do+ w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1")++ return $ do+ logRewrite "Redundant.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 Align $(v "q1") $(v "q2")+ void $ replaceWithNew q $ UnOp (Project proj) zipNode |])++zipProjectRight :: VLRule BottomUpProps+zipProjectRight q =+ $(dagPatMatch 'q "R1 ((q1) Zip (Project p2 (q2)))"+ [| do+ w1 <- liftM (vectorWidth . vectorTypeProp) $ properties $(v "q1")++ return $ do+ logRewrite "Redundant.Zip.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 Zip $(v "q1") $(v "q2")+ r1Node <- insert $ UnOp R1 zipNode+ void $ replaceWithNew q $ UnOp (Project proj) r1Node |])++fromConst :: Monad m => ConstPayload -> m ScalarVal+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 (ConstVec 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 (ConstVec 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 "R1 ((q1) Zip (q2))"+ [| do+ prop1 <- properties $(v "q1")+ VProp card1 <- return $ card1Prop prop1+ VProp (ConstVec 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 "R1 ((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 (ConstVec 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") |])++alignWinRight :: VLRule BottomUpProps+alignWinRight q =+ $(dagPatMatch 'q "(q1) Align (qw=WinFun _ (q2))"+ [| do+ predicate $ $(v "q1") == $(v "q2")++ w <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1")++ return $ do+ logRewrite "Redundant.Align.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") |])++alignWinLeft :: VLRule BottomUpProps+alignWinLeft q =+ $(dagPatMatch 'q "(qw=WinFun _ (q1)) Align (q2)"+ [| do+ predicate $ $(v "q1") == $(v "q2")++ w <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1")++ return $ do+ logRewrite "Redundant.Align.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++alignWinRightPush :: VLRule BottomUpProps+alignWinRightPush q =+ $(dagPatMatch 'q "(q1) Align (WinFun args (q2))"+ [| do+ let (winFun, frameSpec) = $(v "args")+ predicate $ isPrecedingFrameSpec frameSpec+ w1 <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1")++ return $ do+ logRewrite "Redundant.Align.Win.Right" q+ zipNode <- insert $ BinOp Align $(v "q1") $(v "q2")+ let winFun' = mapWinFun (mapExprCols (\c -> c + w1)) winFun+ args' = (winFun', frameSpec)+ void $ replaceWithNew q $ UnOp (WinFun args') zipNode |])++alignGroupJoinRight :: VLRule BottomUpProps+alignGroupJoinRight q =+ $(dagPatMatch 'q "(qo) Align (gj=(qo1) GroupJoin _ (_))"+ [| do+ predicate $ $(v "qo") == $(v "qo1")+ w <- vectorWidth <$> vectorTypeProp <$> properties $(v "qo")++ return $ do+ logRewrite "Redundant.Align.GroupJoin.Right" q+ -- In the result, replicate the columns from the outer+ -- vector to keep the schema intact.+ let proj = map Column $ [1..w] ++ [1..w+1]+ void $ replaceWithNew q $ UnOp (Project proj) $(v "gj") |])++alignGroupJoinLeft :: VLRule BottomUpProps+alignGroupJoinLeft q =+ $(dagPatMatch 'q "(gj=(qo1) GroupJoin _ (_)) Align (qo)"+ [| do+ predicate $ $(v "qo") == $(v "qo1")+ w <- vectorWidth <$> vectorTypeProp <$> properties $(v "qo")++ return $ do+ logRewrite "Redundant.Align.GroupJoin.Left" q+ -- In the result, replicate the columns from the outer+ -- vector to keep the schema intact.+ let proj = map Column $ [1..w+1] ++ [1..w]+ void $ replaceWithNew q $ UnOp (Project proj) $(v "gj") |])++-- | If the right (outer) input of Unbox is a number operator and the+-- number output is not required, eliminate it from the outer+-- input. This is correct because Number does not change the vertical+-- shape of the vector.+--+-- The motivation is to eliminate zip operators that align with the+-- unboxed block. By removing Number from the Unbox input, we hope to+-- achieve that the outer input is the same one as the zip input so+-- that we can remove the zip.+--+-- For an example, see the bestProfit query (AQuery examples).+--+-- FIXME This could be extended to all operators that do not modify+-- the vertical shape.+unboxNumber :: VLRule Properties+unboxNumber q =+ $(dagPatMatch 'q "R1 ((Number (qo)) UnboxSng (qi))"+ [| do+ VProp (Just reqCols) <- reqColumnsProp <$> td <$> properties q+ VProp (VTDataVec wo) <- vectorTypeProp <$> bu <$> properties $(v "qo")+ VProp (VTDataVec wi) <- vectorTypeProp <$> bu <$> properties $(v "qi")+ predicate $ (wo+1) `notElem` reqCols++ return $ do+ logRewrite "Redundant.Unbox.Number" q+ -- FIXME HACKHACKHACK We have to insert a dummy column in+ -- place of the number column to avoid destroying column+ -- indexes.+ let proj = map Column [1..wo]+ ++ [Constant $ IntV 0xdeadbeef]+ ++ map Column [wo+1..wi+wo]+ unboxNode <- insert $ BinOp UnboxSng $(v "qo") $(v "qi")+ r1Node <- insert $ UnOp R1 unboxNode+ void $ replaceWithNew q $ UnOp (Project proj) r1Node |])++-- | If singleton scalar elements in an inner vector (with singleton+-- segments) are unboxed using an outer vector and then aligned with+-- the same outer vector, we can eliminate the align, because the+-- positional alignment is implicitly performed by the UnboxSng+-- operator. We exploit the fact that UnboxSng is only a+-- specialized join which nevertheless produces payload columns from+-- both inputs.+alignUnboxSngRight :: VLRule BottomUpProps+alignUnboxSngRight q =+ $(dagPatMatch 'q "(q11) Align (qu=R1 ((q12) UnboxSng (q2)))"+ [| do+ predicate $ $(v "q11") == $(v "q12")++ leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q11")+ rightWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2")++ return $ do+ logRewrite "Redundant.Align.UnboxSng.Right" q+++ -- Keep the original schema intact by duplicating columns+ -- from the left input (UnboxSng 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.UnboxSng.Right+alignUnboxSngLeft :: VLRule BottomUpProps+alignUnboxSngLeft q =+ $(dagPatMatch 'q "(qu=R1 ((q11) UnboxSng (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.UnboxSng.Left" q+++ -- Keep the original schema intact by duplicating columns+ -- from the left input (UnboxSng 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)++pullProjectGroupJoinLeft :: VLRule BottomUpProps+pullProjectGroupJoinLeft q =+ $(dagPatMatch 'q "(Project proj (q1)) GroupJoin args (q2)"+ [| do+ let (p, a) = $(v "args")+ leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1")+ rightWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2")++ return $ do+ logRewrite "Redundant.Project.GroupJoin.Left" q+ let proj' = $(v "proj") ++ [Column $ leftWidth + 1]+ p' = inlineJoinPredLeft (zip [1..] $(v "proj")) p+ rightCols = [leftWidth+1 .. leftWidth + rightWidth]+ env = zip [1..] ($(v "proj") ++ map Column rightCols)+ a' = mapAggrFun (mergeExpr env) a++ joinNode <- insert $ BinOp (GroupJoin (p', a')) $(v "q1") $(v "q2")+ void $ replaceWithNew q $ UnOp (Project proj') joinNode |])++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).++pullProjectAppKey :: VLRule ()+pullProjectAppKey q =+ $(dagPatMatch 'q "R1 ((qp) AppKey (Project proj (qv)))"+ [| do+ return $ do+ logRewrite "Redundant.Project.AppKey" q+ rekeyNode <- insert $ BinOp AppKey $(v "qp") $(v "qv")+ r1Node <- insert $ UnOp R1 rekeyNode+ void $ replaceWithNew q $ UnOp (Project $(v "proj")) r1Node |])++pullProjectUnboxSngLeft :: VLRule BottomUpProps+pullProjectUnboxSngLeft q =+ $(dagPatMatch 'q "R1 ((Project proj (q1)) UnboxSng (q2))"+ [| do+ leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1")+ rightWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q2")++ return $ do+ logRewrite "Redundant.Project.UnboxSng" 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 UnboxSng $(v "q1") $(v "q2")+ r1Node <- insert $ UnOp R1 unboxNode++ void $ replaceWithNew q $ UnOp (Project proj') r1Node |])++pullProjectUnboxSngRight :: VLRule BottomUpProps+pullProjectUnboxSngRight q =+ $(dagPatMatch 'q "R1 ((q1) UnboxSng (Project proj (q2)))"+ [| do+ leftWidth <- vectorWidth <$> vectorTypeProp <$> properties $(v "q1")++ return $ do+ logRewrite "Redundant.Project.UnboxSng" 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 UnboxSng $(v "q1") $(v "q2")+ r1Node <- insert $ UnOp R1 unboxNode++ void $ replaceWithNew q $ UnOp (Project proj') r1Node |])++pullProjectAppRep :: VLRule ()+pullProjectAppRep q =+ $(dagPatMatch 'q "R1 ((qp) AppRep (Project proj (qv)))"+ [| do+ return $ do+ logRewrite "Redundant.Project.AppRep" q+ repNode <- insert $ BinOp AppRep $(v "qp") $(v "qv")+ r1Node <- insert $ UnOp R1 repNode+ void $ replaceWithNew q $ UnOp (Project $(v "proj")) r1Node |])++pullProjectAppFilter :: VLRule ()+pullProjectAppFilter q =+ $(dagPatMatch 'q "R1 ((q1) AppFilter (Project proj (q2)))"+ [| do+ return $ do+ logRewrite "Redundant.Project.AppFilter" q+ filterNode <- insert $ BinOp AppFilter $(v "q1") $(v "q2")+ r1Node <- insert $ UnOp R1 filterNode+ void $ replaceWithNew q $ UnOp (Project $(v "proj")) r1Node |])++pullProjectAppSort :: VLRule ()+pullProjectAppSort q =+ $(dagPatMatch 'q "R1 ((q1) AppSort (Project proj (q2)))"+ [| do+ return $ do+ logRewrite "Redundant.Project.AppSort" q+ sortNode <- insert $ BinOp AppSort $(v "q1") $(v "q2")+ r1Node <- insert $ UnOp R1 sortNode+ void $ replaceWithNew q $ UnOp (Project $(v "proj")) r1Node |])++pullProjectUnboxKey :: VLRule ()+pullProjectUnboxKey q =+ $(dagPatMatch 'q "UnboxKey (Project _ (q1))"+ [| do+ return $ do+ logRewrite "Redundant.Project.UnboxKey" q+ void $ replaceWithNew q $ UnOp UnboxKey $(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") |])++--------------------------------------------------------------------------------+-- Rewrites that deal with nested structures and propagation vectors.++-- | 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))) AppRep (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 $ IntV 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/VL/Opt/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.VL.Opt.Rewrite.Unused where++{-+import Control.Applicative++import Database.Algebra.Dag.Common+import Database.Algebra.VL.Data++import Database.DSH.Common.Opt+import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.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/VL/Opt/Rewrite/Window.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TemplateHaskell #-}+module Database.DSH.VL.Opt.Rewrite.Window where++import Control.Monad+import Data.List.NonEmpty (NonEmpty (..))++import Database.Algebra.Dag.Common++import Database.DSH.Common.Lang+import Database.DSH.Common.Opt+import Database.DSH.VL.Opt.Properties.ReqColumns+import Database.DSH.VL.Opt.Properties.Types+import Database.DSH.VL.Opt.Properties.VectorType+import Database.DSH.VL.Opt.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) UnboxSng ((_) 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 "(UnboxKey (Number (q1))) AppKey (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 (IntV 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 $ IntV 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/VL/Primitives.hs view
@@ -7,14 +7,13 @@ 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.Common.Vector -import Database.DSH.Impossible+import Database.DSH.Common.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@@ -24,12 +23,18 @@ dvec :: VecConst r VLDVec dvec = fmap VLDVec -pvec :: Build a AlgNode -> Build a PVec-pvec = fmap PVec+rvec :: Build a AlgNode -> Build a VLRVec+rvec = fmap VLRVec -rvec :: Build a AlgNode -> Build a RVec-rvec = fmap RVec- +kvec :: Build a AlgNode -> Build a VLKVec+kvec = fmap VLKVec++svec :: Build a AlgNode -> Build a VLSVec+svec = fmap VLSVec++fvec :: Build a AlgNode -> Build a VLFVec+fvec = fmap VLFVec+ -------------------------------------------------------------------------------- -- Insert VL operators and appropriate R1/R2/R3 nodes @@ -43,10 +48,10 @@ r2 <- mkVec2 $ insert $ UnOp R2 r return (r1, r2) -tripleVec :: VL - -> VecConst r a - -> VecConst r b - -> VecConst r c +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@@ -60,23 +65,15 @@ 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"+pVal :: L.Val -> L.ScalarVal+pVal (L.ScalarV v) = v+pVal L.ListV{} = $impossible+pVal L.TupleV{} = $impossible -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+typeToScalarType :: Ty.Type -> Ty.ScalarType+typeToScalarType Ty.ListT{} = $impossible+typeToScalarType Ty.TupleT{} = $impossible+typeToScalarType (Ty.ScalarT t) = t ---------------------------------------------------------------------------------- -- Convert join expressions into regular VL expressions@@ -85,11 +82,7 @@ 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.ScalarT _ -> 1 Ty.TupleT ts -> sum $ map recordWidth ts Ty.ListT _ -> 0 @@ -115,7 +108,7 @@ toGeneralUnOp (L.JUTextOp o) = L.SUTextOp o toVLjoinConjunct :: L.JoinConjunct L.JoinExpr -> L.JoinConjunct Expr-toVLjoinConjunct (L.JoinConjunct e1 o e2) = +toVLjoinConjunct (L.JoinConjunct e1 o e2) = L.JoinConjunct (joinExpr e1) o (joinExpr e2) toVLJoinPred :: L.JoinPredicate L.JoinExpr -> L.JoinPredicate Expr@@ -149,6 +142,9 @@ ---------------------------------------------------------------------------------- -- DAG constructor functions for VL operators +vlUnique :: VLDVec -> Build VL VLDVec+vlUnique (VLDVec c) = vec (UnOp Unique c) dvec+ vlUniqueS :: VLDVec -> Build VL VLDVec vlUniqueS (VLDVec c) = vec (UnOp UniqueS c) dvec @@ -158,66 +154,72 @@ 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+vlGroup :: [Expr] -> VLDVec -> Build VL (VLDVec, VLDVec, VLSVec)+vlGroup groupExprs (VLDVec c) = tripleVec (UnOp (Group groupExprs) c) dvec dvec svec -vlSortS :: [Expr] -> VLDVec -> Build VL (VLDVec, PVec)-vlSortS sortExprs (VLDVec c1) = pairVec (UnOp (SortS sortExprs) c1) dvec pvec+vlGroupS :: [Expr] -> VLDVec -> Build VL (VLDVec, VLDVec, VLSVec)+vlGroupS groupExprs (VLDVec c) = tripleVec (UnOp (GroupS groupExprs) c) dvec dvec svec +vlSort :: [Expr] -> VLDVec -> Build VL (VLDVec, VLSVec)+vlSort sortExprs (VLDVec c1) = pairVec (UnOp (Sort sortExprs) c1) dvec svec++vlSortS :: [Expr] -> VLDVec -> Build VL (VLDVec, VLSVec)+vlSortS sortExprs (VLDVec c1) = pairVec (UnOp (SortS sortExprs) c1) dvec svec+ 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+vlUnboxKey :: VLDVec -> Build VL VLKVec+vlUnboxKey (VLDVec c) = vec (UnOp UnboxKey c) kvec -vlNestProduct :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec)-vlNestProduct (VLDVec c1) (VLDVec c2) = tripleVec (BinOp NestProduct c1 c2) dvec pvec pvec+vlNestProduct :: VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec, VLRVec)+vlNestProduct (VLDVec c1) (VLDVec c2) = tripleVec (BinOp NestProduct c1 c2) dvec rvec rvec -vlDistLift :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec)-vlDistLift (VLDVec c1) (VLDVec c2) = pairVec (BinOp DistLift c1 c2) dvec pvec+vlDistLift :: VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec)+vlDistLift (VLDVec c1) (VLDVec c2) = pairVec (BinOp DistLift c1 c2) dvec rvec -vlPropRename :: RVec -> VLDVec -> Build VL VLDVec-vlPropRename (RVec c1) (VLDVec c2) = vec (BinOp PropRename c1 c2) dvec+vlDistSng :: VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec)+vlDistSng (VLDVec c1) (VLDVec c2) = pairVec (BinOp DistSng c1 c2) dvec rvec -vlUnboxNested :: RVec -> VLDVec -> Build VL (VLDVec, RVec)-vlUnboxNested (RVec c1) (VLDVec c2) = pairVec (BinOp UnboxNested c1 c2) dvec rvec+vlUnboxSng :: VLDVec -> VLDVec -> Build VL (VLDVec, VLKVec)+vlUnboxSng (VLDVec c1) (VLDVec c2) = pairVec (BinOp UnboxSng c1 c2) dvec kvec -vlUnboxScalar :: VLDVec -> VLDVec -> Build VL VLDVec-vlUnboxScalar (VLDVec c1) (VLDVec c2) = vec (BinOp UnboxScalar c1 c2) dvec+vlAppSort :: VLSVec -> VLDVec -> Build VL (VLDVec, VLSVec)+vlAppSort (VLSVec c1) (VLDVec c2) = pairVec (BinOp AppSort c1 c2) dvec svec -vlPropFilter :: RVec -> VLDVec -> Build VL (VLDVec, RVec)-vlPropFilter (RVec c1) (VLDVec c2) = pairVec (BinOp PropFilter c1 c2) dvec rvec+vlAppFilter :: VLFVec -> VLDVec -> Build VL (VLDVec, VLFVec)+vlAppFilter (VLFVec c1) (VLDVec c2) = pairVec (BinOp AppFilter c1 c2) dvec fvec -vlPropReorder :: PVec -> VLDVec -> Build VL (VLDVec, PVec)-vlPropReorder (PVec c1) (VLDVec c2) = pairVec (BinOp PropReorder c1 c2) dvec pvec+vlAppKey :: VLKVec -> VLDVec -> Build VL (VLDVec, VLKVec)+vlAppKey (VLKVec c1) (VLDVec c2) = pairVec (BinOp AppKey c1 c2) dvec kvec -vlSingletonDescr :: Build VL VLDVec-vlSingletonDescr = vec (NullaryOp SingletonDescr) dvec+vlAppRep :: VLRVec -> VLDVec -> Build VL (VLDVec, VLRVec)+vlAppRep (VLRVec c1) (VLDVec c2) = pairVec (BinOp AppRep c1 c2) dvec rvec -vlAppend :: VLDVec -> VLDVec -> Build VL (VLDVec, RVec, RVec)-vlAppend (VLDVec c1) (VLDVec c2) = tripleVec (BinOp Append c1 c2) dvec rvec rvec+vlNest :: VLDVec -> Build VL (VLDVec, VLDVec)+vlNest (VLDVec c)= pairVec (UnOp Nest c) dvec dvec -vlAppendS :: VLDVec -> VLDVec -> Build VL (VLDVec, RVec, RVec)-vlAppendS (VLDVec c1) (VLDVec c2) = tripleVec (BinOp AppendS c1 c2) dvec rvec rvec+vlAppend :: VLDVec -> VLDVec -> Build VL (VLDVec, VLKVec, VLKVec)+vlAppend (VLDVec c1) (VLDVec c2) = tripleVec (BinOp Append c1 c2) dvec kvec kvec -vlSegment :: VLDVec -> Build VL VLDVec-vlSegment (VLDVec c) = vec (UnOp Segment c) dvec+vlAppendS :: VLDVec -> VLDVec -> Build VL (VLDVec, VLKVec, VLKVec)+vlAppendS (VLDVec c1) (VLDVec c2) = tripleVec (BinOp AppendS c1 c2) dvec kvec kvec -vlUnsegment :: VLDVec -> Build VL VLDVec-vlUnsegment (VLDVec c) = vec (UnOp Unsegment c) dvec+vlSegment :: VLDVec -> Build VL (VLDVec, VLDVec)+vlSegment (VLDVec c) = pairVec (UnOp Segment c) dvec 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+vlCombine :: VLDVec -> VLDVec -> VLDVec -> Build VL (VLDVec, VLKVec, VLKVec)+vlCombine (VLDVec c1) (VLDVec c2) (VLDVec c3) =+ tripleVec (TerOp Combine c1 c2 c3) dvec kvec kvec -vlLit :: L.Emptiness -> [Ty.Type] -> [[VLVal]] -> Build VL VLDVec+vlLit :: L.Emptiness -> [Ty.Type] -> [[L.ScalarVal]] -> 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+vlTableRef :: String -> L.BaseTableSchema -> Build VL VLDVec+vlTableRef n schema = vec (NullaryOp $ TableRef (n, schema)) dvec vlUnExpr :: L.ScalarUnOp -> VLDVec -> Build VL VLDVec vlUnExpr o (VLDVec c) = vec (UnOp (Project [UnApp o (Column 1)]) c) dvec@@ -228,114 +230,84 @@ 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+vlSelect :: Expr -> VLDVec -> Build VL (VLDVec, VLFVec)+vlSelect p (VLDVec c) = pairVec (UnOp (Select p) c) dvec fvec 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+vlZip :: VLDVec -> VLDVec -> Build VL (VLDVec, VLKVec, VLKVec)+vlZip (VLDVec c1) (VLDVec c2) = tripleVec (BinOp Zip c1 c2) dvec kvec kvec 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 -> VLDVec -> Build VL (VLDVec, VLKVec, VLKVec) vlZipS (VLDVec c1) (VLDVec c2) =- tripleVec (BinOp ZipS c1 c2) dvec rvec rvec+ tripleVec (BinOp ZipS c1 c2) dvec kvec kvec -vlCartProduct :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec)+vlCartProduct :: VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec, VLRVec) vlCartProduct (VLDVec c1) (VLDVec c2) =- tripleVec (BinOp CartProduct c1 c2) dvec pvec pvec+ tripleVec (BinOp CartProduct c1 c2) dvec rvec rvec -vlCartProductS :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec)+vlCartProductS :: VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec, VLRVec) vlCartProductS (VLDVec c1) (VLDVec c2) =- tripleVec (BinOp CartProductS c1 c2) dvec pvec pvec+ tripleVec (BinOp CartProductS c1 c2) dvec rvec rvec -vlThetaJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec)+vlThetaJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec, VLRVec) vlThetaJoin joinPred (VLDVec c1) (VLDVec c2) =- tripleVec (BinOp (ThetaJoin joinPred') c1 c2) dvec pvec pvec+ tripleVec (BinOp (ThetaJoin joinPred') c1 c2) dvec rvec rvec where joinPred' = toVLJoinPred joinPred -vlNestJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec)+vlNestJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec, VLRVec) vlNestJoin joinPred (VLDVec c1) (VLDVec c2) =- tripleVec (BinOp (NestJoin joinPred') c1 c2) dvec pvec pvec+ tripleVec (BinOp (NestJoin joinPred') c1 c2) dvec rvec rvec where joinPred' = toVLJoinPred joinPred -vlThetaJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, PVec, PVec)+vlThetaJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec, VLRVec) vlThetaJoinS joinPred (VLDVec c1) (VLDVec c2) =- tripleVec (BinOp (ThetaJoinS joinPred') c1 c2) dvec pvec pvec+ tripleVec (BinOp (ThetaJoinS joinPred') c1 c2) dvec rvec rvec where joinPred' = toVLJoinPred joinPred -vlNestJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, PVec)+vlNestJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec, VLRVec) vlNestJoinS joinPred (VLDVec c1) (VLDVec c2) =- pairVec (BinOp (NestJoinS joinPred') c1 c2) dvec pvec+ tripleVec (BinOp (NestJoinS joinPred') c1 c2) dvec rvec rvec where joinPred' = toVLJoinPred joinPred -vlNestProductS :: VLDVec -> VLDVec -> Build VL (VLDVec, PVec)+vlNestProductS :: VLDVec -> VLDVec -> Build VL (VLDVec, VLRVec, VLRVec) vlNestProductS (VLDVec c1) (VLDVec c2) = do- pairVec (BinOp NestProductS c1 c2) dvec pvec+ tripleVec (BinOp NestProductS c1 c2) dvec rvec rvec -vlSemiJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec)+vlSemiJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, VLFVec) vlSemiJoin joinPred (VLDVec c1) (VLDVec c2) = do- pairVec (BinOp (SemiJoin joinPred') c1 c2) dvec rvec+ pairVec (BinOp (SemiJoin joinPred') c1 c2) dvec fvec where joinPred' = toVLJoinPred joinPred -vlSemiJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec)+vlSemiJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, VLFVec) vlSemiJoinS joinPred (VLDVec c1) (VLDVec c2) = do- pairVec (BinOp (SemiJoinS joinPred') c1 c2) dvec rvec+ pairVec (BinOp (SemiJoinS joinPred') c1 c2) dvec fvec where joinPred' = toVLJoinPred joinPred -vlAntiJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec)+vlAntiJoin :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, VLFVec) vlAntiJoin joinPred (VLDVec c1) (VLDVec c2) = do- pairVec (BinOp (AntiJoin joinPred') c1 c2) dvec rvec+ pairVec (BinOp (AntiJoin joinPred') c1 c2) dvec fvec where joinPred' = toVLJoinPred joinPred -vlAntiJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, RVec)+vlAntiJoinS :: L.JoinPredicate L.JoinExpr -> VLDVec -> VLDVec -> Build VL (VLDVec, VLFVec) vlAntiJoinS joinPred (VLDVec c1) (VLDVec c2) = do- pairVec (BinOp (AntiJoinS joinPred') c1 c2) dvec rvec+ pairVec (BinOp (AntiJoinS joinPred') c1 c2) dvec fvec 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+vlReverse :: VLDVec -> Build VL (VLDVec, VLSVec)+vlReverse (VLDVec c) = pairVec (UnOp Reverse c) dvec svec -vlReshapeS :: Integer -> VLDVec -> Build VL (VLDVec, VLDVec)-vlReshapeS n (VLDVec c) = do- pairVec (UnOp (ReshapeS n) c) dvec dvec+vlReverseS :: VLDVec -> Build VL (VLDVec, VLSVec)+vlReverseS (VLDVec c) = pairVec (UnOp ReverseS c) dvec svec
src/Database/DSH/VL/Render/Dot.hs view
@@ -1,18 +1,20 @@ {-# LANGUAGE TemplateHaskell #-} -module Database.DSH.VL.Render.Dot(renderVLDot, renderTblVal) where+module Database.DSH.VL.Render.Dot(renderVLDot) where +import Prelude hiding ((<$>)) import qualified Data.IntMap as Map import qualified Data.List.NonEmpty as N import Data.List -import Text.PrettyPrint+import Text.PrettyPrint.ANSI.Leijen 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.Common.Type import Database.DSH.VL.Lang nodeToDoc :: AlgNode -> Doc@@ -22,7 +24,7 @@ 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)+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@@ -35,7 +37,7 @@ renderFrameSpec (FNPreceding n) = int n <+> text "prec" renderAggrFun :: AggrFun -> Doc-renderAggrFun (AggrSum t c) = renderFun (text "sum" <> char '_' <> renderColumnType t) +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]@@ -57,26 +59,12 @@ renderColumnType :: ScalarType -> Doc renderColumnType = text . show -renderData :: [[VLVal]] -> Doc+renderData :: [[ScalarVal]] -> 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 [] = []+renderRow :: [ScalarVal] -> Doc+renderRow = hcat . punctuate comma . map pretty bracketList :: (a -> Doc) -> [a] -> Doc bracketList f = brackets . hsep . punctuate comma . map f@@ -84,48 +72,32 @@ 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+renderCol :: (ColName, ScalarType) -> Doc+renderCol (c, t) = renderColName c <> text "::" <> renderColumnType t 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)+renderJoinConjunct (JoinConjunct e1 o e2) =+ parenthize1 e1 <+> text (pp o) <+> (parenthize1 e2) renderJoinPred :: JoinPredicate Expr -> Doc renderJoinPred (JoinPred conjs) = brackets- $ hsep + $ 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 (Constant val) = pretty val renderExpr (Column c) = text "col" <> int c-renderExpr (If c t e) = text "if" - <+> renderExpr c - <+> text "then" - <+> renderExpr t - <+> text "else" +renderExpr (If c t e) = text "if"+ <+> renderExpr c+ <+> text "then"+ <+> renderExpr t+ <+> text "else" <+> renderExpr e parenthize1 :: Expr -> Doc@@ -140,19 +112,22 @@ 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 (NullaryOp (Lit (_, tys, vals))) = labelToDoc i "LIT"+ (bracketList renderColumnType tys <> comma+ <$> renderData vals) (lookupTags i tm)+opDotLabel tm i (NullaryOp (TableRef (n, schema))) =+ labelToDoc i "TableScan"+ (text n <> text "\n"+ <> align (bracketList (\c -> renderCol c <> text "\n")+ (N.toList $ tableCols schema)))+ (lookupTags i tm)+opDotLabel tm i (UnOp Unique _) = labelToDoc i "Unique" empty (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 UnboxKey _) = labelToDoc i "UnboxKey" 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 Nest _) = labelToDoc i "Nest" 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)@@ -164,28 +139,23 @@ 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 (Sort cols) _) = labelToDoc i "Sort" (bracketList renderExpr cols) (lookupTags i tm)+opDotLabel tm i (UnOp (SortS cols) _) = labelToDoc i "SortS" (bracketList renderExpr cols) (lookupTags i tm)+opDotLabel tm i (UnOp (Group cols) _) = labelToDoc i "Group" (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 DistSng _ _) = labelToDoc i "DistSng" empty (lookupTags i tm)+opDotLabel tm i (BinOp UnboxSng _ _) = labelToDoc i "UnboxSng" empty (lookupTags i tm)+opDotLabel tm i (BinOp AppSort _ _) = labelToDoc i "AppSort" empty (lookupTags i tm)+opDotLabel tm i (BinOp AppKey _ _) = labelToDoc i "AppKey" empty (lookupTags i tm)+opDotLabel tm i (BinOp AppFilter _ _) = labelToDoc i "AppFilter" empty (lookupTags i tm)+opDotLabel tm i (BinOp AppRep _ _) = labelToDoc i "AppRep" 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)@@ -208,48 +178,45 @@ 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 (BinOp (GroupJoin (p, a)) _ _) =+ labelToDoc i "GroupJoin" (renderJoinPred p <+> renderAggrFun a) (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+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 (GroupJoin _) _ _) = DCGreen+opDotColor (BinOp Zip _ _) = DCYelloGreen+opDotColor (UnOp (Sort _) _) = DCTomato+opDotColor (UnOp (SortS _) _) = DCTomato+opDotColor (UnOp (Group _) _) = DCTomato+opDotColor (UnOp (GroupS _) _) = DCTomato+opDotColor (BinOp UnboxSng _ _) = DCTan+opDotColor (BinOp AppSort _ _) = DCTan+opDotColor (BinOp AppKey _ _) = DCTan+opDotColor (BinOp AppFilter _ _) = DCTan+opDotColor (BinOp AppRep _ _) = DCTan+opDotColor (BinOp DistLift _ _) = DCTan+opDotColor (BinOp DistSng _ _) = 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 (GroupAggr (_, _)) _) = DCTomato+opDotColor (UnOp (Project _) _) = DCLightSkyBlue+opDotColor _ = DCGray -- Dot colors data DotColor = DCTomato@@ -270,20 +237,20 @@ | 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 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" @@ -313,20 +280,20 @@ -- Generate the preamble of a Dot file preamble :: Doc-preamble = graphAttributes $$ nodeAttributes+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))+ <+> (brackets $ (((text "label=") <> (dquotes $ text l)) <> comma <+> (text "color=") <> (renderColor c) <> styleDoc)) <> semi- where styleDoc =- case s of+ where+ styleDoc = case s of Just Dashed -> comma <+> text "style=dashed" Nothing -> empty @@ -335,9 +302,10 @@ -- | 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+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@@ -346,8 +314,9 @@ DotNode n l c (Just Dashed) else DotNode n l c Nothing- where l = escapeLabel $ render $ opDotLabel ts n op- c = opDotColor op+ where+ l = escapeLabel $ pp $ opDotLabel ts n op+ c = opDotColor op -- | Create an abstract Dot edge constructDotEdge :: (AlgNode, AlgNode) -> DotEdge@@ -358,14 +327,16 @@ 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+ 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+renderVLDot ts roots m = pp $ 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
@@ -1,41 +0,0 @@-{-# 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
@@ -1,72 +0,0 @@-{-# 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
@@ -1,91 +1,88 @@+{-# LANGUAGE TypeFamilies #-} {-# 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.Common.Type import Database.DSH.VL.Lang import Database.Algebra.Dag.Build -class VectorAlgebra v a where- -- | A vector with one segment- singletonDescr :: Build a v+class VectorAlgebra a where+ -- | Data Vector+ type DVec a + -- | Re-Keying Vector+ type KVec a++ -- | Replication Vector+ type RVec a++ -- | Sorting Vector+ type SVec a++ -- | Filtering Vector+ type FVec a++ -- | Turn a flat vector into a nested vector with one segment.+ vecNest :: DVec a -> Build a (DVec a, DVec a)+ -- | A vector representing a literal list.- vecLit :: [ScalarType] -> [[VLVal]] -> Build a v+ vecLit :: [ScalarType] -> [[ScalarVal]] -> Build a (DVec a) -- | A reference to a database-resident table.- vecTableRef :: String -> [VLColumn] -> TableHints -> Build a v+ vecTableRef :: String -> BaseTableSchema -> Build a (DVec a) + -- | Eliminate duplicates+ vecUnique :: DVec a -> Build a (DVec a)+ -- | Perform duplicate elimination per segment.- vecUniqueS :: v -> Build a v+ vecUniqueS :: DVec a -> Build a (DVec a) -- | /Materialize/ vector positions. The operator adds an item -- column that contains the dense positions of the vector's -- elements.- vecNumber :: v -> Build a v+ vecNumber :: DVec a -> Build a (DVec a) -- | /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+ vecNumberS :: DVec a -> Build a (DVec a) - descToRename :: v -> Build a RVec+ vecUnboxKey :: DVec a -> Build a (KVec a) -- | 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)+ vecSegment :: DVec a -> Build a (DVec a, DVec a) - -- | Filter a vector positionally on a /constant/ position.- vecSelectPos1 :: v -> ScalarBinOp -> Int -> Build a (v, RVec, RVec)+ vecAggr :: AggrFun -> DVec a -> Build a (DVec a)+ vecAggrS :: AggrFun -> DVec a -> DVec a -> Build a (DVec a) - -- | 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)+ vecWinFun :: WinFun -> FrameSpec -> DVec a -> Build a (DVec a) -- | Reverse a vector.- vecReverse :: v -> Build a (v, PVec)+ vecReverse :: DVec a -> Build a (DVec a, SVec a) -- | Reverse each segment of a vector individually.- vecReverseS :: v -> Build a (v, PVec)+ vecReverseS :: DVec a -> Build a (DVec a, SVec a) -- | Filter a vector by applying a scalar boolean predicate.- vecSelect:: Expr -> v -> Build a (v, RVec)+ vecSelect:: Expr -> DVec a -> Build a (DVec a, FVec a) - -- | Segmented sorting of a vector. - vecSortS :: [Expr] -> v -> Build a (v, PVec)+ -- | Sort a vector+ vecSort :: [Expr] -> DVec a -> Build a (DVec a, SVec a) - vecGroupS :: [Expr] -> v -> Build a (v, v, PVec)+ -- | Per-segment sorting of a vector.+ vecSortS :: [Expr] -> DVec a -> Build a (DVec a, SVec a) + -- | Regular grouping of a vector+ vecGroup :: [Expr] -> DVec a -> Build a (DVec a, DVec a, SVec a)++ -- | Per-segment grouping of a vector+ vecGroupS :: [Expr] -> DVec a -> Build a (DVec a, DVec a, SVec a)+ -- | 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,@@ -95,94 +92,64 @@ -- 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+ vecGroupAggr :: [Expr] -> N.NonEmpty AggrFun -> DVec a -> Build a (DVec a) -- | Construct a new vector as the result of a list of scalar -- expressions per result column.- vecProject :: [Expr] -> v -> Build a v+ vecProject :: [Expr] -> DVec a -> Build a (DVec a) -- 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)+ vecDistLift :: DVec a -> DVec a -> Build a (DVec a, RVec a) - -- | propRename uses a propagation vector to rename a vector (no- -- filtering or reordering).- vecPropRename :: RVec -> v -> Build a v+ vecDistSng :: DVec a -> DVec a -> Build a (DVec a, RVec a) - -- | propFilter uses a propagation vector to rename and filter a- -- vector (no reordering).- vecPropFilter :: RVec -> v -> Build a (v, RVec)+ -- | Apply a sorting vector to a data vector+ vecAppSort :: SVec a -> DVec a -> Build a (DVec a, SVec a) - -- | propReorder uses a propagation vector to rename, filter and- -- reorder a vector.- vecPropReorder :: PVec -> v -> Build a (v, PVec)+ -- | Apply a filter vector to a data vector+ vecAppFilter :: FVec a -> DVec a -> Build a (DVec a, FVec a) - -- | 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)+ -- | Apply a rekeying vector to a data vector+ vecAppKey :: KVec a -> DVec a -> Build a (DVec a, KVec a) - vecUnboxScalar :: v -> v -> Build a v+ -- | Apply a replication vector to a data vector+ vecAppRep :: RVec a -> DVec a -> Build a (DVec a, RVec a) - vecAppend :: v -> v -> Build a (v, RVec, RVec)- vecAppendS :: v -> v -> Build a (v, RVec, RVec)+ vecUnboxSng :: DVec a -> DVec a -> Build a (DVec a, KVec a) + vecAppend :: DVec a -> DVec a -> Build a (DVec a, KVec a, KVec a)+ vecAppendS :: DVec a -> DVec a -> Build a (DVec a, KVec a, KVec a)+ -- | 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+ vecAlign :: DVec a -> DVec a -> Build a (DVec a) -- | Positionally align two vectors. Basically: @zip xs ys@- vecZip :: v -> v -> Build a v+ vecZip :: (DVec a) -> DVec a -> Build a (DVec a, KVec a, KVec a) -- | 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)+ vecZipS :: DVec a -> DVec a -> Build a (DVec a, KVec a, KVec a) - vecCombine :: v -> v -> v -> Build a (v, RVec, RVec)+ vecCartProduct :: DVec a -> DVec a -> Build a (DVec a, RVec a, RVec a)+ vecCartProductS :: DVec a -> DVec a -> Build a (DVec a, RVec a, RVec a)+ vecNestProduct :: DVec a -> DVec a -> Build a (DVec a, RVec a, RVec a)+ vecNestProductS :: DVec a -> DVec a -> Build a (DVec a, RVec a, RVec a) - -- | 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)+ vecThetaJoin :: JoinPredicate Expr -> DVec a -> DVec a -> Build a (DVec a, RVec a, RVec a)+ vecNestJoin :: JoinPredicate Expr -> DVec a -> DVec a -> Build a (DVec a, RVec a, RVec a)+ vecThetaJoinS :: JoinPredicate Expr -> DVec a -> DVec a -> Build a (DVec a, RVec a, RVec a)+ vecNestJoinS :: JoinPredicate Expr -> DVec a -> DVec a -> Build a (DVec a, RVec a, RVec a) - -- | Experimental: segmented version of reshape.- vecReshapeS :: Integer -> v -> Build a (v, v)+ vecGroupJoin :: JoinPredicate Expr -> AggrFun -> DVec a -> DVec a -> Build a (DVec a) - -- | Experimental: Matrix transposition- vecTranspose :: v -> Build a (v, v)+ vecSemiJoin :: JoinPredicate Expr -> DVec a -> DVec a -> Build a (DVec a, FVec a)+ vecSemiJoinS :: JoinPredicate Expr -> DVec a -> DVec a -> Build a (DVec a, FVec a) - -- | Experimental: Segmented matrix transposition- vecTransposeS :: v -> v -> Build a (v, v)+ vecAntiJoin :: JoinPredicate Expr -> DVec a -> DVec a -> Build a (DVec a, FVec a)+ vecAntiJoinS :: JoinPredicate Expr -> DVec a -> DVec a -> Build a (DVec a, FVec a) + vecCombine :: DVec a -> DVec a -> DVec a -> Build a (DVec a, KVec a, KVec a)
− src/Database/DSH/VL/VectorAlgebra/TA.hs
@@ -1,908 +0,0 @@-{-# 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
@@ -9,6 +9,7 @@ import Control.Applicative import qualified Data.List as List+import qualified Data.List.NonEmpty as N import Prelude hiding (reverse, zip) import qualified Prelude as P @@ -18,264 +19,218 @@ 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.Common.Impossible+import Database.DSH.VL.Lang (AggrFun (..), Expr (..), VL ()) import Database.DSH.VL.Primitives-import Database.DSH.VL.Vector+import Database.DSH.Common.Vector -------------------------------------------------------------------------------- -- Construction of not-lifted primitives +binOp :: L.ScalarBinOp -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec)+binOp o (SShape dv1 _) (SShape dv2 _) = do+ (dv, _, _) <- vlCartProduct dv1 dv2+ dv' <- vlProject [BinApp o (Column 1) (Column 2)] dv+ return $ SShape dv' LCol+binOp _ _ _ = $impossible+ 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 (VShape dv1 lyt1) (VShape dv2 lyt2) = do+ (dv, fv1, fv2) <- vlZip dv1 dv2+ lyt1' <- rekeyOuter fv1 lyt1+ lyt2' <- rekeyOuter fv2 lyt2+ return $ VShape dv $ LTuple [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 (VShape dv1 lyt1) (VShape dv2 lyt2) = do+ (dv, rv1, rv2) <- vlCartProduct dv1 dv2+ lyt1' <- repLayout rv1 lyt1+ lyt2' <- repLayout rv2 lyt2+ return $ VShape dv $ LTuple [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 (VShape dv1 lyt1) (VShape dv2 lyt2) = do+ (dvi, rv1, rv2) <- vlNestProduct dv1 dv2+ lyt1' <- repLayout rv1 lyt1+ lyt2' <- repLayout rv2 lyt2+ return $ VShape dv1 (LTuple [lyt1, LNest dvi (LTuple [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 joinPred (VShape dv1 lyt1) (VShape dv2 lyt2) = do+ (dv, rv1, rv2) <- vlThetaJoin joinPred dv1 dv2+ lyt1' <- repLayout rv1 lyt1+ lyt2' <- repLayout rv2 lyt2+ return $ VShape dv $ LTuple [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 joinPred (VShape dv1 lyt1) (VShape dv2 lyt2) = do+ (dv, rv1, rv2) <- vlNestJoin joinPred dv1 dv2+ lyt1' <- repLayout rv1 lyt1+ lyt2' <- repLayout rv2 lyt2+ return $ VShape dv1 (LTuple [lyt1, LNest dv (LTuple [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 joinPred (VShape dv1 lyt1) (VShape dv2 _) = do+ (dv, fv) <- vlSemiJoin joinPred dv1 dv2+ lyt1' <- filterLayout fv lyt1+ return $ VShape dv 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 joinPred (VShape dv1 lyt1) (VShape dv2 _) = do+ (dv, fv) <- vlAntiJoin joinPred dv1 dv2+ lyt1' <- filterLayout fv lyt1+ return $ VShape dv lyt1' antiJoin _ _ _ = $impossible nub :: Shape VLDVec -> Build VL (Shape VLDVec)-nub (VShape q lyt) = VShape <$> vlUniqueS q <*> pure lyt+nub (VShape dv lyt) = VShape <$> vlUnique dv <*> pure lyt nub _ = $impossible number :: Shape VLDVec -> Build VL (Shape VLDVec) number (VShape q lyt) =- VShape <$> vlNumber q <*> (pure $ zipLayout lyt (LCol 1))+ VShape <$> vlNumber q <*> (pure $ LTuple [lyt, LCol]) 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 (VShape dv1 lyt1) (VShape dv2 lyt2) = do -- Append the current vectors- (v, p1, p2) <- vlAppend q1 q2+ (dv12, kv1, kv2) <- vlAppend dv1 dv2 -- Propagate position changes to descriptors of any inner vectors- lyt1' <- renameOuterLyt p1 lyt1- lyt2' <- renameOuterLyt p2 lyt2+ lyt1' <- rekeyOuter kv1 lyt1+ lyt2' <- rekeyOuter kv2 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+ return $ VShape dv12 lyt'+append _ _ = $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 (VShape dv lyt) = do+ (dv', sv) <- vlReverse dv+ lyt' <- sortLayout sv lyt+ return (VShape dv' 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+sort :: Shape VLDVec -> Build VL (Shape VLDVec)+sort (VShape dv (LTuple [xl, sl])) = do+ let leftWidth = columnsInLayout xl+ rightWidth = columnsInLayout sl sortExprs = map Column [leftWidth+1..leftWidth+rightWidth] - -- Sort by all columns from the right vector- (sortedVec, propVec) <- vlSortS sortExprs =<< vlAlign q1 q2+ -- Sort by all sorting columns from the right tuple component+ (dv', sv) <- vlSort sortExprs dv - -- 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+ -- After sorting, discard the sorting criteria columns+ dv'' <- vlProject (map Column [1..leftWidth]) dv'+ xl' <- sortLayout sv xl+ return $ VShape dv'' xl'+sort _e1 = $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+group :: Shape VLDVec -> Build VL (Shape VLDVec)+group (VShape dv (LTuple [lyt1, lyt2])) = do let leftWidth = columnsInLayout lyt1 rightWidth = columnsInLayout lyt2 groupExprs = map Column [leftWidth+1..leftWidth+rightWidth] - (outerVec, innerVec, propVec) <- vlGroupS groupExprs =<< vlAlign q1 q2+ (dvo, dvi, sv) <- vlGroup groupExprs dv -- Discard the grouping columns in the inner vector- innerVec' <- vlProject (map Column [1..leftWidth]) innerVec+ dvi' <- vlProject (map Column [1..leftWidth]) dvi - lyt1' <- chainReorder propVec lyt1- return $ VShape outerVec (LTuple [lyt2, LNest innerVec' lyt1'])-group _e1 _e2 = $impossible+ lyt1' <- sortLayout sv lyt1+ return $ VShape dvo (LTuple [lyt2, LNest dvi' lyt1'])+group _e1 = $impossible length_ :: Shape VLDVec -> Build VL (Shape VLDVec) length_ (VShape q _) = do v <- vlAggr AggrCount q- return $ SShape v (LCol 1)+ return $ SShape v LCol+length_ _ = $impossible -restrict :: Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec)-restrict(VShape q1 lyt) (VShape q2 (LCol 1)) = do+restrict :: Shape VLDVec -> Build VL (Shape VLDVec)+restrict (VShape dv (LTuple [l, LCol])) = 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+ let leftWidth = columnsInLayout l predicate = Column $ leftWidth + 1 -- Filter the vector according to the boolean column- (filteredVec, renameVec) <- vlSelect predicate =<< vlAlign q1 q2+ (dv', fv) <- vlSelect predicate dv -- After the selection, discard the boolean column from the right- resVec <- vlProject (map Column [1..leftWidth]) filteredVec- + dv'' <- vlProject (map Column [1..leftWidth]) dv'+ -- Filter any inner vectors- lyt' <- chainRenameFilter renameVec lyt- return $ VShape resVec lyt'-restrict _e1 _e2 = $impossible+ l' <- filterLayout fv l+ return $ VShape dv'' l'+restrict e1 = trace (show e1) $ $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 (VShape dvb LCol) (VShape dv1 lyt1) (VShape dv2 lyt2) = do+ (dv, kv1, kv2) <- vlCombine dvb dv1 dv2+ lyt1' <- rekeyOuter kv1 lyt1+ lyt2' <- rekeyOuter kv2 lyt2+ lyt' <- appendLayout lyt1' lyt2'+ return $ VShape dv 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]+-- | Distribute a single value in vector 'dv2' over an arbitrary+-- (inner) vector.+distSingleton :: VLDVec -- ^ The singleton outer vector+ -> Layout VLDVec -- ^ The outer vector's layout+ -> VLDVec -- ^ The inner vector distributed over+ -> Build VL (Shape VLDVec)+distSingleton dv1 lyt1 dv2 = do+ let leftWidth = columnsInLayout lyt1+ proj = map Column [1..leftWidth] - (prodVec, _, propVec) <- q1 `vlCartProduct` q2- resVec <- vlProject proj prodVec+ (dv, rv) <- dv1 `vlDistSng` dv2+ dv' <- vlProject proj dv - lyt' <- chainReorder propVec lyt2- return $ shapeCon resVec lyt'+ lyt' <- repLayout rv lyt1+ return $ VShape dv' 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+dist (SShape dv lyt) (VShape dv1 _) = distSingleton dv lyt dv1+dist (VShape dv lyt) (VShape dvo 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+ (prodVec, _, rv) <- vlNestProduct dvo dv+ innerVec <- vlProject innerProj prodVec -- The outer vector does not have columns, it only describes the -- shape.- outerVec <- vlProject [] qo- + outerVec <- vlProject [] dvo+ -- Replicate any inner vectors- lyt' <- chainReorder propVec lyt+ lyt' <- repLayout rv lyt return $ VShape outerVec (LNest innerVec lyt') dist _ _ = $impossible +only :: Shape VLDVec -> Build VL (Shape VLDVec)+only (VShape _ (LNest qi lyti)) = return $ VShape qi lyti+only (VShape q lyt) = return $ SShape q lyt+only _ = $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 afun (VShape q LCol) =+ SShape <$> vlAggr (afun (Column 1)) q <*> pure LCol aggr _ _ = $impossible ifList :: Shape VLDVec -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec)@@ -283,23 +238,23 @@ 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+ VShape trueSelVec _ <- distSingleton qb lytb q1+ (trueVec, truefv) <- 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+ VShape falseSelVec _ <- distSingleton qb lytb q2+ (falseVec, falsefv) <- vlSelect predicate'+ =<< vlAlign q2 falseSelVec+ falseVec' <- vlProject (map Column [1..leftWidth]) falseVec - lyt1' <- renameOuterLyt trueRenameVec lyt1- lyt2' <- renameOuterLyt falseRenameVec lyt2- lyt' <- appendLayout lyt1' lyt2'+ lyt1' <- filterLayout truefv lyt1+ lyt2' <- filterLayout falsefv lyt2+ lyt' <- appendLayout lyt1' lyt2' - (bothBranches, _, _) <- vlAppend trueVec' falseVec'+ (bothBranches, _, _) <- vlAppend trueVec' falseVec' return $ VShape bothBranches lyt' ifList qb (SShape q1 lyt1) (SShape q2 lyt2) = do@@ -309,86 +264,85 @@ tuple :: [Shape VLDVec] -> Build VL (Shape VLDVec) tuple shapes@(_ : _) = do- (q, lyts) <- tupleVectors shapes- let lyts' = zipLayouts lyts- return $ SShape q (LTuple lyts')+ (q, lyts) <- boxVectors shapes+ 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+ _ -> do+ let (lyt', cols) = projectColumns i lyts 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 (VShape _ (LNest q lyt)) = return $ VShape q lyt concat _e = $impossible +onlyL :: Shape VLDVec -> Build VL (Shape VLDVec)+onlyL (VShape dvo (LNest dvi lyt)) = do+ (dv, kv) <- vlUnboxSng dvo dvi+ lyt' <- rekeyOuter kv lyt+ return $ VShape dv lyt'+onlyL _ = $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))+binOpL :: L.ScalarBinOp -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec)+binOpL o (VShape dv1 _) (VShape dv2 _) = do+ dv <- vlProject [BinApp o (Column 1) (Column 2)] =<< vlAlign dv1 dv2+ return $ VShape dv LCol+binOpL _ _ _ = $impossible++restrictL :: Shape VLDVec -> Build VL (Shape VLDVec)+restrictL (VShape qo (LNest qi lyt)) = do+ VShape qi' lyt' <- restrict (VShape qi lyt) return $ VShape qo (LNest qi' lyt')-restrictL l1 l2 =- trace (show l1 ++ " " ++ show l2) $ $impossible+restrictL l1 = trace (show l1) $ $impossible combineL :: Shape VLDVec -> Shape VLDVec -> Shape VLDVec -> Build VL (Shape VLDVec)-combineL (VShape qo (LNest qb (LCol 1)))+combineL (VShape qo (LNest qb LCol)) (VShape _ (LNest qi1 lyt1)) (VShape _ (LNest qi2 lyt2)) = do- VShape qi' lyt' <- combine (VShape qb (LCol 1)) (VShape qi1 lyt1) (VShape qi2 lyt2)+ VShape qi' lyt' <- combine (VShape qb LCol) (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')+ lyt1' <- rekeyLayout r1 lyt1+ lyt2' <- rekeyLayout r2 lyt2+ return $ VShape d1 (LNest q' $ LTuple [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 (VShape dvo1 (LNest dvi1 lyt1)) (VShape _ (LNest dvi2 lyt2)) = do+ (dv, rv1, rv2) <- vlCartProductS dvi1 dvi2+ lyt1' <- repLayout rv1 lyt1+ lyt2' <- repLayout rv2 lyt2+ return $ VShape dvo1 (LNest dv $ LTuple [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 (VShape dvo1 (LNest dvi1 lyt1)) (VShape _dvo2 (LNest dvi2 lyt2)) = do+ (dvi, rv1, rv2) <- vlNestProductS dvi1 dvi2+ lyt1' <- repLayout rv1 lyt1+ lyt2' <- repLayout rv2 lyt2+ let lyt = LTuple [lyt1', lyt2']+ return $ VShape dvo1 (LNest dvi1 (LTuple [lyt1, (LNest dvi lyt)])) 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 joinPred (VShape dvo1 (LNest dvi1 lyt1)) (VShape _ (LNest dvi2 lyt2)) = do+ (dvi, rv1, rv2) <- vlThetaJoinS joinPred dvi1 dvi2+ lyt1' <- repLayout rv1 lyt1+ lyt2' <- repLayout rv2 lyt2+ return $ VShape dvo1 (LNest dvi $ LTuple [lyt1', lyt2']) thetaJoinL _ _ _ = $impossible -- △^L :: [[a]] -> [[b]] -> [[(a, [(a, b)])]]@@ -399,29 +353,28 @@ -- 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 joinPred (VShape dvo1 (LNest dvi1 lyt1)) (VShape _ (LNest dvi2 lyt2)) = do+ (dv, rv1, rv2) <- vlNestJoinS joinPred dvi1 dvi2+ lyt1' <- repLayout rv1 lyt1+ lyt2' <- repLayout rv2 lyt2+ let lyt = LTuple [lyt1', lyt2']+ return $ VShape dvo1 (LNest dvo1 (LTuple [lyt1, LNest dv lyt])) 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 joinPred (VShape dvo1 (LNest dvi1 lyt1)) (VShape _ (LNest dvi2 _)) = do+ (dv, fv) <- vlSemiJoinS joinPred dvi1 dvi2+ lyt1' <- filterLayout fv lyt1+ return $ VShape dvo1 (LNest dv 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 joinPred (VShape dvo1 (LNest dvi1 lyt1)) (VShape _ (LNest dvi2 _)) = do+ (dv, fv) <- vlAntiJoinS joinPred dvi1 dvi2+ lyt1' <- filterLayout fv lyt1+ return $ VShape dvo1 (LNest dv 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@@ -429,101 +382,65 @@ numberL :: Shape VLDVec -> Build VL (Shape VLDVec) numberL (VShape d (LNest q lyt)) = VShape d <$> (LNest <$> vlNumberS q- <*> (pure $ zipLayout lyt (LCol 1)))+ <*> (pure $ LTuple [lyt, LCol])) 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 (VShape dvo (LNest dvi lyt)) = do+ (dv, sv) <- vlReverseS dvi+ lyt' <- sortLayout sv lyt+ return (VShape dvo (LNest dv 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+sortL :: Shape VLDVec -> Build VL (Shape VLDVec)+sortL (VShape dvo (LNest dvi (LTuple [xl, sl]))) = do+ let leftWidth = columnsInLayout xl+ rightWidth = columnsInLayout sl -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+ sortExprs = map Column [leftWidth+1..leftWidth+rightWidth] -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+ -- Sort by all sorting columns from the right tuple component+ (sortedVec, sv) <- vlSortS sortExprs dvi -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+ -- After sorting, discard the sorting criteria columns+ resVec <- vlProject (map Column [1..leftWidth]) sortedVec+ xl' <- sortLayout sv xl+ return $ VShape dvo (LNest resVec xl')+sortL _ = $impossible +groupL :: Shape VLDVec -> Build VL (Shape VLDVec)+groupL (VShape dvo (LNest dvi (LTuple [xl, gl]))) = do+ let leftWidth = columnsInLayout xl+ rightWidth = columnsInLayout gl++ groupExprs = map Column [leftWidth+1..leftWidth+rightWidth]++ (dvo', dvi', rv) <- vlGroupS groupExprs dvi++ -- Discard the grouping columns in the inner vector+ dvi'' <- vlProject (map Column [1..leftWidth]) dvi'++ xl' <- sortLayout rv xl+ return $ VShape dvo (LNest dvo' (LTuple [gl, LNest dvi'' xl']))+groupL _ = $impossible+ concatL :: Shape VLDVec -> Build VL (Shape VLDVec) concatL (VShape d (LNest d' vs)) = do- p <- vlUnboxRename d'- vs' <- renameOuterLyt p vs+ p <- vlUnboxKey d'+ vs' <- rekeyOuter 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)+ lsu <- fst <$> vlUnboxSng q ls+ return $ VShape lsu LCol lengthL s = trace (show s) $ $impossible outer :: Shape VLDVec -> Build VL VLDVec@@ -531,85 +448,67 @@ outer (VShape q _) = return q aggrL :: (Expr -> AggrFun) -> Shape VLDVec -> Build VL (Shape VLDVec)-aggrL afun (VShape d (LNest q (LCol 1))) = do+aggrL afun (VShape d (LNest q LCol)) = do qr <- vlAggrS (afun (Column 1)) d q- qu <- vlUnboxScalar d qr- return $ VShape qu (LCol 1)+ qu <- fst <$> vlUnboxSng d qr+ return $ VShape qu LCol 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 (VShape dv1 lyt1) (VShape dvo2 (LNest dvi2 lyt2)) = do+ (dv, rv) <- vlDistLift dv1 dvi2+ lyt1' <- repLayout rv lyt1+ let lyt = LTuple [lyt1', lyt2]+ VShape dv' lytf <- tupElemL First $ VShape dv lyt+ return $ VShape dvo2 (LNest dv' 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')+ (q, lyts) <- alignVectors shapes+ 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)+ let (lyt', cols) = projectColumns i lyts 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+projectColumns :: TupleIndex -> [Layout VLDVec] -> (Layout VLDVec, [DBCol])+projectColumns i lyts =+ let (prefixLyts, lyt : _) = splitAt (tupleIndex i - 1) lyts+ lytWidth = columnsInLayout lyt+ prefixWidth = sum $ map columnsInLayout prefixLyts+ in (lyt, [ c + prefixWidth | c <- [1..lytWidth] ]) singleton :: Shape VLDVec -> Build VL (Shape VLDVec) singleton (VShape q lyt) = do- VLDVec d <- vlSingletonDescr- return $ VShape (VLDVec d) (LNest q lyt)+ (dvo, dvi) <- vlNest q+ return $ VShape dvo (LNest dvi 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)+ (dvo, dvi) <- vlSegment q+ return $ VShape dvo (LNest dvi 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]])+dbTable :: String -> L.BaseTableSchema -> Build VL (Shape VLDVec)+dbTable n schema = do+ tab <- vlTableRef n schema+ -- Single-column tables are represented by a flat list and map to+ -- a flat one-column layout. Multi-column tables map to a list of+ -- tuples and the corresponding tuple layout.+ let lyt = case L.tableCols schema of+ _ N.:| [] -> LCol+ cs -> LTuple $ map (const LCol) $ N.toList cs+ return $ VShape tab lyt -- | Create a VL representation of a literal value. mkLiteral :: Type -> L.Val -> Build VL (Shape VLDVec)@@ -628,7 +527,7 @@ litNode <- vlLit L.NonEmpty (P.reverse tabTys) [(P.reverse tabCols)] return $ SShape litNode layout -type Table = ([Type], [[VLVal]])+type Table = ([Type], [[L.ScalarVal]]) -- | Add values to a vector. If necessary (i.e. inner lists are -- encountered), create new inner vectors. 'toPlan' receives a@@ -636,7 +535,7 @@ -- are currently encoded. -- FIXME Check if inner list literals are nonempty and flag VL--- literals appropriately. +-- 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@@ -659,11 +558,11 @@ mkTupleTable (tabTys, tabCols) nextCol [] colsVals elemTys _ -> let (hd, vs) = mkColumn t es- in return ((hd:tabTys, zipWith (:) vs tabCols), (LCol nextCol), nextCol + 1)+ in return ((hd:tabTys, zipWith (:) vs tabCols), LCol, 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)+ in return $ ((hd:tabTys, zipWith (:) v' tabCols), LCol, c + 1) -- | Construct the literal table for a list of tuples. mkTupleTable :: Table -- ^ The literal table so far.@@ -679,8 +578,8 @@ 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]]+literal :: Type -> L.ScalarVal -> Build VL VLDVec+literal t v = vlLit L.NonEmpty [t] [[L.IntV 1, L.IntV 1, v]] listElems :: L.Val -> [L.Val] listElems (L.ListV es) = es@@ -690,14 +589,14 @@ tupleElems (L.TupleV es) = es tupleElems _ = $impossible -mkColumn :: Type -> [L.Val] -> (Type, [VLVal])+mkColumn :: Type -> [L.Val] -> (Type, [L.ScalarVal]) 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 ] + body = [ [L.IntV $ fromInteger p, L.IntV $ fromInteger d]+ | d <- P.concat [ replicate l p | p <- [1..] | l <- lengths ] | p <- [1..] ] in (header, body)@@ -705,48 +604,36 @@ -------------------------------------------------------------------------------- -- 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+-- | Simply align a list of shapes and collect their layouts.+alignVectors :: [Shape VLDVec] -> Build VL (VLDVec, [Layout VLDVec])+alignVectors (VShape q1 lyt1 : []) = return (q1, [lyt1])+alignVectors (VShape q1 lyt1 : shapes) = do+ (q, lyts) <- alignVectors shapes qz' <- vlAlign q1 q return (qz', lyt1 : lyts)-zipVectors _ = $impossible+alignVectors _ = $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+-- | Align a list of shapes and nest vectors if necessary. This helper+-- function covers tuple construction in the unlifted case.+boxVectors :: [Shape VLDVec] -> Build VL (VLDVec, [Layout VLDVec])+boxVectors (SShape q1 lyt1 : []) = return (q1, [lyt1])+boxVectors (VShape q1 lyt1 : []) = do+ (dvo, dvi) <- vlNest q1+ return (dvo, [LNest dvi lyt1])+boxVectors (SShape dv1 lyt1 : shapes) = do+ (dv, lyts) <- boxVectors shapes+ (dv', rv1, rv2) <- vlCartProduct dv1 dv+ lyt1' <- repLayout rv1 lyt1+ lyts' <- mapM (repLayout rv2) lyts+ return (dv', lyt1' : lyts')+boxVectors (VShape dv1 lyt1 : shapes) = do+ (dv, lyts) <- boxVectors shapes+ (dvo, dvi) <- vlNest dv1+ (dv', rv1, rv2) <- vlCartProduct dvo dv+ lyt1' <- repLayout rv1 (LNest dvi lyt1)+ lyts' <- mapM (repLayout rv2) lyts+ return (dv', lyt1' : lyts')+boxVectors s = error $ show s -------------------------------------------------------------------------------- -- Compile-time operations that implement higher-lifted primitives.@@ -785,77 +672,51 @@ -------------------------------------------------------------------------------- -- 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+appLayout :: v+ -> (v -> VLDVec -> Build VL (VLDVec, v))+ -> Layout VLDVec+ -> Build VL (Layout VLDVec)+appLayout _ _ LCol = return LCol+appLayout v appVec (LNest d l) = do+ (d', v') <- appVec v d+ l' <- appLayout v' appVec l+ return $ LNest d' l'+appLayout v appVec (LTuple ls) =+ LTuple <$> mapM (appLayout v appVec) ls --- | 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+filterLayout :: VLFVec -> Layout VLDVec -> Build VL (Layout VLDVec)+filterLayout v l = appLayout v vlAppFilter l --- | 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+repLayout :: VLRVec -> Layout VLDVec -> Build VL (Layout VLDVec)+repLayout v l = appLayout v vlAppRep l --- | 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"+sortLayout :: VLSVec -> Layout VLDVec -> Build VL (Layout VLDVec)+sortLayout v l = appLayout v vlAppSort l -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+rekeyLayout :: VLKVec -> Layout VLDVec -> Build VL (Layout VLDVec)+rekeyLayout v l = appLayout v vlAppKey l --- | 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+-- | Apply a rekeying vector to the outermost nested vectors in the+-- layout.+rekeyOuter :: VLKVec -> Layout VLDVec -> Build VL (Layout VLDVec)+rekeyOuter _ LCol = return LCol+rekeyOuter r (LNest q lyt) = LNest <$> (fst <$> vlAppKey r q) <*> pure lyt+rekeyOuter r (LTuple lyts) = LTuple <$> mapM (rekeyOuter r) lyts -- | 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"+appendLayout LCol LCol = return LCol -- 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 (LNest dv1 lyt1) (LNest dv2 lyt2) = do+ -- Append the current vectors+ (dv12, kv1, kv2) <- vlAppendS dv1 dv2+ -- Propagate position changes to descriptors of any inner vectors+ lyt1' <- rekeyOuter kv1 lyt1+ lyt2' <- rekeyOuter kv2 lyt2+ -- Append the layouts, i.e. actually append all inner vectors+ lyt' <- appendLayout lyt1' lyt2'+ return $ LNest dv12 lyt' appendLayout (LTuple lyts1) (LTuple lyts2) = LTuple <$> (sequence $ zipWith appendLayout lyts1 lyts2) appendLayout _ _ = $impossible
− tests/CombinatorTests.hs
@@ -1,1241 +0,0 @@-{-# 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
@@ -1,526 +0,0 @@-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
@@ -1,384 +0,0 @@-{-# 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
@@ -1,60 +0,0 @@-{-# 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--#ifdef TESTSQL-import Database.HDBC.PostgreSQL-#endif--import System.Environment-import Test.Framework (Test, defaultMainWithArgs)-import Test.QuickCheck--import Data.List---#ifdef TESTSQL-getConn :: IO Connection-getConn = connectPostgreSQL "user = 'au' password = 'foobar' host = 'localhost' dbname = 'test'"-#endif--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- args <- getArgs- let args' = if or $ map (isPrefixOf "-s") args- then args- else "-s5":args- defaultMainWithArgs tests args'--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- ]