project-m36 0.9.9 → 1.0.0

raw patch · 93 files changed

+4942/−389 lines, 93 filesdep ~aesondep ~basedep ~base16-bytestringnew-component:exe:sqlegacyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, base, base16-bytestring, cassava, curryer-rpc, ghc, megaparsec, scotty, stm-containers, uuid, winery

API changes (from Hackage documentation)

Files

• Changelog.markdown +5/−0
• README.markdown +13/−4
• examples/Plantfarm.hs +2/−1
• examples/blog.hs +4/−4
• examples/hair.hs +1/−1
• examples/out_of_the_tarpit.hs +1/−1
• project-m36.cabal +125/−16
• scripts/DateExamples.tutd +26/−0
• scripts/multiline.tutd +2/−0
• src/bin/ProjectM36/Cli.hs +143/−0
• src/bin/ProjectM36/Interpreter.hs +61/−0
• src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +98/−0
• src/bin/ProjectM36/Server/WebSocket.hs +9/−2
• src/bin/SQL/Interpreter.hs +109/−0
• src/bin/SQL/Interpreter/Base.hs +92/−0
• src/bin/SQL/Interpreter/CreateTable.hs +61/−0
• src/bin/SQL/Interpreter/DBUpdate.hs +20/−0
• src/bin/SQL/Interpreter/Delete.hs +15/−0
• src/bin/SQL/Interpreter/DropTable.hs +10/−0
• src/bin/SQL/Interpreter/ImportBasicExample.hs +12/−0
• src/bin/SQL/Interpreter/Info.hs +9/−0
• src/bin/SQL/Interpreter/Insert.hs +15/−0
• src/bin/SQL/Interpreter/Select.hs +376/−0
• src/bin/SQL/Interpreter/TransactionGraphOperator.hs +20/−0
• src/bin/SQL/Interpreter/Update.hs +26/−0
• src/bin/SQL/Interpreter/sqlegacy.hs +49/−0
• src/bin/TutorialD/Interpreter.hs +9/−46
• src/bin/TutorialD/Interpreter/Base.hs +2/−57
• src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +3/−1
• src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +1/−0
• src/bin/TutorialD/Interpreter/Export/CSV.hs +1/−0
• src/bin/TutorialD/Interpreter/Import/BasicExamples.hs +1/−0
• src/bin/TutorialD/Interpreter/Import/CSV.hs +1/−0
• src/bin/TutorialD/Interpreter/Import/TutorialD.hs +1/−0
• src/bin/TutorialD/Interpreter/InformationOperator.hs +1/−0
• src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +12/−9
• src/bin/TutorialD/Interpreter/RelationalExpr.hs +38/−13
• src/bin/TutorialD/Interpreter/SchemaOperator.hs +1/−0
• src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs +2/−1
• src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +1/−0
• src/bin/TutorialD/Interpreter/Types.hs +6/−1
• src/bin/TutorialD/Printer.hs +108/−9
• src/bin/TutorialD/tutd.hs +7/−94
• src/bin/benchmark/Basic.hs +9/−13
• src/bin/benchmark/Handles.hs +4/−3
• src/bin/benchmark/OnDiskClient.hs +1/−1
• src/bin/benchmark/Server.hs +1/−1
• src/lib/ProjectM36/AtomFunctions/Primitive.hs +36/−1
• src/lib/ProjectM36/Atomable.hs +1/−1
• src/lib/ProjectM36/Attribute.hs +9/−1
• src/lib/ProjectM36/AttributeNames.hs +16/−0
• src/lib/ProjectM36/Base.hs +17/−13
• src/lib/ProjectM36/Client.hs +51/−6
• src/lib/ProjectM36/DataFrame.hs +36/−13
• src/lib/ProjectM36/DataTypes/SQL/Null.hs +329/−0
• src/lib/ProjectM36/DatabaseContext.hs +6/−0
• src/lib/ProjectM36/Error.hs +31/−1
• src/lib/ProjectM36/HashSecurely.hs +10/−4
• src/lib/ProjectM36/InclusionDependency.hs +12/−1
• src/lib/ProjectM36/IsomorphicSchema.hs +1/−1
• src/lib/ProjectM36/Key.hs +5/−2
• src/lib/ProjectM36/NormalizeExpr.hs +5/−2
• src/lib/ProjectM36/ReferencedTransactionIds.hs +144/−0
• src/lib/ProjectM36/Relation.hs +11/−4
• src/lib/ProjectM36/RelationalExpression.hs +113/−12
• src/lib/ProjectM36/SQL/Convert.hs +1499/−0
• src/lib/ProjectM36/SQL/CreateTable.hs +33/−0
• src/lib/ProjectM36/SQL/DBUpdate.hs +21/−0
• src/lib/ProjectM36/SQL/Delete.hs +12/−0
• src/lib/ProjectM36/SQL/DropTable.hs +14/−0
• src/lib/ProjectM36/SQL/Insert.hs +16/−0
• src/lib/ProjectM36/SQL/Select.hs +267/−0
• src/lib/ProjectM36/SQL/Update.hs +19/−0
• src/lib/ProjectM36/SQLDatabaseContext.hs +13/−0
• src/lib/ProjectM36/Serialise/Error.hs +1/−0
• src/lib/ProjectM36/Server.hs +8/−2
• src/lib/ProjectM36/Server/EntryPoints.hs +8/−0
• src/lib/ProjectM36/Server/RemoteCallTypes.hs +8/−0
• src/lib/ProjectM36/Shortcuts.hs +1/−2
• src/lib/ProjectM36/StaticOptimizer.hs +42/−8
• src/lib/ProjectM36/TransGraphRelationalExpression.hs +5/−2
• src/lib/ProjectM36/TransactionGraph.hs +31/−9
• src/lib/ProjectM36/TransactionGraph/Merge.hs +4/−4
• src/lib/ProjectM36/WithNameExpr.hs +31/−8
• test/Client/Simple.hs +3/−3
• test/MultiProcessDatabaseAccess.hs +1/−1
• test/SQL/InterpreterTest.hs +514/−0
• test/TransactionGraph/Automerge.hs +1/−1
• test/TransactionGraph/Merge.hs +2/−2
• test/TransactionGraph/Persist.hs +1/−1
• test/TutorialD/Interpreter/TestBase.hs +24/−2
• test/TutorialD/InterpreterTest.hs +15/−3
• test/TutorialD/PrinterTest.hs +1/−1

@@ -1,3 +1,8 @@+# 2024-06-06 (v1.0.0)++* add support for relational expression evaluation against sub-relations+* add support for SQL dialect and console called "SQLegacy"+ # 2024-01-12 (v0.9.9)  * revert to using streamly 0.9.0 due to over-the-wire corruption bug in 0.10.0

@@ -12,14 +12,16 @@  ## Introduction -Project:M36 implements a relational algebra engine as inspired by the writings of Chris Date.+Project:M36 implements a relational algebra engine as inspired by the writings of Chris Date. Project:M36 supports both SQL and TutorialD interactive access.  ## Quick Install -Project:M36 can be downloaded and run via docker, which supports Windows 10, macOS, and Linux.+Project:M36 can be downloaded and run via docker, which supports Windows 10+, macOS, and Linux. -Run `docker run -it projectm36/project-m36 tutd` to start the TutorialD command line interface.+Run `docker run -it projectm36/project-m36 tutd` to start the [TutorialD](docs/tutd_tutorial.markdown) command line interface. +Run `docker run -it projectm36/project-m36 sqlegacy` to start the [SQLegacy](docs/sqlegacy.markdown) (SQL dialect) command line interface.+ ## Description  Unlike most database management systems (DBMS), Project:M36 is opinionated software which adheres strictly to the mathematics of the relational algebra. The purpose of this adherence is to prove that software which implements mathematically-sound design principles reaps benefits in the form of code clarity, consistency, performance, and future-proofing.@@ -37,6 +39,7 @@ Project:M36 supports multiple frontends which target different audiences.  * learn about the relational algebra via TutorialD+* use SQLegacy to learn how SQL differs from the relational algebra * store and manipulate databases * use Project:M36 as a native Haskell database backend @@ -68,7 +71,13 @@ 1. [ACID Database Properties](docs/acid_assessment.markdown) 1. [On NULL (in SQL)](docs/on_null.markdown) 1. [Reaching "Out of the Tarpit" with Project:M36](docs/reaching_out_of_the_tarpit.markdown)-1. [An Architecture for Data Independence](docs/data_independence.markdown)+1. [An Architecture for Data Independence](docs/data_independence.markdown)'+++### SQL Support++1. [Why SQLegacy?](docs/why_sqlegacy.markdown)+1. [SQLegacy Documentation](docs/sqlegacy.markdown)  ### Advanced Features 

@@ -17,6 +17,7 @@ import qualified Data.Text.Lazy as TL (pack) import GHC.Generics (Generic) import qualified ProjectM36.Base as Base+import ProjectM36.DatabaseContext import ProjectM36.Client        ( AtomExprBase(NakedAtomExpr)        , Atomable(toAddTypeExpr, toAtom)@@ -354,7 +355,7 @@ dbConnection :: IO DBConnection dbConnection = do   --  connect to the database-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext   --  The code below persists the data in a DB with the name "base". \\ --  let connInfo = InProcessConnectionInfo (CrashSafePersistence "base") emptyNotificationCallback [] \\   --  In addition minimal persistance is available. \\

@@ -76,7 +76,7 @@ main :: IO ()                        main = do   --connect to the database-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext   conn <- handleIOError $ connectProjectM36 connInfo      sessionId <- handleIOError $ createSessionAtHead conn "master"@@ -154,7 +154,7 @@ --display one blog post along with its comments showBlogEntry :: SessionId -> Connection -> ActionM () showBlogEntry sessionId conn = do-  blogid <- param "blogid"+  blogid <- pathParam "blogid"   --query the database to return the blog entry with a relation-valued attribute of the associated comments   let blogRestrictionExpr = AttributeEqualityPredicate "title" (NakedAtomExpr (TextAtom blogid))       extendExpr = AttributeExtendTupleExpr "comments" (RelationAtomExpr commentsRestriction)@@ -204,8 +204,8 @@ --add a comment to a blog post addComment :: SessionId -> Connection -> ActionM ()             addComment sessionId conn = do-  blogid <- param "blogid"-  commentText <- param "contents"+  blogid <- pathParam "blogid"+  commentText <- formParam "contents"   now <- liftIO getCurrentTime      case toInsertExpr [Comment {blogTitle = blogid,

@@ -16,7 +16,7 @@ main :: IO () main = do  --connect to the database-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext       eCheck v = do         x <- v         case x of 

@@ -39,7 +39,7 @@ main :: IO () main = do   --connect to the database-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext       check x = case x of          Left err -> error (show err)         Right x' -> x'

@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36-Version: 0.9.9+Version: 1.0.0 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple@@ -12,7 +12,8 @@ Maintainer: agentm@themactionfaction.com Synopsis: Relational Algebra Engine Description: A relational algebra engine which can be used to persist and query Haskell data types.-Extra-Source-Files: Changelog.markdown README.markdown+Extra-Source-Files: Changelog.markdown README.markdown scripts/DateExamples.tutd scripts/multiline.tutd+tested-with: GHC ==9.2.8 || ==9.4.8  Source-Repository head     Type: git@@ -35,7 +36,7 @@      Default: True  Library-    Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.4, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific+    Build-Depends: base>=4.16 && < 4.19, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.3.5, network, async, vector-instances, recursion-schemes, streamly == 0.9.0, convertible, fast-builder, scientific     if flag(haskell-scripting)         Build-Depends: ghc >= 9.0 && < 9.5         CPP-Options: -DPM36_HASKELL_SCRIPTING@@ -107,6 +108,8 @@                      ProjectM36.DataTypes.Primitive,                      ProjectM36.DataTypes.Interval,                      ProjectM36.DataTypes.ByteString,+                     ProjectM36.DataTypes.SQL.Null,+                     ProjectM36.SQLDatabaseContext,                      ProjectM36.MiscUtils,                      ProjectM36.Notifications,                      ProjectM36.Relation,@@ -134,7 +137,16 @@                      ProjectM36.Trace,                      ProjectM36.HashSecurely,                      ProjectM36.DDLType,-                     ProjectM36.RegisteredQuery+                     ProjectM36.RegisteredQuery,+                     ProjectM36.SQL.Convert,+                     ProjectM36.SQL.Select,+                     ProjectM36.SQL.Update,+                     ProjectM36.SQL.Insert,+                     ProjectM36.SQL.Delete,+                     ProjectM36.SQL.DBUpdate,+                     ProjectM36.SQL.CreateTable,+                     ProjectM36.SQL.DropTable+                     ProjectM36.ReferencedTransactionIds     GHC-Options: -Wall -rdynamic     if os(windows)       Build-Depends: Win32 >= 2.12@@ -195,7 +207,8 @@                    base16-bytestring >= 1.0.0.0,                    http-conduit,                    modern-uri,-                   http-types+                   http-types,+                   recursion-schemes     Other-Modules: TutorialD.Interpreter,                    TutorialD.Interpreter.Base,                    TutorialD.Interpreter.DatabaseContextExpr,@@ -211,9 +224,11 @@                    TutorialD.Interpreter.Import.TutorialD,                    TutorialD.Interpreter.RelationalExpr,                    TutorialD.Interpreter.Types,-                   TutorialD.Interpreter.SchemaOperator,                    TutorialD.Interpreter.TransGraphRelationalOperator,-                   TutorialD.Printer+                   TutorialD.Interpreter.SchemaOperator,+                   TutorialD.Printer,+                   ProjectM36.Cli,+                   ProjectM36.Interpreter     main-is: TutorialD/tutd.hs     CC-Options: -fPIC     if os(windows)@@ -226,6 +241,80 @@     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings +Executable sqlegacy+    if flag(haskell-scripting)+        Build-Depends: ghc >= 9.0 && < 9.5+    Build-Depends: base,+                   ghc-paths,+                   project-m36,+                   containers,+                   unordered-containers,+                   hashable,+                   transformers,+                   semigroups,+                   mtl,+                   uuid,+                   deepseq-generics,+                   MonadRandom, MonadRandom,+                   vector,+                   text,+                   time,+                   bytestring,+                   stm,+                   deepseq,+                   data-interval,+                   parallel,+                   cassava,+                   gnuplot,+                   directory,+                   filepath,+                   temporary,+                   megaparsec >= 5.2.0 && < 10,+                   haskeline,+                   random, MonadRandom,+                   base64-bytestring,+                   optparse-applicative,+                   attoparsec,+                   stm-containers >= 1.0.0,+                   list-t,+                   parser-combinators,+                   curryer-rpc,+                   prettyprinter,+                   cryptohash-sha256,+                   --due to decode signature change+                   base16-bytestring >= 1.0.0.0,+                   http-conduit,+                   modern-uri,+                   http-types,+                   recursion-schemes,+    Other-Modules: SQL.Interpreter.Base,+                   SQL.Interpreter.Select,+                   ProjectM36.Cli,+                   ProjectM36.Interpreter,+                   SQL.Interpreter,+                   SQL.Interpreter.TransactionGraphOperator,+                   SQL.Interpreter.ImportBasicExample,+                   SQL.Interpreter.Update,+                   SQL.Interpreter.Insert,+                   SQL.Interpreter.Delete,                   +                   SQL.Interpreter.DBUpdate,+                   SQL.Interpreter.CreateTable,+                   SQL.Interpreter.DropTable,+                   SQL.Interpreter.Info,+                   TutorialD.Printer,+                   TutorialD.Interpreter.Base+                   +    Main-Is: ./SQL/Interpreter/sqlegacy.hs+    if os(windows)+      GHC-Options: -Wall -threaded -rtsopts+    else+      GHC-Options: -Wall -threaded -rtsopts -rdynamic+    if flag(profiler)+      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall+    Hs-Source-Dirs: ./src/bin      +    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+ Executable project-m36-server     if flag(haskell-scripting)         Build-Depends: ghc >= 9.0 && < 9.5@@ -273,7 +362,8 @@     Other-Modules: TutorialD.Interpreter.Base,                    TutorialD.Interpreter.DatabaseContextExpr,                    TutorialD.Interpreter.RelationalExpr,-                   TutorialD.Interpreter.Types+                   TutorialD.Interpreter.Types,+                   ProjectM36.Interpreter     main-is: benchmark/bigrel.hs     GHC-Options: -Wall -threaded -rtsopts     HS-Source-Dirs: ./src/bin@@ -310,23 +400,37 @@   if flag(profiler)     GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall -fexternal-interpreter +Test-Suite test-sql+    import: commontest+    type: exitcode-stdio-1.0+    main-is: SQL/InterpreterTest.hs+    Other-Modules: SQL.Interpreter.Select, SQL.Interpreter.Base, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RODatabaseContextOperator, ProjectM36.Interpreter, SQL.Interpreter.CreateTable+                   TutorialD.Printer,+                   SQL.Interpreter.DBUpdate,+                   SQL.Interpreter.Delete,+                   SQL.Interpreter.DropTable,+                   SQL.Interpreter.Insert,+                   SQL.Interpreter.Update++    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific, recursion-schemes+     Test-Suite test-tutoriald     import: commontest     type: exitcode-stdio-1.0     main-is: TutorialD/InterpreterTest.hs-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter     Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific  Test-Suite test-tutoriald-atomfunctionscript     import: commontest     type: exitcode-stdio-1.0-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter     main-is: TutorialD/Interpreter/AtomFunctionScript.hs  Test-Suite test-tutoriald-databasecontextfunctionscript     import: commontest     type: exitcode-stdio-1.0-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter     main-is: TutorialD/Interpreter/DatabaseContextFunctionScript.hs  Test-Suite test-relation@@ -376,6 +480,7 @@  benchmark bench     import: commontest+    build-depends: criterion     type: exitcode-stdio-1.0     main-is: benchmark/Relation.hs @@ -407,7 +512,7 @@ Executable Example-Blog     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty >= 0.22, blaze-html, http-types, winery     Main-Is: examples/blog.hs     GHC-Options: -Wall -threaded @@ -421,7 +526,7 @@ Executable Example-Plantfarm     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends:  aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty, text, winery+    Build-Depends:  aeson, barbies, base, containers, deepseq, hashable, project-m36, random, scotty >= 0.22, text, winery     Main-Is: examples/Plantfarm.hs     GHC-Options: -Wall -threaded @@ -452,7 +557,7 @@     Default-Language: Haskell2010     Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls, scientific     Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs-    Other-Modules:  ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer+    Other-Modules:  ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer, ProjectM36.Interpreter     GHC-Options: -Wall -threaded     Hs-Source-Dirs: ./src/bin     Default-Extensions: OverloadedStrings@@ -518,7 +623,8 @@       TutorialD.Interpreter.TransGraphRelationalOperator,       TutorialD.Interpreter.TransactionGraphOperator,       TutorialD.Interpreter.Types,-      TutorialD.Printer+      TutorialD.Printer,+      ProjectM36.Interpreter     GHC-Options: -Wall -threaded -rtsopts     HS-Source-Dirs: ./src/bin     if flag(profiler)@@ -528,4 +634,7 @@     import: commontest     type: exitcode-stdio-1.0     Main-Is: DataFrame.hs-    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr,  TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr,  TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer, ProjectM36.Interpreter+++  

@@ -0,0 +1,26 @@+s := relation{tuple{s# "S1",sname "Smith",status 20, city "London"}, +              tuple{s# "S2",sname "Jones",status 10,city "Paris"}, +	      tuple{s# "S3",sname "Blake",status 30,city "Paris"}, +	      tuple{s# "S4",sname "Clark",status 20,city "London"}, +	      tuple{s# "S5",sname "Adams",status 30,city "Athens"}};+p := relation{tuple{p# "P1",pname "Nut",color "Red",weight 12,city "London"}, +              tuple{p# "P2",pname "Bolt",color "Green",weight 17,city "Paris"}, +	      tuple{p# "P3",pname "Screw",color "Blue",weight 17,city "Oslo"}, +	      tuple{p# "P4",pname "Screw",color "Red",weight 14,city "London"}, +	      tuple{p# "P5",pname "Cam",color "Blue",weight 12,city "Paris"}, +	      tuple{p# "P6", pname "Cog", color "Red",weight 19,city "London"}};+sp := relation{tuple{s# "S1",p# "P1",qty 300}, +      	       tuple{s# "S1",p# "P2",qty 200}, +	       tuple{s# "S1",p# "P3",qty 400}, +	       tuple{s# "S1",p# "P4",qty 200}, +	       tuple{s# "S1",p# "P5",qty 100}, +	       tuple{s# "S1",p# "P6",qty 100}, +	       tuple{s# "S2",p# "P1",qty 300}, +	       tuple{s# "S2",p# "P2",qty 400}, +	       tuple{s# "S3",p# "P2",qty 200}, +	       tuple{s# "S4",p# "P4",qty 300}, +	       tuple{s# "S4",p# "P5",qty 400}};+key s_pkey {s#} s;+key p_key {p#} p;+foreign key s_sp_fk sp{s#} in s{s#};+foreign key p_sp_fk sp{p#} in p{p#};

@@ -0,0 +1,2 @@+x:=relation{ +tuple{  x 2}} -- nice

@@ -0,0 +1,143 @@+{-# LANGUAGE LambdaCase #-}+-- functions common to both tutd and sqlegacy command line interfaces+module ProjectM36.Cli where+import qualified ProjectM36.Client as C+import qualified Data.Text as T+import ProjectM36.Base+import System.Console.Haskeline+import Control.Exception+import System.IO+import ProjectM36.Relation.Show.Term -- probably want to display dataframes instead+import ProjectM36.Error+import Options.Applicative +import ProjectM36.Server.ParseArgs+import ProjectM36.Server (checkFSType, checkFSErrorMsg)+import Data.Maybe (fromMaybe)+import GHC.IO.Encoding+import Control.Monad (when)+import System.Exit+import Text.Megaparsec.Error+import Data.Void (Void)+import ProjectM36.Interpreter hiding (Parser)++type GhcPkgPath = String+type TutorialDExec = String+type CheckFS = Bool++type DirectExecute = String+type ParserError = ParseErrorBundle T.Text Void++data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe DirectExecute) [GhcPkgPath] CheckFS |+                         RemoteInterpreterConfig C.Hostname C.Port C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS++outputNotificationCallback :: C.NotificationCallback+outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot++prettyEvaluatedNotification :: C.EvaluatedNotification -> String+prettyEvaluatedNotification eNotif = let eRelShow eRel = case eRel of+                                           Left err -> show err+                                           Right reportRel -> T.unpack (showRelation reportRel) in+  eRelShow (C.reportOldRelation eNotif) <> "\n" <> eRelShow (C.reportNewRelation eNotif)++type ReprLoopEvaluator = C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO ()+type MakePrompt = Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType+type HistoryFilePath = FilePath+  +reprLoop :: InterpreterConfig -> HistoryFilePath -> ReprLoopEvaluator -> MakePrompt -> C.SessionId -> C.Connection -> IO ()+reprLoop config historyFilePath reprLoopEvaluator promptText sessionId conn = do+  let settings = defaultSettings {historyFile = Just historyFilePath} -- (homeDirectory ++ "/.tutd_history")}+  eHeadName <- C.headName sessionId conn+  eSchemaName <- C.currentSchemaName sessionId conn+  let prompt = promptText eHeadName eSchemaName+      catchInterrupt = handleJust (\case+                                      UserInterrupt -> Just Nothing+                                      _ -> Nothing) (\_ -> do+                                                        hPutStrLn stderr "Statement cancelled. Use \":quit\" to exit."+                                                        pure (Just ""))+  maybeLine <- catchInterrupt $ runInputT settings $ getInputLine (T.unpack prompt)+  case maybeLine of+    Nothing -> return ()+    Just line -> do+      reprLoopEvaluator sessionId conn (Just (T.length prompt)) (T.pack line)+      reprLoop config historyFilePath reprLoopEvaluator promptText sessionId conn++parseArgs :: Parser InterpreterConfig+parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseDirectExecute <*> many parseGhcPkgPath <*> parseCheckFS <|>+            RemoteInterpreterConfig <$> parseHostname "127.0.0.1" <*> parsePort C.defaultServerPort <*> parseDatabaseName <*> parseHeadName <*> parseDirectExecute <*> parseCheckFS++parseHeadName :: Parser HeadName               +parseHeadName = option auto (long "head" <>+                             help "Start session at head name." <>+                             metavar "GRAPH HEAD NAME" <>+                             value "master"+                            )++parseDirectExecute :: Parser (Maybe DirectExecute)+parseDirectExecute = optional $ strOption (long "exec-tutd" <>+                           short 'e' <>+                           metavar "TUTORIALD" <>+                           help "Execute TutorialD expression and exit"+                           )++type PrintWelcome = IO ()+type ExecUserInput = C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO ()++mainLoop :: IO () -> HistoryFilePath -> ReprLoopEvaluator -> MakePrompt -> ExecUserInput -> DatabaseContext -> IO ()+mainLoop printWelcome historyFilePath reprLoopEvaluator promptText execUserInput defaultDBContext = do+  setLocaleIfNecessary+  interpreterConfig <- execParser opts+  let connInfo = connectionInfoForConfig interpreterConfig defaultDBContext+  fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))+  if not fscheck then+    errDie checkFSErrorMsg+    else do+    dbconn <- C.connectProjectM36 connInfo+    case dbconn of +      Left err -> +        errDie ("Failed to create database connection: " ++ show err)+      Right conn -> do+        let connHeadName = headNameForConfig interpreterConfig+        eSessionId <- C.createSessionAtHead conn connHeadName+        case eSessionId of +            Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)+            Right sessionId -> +              case directExecForConfig interpreterConfig of+                Nothing -> do+                  printWelcome+                  _ <- reprLoop interpreterConfig historyFilePath reprLoopEvaluator promptText sessionId conn+                  pure ()+                Just execStr -> +                  execUserInput sessionId conn Nothing (T.pack execStr)+  +-- | If the locale is set to ASCII, upgrade it to UTF-8 because tutd outputs UTF-8-encoded attributes. This is especially important in light docker images where the locale data may be missing.+setLocaleIfNecessary :: IO ()+setLocaleIfNecessary = do+  l <- getLocaleEncoding+  when (textEncodingName l == "ASCII") (setLocaleEncoding utf8)++opts :: ParserInfo InterpreterConfig            +opts = info (parseArgs <**> helpOption) idm++connectionInfoForConfig :: InterpreterConfig -> DatabaseContext -> C.ConnectionInfo+connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) defaultDBContext = C.InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths defaultDBContext+connectionInfoForConfig (RemoteInterpreterConfig remoteHost remotePort remoteDBName _ _ _) _ = C.RemoteConnectionInfo remoteDBName remoteHost (show remotePort) outputNotificationCallback++headNameForConfig :: InterpreterConfig -> HeadName+headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn+headNameForConfig (RemoteInterpreterConfig _ _ _ headn _ _) = headn++directExecForConfig :: InterpreterConfig -> Maybe String+directExecForConfig (LocalInterpreterConfig _ _ t _ _) = t+directExecForConfig (RemoteInterpreterConfig _ _ _ _ t _) = t++checkFSForConfig :: InterpreterConfig -> Bool+checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c+checkFSForConfig (RemoteInterpreterConfig _ _ _ _ _ c) = c++persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy+persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat+persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing+                         +errDie :: String -> IO ()                                                           +errDie err = hPutStrLn stderr err >> exitFailure+

@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveGeneric #-}+-- functions common to both SQL and TutorialD interpreters+module ProjectM36.Interpreter where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.DataFrame+import Text.Megaparsec+import Data.Void+import Data.Text+import GHC.Generics+import qualified Data.Text.IO as TIO+import qualified Data.Text as T+import qualified Data.List.NonEmpty as NE+import System.IO+import Control.Monad.Random+import ProjectM36.Relation.Show.Term+import ProjectM36.Relation++type Parser = Parsec Void Text+type ParserError = ParseErrorBundle Text Void+type PromptLength = Int++data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)++data ConsoleResult = QuitResult |+                     DisplayResult StringType |+                     DisplayIOResult (IO ()) |+                     DisplayRelationResult Relation |+                     DisplayDataFrameResult DataFrame |+                     DisplayHintWith Text ConsoleResult |+                     DisplayErrorResult StringType |+                     DisplayRelationalErrorResult RelationalError |+                     DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text+                     QuietSuccessResult+                   deriving (Generic)++type InteractiveConsole = Bool++displayResult :: ConsoleResult -> IO ()+displayResult QuitResult = return ()+displayResult (DisplayResult out) = TIO.putStrLn out+displayResult (DisplayIOResult ioout) = ioout+displayResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in+  outputf stderr ("ERR: " <> err)+displayResult QuietSuccessResult = return ()+displayResult (DisplayRelationResult rel) = do+  gen <- newStdGen+  let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen+  TIO.putStrLn (showRelation randomlySortedRel)+displayResult (DisplayParseErrorResult mPromptLength err) = do+  let errorIndent = errorOffset . NE.head . bundleErrors $ err+      errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err)+      pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^"+  maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength+  TIO.putStr ("ERR:" <> errString)+displayResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame)+displayResult (DisplayRelationalErrorResult err) =+  TIO.putStrLn ("ERR:" <> T.pack (show err))+displayResult (DisplayHintWith hint result) = do+  displayResult (DisplayResult hint)+  displayResult result

@@ -12,6 +12,7 @@ import ProjectM36.Server.RemoteCallTypes import ProjectM36.MerkleHash import ProjectM36.Attribute as A+import ProjectM36.SQL.Select  import Data.Aeson import Data.ByteString.Base64 as B64@@ -172,6 +173,33 @@ instance ToJSON RelationalError instance FromJSON RelationalError +instance ToJSON SQLError+instance FromJSON SQLError++instance ToJSON ColumnProjectionName+instance FromJSON ColumnProjectionName++instance ToJSON UnqualifiedColumnName+instance FromJSON UnqualifiedColumnName++instance ToJSON ProjectionName+instance FromJSON ProjectionName++instance ToJSON ColumnAlias+instance FromJSON ColumnAlias++instance ToJSON ColumnName+instance FromJSON ColumnName++instance ToJSON TableName+instance FromJSON TableName++instance ToJSON TableAlias+instance FromJSON TableAlias++instance ToJSON FuncName+instance FromJSON FuncName+ instance ToJSON SchemaError instance FromJSON SchemaError @@ -196,4 +224,74 @@ instance ToJSON WithNameExpr instance FromJSON WithNameExpr +instance ToJSON (ScalarExprBase ColumnProjectionName)+instance FromJSON (ScalarExprBase ColumnProjectionName) +instance ToJSON OperatorName+instance FromJSON OperatorName++instance ToJSON BoolOp+instance FromJSON BoolOp++instance ToJSON InPredicateValue+instance FromJSON InPredicateValue++instance ToJSON Select+instance FromJSON Select++instance ToJSON InFlag+instance FromJSON InFlag++instance ToJSON QuantifiedComparisonPredicate+instance FromJSON QuantifiedComparisonPredicate++instance ToJSON ComparisonOperator+instance FromJSON ComparisonOperator++instance ToJSON (ScalarExprBase ColumnName)+instance FromJSON (ScalarExprBase ColumnName)++instance ToJSON WithClause+instance FromJSON WithClause++instance ToJSON Distinctness+instance FromJSON Distinctness++instance ToJSON TableExpr+instance FromJSON TableExpr++instance ToJSON WithExpr+instance FromJSON WithExpr++instance ToJSON SortExpr+instance FromJSON SortExpr++instance ToJSON HavingExpr+instance FromJSON HavingExpr++instance ToJSON GroupByExpr+instance FromJSON GroupByExpr++instance ToJSON RestrictionExpr+instance FromJSON RestrictionExpr++instance ToJSON TableRef+instance FromJSON TableRef++instance ToJSON WithExprAlias+instance FromJSON WithExprAlias++instance ToJSON Direction+instance FromJSON Direction++instance ToJSON JoinCondition+instance FromJSON JoinCondition++instance ToJSON NullsOrder+instance FromJSON NullsOrder++instance ToJSON JoinOnCondition+instance FromJSON JoinOnCondition++instance ToJSON QueryOperator+instance FromJSON QueryOperator

@@ -15,7 +15,7 @@ import ProjectM36.Relation.Show.HTML import Data.Aeson import TutorialD.Interpreter-import TutorialD.Interpreter.Base (TutorialDOperatorResult(..))+import ProjectM36.Interpreter (ConsoleResult(..), SafeEvaluationFlag(..)) import ProjectM36.Client import Control.Exception import Data.Attoparsec.Text@@ -91,7 +91,7 @@ sendError :: (ToJSON a) => WS.Connection -> a -> IO () sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err])) -handleOpResult :: WS.Connection -> Connection -> Presentation -> TutorialDOperatorResult -> IO ()+handleOpResult :: WS.Connection -> Connection -> Presentation -> ConsoleResult -> IO () handleOpResult conn db _ QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db handleOpResult conn  _ _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out])) handleOpResult _ _ _ (DisplayIOResult ioout) = ioout@@ -112,6 +112,13 @@       texto = ["text" .= showDataFrame df | textPresentation presentation]       htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation]   WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)]))+handleOpResult conn _ _ (DisplayRelationalErrorResult relErr) =+  WS.sendTextData conn (encode (object ["displayrelationalerrorresult" .= relErr]))+handleOpResult conn dbconn presentation (DisplayHintWith txt conResult) = do+  -- we should wrap this up into one response instead of two responses for clarity+  WS.sendTextData conn (encode (object ["hint" .= txt]))+  handleOpResult conn dbconn presentation conResult+  -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)

@@ -0,0 +1,109 @@+module SQL.Interpreter where+import ProjectM36.Base+import ProjectM36.Interpreter+import ProjectM36.SQL.Select+import ProjectM36.DatabaseContext+import ProjectM36.DateExamples+import ProjectM36.Error+import TutorialD.Printer+import SQL.Interpreter.ImportBasicExample+import SQL.Interpreter.TransactionGraphOperator+import SQL.Interpreter.Select+import SQL.Interpreter.DBUpdate+import SQL.Interpreter.Info+import ProjectM36.SQL.DBUpdate+import qualified Data.Text as T+import qualified ProjectM36.Client as C+import Text.Megaparsec+import SQL.Interpreter.Base++data SQLCommand = RODatabaseContextOp Query | -- SELECT+                  DatabaseContextExprOp DatabaseContextExpr |+                  DBUpdateOp [DBUpdate] | -- INSERT, UPDATE, DELETE, CREATE TABLE, DROP TABLE+                  ImportBasicExampleOp ImportBasicExampleOperator |  -- IMPORT EXAMPLE cjdate+                  TransactionGraphOp TransactionGraphOperator | -- COMMIT, ROLLBACK+                  InfoOp InfoOperator -- help+                deriving (Show)++type SQLCommands = [SQLCommand]+  +parseSQLUserInput :: T.Text -> Either ParserError SQLCommands+parseSQLUserInput = parse (some semiCommand <* eof) ""++semiCommand :: Parser SQLCommand+semiCommand =  (parseRODatabaseContextOp <|>+                parseDatabaseContextExprOp <|>+                parseTransactionGraphOp <|>+                parseImportBasicExampleOp <|>+                parseInfoOperator+               ) <* semi+++parseRODatabaseContextOp :: Parser SQLCommand+parseRODatabaseContextOp = RODatabaseContextOp <$> queryP++parseImportBasicExampleOp :: Parser SQLCommand+parseImportBasicExampleOp = ImportBasicExampleOp <$> importBasicExampleP++parseTransactionGraphOp :: Parser SQLCommand+parseTransactionGraphOp = TransactionGraphOp <$> transactionGraphOperatorP++parseDatabaseContextExprOp :: Parser SQLCommand+parseDatabaseContextExprOp = DBUpdateOp <$> dbUpdatesP++parseInfoOperator :: Parser SQLCommand+parseInfoOperator = InfoOp <$> infoP++evalSQLInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> [SQLCommand] -> IO [ConsoleResult]+evalSQLInteractive sessionId conn _safeFlag _interactiveConsole =+  mapM evalOneCommand+ where+ evalOneCommand command =  +  case command of+    RODatabaseContextOp query -> do+      --get relvars to build conversion context+      eDFExpr <- C.convertSQLQuery sessionId conn query+      case eDFExpr of+        Left err -> pure $ DisplayRelationalErrorResult err+        Right dfExpr -> do+          let hint = renderPretty dfExpr+          eDF <- C.executeDataFrameExpr sessionId conn dfExpr+          case eDF of+            Left err -> pure $ DisplayRelationalErrorResult err+            Right df -> pure $ DisplayHintWith ("[Equivalent TutorialD] " <> hint) (DisplayDataFrameResult df)+    ImportBasicExampleOp (ImportBasicExampleOperator exampleName) -> do+      if exampleName == "cjdate" then+        evalOneCommand (DatabaseContextExprOp (databaseContextAsDatabaseContextExpr dateExamples))+        else+          pure (DisplayErrorResult ("No such example: " <> exampleName))+    DatabaseContextExprOp dbcExpr -> do+      eHandler $ C.executeDatabaseContextExpr sessionId conn dbcExpr+    DBUpdateOp updates -> do+      eDBCExpr <- C.convertSQLDBUpdates sessionId conn updates+      case eDBCExpr of+        Left err -> pure $ DisplayRelationalErrorResult err+        Right dbcExpr -> do+          let hint = renderPretty dbcExpr+          ret <- C.executeDatabaseContextExpr sessionId conn dbcExpr+          case ret of+            Left err -> barf err+            Right () -> pure $ DisplayHintWith ("Equivalent TutorialD: " <> hint) QuietSuccessResult+    TransactionGraphOp Commit -> do+      eHandler $ C.commit sessionId conn+    TransactionGraphOp Rollback -> do+      eHandler $ C.rollback sessionId conn+    TransactionGraphOp Begin ->+      pure $ DisplayHintWith "Advisory Warning: BEGIN is redundant as transaction is started automatically." QuietSuccessResult+    InfoOp HelpOperator -> +      pure $ DisplayResult "The SQLegacy Console supports common SQL expressions. To import the C.J.Date examples:\n IMPORT EXAMPLE CJDATE;\nExample queries:\n SELECT status FROM s WHERE city='London';\nSELECT * FROM s NATURAL JOIN sp;\nExample statements:\n INSERT INTO s(city,s#,sname,status) VALUES ('Frankfurt', 'S6', 'Brians', 40);\n DELETE FROM s WHERE city='London';\n UPDATE s SET status=20 WHERE city='Paris';"+  where+    eHandler io = do+      eErr <- io+      case eErr of+        Left err -> barf err+        Right () -> return QuietSuccessResult+    barf :: C.RelationalError -> IO ConsoleResult+    barf (C.ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))+    barf (C.ParseError err) = pure (DisplayErrorResult err)+    barf err = return $ DisplayErrorResult (T.pack (show err))+      

@@ -0,0 +1,92 @@+module SQL.Interpreter.Base where+import ProjectM36.Interpreter+import Text.Megaparsec+import Text.Megaparsec.Char+import qualified Text.Megaparsec.Char.Lexer as Lex+import Data.Text as T (Text, singleton, pack, splitOn, toLower)+import Data.Functor (($>))++-- consumes only horizontal spaces+spaceConsumer :: Parser ()+spaceConsumer = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")++opChar :: Parser Char+opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces++-- parse case-insensitive keyword+reserved :: Text -> Parser ()+reserved word = do+  try (string' word *> spaceConsumer)++reserveds :: Text -> Parser ()+reserveds words' = do+  let words'' = T.splitOn " " words'+  reserveds' words''++reserveds' :: [Text] -> Parser ()+reserveds' = mapM_ reserved +  +-- does not consume trailing spaces+qualifiedNameSegment :: Text -> Parser Text+qualifiedNameSegment sym = T.toLower <$> string' sym++reservedOp :: Text -> Parser ()+reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer)++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++identifier :: Parser Text+identifier = do+  istart <- letterChar <|> char '_'+  (toLower <$> identifierRemainder istart) <* spaceConsumer++identifierRemainder :: Char -> Parser Text+identifierRemainder c = do+  rest <- many (alphaNumChar <|> char '_' <|> char '#')+  spaceConsumer+  pure (pack (c:rest))++symbol :: Text -> Parser Text+symbol = Lex.symbol spaceConsumer++comma :: Parser Text+comma = symbol ","++sepByComma1 :: Parser a -> Parser [a]+sepByComma1 p = sepBy1 p comma++sepByComma :: Parser a -> Parser [a]+sepByComma p = sepBy p comma++pipe :: Parser Text+pipe = symbol "|"++semi :: Parser Text+semi = symbol ";"++nline :: Parser Text+nline = (T.singleton <$> newline) <|> crlf++integer :: Parser Integer+integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer++natural :: Parser Integer+natural = Lex.decimal <* spaceConsumer++double :: Parser Double+double = Lex.float <* spaceConsumer++-- | When an identifier is quoted, it can contain any string.+quotedIdentifier :: Parser Text+quotedIdentifier =+  (T.pack <$> (doubleQuote *> many (escapedDoubleQuote <|> notDoubleQuote) <* doubleQuote)) <* spaceConsumer+  where+    doubleQuote = char '"'+    escapedDoubleQuote = chunk "\"\"" $> '"'+    notDoubleQuote = satisfy ('"' /=)++    

@@ -0,0 +1,61 @@+module SQL.Interpreter.CreateTable where+import SQL.Interpreter.Select+import ProjectM36.SQL.Select+import ProjectM36.SQL.CreateTable+import SQL.Interpreter.Base+import ProjectM36.Interpreter+import Text.Megaparsec+import Control.Monad.Permutations+import Data.Functor (($>))++createTableP :: Parser CreateTable+createTableP = do+  reserveds "create table"+  tname <- tableNameP+  colsAndTypes <- parens columnNamesAndTypesP+  pure $ CreateTable { target = tname,+                       targetColumns = colsAndTypes+                       }++columnNamesAndTypesP :: Parser [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)]+columnNamesAndTypesP =+  sepByComma $ do+    colName <- unqualifiedColumnNameP+    colType <- columnTypeP+    perColConstraints <- perColConstraintsP+    pure (colName, colType, perColConstraints) ++columnTypeP :: Parser ColumnType+columnTypeP = choice (map (\(nam, typ) -> reserved nam $> typ) types)+  where+    types = [("integer", IntegerColumnType),+             ("int", IntegerColumnType),+             ("text", TextColumnType),+             ("bool", BoolColumnType),+             ("double", DoubleColumnType),+             ("datetime", DateTimeColumnType)]++data PerColumnConstraintsParse =+  PerColumnConstraintsParse { parse_notNullConstraint :: Bool,+                              parse_uniquenessConstraint :: Bool,+                              parse_primaryKeyConstraint :: Bool,+                              parse_references :: Maybe (TableName, UnqualifiedColumnName)+                              }++referencesP :: Parser (TableName, UnqualifiedColumnName)+referencesP = do+  reserved "references"+  (,) <$> tableNameP <*> parens unqualifiedColumnNameP +  +perColConstraintsP :: Parser PerColumnConstraints+perColConstraintsP = do+  parsed <- runPermutation $+    PerColumnConstraintsParse <$>+      toPermutationWithDefault False (try (reserveds "not null" $> True)) <*>+      toPermutationWithDefault False (reserved "unique" $> True) <*>+      toPermutationWithDefault False (reserved "primary key" $> True) <*>+      toPermutationWithDefault Nothing (Just <$> referencesP)+  pure (PerColumnConstraints { notNullConstraint = parse_notNullConstraint parsed || parse_primaryKeyConstraint parsed,+                               uniquenessConstraint = parse_uniquenessConstraint parsed || parse_primaryKeyConstraint parsed,+                               references = parse_references parsed })+

@@ -0,0 +1,20 @@+module SQL.Interpreter.DBUpdate where+import ProjectM36.Interpreter+import ProjectM36.SQL.DBUpdate+import SQL.Interpreter.Update+import SQL.Interpreter.Insert+import SQL.Interpreter.Delete+import SQL.Interpreter.CreateTable+import SQL.Interpreter.DropTable+import Text.Megaparsec++dbUpdatesP :: Parser [DBUpdate]+dbUpdatesP = some dbUpdateP++dbUpdateP :: Parser DBUpdate+dbUpdateP = (UpdateUpdate <$> updateP) <|>+            (UpdateInsert <$> insertP) <|>+            (UpdateDelete <$> deleteP) <|>+            (UpdateCreateTable <$> createTableP) <|>+            (UpdateDropTable <$> dropTableP)+  

@@ -0,0 +1,15 @@+module SQL.Interpreter.Delete where+import SQL.Interpreter.Select+import ProjectM36.SQL.Delete+import ProjectM36.SQL.Select+import SQL.Interpreter.Base+import ProjectM36.Interpreter+import Control.Applicative++deleteP :: Parser Delete+deleteP = do+  reserveds "delete from"+  tname <- tableNameP+  restrictExpr <- whereP <|> pure (RestrictionExpr (BooleanLiteral True))+  pure $ Delete { target = tname,+                  restriction = restrictExpr }

@@ -0,0 +1,10 @@+module SQL.Interpreter.DropTable where+import ProjectM36.SQL.DropTable+import SQL.Interpreter.Select+import SQL.Interpreter.Base+import ProjectM36.Interpreter++dropTableP :: Parser DropTable+dropTableP = do+  reserveds "drop table"+  DropTable <$> tableNameP

@@ -0,0 +1,12 @@+module SQL.Interpreter.ImportBasicExample where+import qualified Data.Text as T+import SQL.Interpreter.Base+import ProjectM36.Interpreter++newtype ImportBasicExampleOperator = ImportBasicExampleOperator T.Text+  deriving (Show)++importBasicExampleP :: Parser ImportBasicExampleOperator+importBasicExampleP = do+  reserveds "IMPORT EXAMPLE CJDATE"+  pure (ImportBasicExampleOperator "cjdate")

@@ -0,0 +1,9 @@+module SQL.Interpreter.Info where+import ProjectM36.Interpreter+import SQL.Interpreter.Base+import Data.Functor+  +data InfoOperator = HelpOperator deriving Show++infoP :: Parser InfoOperator+infoP = reserved "help" $> HelpOperator

@@ -0,0 +1,15 @@+module SQL.Interpreter.Insert where+import SQL.Interpreter.Select+import ProjectM36.SQL.Insert+import SQL.Interpreter.Base+import ProjectM36.Interpreter++insertP :: Parser Insert+insertP = do+  reserveds "insert into"+  tname <- tableNameP+  colNames <- parens (sepByComma1 unqualifiedColumnNameP)+  q <- queryP+  pure (Insert { target = tname,+                 targetColumns = colNames,+                 source = q })

@@ -0,0 +1,376 @@+{-# LANGUAGE TypeFamilies #-}+module SQL.Interpreter.Select where+import ProjectM36.Interpreter+import ProjectM36.SQL.Select+import Text.Megaparsec+import Text.Megaparsec.Char+import Control.Monad.Combinators.Expr as E+import SQL.Interpreter.Base+import Data.Text (Text, splitOn)+import qualified Data.Text as T+import Data.Functor+import Data.Char (isLetter)+import qualified Data.List.NonEmpty as NE+++parseSelect :: Text -> Either ParserError Select+parseSelect = parse (selectP <* semi <* eof) "<interactive>"++parseQuery :: Text -> Either ParserError Query+parseQuery = parse (queryP <* semi <* eof) "<interactive>"+  +queryP :: Parser Query+queryP = E.makeExprParser queryTermP queryOpP+  where+    queryTermP = (QuerySelect <$> selectP) <|>+                (QueryValues <$> valuesP) <|>+                (QueryTable <$> tableP)+    queryOpP = [[infixOpP "union" UnionQueryOperator,+                 infixOpP "intersect" IntersectQueryOperator,+                 infixOpP "except" ExceptQueryOperator+                ]]+    infixOpP nam op =+      E.InfixL $ do+        reserved nam+        pure (QueryOp op)++valuesP :: Parser [[ScalarExpr]]+valuesP = do+  reserved "values"+  sepByComma1 tupleP++tupleP :: Parser [ScalarExpr]+tupleP = parens (sepByComma1 scalarExprP)++tableP :: Parser TableName+tableP = do+  reserved "table"+  tableNameP++tableNameP :: Parser TableName+tableNameP = TableName <$> qualifiedNameP'+  +selectP :: Parser Select+selectP = do+  withClause' <- optional withP+  reserved "select"+--  distinctOptions+  projection <- selectItemListP+  tExpr <- optional tableExprP+  pure (Select { distinctness = Nothing,+                 projectionClause = projection,+                 tableExpr = tExpr,+                 withClause = withClause'+               })+  +  +selectItemListP :: Parser [SelectItem]+selectItemListP = sepBy selectItemP comma++selectItemP :: Parser SelectItem+selectItemP = (,) <$> scalarExprP <*> optional (reserved "as" *> columnAliasP)+++tableExprP :: Parser TableExpr+tableExprP =+  TableExpr <$> fromP <*> optional whereP <*> option [] groupByP <*> optional havingP <*> option [] orderByP <*> limitP <*> offsetP++fromP :: Parser [TableRef]+fromP = reserved "from" *> (concat <$> sepByComma trefs)+  where+    trefs = (:) <$> nonJoinTref <*> many joinP+    nonJoinTref = choice [parens $ QueryTableRef <$> selectP,+                          try (AliasedTableRef <$> simpleRef <*> (reserved "as" *> tableAliasP)),+                          simpleRef]+    simpleRef = SimpleTableRef <$> tableNameP+    joinP = do+      joinType <- joinTypeP+      tref <- nonJoinTref+      case joinType of -- certain join types require join conditions, others not+        InnerJoin -> InnerJoinTableRef tref <$> joinConditionP+        RightOuterJoin -> RightOuterJoinTableRef tref <$> joinConditionP+        LeftOuterJoin -> LeftOuterJoinTableRef tref <$> joinConditionP+        FullOuterJoin -> FullOuterJoinTableRef tref <$> joinConditionP+        CrossJoin -> pure $ CrossJoinTableRef tref+        NaturalJoin -> pure $ NaturalJoinTableRef tref+      +joinConditionP :: Parser JoinCondition+joinConditionP = do+  (JoinOn <$> (reserved "on" *> (JoinOnCondition <$> scalarExprP))) <|>+   JoinUsing <$> (reserved "using" *> parens (sepBy1 unqualifiedColumnNameP comma))++joinTypeP :: Parser JoinType+joinTypeP = choice [reserveds "cross join" $> CrossJoin,+                    reserveds "inner join" $> InnerJoin,+                    (reserveds "left outer join" <|>+                     reserveds "left join") $> LeftOuterJoin,+                    (reserveds "right outer join" <|>+                     reserveds "right join") $> RightOuterJoin,+                     (reserveds "full join" <|>+                      reserveds "full outer join") $> FullOuterJoin,+                     (reserved "inner join" <|> reserveds "join") $> InnerJoin,+                     reserved "natural join" $> NaturalJoin]+  ++whereP :: Parser RestrictionExpr+whereP = reserved "where" *> (RestrictionExpr <$> scalarExprP)++groupByP :: Parser [GroupByExpr]+groupByP =+  reserveds "group by" *> sepBy1 (GroupByExpr <$> scalarExprP) comma++havingP :: Parser HavingExpr+havingP = reserved "having" *> (HavingExpr <$> scalarExprP)++orderByP :: Parser [SortExpr]+orderByP =+  reserveds "order by" *> sepByComma1 (SortExpr <$> scalarExprP <*> optional directionP <*> optional nullsOrderP)+  where+    directionP = (reserved "asc" $> Ascending) <|>+                 (reserved "desc" $> Descending)+    nullsOrderP = (reserveds "nulls first" $> NullsFirst) <|>+                  (reserveds "nulls last" $> NullsLast)+  +nameP :: Parser Text+nameP = (quotedIdentifier <|> identifier) <* spaceConsumer++qualifiedNameP' :: Parser [Text]+qualifiedNameP' = sepBy1 nameP (symbol ".")++columnAliasP :: Parser ColumnAlias+columnAliasP = ColumnAlias <$> (quotedIdentifier <|> identifier)++tableAliasP :: Parser TableAlias+tableAliasP = TableAlias <$> (quotedIdentifier <|> identifier)++unqualifiedColumnNameP :: Parser UnqualifiedColumnName+unqualifiedColumnNameP = UnqualifiedColumnName <$> nameP++scalarExprP :: QualifiedNameP a => Parser (ScalarExprBase a)+scalarExprP = E.makeExprParser scalarTermP scalarExprOp++scalarExprOp :: QualifiedNameP a => [[E.Operator Parser (ScalarExprBase a)]]+scalarExprOp =+  [[qComparisonOp],+   [prefixSymbol "+",+    prefixSymbol "-"],+    [binarySymbolL "^"],+    map binarySymbolL ["\"","*","%"],+    map binarySymbolL ["+","-"],+    [binarySymbolR "||",+     prefixSymbol "~",+     binarySymbolR "&",+     binarySymbolR "|"],+    [binarySymbolN "like",+     E.Postfix $ try inSuffixP,+     E.Postfix betweenSuffixP+     --binarySymbolsN ["not", "like"]+     ],+    map binarySymbolN [">=","<=","!=","<>","=", "<",">"],+    [postfixKeywords ["is","null"], postfixKeywords ["is","not","null"]],+{-    [binarySymbolsN ["is", "distinct", "from"],+     binarySymbolsN ["is", "not", "distinct", "from"]],-}+    [binarySymbolL "and"],+    [prefixSymbol "not"],+    [binarySymbolL "or"]+    -- AT TIME ZONE+    ]+ where+   prefixSymbol s = E.Prefix $ PrefixOperator <$> qualifiedOperatorP s+   binarySymbolL s = E.InfixL $ binary s+   binary s = do+     op <- qualifiedOperatorP s+     pure (`BinaryOperator` op)+   binarySymbolR s = E.InfixR $ binary s+   binarySymbolN s = E.InfixN $ binary s+   qComparisonOp = E.Postfix $ try quantifiedComparisonSuffixP+   postfixKeywords kws = E.Postfix $ do+     try $ reserveds' kws+     pure (\a -> PostfixOperator a (OperatorName kws))+                     ++qualifiedOperatorP :: Text -> Parser OperatorName+qualifiedOperatorP sym =+  OperatorName <$> segmentsP (splitOn "." sym) <* spaceConsumer+  where+    isLetters :: Text -> Bool+    isLetters = T.all isLetter+    segmentsP :: [Text] -> Parser [Text]+    -- simple case for non-string-based operators+    segmentsP [op] | not (isLetters op) = qualifiedNameSegment op $> [op]+    segmentsP segments = case segments of+      [] -> fail "empty operator"+      [seg] -> do+        final <- try (qualifiedNameSegment seg <* notFollowedBy alphaNumChar)+        pure [final]+      (seg:remainder) -> do+        first <- qualifiedNameSegment seg+        _ <- char '.'+        rem' <- segmentsP remainder+        pure (first:rem')+    ++betweenSuffixP :: QualifiedNameP a => Parser (ScalarExprBase a -> ScalarExprBase a)+betweenSuffixP = do+  reserved "between"+  arg1 <- scalarExprP+  reserved "and"+  arg2 <- scalarExprP+  pure (\x -> BetweenOperator x arg1 arg2)++inSuffixP :: QualifiedNameP a => Parser (ScalarExprBase a -> ScalarExprBase a)+inSuffixP = do+  matchIn <|> matchNotIn+  where+    matchIn = do+      reserved "in"+      pred' <- inPredicateValue+      pure (\sexpr -> InExpr In sexpr pred')+    matchNotIn = do+      reserved "not" >> reserved "in"+      pred' <- inPredicateValue      +      pure (\sexpr -> InExpr NotIn sexpr pred')+    inPredicateValue = parens ((InQueryExpr <$> selectP) <|>+                                (InList <$> sepBy1 scalarExprP comma)) <|>+                       InScalarExpr <$> scalarExprP++  +quantifiedComparisonSuffixP :: QualifiedNameP a => Parser (ScalarExprBase a -> ScalarExprBase a)+quantifiedComparisonSuffixP = do+  op <- comparisonOperatorP+  quantOp <- (reserved "any" $> QCAny) <|>+             (reserved "some" $> QCSome) <|>+             (reserved "all" $> QCAll)+  subq <- parens selectP+  pure (\sexpr -> QuantifiedComparison { qcExpr = sexpr,+                                         qcOperator = op,+                                         qcPredicate = quantOp,+                                         qcQuery = subq })++comparisonOperatorP :: Parser ComparisonOperator+comparisonOperatorP = choice (map (\(match', op) -> reserved match' $> op) ops)+    where ops =[(">", OpGT),+                 ("<", OpLT),+                 ("=", OpEQ),+                 (">=", OpGTE),+                 ("<=", OpLTE),+                 ("<>", OpNE),+                 ("!=", OpNE)]++simpleLiteralP :: Parser (ScalarExprBase a)+simpleLiteralP = try doubleLiteralP <|> integerLiteralP <|> booleanLiteralP <|> stringLiteralP <|> nullLiteralP++doubleLiteralP :: Parser (ScalarExprBase a)+doubleLiteralP = DoubleLiteral <$> double++booleanLiteralP :: Parser (ScalarExprBase a)+booleanLiteralP = BooleanLiteral <$> ((reserved "true" $> True) <|> (reserved "false" $> False))++integerLiteralP :: Parser (ScalarExprBase a)+integerLiteralP = IntegerLiteral <$> integer++stringLiteralP :: Parser (ScalarExprBase a)+stringLiteralP = StringLiteral <$> stringP+  where+    stringP = do+      void $ char '\''+      stringEndP+    stringEndP = do+      capture <- T.pack <$> manyTill printChar (char '\'')+      choice [char '\'' *> (do+                               rest <- stringEndP+                               pure $ T.concat [capture, "'",rest]), --quoted quote+              pure capture+             ] <* spaceConsumer++nullLiteralP :: Parser (ScalarExprBase a)+nullLiteralP = +  reserved "NULL" $> NullLiteral+  +scalarTermP :: QualifiedNameP a => Parser (ScalarExprBase a)+scalarTermP = choice [+  existsP,  +  simpleLiteralP,+    --,subQueryExpr+    caseExprP,+    --,cast+--    subquery,+--    pseudoArgFunc, -- includes NOW, NOW(), CURRENT_USER, TRIM(...), etc.+    scalarFunctionP,+    Identifier <$> qualifiedNameP+    ]+  <?> "scalar expression"++caseExprP :: QualifiedNameP a => Parser (ScalarExprBase a)+caseExprP = do+  let whenThenClause = do+        reserved "when"+        cond <- scalarExprP+        reserved "then"+        result <- scalarExprP+        pure (cond, result)+      elseClause = do+        reserved "else"+        scalarExprP+  reserved "case"+  conditionals <- some whenThenClause+  mElse <- optional elseClause+  reserved "end"+  pure (CaseExpr { caseWhens = conditionals,+                   caseElse = mElse })+       +scalarFunctionP :: QualifiedNameP a => Parser (ScalarExprBase a)+scalarFunctionP =+  try $+  FunctionApplication <$> functionNameP <*> parens (sepByComma scalarExprP)++existsP :: Parser (ScalarExprBase a)+existsP = do+  reserved "exists"+  ExistsExpr <$> parens selectP++-- used to distinguish between sections which may include an asterisk and those which cannot+class QualifiedNameP a where+  qualifiedNameP :: Parser a++-- | col, table.col, table.*, *+instance QualifiedNameP ColumnProjectionName where+  qualifiedNameP = columnProjectionNameP++instance QualifiedNameP ColumnName where+  qualifiedNameP = columnNameP++columnNameP :: Parser ColumnName+columnNameP = +  ColumnName <$> sepBy1 nameP (char '.') <* spaceConsumer    ++columnProjectionNameP :: Parser ColumnProjectionName+columnProjectionNameP =+  ColumnProjectionName <$> sepBy1 ((ProjectionName <$> nameP) <|> (char '*' $> Asterisk)) (char '.') <* spaceConsumer+  +functionNameP :: Parser FuncName+functionNameP = do+  FuncName <$> sepBy1 nameP (char '.') <* spaceConsumer++withExprAliasP :: Parser WithExprAlias+withExprAliasP = WithExprAlias <$> nameP++limitP :: Parser (Maybe Integer)+limitP = optional (reserved "limit" *> integer)++offsetP :: Parser (Maybe Integer)+offsetP = optional (reserved "offset" *> integer)++withP :: Parser WithClause+withP = do+  reserved "with"+  recursive <- try (reserved "recursive" $> True) <|> pure False  +  wExprs <- sepByComma1 $ do+    wName <- withExprAliasP+    reserved "as"+    wSelect <- parens selectP+    pure (WithExpr wName wSelect)+  pure (WithClause recursive (NE.fromList wExprs))+      ++

@@ -0,0 +1,20 @@+module SQL.Interpreter.TransactionGraphOperator where+import ProjectM36.Interpreter+import SQL.Interpreter.Base+import Control.Applicative+import Data.Functor (($>))++data TransactionGraphOperator = Begin | Commit | Rollback+  deriving (Show, Eq)++transactionGraphOperatorP :: Parser TransactionGraphOperator+transactionGraphOperatorP = beginP <|> commitP <|> rollbackP++beginP :: Parser TransactionGraphOperator+beginP = reserved "begin" $> Begin+  +commitP :: Parser TransactionGraphOperator+commitP = reserved "commit" $> Commit++rollbackP :: Parser TransactionGraphOperator+rollbackP = reserved "rollback" $> Rollback

@@ -0,0 +1,26 @@+module SQL.Interpreter.Update where+import SQL.Interpreter.Select+import ProjectM36.SQL.Update+import SQL.Interpreter.Base+import ProjectM36.Interpreter+import Control.Applicative+import Text.Megaparsec++updateP :: Parser Update+updateP = do+  reserved "update"+  tname <- tableNameP+  --mTAlias <- try (reserved "as" *> (Just <$> tableAliasP)) <|> pure Nothing+  reserved "set"+  setCols <- sepByComma1 $ do+    calias <- unqualifiedColumnNameP+    reserved "="+    sexpr <- scalarExprP+    pure (calias, sexpr)+  mWhere <- try (Just <$> whereP) <|> pure Nothing+  pure (Update {+           target = tname,+--           targetAlias = mTAlias,+           setColumns = setCols,+           mRestriction = mWhere+           })

@@ -0,0 +1,49 @@+-- the sqlegacy SQL interpreter wrap+{-# LANGUAGE CPP #-}+import ProjectM36.Base+import ProjectM36.Cli+import SQL.Interpreter+import ProjectM36.SQLDatabaseContext+import ProjectM36.Error+import System.Directory+import System.FilePath+import qualified ProjectM36.Client as C+import qualified Data.Text as T+import Data.Either (fromRight)+import Control.Exception (catchJust)+import ProjectM36.Interpreter++#if !defined(VERSION_project_m36) +# warning Failed to discover proper version from cabal_macros.h+# define VERSION_project_m36 "<unknown>"+#endif++main :: IO ()+main = do+  homeDir <- getHomeDirectory+  let historyPath = homeDir </> ".sqlegacy_history"+  mainLoop printWelcome historyPath sqlReprLoop promptText sqlReprLoop sqlDatabaseContext+  +printWelcome :: IO ()+printWelcome = do+  putStrLn ("Project:M36 SQLegacy Interpreter " ++ VERSION_project_m36)+  putStrLn "SQL does not support the complete relational algebra. To access the complete relational algebra, use the bundled \"tutd\" interpreter."+  putStrLn "Type \"help;\" for more information."++sqlReprLoop :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO ()+sqlReprLoop sessionId conn mPromptLength userInput = do+  case parseSQLUserInput userInput of+    Left err ->+      displayResult (DisplayParseErrorResult mPromptLength err)+    Right parsed ->+      catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do+        evald <- evalSQLInteractive sessionId conn UnsafeEvaluation True parsed+        mapM_ displayResult evald)+        (\_ -> displayResult (DisplayErrorResult "Request timed out."))+      ++promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType+promptText eHeadName eSchemaName = "SQLegacy (" <> transInfo <> "): "+  where+    transInfo = fromRight "<unknown>" eHeadName <> "/" <> fromRight "<no schema>" eSchemaName+  

@@ -1,5 +1,6 @@-{-# LANGUAGE GADTs, LambdaCase, CPP #-}+{-# LANGUAGE GADTs, CPP #-} module TutorialD.Interpreter where+import ProjectM36.Interpreter import TutorialD.Interpreter.Base import TutorialD.Interpreter.RODatabaseContextOperator import TutorialD.Interpreter.DatabaseContextExpr@@ -19,15 +20,12 @@  import ProjectM36.Base import ProjectM36.Error-import ProjectM36.Relation.Show.Term import ProjectM36.TransactionGraph import qualified ProjectM36.Client as C import ProjectM36.Relation (attributes)  import System.Console.Haskeline-import System.Directory (getHomeDirectory) import qualified Data.Text as T-import System.IO (hPutStrLn, stderr) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -87,15 +85,12 @@ safeParseTutorialD :: T.Text -> Either ParserError ParsedOperation safeParseTutorialD = parse safeInterpreterParserP "" -data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq) -type InteractiveConsole = Bool--evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO TutorialDOperatorResult+evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO ConsoleResult evalTutorialD sessionId conn safe = evalTutorialDInteractive sessionId conn safe False  --execute the operation and display result-evalTutorialDInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> ParsedOperation -> IO TutorialDOperatorResult+evalTutorialDInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> ParsedOperation -> IO ConsoleResult evalTutorialDInteractive sessionId conn safe interactive expr = case expr of   --this does not pass through the ProjectM36.Client library because the operations   --are specific to the interpreter, though some operations may be of general use in the future@@ -214,7 +209,7 @@   where     needsSafe = safe == SafeEvaluation     unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."-    barf :: RelationalError -> IO TutorialDOperatorResult+    barf :: RelationalError -> IO ConsoleResult     barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))     barf (ParseError err) = pure (DisplayErrorResult err)     barf err = return $ DisplayErrorResult (T.pack (show err))@@ -224,49 +219,17 @@         Left err -> barf err         Right () -> return QuietSuccessResult -type GhcPkgPath = String-type TutorialDExec = String-type CheckFS = Bool -data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] CheckFS |-                         RemoteInterpreterConfig C.Hostname C.Port C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS -outputNotificationCallback :: C.NotificationCallback-outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot -prettyEvaluatedNotification :: C.EvaluatedNotification -> String-prettyEvaluatedNotification eNotif = let eRelShow eRel = case eRel of-                                           Left err -> show err-                                           Right reportRel -> T.unpack (showRelation reportRel) in-  eRelShow (C.reportOldRelation eNotif) <> "\n" <> eRelShow (C.reportNewRelation eNotif)--reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO ()-reprLoop config sessionId conn = do-  homeDirectory <- getHomeDirectory-  let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}-  eHeadName <- C.headName sessionId conn-  eSchemaName <- C.currentSchemaName sessionId conn-  let prompt = promptText eHeadName eSchemaName-      catchInterrupt = handleJust (\case-                                      UserInterrupt -> Just Nothing-                                      _ -> Nothing) (\_ -> do-                                                        hPutStrLn stderr "Statement cancelled. Use \":quit\" to exit tutd."-                                                        pure (Just ""))-  maybeLine <- catchInterrupt $ runInputT settings $ getInputLine (T.unpack prompt)-  case maybeLine of-    Nothing -> return ()-    Just line -> do-      runTutorialD sessionId conn (Just (T.length prompt)) (T.pack line)-      reprLoop config sessionId conn-- runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () runTutorialD sessionId conn mPromptLength tutd =   case parseTutorialD tutd of     Left err ->-      displayOpResult $ DisplayParseErrorResult mPromptLength err+      displayResult $ DisplayParseErrorResult mPromptLength err     Right parsed ->       catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do         evald <- evalTutorialDInteractive sessionId conn UnsafeEvaluation True parsed-        displayOpResult evald)-        (\_ -> displayOpResult (DisplayErrorResult "Request timed out."))+        displayResult evald)+        (\_ -> displayResult (DisplayErrorResult "Request timed out."))+

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, CPP #-}+{-# LANGUAGE CPP #-} module TutorialD.Interpreter.Base (   module TutorialD.Interpreter.Base,   module Text.Megaparsec,@@ -13,14 +13,12 @@ import ProjectM36.Base import ProjectM36.AtomType import ProjectM36.Attribute as A-import ProjectM36.Relation-import ProjectM36.DataFrame+import ProjectM36.Interpreter  #if MIN_VERSION_megaparsec(6,0,0) import Text.Megaparsec.Char  import qualified Text.Megaparsec.Char.Lexer as Lex import Text.Megaparsec-import Data.Void import Control.Applicative hiding (many, some) #else import Text.Megaparsec.Text@@ -28,19 +26,13 @@ #endif  import Data.Text hiding (count)-import System.Random import qualified Data.Text as T import qualified Data.List as L-import qualified Data.Text.IO as TIO-import System.IO-import ProjectM36.Relation.Show.Term-import GHC.Generics #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif import qualified Data.UUID as U import Control.Monad.Random-import Data.List.NonEmpty as NE import Data.Time.Clock import Data.Time.Format import Data.Char@@ -50,36 +42,8 @@ anySingle = anyChar #endif -displayOpResult :: TutorialDOperatorResult -> IO ()-displayOpResult QuitResult = return ()-displayOpResult (DisplayResult out) = TIO.putStrLn out-displayOpResult (DisplayIOResult ioout) = ioout-displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in-  outputf stderr ("ERR: " <> err)-displayOpResult QuietSuccessResult = return ()-displayOpResult (DisplayRelationResult rel) = do-  gen <- newStdGen-  let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen-  TIO.putStrLn (showRelation randomlySortedRel)-displayOpResult (DisplayParseErrorResult mPromptLength err) = do-#if MIN_VERSION_megaparsec(7,0,0)-  let errorIndent = errorOffset . NE.head . bundleErrors $ err-      errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err)-#else-  let errorIndent = unPos (sourceColumn (NE.head (errorPos err)))-      errString = T.pack (parseErrorPretty err)-#endif-      pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^"-  maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength-  TIO.putStr ("ERR:" <> errString)-displayOpResult (DisplayDataFrameResult dFrame) = TIO.putStrLn (showDataFrame dFrame) -#if MIN_VERSION_megaparsec(6,0,0)-type Parser = Parsec Void Text type ParseStr = Text-#else-type ParseStr = String-#endif  -- consumes only horizontal spaces spaceConsumer :: Parser ()@@ -184,25 +148,6 @@     showAttribute (Attribute name atomType') = name <> " " <> prettyAtomType atomType'     attrsL = A.toList attrs -type PromptLength = Int--#if MIN_VERSION_megaparsec(7,0,0)-type ParserError = ParseErrorBundle T.Text Void-#elif MIN_VERSION_megaparsec(6,0,0)-type ParserError = ParseError Char Void-#else-type ParserError = ParseError Char Dec-#endif--data TutorialDOperatorResult = QuitResult |-                               DisplayResult StringType |-                               DisplayIOResult (IO ()) |-                               DisplayRelationResult Relation |-                               DisplayDataFrameResult DataFrame |-                               DisplayErrorResult StringType |-                               DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text-                               QuietSuccessResult-                               deriving (Generic)  type TransactionGraphWasUpdated = Bool 

@@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} module TutorialD.Interpreter.DatabaseContextExpr where import ProjectM36.Base+import ProjectM36.Interpreter+import ProjectM36.DatabaseContext import TutorialD.Interpreter.Base import qualified Data.Text as T import TutorialD.Interpreter.RelationalExpr@@ -57,7 +59,7 @@ multipleDatabaseContextExprP :: Parser DatabaseContextExpr multipleDatabaseContextExprP = do   exprs <- filter (/= NoOperation) <$> sepBy1 databaseContextExprP semi-  pure (MultipleExpr exprs)+  pure (someDatabaseContextExprs exprs)  insertP :: Parser DatabaseContextExpr insertP = do

@@ -1,6 +1,7 @@ --compiling the script requires the IO monad because it must load modules from the filesystem, so we create the function and generate the requisite DatabaseExpr here. module TutorialD.Interpreter.DatabaseContextIOOperator where import ProjectM36.Base+import ProjectM36.Interpreter import TutorialD.Interpreter.Base import TutorialD.Interpreter.Types import Data.Text

@@ -1,5 +1,6 @@ module TutorialD.Interpreter.Export.CSV where import ProjectM36.Relation.Show.CSV+import ProjectM36.Interpreter import TutorialD.Interpreter.Export.Base import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.Base hiding (try)

@@ -3,6 +3,7 @@ module TutorialD.Interpreter.Import.BasicExamples where import ProjectM36.DateExamples import ProjectM36.Base+import ProjectM36.Interpreter import ProjectM36.DatabaseContext import TutorialD.Interpreter.Base 

@@ -2,6 +2,7 @@ module TutorialD.Interpreter.Import.CSV where import TutorialD.Interpreter.Import.Base import ProjectM36.Base+import ProjectM36.Interpreter import ProjectM36.Error import ProjectM36.Relation.Parse.CSV hiding (quotedString) import qualified Data.ByteString.Lazy as BS

@@ -1,5 +1,6 @@ module TutorialD.Interpreter.Import.TutorialD where import ProjectM36.Base+import ProjectM36.Interpreter import TutorialD.Interpreter.Import.Base import TutorialD.Interpreter.Base hiding (try) import TutorialD.Interpreter.DatabaseContextExpr

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} module TutorialD.Interpreter.InformationOperator where import Data.Text+import ProjectM36.Interpreter import Text.Megaparsec import TutorialD.Interpreter.Base -- older versions of stack fail to

@@ -2,6 +2,7 @@ module TutorialD.Interpreter.RODatabaseContextOperator where import ProjectM36.Base import ProjectM36.Relation+import ProjectM36.Interpreter import qualified ProjectM36.DataFrame as DF import ProjectM36.Error import ProjectM36.Tuple@@ -96,7 +97,7 @@              <|> quitP  --logically, these read-only operations could happen purely, but not if a remote call is required-evalRODatabaseContextOp :: C.SessionId -> C.Connection -> RODatabaseContextOperator -> IO TutorialDOperatorResult+evalRODatabaseContextOp :: C.SessionId -> C.Connection -> RODatabaseContextOperator -> IO ConsoleResult evalRODatabaseContextOp sessionId conn (ShowRelationType expr) = do   res <- C.typeForRelationalExpr sessionId conn expr   case res of@@ -194,7 +195,7 @@   evalRODatabaseContextOp _ _ Quit = pure QuitResult -interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> T.Text -> IO TutorialDOperatorResult+interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> T.Text -> IO ConsoleResult interpretRODatabaseContextOp sessionId conn tutdstring = case parse roDatabaseContextOperatorP "" tutdstring of   Left err -> pure $ DisplayErrorResult (T.pack (show err))   Right parsed -> evalRODatabaseContextOp sessionId conn parsed@@ -202,13 +203,15 @@ showDataFrameP :: Parser RODatabaseContextOperator showDataFrameP = do   colonOp ":showdataframe"-  relExpr <- relExprP-  reservedOp "orderby"-  attrOrdersExpr <- attrOrdersExprP-  mbOffset <- optional offsetP-  mbLimit <- optional limitP-  pure $ ShowDataFrame (DF.DataFrameExpr relExpr attrOrdersExpr mbOffset mbLimit)+  ShowDataFrame <$> dataFrameP +dataFrameP :: Parser DF.DataFrameExpr+dataFrameP = do+  relExpr <- parens relExprP+  attrOrdersExpr <- try attrOrdersExprP <|> pure []+  mbLimit <- optional limitP+  mbOffset <- optional offsetP+  pure $ DF.DataFrameExpr relExpr attrOrdersExpr mbOffset mbLimit  offsetP :: Parser Integer offsetP = do@@ -221,7 +224,7 @@   natural  attrOrdersExprP :: Parser [DF.AttributeOrderExpr]-attrOrdersExprP = braces (sepBy attrOrderExprP comma)+attrOrdersExprP = reserved "orderby" *> braces (sepBy attrOrderExprP comma)  attrOrderExprP :: Parser DF.AttributeOrderExpr attrOrderExprP = DF.AttributeOrderExpr <$> identifier <*> orderP

@@ -7,6 +7,7 @@ import Text.Megaparsec.Expr #endif import ProjectM36.Base+import ProjectM36.Interpreter import TutorialD.Interpreter.Base import TutorialD.Interpreter.Types import qualified Data.Text as T@@ -82,9 +83,9 @@   reservedOp "rename"   renameList <- braces (sepBy renameClauseP comma)   case renameList of-    [] -> pure (Restrict TruePredicate) --no-op when rename list is empty+    [] -> pure id     renames ->-      pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames+      pure $ Rename (S.fromList renames)  whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP)@@ -157,7 +158,12 @@ relTerm = parens relExprP           <|> makeRelationP           <|> (relVarP <* notFollowedBy "(")+          <|> relationValuedAttributeP +relationValuedAttributeP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)+relationValuedAttributeP = do+  RelationValuedAttribute <$> (single '@' *> attributeNameP)+ restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) restrictionPredicateP = makeExprParser predicateTerm predicateOperators   where@@ -202,12 +208,13 @@  consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a) consumeAtomExprP consume = try functionAtomExprP <|>+            ifThenAtomExprP <|>  +            boolAtomExprP <|> -- we do this before the constructed atom parser to consume True and False              try (parens (constructedAtomExprP True)) <|>             constructedAtomExprP consume <|>+            relationalAtomExprP <|>             attributeAtomExprP <|>-            try nakedAtomExprP <|>-            relationalAtomExprP-            +            try nakedAtomExprP  attributeAtomExprP :: Parser (AtomExprBase a) attributeAtomExprP = do@@ -230,12 +237,26 @@         integerAtomP <|>         boolAtomP +-- Haskell-like if-then-else expression for TutorialD+ifThenAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)+ifThenAtomExprP = do+  reserved "if"+  ifE <- atomExprP+  reserved "then"+  thenE <- atomExprP+  reserved "else"+  IfThenAtomExpr ifE thenE <$> atomExprP+ functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) functionAtomExprP =   FunctionAtomExpr <$> functionNameP <*> parens (sepBy atomExprP comma) <*> parseMarkerP  relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)-relationalAtomExprP = RelationAtomExpr <$> relExprP+relationalAtomExprP = do+  expr <- relExprP+  case expr of+    RelationValuedAttribute attrName -> pure $ AttributeAtomExpr attrName+    other -> pure $ RelationAtomExpr other  stringAtomP :: Parser Atom stringAtomP = TextAtom <$> quotedString@@ -246,14 +267,18 @@ integerAtomP :: Parser Atom integerAtomP = IntegerAtom <$> integer +boolP :: Parser Bool+boolP =+  (chunk "True" >> spaceConsumer >> pure True) <|>+  (chunk "False" >> spaceConsumer >> pure False)+   boolAtomP :: Parser Atom-boolAtomP = do-  v <- identifier-  if v == "True" || v == "False" then-    pure $ BoolAtom (v == "t")    -    else-    fail "invalid boolAtom"-    +boolAtomP = +  BoolAtom <$> boolP++boolAtomExprP :: Parser (AtomExprBase a)+boolAtomExprP =+  NakedAtomExpr <$> boolAtomP  relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) relationAtomExprP = RelationAtomExpr <$> makeRelationP

@@ -1,5 +1,6 @@ module TutorialD.Interpreter.SchemaOperator where import Text.Megaparsec+import ProjectM36.Interpreter import ProjectM36.Base import ProjectM36.IsomorphicSchema import ProjectM36.Session

@@ -3,6 +3,7 @@ module TutorialD.Interpreter.TransGraphRelationalOperator where import ProjectM36.TransGraphRelationalExpression import ProjectM36.TransactionGraph+import ProjectM36.Interpreter import TutorialD.Interpreter.Types import qualified ProjectM36.Client as C @@ -37,7 +38,7 @@   reservedOp ":showtransgraphexpr"   ShowTransGraphRelation <$> relExprP     -evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO TutorialDOperatorResult+evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO ConsoleResult evalTransGraphRelationalOp sessionId conn (ShowTransGraphRelation expr) = do   res <- C.executeTransGraphRelationalExpr sessionId conn expr   case res of

@@ -3,6 +3,7 @@ import TutorialD.Interpreter.Base import ProjectM36.TransactionGraph hiding (autoMergeToHead) import ProjectM36.Client as C+import ProjectM36.Interpreter import ProjectM36.Base import ProjectM36.Relation (relationTrue) import Data.Functor

@@ -1,8 +1,10 @@ --parse type and data constructors module TutorialD.Interpreter.Types where import ProjectM36.Base+import ProjectM36.Interpreter import Text.Megaparsec import TutorialD.Interpreter.Base+import Control.Monad  class RelationalMarkerExpr a where   parseMarkerP :: Parser a@@ -14,7 +16,10 @@ typeConstructorNameP = capitalizedIdentifier  dataConstructorNameP :: Parser DataConstructorName-dataConstructorNameP = capitalizedIdentifier+dataConstructorNameP = try $ do+  ident <- capitalizedIdentifier+  when (ident `elem` ["True", "False"]) $ failure Nothing mempty --don't parse True or False as ConstructedAtoms (use NakedAtoms instead)+  pure ident  attributeNameP :: Parser AttributeName attributeNameP = try uncapitalizedIdentifier <|> quotedIdentifier

@@ -6,7 +6,9 @@ module TutorialD.Printer where import ProjectM36.Base import ProjectM36.Attribute as A hiding (null)+import ProjectM36.DataFrame import Prettyprinter+import Prettyprinter.Render.Text import qualified Data.Set as S hiding (fromList) import qualified Data.Vector as V import qualified Data.Map.Strict as M@@ -15,7 +17,14 @@ import qualified Data.ByteString.Base64 as B64 import qualified Data.Text.Encoding as TE import Data.UUID hiding (null)+import Data.Text (Text)+import TutorialD.Interpreter.Base (uncapitalizedIdentifier)+import Text.Megaparsec+import Data.Either (isLeft) +renderPretty :: Pretty a => a -> Text+renderPretty = renderStrict . layoutPretty defaultLayoutOptions . pretty+ instance Pretty Atom where   pretty (IntegerAtom x) = pretty x   pretty (IntAtom x) = "int" <> parensList [pretty x]@@ -34,28 +43,33 @@   pretty (ConstructedAtom n _ as) = pretty n <+> prettyList as  instance Pretty AtomExpr where-  pretty (AttributeAtomExpr attrName) = pretty attrName+  pretty (AttributeAtomExpr attrName) = prettyAttributeName ("@" <> attrName)   pretty (NakedAtomExpr atom)         = pretty atom   pretty (FunctionAtomExpr atomFuncName' atomExprs _) = pretty atomFuncName' <> prettyAtomExprsAsArguments atomExprs   pretty (RelationAtomExpr relExpr) = pretty relExpr+  pretty (IfThenAtomExpr ifE thenE elseE) = "if" <+> pretty ifE <+> "then" <+> pretty thenE <+> "else" <+> pretty elseE   pretty (ConstructedAtomExpr dName [] _) = pretty dName   pretty (ConstructedAtomExpr dName atomExprs _) = pretty dName <+> hsep (map prettyAtomExpr atomExprs)                                             prettyAtomExpr :: AtomExpr -> Doc ann prettyAtomExpr atomExpr =   case atomExpr of-    AttributeAtomExpr attrName -> "@" <> pretty attrName+    AttributeAtomExpr attrName -> "@" <> prettyAttributeName attrName     ConstructedAtomExpr dConsName [] () -> pretty dConsName     ConstructedAtomExpr dConsName atomExprs () -> parens (pretty dConsName <+> hsep (map prettyAtomExpr atomExprs))     _ -> pretty atomExpr      prettyAtomExprsAsArguments :: [AtomExpr] -> Doc ann-prettyAtomExprsAsArguments = align . parensList . map addAt+prettyAtomExprsAsArguments = {-align .-} parensList . map addAt   where addAt (atomExpr :: AtomExpr) =           case atomExpr of-            AttributeAtomExpr attrName -> "@" <> pretty attrName+            AttributeAtomExpr attrName -> "@" <> prettyAttributeName attrName             _ -> pretty atomExpr +nameNeedsQuoting :: StringType -> Bool+nameNeedsQuoting s =+  isLeft (parse uncapitalizedIdentifier "" s)+ instance Pretty UUID where   pretty = pretty . show @@ -76,6 +90,7 @@ instance Pretty RelationalExpr where   pretty (RelationVariable n _) = pretty n   pretty (ExistingRelation r) = pretty r+  pretty (RelationValuedAttribute attrName) = "@" <> prettyAttributeName attrName   pretty (NotEquals a b) = pretty' a <+> "!=" <+> pretty' b   pretty (Equals a b) = pretty' a <+> "==" <+> pretty' b   pretty (Project ns r) = pretty' (ignoreProjects r) <> pretty ns@@ -85,7 +100,7 @@   pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet)   pretty (Union a b) = parens $ pretty' a <+> "union" <+> pretty' b   pretty (Join a b) = parens $ pretty' a <+> "join" <+> pretty' b-  pretty (Rename n1 n2 relExpr) = parens $ pretty relExpr <+> "rename" <+> braces (pretty n1 <+> "as" <+> pretty n2)+  pretty (Rename attrs relExpr) = parens $ pretty relExpr <+> "rename" <+> prettyBracesList (map RenameTuple (S.toList attrs))   pretty (Difference a b) = parens $ pretty' a <+> "minus" <+> pretty' b   pretty (Group attrNames attrName relExpr) = parens $ pretty relExpr <+> "group" <+> parens (pretty attrNames <+> "as" <+> pretty attrName)   pretty (Ungroup attrName relExpr) = parens $ pretty' relExpr <+> "ungroup" <+> pretty attrName@@ -110,15 +125,15 @@ pretty' = prettyRelationalExpr  instance Pretty AttributeNames where-  pretty (AttributeNames attrNames) = prettyBracesList (S.toList attrNames)-  pretty (InvertedAttributeNames attrNames) = braces $ "all but" <+> concatWith (surround ", ") (map pretty (S.toList attrNames))+  pretty (AttributeNames attrNames) = bracesList (map prettyAttributeName (S.toList attrNames))+  pretty (InvertedAttributeNames attrNames) = braces $ "all but" <+> concatWith (surround ", ") (map prettyAttributeName (S.toList attrNames))   pretty (RelationalExprAttributeNames relExpr) = braces $ "all from" <+> pretty relExpr   pretty (UnionAttributeNames aAttrNames bAttrNames) = braces ("union of" <+> pretty aAttrNames <+> pretty bAttrNames)   pretty (IntersectAttributeNames aAttrNames bAttrNames) = braces ("intersection of" <+> pretty aAttrNames <+> pretty bAttrNames)  instance Pretty AttributeExpr where   pretty (NakedAttributeExpr attr) = pretty attr-  pretty (AttributeAndTypeNameExpr name typeCons _) = pretty name <+> pretty typeCons+  pretty (AttributeAndTypeNameExpr name typeCons _) = prettyAttributeName name <+> pretty typeCons  instance Pretty TypeConstructor where   pretty (ADTypeConstructor tcName []) = pretty tcName@@ -146,6 +161,11 @@ instance Pretty ExtendTupleExpr where   pretty (AttributeExtendTupleExpr attrName atomExpr) = pretty attrName <> ":=" <> pretty atomExpr +newtype RenameTuple = RenameTuple { _unRenameTuple :: (AttributeName, AttributeName) }+  +instance Pretty RenameTuple where+  pretty (RenameTuple (n1, n2)) = pretty n1 <+> "as" <+> prettyAttributeName n2+    instance Pretty RestrictionPredicateExpr where   pretty TruePredicate = "true"@@ -154,11 +174,90 @@   pretty (NotPredicate a) = "not" <+> pretty a    pretty (RelationalExprPredicate relExpr) = pretty relExpr   pretty (AtomExprPredicate atomExpr) = pretty atomExpr-  pretty (AttributeEqualityPredicate attrName atomExpr) = pretty attrName <> "=" <> pretty atomExpr+  pretty (AttributeEqualityPredicate attrName atomExpr) = prettyAttributeName attrName <> "=" <> pretty atomExpr +prettyAttributeName :: AttributeName -> Doc a+prettyAttributeName attrName | nameNeedsQuoting attrName = pretty $ "`" <> attrName <> "`"+prettyAttributeName attrName = pretty attrName + instance Pretty WithNameExpr where   pretty (WithNameExpr name _) = pretty name +instance Pretty DataFrameExpr where+  pretty df =+    ":showdataframe" <+>+    pretty (convertExpr df) <+>+    if null (orderExprs df) then+      mempty+      else+      "orderby" <+>+      prettyBracesList (orderExprs df)+    <+> prettyOffset (offset df)+    <+> prettyLimit (limit df)+    where+      prettyOffset Nothing = mempty+      prettyOffset (Just offset') = "offset" <+> pretty (show offset')+      prettyLimit Nothing = mempty+      prettyLimit (Just limit') = "limit" <+> pretty (show limit')++instance Pretty AttributeOrderExpr where+  pretty (AttributeOrderExpr attrName order) =+    pretty attrName <+> pretty order++instance Pretty Order where+  pretty AscendingOrder = "ascending"+  pretty DescendingOrder = "descending"++instance Pretty DatabaseContextExpr where+  pretty expr =+    case expr of+      NoOperation -> mempty+      Define rvname attrExprs -> pretty rvname <+> "::" <+> bracesList (map pretty attrExprs)+      Undefine rvname -> "undefine" <+> pretty rvname+      Assign rvname relExpr -> pretty rvname <+> ":=" <+> pretty relExpr+      Insert rvname relExpr -> "insert" <+> pretty rvname <+> pretty relExpr+      Delete rvname restExpr -> "delete" <+> pretty rvname <+> "where" <+> pretty restExpr+      Update rvname attrAtomMap restExpr -> "update" <+> pretty rvname <+> "where" <+> pretty restExpr <+> pretty attrAtomMap+      AddInclusionDependency idName (InclusionDependency idA idB) ->+        "constraint" <+> pretty idName <+> pretty idA <+> "in" <+> pretty idB+      RemoveInclusionDependency idName -> "deleteconstraint" <+> pretty idName+      AddNotification notName trigger old new ->+        "notify" <+> pretty notName <+> pretty trigger <+> pretty old <+> pretty new+      RemoveNotification notName ->+        "unnotify" <+> pretty notName+      AddTypeConstructor tConsDef dConss ->+        "data" <+> pretty tConsDef <+> "=" <+> group (encloseSep "" "" "| " (pretty <$> dConss))+      RemoveTypeConstructor tConsName ->+        "undata" <+> pretty tConsName+      RemoveAtomFunction fname ->+        "removeatomfunction" <+> pretty fname+      RemoveDatabaseContextFunction fname ->+        "removedatabasecontextfunction" <+> pretty fname+      ExecuteDatabaseContextFunction fname atomExprs ->+        "execute" <+> pretty fname <> prettyParensList atomExprs+      AddRegisteredQuery rQName relExpr ->+        "registerquery" <+> pretty rQName <+> pretty relExpr+      RemoveRegisteredQuery rQName ->+        "unregisterquery" <+> pretty rQName+      MultipleExpr dbcExprs ->+        group (encloseSep "" "" "; " (pretty <$> dbcExprs))++instance Pretty AttributeNameAtomExprMap where+  pretty m =+    group (encloseSep "(" ")" "," (map (\(attrName, atomExpr) -> prettyAttributeName attrName <+> ":=" <+> pretty atomExpr) (M.toList m)))+  +instance Pretty TypeConstructorDef where+  pretty (ADTypeConstructorDef tConsName tVarNames) = pretty tConsName <+> hsep (pretty <$> tVarNames)+  pretty (PrimitiveTypeConstructorDef tConsName _atomType') = pretty tConsName++instance Pretty DataConstructorDef where+  pretty (DataConstructorDef dConsName []) = pretty dConsName+  pretty (DataConstructorDef dConsName args) = "(" <+> pretty dConsName <+> hsep (pretty <$> args) <+> ")"++instance Pretty DataConstructorDefArg where+  pretty (DataConstructorDefTypeConstructorArg tCons) = pretty tCons+  pretty (DataConstructorDefTypeVarNameArg tVar) = pretty tVar+     bracesList :: [Doc ann] -> Doc ann bracesList = group . encloseSep (flatAlt "{ " "{") (flatAlt " }" "}") ", " 

@@ -1,73 +1,15 @@ {-# LANGUAGE CPP #-} import TutorialD.Interpreter-import ProjectM36.Base-import ProjectM36.Client-import ProjectM36.Server.ParseArgs-import ProjectM36.Server-import System.IO-import GHC.IO.Encoding-import Options.Applicative-import System.Exit-import Control.Monad-#if __GLASGOW_HASKELL__ < 804-import Data.Monoid-#endif-import Data.Maybe-import qualified Data.Text as T+import ProjectM36.Cli+import ProjectM36.DatabaseContext+import System.Directory+import System.FilePath  #if !defined(VERSION_project_m36) -# warning Failed to discover proper version from cabal_macros.h+# error Failed to discover proper version from cabal_macros.h # define VERSION_project_m36 "<unknown>" #endif -parseArgs :: Parser InterpreterConfig-parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> many parseGhcPkgPath <*> parseCheckFS <|>-            RemoteInterpreterConfig <$> parseHostname "127.0.0.1" <*> parsePort defaultServerPort <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS--parseHeadName :: Parser HeadName               -parseHeadName = option auto (long "head" <>-                             help "Start session at head name." <>-                             metavar "GRAPH HEAD NAME" <>-                             value "master"-                            )----just execute some tutd and exit-parseTutDExec :: Parser (Maybe TutorialDExec)-parseTutDExec = optional $ strOption (long "exec-tutd" <>-                           short 'e' <>-                           metavar "TUTORIALD" <>-                           help "Execute TutorialD expression and exit"-                           )--opts :: ParserInfo InterpreterConfig            -opts = info (parseArgs <**> helpOption) idm--connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo-connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths-connectionInfoForConfig (RemoteInterpreterConfig remoteHost remotePort remoteDBName _ _ _) = RemoteConnectionInfo remoteDBName remoteHost (show remotePort) outputNotificationCallback--headNameForConfig :: InterpreterConfig -> HeadName-headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn-headNameForConfig (RemoteInterpreterConfig _ _ _ headn _ _) = headn--execTutDForConfig :: InterpreterConfig -> Maybe String-execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t-execTutDForConfig (RemoteInterpreterConfig _ _ _ _ t _) = t--checkFSForConfig :: InterpreterConfig -> Bool-checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c-checkFSForConfig (RemoteInterpreterConfig _ _ _ _ _ c) = c--persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy-persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat-persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing-                         -errDie :: String -> IO ()                                                           -errDie err = hPutStrLn stderr err >> exitFailure--#ifndef VERSION_project_m36-#error VERSION_project_m36 is not defined-#endif printWelcome :: IO () printWelcome = do   putStrLn $ "Project:M36 TutorialD Interpreter " ++ VERSION_project_m36@@ -75,36 +17,7 @@   putStrLn "A full tutorial is available at:"   putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown" --- | If the locale is set to ASCII, upgrade it to UTF-8 because tutd outputs UTF-8-encoded attributes. This is especially important in light docker images where the locale data may be missing.-setLocaleIfNecessary :: IO ()-setLocaleIfNecessary = do-  l <- getLocaleEncoding-  when (textEncodingName l == "ASCII") (setLocaleEncoding utf8)-     main :: IO () main = do-  setLocaleIfNecessary-  interpreterConfig <- execParser opts-  let connInfo = connectionInfoForConfig interpreterConfig-  fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig))-  if not fscheck then-    errDie checkFSErrorMsg-    else do-    dbconn <- connectProjectM36 connInfo-    case dbconn of -      Left err -> -        errDie ("Failed to create database connection: " ++ show err)-      Right conn -> do-        let connHeadName = headNameForConfig interpreterConfig-        eSessionId <- createSessionAtHead conn connHeadName-        case eSessionId of -            Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)-            Right sessionId -> -              case execTutDForConfig interpreterConfig of-                Nothing -> do-                  printWelcome-                  _ <- reprLoop interpreterConfig sessionId conn-                  pure ()-                Just tutdStr -> -                  runTutorialD sessionId conn Nothing (T.pack tutdStr)-+  homeDir <- getHomeDirectory+  mainLoop printWelcome (homeDir </> ".tutd_history") runTutorialD promptText runTutorialD basicDatabaseContext

@@ -5,13 +5,11 @@ import ProjectM36.Persist import ProjectM36.RelationalExpression import ProjectM36.Error-import ProjectM36.Transaction.Persist+import ProjectM36.TransactionGraph import qualified Data.Text as T import qualified Data.Vector as V-import Control.Monad.Trans.Reader import qualified ProjectM36.DatabaseContext as DBC import qualified Data.Set as S-import Data.Monoid import System.IO.Temp import System.FilePath import System.Directory@@ -38,23 +36,23 @@ createRelation' x y = validate (createRelation x y)  restrictRelationToOneTuple :: Int -> Relation ->  Relation-restrictRelationToOneTuple match rel = validate (runReader (evalRelationalExpr restriction) exprState)+restrictRelationToOneTuple match rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr restriction))  where-  exprState = mkRelationalExprState DBC.empty   restriction = Restrict predicateMatch (ExistingRelation rel)   predicateMatch = AttributeEqualityPredicate "a0" (NakedAtomExpr (IntAtom match))  restrictRelationToHalfRelation :: Int -> Relation -> Relation-restrictRelationToHalfRelation cutoff rel = validate (runReader (evalRelationalExpr restriction) exprState)+restrictRelationToHalfRelation cutoff rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr restriction))  where-  exprState = mkRelationalExprState DBC.basicDatabaseContext   restriction = Restrict predicateMatch (ExistingRelation rel)   predicateMatch = AtomExprPredicate (FunctionAtomExpr "lte" [AttributeAtomExpr "a0", NakedAtomExpr (IntAtom cutoff)] ()) +basicREEnv :: RelationalExprEnv+basicREEnv = mkRelationalExprEnv DBC.basicDatabaseContext emptyTransactionGraph+ projectRelationToAttributes :: AttributeNames -> Relation -> Relation-projectRelationToAttributes attrNames rel = validate (runReader (evalRelationalExpr projection) exprState)+projectRelationToAttributes attrNames rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr projection))  where-  exprState = mkRelationalExprState DBC.empty   projection = Project attrNames (ExistingRelation rel)  unionRelations :: Relation -> Relation -> Relation@@ -64,9 +62,7 @@ joinRelations relA relB = validate (join relA relB)  groupRelation :: AttributeNames -> Relation -> Relation-groupRelation attrNames rel = validate (runReader (evalRelationalExpr (Group attrNames "x" (ExistingRelation rel))) exprState)- where-  exprState = mkRelationalExprState DBC.empty+groupRelation attrNames rel = validate (runRelationalExprM basicREEnv (evalRelationalExpr (Group attrNames "x" (ExistingRelation rel))))  bigRelAttrNames :: Int -> Int -> AttributeNames bigRelAttrNames start end = AttributeNames (S.fromList (map (\i -> "a" <> T.pack (show i)) [start .. end]))@@ -101,6 +97,6 @@   group100 = bench "group 10x100" (nf (groupRelation (bigRelAttrNames 1 9)) bigrel100)    writeRel tmpDir = bgroup "write" [writeRel10000 tmpDir]-  writeRel10000 tmpDir = bench "write 10x1000" $ nfIO (writeRelVar FsyncDiskSync tmpDir ("x", bigrel10000))+  writeRel10000 tmpDir = bench "write 10x1000" $ nfIO (writeSerialiseSync FsyncDiskSync tmpDir ("x"::String, bigrel10000))    

@@ -4,7 +4,8 @@ import ProjectM36.Persist import Options.Applicative import TutorialD.Interpreter-import TutorialD.Interpreter.Base hiding (Parser, option)+import ProjectM36.Interpreter hiding (Parser)+import TutorialD.Interpreter.Base hiding (option) import qualified Data.Text as T #if __GLASGOW_HASKELL__ < 804 import Data.Monoid@@ -48,8 +49,8 @@  runOpenClose :: T.Text -> T.Text -> Int -> FilePath -> IO () runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do-  let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback []-  eConn <- connectProjectM36 connInfo+  let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback [] basicDatabaseContext+  eConn <- connectProjectM36 connInfo    case eConn of     Left err -> error (show err)     Right conn -> do

@@ -38,7 +38,7 @@ main = do   let parser = info (parseOptions <**> helper) (fullDesc <> progDesc "Read or write data for heap profiling.")   opts <- execParser parser-  let connInfo = InProcessConnectionInfo (MinimalPersistence (datadir opts)) emptyNotificationCallback []+  let connInfo = InProcessConnectionInfo (MinimalPersistence (datadir opts)) emptyNotificationCallback [] basicDatabaseContext       eCheck v = do         x <- v         case x of 

@@ -23,7 +23,7 @@ --test local connection speeds of inserts, updates, and deletes to look for space leaks, etc. main :: IO () main = do-  conn <- handleIOError $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [])+  conn <- handleIOError $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext)   sess <- handleIOError $ createSessionAtHead conn "master"   _ <- handleIOError $ executeDatabaseContextExpr sess conn (toDefineExpr (Proxy :: Proxy User) "user") 

@@ -20,6 +20,13 @@              funcBody = body (\case                                  IntegerAtom i1:IntegerAtom i2:_ -> pure (IntegerAtom (i1 + i2))                                  _ -> Left AtomFunctionTypeMismatchError)},+    Function { funcName = "abs",+               funcType = [IntegerAtomType, IntegerAtomType],+               funcBody = body (\case+                                   IntegerAtom i:_ -> pure $ IntegerAtom (abs i)+                                   _ -> Left AtomFunctionTypeMismatchError+                               )+             },     Function { funcName = "id",                funcType = [TypeVariableType "a", TypeVariableType "a"],                funcBody = body (\case@@ -42,8 +49,12 @@                funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,                funcBody = body $ relationAtomFunc relationMin              },+    Function { funcName = "mean",+               funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,+               funcBody = body $ relationAtomFunc relationMean+             },     Function { funcName = "eq",-               funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+               funcType = [TypeVariableType "a", TypeVariableType "a", BoolAtomType],                funcBody = body $ \case                                          [i1,i2] -> pure (BoolAtom (i1 == i2))                                          _ -> Left AtomFunctionTypeMismatchError@@ -92,7 +103,22 @@                        Just u -> pure $ UUIDAtom u                        Nothing -> Left $ InvalidUUIDString v                  _ -> Left AtomFunctionTypeMismatchError+             },+    Function { funcName = "and",+               funcType = [BoolAtomType, BoolAtomType, BoolAtomType],+               funcBody = body $ \case+                 [BoolAtom b1, BoolAtom b2] ->+                   Right $ BoolAtom (b1 && b2)+                 _ -> Left AtomFunctionTypeMismatchError+             },+    Function { funcName = "or",+               funcType = [BoolAtomType, BoolAtomType, BoolAtomType],+               funcBody = body $ \case+                 [BoolAtom b1, BoolAtom b2] ->+                   Right $ BoolAtom (b1 || b2)+                 _ -> Left AtomFunctionTypeMismatchError                                 }+       ] <> scientificAtomFunctions   where     body = FunctionBuiltInBody@@ -132,6 +158,15 @@   Just oneTup -> pure (IntegerAtom (relFold (\tupIn acc -> min acc (newVal tupIn)) (newVal oneTup) relIn))   where     newVal tupIn = castInteger (tupleAtoms tupIn V.! 0)++relationMean :: Relation -> Either AtomFunctionError Atom+relationMean relIn = case oneTuple relIn of+  Nothing -> Left AtomFunctionEmptyRelationError+  Just _oneTup -> do+    let (sum'', count') = relFold (\tupIn (sum', count) -> (sum' + newVal tupIn, count + 1)) (0, 0) relIn+        newVal tupIn = castInteger (tupleAtoms tupIn V.! 0)+    pure (IntegerAtom (sum'' `div` count'))+      castInt :: Atom -> Int castInt (IntAtom i) = i

@@ -161,7 +161,7 @@   toAtom (x NE.:| xs) = ConstructedAtom "NECons" (nonEmptyListAtomType (toAtomType (Proxy :: Proxy a))) [toAtom x, toAtom xs]   fromAtom (ConstructedAtom "NECons" _ [x]) = fromAtom x NE.:| []   fromAtom (ConstructedAtom "NECons" _ [x,y] ) = fromAtom x NE.:| fromAtom y-  fromAtom x = error "improper fromAtom (NonEmptyList a)"+  fromAtom _x = error "improper fromAtom (NonEmptyList a)"    toAtomType _ = ConstructedAtomType "NonEmptyList" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))   toAddTypeExpr _ = NoOperation

@@ -135,6 +135,11 @@                    else                      attr +renameAttributes' :: S.Set (AttributeName, AttributeName) -> Attributes -> Attributes+renameAttributes' renameSet attrs = +  foldr (\(old, new) acc -> renameAttributes old new acc) attrs renameSet+    + atomTypeForAttributeName :: AttributeName -> Attributes -> Either RelationalError AtomType atomTypeForAttributeName attrName attrs = do   (Attribute _ atype) <- attributeForName attrName attrs@@ -172,6 +177,9 @@ attributeNames :: Attributes -> V.Vector AttributeName attributeNames attrs = V.map attributeName (attributesVec attrs) +attributeNamesList :: Attributes -> [AttributeName]+attributeNamesList = V.toList . attributeNames+ --checks if set s1 is wholly contained in the set s2 attributesContained :: Attributes -> Attributes -> Bool attributesContained attrs1 attrs2 = attributeNamesContained (attributeNameSet attrs1) (attributeNameSet attrs2)@@ -225,7 +233,7 @@ verifyAttributes attrs =   if vecSet == attributesSet attrs then     pure attrs-  else+  else do     Left (TupleAttributeTypeMismatchError diffAttrs)   where     vecSet = V.foldr' HS.insert HS.empty (attributesVec attrs)

@@ -1,6 +1,7 @@ module ProjectM36.AttributeNames where import ProjectM36.Base import qualified Data.Set as S+import Data.List (foldl') --AttributeNames is a data structure which can represent inverted projection attributes and attribute names derived from relational expressions  empty :: AttributeNamesBase a@@ -9,3 +10,18 @@ all :: AttributeNamesBase a all = InvertedAttributeNames S.empty +-- | Coalesce a bunch of AttributeNames into a single AttributeNames.+some :: Eq a => [AttributeNamesBase a] -> AttributeNamesBase a+some [] = ProjectM36.AttributeNames.all+some [an] = an+some (a:as) = foldl' folder a as+  where+    folder :: Eq a => AttributeNamesBase a -> AttributeNamesBase a -> AttributeNamesBase a+    folder acc names =+      case acc of+        AttributeNames an | S.null an -> names+        acc' -> if names == empty then+                  acc+                else+                  UnionAttributeNames acc' names+      

@@ -105,9 +105,6 @@                 --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor               deriving (Eq, NFData, Generic, Show, Read, Hashable) -instance Ord AtomType where-  compare = undefined- -- this should probably be an ordered dictionary in order to be able to round-trip these arguments   type TypeVarMap = M.Map TypeVarName AtomType @@ -237,13 +234,15 @@   --- | Reference a relation variable by its name.   RelationVariable RelVarName a |      --- | Create a projection over attribute names. (Note that the 'AttributeNames' structure allows for the names to be inverted.)+  RelationValuedAttribute AttributeName |+  -- | Extract a relation from an `Atom` that is a nested relation (a relation within a relation).   Project (AttributeNamesBase a) (RelationalExprBase a) |   --- | Create a union of two relational expressions. The expressions should have identical attributes.   Union (RelationalExprBase a) (RelationalExprBase a) |   --- | Create a join of two relational expressions. The join occurs on attributes which are identical. If the expressions have no overlapping attributes, the join becomes a cross-product of both tuple sets.   Join (RelationalExprBase a) (RelationalExprBase a)  |   --- | Rename an attribute (first argument) to another (second argument).-  Rename AttributeName AttributeName (RelationalExprBase a) |+  Rename (S.Set (AttributeName, AttributeName)) (RelationalExprBase a) | -- should the rename be a Map?   --- | Return a relation containing all tuples of the first argument which do not appear in the second argument (minus).   Difference (RelationalExprBase a) (RelationalExprBase a) |   --- | Create a sub-relation composed of the first argument's attributes which will become an attribute of the result expression. The unreferenced attributes are not altered in the result but duplicate tuples in the projection of the expression minus the attribute names are compressed into one. For more information, <https://github.com/agentm/project-m36/blob/master/docs/introduction_to_the_relational_algebra.markdown#group read the relational algebra tutorial.>@@ -258,13 +257,19 @@   Extend (ExtendTupleExprBase a) (RelationalExprBase a) |   --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend   --Evaluate relationalExpr with scoped views-  With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)+  With (WithNamesAssocsBase a) (RelationalExprBase a)   deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable)  instance Hashable RelationalExpr-    ++type WithNamesAssocs = WithNamesAssocsBase ()++type WithNamesAssocsBase a = [(WithNameExprBase a, RelationalExprBase a)]++type GraphRefWithNameAssocs = [(GraphRefWithNameExpr, GraphRefRelationalExpr)]+ data WithNameExprBase a = WithNameExpr RelVarName a-  deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable, Hashable)+                        deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable, Hashable)  type WithNameExpr = WithNameExprBase () @@ -454,6 +459,9 @@ transactionsForGraph :: TransactionGraph -> S.Set Transaction transactionsForGraph (TransactionGraph _ ts) = ts +transactionIdsForGraph :: TransactionGraph -> S.Set TransactionId+transactionIdsForGraph = S.map transactionId . transactionsForGraph+ -- | Every transaction has context-specific information attached to it. -- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch). data TransactionInfo = TransactionInfo {@@ -463,11 +471,6 @@   } deriving (Show, Generic)  type TransactionParents = NE.NonEmpty TransactionId-{--data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children-                       MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children-                     deriving (Show, Generic)--}  -- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction. type TransactionId = UUID@@ -502,10 +505,11 @@ type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker  -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple.-data AtomExprBase a = AttributeAtomExpr AttributeName |+data AtomExprBase a = AttributeAtomExpr !AttributeName |                       NakedAtomExpr !Atom |                       FunctionAtomExpr FunctionName [AtomExprBase a] a |                       RelationAtomExpr (RelationalExprBase a) |+                      IfThenAtomExpr (AtomExprBase a) (AtomExprBase a) (AtomExprBase a) | -- if, then, else                       ConstructedAtomExpr DataConstructorName [AtomExprBase a] a                     deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable)                        

@@ -48,6 +48,8 @@        defaultHeadName,        addClientNode,        getDDLHash,+       convertSQLQuery,+       convertSQLDBUpdates,        PersistenceStrategy(..),        RelationalExpr,        RelationalExprBase(..),@@ -105,12 +107,14 @@        TupleExprsBase(..),        AtomExprBase(..),        RestrictionPredicateExprBase(..),-       withTransaction+       withTransaction,+       basicDatabaseContext        ) where import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well import qualified ProjectM36.Base as B import ProjectM36.Serialise.Error () import ProjectM36.Error+import ProjectM36.DatabaseContext import ProjectM36.Atomable import ProjectM36.AtomFunction as AF import ProjectM36.StaticOptimizer@@ -120,7 +124,6 @@ import qualified ProjectM36.IsomorphicSchema as Schema import Control.Monad.State import qualified ProjectM36.RelationalExpression as RE-import ProjectM36.DatabaseContext (basicDatabaseContext) import qualified ProjectM36.TransactionGraph as Graph import ProjectM36.TransactionGraph as TG import qualified ProjectM36.Transaction as Trans@@ -168,6 +171,9 @@ import qualified Network.RPC.Curryer.Server as RPC import Network.Socket (Socket, AddrInfo(..), getAddrInfo, defaultHints, AddrInfoFlag(..), SocketType(..), ServiceName, hostAddressToTuple, SockAddr(..)) import GHC.Conc (unsafeIOToSTM)+import ProjectM36.SQL.Select as SQL+import ProjectM36.SQL.DBUpdate as SQL+import ProjectM36.SQL.Convert   type Hostname = String @@ -193,7 +199,7 @@ instance Exception RequestTimeoutException  -- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via RPC.-data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] |+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath] DatabaseContext |                       RemoteConnectionInfo DatabaseName Hostname ServiceName NotificationCallback                        type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification@@ -260,11 +266,10 @@ -- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'. connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection) --create a new in-memory database/transaction graph-connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do+connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths bootstrapDatabaseContext) = do   freshId <- nextRandom   tstamp <- getCurrentTime-  let bootstrapContext = basicDatabaseContext -      freshGraph = bootstrapTransactionGraph tstamp freshId bootstrapContext+  let freshGraph = bootstrapTransactionGraph tstamp freshId bootstrapDatabaseContext   case strat of     --create date examples graph for now- probably should be empty context in the future     NoPersistence -> do@@ -1096,6 +1101,46 @@         graph <- readTVar (ipTransactionGraph conf)         pure (ddlHash ctx graph) getDDLHash sessionId conn@RemoteConnection{} = remoteCall conn (GetDDLHash sessionId)++-- | Convert a SQL Query expression into a DataFrameExpr. Because the conversion process requires substantial database metadata access (such as retrieving types for various subexpressions), we cannot process SQL client-side. However, the underlying DBMS is completely unaware that the resultant DataFrameExpr has come from SQL.+convertSQLQuery :: SessionId -> Connection -> Query -> IO (Either RelationalError DF.DataFrameExpr)+convertSQLQuery sessionId (InProcessConnection conf) query = do+  let sessions = ipSessions conf+      graphTvar = ipTransactionGraph conf  +  atomically $ do+    transGraph <- readTVar graphTvar    +    eSession <- sessionAndSchema sessionId sessions+    case eSession of+      Left err -> pure (Left err)+      Right (session, _schema) -> do -- TODO: enable SQL to leverage isomorphic schemas+        let ctx = Sess.concreteDatabaseContext session+            reEnv = RE.mkRelationalExprEnv ctx transGraph+            typeF expr =+              RE.runRelationalExprM reEnv (RE.typeForRelationalExpr expr) +        -- convert SQL data into DataFrameExpr+        case evalConvertM mempty (convertQuery typeF query) of+          Left err -> pure (Left (SQLConversionError err))+          Right dfExpr -> pure (Right dfExpr)+convertSQLQuery sessionId conn@RemoteConnection{} q = remoteCall conn (ConvertSQLQuery sessionId q)++convertSQLDBUpdates :: SessionId -> Connection -> [SQL.DBUpdate] -> IO (Either RelationalError DatabaseContextExpr)+convertSQLDBUpdates sessionId (InProcessConnection conf) updates = do+  let sessions = ipSessions conf+      graphTvar = ipTransactionGraph conf  +  atomically $ do+    transGraph <- readTVar graphTvar    +    eSession <- sessionAndSchema sessionId sessions+    case eSession of+      Left err -> pure (Left err)+      Right (session, _schema) -> do -- TODO: enable SQL to leverage isomorphic schemas+        let ctx = Sess.concreteDatabaseContext session+            reEnv = RE.mkRelationalExprEnv ctx transGraph+            typeF = optimizeAndEvalRelationalExpr reEnv -- TODO: replace with typeForRelationalExpr+        -- convert SQL data into DataFrameExpr+        case evalConvertM mempty (convertDBUpdates typeF updates) of+          Left err -> pure (Left (SQLConversionError err))+          Right updateExpr -> pure (Right updateExpr)+convertSQLDBUpdates sessionId conn@RemoteConnection{} ups = remoteCall conn (ConvertSQLUpdates sessionId ups)     registeredQueriesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) registeredQueriesAsRelation sessionId (InProcessConnection conf) = do

@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveGeneric, DerivingVia #-}+{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-} {- A dataframe is a strongly-typed, ordered list of named tuples. A dataframe differs from a relation in that its tuples are ordered.-} module ProjectM36.DataFrame where import ProjectM36.Base-import ProjectM36.Attribute as A hiding (drop)+import qualified ProjectM36.Attribute as A hiding (drop) import ProjectM36.Error import qualified ProjectM36.Relation as R import ProjectM36.Relation.Show.Term@@ -14,6 +14,8 @@ import GHC.Generics import qualified Data.List as L import qualified Data.Set as S+import qualified Data.HashSet as HS+import Data.Hashable (Hashable) import Data.Maybe import qualified Data.Text as T import Control.Arrow@@ -23,10 +25,10 @@ #endif  data AttributeOrderExpr = AttributeOrderExpr AttributeName Order-  deriving (Show, Generic)+  deriving (Show, Generic, Eq)  data AttributeOrder = AttributeOrder AttributeName Order-  deriving (Show, Generic)+  deriving (Show, Generic, Eq)  data Order = AscendingOrder | DescendingOrder   deriving (Eq, Show, Generic)@@ -47,13 +49,23 @@   }   deriving (Show, Generic) +-- if there is no ordering, then compare sets of tuples+instance Eq DataFrame where+  dfA == dfB =+    attributes dfA == attributes dfB &&+    orders dfA == orders dfB &&+    if null (orders dfA) && null (orders dfB) then+      HS.fromList (tuples dfA) == HS.fromList (tuples dfB)+      else+      tuples dfA == tuples dfB+ data DataFrameTuple = DataFrameTuple Attributes (V.Vector Atom)-  deriving (Eq, Show, Generic)+  deriving (Eq, Show, Generic, Hashable)  sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame sortDataFrameBy attrOrders frame = do   attrs <- mapM (\(AttributeOrder nam _) -> A.attributeForName nam (attributes frame)) attrOrders -  mapM_ (\attr -> unless (isSortableAtomType (atomType attr)) $ Left (AttributeNotSortableError attr)) attrs+  mapM_ (\attr -> unless (isSortableAtomType (A.atomType attr)) $ Left (AttributeNotSortableError attr)) attrs   pure $ DataFrame attrOrders (attributes frame) (sortTuplesBy (compareTupleByAttributeOrders attrOrders) (tuples frame))  sortTuplesBy :: (DataFrameTuple -> DataFrameTuple -> Ordering) -> [DataFrameTuple] -> [DataFrameTuple]@@ -79,7 +91,7 @@         Right atom2 -> compareAtoms atom1 atom2  atomForAttributeName :: AttributeName -> DataFrameTuple -> Either RelationalError Atom-atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) (attributesVec tupAttrs) of+atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> A.attributeName attr == attrName) (attributesVec tupAttrs) of   Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))   Just index -> case tupVec V.!? index of     Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))@@ -106,10 +118,10 @@ dataFrameAsTable :: DataFrame -> Table dataFrameAsTable df = (header, body)   where-    oAttrNames = orderedAttributeNames (attributes df)-    oAttrs = orderedAttributes (attributes df)+    oAttrNames = A.orderedAttributeNames (attributes df)+    oAttrs = A.orderedAttributes (attributes df)     header = "DF" : map dfPrettyAttribute oAttrs-    dfPrettyAttribute attr = prettyAttribute attr <> case L.find (\(AttributeOrder nam _) -> nam == attributeName attr) (orders df) of+    dfPrettyAttribute attr = prettyAttribute attr <> case L.find (\(AttributeOrder nam _) -> nam == A.attributeName attr) (orders df) of       Nothing -> arbitrary       Just (AttributeOrder _ AscendingOrder) -> ascending       Just (AttributeOrder _ DescendingOrder) -> descending@@ -127,8 +139,19 @@   offset :: Maybe Integer,   limit :: Maybe Integer   }-  deriving (Show, Generic)+  deriving (Show, Generic, Eq) +-- | True iff dataframe features are required to execute this expression, False if this expression could be evaluated as a relational expression (no sorting, limit, or offset).+usesDataFrameFeatures :: DataFrameExpr -> Bool+usesDataFrameFeatures df = not (null (orderExprs df)) || isJust (offset df) || isJust (limit df)++-- | Returns a data frame expression without any sorting or limits.+nakedDataFrameExpr :: RelationalExpr -> DataFrameExpr+nakedDataFrameExpr rexpr = DataFrameExpr { convertExpr = rexpr,+                                           orderExprs = [],+                                           offset = Nothing,+                                           limit = Nothing }+ dataFrameAsHTML :: DataFrame -> T.Text -- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser dataFrameAsHTML df @@ -160,7 +183,7 @@     folder tuple acc = acc <> tupleAsHTML tuple  tupleAssocs :: DataFrameTuple -> [(AttributeName, Atom)]-tupleAssocs (DataFrameTuple attrs tupVec) = V.toList $ V.map (first attributeName) (V.zip (attributesVec attrs) tupVec)+tupleAssocs (DataFrameTuple attrs tupVec) = V.toList $ V.map (first A.attributeName) (V.zip (attributesVec attrs) tupVec)       tupleAsHTML :: DataFrameTuple -> T.Text@@ -174,7 +197,7 @@ attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (A.toList attrs)) <> "</tr>"   where-    oneAttrHTML attr = "<th>" <> prettyAttribute attr <> ordering (attributeName attr) <> "</th>"+    oneAttrHTML attr = "<th>" <> prettyAttribute attr <> ordering (A.attributeName attr) <> "</th>"     ordering attrName = " " <> case L.find (\(AttributeOrder nam _) -> nam == attrName) orders' of       Nothing -> "(arb)"       Just (AttributeOrder _ AscendingOrder) -> "(asc)"

@@ -0,0 +1,329 @@+module ProjectM36.DataTypes.SQL.Null where+import ProjectM36.Base+import ProjectM36.AtomFunctionError+import qualified Data.Map as M+import qualified Data.HashSet as HS+import ProjectM36.DataTypes.Primitive+import qualified Data.Vector as V+import ProjectM36.AtomFunction+import ProjectM36.Tuple+import ProjectM36.Relation+import Data.Maybe (isJust)+import Data.Text (Text)++-- analogous but not equivalent to a Maybe type due to how NULLs interact with every other value++nullAtomType :: AtomType -> AtomType+nullAtomType arg = ConstructedAtomType "SQLNullable" (M.singleton "a" arg)++nullTypeConstructorMapping :: TypeConstructorMapping+nullTypeConstructorMapping = [(ADTypeConstructorDef "SQLNullable" ["a"],+                                [DataConstructorDef "SQLNull" [],+                                 DataConstructorDef "SQLJust" [DataConstructorDefTypeVarNameArg "a"]]),+                               -- used in SQL conversion from in expressions such as INSERT INTO s(city) VALUES (NULL) where the query expression must defer type resolution to SQLNull.+                               (ADTypeConstructorDef "SQLNullOfUnknownType" [],+                                [DataConstructorDef "SQLNullOfUnknownType" []])+                              ]++nullAtomFunctions :: AtomFunctions+nullAtomFunctions = HS.fromList [+    Function {+      funcName = "sql_equals",+      funcType = [TypeVariableType "a",+                  TypeVariableType "b", -- either type could be SQLNullable or a NakedAtom+                  nullAtomType BoolAtomType],+      funcBody = FunctionBuiltInBody sqlEquals+      },+    Function {+      funcName = "sql_and",+      funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType+      funcBody = FunctionBuiltInBody nullAnd+      },+    Function {+      funcName = "sql_or",+      funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType], -- for a more advanced typechecker, this should be BoolAtomType or SQLNullable BoolAtomType+      funcBody = FunctionBuiltInBody nullOr+             },+    Function {+      funcName = "sql_coalesce_bool", -- used in where clause so that NULLs are filtered out+      funcType = [TypeVariableType "a",+                  BoolAtomType],+      funcBody = FunctionBuiltInBody coalesceBool+      },+    Function {+      funcName = "sql_add",+      funcType = [TypeVariableType "a", +                  TypeVariableType "b",+                  nullAtomType IntegerAtomType],+      funcBody = FunctionBuiltInBody (sqlIntegerBinaryFunction IntegerAtomType (\a b -> IntegerAtom (a + b)))+      },+    Function {+      funcName = "sql_abs",+      funcType = [TypeVariableType "a",+                  nullAtomType IntegerAtomType],+      funcBody = FunctionBuiltInBody sqlAbs+      },+    Function {+      funcName = "sql_negate",+      funcType = [TypeVariableType "a",+                  nullAtomType IntegerAtomType],+      funcBody = FunctionBuiltInBody (sqlIntegerUnaryFunction IntegerAtomType (\a -> IntegerAtom (- a)))+      },+    Function {+      funcName = "sql_max",+      funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType),+      funcBody = FunctionBuiltInBody sqlMax+      },+    Function {+      funcName = "sql_min",+      funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType),+      funcBody = FunctionBuiltInBody sqlMin+      },+    Function {+      funcName = "sql_count",+      funcType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType,+      funcBody = FunctionBuiltInBody sqlCount+      },+    Function {+      funcName = "sql_sum",+      funcType = foldAtomFuncType (TypeVariableType "a") (nullAtomType IntegerAtomType),+      funcBody = FunctionBuiltInBody sqlSum+      },+    Function {+      funcName = "sql_isnull",+      funcType = [TypeVariableType "a", BoolAtomType],+      funcBody = FunctionBuiltInBody sqlIsNull+      }+    ] <> sqlCompareFunctions+++sqlCompareFunctions :: HS.HashSet AtomFunction+sqlCompareFunctions = HS.fromList $+  map mkFunc ops+  where+    mkFunc (sql_func, opi, opt) =+      Function {+      funcName = sql_func,+        funcType = [TypeVariableType "a", TypeVariableType "b", nullAtomType BoolAtomType],+        funcBody = FunctionBuiltInBody (sqlCompareFunc (opi, opt))+      }+    boolNull = nullAtom BoolAtomType Nothing+    sqlCompareFunc :: (Integer -> Integer -> Bool, Text -> Text -> Bool) -> [Atom] -> Either AtomFunctionError Atom+    sqlCompareFunc (opi, opt) [atomA, atomB] = +      case (maybeFromAtom atomA, maybeFromAtom atomB) of+        (Nothing, _) -> pure boolNull+        (_, Nothing) -> pure boolNull+        (Just (IntegerAtom a), Just (IntegerAtom b)) -> pure $ nullAtom BoolAtomType (Just (BoolAtom (opi a b)))+        (Just (TextAtom a), Just (TextAtom b)) -> pure (nullAtom BoolAtomType (Just (BoolAtom (opt a b))))+        _ -> Left AtomFunctionTypeMismatchError+    sqlCompareFunc _ _ = Left AtomFunctionTypeMismatchError+    ops :: [(FunctionName,+              Integer -> Integer -> Bool,+              Text -> Text -> Bool)]+    ops = [("sql_gt", (>), (>)),+            ("sql_lt", (<), (<)),+            ("sql_gte", (>=), (>=)),+            ("sql_lte", (<=), (<=))+           ]++maybeFromAtom :: Atom -> Maybe Atom+maybeFromAtom atom | isNull atom = Nothing+maybeFromAtom atom = Just atom           ++coalesceBool :: [Atom] -> Either AtomFunctionError Atom+coalesceBool [arg] = case sqlBool arg of+                       Nothing -> pure (BoolAtom False)+                       Just tf -> pure (BoolAtom tf)+coalesceBool _other = Left AtomFunctionTypeMismatchError                       ++isSQLBool :: Atom -> Bool+isSQLBool atom = case atomTypeForAtom atom of+                   ConstructedAtomType "SQLNullable" _ -> True+                   ConstructedAtomType "SQLNullOfUnknownType" _ -> True+                   BoolAtomType -> True+                   _ -> False++sqlBool :: Atom -> Maybe Bool+sqlBool (ConstructedAtom dConsName aType [BoolAtom tf]) |+  dConsName == "SQLJust" &&+  (aType == nullAtomType BoolAtomType ||+   aType == nullAtomType (TypeVariableType "a")) = Just tf+sqlBool (ConstructedAtom dConsName aType []) |+  dConsName == "SQLNull" &&+  (aType == nullAtomType BoolAtomType ||+   aType == nullAtomType (TypeVariableType "a")) = Nothing+sqlBool (ConstructedAtom "SQLNullOfUnknownType" _ []) = Nothing+sqlBool (BoolAtom tf) = Just tf+sqlBool x | isSQLBool x = error "internal sqlBool type error" -- should be caught above+sqlBool other = error ("sqlBool type mismatch: " <> show other)++nullAnd :: [Atom] -> Either AtomFunctionError Atom+nullAnd [a,b] | isSQLBool a && isSQLBool b = do+                  let bNull = nullAtom BoolAtomType Nothing+                      boolF = nullAtom BoolAtomType (Just (BoolAtom False))+                  pure $ case (sqlBool a, sqlBool b) of+                             (Nothing, Nothing) -> bNull+                             (Nothing, Just True) -> bNull+                             (Nothing, Just False) -> boolF+                             (Just True, Nothing) -> bNull+                             (Just False, Nothing) -> boolF+                             (Just a', Just b') ->+                               nullAtom BoolAtomType (Just (BoolAtom (a' && b')))+nullAnd _other = Left AtomFunctionTypeMismatchError++nullOr :: [Atom] -> Either AtomFunctionError Atom+nullOr [a,b] | isSQLBool a && isSQLBool b = do+                let bNull = nullAtom BoolAtomType Nothing+                    boolTF tf = nullAtom BoolAtomType (Just (BoolAtom tf))+                pure $ case (sqlBool a, sqlBool b) of+                  (Nothing, Nothing) -> bNull+                  (Nothing, Just True) -> boolTF True+                  (Nothing, Just False) -> bNull+                  (Just True, Nothing) -> boolTF True+                  (Just False, Nothing) -> bNull+                  (Just a', Just b') -> boolTF (a' || b')+nullOr _other = Left AtomFunctionTypeMismatchError                  +                +nullAtom :: AtomType -> Maybe Atom -> Atom+nullAtom aType mAtom =+  case mAtom of+    Nothing -> ConstructedAtom "SQLNull" (nullAtomType aType) []+    Just atom -> ConstructedAtom "SQLJust" (nullAtomType aType) [atom]++isNullOrType :: AtomType -> Atom -> Bool+isNullOrType aType atom = atomTypeForAtom atom == nullAtomType aType || atomTypeForAtom atom == aType++isNull :: Atom -> Bool+isNull (ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" _) []) = True+isNull (ConstructedAtom "SQLNullOfUnknownType" (ConstructedAtomType "SQLNullOfUnknownType" _) []) = True+isNull _ = False++isNullAtomType :: AtomType -> Bool+isNullAtomType = isJust . atomTypeFromSQLNull++atomTypeFromSQLNull :: AtomType -> Maybe AtomType+atomTypeFromSQLNull (ConstructedAtomType "SQLNullOfUnknownType" _) = Nothing+atomTypeFromSQLNull (ConstructedAtomType "SQLNullable" vars)+  | M.size vars == 1 =+    case M.elems vars of+      [] -> Nothing+      [t] -> Just t+      _ts -> Nothing+atomTypeFromSQLNull _ = Nothing++sqlIntegerBinaryFunction :: AtomType -> (Integer -> Integer -> Atom) -> [Atom] -> Either AtomFunctionError Atom+sqlIntegerBinaryFunction expectedAtomType op [a,b] +  | isNullOrType IntegerAtomType a && isNullOrType IntegerAtomType b = do+    let extractVal (ConstructedAtom "SQLJust" _ [IntegerAtom val]) = pure val+        extractVal (IntegerAtom val) = pure val+        extractVal (ConstructedAtom "SQLNull" _ []) = Nothing+        extractVal _ = Nothing+        mValA = extractVal a+        mValB = extractVal b+        inull = nullAtom expectedAtomType Nothing+    case (mValA, mValB) of+      (Nothing, Nothing) -> pure inull+      (Nothing, _) -> pure inull+      (_, Nothing) -> pure inull+      (Just valA, Just valB) -> pure (nullAtom expectedAtomType (Just (op valA valB)))+sqlIntegerBinaryFunction _ _ _ = Left AtomFunctionTypeMismatchError ++sqlIntegerUnaryFunction :: AtomType -> (Integer -> Atom) -> [Atom] -> Either AtomFunctionError Atom+sqlIntegerUnaryFunction expectedAtomType op [x]+  | isNullOrType IntegerAtomType x =+    case x of+      n@(ConstructedAtom "SQLNull" _ []) -> pure n+      ConstructedAtom "SQLJust" _ [IntegerAtom val] -> pure (nullAtom expectedAtomType (Just (op val)))+      IntegerAtom val -> pure (nullAtom expectedAtomType (Just (op val)))+      _other -> Left AtomFunctionTypeMismatchError+sqlIntegerUnaryFunction _ _ _ = Left AtomFunctionTypeMismatchError       ++sqlCount :: [Atom] -> Either AtomFunctionError Atom+sqlCount [RelationAtom relIn] =+  case cardinality relIn of+    Finite c -> pure $ IntegerAtom (toInteger c)+    Countable -> Left AtomFunctionTypeMismatchError+sqlCount _ = Left AtomFunctionTypeMismatchError++sqlAbs :: [Atom] -> Either AtomFunctionError Atom+sqlAbs [IntegerAtom val] = pure $ IntegerAtom (abs val)+sqlAbs [arg] | arg == nullAtom IntegerAtomType Nothing =+               pure $ nullAtom IntegerAtomType Nothing+sqlAbs [ConstructedAtom "SQLJust" aType [IntegerAtom val]]+  | aType == nullAtomType IntegerAtomType =+            pure $ nullAtom IntegerAtomType (Just (IntegerAtom (abs val)))+sqlAbs _other = Left AtomFunctionTypeMismatchError         ++sqlMax :: [Atom] -> Either AtomFunctionError Atom+sqlMax = sqlIntegerAgg max++sqlMin :: [Atom] -> Either AtomFunctionError Atom+sqlMin = sqlIntegerAgg min++sqlSum :: [Atom] -> Either AtomFunctionError Atom+sqlSum = sqlIntegerAgg (+)++sqlIntegerAgg :: (Integer -> Integer -> Integer) -> [Atom] -> Either AtomFunctionError Atom+sqlIntegerAgg op [RelationAtom relIn] =+  case oneTuple relIn of+    Nothing -> pure $ nullAtom IntegerAtomType Nothing -- SQL max/min of empty table is NULL+    Just oneTup ->+      if atomTypeForAtom (newVal oneTup) /= IntegerAtomType then+        Left AtomFunctionTypeMismatchError+        else+        pure $ relFold (\tupIn acc -> nullMax acc (newVal tupIn)) (newVal oneTup) relIn+ where+   newVal tupIn = tupleAtoms tupIn V.! 0+   nullMax acc nextVal =+     let mNextVal = sqlNullableIntegerToMaybe nextVal+         mOldVal = sqlNullableIntegerToMaybe acc+         mResult = op <$> mNextVal <*> mOldVal+         in+       nullAtom IntegerAtomType (case mResult of+                                    Nothing -> Nothing+                                    Just v -> Just (IntegerAtom v))+sqlIntegerAgg _ _ = Left AtomFunctionTypeMismatchError       +       ++sqlNullableIntegerToMaybe :: Atom -> Maybe Integer+sqlNullableIntegerToMaybe (IntegerAtom i) = Just i+sqlNullableIntegerToMaybe (ConstructedAtom "SQLJust" aType [IntegerAtom i]) | aType == nullAtomType IntegerAtomType = Just i+sqlNullableIntegerToMaybe (ConstructedAtom "SQLNull" aType []) | aType == nullAtomType IntegerAtomType = Nothing+sqlNullableIntegerToMaybe (ConstructedAtom "SQLNullOfUnknownType" aType []) | aType == nullAtomType IntegerAtomType = Nothing+sqlNullableIntegerToMaybe _ = Nothing+           +-- check that types check out- Int and SQLNullable Int are OK, Int and SQLNullable Text are not OK+sqlEqualsTypes :: Atom -> Atom -> Bool+sqlEqualsTypes a b = underlyingType a == underlyingType b+  where+    underlyingType (ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" typmap) []) | M.size typmap == 1 = snd (head (M.assocs typmap))+    underlyingType (ConstructedAtom "SQLJust" (ConstructedAtomType "SQLNullable" typmap) _args) | M.size typmap == 1 = snd (head (M.assocs typmap))+    underlyingType atom = atomTypeForAtom atom++sqlEquals :: AtomFunctionBodyType+sqlEquals [a,b] | sqlEqualsTypes a b =+  case (maybeNullAtom a, maybeNullAtom b) of+    (Nothing, _) -> pure $ nullAtom BoolAtomType Nothing+    (_, Nothing) -> pure $ nullAtom BoolAtomType Nothing+    (Just a', Just b') -> pure $ nullAtom BoolAtomType (Just (BoolAtom $ a' == b'))+  where+      maybeNullAtom (ConstructedAtom "SQLJust" (ConstructedAtomType "SQLNullable" _) [atom]) = Just atom+      maybeNullAtom (ConstructedAtom "SQLNull" _ []) = Nothing+      maybeNullAtom other = Just other+sqlEquals _other = Left AtomFunctionTypeMismatchError      ++sqlIsNull :: AtomFunctionBodyType+sqlIsNull [ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" _) []] = pure (BoolAtom True)+sqlIsNull [_arg] = pure (BoolAtom False)+sqlIsNull _other = Left AtomFunctionTypeMismatchError++isSQLNullableType :: AtomType -> Bool+isSQLNullableType (ConstructedAtomType "SQLNullable" _) = True+isSQLNullableType _ = False++isSQLNullableSpecificType :: AtomType -> AtomType -> Bool+isSQLNullableSpecificType (ConstructedAtomType "SQLNullable" vars) expectedType | M.elems vars == [expectedType] = True+isSQLNullableSpecificType _ _ = False++isSQLNullUnknownType :: AtomType -> Bool+isSQLNullUnknownType t = t == ConstructedAtomType "SQLNullOfUnknownType" mempty

@@ -43,3 +43,9 @@                                          registeredQueries = M.singleton "booleans" (Union (RelationVariable "true" ()) (RelationVariable "false" ()))                                          } +someDatabaseContextExprs :: [DatabaseContextExpr] -> DatabaseContextExpr+someDatabaseContextExprs [s] = s+someDatabaseContextExprs (s:ss) = MultipleExpr (s:ss)+someDatabaseContextExprs [] = NoOperation++

@@ -11,6 +11,7 @@ import qualified Data.Text as T import Data.Typeable import Control.Exception+import ProjectM36.SQL.Select  data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)                      | TupleAttributeCountMismatchError Int --attribute name@@ -19,6 +20,7 @@                      | TupleAttributeTypeMismatchError Attributes                      | AttributeCountMismatchError Int                      | AttributeNamesMismatchError (S.Set AttributeName)+                     | AttributeTypesMismatchError Attributes                      | AttributeNameInUseError AttributeName                      | AttributeIsNotRelationValuedError AttributeName                      | CouldNotInferAttributes@@ -59,6 +61,7 @@                      | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap                      | AtomFunctionTypeVariableResolutionError FunctionName TypeVarName                      | AtomFunctionTypeVariableMismatch TypeVarName AtomType AtomType+                     | IfThenExprExpectedBooleanError AtomType                      | AtomTypeNameInUseError AtomTypeName                      | IncompletelyDefinedAtomTypeWithConstructorError                      | AtomTypeNameNotInUseError AtomTypeName@@ -109,6 +112,8 @@                      | RegisteredQueryNameInUseError RegisteredQueryName                      | RegisteredQueryNameNotInUseError RegisteredQueryName +                     | SQLConversionError SQLError+                      | MultipleErrors [RelationalError]                        deriving (Show,Eq,Generic,Typeable, NFData)  @@ -131,7 +136,8 @@                   InvalidMergeStrategyError MergeStrategy | -- this is an internal coding error                   DisconnectedTransactionNotAMergeHeadError TransactionId |                   StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc.-                  StrategyViolatesRelationVariableMergeError |+                  StrategyViolatesRelationVariableMergeError RelationalError |+                  StrategyWithoutPreferredBranchResolutionMergeError |                   StrategyViolatesTypeConstructorMergeError |                   StrategyViolatesRegisteredQueryMergeError [RegisteredQueryName]                   deriving (Show, Eq, Generic, Typeable)@@ -159,3 +165,27 @@                   | ImportFileError T.Text                   | ImportDownloadError T.Text                   deriving (Show, Eq, Generic, Typeable, NFData)++data SQLError = NotSupportedError T.Text |+                TypeMismatchError AtomType AtomType |+                NoSuchSQLFunctionError FuncName |+                NoSuchSQLOperatorError OperatorName |+                DuplicateTableReferenceError TableAlias |+                MissingTableReferenceError TableAlias |+                TableAliasMismatchError TableAlias |+                UnexpectedTableNameError TableName |+                UnexpectedColumnNameError ColumnName |+                ColumnNamesMismatch (S.Set UnqualifiedColumnName) (S.Set UnqualifiedColumnName) | -- used for INSERT expressions+                ColumnResolutionError ColumnName |+                ColumnAliasResolutionError ColumnAlias |+                UnexpectedRelationalExprError RelationalExpr |+                UnexpectedAsteriskError ColumnProjectionName |+                UnexpectedColumnProjectionName ColumnProjectionName |+                AmbiguousColumnResolutionError ColumnName |+                DuplicateColumnAliasError ColumnAlias |+                AggregateGroupByMismatchError ProjectionScalarExpr |+                GroupByColumnNotReferencedInGroupByError [ProjectionScalarExpr] |+                UnsupportedGroupByProjectionError ProjectionScalarExpr |+                QueryOperatorTypeMismatchError QueryOperator Attributes Attributes |+                SQLRelationalError RelationalError +  deriving (Show, Eq, Generic, Typeable, NFData)

@@ -72,9 +72,10 @@ instance HashBytes a => HashBytes (RelationalExprBase a) where   hashBytes (MakeRelationFromExprs mAttrs tupleExprs) ctx =     hashBytesL ctx "MakeRelationFromExprs" [SHash mAttrs, SHash tupleExprs]-  hashBytes (MakeStaticRelation attrs tupSet) ctx = -- blowing up here!+  hashBytes (MakeStaticRelation attrs tupSet) ctx =      hashBytesL ctx "MakeStaticRelation" [SHash attrs, SHash tupSet]---  hashBytes _ ctx = ctx+  hashBytes (RelationValuedAttribute attrName) ctx =+    hashBytesL ctx "RelationValuedAttribute" [SHash attrName]   hashBytes (ExistingRelation (Relation attrs tupSet)) ctx =     hashBytesL ctx "ExistingRelation" [SHash tupSet, SHash attrs]   hashBytes (RelationVariable rvName marker) ctx =@@ -85,8 +86,8 @@     hashBytesL ctx "Union" [SHash exprA, SHash exprB]   hashBytes (Join exprA exprB) ctx =     hashBytesL ctx "Join" [SHash exprA, SHash exprB]-  hashBytes (Rename nameA nameB expr) ctx =-    hashBytesL ctx "Rename" [SHash nameA, SHash nameB, SHash expr]+  hashBytes (Rename attrs expr) ctx =+    hashBytesL ctx "Rename" [SHash attrs, SHash expr]   hashBytes (Difference exprA exprB) ctx =     hashBytesL ctx "Difference" [SHash exprA, SHash exprB]   hashBytes (Group names name expr) ctx =@@ -115,6 +116,10 @@   hashBytes (AttributeExtendTupleExpr name expr) ctx =     hashBytesL ctx "AttributeExtendTupleExpr" [SHash name, SHash expr] +instance HashBytes (S.Set (AttributeName, AttributeName)) where+  hashBytes attrs ctx =+    hashBytesL ctx "RenameAttrSet" (V.concatMap (\(a,b) -> V.fromList [SHash a, SHash b]) (V.fromList $ S.toList attrs))+ instance HashBytes a => HashBytes (WithNameExprBase a) where   hashBytes (WithNameExpr rv marker) ctx = hashBytesL ctx "WithNameExpr" [SHash rv, SHash marker]   @@ -137,6 +142,7 @@       (FunctionAtomExpr fname args marker) ->         hashBytesL ctx "FunctionAtomExpr" $ [SHash fname, SHash marker] <> map SHash args       (RelationAtomExpr r) -> hashBytesL ctx "RelationAtomExpr" [SHash r]+      (IfThenAtomExpr i t e) -> hashBytesL ctx "IfThenAtomExpr" [SHash i, SHash t, SHash e]       (ConstructedAtomExpr dConsName args marker) ->         hashBytesL ctx "ConstructedAtomExpr" ([SHash dConsName, SHash marker] <> map SHash args) 

@@ -16,4 +16,15 @@     incDepAsAtoms (name, InclusionDependency exprA exprB) = [TextAtom name,                                                              RelationalExprAtom exprA,                                                              RelationalExprAtom exprB]-  ++-- validate that the given AtomExpr is true for an relvar+inclusionDependencyForAtomExpr :: RelVarName -> AtomExpr -> InclusionDependency+inclusionDependencyForAtomExpr rvname atomExpr =+  InclusionDependency+  (NotEquals (ExistingRelation relationTrue)+    (Project (AttributeNames mempty) (Restrict check (RelationVariable rvname ())))+  )+  (ExistingRelation relationFalse)+  where+    check = AtomExprPredicate atomExpr+

@@ -163,7 +163,7 @@   exA <- func exprA   exB <- func exprB   func (Join exA exB)-relExprMogrify func (Rename n1 n2 expr) = func expr >>= \ex -> func (Rename n1 n2 ex)+relExprMogrify func (Rename attrs expr) = func expr >>= \ex -> func (Rename attrs ex) relExprMogrify func (Difference exprA exprB) = do   exA <- func exprA   exB <- func exprB

@@ -2,6 +2,7 @@ import ProjectM36.Base import ProjectM36.Relation import qualified Data.Set as S+import qualified Data.Text as T #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -37,7 +38,9 @@  -- | Create a 'DatabaseContextExpr' which can be used to add a uniqueness constraint to attributes on one relation variable. databaseContextExprForUniqueKey :: RelVarName -> [AttributeName] -> DatabaseContextExpr-databaseContextExprForUniqueKey rvName attrNames = AddInclusionDependency (rvName <> "_key") $ inclusionDependencyForKey (AttributeNames (S.fromList attrNames)) (RelationVariable rvName ())+databaseContextExprForUniqueKey rvName attrNames = AddInclusionDependency (rvName <> "_" <> cols <>  "_key") $ inclusionDependencyForKey (AttributeNames (S.fromList attrNames)) (RelationVariable rvName ())+  where+    cols = T.intercalate "_" attrNames  -- | Create a foreign key constraint from the first relation variable and attributes to the second. databaseContextExprForForeignKey :: IncDepName -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> DatabaseContextExpr@@ -56,7 +59,7 @@     folder (attrExpected, attrExisting) expr = if attrExpected == attrExisting then                                                    expr                                                  else-                                                   Rename attrExisting attrExpected expr+                                                   Rename (S.singleton (attrExisting, attrExpected)) expr  -- if the constraint is a foreign key constraint, then return the relations and attributes involved - this only detects foreign keys created with `databaseContextExprForForeignKey` isForeignKeyFor :: InclusionDependency -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> Bool

@@ -25,12 +25,13 @@ processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet) processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel) --requires current trans id and graph+processRelationalExpr (RelationValuedAttribute attrName) = pure (RelationValuedAttribute attrName) processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askMarker processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB-processRelationalExpr (Rename attrA attrB expr) =-  Rename attrA attrB <$> processRelationalExpr expr+processRelationalExpr (Rename attrs expr) =+  Rename attrs <$> processRelationalExpr expr processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr@@ -115,6 +116,8 @@ processAtomExpr (FunctionAtomExpr fName atomExprs ()) =   FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs  <*> askMarker processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr+processAtomExpr (IfThenAtomExpr ifE thenE elseE) =+  IfThenAtomExpr <$> processAtomExpr ifE <*> processAtomExpr thenE <*> processAtomExpr elseE processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askMarker  processTupleExprs :: TupleExprs -> ProcessExprM GraphRefTupleExprs

@@ -0,0 +1,144 @@+{-# LANGUAGE FlexibleInstances #-}+module ProjectM36.ReferencedTransactionIds where+import ProjectM36.Base+import ProjectM36.Error+import qualified ProjectM36.Transaction as T+import ProjectM36.RelationalExpression+import qualified Data.Map as M+import qualified Data.Set as S+import Control.Monad (foldM)++type TransactionIds = S.Set TransactionId++-- return all transactionIds referenced recursively- can be used to create subgraph of transaction dependencies+class ReferencedTransactionIds a where+  referencedTransactionIds :: a -> TransactionIds++instance ReferencedTransactionIds a => ReferencedTransactionIds (RelationalExprBase a) where+  referencedTransactionIds x = case x of+    MakeRelationFromExprs (Just attrExprs) tupleExprs ->+      S.unions (referencedTransactionIds tupleExprs : map referencedTransactionIds attrExprs)+    MakeRelationFromExprs Nothing tupleExprs ->+      referencedTransactionIds tupleExprs+    MakeStaticRelation{} -> S.empty+    ExistingRelation{} -> S.empty+    RelationVariable _ marker -> referencedTransactionIds marker+    RelationValuedAttribute _ -> S.empty+    Project attrNames expr -> S.union (referencedTransactionIds attrNames) (referencedTransactionIds expr)+    Union exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+    Join exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+    Rename _ expr -> referencedTransactionIds expr+    Difference exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+    Group attrNames _ expr -> S.union (referencedTransactionIds attrNames) (referencedTransactionIds expr)+    Ungroup _ expr -> referencedTransactionIds expr+    Restrict pred' expr -> S.union (referencedTransactionIds pred') (referencedTransactionIds expr)+    Equals exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+    NotEquals exprA exprB -> S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+    Extend extendTupleExpr expr -> S.union (referencedTransactionIds extendTupleExpr) (referencedTransactionIds expr)+    With assocs expr -> S.unions (referencedTransactionIds expr : map tAssocs assocs)+      where+        tAssocs (withNameExpr, rExpr) = S.union (referencedTransactionIds withNameExpr) (referencedTransactionIds rExpr)++instance ReferencedTransactionIds a => ReferencedTransactionIds (AttributeExprBase a) where+  referencedTransactionIds NakedAttributeExpr{} = S.empty+  referencedTransactionIds (AttributeAndTypeNameExpr _ _ marker) = referencedTransactionIds marker++instance ReferencedTransactionIds a => ReferencedTransactionIds (TupleExprBase a) where+  referencedTransactionIds (TupleExpr tMap) =+    S.unions (referencedTransactionIds <$> M.elems tMap)++instance ReferencedTransactionIds a => ReferencedTransactionIds (TupleExprsBase a) where+  referencedTransactionIds (TupleExprs marker tupleExprs) =+    S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> tupleExprs))++instance ReferencedTransactionIds GraphRefTransactionMarker where+  referencedTransactionIds (TransactionMarker tid) = S.singleton tid+  referencedTransactionIds UncommittedContextMarker = S.empty -- we have other methods to determine if there is an uncommitted transaction marker in the expr++instance ReferencedTransactionIds a => ReferencedTransactionIds (AttributeNamesBase a) where+  referencedTransactionIds names =+    case names of+      AttributeNames{} -> S.empty+      InvertedAttributeNames{} -> S.empty+      UnionAttributeNames exprA exprB ->+        S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+      IntersectAttributeNames exprA exprB ->+        S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+      RelationalExprAttributeNames rExpr ->+        referencedTransactionIds rExpr++instance ReferencedTransactionIds a => ReferencedTransactionIds (RestrictionPredicateExprBase a) where+  referencedTransactionIds expr =+    case expr of+      TruePredicate -> mempty+      AndPredicate exprA exprB ->+        S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+      OrPredicate exprA exprB ->+        S.union (referencedTransactionIds exprA) (referencedTransactionIds exprB)+      NotPredicate exprA ->+        referencedTransactionIds exprA+      RelationalExprPredicate rExpr ->+        referencedTransactionIds rExpr+      AtomExprPredicate aExpr ->+        referencedTransactionIds aExpr+      AttributeEqualityPredicate _ aExpr ->+        referencedTransactionIds aExpr++instance ReferencedTransactionIds a => ReferencedTransactionIds (ExtendTupleExprBase a) where+  referencedTransactionIds (AttributeExtendTupleExpr _ aExpr) =+    referencedTransactionIds aExpr++instance ReferencedTransactionIds a => ReferencedTransactionIds (WithNameExprBase a) where+  referencedTransactionIds (WithNameExpr _ marker) = referencedTransactionIds marker++instance ReferencedTransactionIds a => ReferencedTransactionIds (AtomExprBase a) where+  referencedTransactionIds expr =+    case expr of+      AttributeAtomExpr{} -> mempty+      NakedAtomExpr{} -> mempty+      FunctionAtomExpr _ args marker ->+        S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args))+      RelationAtomExpr rExpr ->+        referencedTransactionIds rExpr+      ConstructedAtomExpr _ args marker ->+        S.unions (referencedTransactionIds marker : (referencedTransactionIds <$> args))+      IfThenAtomExpr ifE thenE elseE ->+        S.unions [referencedTransactionIds ifE,+                  referencedTransactionIds thenE,+                  referencedTransactionIds elseE]++-- only the relvars can reference other transactions+instance ReferencedTransactionIds DatabaseContext where+  referencedTransactionIds dbc =+    S.unions [+    --referencedTransactionIds (inclusionDependencies dbc),+    referencedTransactionIds (relationVariables dbc)+    --referencedTransactionIds (atomFunctions dbc),+    --referencedTransactionIds (dbcFunctions dbc),+    --referencedTransactionIds (notifications dbc),+    --referencedTransactionIds (typeConstructorMapping dbc),+    --referencedTransactionIds (registeredQueries dbc)+    ]++instance ReferencedTransactionIds RelationVariables where+  referencedTransactionIds relVars =+    S.unions (referencedTransactionIds <$> M.elems relVars)++-- | Recurse relvars references and transaction parents to extract a subset of relevant transactions.+-- probably could do some trimming of transactions that are not referenced by relvars, but that is rare, so probably of not much benefit+-- should be trim merge parents that don't contribute to the relvars? maybe+referencedTransactionIdsForTransaction :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)+referencedTransactionIdsForTransaction trans graph+  | parentIds == T.rootParent = pure (S.singleton trans)+  | otherwise = +    foldM folder (S.singleton trans) parentIds+  where+    parentIds = parents (transactionInfo trans)+    folder acc transId' = do+      trans' <- transactionForId transId' graph+      transSet <- referencedTransactionIdsForTransaction trans' graph+      pure (S.union acc transSet)++++

@@ -80,10 +80,12 @@  -- this is still unncessarily expensive for (bigx union bigx) because each tuple is hashed and compared for equality (when the hashes match), but the major expense is attributesEqual, but we already know that all tuple attributes are equal (it's a precondition) union :: Relation -> Relation -> Either RelationalError Relation-union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =-  if not (A.attributesEqual attrs1 attrs2)-     then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))-  else+union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) +  | A.attributeNameSet attrs1 /= A.attributeNameSet attrs2 =+    Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))+  | not (A.attributesEqual attrs1 attrs2) =+    Left $ AttributeTypesMismatchError $ A.attributesDifference attrs1 attrs2+  | otherwise =     Right $ Relation attrs1 newtuples   where     newtuples = tupleSetUnion attrs1 tupSet1 tupSet2@@ -94,6 +96,11 @@   newTupleList <- mapM (tupleProject newAttrs) (asList tupSet)   pure (Relation newAttrs (RelationTupleSet (HS.toList (HS.fromList newTupleList)))) +renameMany :: S.Set (AttributeName, AttributeName) -> Relation -> Either RelationalError Relation+renameMany renames rel = foldM folder rel (S.toList renames)+  where+    folder r (oldName, newName) = rename oldName newName r+   rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet)    | not attributeValid = Left $ AttributeNamesMismatchError (S.singleton oldAttrName)

@@ -25,6 +25,7 @@ import Control.Monad.State hiding (join) import Data.Bifunctor (second) import Data.Maybe+import Data.Tuple (swap) import Data.Either import Data.Char (isUpper) import Data.Time@@ -50,6 +51,8 @@ import GHC.Paths #endif +--import Debug.Trace+ data DatabaseContextExprDetails = CountUpdatedTuples  databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc@@ -280,7 +283,7 @@   context <- getStateContext   let existingRelVar = M.lookup relVarName (relationVariables context)       reEnv = freshGraphRefRelationalExprEnv (Just context) graph-      eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)      +   case existingRelVar of     Nothing -> do       case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of@@ -292,13 +295,16 @@       let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)       case eExpectedType of         Left err -> dbErr err-        Right expectedType ->+        Right expectedType -> do+      -- if we are targeting an existing rv, we can morph a MakeRelationFromExprs datum to fill in missing type variables'+          let hintedExpr = addTargetTypeHints (attributes expectedType) expr+              eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr hintedExpr)           case eNewExprType of             Left err -> dbErr err             Right newExprType -> do               if newExprType == expectedType then do                 lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType)-                setRelVar relVarName expr +                setRelVar relVarName hintedExpr                else                 dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)) @@ -335,7 +341,7 @@           else              tmpAttrName       updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)-      projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)+      projectAndRename attr expr = Rename (S.singleton (tmpAttr attr, attr)) (Project (InvertedAttributeNames (S.singleton attr)) expr)       restrictedPortion = Restrict pred' rvExpr       updated = foldr (\(oldname, atomExpr) accum ->                                  let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in@@ -798,7 +804,7 @@                                               Left err2@(NoSuchAttributeNamesError _) -> Left err2                                               Left err -> Left err       Left err -> Left err-  if atomExprType /= A.atomType attr then+  if atomExprType /= A.atomType attr then do       throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))     else       pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of@@ -889,6 +895,12 @@   let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env   relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)   pure (RelationAtom relAtom)+evalGraphRefAtomExpr tupIn (IfThenAtomExpr ifExpr thenExpr elseExpr) = do+  conditional <- evalGraphRefAtomExpr tupIn ifExpr+  case conditional of+    BoolAtom True -> evalGraphRefAtomExpr tupIn thenExpr+    BoolAtom False -> evalGraphRefAtomExpr tupIn elseExpr+    otherAtom -> throwError (IfThenExprExpectedBooleanError (atomTypeForAtom otherAtom)) evalGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _)   | tOrF == "True" = pure (BoolAtom True)   | tOrF == "False" = pure (BoolAtom False)@@ -941,6 +953,15 @@ typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do   relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)     pure (RelationAtomType (attributes relType))+typeForGraphRefAtomExpr attrs (IfThenAtomExpr ifExpr thenExpr elseExpr) = do+  -- ifExpr must be BoolAtomType+  ifType <- typeForGraphRefAtomExpr attrs ifExpr+  when (ifType /= BoolAtomType) $ throwError (IfThenExprExpectedBooleanError ifType)+  -- thenExpr and elseExpr must return the same type+  thenType <- typeForGraphRefAtomExpr attrs thenExpr+  elseType <- typeForGraphRefAtomExpr attrs elseExpr+  when (thenType /= elseType) $ throwError (AtomTypeMismatchError thenType elseType)+  pure thenType -- grab the type of the data constructor, then validate that the args match the expected types typeForGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _) | tOrF `elem` ["True", "False"] =                                                             pure BoolAtomType@@ -988,6 +1009,11 @@     let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn)     relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)     lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))+verifyGraphRefAtomExprTypes relIn (IfThenAtomExpr _ifExpr thenExpr elseExpr) expectedType = do+  thenType <- typeForGraphRefAtomExpr (attributes relIn) thenExpr+  elseType <- typeForGraphRefAtomExpr (attributes relIn) elseExpr+  when (thenType /= elseType) $ throwError (AtomTypeMismatchError thenType elseType)  +  lift $ except $ atomTypeVerify expectedType thenType verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do   cType <- typeForGraphRefAtomExpr (attributes rel) cons   lift $ except $ atomTypeVerify expectedType cType@@ -1072,7 +1098,8 @@       tup = mkRelationTuple tupAttrs atoms       finalAttrs = fromMaybe tupAttrs mAttrs     --verify that the attributes match-  when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)+  when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ do+    throwError (TupleAttributeTypeMismatchError tupAttrs)   --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held   --tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))   let tup' = reorderTuple finalAttrs tup@@ -1099,6 +1126,16 @@   case M.lookup name (relationVariables ctx) of     Nothing -> throwError (RelVarNotDefinedError name)     Just rv -> evalGraphRefRelationalExpr rv+evalGraphRefRelationalExpr (RelationValuedAttribute attrName) = do+  env <- askEnv+  case gre_extra env of+    Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName))+    Just (Left ctxtup) -> do+      atom <- lift $ except $ atomForAttributeName attrName ctxtup+      case atom of+        RelationAtom rel -> pure rel+        other -> throwError (AtomTypeMismatchError (RelationAtomType mempty) (atomTypeForAtom other))+    Just (Right _) -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) evalGraphRefRelationalExpr (Project attrNames expr) = do   attrNameSet <- evalGraphRefAttributeNames attrNames expr   rel <- evalGraphRefRelationalExpr expr@@ -1111,9 +1148,9 @@   relA <- evalGraphRefRelationalExpr exprA   relB <- evalGraphRefRelationalExpr exprB   lift $ except $ join relA relB-evalGraphRefRelationalExpr (Rename oldName newName expr) = do+evalGraphRefRelationalExpr (Rename attrsSet expr) = do   rel <- evalGraphRefRelationalExpr expr-  lift $ except $ rename oldName newName rel+  lift $ except $ renameMany attrsSet rel evalGraphRefRelationalExpr (Difference exprA exprB) = do   relA <- evalGraphRefRelationalExpr exprA   relB <- evalGraphRefRelationalExpr exprB@@ -1184,6 +1221,23 @@     Nothing -> throwError (RelVarNotDefinedError rvName)     Just rvExpr ->        typeForGraphRefRelationalExpr rvExpr+typeForGraphRefRelationalExpr (RelationValuedAttribute attrName) = do+  env <- askEnv+  case gre_extra env of+    Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) -- or can this be an attribute at the top-level?+    Just (Left ctxtup) -> do+      atom <- lift $ except $ atomForAttributeName attrName ctxtup+      case atom of+        RelationAtom rel -> pure (emptyRelationWithAttrs (attributes rel))+        other -> throwError (AtomTypeMismatchError (RelationAtomType mempty) (atomTypeForAtom other))+    Just (Right attrs) -> do+      case A.atomTypeForAttributeName attrName attrs of+        Left{} -> throwError (NoSuchAttributeNamesError (S.singleton attrName))+        Right typ -> do+          case typ of+            RelationAtomType relAttrs -> pure $ emptyRelationWithAttrs relAttrs+            other -> throwError (AtomTypeMismatchError (RelationAtomType A.emptyAttributes) other)+         typeForGraphRefRelationalExpr (Project attrNames expr) = do   exprType' <- typeForGraphRefRelationalExpr expr   projectionAttrs <- evalGraphRefAttributeNames attrNames expr@@ -1196,9 +1250,9 @@   exprA' <- typeForGraphRefRelationalExpr exprA   exprB' <- typeForGraphRefRelationalExpr exprB   lift $ except $ join exprA' exprB'-typeForGraphRefRelationalExpr (Rename oldAttr newAttr expr) = do+typeForGraphRefRelationalExpr (Rename attrs expr) = do   expr' <- typeForGraphRefRelationalExpr expr-  lift $ except $ rename oldAttr newAttr expr'+  lift $ except $ renameMany attrs expr' typeForGraphRefRelationalExpr (Difference exprA exprB) = do     exprA' <- typeForGraphRefRelationalExpr exprA   exprB' <- typeForGraphRefRelationalExpr exprB@@ -1279,11 +1333,12 @@     mkEmptyRelVar expr@MakeRelationFromExprs{} = expr --do not truncate here because we might lose essential type information in emptying the tuples     mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet     mkEmptyRelVar (ExistingRelation rel) = ExistingRelation (emptyRelationWithAttrs (attributes rel))+    mkEmptyRelVar x@RelationValuedAttribute{} = x     mkEmptyRelVar rv@RelationVariable{} = Restrict (NotPredicate TruePredicate) rv     mkEmptyRelVar (Project attrNames expr) = Project attrNames (mkEmptyRelVar expr)     mkEmptyRelVar (Union exprA exprB) = Union (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)     mkEmptyRelVar (Join exprA exprB) = Join (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)-    mkEmptyRelVar (Rename nameA nameB expr) = Rename nameA nameB (mkEmptyRelVar expr)+    mkEmptyRelVar (Rename attrs expr) = Rename attrs (mkEmptyRelVar expr)     mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)     mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr)     mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr)@@ -1354,6 +1409,7 @@     MakeRelationFromExprs mAttrs <$> resolve tupleExprs   resolve orig@MakeStaticRelation{} = pure orig   resolve orig@ExistingRelation{} = pure orig+  resolve orig@RelationValuedAttribute{} = pure orig   resolve orig@(RelationVariable rvName UncommittedContextMarker) = do     rvMap <- relationVariables <$> getStateContext     case M.lookup rvName rvMap of@@ -1363,7 +1419,7 @@   resolve (Project attrNames relExpr) = Project <$> resolve attrNames <*> resolve relExpr   resolve (Union exprA exprB) = Union <$> resolve exprA <*> resolve exprB   resolve (Join exprA exprB) = Join <$> resolve exprA <*> resolve exprB-  resolve (Rename attrA attrB expr) = Rename attrA attrB <$> resolve expr+  resolve (Rename attrs expr) = Rename attrs <$> resolve expr   resolve (Difference exprA exprB) = Difference <$> resolve exprA <*> resolve exprB   resolve (Group namesA nameB expr) = Group <$> resolve namesA <*> pure nameB <*> resolve expr   resolve (Ungroup nameA expr) = Ungroup nameA <$> resolve expr@@ -1410,6 +1466,7 @@   resolve (FunctionAtomExpr nam atomExprs marker) =     FunctionAtomExpr nam <$> mapM resolve atomExprs <*> pure marker   resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr+  resolve (IfThenAtomExpr ifExpr thenExpr elseExpr) = IfThenAtomExpr <$> resolve ifExpr <*> resolve thenExpr <*> resolve elseExpr   resolve (ConstructedAtomExpr dConsName atomExprs marker) =     ConstructedAtomExpr dConsName <$> mapM resolve atomExprs <*> pure marker @@ -1452,4 +1509,48 @@     _ -> orig applyRestrictionCollapse expr = expr +firstAtomForAttributeName :: AttributeName -> [RelationTuple] -> GraphRefRelationalExprM Atom+firstAtomForAttributeName attrName tuples = do+  let folder tup acc =+        case atomForAttributeName attrName tup of+          Left{} -> acc+          Right atom -> Just atom+  case foldr folder Nothing tuples of+    Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName))+    Just match -> pure match +-- | Optionally add type hints to resolve type variables. For example, if we are inserting into a known relvar, then we have its concrete type.    +addTargetTypeHints :: Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExpr+addTargetTypeHints targetAttrs expr =+  case expr of+    MakeRelationFromExprs Nothing tupExprs ->+      MakeRelationFromExprs (Just targetAttrExprs) tupExprs+    Project attrs e ->+      Project attrs (hint e)+    Union a b ->+      Union (hint a) (hint b)+    Join a b ->+      Join (hint a) (hint b)+    Rename rens e ->+      let renamedAttrs = A.renameAttributes' (S.map swap rens) targetAttrs in+      Rename rens (addTargetTypeHints renamedAttrs e)+    Difference a b ->+      Difference (hint a) (hint b)+    Group attrs gname e ->+      Group attrs gname (hint e)+    Ungroup gname e ->+      Ungroup gname (hint e)+    Restrict restriction e ->+      Restrict restriction (hint e)+    Equals a b ->+      Equals (hint a) (hint b)+    NotEquals a b ->+      NotEquals (hint a) (hint b)+    Extend tupExprs e ->+      Extend tupExprs (hint e)+    With withs e ->+      With withs (hint e)+    _ -> expr+  where+    targetAttrExprs = map NakedAttributeExpr (A.toList targetAttrs)+    hint = addTargetTypeHints targetAttrs

@@ -0,0 +1,1499 @@+--convert SQL into relational or database context expressions+{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-}+module ProjectM36.SQL.Convert where+import ProjectM36.Base as B+import ProjectM36.Error+import ProjectM36.DataTypes.SQL.Null+import ProjectM36.SQL.Select+import ProjectM36.DatabaseContext (someDatabaseContextExprs)+import ProjectM36.SQL.Insert as Insert+import ProjectM36.Key (databaseContextExprForUniqueKey, inclusionDependencyForKey)+import ProjectM36.SQL.DBUpdate+import ProjectM36.SQL.Update as Update+import ProjectM36.SQL.Delete as Delete+import ProjectM36.SQL.CreateTable as CreateTable+import ProjectM36.SQL.DropTable as DropTable+import ProjectM36.RelationalExpression+import ProjectM36.DataFrame (DataFrameExpr(..), AttributeOrderExpr(..), Order(..), usesDataFrameFeatures)+import ProjectM36.AttributeNames as A+import ProjectM36.Relation (attributes, atomTypeForName)+import qualified ProjectM36.Attribute as A+import qualified Data.Text as T+import qualified ProjectM36.WithNameExpr as With+import Control.Monad (foldM, when)+import qualified Data.Set as S+import qualified Data.Map as M+import Data.List (intercalate, find)+import qualified Data.Functor.Foldable as Fold+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isJust)+--import Control.Monad (void)+import Control.Monad.Trans.State (StateT, get, put, runStateT, evalStateT)+import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)+import Control.Monad.Identity (Identity, runIdentity)+import Control.Monad.Trans.Class (lift)+import Data.Foldable (foldl')+import Data.Bifunctor (bimap)+--import qualified Data.HashSet as HS++--import Debug.Trace++{-+TODO+* enable duplicate rows by adding uuid column+-}++--over the course of conversion of a table expression, we collect all the table aliases we encounter, including non-aliased table references, including the type of the table, projections have their own name resolution system+newtype TableContext = TableContext (M.Map TableAlias (RelationalExpr, Attributes, ColumnAliasRemapper))+  deriving (Semigroup, Monoid, Show, Eq)++type TypeForRelExprF = RelationalExpr -> Either RelationalError Relation++type ConvertM = StateT TableContext (ExceptT SQLError Identity)++runConvertM :: TableContext -> ConvertM a -> Either SQLError (a, TableContext)+runConvertM tcontext m = runIdentity (runExceptT (runStateT m tcontext))++runLocalConvertM :: ConvertM a -> ConvertM a+runLocalConvertM m = do+  saveState <- get+  ret <- m+  put saveState+  pure ret++evalConvertM :: TableContext -> ConvertM a -> Either SQLError a+evalConvertM tcontext m = runIdentity (runExceptT (evalStateT m tcontext))++data SelectItemsConvertTask = SelectItemsConvertTask { taskProjections :: S.Set ColumnProjectionName,+                                                       taskRenames :: [(ColumnProjectionName, ColumnAlias)],+                                                       taskExtenders :: [ExtendTupleExpr],+                                                       taskGroups :: [S.Set ColumnProjectionName]+                                                     } deriving (Show, Eq)++emptyTask :: SelectItemsConvertTask+emptyTask = SelectItemsConvertTask { taskProjections = S.empty,+                                     taskRenames = mempty,+                                     taskGroups = mempty,+                                     taskExtenders = mempty }++                                          +-- (real attribute name in table- immutable, (renamed "preferred" attribute name needed to disambiguate names on conflict, set of names which are used to reference the "preferred" name)+type AttributeAlias = AttributeName+-- the AttributeAlias is necessary when then is otherwise a naming conflict such as with join conditions which would otherwise cause duplicate column names which SQL supports but the relational algebra does not+type ColumnAliasRemapper = M.Map AttributeName (AttributeAlias, S.Set ColumnName)++insertIntoColumnAliasRemap' :: AttributeName -> AttributeAlias -> ColumnName -> ColumnAliasRemapper -> Either SQLError ColumnAliasRemapper+insertIntoColumnAliasRemap' attrName attrAlias colName remap =+  case attrName `M.lookup` remap of+    Nothing -> pure $ M.insert attrName (attrAlias, S.singleton colName) remap+    Just (attrAlias', colNames) | attrAlias' == attrAlias ->+                                  pure $ M.insert attrName (attrAlias, S.insert colName colNames) remap+                                  | otherwise ->+                                    Left (ColumnAliasResolutionError (ColumnAlias attrName))++-- | Used to note if columns are remapped to different attributes in order to mitigate attribute naming conflicts.+insertColumnAlias ::+  TableAlias -> -- table reference+  AttributeName -> -- real attribute name+  ColumnAlias -> -- column alias+  ColumnName -> -- original reference name+  ConvertM ()+insertColumnAlias tAlias attrName (ColumnAlias colAlias) colName = do+  TableContext tmap <- get+  case tAlias `M.lookup` tmap of+    Nothing -> throwSQLE (MissingTableReferenceError tAlias)+    Just (rve,attrs,remap) -> do+      case insertIntoColumnAliasRemap' attrName colAlias colName remap of+        Left err -> throwSQLE err+        Right remap' -> do+          let tmap' = M.insert tAlias (rve, attrs, remap') tmap+          put (TableContext tmap')++-- debugging utility function+prettyTableContext :: TableContext -> String+prettyTableContext (TableContext tMap) = "TableContext {\n" <> concatMap prettyKV (M.toList tMap) <> "}"+  where+    prettyKV (TableAlias k, (_rvexpr, _attrs, aliasMap)) =+      " " <> T.unpack k <> "::  " <> +      prettyColumnAliasRemapper aliasMap <> "\n"++prettyColumnAliasRemapper :: ColumnAliasRemapper -> String+prettyColumnAliasRemapper cAMap = intercalate ", " $ map (\(realAttr, (attrAlias, colNameSet)) -> "real->" <> T.unpack realAttr <> ":alias->" <> T.unpack attrAlias <> ":alts->{" <> show colNameSet <> "}") (M.toList cAMap)+++{-  +traceStateM :: ConvertM ()+traceStateM = do+  s <- get+  traceM (prettyTableContext s)+-}++-- key: alias value: real column attribute name+type ColumnAliasMap = M.Map ColumnAlias AttributeName++tableAliasesAsWithNameAssocs :: ConvertM WithNamesAssocs+tableAliasesAsWithNameAssocs = do+  (TableContext tmap) <- get+  filter notSelfRef <$> mapM mapper (M.toList tmap)+  where+    notSelfRef (WithNameExpr nam (), RelationVariable nam' ()) | nam == nam' = False+                                                            | otherwise = True+    notSelfRef _ = True+--    mapper :: (TableAlias, (RelationalExpr, Attributes)) -> ConvertM (WithNameExpr, RelationalExpr)+    mapper (TableAlias nam, (rvExpr, _, _)) = pure (WithNameExpr nam (), rvExpr)++throwSQLE :: SQLError -> ConvertM a+throwSQLE = lift . throwE++type ColumnAliasRenameMap = M.Map (TableAlias, AttributeName) ColumnAlias++-- | Pass state down to subselect, but discard any state changes from the subselect processing.+withSubSelect :: ConvertM a -> ConvertM (a, ColumnAliasRenameMap)+withSubSelect m = do+  state@(TableContext orig) <- get+  ret <- m+  (TableContext postSub) <- get+  put state+  -- diff the state to get just the items that were added+  let tableDiffFolder acc (tAlias, (RelationVariable _rv (), _ , colAliasRemapper)) = do+        let convertColAliases :: ColumnAliasRemapper -> (AttributeName, (AttributeName, S.Set ColumnName)) -> ColumnAliasRenameMap -> ColumnAliasRenameMap+            convertColAliases origColAlRemapper (attrName, (attrAlias,_)) acc' =+              if M.member attrName origColAlRemapper then+                acc'+                else+                M.insert (tAlias, attrName) (ColumnAlias attrAlias) acc'+        case M.lookup tAlias orig of+          -- new table has been added to column alias map, add all columns aliased+          Nothing -> do+            pure (acc <> foldr (convertColAliases mempty) mempty (M.toList colAliasRemapper))+          -- we are aware of the table, but there may have been some new columns added+          Just (_,_,colAliasRemapper') ->+            pure (acc <> foldr (convertColAliases colAliasRemapper') mempty (M.toList colAliasRemapper'))+      tableDiffFolder _ (_, (rvexpr, _, _)) = throwSQLE (UnexpectedRelationalExprError rvexpr)+            +  diff <- foldM tableDiffFolder mempty (M.toList postSub)++  pure (ret, diff)++-- if we find a column naming conflict, generate a non-conflicting name for insertion into the column alias map+generateColumnAlias :: TableAlias -> AttributeName -> ConvertM ColumnAlias+generateColumnAlias (TableAlias tAlias) attrName = do+  tctx <- get+  let potentialNames = map ColumnName ([[attrName],+                                        [tAlias <> "." <> attrName]] <>+                                        map (\x -> [tAlias <> "." <> attrName <> T.pack (show x)]) [1::Int ..])+      nameIsAvailable nam = +        case findOneColumn' nam tctx of+          Left ColumnResolutionError{} -> --no match, so we can use this name+            True+          _ -> False --some conflict, so loop+      firstAvailableName = find nameIsAvailable potentialNames+--  traceShowM ("generateColumnAlias scan"::String, tAlias, attrName, firstAvailableName)     +  case firstAvailableName of+    Just (ColumnName [nam]) -> pure (ColumnAlias nam)+    _ -> throwSQLE $ ColumnResolutionError (ColumnName [attrName])++-- | Insert another table into the TableContext. Returns an alias map of any columns which could conflict with column names already present in the TableContext so that they can be optionally renamed.+insertTable :: TableAlias -> RelationalExpr -> Attributes -> ConvertM ColumnAliasMap+insertTable tAlias expr rtype = do+  (TableContext map') <- get+  case M.lookup tAlias map' of+    Nothing -> do+      put $ TableContext $ M.insert tAlias (expr, rtype, mempty) map'+--      traceShowM ("insertTable"::String, tAlias)+      pure mempty+    Just _ -> throwSQLE (DuplicateTableReferenceError tAlias)++-- | When a column is mentioned, it may need to be aliased. The table name must already be in the table context so that we can identify that the attribute exists. Without a table name, we must look for a uniquely named column amongst all tables. Thus, we pre-emptively eliminate duplicate column names.+noteColumnMention :: Maybe TableAlias -> ColumnName -> Maybe ColumnAlias -> ConvertM ColumnAlias+noteColumnMention mTblAlias colName mColAlias = do+  -- find the relevant table for the key to the right table+  tc@(TableContext tcontext) <- get+  -- check if we already have a mention mapping+  let lookupWithTableAlias (TableAlias tAlias) colAttr = do+        when (isJust mTblAlias && Just (TableAlias tAlias) /= mTblAlias) (throwSQLE (TableAliasMismatchError (TableAlias tAlias)))+      -- we have a specific table alias, so ensure it's valid+        let tPrefixColAttr = tAlias <> "." <> colAttr+            insertColAlias newAlias = do+              insertColumnAlias (TableAlias tAlias) colAttr (ColumnAlias newAlias) colName+              pure (ColumnAlias newAlias)+        case M.lookup (TableAlias tAlias) tcontext of+          Nothing -> do -- add a new colaliasremapper+            insertColAlias (maybe tPrefixColAttr unColumnAlias mColAlias)+          Just (_, _, colAlRemapper) -> do+            -- table alias already known, check for column alias+            case attributeNameForAttributeAlias colAttr colAlRemapper of+              Left _ -> do+                -- col alias missing, so add it- figure out if it needs a table prefix+                let sqlColAlias = maybe colAttr unColumnAlias mColAlias+                case findNotedColumn' (ColumnName [colAttr]) tc of+                               Left _ -> -- no match, so table prefix not required+                                 insertColAlias sqlColAlias+                               Right [] -> -- no match, so table prefix not required+                                 insertColAlias sqlColAlias+                               Right [_] -> -- we have a match, so we need the table prefix+                                 insertColAlias (maybe tPrefixColAttr unColumnAlias mColAlias)+                               Right (_:_) -> throwSQLE (AmbiguousColumnResolutionError colName)+              Right attrName ->+                -- we know the alias already, so return it+                pure (ColumnAlias attrName)++  case colName of+    ColumnName [tAlias,colAlias] -> lookupWithTableAlias (TableAlias tAlias) colAlias+    ColumnName [colAlias] ->+      case mTblAlias of+        Just tAlias -> lookupWithTableAlias tAlias colAlias+        Nothing -> do+          -- lookup without table alias+          -- unqualified column alias- search for unambiguous table reference+          let folder (ta, (_, _, colAliasRemapper)) acc =+                case attributeNameForAttributeAlias colAlias colAliasRemapper of+                  Left _ -> acc+                  Right attrName -> (ta,attrName) : acc+              sqlColAlias = maybe colAlias unColumnAlias mColAlias+      +          case foldr folder mempty (M.toList tcontext) of+            [] -> do -- no matches, search raw attributes+              case findColumn' colName tc of+                [] -> -- no match in attributes, either, error+                  throwSQLE (UnexpectedColumnNameError colName)+                [tAlias] -> do -- one match, insert it+                  insertColumnAlias tAlias sqlColAlias (ColumnAlias colAlias) colName+                  pure (ColumnAlias colAlias)+                (_:_) -> -- too many matches, error+                  throwSQLE (AmbiguousColumnResolutionError colName)+            [(tAlias, attrName)] -> do -- valid attribute match, so add colaliasremapper+              insertColumnAlias tAlias attrName (ColumnAlias colAlias) colName+              pure (ColumnAlias colAlias)+            (_:_) -> -- two many matches, error+              throwSQLE (AmbiguousColumnResolutionError colName)+    other@ColumnName{} -> throwSQLE (UnexpectedColumnNameError other)   ++lookupTable :: TableAlias -> ConvertM (RelationalExpr, Attributes, ColumnAliasRemapper)+lookupTable ta = do+  (TableContext map') <- get+  case M.lookup ta map' of+    Nothing -> throwSQLE (MissingTableReferenceError ta)+    Just res -> pure res++-- | Find a column name or column alias in the underlying table context. Returns key into table context.+findColumn :: ColumnName -> ConvertM [TableAlias]+findColumn targetCol = +  findColumn' targetCol <$> get+  +-- | non ConvertM version of findColumn+findColumn' :: ColumnName -> TableContext -> [TableAlias]+findColumn' targetCol (TableContext tMap) = do+  M.foldrWithKey folder [] tMap+   where+    folder tAlias@(TableAlias tat) (_rvExpr, rtype, _) acc =+      case targetCol of+        ColumnName [colName'] ->+          if S.member colName' (A.attributeNameSet rtype) then+            tAlias : acc+            else+            acc+        ColumnName [tPrefix, colName'] ->+          if tat == tPrefix && S.member colName' (A.attributeNameSet rtype) then+            tAlias : acc+            else+            acc+        _ -> acc++-- search ColumnAliasRemapper for columns which have already been noted- can be used for probing for new aliases+findNotedColumn' :: ColumnName -> TableContext -> Either SQLError [(TableAlias, AttributeName)]+findNotedColumn' (ColumnName [attr]) (TableContext tcontext) =+  -- search all column alias remappers for attribute- if there is a conflict because the alias is ambiguous, error out+  pure $ foldr folder mempty (M.toList tcontext)+  where+    folder (ta, (_, _, colAliasRemapper)) acc =+      case attributeNameForAttributeAlias attr colAliasRemapper of+        Left _ -> acc+        Right attrName -> (ta,attrName) : acc++findNotedColumn' (ColumnName [tPrefix, attr]) (TableContext tcontext) =+  --find referenced table alias+  --search for noted column in column alias remapper+  case M.lookup (TableAlias tPrefix) tcontext of+    Nothing -> Left (MissingTableReferenceError (TableAlias tPrefix))+    Just (_, _, colAlRemapper) -> do+      attrName <- attributeNameForAttributeAlias attr colAlRemapper+      pure [(TableAlias tPrefix, attrName)]+findNotedColumn' colName _ = Left $ UnexpectedColumnNameError colName      +++attributeNameForAttributeAlias :: AttributeAlias -> ColumnAliasRemapper -> Either SQLError AttributeName+attributeNameForAttributeAlias al remapper = do+  foldr folder (Left (ColumnAliasResolutionError (ColumnAlias al))) (M.toList remapper)+  where+    folder (_attrName, (attrAlias, _)) acc =+               if attrAlias == al then+                 pure attrAlias+               else+                 acc+  ++findOneColumn :: ColumnName -> ConvertM TableAlias+findOneColumn targetCol = do+  tcontext <- get+  case findOneColumn' targetCol tcontext of+    Left err -> throwSQLE err+    Right match -> pure match++findOneColumn' :: ColumnName -> TableContext -> Either SQLError TableAlias+findOneColumn' targetCol tcontext = do+  case findColumn' targetCol tcontext of+    [] -> do+      Left (ColumnResolutionError targetCol)+    [match] -> pure match+    _matches -> Left (AmbiguousColumnResolutionError targetCol)++-- | Search the TableContext for a column alias remapping for the given column name. This function can change the state context if column names conflict.+attributeNameForColumnName :: ColumnName -> ConvertM AttributeName+attributeNameForColumnName colName = do+  tKey@(TableAlias tAlias) <- findOneColumn colName+  tcontext@(TableContext tmap) <- get+  let (_, rvattrs, colAliases) = tmap M.! tKey+  --strip table prefix, if necessary+  (ColumnAlias colAttr) <- case colName of+                ColumnName [attr] -> pure $ ColumnAlias attr+                ColumnName [_tname,attr] -> pure $ ColumnAlias attr+                ColumnName{} -> throwSQLE $ ColumnResolutionError colName+  case M.lookup colAttr colAliases of+    Just (alias,_) -> pure alias -- we found it, so it's valid+    Nothing ->+      -- look in rvattrs, so we don't need the table alias prefix. The lack of an entry in the column alias map indicates that the column was not renamed in the join condition.+      if colAttr `A.isAttributeNameContained` rvattrs then+        -- we have a matching attribute, but it could conflict with another attribute, so check for that+        case findOneColumn' (ColumnName [colAttr]) tcontext of+          Right _ -> pure colAttr+          Left (AmbiguousColumnResolutionError{}) -> do+            --we have a conflict, so insert a new column alias and return it+            (ColumnAlias al) <- noteColumnMention (Just tKey) (ColumnName [tAlias,colAttr]) Nothing+            pure al+          Left err -> throwSQLE err+      else+        case colName of+          ColumnName [_, col] | col `A.isAttributeNameContained` rvattrs ->+                                -- the column has not been aliased, so we presume it can be use the column name directly+                                pure col+          _ -> throwSQLE $ ColumnResolutionError colName++wrapTypeF :: TypeForRelExprF -> RelationalExpr -> ConvertM Relation+wrapTypeF typeF relExpr =+  case typeF relExpr of+    Left relError -> throwSQLE (SQLRelationalError relError)+    Right v -> pure v    ++baseDFExpr :: DataFrameExpr+baseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () [TupleExpr mempty]), --relationTrue if the table expression is empty "SELECT 1"+                             orderExprs = [],+                             offset = Nothing,+                             limit = Nothing }++falseDFExpr :: DataFrameExpr+falseDFExpr = DataFrameExpr { convertExpr = MakeRelationFromExprs (Just []) (TupleExprs () []), --relationFalse +                             orderExprs = [],+                             offset = Nothing,+                             limit = Nothing }+++convertQuery :: TypeForRelExprF -> Query -> ConvertM DataFrameExpr+convertQuery typeF (QuerySelect sel) = convertSelect typeF sel+convertQuery typeF (QueryValues vals) = do+  let convertTupleExprs tupVals = do+        TupleExpr . M.fromList <$> mapM (\(c, sexpr) -> do+                                            atomExpr <- convertScalarExpr typeF sexpr+                                            pure ("attr_" <> T.pack (show c), atomExpr)+                                        ) (zip [1::Int ..] tupVals)+  tupleExprs <- mapM convertTupleExprs vals+  pure (baseDFExpr { convertExpr = MakeRelationFromExprs Nothing (TupleExprs () tupleExprs) })+convertQuery _typeF (QueryTable tname) = do+  rvName <- convertTableName tname+  pure $ baseDFExpr { convertExpr = RelationVariable rvName () }+convertQuery typeF (QueryOp op q1 q2) = do+  let dfErr = NotSupportedError ("ORDER BY/LIMIT/OFFSET in " <> T.pack (show op))+  dfExpr1 <- runLocalConvertM (convertQuery typeF q1)+  when (usesDataFrameFeatures dfExpr1) $ throwSQLE dfErr  +  dfType1 <- case typeF (convertExpr dfExpr1) of+              Left err -> throwSQLE (SQLRelationalError err)+              Right t -> pure t++  dfExpr2 <- runLocalConvertM (convertQuery typeF q2)+  when (usesDataFrameFeatures dfExpr2) $ throwSQLE dfErr   +  dfType2 <- case typeF (convertExpr dfExpr2) of+               Left err -> throwSQLE (SQLRelationalError err)+               Right t -> pure t++  when (dfType1 /= dfType2) $ throwSQLE (QueryOperatorTypeMismatchError op (attributes dfType1) (attributes dfType2))++  let relOp = case op of+        UnionQueryOperator -> Union+        ExceptQueryOperator -> Difference+        IntersectQueryOperator -> Join++  pure $ baseDFExpr { convertExpr = relOp (convertExpr dfExpr1) (convertExpr dfExpr2) }+             +convertSelect :: TypeForRelExprF -> Select -> ConvertM DataFrameExpr+convertSelect typeF sel = do+  wExprs <- case withClause sel of+              Nothing -> pure mempty+              Just wClause -> do+                convertWithClause typeF wClause+  -- extract all mentioned tables into the table alias map for+  let typeF' = appendWithsToTypeF typeF wExprs+  (dfExpr, _colRemap) <- case tableExpr sel of+              Nothing -> pure (baseDFExpr, mempty)+              Just tExpr -> convertTableExpr typeF' tExpr+  let explicitWithF = if null wExprs then id else With wExprs+      (groupByExprs, havingExpr) = case tableExpr sel of+                                     Nothing -> ([],Nothing)+                                     Just texpr -> (groupByClause texpr, havingClause texpr)+  -- convert projection using table alias map to resolve column names+  projF <- convertProjection typeF' (projectionClause sel) groupByExprs havingExpr+  -- add with clauses+  withAssocs <- tableAliasesAsWithNameAssocs+  let withF = case withAssocs of+                [] -> id+                _ -> With withAssocs+      finalRelExpr = explicitWithF (withF (projF (convertExpr dfExpr)))+  -- if we have only one table alias or the columns are all unambiguous, remove table aliasing of attributes+  -- apply rename reduction- this could be applied by the static query optimizer, but we do it here to simplify the tests so that they aren't polluted with redundant renames+--  traceShowM ("finalExpr"::String, finalRelExpr)+  pure (dfExpr { convertExpr = finalRelExpr })+++-- returns a new typeF function which adds type checking for "with" clause expressions+appendWithsToTypeF :: TypeForRelExprF -> WithNamesAssocs -> TypeForRelExprF+appendWithsToTypeF typeF withAssocs relExpr =+  case relExpr of+    expr@(RelationVariable x ()) -> case With.lookup x withAssocs of+                               Nothing -> typeF expr+                               Just matchExpr -> typeF matchExpr+    other -> typeF other+      ++-- | Slightly different processing for subselects.+convertSubSelect :: TypeForRelExprF -> Select -> ConvertM RelationalExpr+convertSubSelect typeF sel = do+  ((applyF, tExpr), colRenames) <- withSubSelect $ do+    wExprs <- case withClause sel of+                Nothing -> pure mempty+                Just wClause -> do+                  convertWithClause typeF wClause+    let typeF' = appendWithsToTypeF typeF wExprs    +    (dfExpr, _colMap) <- case tableExpr sel of+                            Nothing -> pure (baseDFExpr, mempty)+                            Just tExpr -> convertTableExpr typeF' tExpr  +    when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery")+    let explicitWithF = if null wExprs then id else With wExprs    +    -- convert projection using table alias map to resolve column names+    projF <- convertProjection typeF' (projectionClause sel) [] Nothing -- the projection can only project on attributes from the subselect table expression+    -- add with clauses+    withAssocs <- tableAliasesAsWithNameAssocs+    let withF = case withAssocs of+                  [] -> id+                  _ -> With withAssocs+    -- add disambiguation renaming+    pure (explicitWithF . withF . projF, convertExpr dfExpr)+    +  let renamedExpr = foldr renamerFolder tExpr (M.toList colRenames)+      renamerFolder ((TableAlias tAlias, oldAttrName), ColumnAlias newAttrName)=+        pushDownAttributeRename (S.singleton (oldAttrName, newAttrName)) (RelationVariable tAlias ())+        +  pure (applyF renamedExpr)++convertSelectItem :: TypeForRelExprF -> SelectItemsConvertTask -> (Int, SelectItem) -> ConvertM SelectItemsConvertTask+convertSelectItem typeF acc (c,selItem) = +  case selItem of+    -- select * from x+    (Identifier (ColumnProjectionName [Asterisk]), Nothing) ->+      pure acc+    -- select sup.* from s as sup+    (Identifier qpn@(ColumnProjectionName [ProjectionName _, Asterisk]), Nothing) ->+      pure $ acc { taskProjections = S.insert qpn (taskProjections acc) }+    -- select a from x+    (Identifier qpn@(ColumnProjectionName [ProjectionName _col]), Nothing) -> do+      --look up unaliased column name+      _ <- colinfo qpn+      pure $ acc { taskProjections = S.insert qpn (taskProjections acc)+                 }+    -- select city as x from s        +    (Identifier qpn@(ColumnProjectionName [ProjectionName _]), Just newName@(ColumnAlias newNameTxt)) -> do+          pure $ acc { taskProjections = S.insert (ColumnProjectionName [ProjectionName newNameTxt]) (taskProjections acc),+                       taskRenames = taskRenames acc <> [(qpn, newName)] }+    -- select s.city from s+    (Identifier qpn@(ColumnProjectionName [ProjectionName tname, ProjectionName colname]), Nothing) -> do+      --lookup column renaming, if applicable+          pure $ acc { taskProjections = S.insert qpn (taskProjections acc),+                       taskRenames = taskRenames acc <> [(ColumnProjectionName [ProjectionName colname], ColumnAlias (T.intercalate "." [tname,colname]))] }+    -- other exprs+    (scalarExpr, mAlias) -> do+      let attrName' (Just (ColumnAlias nam)) _ = nam+          attrName' Nothing c' = "attr_" <> T.pack (show c')+          newAttrName = attrName' mAlias c+      atomExpr <- processSQLAggregateFunctions <$> convertProjectionScalarExpr typeF scalarExpr+      -- we need to apply the projections after the extension!+      pure $ acc { taskExtenders = AttributeExtendTupleExpr newAttrName atomExpr : taskExtenders acc,+                   taskProjections = S.insert (ColumnProjectionName [ProjectionName newAttrName]) (taskProjections acc)+                     }+  where+   colinfo (ColumnProjectionName [ProjectionName name]) = do+     findOneColumn (ColumnName [name])+   colinfo colProjName = throwSQLE $ UnexpectedColumnProjectionName colProjName++convertProjection :: TypeForRelExprF -> [SelectItem] -> [GroupByExpr] -> Maybe HavingExpr -> ConvertM (RelationalExpr -> RelationalExpr)+convertProjection typeF selItems groupBys havingExpr = do+    groupInfo <- convertGroupBy typeF groupBys havingExpr selItems+    task <- foldM (convertSelectItem typeF) emptyTask (zip [1::Int ..] selItems)+    -- SQL supports only one grouping at a time, but multiple aggregations, so we create the group as attribute "_sql_aggregate" and the aggregations as fold projections on it+    fGroup <- if not (null (nonAggregates groupInfo)) ||+                 (null (nonAggregates groupInfo) && not (null (aggregates groupInfo)))+                 -- special case: SELECT max(status) FROM city- handle aggregations without GROUP BY                 +              then+                pure $ Group (InvertedAttributeNames+                              (S.fromList (map fst (nonAggregates groupInfo)))) "_sql_aggregate"+              else+                pure id+    let coalesceBoolF expr = FunctionAtomExpr "sql_coalesce_bool" [expr] ()                +    fGroupHavingExtend <- +      case havingRestriction groupInfo of+        Nothing -> pure id+        Just sexpr -> do+          convertedAtomExpr <- convertProjectionScalarExpr typeF sexpr+          let atomExpr = processSQLAggregateFunctions convertedAtomExpr+          pure $ Extend (AttributeExtendTupleExpr "_sql_having" (coalesceBoolF atomExpr))+    let fGroupRestriction = case havingRestriction groupInfo of+                              Nothing -> id+                              Just _ ->+                                  Restrict (AttributeEqualityPredicate "_sql_having" (NakedAtomExpr (BoolAtom True)))+    --apply projections+    fProjection <- if S.null (taskProjections task) then+                     pure id+                   else do+                     let projFolder (attrNames, b) (ColumnProjectionName [ProjectionName nam]) =+                           pure (S.insert nam attrNames, b)+                         projFolder (attrNames, b) (ColumnProjectionName [ProjectionName nameA, ProjectionName nameB]) =+                           pure (S.insert (T.concat [nameA, ".", nameB]) attrNames, b)+                         projFolder (attrNames, relExprAttributes) (ColumnProjectionName [ProjectionName tname, Asterisk]) =+                           pure (attrNames, relExprAttributes <> [tname])+                         projFolder _ colProjName = throwSQLE $ UnexpectedColumnProjectionName colProjName+                     (attrNames, relExprRvs) <- foldM projFolder mempty (S.toList (taskProjections task))+                     let attrsProj = A.some (map (\rv -> RelationalExprAttributeNames (RelationVariable rv ())) relExprRvs <> [AttributeNames attrNames])+                     pure $ Project attrsProj+    -- apply extensions+    let fExtended = foldr (\ext acc -> Extend ext . acc) id (taskExtenders task)+    -- process SQL aggregates by replacing projections+    -- apply rename+    renamesSet <- foldM (\acc (qProjName, ColumnAlias newName) -> do+                          oldName <- convertColumnProjectionName qProjName+                          pure $ S.insert (oldName, newName) acc) S.empty (taskRenames task)+    let fRenames = if S.null renamesSet then id else Rename renamesSet+    pure (fGroupRestriction . fProjection . fGroupHavingExtend . fExtended . fRenames . fGroup)++convertUnqualifiedColumnName :: UnqualifiedColumnName -> AttributeName+convertUnqualifiedColumnName (UnqualifiedColumnName nam) = nam++convertColumnName :: ColumnName -> ConvertM AttributeName+convertColumnName colName = do+  attributeNameForColumnName colName++convertColumnProjectionName :: ColumnProjectionName -> ConvertM AttributeName+convertColumnProjectionName qpn@(ColumnProjectionName names) = do+  let namer (ProjectionName t) = pure t+      namer Asterisk = throwSQLE $ UnexpectedAsteriskError qpn+  names' <- mapM namer names+  convertColumnName (ColumnName names')+                      +        +convertTableExpr :: TypeForRelExprF -> TableExpr -> ConvertM (DataFrameExpr, ColumnAliasMap)+convertTableExpr typeF tExpr = do+    (fromExpr, columnMap) <- convertFromClause typeF (fromClause tExpr)+    whereF <- case whereClause tExpr of+      Just whereExpr -> do+        restrictPredExpr <- convertWhereClause typeF whereExpr+        pure $ Restrict restrictPredExpr+      Nothing -> pure id+    orderExprs' <- convertOrderByClause typeF (orderByClause tExpr)+    -- add disambiguation renaming+    let disambiguationRenamerF = if S.null renames then id else Rename renames+        renames = S.fromList $ foldr folder mempty (M.toList columnMap)+        whereAttrNames = S.map (\(ColumnName cs) -> T.intercalate "." cs) whereColNames+        whereColNames = maybe mempty columnNamesInRestrictionExpr (whereClause tExpr)+        folder (ColumnAlias alias, attrName) acc = -- include renamer only if the column is referenced and the renaming is not redundant+          if alias /= attrName && S.member alias whereAttrNames then+             (attrName, alias):acc+             else+            acc+    +    let dfExpr = DataFrameExpr { convertExpr = whereF (disambiguationRenamerF fromExpr),+                                 orderExprs = orderExprs',+                                 offset = offsetClause tExpr,+                                 limit = limitClause tExpr }+    pure (dfExpr, columnMap)++convertWhereClause :: TypeForRelExprF -> RestrictionExpr -> ConvertM RestrictionPredicateExpr+convertWhereClause typeF (RestrictionExpr rexpr) = do+    let wrongType t = throwSQLE $ TypeMismatchError t BoolAtomType --must be boolean expression+        coalesceBoolF expr = FunctionAtomExpr "sql_coalesce_bool" [expr] ()+        sqlEq l = FunctionAtomExpr "sql_equals" l ()+    case rexpr of+      IntegerLiteral{} -> wrongType IntegerAtomType+      DoubleLiteral{} -> wrongType DoubleAtomType+      NullLiteral{} -> wrongType IntegerAtomType+      StringLiteral{} -> wrongType TextAtomType+      Identifier _i -> wrongType TextAtomType -- could be a better error here+      BooleanLiteral True -> +        pure TruePredicate+      BooleanLiteral False ->+        pure (NotPredicate TruePredicate)+      BinaryOperator (Identifier colName) (OperatorName ["="]) exprMatch -> do --we don't know here if this results in a boolean expression, so we pass it down+        attrName <- attributeNameForColumnName colName+        expr' <- convertScalarExpr typeF exprMatch+        pure (AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_equals" [AttributeAtomExpr attrName, expr'] ())))+      BinaryOperator exprA op exprB -> do+        a <- convertScalarExpr typeF exprA+        b <- convertScalarExpr typeF exprB+        f <- lookupOperator False op+        pure (AtomExprPredicate (coalesceBoolF (f [a,b])))+      PostfixOperator expr (OperatorName ops) -> do+        expr' <- convertScalarExpr typeF expr+        let isnull = AtomExprPredicate (coalesceBoolF (FunctionAtomExpr "sql_isnull" [expr'] ()))+        case ops of+          ["is", "null"] -> +            pure isnull+          ["is", "not", "null"] -> +            pure (NotPredicate isnull)+          other -> throwSQLE $ NotSupportedError ("postfix operator: " <> T.pack (show other))+      InExpr inOrNotIn sexpr (InList matches') -> do+        eqExpr <- convertScalarExpr typeF sexpr+        case reverse matches' of+         (match:matches) -> do+           firstItem <- convertScalarExpr typeF match+           let predExpr' = sqlEq [eqExpr, firstItem]+               folder predExpr'' sexprItem = do+                 item <- convertScalarExpr typeF sexprItem+                 pure $ FunctionAtomExpr "sql_or" [sqlEq [eqExpr,item], predExpr''] ()+           res <- AtomExprPredicate . coalesceBoolF <$> foldM folder predExpr' matches +           case inOrNotIn of+             In -> pure res+             NotIn -> pure (NotPredicate res)+         [] -> throwSQLE $ NotSupportedError "empty IN() clause"+      ExistsExpr subQ -> do+        relExpr  <- convertSubSelect typeF subQ+        --pretty sure I have to rename attributes in both the top-level query and in this one to prevent attribute conflicts- we can't rename all the attributes in the subquery, because the renamer won't know which attributes actually refer to the top-level attributes- should we just prefix all attributes unconditionally or send a signal upstream to rename attributes? FIXME+        let rexpr' = Project A.empty relExpr+        pure (RelationalExprPredicate rexpr')+      other -> throwSQLE $ NotSupportedError ("where clause: " <> T.pack (show other))+++convertScalarExpr :: TypeForRelExprF -> ScalarExpr -> ConvertM AtomExpr+convertScalarExpr typeF expr = do+    let naked = pure . NakedAtomExpr+    case expr of+      IntegerLiteral i -> naked (IntegerAtom i)+      DoubleLiteral d -> naked (DoubleAtom d)+      StringLiteral s -> naked (TextAtom s)+      BooleanLiteral True -> naked (BoolAtom True)+      -- pure $ ConstructedAtomExpr "True" [] ()+      BooleanLiteral False -> naked (BoolAtom False)+      --pure $ ConstructedAtomExpr "False" [] ()+      -- we don't have enough type context with a cast, so we default to text+      NullLiteral -> pure $ ConstructedAtomExpr "SQLNullOfUnknownType" [] ()+      Identifier i -> do+        AttributeAtomExpr <$> convertColumnName i+      BinaryOperator exprA op exprB -> do+        a <- convertScalarExpr typeF exprA+        b <- convertScalarExpr typeF exprB+        f <- lookupOperator False op+        pure $ f [a,b]+      FunctionApplication funcName' fargs -> do+        func <- lookupFunc funcName'+        fargs' <- mapM (convertScalarExpr typeF) fargs+        pure (func fargs')+      other -> throwSQLE $ NotSupportedError ("scalar expr: " <> T.pack (show other))++-- SQL conflates projection and extension so we use the SQL context name here+convertProjectionScalarExpr :: TypeForRelExprF -> ProjectionScalarExpr -> ConvertM AtomExpr+convertProjectionScalarExpr typeF expr = do+    let naked = pure . NakedAtomExpr+    case expr of+      IntegerLiteral i -> naked (IntegerAtom i)+      DoubleLiteral d -> naked (DoubleAtom d)+      StringLiteral s -> naked (TextAtom s)+      BooleanLiteral True ->+        naked (BoolAtom True)+        --pure $ ConstructedAtomExpr "True" [] ()+      BooleanLiteral False ->+        naked (BoolAtom False)+        --pure $ ConstructedAtomExpr "False" [] ()+      NullLiteral -> pure $ ConstructedAtomExpr "SQLNullOfUnknownType" [] ()+      Identifier i -> do+        AttributeAtomExpr <$> convertColumnProjectionName i+      BinaryOperator exprA op exprB -> do+        a <- convertProjectionScalarExpr typeF exprA+        b <- convertProjectionScalarExpr typeF exprB+        f <- lookupOperator False op+        pure $ f [a,b]+      FunctionApplication fname fargs -> do+        func <- lookupFunc fname+        -- as a special case, count(*) is valid, if non-sensical SQL, so handle it here+        fargs' <- if fname == FuncName ["count"] && fargs == [Identifier (ColumnProjectionName [Asterisk])] then+                   pure [AttributeAtomExpr "_sql_aggregate"]+                 else +                   mapM (convertProjectionScalarExpr typeF) fargs+        pure (func fargs')+      PrefixOperator op sexpr -> do+        func <- lookupOperator True op+        arg <- convertProjectionScalarExpr typeF sexpr+        pure (func [arg])+      CaseExpr conditionals mElse -> do+        let coalesceBoolF expr' = FunctionAtomExpr "sql_coalesce_bool" [expr'] ()+        conditionals' <- mapM (\(ifExpr, thenExpr) -> do+                                  ifE <- coalesceBoolF <$> convertProjectionScalarExpr typeF ifExpr+                                  thenE <- convertProjectionScalarExpr typeF thenExpr+                                  +                                  pure (ifE, thenE)+                              ) conditionals++        elseExpr <- case mElse of+                      Nothing -> pure $ NakedAtomExpr $ nullAtom (TypeVariableType "a") Nothing --will the engine resolve this type variable?+                      Just expr' -> convertProjectionScalarExpr typeF expr'+        let ifThenFolder acc (ifE, thenE) = IfThenAtomExpr ifE thenE acc+        pure $ foldl' ifThenFolder elseExpr conditionals'+      other -> throwSQLE $ NotSupportedError ("projection scalar expr: " <> T.pack (show other))++convertOrderByClause :: TypeForRelExprF -> [SortExpr] -> ConvertM [AttributeOrderExpr]+convertOrderByClause typeF =+  mapM converter+    where+      converter (SortExpr sexpr mDirection mNullsOrder) = do+        atomExpr <- convertScalarExpr typeF sexpr+        attrn <- case atomExpr of+                   AttributeAtomExpr aname -> pure aname+                   x -> throwSQLE (NotSupportedError (T.pack (show x)))+        let ordering = case mDirection of+                         Nothing -> AscendingOrder+                         Just Ascending -> AscendingOrder+                         Just Descending -> DescendingOrder+        case mNullsOrder of+          Nothing -> pure ()+          Just x -> throwSQLE (NotSupportedError (T.pack (show x)))+        pure (AttributeOrderExpr attrn ordering)+  ++convertWithClause :: TypeForRelExprF -> WithClause -> ConvertM WithNamesAssocs+convertWithClause typeF wClause =+  mapM convertOneWith (NE.toList (withExprs wClause))+  where+    convertOneWith (WithExpr (WithExprAlias alias) sel) = do+      relExpr <- convertSubSelect typeF sel+      pure (WithNameExpr alias (), relExpr)++type ColumnRemap = M.Map ColumnName ColumnName++convertFromClause :: TypeForRelExprF -> [TableRef] -> ConvertM (RelationalExpr, ColumnAliasMap)+convertFromClause typeF (firstRef:trefs) = do+    --the first table ref must be a straight RelationVariable+  let convertFirstTableRef (SimpleTableRef (TableName [nam])) = do+        let rv = RelationVariable nam ()+        typeR <- wrapTypeF typeF rv+        colMap <- insertTable (TableAlias nam) rv (attributes typeR)+        pure (rv, colMap)+      convertFirstTableRef (AliasedTableRef (SimpleTableRef (TableName [nam])) al@(TableAlias alias)) = do+        let rv = RelationVariable nam ()+        typeR <- wrapTypeF typeF rv+        colMap <- insertTable al rv (attributes typeR)+        pure (RelationVariable alias (), colMap)+      convertFirstTableRef tref =+        throwSQLE $ NotSupportedError ("first table ref: " <> T.pack (show tref))+  (firstRel, colMap) <- convertFirstTableRef firstRef+  expr' <- foldM (joinTableRef typeF) firstRel (zip [1..] trefs)+  pure (expr', colMap)+convertFromClause _ [] = throwSQLE $ NotSupportedError "empty table refs"  ++-- | Convert TableRefs after the first one (assumes all additional TableRefs are for joins). Returns the qualified name key that was added to the map, the underlying relexpr (not aliased so that it can used for extracting type information), and the new table context map+convertTableRef :: TypeForRelExprF -> TableRef -> ConvertM (TableAlias, RelationalExpr)+convertTableRef typeF tref =+  case tref of+    SimpleTableRef (TableName [nam]) -> do+      let rv = RelationVariable nam ()+          ta = TableAlias nam+      typeRel <- wrapTypeF typeF rv +      _ <- insertTable ta rv (attributes typeRel)+      pure (ta, rv) -- include with clause even for simple cases because we use this mapping to +    AliasedTableRef (SimpleTableRef (TableName [nam])) tAlias -> do+      typeRel <- wrapTypeF typeF (RelationVariable nam ())+      let rv = RelationVariable nam ()+      _ <- insertTable tAlias rv (attributes typeRel)+      pure (tAlias, RelationVariable nam ())+    x -> throwSQLE $ NotSupportedError ("table ref: " <> T.pack (show x))++  +joinTableRef :: TypeForRelExprF -> RelationalExpr -> (Int, TableRef) -> ConvertM RelationalExpr+joinTableRef typeF rvA (_c,tref) = do+      -- optionally prefix attributes unelss the expr is a RelationVariable+  let attrRenamer x expr attrs = do+        renamed <- mapM (renameOneAttr x expr) attrs+        pure (Rename (S.fromList renamed) expr)+      -- prefix all attributes+      prefixRenamer tAlias expr attrs = do+        renamed <- mapM (prefixOneAttr tAlias) attrs+        pure (Rename (S.fromList renamed) expr)+      prefixOneAttr tAlias@(TableAlias tPrefix) old_name = do+        -- insert into columnAliasMap+        let new_name = T.concat [tPrefix, ".", old_name]+--        traceShowM ("prefixOneAttr", tAlias, old_name, new_name)+        (ColumnAlias alias) <- noteColumnMention (Just tAlias) (ColumnName [old_name]) (Just (ColumnAlias new_name))+--        traceShowM ("joinTableRef prefixOneAttr", alias)+--        traceStateM+--        insertColumnAlias tAlias old_name (ColumnAlias new_name) (ColumnName [new_name])+--        addColumnAlias tAlias (ColumnAlias new_name) old_name+        pure (old_name, alias)+      renameOneAttr x expr old_name = do+--        traceShowM ("renameOneAttr", old_name, new_name)+        insertColumnAlias (TableAlias prefix) old_name (ColumnAlias new_name) (ColumnName [new_name])+--        addColumnAlias (TableAlias prefix) (ColumnAlias new_name) old_name+        pure (old_name, new_name)+        where+          new_name = T.concat [prefix, ".", old_name]+          prefix = case expr of+            RelationVariable rvName () -> rvName+            _ -> x -- probably need to return errors for some expressions+      crossJoin jtref = do+            --rename all columns to prefix them with a generated alias to prevent any natural join occurring, then perform normal join+            -- we need the type to get all the attribute names for both relexprs+            (_tKey, rvB) <- convertTableRef typeF jtref+            case typeF rvA of+              Left err -> throwSQLE (SQLRelationalError err)+              Right typeA ->+                case typeF rvB of+                  Left err -> throwSQLE (SQLRelationalError err)+                  Right typeB -> do+                    let attrsA = A.attributeNameSet (attributes typeA)+                        attrsB = A.attributeNameSet (attributes typeB)+                        attrsIntersection = S.intersection attrsA attrsB+                        --find intersection of attributes and rename all of them with prefix 'expr'+c+'.'+                    exprA <- attrRenamer "a" rvA (S.toList attrsIntersection)+                    pure (Join exprA rvB)+  case tref of+          SimpleTableRef tname -> -- a simple table ref in this position implies a cross join (no join condition unless it appears in the where clause)+            crossJoin (SimpleTableRef tname)+          NaturalJoinTableRef jtref -> do+            -- then natural join is the only type of join which the relational algebra supports natively+            (_, rvB) <- convertTableRef typeF jtref+            pure $ Join rvA rvB+          CrossJoinTableRef jtref -> crossJoin jtref+          InnerJoinTableRef jtref (JoinUsing qnames) -> do+            (tKey, rvB) <- convertTableRef typeF jtref+            let jCondAttrs = S.fromList $ map convertUnqualifiedColumnName qnames+            (attrsIntersection, _attrsA, _attrsB) <- commonAttributeNames typeF rvA rvB+            --rename attributes used in the join condition+            let attrsToRename = S.difference attrsIntersection jCondAttrs+--            traceShowM ("inner", attrsToRename, attrsIntersection, jCondAttrs)+                rvNameB = case tKey of+                            TableAlias ta -> ta+            exprA <- attrRenamer "a" rvA (S.toList attrsToRename)+            exprB <- prefixRenamer tKey (RelationVariable rvNameB ()) (S.toList attrsToRename)+            pure (Join exprA exprB)+            +          InnerJoinTableRef jtref (JoinOn (JoinOnCondition joinExpr)) -> do+            --create a cross join but extend with the boolean sexpr+            --extend the table with the join conditions, then join on those+            --exception: for simple attribute equality, use regular join renames using JoinOn logic+            +            (tKey, rvB) <- convertTableRef typeF jtref+            --rvA and rvB now reference potentially aliased relation variables (needs with clause to execute), but this is useful for making attributes rv-prefixed+            --extract all table aliases to create a remapping for SQL names discovered in the sexpr+            +            withExpr <- With <$> tableAliasesAsWithNameAssocs+            (_commonAttrs, attrsA, attrsB) <- commonAttributeNames typeF (withExpr rvA) (withExpr rvB)+            -- first, execute the rename, renaming all attributes according to their table aliases+            let rvPrefix rvExpr =+                  case rvExpr of+                    RelationVariable nam () -> pure nam+                    x -> throwSQLE $ NotSupportedError ("cannot derived name for relational expression " <> T.pack (show x))+                   +                rvNameB = case tKey of+                             TableAlias ta -> ta+            rvNameA <- rvPrefix rvA+--            rvPrefixB <- rvPrefix rvB+            exprA <- prefixRenamer (TableAlias rvNameA) rvA (S.toList attrsA)+            exprB <- prefixRenamer tKey (RelationVariable rvNameB ()) (S.toList attrsB)+            -- for the join condition, we can potentially extend to include all the join criteria columns, then project them away after constructing the join condition+            joinRe <- convertScalarExpr typeF joinExpr --' why are we renaming here- can't we call attributenameforcolumnname in the scalarexpr conversion???+            --let joinCommonAttrRenamer (RelationVariable rvName ()) old_name =+            --rename all common attrs and use the new names in the join condition+            let allAttrs = S.union attrsA attrsB+                firstAvailableName c allAttrs' =+                  let new_name = T.pack ("join_" <> show c) in+                  if S.member new_name allAttrs' then+                    firstAvailableName (c + 1) allAttrs'+                    else+                    new_name+                joinName = firstAvailableName (1::Int) allAttrs+                extender = AttributeExtendTupleExpr joinName (FunctionAtomExpr "sql_coalesce_bool" [joinRe] ())+                --joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (ConstructedAtomExpr "True" [] ()))+                joinMatchRestriction = Restrict (AttributeEqualityPredicate joinName (NakedAtomExpr (BoolAtom True)))+                projectAwayJoinMatch = Project (InvertedAttributeNames (S.fromList [joinName]))+            pure (projectAwayJoinMatch (joinMatchRestriction (Extend extender (Join exprB exprA))))+          other -> throwSQLE $ NotSupportedError ("join: " <> T.pack (show other))++lookupOperator :: Bool -> OperatorName -> ConvertM ([AtomExpr] -> AtomExpr)+lookupOperator isPrefix op@(OperatorName nam)+  | isPrefix = do+      let f n args = FunctionAtomExpr n args ()+      case nam of+        ["-"] -> pure $ f "sql_negate"+        _ -> throwSQLE $ NoSuchSQLOperatorError op+  | otherwise =+      lookupFunc (FuncName nam)+++-- this could be amended to support more complex expressions such as coalesce by returning an [AtomExpr] -> AtomExpr function+lookupFunc :: FuncName -> ConvertM ([AtomExpr] -> AtomExpr)+lookupFunc qname =+  case qname of+    FuncName [nam] ->+      case lookup nam sqlFuncs of+        Nothing -> throwSQLE $ NoSuchSQLFunctionError qname+        Just match -> pure match+    other -> throwSQLE $ NotSupportedError ("function name: " <> T.pack (show other))+  where+    f n args = FunctionAtomExpr n args ()+    aggMapper (FuncName [nam], nam') = (nam, f nam')+    aggMapper (FuncName other,_) = error ("unexpected multi-component SQL aggregate function: " <> show other)+    sqlFuncs = [(">",f "sql_gt"),+                 ("<",f "sql_lt"),+                 (">=",f "sql_gte"),+                 ("<=",f "sql_lte"),+                 ("=",f "sql_equals"),+                 ("!=",f "sql_not_equals"), -- function missing+                 ("<>",f "sql_not_equals"), -- function missing+                 ("+", f "sql_add"),+                 ("and", f "sql_and"),+                 ("or", f "sql_or"),+                 ("abs", f "sql_abs")+               ] <> map aggMapper aggregateFunctions+++-- | Used in join condition detection necessary for renames to enable natural joins.+commonAttributeNames :: TypeForRelExprF -> RelationalExpr -> RelationalExpr -> ConvertM (S.Set AttributeName, S.Set AttributeName, S.Set AttributeName)+commonAttributeNames typeF rvA rvB =+  case typeF rvA of+    Left err -> throwSQLE (SQLRelationalError err)+    Right typeA ->+      case typeF rvB of+        Left err -> throwSQLE (SQLRelationalError err)+        Right typeB -> do+          let attrsA = A.attributeNameSet (attributes typeA)+              attrsB = A.attributeNameSet (attributes typeB)+          pure (S.intersection attrsA attrsB, attrsA, attrsB)++-- | Used to remap SQL qualified names to new names to prevent conflicts in join conditions.+renameIdentifier :: (ColumnName -> ColumnName) -> ScalarExpr -> ScalarExpr+renameIdentifier renamer = Fold.cata renamer'+  where+    renamer' :: ScalarExprBaseF ColumnName ScalarExpr -> ScalarExpr+    renamer' (IdentifierF n) = Identifier (renamer n)+    renamer' x = Fold.embed x++-- find all column aliases in a scalar expression- useful for determining if a renamer needs to be applied+columnNamesInScalarExpr :: ScalarExpr -> S.Set ColumnName+columnNamesInScalarExpr = Fold.cata finder+  where+    finder :: ScalarExprBaseF ColumnName (S.Set ColumnName) -> S.Set ColumnName+    finder (IdentifierF n) = S.singleton n+    finder sexpr = foldr S.union mempty sexpr++columnNamesInRestrictionExpr :: RestrictionExpr -> S.Set ColumnName+columnNamesInRestrictionExpr (RestrictionExpr sexpr) = columnNamesInScalarExpr sexpr++-- | If the restriction includes a EXISTS expression, we must rename all attributes at the top-level to prevent conflicts.+needsToRenameAllAttributes :: RestrictionExpr -> Bool+needsToRenameAllAttributes (RestrictionExpr sexpr) =+  rec' sexpr+  where+  rec' sexpr' =+    case sexpr' of+      DoubleLiteral{} -> False+      StringLiteral{} -> False+      IntegerLiteral{} -> False+      NullLiteral{} -> False+      BooleanLiteral{} -> False+      Identifier{} -> False+      BinaryOperator e1 _ e2 -> rec' e1 || rec' e2+      PrefixOperator _ e1 -> rec' e1+      PostfixOperator e1 _ -> rec' e1+      BetweenOperator e1 _ e2 -> rec' e1 || rec' e2+      FunctionApplication _ e1 -> or (rec' <$> e1)+      CaseExpr cases else' -> any (\(when', then') ->+                                          rec' when' || rec' then' || maybe False rec' else') cases+      QuantifiedComparison{} -> True+      InExpr _ sexpr'' _ -> rec' sexpr''+      BooleanOperatorExpr e1 _ e2 -> rec' e1 || rec' e2+      ExistsExpr{} -> True++{-+":showexpr relation{tuple{val 4, children relation{tuple{val 6,children relation{tuple{}}}}},+                   tuple{val 10, children relation{tuple{val 1, children relation{tuple{}}},+                                                   tuple{val 2, children relation{tuple{}}}}}}+-}++-- rename an attribute within a relational expression+-- this really should be generalized to a standard fold or via recursion schemes+pushDownAttributeRename :: S.Set (AttributeName, AttributeName) -> RelationalExpr -> RelationalExpr -> RelationalExpr+pushDownAttributeRename renameSet matchExpr targetExpr =+  case targetExpr of+    _ | targetExpr == matchExpr ->+        Rename renameSet targetExpr+    x@MakeRelationFromExprs{} -> x+    x@MakeStaticRelation{} -> x+    x@ExistingRelation{} -> x+    x@RelationValuedAttribute{} -> x+    x@RelationVariable{} -> x+    Project attrs expr -> Project attrs (push expr)+    Union exprA exprB -> Union (push exprA) (push exprB)+    Join exprA exprB -> Join (push exprA) (push exprB)+    Rename rset expr -> Rename (S.union rset renameSet) (push expr)+    Difference exprA exprB -> Difference (push exprA) (push exprB)+    B.Group gAttrs newAttr expr -> B.Group gAttrs newAttr (push expr)+    Ungroup attrName expr -> Ungroup attrName (push expr)+    Restrict rExpr expr -> Restrict (pushRestrict rExpr) (push expr)+    Equals exprA exprB -> Equals (push exprA) (push exprB)+    NotEquals exprA exprB -> NotEquals (push exprA) (push exprB)+    Extend eExpr expr -> Extend (pushExtend eExpr) (push expr)+    With wAssocs expr -> With wAssocs (push expr)+  where+    push = pushDownAttributeRename renameSet matchExpr+    pushRestrict expr =+      case expr of+        x@TruePredicate -> x+        AndPredicate eA eB -> AndPredicate (pushRestrict eA) (pushRestrict eB)+        OrPredicate eA eB -> OrPredicate (pushRestrict eA) (pushRestrict eB)+        NotPredicate e -> NotPredicate (pushRestrict e)+        RelationalExprPredicate rexpr -> RelationalExprPredicate (push rexpr)+        AtomExprPredicate aexpr -> AtomExprPredicate (pushAtom aexpr)+        AttributeEqualityPredicate attr aexpr -> AttributeEqualityPredicate attr (pushAtom aexpr)+    pushExtend (AttributeExtendTupleExpr attrName aexpr) =+      --should this rename the attrName, too?+      AttributeExtendTupleExpr attrName (pushAtom aexpr)+    pushAtom expr =+      case expr of+        x@AttributeAtomExpr{} -> x --potential rename+        x@NakedAtomExpr{} -> x+        FunctionAtomExpr fname args () -> FunctionAtomExpr fname (pushAtom <$> args) ()+        RelationAtomExpr e -> RelationAtomExpr (push e)+        IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (pushAtom ifE) (pushAtom thenE) (pushAtom elseE)+        ConstructedAtomExpr dConsName args () -> ConstructedAtomExpr dConsName (pushAtom <$> args) ()+        +mkTableContextFromDatabaseContext :: DatabaseContext -> TransactionGraph -> Either RelationalError TableContext+mkTableContextFromDatabaseContext dbc tgraph = do+  TableContext . M.fromList <$> mapM rvMapper (M.toList (relationVariables dbc))+  where+    rvMapper (nam, rvexpr) = do+      let gfEnv = freshGraphRefRelationalExprEnv (Just dbc) tgraph+      typeRel <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr rvexpr)+      pure (TableAlias nam,+            (RelationVariable nam (), attributes typeRel, mempty))++convertUpdate :: TypeForRelExprF -> Update -> ConvertM DatabaseContextExpr+convertUpdate typeF up = do+  let convertSetColumns (UnqualifiedColumnName colName, sexpr) = do+        (,) colName <$> convertScalarExpr typeF sexpr+  atomMap <- M.fromList <$> mapM convertSetColumns (setColumns up)+  rvname <- convertTableName (Update.target up)+  let rv = RelationVariable rvname ()  +  case typeF rv of+    Left err -> throwSQLE (SQLRelationalError err)+    Right typeRel -> do+      _ <- insertTable (TableAlias rvname) rv (attributes typeRel)+      restrictionExpr <- case mRestriction up of+                           Nothing -> pure TruePredicate+                           Just restriction' -> convertWhereClause typeF restriction'+      pure (B.Update rvname atomMap restrictionExpr)++convertTableName :: TableName -> ConvertM RelVarName+convertTableName (TableName [tname]) = pure tname+convertTableName t@TableName{} = throwSQLE (UnexpectedTableNameError t)++convertDBUpdates :: TypeForRelExprF -> [DBUpdate] -> ConvertM DatabaseContextExpr+convertDBUpdates typeF dbUpdates = MultipleExpr <$> mapM (convertDBUpdate typeF) dbUpdates++convertDBUpdate :: TypeForRelExprF -> DBUpdate -> ConvertM DatabaseContextExpr+convertDBUpdate typeF (UpdateUpdate up) = convertUpdate typeF up+convertDBUpdate typeF (UpdateInsert ins) = convertInsert typeF ins+convertDBUpdate typeF (UpdateDelete del) = convertDelete typeF del+convertDBUpdate typeF (UpdateCreateTable ct) = convertCreateTable typeF ct+convertDBUpdate typeF (UpdateDropTable dt) = convertDropTable typeF dt++convertInsert :: TypeForRelExprF -> Insert -> ConvertM DatabaseContextExpr+convertInsert typeF ins = do+  -- check that all columns are mentioned because Project:M36 does not support default columns+  rvTarget <- convertTableName (Insert.target ins)+  let eRvTargetType = typeF (RelationVariable rvTarget ())+  case eRvTargetType of+    Left err -> throwSQLE (SQLRelationalError err)+    Right rvTargetType -> do+      -- if types do not align due to nullability, then add SQLJust+      dfExpr <- convertQuery typeF (source ins)+      when (usesDataFrameFeatures dfExpr) $ throwSQLE (NotSupportedError "ORDER BY/LIMIT/OFFSET in subquery")+      case typeF (convertExpr dfExpr) of+        Left err -> throwSQLE (SQLRelationalError err)+        Right rvExprType -> do+          let rvExprAttrNames = A.attributeNamesList (attributes rvExprType)+              insAttrNames = map convertUnqualifiedColumnName (Insert.targetColumns ins)+              rvExprColNameSet = S.map UnqualifiedColumnName (S.fromList rvExprAttrNames)+              insAttrColSet = S.fromList (Insert.targetColumns ins)+          when (length rvExprAttrNames /= length insAttrNames) $ throwSQLE (ColumnNamesMismatch rvExprColNameSet insAttrColSet)+    ++          -- insert into s(s#,sname,city,status) select * from s; -- we need to reorder attributes to align?+          -- rename attributes rexpr via query/values to map to targetCol attrs+          let atomTypeForName' attrName type' =+                case atomTypeForName attrName type' of+                  Left err -> throwSQLE (SQLRelationalError err)+                  Right targetType -> pure targetType+              ren a b (Rename names expr) = Rename (S.insert (a,b) names) expr+              ren a b e = Rename (S.singleton (a, b)) e+              sqlPrefix s = "_sql_" <> s+              projHide n = Project (InvertedAttributeNames (S.singleton n))+              -- if one of the types is a nullable version of the other+--              isSQLNullableCombo t1 t2 = isSQLNullableSpecificType t1 t2 || isSQLNullableSpecificType t2 t1+              sqlNullMorpher interName targetName targetType t2 expr+                | isSQLNullableSpecificType targetType t2 = -- targetType is nullable version of t2+                  Extend (AttributeExtendTupleExpr targetName (ConstructedAtomExpr "SQLJust" [AttributeAtomExpr interName] ())) expr+                | otherwise = expr+               +          let typeMatchRenamer acc (targetAttrName, sourceAttrName) = do+                targetType <- atomTypeForName' targetAttrName rvTargetType+                insType <- atomTypeForName' sourceAttrName rvExprType+                if targetType == insType && targetAttrName == sourceAttrName then --nothing to do+                  pure acc+                  else if targetAttrName /= sourceAttrName &&+                          targetType == insType then do+                          --simple rename+                         pure $ ren sourceAttrName targetAttrName acc+                  else if targetAttrName == sourceAttrName &&+                          targetType /= insType &&+                          isSQLNullableSpecificType targetType insType+                  then do -- we need to extend the expr, but we want to use the targetName, so we have to rename it twice+                         let intermediateName = sqlPrefix targetAttrName+                         pure $ ren intermediateName targetAttrName (sqlNullMorpher intermediateName targetAttrName targetType insType (ren sourceAttrName intermediateName acc))+                  else if targetAttrName /= sourceAttrName &&+                          targetType /= insType &&+                          isSQLNullableSpecificType targetType insType then do+                         -- we extend the expr, but don't need an intermediate rename+                         pure $ projHide sourceAttrName (Extend (AttributeExtendTupleExpr targetAttrName (ConstructedAtomExpr "SQLJust" [AttributeAtomExpr sourceAttrName] ())) acc)+                  else if targetAttrName == sourceAttrName &&+                          isSQLNullUnknownType insType &&+                          isNullAtomType targetType then do+                         case atomTypeFromSQLNull targetType of+                           Nothing -> do+                             pure acc+                           -- replace null of unknown type with typed null+                           Just atype -> do+                               pure $ Extend (AttributeExtendTupleExpr targetAttrName (NakedAtomExpr (nullAtom atype Nothing))) (projHide sourceAttrName acc)+                  else if targetAttrName /= sourceAttrName &&+                          isSQLNullUnknownType insType &&+                          isNullAtomType targetType then do+                         case atomTypeFromSQLNull targetType of+                           Nothing -> do+                             pure acc+                           -- replace null of unknown type with typed null+                           Just _atype -> do+                               pure $ projHide sourceAttrName $ Extend (AttributeExtendTupleExpr targetAttrName (ConstructedAtomExpr "SQLNull" [] ())) acc+                  else+                         pure acc+                         +          insExpr <- foldM typeMatchRenamer (convertExpr dfExpr) (zip insAttrNames rvExprAttrNames)+{-          let insExpr = if rvExprColNameSet == insAttrColSet then -- if the attributes already align, don't perform any renaming+                          convertExpr dfExpr+                        else+                          Rename (S.fromList (filter rendundantRename (zip rvExprAttrNames insAttrNames))) (convertExpr dfExpr)+              rendundantRename (a,b) = a /= b-}+{-          traceShowM ("source ins"::String, source ins)+          traceShowM ("source ins converted"::String, convertExpr dfExpr)+          traceShowM ("ins converted"::String, insExpr)+          traceShowM ("rvTargetType"::String, rvTargetType)-}++          pure $ B.Insert rvTarget insExpr++convertDelete :: TypeForRelExprF -> Delete.Delete -> ConvertM DatabaseContextExpr+convertDelete typeF del = do+  rvname <- convertTableName (Delete.target del)+  let rv = RelationVariable rvname ()+  case typeF rv of+    Left err -> throwSQLE (SQLRelationalError err)+    Right typeRel -> do+      _ <- insertTable (TableAlias rvname) rv (attributes typeRel)+      res <- convertWhereClause typeF (restriction del)+      pure (B.Delete rvname res)++convertCreateTable :: TypeForRelExprF -> CreateTable -> ConvertM DatabaseContextExpr+convertCreateTable _typeF ct = do+  rvTarget <- convertTableName (CreateTable.target ct)+  (attrs, constraintExprs) <- convertColumnNamesAndTypes rvTarget (CreateTable.targetColumns ct)+  pure (someDatabaseContextExprs (Define rvTarget attrs : constraintExprs))++convertDropTable :: TypeForRelExprF -> DropTable -> ConvertM DatabaseContextExpr+convertDropTable _typeF dt = do+  rvTarget <- convertTableName (DropTable.target dt)+  pure (Undefine rvTarget)++convertColumnNamesAndTypes :: RelVarName -> [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)] -> ConvertM ([AttributeExpr], [DatabaseContextExpr])+convertColumnNamesAndTypes rvName =+  foldM processColumn mempty+  where+    processColumn acc (ucn@(UnqualifiedColumnName colName), colType, constraints) = do+      aTypeCons <- convertColumnType colType constraints+      constraintExprs <- convertPerColumnConstraints rvName ucn constraints+      pure ( fst acc <> [AttributeAndTypeNameExpr colName aTypeCons ()],+             constraintExprs <> snd acc)++convertColumnType :: ColumnType -> PerColumnConstraints -> ConvertM TypeConstructor+convertColumnType colType constraints = do+  let mkTypeCons aType =+        let typeName = T.dropEnd (length ("AtomType"::String)) (T.pack (show aType))+            tCons = ADTypeConstructor typeName []+        in+          if notNullConstraint constraints then+            tCons+          else+            ADTypeConstructor "SQLNullable" [tCons]+      colTCons = mkTypeCons $+             case colType of+               IntegerColumnType -> IntegerAtomType+               TextColumnType -> TextAtomType+               BoolColumnType -> BoolAtomType+               DoubleColumnType -> DoubleAtomType+               DateTimeColumnType -> DateTimeAtomType+               DateColumnType -> DayAtomType+               ByteaColumnType -> ByteStringAtomType+  pure colTCons++convertPerColumnConstraints :: RelVarName -> UnqualifiedColumnName -> PerColumnConstraints -> ConvertM [DatabaseContextExpr]+convertPerColumnConstraints rvname (UnqualifiedColumnName colName) constraints = do+  -- NOT NULL constraints are already enforced by the column type+  fkExprs <- case references constraints of+               Nothing -> pure []        +               Just (TableName [fkTableName], UnqualifiedColumnName fkColName) -> do+                 let fkIncDepName = rvname <> "_" <> colName <> "__" <> fkTableName <> "_" <> fkColName <> "_fk"+                     mkFK = InclusionDependency (Project (AttributeNames (S.singleton colName)) (RelationVariable rvname ())) (Project (AttributeNames (S.singleton fkColName)) (RelationVariable fkTableName ()))++                 pure [AddInclusionDependency fkIncDepName mkFK]+               Just (TableName fkTableNames, UnqualifiedColumnName fkColName) ->+                 throwSQLE (NotSupportedError ("schema-qualified table name in fk constraint: " <> T.pack (show fkTableNames) <> " " <> fkColName))+  -- the uniqueness constraint in SQL does not consider NULLs to be equal by default+  let uniqueExprs = if uniquenessConstraint constraints then+                      if notNullConstraint constraints then+                        [databaseContextExprForUniqueKey rvname [colName]]+                      else+                        [databaseContextExprForUniqueKeyWithNull rvname colName]+                    else+                      []+  pure $ uniqueExprs <> fkExprs++databaseContextExprForUniqueKeyWithNull :: RelVarName -> AttributeName -> DatabaseContextExpr+databaseContextExprForUniqueKeyWithNull rvname attrName =+  AddInclusionDependency incDepName incDep+  where+    incDep = inclusionDependencyForKey (AttributeNames (S.singleton attrName)) (Restrict notNull (RelationVariable rvname ()))+    incDepName = rvname <> "_" <> attrName <> "_unique"+    notNull = NotPredicate (AtomExprPredicate (FunctionAtomExpr "sql_isnull" [AttributeAtomExpr attrName] ()))+                                  ++{-+select city,max(status) from s group by city;+(((s{city,status}) group ({status} as sub)) : {status2:=max(@sub)}){city,status2} rename {status2 as status}++before: Project (AttributeNames (fromList ["attr_2","city"])) (Extend (AttributeExtendTupleExpr "attr_2" (FunctionAtomExpr "sql_max" [AttributeAtomExpr "status"] ())) (RelationVariable "s" ()))++after: Rename (fromList [("status2","status")]) (Project (AttributeNames (fromList ["city","status2"])) (Extend (AttributeExtendTupleExpr "status2" (FunctionAtomExpr "max" [AttributeAtomExpr "sub"] ())) (Group (AttributeNames (fromList ["status"])) "sub" (Project (AttributeNames (fromList ["city","status"])) (RelationVariable "s" ())))))+-}++-- (s group ({all but city} as sub): {maxstatus:=max(@sub{status})}){city,maxstatus}+-- select city,max(status) from s group by city;++convertGroupBy :: TypeForRelExprF -> [GroupByExpr] -> Maybe HavingExpr -> [SelectItem] -> ConvertM GroupByInfo+convertGroupBy _typeF groupBys mHavingExpr sqlProjection = do+  --first, check that projection includes an aggregate, otherwise, there's no point+  --find aggregate functions at the top-level (including within other functions such as 1+max(x)), and refocus them on the group attribute projected on the aggregate target+  -- do we need an operator to apply a relexpr to a subrelation? For example, it would be useful to apply a projection across all the subrelations, and types are maintained+--  foldM convertGroupByExpr emptyGroupByInfo sqlProjection+  -- each scalar expr must appear at the top-level SelectItem list+--    convertGroupByExpr acc+  -- search group by exprs to find the matching sexpr- if more than one matches, error+  --todo: handle asterisk+  let findMatchingProjection expr@(GroupByExpr gbexpr) =+        let exprMatcher (projExpr, _alias) acc =+              if containsProjScalarExpr gbexpr projExpr then+                projExpr : acc+              else+                acc+        in+          case foldr exprMatcher mempty sqlProjection of+            [] -> throwSQLE (AggregateGroupByMismatchError gbexpr)+            [match] -> if containsAggregate match then+                         pure (AggGroupByItem match expr)+                       else+                         pure (NonAggGroupByItem match expr)+            _matches -> throwSQLE (AggregateGroupByMismatchError gbexpr)+      collectGroupByInfo info gbsexpr = do+        -- validate that there is a corresponding group by+        matchExpr <- findMatchingProjection gbsexpr+        case matchExpr of+          AggGroupByItem pe _gb -> +            pure $ info { aggregates = pe : aggregates info }+          NonAggGroupByItem (Identifier colName) gb -> do+            aname <- convertColumnProjectionName colName+            pure $ info { nonAggregates = (aname, gb) : nonAggregates info }+          NonAggGroupByItem pe _ -> do+            throwSQLE (UnsupportedGroupByProjectionError pe)+      -- find select items which are not mentioned in the group by expression and make sure that are in the aggregates info+--      collectNonGroupByInfo :: [ProjectionScalarExpr] -> GroupByInfo -> SelectItem ->  ConvertM GroupByInfo+      collectNonGroupByInfo info (projExpr, _alias) = +       if containsAggregate projExpr then+         pure (info { aggregates = projExpr : aggregates info })+       else+         pure info+         +  groups1 <- foldM collectGroupByInfo emptyGroupByInfo groupBys+  groups2 <- foldM collectNonGroupByInfo groups1 sqlProjection+  let groups3 = case mHavingExpr of+                  Just (HavingExpr sexpr) -> groups2 { havingRestriction = Just sexpr }+                  Nothing -> groups2+  -- perform some validation+{-  let sqlProj = HS.fromList (map fst sqlProjection)+      groupByProj = HS.fromList (aggregates groups2 <> map fst (nonAggregates groups2))+      diff = HS.difference sqlProj groupByProj+  if HS.null diff then-}+  pure groups3+{-    else+    throwSQLE (GroupByColumnNotReferencedInGroupByError (HS.toList diff))-}+    +++data GroupByItem = AggGroupByItem ProjectionScalarExpr GroupByExpr |+                   NonAggGroupByItem ProjectionScalarExpr GroupByExpr+ deriving (Show, Eq)++-- | Validated "group by" and "having" data+data GroupByInfo =+  GroupByInfo { aggregates :: [ProjectionScalarExpr], -- ^ mentioned in group by clause and uses aggregation+                nonAggregates :: [(AttributeName, GroupByExpr)], -- ^ mentioned in group by clause by not aggregations+                havingRestriction :: Maybe ProjectionScalarExpr                +              }+  deriving (Show, Eq)++emptyGroupByInfo :: GroupByInfo+emptyGroupByInfo = GroupByInfo { aggregates = [], nonAggregates = [], havingRestriction = Nothing }++aggregateFunctions :: [(FuncName, FunctionName)]+aggregateFunctions = [(FuncName ["max"], "sql_max"),+                       (FuncName ["min"], "sql_min"),+                       (FuncName ["sum"], "sql_sum"),+                       (FuncName ["count"], "sql_count")]++isAggregateFunction :: FuncName -> Bool+isAggregateFunction fname = fname `elem` map fst aggregateFunctions++containsAggregate :: ProjectionScalarExpr -> Bool+containsAggregate expr =+  case expr of+    IntegerLiteral{} -> False+    DoubleLiteral{} -> False+    StringLiteral{} -> False+    BooleanLiteral{} -> False+    NullLiteral -> False+    Identifier{} -> False+    BinaryOperator e1 op e2 -> containsAggregate e1 || containsAggregate e2 || opAgg op+    PrefixOperator op e1 -> containsAggregate e1 || opAgg op+    PostfixOperator e1 op -> containsAggregate e1 || opAgg op+    BetweenOperator e1 e2 e3 -> containsAggregate e1 || containsAggregate e2 || containsAggregate e3+    FunctionApplication fname args -> isAggregateFunction fname || any containsAggregate args+    c@CaseExpr{} -> or (cElse : concatMap (\(when', res) -> [containsAggregate res, containsAggregate when']) (caseWhens c))+      where+        cElse = maybe False containsAggregate (caseElse c)+    q@QuantifiedComparison{} -> containsAggregate (qcExpr q)+    InExpr _ e1 _ -> containsAggregate e1+    BooleanOperatorExpr e1 opName e2 -> opAgg opName || containsAggregate e1 || containsAggregate e2+    ExistsExpr{} -> False+  where+    opAgg _opName = False++-- | Returns True iff a projection scalar expr within a larger expression. Used for group by aggregation validation.+containsProjScalarExpr :: ProjectionScalarExpr -> ProjectionScalarExpr -> Bool+containsProjScalarExpr needle haystack =+  (needle == haystack) ||+    case haystack of+      IntegerLiteral{} -> False+      DoubleLiteral{} -> False+      StringLiteral{} -> False+      BooleanLiteral{} -> False+      NullLiteral -> False+      Identifier{} -> False+      BinaryOperator e1 _op e2 -> con e1 || con e2+      PrefixOperator _op e1 -> con e1+      PostfixOperator e1 _op -> con e1+      BetweenOperator e1 e2 e3 -> con e1 || con e2 || con e3+      FunctionApplication _fname args -> any con args+      c@CaseExpr{} -> or (cElse : concatMap (\(when', res) -> [con res, con when']) (caseWhens c))+        where+          cElse = maybe False con (caseElse c)+      q@QuantifiedComparison{} -> con (qcExpr q)+      InExpr _ e1 _ -> containsAggregate e1+      BooleanOperatorExpr e1 _opName e2 -> con e1 || con e2+      ExistsExpr{} -> False+   where+     con = containsProjScalarExpr needle++-- depth first replacement for scalar expr modification+replaceProjScalarExpr :: (ProjectionScalarExpr -> ProjectionScalarExpr) -> ProjectionScalarExpr -> ProjectionScalarExpr+replaceProjScalarExpr r orig =+  case orig of+    IntegerLiteral{} -> r orig+    DoubleLiteral{} -> r orig+    StringLiteral{} -> r orig+    BooleanLiteral{} -> r orig+    NullLiteral{} -> r orig+    Identifier{} -> r orig+    BinaryOperator e1 op e2 -> r (BinaryOperator (recr e1) op (recr e2))+    PrefixOperator op e1 -> r (PrefixOperator op (recr e1))+    PostfixOperator e1 op -> r (PostfixOperator (recr e1) op)+    BetweenOperator e1 e2 e3 -> r (BetweenOperator (recr e1) (recr e2) (recr e3))+    FunctionApplication fname args -> r (FunctionApplication fname (map recr args))+    c@CaseExpr{} -> r (CaseExpr { caseWhens = map (bimap recr recr) (caseWhens c),+                                  caseElse = recr <$> caseElse c+                                })+    c@QuantifiedComparison{} -> r (c{ qcExpr = recr (qcExpr c) })+    InExpr flag e1 predval -> r (InExpr flag (recr e1) predval)+    BooleanOperatorExpr e1 op e2 -> r (BooleanOperatorExpr (recr e1) op (recr e2))+    e@ExistsExpr{} -> e+  where+    recr = replaceProjScalarExpr r++-- find SQL aggregate functions and replace then with folds on attribute "_sql_aggregate"+processSQLAggregateFunctions :: AtomExpr -> AtomExpr+processSQLAggregateFunctions expr = +  case expr of+    AttributeAtomExpr{} -> expr+    NakedAtomExpr{} -> expr+    FunctionAtomExpr fname [AttributeAtomExpr attrName] ()+      | fname == "sql_count" && -- count(*) counts the number of rows+        attrName == "_sql_aggregate" -> expr+      | fname == "sql_count" -> -- count(city) counts the number city elements that are not null+        callF fname [RelationAtomExpr+                     (Restrict+                       (NotPredicate+                        (AtomExprPredicate+                         (callF "sql_isnull" [AttributeAtomExpr attrName]))) (RelationValuedAttribute "_sql_aggregate"))]+      | fname `elem` map snd aggregateFunctions ->+          FunctionAtomExpr fname+            [RelationAtomExpr (Project (AttributeNames (S.singleton attrName)) (RelationValuedAttribute "_sql_aggregate"))] ()+    FunctionAtomExpr fname args () -> FunctionAtomExpr fname (map processSQLAggregateFunctions args) ()+    RelationAtomExpr{} -> expr --not supported in SQL+    IfThenAtomExpr ifE thenE elseE -> IfThenAtomExpr (processSQLAggregateFunctions ifE) (processSQLAggregateFunctions thenE) (processSQLAggregateFunctions elseE)+    ConstructedAtomExpr{} -> expr --not supported in SQL+  where+    callF fname args = FunctionAtomExpr fname args ()

@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-}+module ProjectM36.SQL.CreateTable where+import ProjectM36.SQL.Select+import Control.DeepSeq+import Codec.Winery+import GHC.Generics++data CreateTable = CreateTable+  { target :: TableName,+    targetColumns :: [(UnqualifiedColumnName, ColumnType, PerColumnConstraints)]+  }+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryRecord CreateTable++data ColumnType =+  IntegerColumnType |+  TextColumnType |+  BoolColumnType |+  DoubleColumnType |+  DateTimeColumnType | -- timestamp with timezone+  DateColumnType |+  ByteaColumnType+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant ColumnType++-- | Used to represent constraints which are defined next to a column name and type.+data PerColumnConstraints = PerColumnConstraints {+  notNullConstraint :: Bool,+  uniquenessConstraint :: Bool,+  references :: Maybe (TableName, UnqualifiedColumnName)+  }+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant PerColumnConstraints

@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-}+module ProjectM36.SQL.DBUpdate where+import ProjectM36.SQL.Update+import ProjectM36.SQL.Insert+import ProjectM36.SQL.Delete+import ProjectM36.SQL.CreateTable+import ProjectM36.SQL.DropTable+import Control.DeepSeq+import Codec.Winery+import GHC.Generics++-- | represents any SQL expression which can change the current transaction state such as+data DBUpdate = UpdateUpdate Update |+                UpdateInsert Insert |+                UpdateDelete Delete |+                UpdateCreateTable CreateTable |+                UpdateDropTable DropTable+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant DBUpdate+                +

@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-}+module ProjectM36.SQL.Delete where+import ProjectM36.SQL.Select+import Control.DeepSeq+import Codec.Winery+import GHC.Generics++data Delete = Delete { target :: TableName,+                       restriction :: RestrictionExpr+                     }+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryRecord Delete

@@ -0,0 +1,14 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-}+module ProjectM36.SQL.DropTable where+import ProjectM36.SQL.Select+import Control.DeepSeq+import Codec.Winery+import GHC.Generics++newtype DropTable = DropTable+  { target :: TableName }+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryRecord DropTable+++  

@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-}+module ProjectM36.SQL.Insert where+import ProjectM36.SQL.Select+import ProjectM36.Serialise.Base ()+import Control.DeepSeq+import Codec.Winery+import GHC.Generics++data Insert = Insert+  { target :: TableName,+    targetColumns :: [UnqualifiedColumnName], -- because ProjectM36 does not support default values in columns, all columns from the underlying table must be included here+    source :: Query+  }+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryRecord Insert+

@@ -0,0 +1,267 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveTraversable, GeneralizedNewtypeDeriving, DerivingVia, DeriveAnyClass, DeriveGeneric, StandaloneDeriving, FlexibleInstances #-}+module ProjectM36.SQL.Select where+import qualified Data.List.NonEmpty as NE+import Data.Text (Text)+import Data.Functor.Foldable.TH+import Codec.Winery+import GHC.Generics+import Control.DeepSeq+import Data.Hashable++data Query = QuerySelect Select |+             QueryValues [[ScalarExpr]] |+             QueryTable TableName |+             QueryOp QueryOperator Query Query+             deriving (Show, Eq, Generic, NFData)+             deriving Serialise via WineryVariant Query++data QueryOperator = UnionQueryOperator | IntersectQueryOperator | ExceptQueryOperator+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant QueryOperator++data Select = Select { distinctness :: Maybe Distinctness,+                       projectionClause :: [SelectItem],+                       tableExpr :: Maybe TableExpr,+                       withClause :: Maybe WithClause+                     }+              deriving (Show, Eq, Generic, NFData)+              deriving Serialise via WineryRecord Select++instance Hashable Select++emptySelect :: Select+emptySelect = Select { distinctness = Nothing,+                       projectionClause = [],+                       tableExpr = Nothing,+                       withClause = Nothing+                     }++type SelectItem = (ProjectionScalarExpr, Maybe ColumnAlias)++data WithClause = WithClause { isRecursive :: Bool,+                               withExprs :: NE.NonEmpty WithExpr }+                  deriving (Show, Eq, Generic, NFData)+                  deriving Serialise via WineryRecord WithClause+                  deriving Hashable++data WithExpr = WithExpr WithExprAlias Select+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant WithExpr+  deriving Hashable++newtype WithExprAlias = WithExprAlias Text+  deriving (Show, Eq, Generic)+  deriving Serialise via WineryVariant WithExprAlias+  deriving newtype NFData+  deriving anyclass Hashable++data InFlag = In | NotIn+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant InFlag+  deriving Hashable++data ComparisonOperator = OpLT | OpGT | OpGTE | OpEQ | OpNE | OpLTE+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant ComparisonOperator++instance Hashable ComparisonOperator++data QuantifiedComparisonPredicate = QCAny | QCSome | QCAll+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant QuantifiedComparisonPredicate++instance Hashable QuantifiedComparisonPredicate++data TableRef = SimpleTableRef TableName+              | InnerJoinTableRef TableRef JoinCondition+              | RightOuterJoinTableRef TableRef JoinCondition+              | LeftOuterJoinTableRef TableRef JoinCondition+              | FullOuterJoinTableRef TableRef JoinCondition+              | CrossJoinTableRef TableRef+              | NaturalJoinTableRef TableRef+              | AliasedTableRef TableRef TableAlias+              | QueryTableRef Select+              deriving (Show, Eq, Generic, NFData)+              deriving Serialise via WineryVariant TableRef+              deriving Hashable++-- distinguish between projection attributes which may include an asterisk and scalar expressions (such as in a where clause) where an asterisk is invalid+type ProjectionScalarExpr = ScalarExprBase ColumnProjectionName++deriving via WineryVariant ProjectionScalarExpr instance Serialise ProjectionScalarExpr++type ScalarExpr = ScalarExprBase ColumnName++deriving via WineryVariant ScalarExpr instance Serialise ScalarExpr++data ScalarExprBase n =+  IntegerLiteral Integer+  | DoubleLiteral Double+  | StringLiteral Text+  | BooleanLiteral Bool+  | NullLiteral+    -- | Interval+  | Identifier n+  | BinaryOperator (ScalarExprBase n) OperatorName (ScalarExprBase n)+  | PrefixOperator OperatorName (ScalarExprBase n)+  | PostfixOperator (ScalarExprBase n) OperatorName+  | BetweenOperator (ScalarExprBase n) (ScalarExprBase n) (ScalarExprBase n)+  | FunctionApplication FuncName [ScalarExprBase n]+  | CaseExpr { caseWhens :: [(ScalarExprBase n,ScalarExprBase n)],+               caseElse :: Maybe (ScalarExprBase n) }+  | QuantifiedComparison { qcExpr :: ScalarExprBase n,+                           qcOperator :: ComparisonOperator,+                           qcPredicate :: QuantifiedComparisonPredicate,+                           qcQuery :: Select }+    +  | InExpr InFlag (ScalarExprBase n) InPredicateValue+    -- | ExistsSubQuery Select+    -- | UniqueSubQuery Select+    -- | ScalarSubQuery Select+  | BooleanOperatorExpr (ScalarExprBase n) BoolOp (ScalarExprBase n)+  | ExistsExpr Select+  deriving (Show, Eq, Generic, NFData)++instance (Hashable n, Eq n) => Hashable (ScalarExprBase n)++data BoolOp = AndOp | OrOp+  deriving (Eq, Show, Generic, NFData)+  deriving Serialise via WineryVariant BoolOp+  deriving Hashable++data InPredicateValue = InList [ScalarExpr] | InQueryExpr Select | InScalarExpr ScalarExpr+  deriving (Eq, Show, Generic, NFData)+  deriving Serialise via WineryVariant InPredicateValue+  deriving Hashable++newtype GroupByExpr = GroupByExpr ProjectionScalarExpr+  deriving (Show, Eq, Generic)+  deriving Serialise via WineryVariant GroupByExpr+  deriving newtype Hashable+  deriving newtype NFData++newtype HavingExpr = HavingExpr ProjectionScalarExpr+  deriving (Show, Eq, Generic)+  deriving Serialise via WineryVariant HavingExpr+  deriving newtype Hashable+  deriving newtype NFData++data SortExpr = SortExpr ScalarExpr (Maybe Direction) (Maybe NullsOrder)+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant SortExpr  +  deriving Hashable++data Direction = Ascending | Descending+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant Direction  +  deriving Hashable++data NullsOrder = NullsFirst | NullsLast+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant NullsOrder  +  deriving Hashable++data JoinType = InnerJoin | RightOuterJoin | LeftOuterJoin | FullOuterJoin | CrossJoin | NaturalJoin+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant JoinType  ++data JoinCondition = JoinOn JoinOnCondition | JoinUsing [UnqualifiedColumnName]+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant JoinCondition+  deriving Hashable++newtype JoinOnCondition = JoinOnCondition ScalarExpr+  deriving (Show, Eq, Generic)+  deriving Serialise via WineryVariant JoinOnCondition+  deriving newtype NFData+  deriving newtype Hashable++newtype ColumnProjectionName = ColumnProjectionName [ProjectionName] --dot-delimited reference+  deriving (Show, Eq, Ord, Generic)+  deriving Serialise via WineryVariant ColumnProjectionName+  deriving newtype NFData+  deriving newtype Hashable++data ProjectionName = ProjectionName Text | Asterisk+  deriving (Show, Eq, Ord, Generic, NFData)+  deriving Serialise via WineryVariant ProjectionName+  deriving Hashable++newtype ColumnName = ColumnName [Text]+  deriving (Show, Eq, Ord, Generic)+  deriving Serialise via WineryVariant ColumnName+  deriving newtype Hashable+  deriving newtype NFData++newtype UnqualifiedColumnName = UnqualifiedColumnName Text+  deriving (Show, Eq, Ord, Generic)+  deriving Serialise via WineryVariant UnqualifiedColumnName+  deriving newtype (Hashable, NFData)++newtype TableName = TableName [Text]+  deriving (Show, Eq, Ord, Generic)+  deriving Serialise via WineryVariant TableName+  deriving newtype (Hashable, NFData)++newtype OperatorName = OperatorName [Text]+  deriving (Show, Eq, Ord, Generic)+  deriving Serialise via WineryVariant OperatorName+  deriving newtype NFData++instance Hashable OperatorName++newtype ColumnAlias = ColumnAlias { unColumnAlias :: Text }+  deriving (Show, Eq, Ord, Generic)+  deriving Serialise via WineryVariant ColumnAlias+  deriving newtype NFData+  deriving newtype Hashable++newtype TableAlias = TableAlias { unTableAlias :: Text }+  deriving (Show, Eq, Ord, Generic)+  deriving Serialise via WineryVariant TableAlias+  deriving newtype (Monoid, Semigroup, NFData)+  deriving newtype Hashable++newtype FuncName = FuncName [Text]+  deriving (Show, Eq, Generic, Ord)+  deriving Serialise via WineryVariant FuncName+  deriving newtype NFData++instance Hashable FuncName++data Distinctness = Distinct | All+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryVariant Distinctness++instance Hashable Distinctness++newtype RestrictionExpr = RestrictionExpr ScalarExpr+  deriving (Show, Eq, Generic)+  deriving Serialise via WineryVariant RestrictionExpr+  deriving newtype NFData+  deriving newtype Hashable++data TableExpr =+  TableExpr { fromClause :: [TableRef],+              whereClause :: Maybe RestrictionExpr,+              groupByClause :: [GroupByExpr],+              havingClause :: Maybe HavingExpr,+              orderByClause :: [SortExpr],+              limitClause :: Maybe Integer,+              offsetClause :: Maybe Integer+                           }+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryRecord TableExpr+  deriving Hashable++emptyTableExpr :: TableExpr+emptyTableExpr = TableExpr { fromClause = [],+                             whereClause = Nothing,+                             groupByClause = [],+                             havingClause = Nothing,+                             orderByClause = [],+                             limitClause = Nothing,+                             offsetClause = Nothing }++makeBaseFunctor ''ScalarExprBase+

@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveGeneric, DerivingVia, DeriveAnyClass #-}+module ProjectM36.SQL.Update where+import ProjectM36.SQL.Select+import ProjectM36.Serialise.Base ()+import Control.DeepSeq+import Codec.Winery+import GHC.Generics++data Update = Update+  { target :: TableName,+--    targetAlias :: Maybe TableAlias,+    --SET+    setColumns :: [(UnqualifiedColumnName, ScalarExpr)], --we don't support multi-column SET yet+    mRestriction :: Maybe RestrictionExpr+  }+            --RETURNING not yet supported- how would we support this anyway- we must force the update to be materialized+  deriving (Show, Eq, Generic, NFData)+  deriving Serialise via WineryRecord Update+

@@ -0,0 +1,13 @@+-- | Enables SQL-equivalent features such as NULL types in the database in addition to Project:M36 basic functions.+module ProjectM36.SQLDatabaseContext where+import ProjectM36.Base+import ProjectM36.DatabaseContext+import ProjectM36.DataTypes.SQL.Null++sqlDatabaseContext :: DatabaseContext+sqlDatabaseContext = basicDatabaseContext { atomFunctions =+                                            atomFunctions basicDatabaseContext <> nullAtomFunctions,+                                            typeConstructorMapping =+                                            typeConstructorMapping basicDatabaseContext <> nullTypeConstructorMapping+                                            }+

@@ -13,3 +13,4 @@ deriving via WineryVariant PersistenceError instance Serialise PersistenceError deriving via WineryVariant SchemaError instance Serialise SchemaError deriving via WineryVariant ImportError' instance Serialise ImportError'+deriving via WineryVariant SQLError instance Serialise SQLError

@@ -111,7 +111,13 @@                         handleRetrieveDDLAsRelation ti sessionId conn),      RequestHandler (\sState (RetrieveRegisteredQueries sessionId) -> do                         conn <- getConn sState-                        handleRetrieveRegisteredQueries ti sessionId conn)+                        handleRetrieveRegisteredQueries ti sessionId conn),+     RequestHandler (\sState (ConvertSQLQuery sessionId q) -> do+                        conn <- getConn sState+                        handleConvertSQLQuery ti sessionId conn q),+     RequestHandler (\sState (ConvertSQLUpdates sessionId updates) -> do+                        conn <- getConn sState+                        handleConvertSQLUpdates ti sessionId conn updates)      ] ++ if testFlag then testModeHandlers ti else []  getConn :: ConnectionState ServerState -> IO Connection@@ -199,7 +205,7 @@     hPutStrLn stderr checkFSErrorMsg     pure False     else do-      econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))+      econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig) basicDatabaseContext)       case econn of          Left err -> do                 hPutStrLn stderr ("Failed to create database connection: " ++ show err)

@@ -3,6 +3,8 @@ import ProjectM36.Base hiding (inclusionDependencies) import ProjectM36.IsomorphicSchema import ProjectM36.HashSecurely+import ProjectM36.SQL.Select+import ProjectM36.SQL.DBUpdate import ProjectM36.Client as C import Data.Map import Control.Concurrent (threadDelay)@@ -157,3 +159,9 @@ handleRetrieveRegisteredQueries :: Maybe Timeout -> SessionId -> Connection -> IO (Either RelationalError Relation) handleRetrieveRegisteredQueries ti sessionId conn =   timeoutRelErr ti (C.registeredQueriesAsRelation sessionId conn)++handleConvertSQLQuery :: Maybe Timeout -> SessionId -> Connection -> Query -> IO (Either RelationalError DataFrameExpr)+handleConvertSQLQuery ti sessionId conn sel = timeoutRelErr ti (C.convertSQLQuery sessionId conn sel)++handleConvertSQLUpdates :: Maybe Timeout -> SessionId -> Connection -> [DBUpdate] -> IO (Either RelationalError DatabaseContextExpr)+handleConvertSQLUpdates ti sessionId conn ups = timeoutRelErr ti (C.convertSQLDBUpdates sessionId conn ups)

@@ -8,6 +8,8 @@ import ProjectM36.Session import ProjectM36.Serialise.DataFrame () import ProjectM36.Serialise.IsomorphicSchema ()+import ProjectM36.SQL.Select+import ProjectM36.SQL.DBUpdate import GHC.Generics import Codec.Winery @@ -110,3 +112,9 @@  data RetrieveRegisteredQueries = RetrieveRegisteredQueries SessionId   RPCData(RetrieveRegisteredQueries)++data ConvertSQLQuery = ConvertSQLQuery SessionId Query+  RPCData(ConvertSQLQuery)++data ConvertSQLUpdates = ConvertSQLUpdates SessionId [DBUpdate]+  RPCData(ConvertSQLUpdates)

@@ -118,8 +118,7 @@ rename :: RelationalExpr -> [(AttributeName,AttributeName)] -> RelationalExpr  rename relExpr renameList = case renameList of    [] -> Restrict TruePredicate relExpr-  renames -> -    foldl (\acc (old,new) -> Rename old new  acc) relExpr renames +  renames -> Rename (S.fromList renames) relExpr  --project !! -- #a !! [#b,#c]

@@ -19,6 +19,8 @@ import Data.Functor.Identity import qualified Data.Map as M import qualified Data.Set as S+import Data.Functor.Foldable as Fold+--import Debug.Trace  -- the static optimizer performs optimizations which need not take any specific-relation statistics into account @@ -44,13 +46,18 @@ -- | A temporary function to be replaced by IO-based implementation. optimizeAndEvalRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError Relation optimizeAndEvalRelationalExpr env expr = do-  let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr) -- references parent tid instead of context! options- I could add the context to the graph with a new transid or implement an evalRelationalExpr in RE.hs to use the context (which is what I had previously)-      graph = re_graph env+  let graph = re_graph env       ctx = re_context env       gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph-  optExpr <- runGraphRefSOptRelationalExprM (Just ctx) (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)+  optExpr <- optimizeRelationalExpr env expr   runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr) +optimizeRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError GraphRefRelationalExpr+optimizeRelationalExpr env expr = do+  let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr) -- references parent tid instead of context! options- I could add the context to the graph with a new transid or implement an evalRelationalExpr in RE.hs to use the context (which is what I had previously)+      ctx = re_context env+  runGraphRefSOptRelationalExprM (Just ctx) (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)+ class Monad m => AskGraphContext m where   askGraph :: m TransactionGraph   askContext :: m DatabaseContext@@ -181,6 +188,8 @@  optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e +optimizeGraphRefRelationalExpr e@(RelationValuedAttribute{}) = pure e+ optimizeGraphRefRelationalExpr e@(RelationVariable _ _) = pure e    --remove project of attributes which removes no attributes@@ -431,6 +440,7 @@ isStaticAtomExpr ConstructedAtomExpr{} = True isStaticAtomExpr AttributeAtomExpr{} = False isStaticAtomExpr FunctionAtomExpr{} = False+isStaticAtomExpr IfThenAtomExpr{} = False isStaticAtomExpr RelationAtomExpr{} = False  --if the projection of a join only uses the attributes from one of the expressions and there is a foreign key relationship between the expressions, we know that the join is inconsequential and can be removed@@ -498,6 +508,7 @@     MakeRelationFromExprs _ _ -> expr     MakeStaticRelation _ _ -> expr     ExistingRelation _ -> expr+    RelationValuedAttribute{} -> expr     RelationVariable _ _ -> expr     With _ _ -> expr     Project attrs subexpr -> @@ -506,8 +517,8 @@       Union (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2)         Join sub1 sub2 ->       Join (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2)-    Rename n1 n2 sub -> -      Rename n1 n2 (applyStaticRestrictionCollapse sub)+    Rename attrs sub -> +      Rename attrs (applyStaticRestrictionCollapse sub)     Difference sub1 sub2 ->        Difference (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2)     Group n1 n2 sub ->@@ -544,6 +555,7 @@   MakeRelationFromExprs _ _ -> expr   MakeStaticRelation _ _ -> expr   ExistingRelation _ -> expr+  RelationValuedAttribute{} -> expr   RelationVariable _ _ -> expr   With _ _ -> expr   Project _ _ -> expr@@ -561,8 +573,8 @@     Union (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2)   Join sub1 sub2 ->     Join (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2)-  Rename n1 n2 sub ->-    Rename n1 n2 (applyStaticRestrictionPushdown sub)+  Rename attrs sub ->+    Rename attrs (applyStaticRestrictionPushdown sub)   Difference sub1 sub2 ->      Difference (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2)   Group n1 n2 sub ->@@ -575,7 +587,29 @@     NotEquals (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2)   Extend n sub ->     Extend n (applyStaticRestrictionPushdown sub)-    ++-- if the rename is completely redundant because it renames an attribute name to the same attribute name, remove it+-- Rename [(x,x)] == Rename []+applyRedundantRenameCleanup :: GraphRefRelationalExpr -> GraphRefRelationalExpr+applyRedundantRenameCleanup = Fold.cata folder+  where+    folder (RenameF renameSet e) =+      if S.null renameSet then+        e+      else+        Rename (S.filter (uncurry (/=)) renameSet) e+    folder e = Fold.embed e++-- if the destination name in the rename is unused, we can remove it- does not detect errors if an a Rename is missing+-- Project ["x"] (Rename [("y","z"),("w","x")] (RelationVariable "rv" ())) == Project ["x"] (Rename [("w","x")] (RelationVariable "rv" ()))+{-+applyUnusedRenameCleanup :: Show a => RelationalExprBase a -> RelationalExprBase a+applyUnusedRenameCleanup expr = Fold.para folder expr+  where+    folder :: Show a => RelationalExprBaseF a (RelationalExprBase a, RelationalExprBase a) -> RelationalExprBase a+    folder (RenameF renameSet (expr', acc)) = traceShow ("para", expr', acc) (Rename renameSet expr')+    folder e = traceShow ("para2", Fold.embed $ fst <$> e) $ Fold.embed $ fst <$> e+-}     -- no optimizations available   optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr optimizeDatabaseContextIOExpr = pure

@@ -64,6 +64,7 @@       pure (MakeRelationFromExprs (Just attrExprs') tupleExprs') processTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet) processTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)+processTransGraphRelationalExpr (RelationValuedAttribute attrName) = pure (RelationValuedAttribute attrName) processTransGraphRelationalExpr (RelationVariable rvname transLookup) =    RelationVariable rvname <$> findTransId transLookup processTransGraphRelationalExpr (Project transAttrNames expr) = @@ -72,8 +73,8 @@   Union <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB processTransGraphRelationalExpr (Join exprA exprB) =   Join <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB-processTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =-  Rename attrName1 attrName2 <$> processTransGraphRelationalExpr expr+processTransGraphRelationalExpr (Rename attrs expr) =+  Rename attrs <$> processTransGraphRelationalExpr expr processTransGraphRelationalExpr (Difference exprA exprB) =   Difference <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB processTransGraphRelationalExpr (Group transAttrNames attrName expr) = @@ -126,6 +127,8 @@   FunctionAtomExpr funcName' <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup processTransGraphAtomExpr (RelationAtomExpr expr) =   RelationAtomExpr <$> processTransGraphRelationalExpr expr+processTransGraphAtomExpr (IfThenAtomExpr ifE thenE elseE) =+  IfThenAtomExpr <$> processTransGraphAtomExpr ifE <*> processTransGraphAtomExpr thenE <*> processTransGraphAtomExpr elseE processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =   ConstructedAtomExpr dConsName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr

@@ -13,6 +13,7 @@ import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.Attribute as A import ProjectM36.HashSecurely+import ProjectM36.ReferencedTransactionIds  import Codec.Winery import Control.Monad.Except hiding (join)@@ -373,7 +374,7 @@                   else                     pure trans   --- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal.+-- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal. The subgraph must also include any transactions which are referenced by other transactions. subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do   let currentid = transactionId currentTrans'@@ -398,8 +399,14 @@         Left err -> Left err         Right currentTransParent ->           subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans' traverseSet)-      else -- we found a path-      Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))+      else do -- we found a path+        -- we union all the relevant path transactions together, but we are missing any transactions which these transaction may reference. To make a valid transaction graph, we must include these referenced transactions.+        let openSet = S.unions (traverseSet : pathsFound)+            transactionIncluder acc trans = do+              allTrans <- referencedTransactionIdsForTransaction trans origGraph+              pure $ S.union allTrans acc+        closedTransactionSet <- foldM transactionIncluder mempty (S.toList openSet)+        Right (TransactionGraph resultHeads closedTransactionSet)   where     oneParent (Transaction _ tinfo _) = transactionForId (NE.head (parents tinfo)) origGraph     @@ -437,9 +444,14 @@   transB <- transactionForHeadErr headNameB   disconParent <- gfTransForId parentId   let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)+  -- is this an optimization???   subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty+  _ <- runE $ validateConnectivity subGraph+   subGraph' <- runE $ filterSubGraph subGraph subHeads-  mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB)+  -- we cannot cut the transaction graph away only to "relevant" transactions because transactions can reference other transactions via relvar expressions+  mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $+                 createMergeTransaction stamp' newId mergeStrategy (transA, transB)   case headNameForTransaction disconParent graph of         Nothing -> throwError (TransactionIsNotAHeadError parentId)         Just headName -> do@@ -452,18 +464,20 @@               pure (newDiscon, newGraph')    --TEMPORARY COPY/PASTE  -showTransactionStructureX :: Transaction -> TransactionGraph -> String-showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo+showTransactionStructureX :: Bool -> Transaction -> TransactionGraph -> String+showTransactionStructureX showRelVars trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo ++ relVarsInfo   where+    relVarsInfo | not showRelVars = ""+                | otherwise = "\n" <> concatMap show (M.toList (relationVariables (concreteDatabaseContext trans)))     headInfo = maybe "" show (headNameForTransaction trans graph)     parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of       Left err -> show err       Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet   -showGraphStructureX :: TransactionGraph -> String-showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet+showGraphStructureX :: Bool -> TransactionGraph -> String+showGraphStructureX showRelVars graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet   where-    folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"+    folder trans acc = acc ++ showTransactionStructureX showRelVars trans graph ++ "\n"     headsInfo = show $ M.map transactionId heads      -- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.@@ -625,3 +639,11 @@       case validateMerkleHash trans graph of         Left err -> err : acc         _ -> acc++-- | Ensure that referenced transactions remain in the graph.+validateConnectivity :: TransactionGraph -> Either RelationalError TransactionGraph+validateConnectivity graph = do+  let validateTrans trans =+        mapM_ (`transactionForId` graph) (referencedTransactionIds (concreteDatabaseContext trans))+  mapM_ validateTrans (transactionsForGraph graph)+  pure graph

@@ -26,14 +26,14 @@ unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr unionMergeRelation prefer relA relB = do   let unioned = Union relA relB-      mergeErr = MergeTransactionError StrategyViolatesRelationVariableMergeError+      mergeErr e = MergeTransactionError (StrategyViolatesRelationVariableMergeError e)       preferredRelVar =         case prefer of           PreferFirst -> pure relA           PreferSecond -> pure relB-          PreferNeither -> throwError mergeErr+          PreferNeither -> throwError (MergeTransactionError StrategyWithoutPreferredBranchResolutionMergeError)       handler AttributeNamesMismatchError{} = preferredRelVar-      handler _err' = throwError mergeErr+      handler err' = throwError (mergeErr err')   --typecheck first?   (evalGraphRefRelationalExpr unioned >> pure (Union relA relB)) `catchError` handler @@ -47,7 +47,7 @@                   lookupA = findRel relvarsA                   lookupB = findRel relvarsB               case (lookupA, lookupB) of-                (Just relA, Just relB) -> +                (Just relA, Just relB) -> do                   unionMergeRelation prefer relA relB                 (Nothing, Just relB) -> pure relB                  (Just relA, Nothing) -> pure relA 

@@ -1,17 +1,24 @@ module ProjectM36.WithNameExpr where import ProjectM36.Base+import Data.List (find)  -- substitute all instances of With-based macros to remove macro context -- ideally, we would use a different relational expr type to "prove" that the with macros can no longer exist-type WithNameAssocs = [(GraphRefWithNameExpr, GraphRefRelationalExpr)]++-- | +lookup :: RelVarName -> WithNamesAssocsBase a -> Maybe (RelationalExprBase a)+lookup matchrv assocs =+  snd <$> find (\(WithNameExpr rv _, _) -> rv == matchrv) assocs+ -- | Drop macros into the relational expression wherever they are referenced. substituteWithNameMacros ::-  WithNameAssocs ->+  GraphRefWithNameAssocs ->   GraphRefRelationalExpr ->   GraphRefRelationalExpr substituteWithNameMacros _ e@MakeRelationFromExprs{} = e substituteWithNameMacros _ e@MakeStaticRelation{} = e substituteWithNameMacros _ e@ExistingRelation{} = e+substituteWithNameMacros _ e@RelationValuedAttribute{} = e substituteWithNameMacros macros e@(RelationVariable rvname tid) =   let     macroFilt (WithNameExpr macroName macroTid, _) = rvname == macroName && tid== macroTid in@@ -20,13 +27,13 @@     [(_,replacement)] -> replacement     _ -> error "more than one macro matched!" substituteWithNameMacros macros (Project attrs expr) =-  Project attrs (substituteWithNameMacros macros expr)+  Project (substituteWithNameMacrosAttributeNames macros attrs) (substituteWithNameMacros macros expr) substituteWithNameMacros macros (Union exprA exprB) =   Union (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB) substituteWithNameMacros macros (Join exprA exprB) =   Join (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)-substituteWithNameMacros macros (Rename attrA attrB expr) =-  Rename attrA attrB (substituteWithNameMacros macros expr)+substituteWithNameMacros macros (Rename attrs expr) =+  Rename attrs (substituteWithNameMacros macros expr) substituteWithNameMacros macros (Difference exprA exprB) =   Difference (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB) substituteWithNameMacros macros (Group attrs attr expr) =@@ -51,7 +58,7 @@   substituteWithNameMacros newMacros expr  -substituteWithNameMacrosRestrictionPredicate :: WithNameAssocs -> GraphRefRestrictionPredicateExpr -> GraphRefRestrictionPredicateExpr+substituteWithNameMacrosRestrictionPredicate :: GraphRefWithNameAssocs -> GraphRefRestrictionPredicateExpr -> GraphRefRestrictionPredicateExpr substituteWithNameMacrosRestrictionPredicate macros pred' =   let sub = substituteWithNameMacrosRestrictionPredicate macros in   case pred' of@@ -69,11 +76,11 @@     AttributeEqualityPredicate attrName atomExpr ->       AttributeEqualityPredicate attrName (substituteWithNameMacrosAtomExpr macros atomExpr) -substituteWitNameMacrosExtendTupleExpr :: WithNameAssocs -> GraphRefExtendTupleExpr -> GraphRefExtendTupleExpr+substituteWitNameMacrosExtendTupleExpr :: GraphRefWithNameAssocs -> GraphRefExtendTupleExpr -> GraphRefExtendTupleExpr substituteWitNameMacrosExtendTupleExpr macros (AttributeExtendTupleExpr attrName atomExpr) =   AttributeExtendTupleExpr attrName (substituteWithNameMacrosAtomExpr macros atomExpr) -substituteWithNameMacrosAtomExpr :: WithNameAssocs -> GraphRefAtomExpr -> GraphRefAtomExpr+substituteWithNameMacrosAtomExpr :: GraphRefWithNameAssocs -> GraphRefAtomExpr -> GraphRefAtomExpr substituteWithNameMacrosAtomExpr macros atomExpr =   case atomExpr of     e@AttributeAtomExpr{} -> e@@ -82,5 +89,21 @@       FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid     RelationAtomExpr reExpr ->       RelationAtomExpr (substituteWithNameMacros macros reExpr)+    IfThenAtomExpr ifE thenE elseE ->+      IfThenAtomExpr (substituteWithNameMacrosAtomExpr macros ifE) (substituteWithNameMacrosAtomExpr macros thenE) (substituteWithNameMacrosAtomExpr macros elseE)     ConstructedAtomExpr dconsName atomExprs tid ->       ConstructedAtomExpr dconsName (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid++substituteWithNameMacrosAttributeNames :: GraphRefWithNameAssocs -> GraphRefAttributeNames -> GraphRefAttributeNames+substituteWithNameMacrosAttributeNames macros attrNames =+  case attrNames of+    AttributeNames{} -> attrNames+    InvertedAttributeNames{} -> attrNames+    UnionAttributeNames a b ->+      UnionAttributeNames (substituteWithNameMacrosAttributeNames macros a) (substituteWithNameMacrosAttributeNames macros b)+    IntersectAttributeNames a b ->+      IntersectAttributeNames (substituteWithNameMacrosAttributeNames macros a) (substituteWithNameMacrosAttributeNames macros b)+    RelationalExprAttributeNames relExpr ->+      RelationalExprAttributeNames (substituteWithNameMacros macros relExpr)++      

@@ -29,7 +29,7 @@ testSimpleCommitSuccess :: Test testSimpleCommitSuccess = TestCase $   withSystemTempDirectory "m36tempdb" $ \tempdir -> do-    let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback []+    let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback [] basicDatabaseContext         relExpr = Union (RelationVariable "x" ()) (RelationVariable "y" ())          dbconn <- assertEither (simpleConnectProjectM36 connInfo)@@ -52,7 +52,7 @@ testSimpleCommitFailure = TestCase $ do   let failAttrs = attributesFromList [Attribute "fail" IntAtomType]   err <- withSystemTempDirectory "m36tempdb" $ \tempdir -> do-    let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback []+    let connInfo = InProcessConnectionInfo (MinimalPersistence (tempdir </> "db")) emptyNotificationCallback [] basicDatabaseContext     dbconn <- assertEither (simpleConnectProjectM36 connInfo)     withTransaction dbconn $ do       execute $ Assign "x" (ExistingRelation relationTrue)@@ -64,7 +64,7 @@ -- #176 default merge couldn't handle Update   testSimpleUpdate :: Test testSimpleUpdate = TestCase $ do-  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext   dbconn <- assertEither (simpleConnectProjectM36 connInfo)   assertEither $ withTransaction dbconn $      execute $ databaseContextAsDatabaseContextExpr dateExamples

@@ -24,7 +24,7 @@ testMultipleProcessAccess :: Test testMultipleProcessAccess = TestCase $    withSystemTempDirectory "pm36" $ \tmpdir -> do-    let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []+    let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] basicDatabaseContext         master = "master"         dudExpr = Assign "x" (RelationVariable "true" ())         dbdir = tmpdir </> "db"

@@ -0,0 +1,514 @@+{-# LANGUAGE OverloadedStrings #-}+import SQL.Interpreter.Select+import ProjectM36.SQL.Convert+import ProjectM36.SQL.Select+import TutorialD.Interpreter.RODatabaseContextOperator+import TutorialD.Interpreter.DatabaseContextExpr+import ProjectM36.RelationalExpression+--import ProjectM36.StaticOptimizer+import SQL.Interpreter.DBUpdate+import SQL.Interpreter.CreateTable+import SQL.Interpreter.Base (semi)+import ProjectM36.DataTypes.SQL.Null+import ProjectM36.TransactionGraph+import ProjectM36.DateExamples+import ProjectM36.DatabaseContext+import ProjectM36.NormalizeExpr+import ProjectM36.Client hiding (typeConstructorMapping)+import ProjectM36.SQLDatabaseContext+import ProjectM36.Base+import ProjectM36.Relation+import qualified ProjectM36.Attribute as A+import System.Exit+import Test.HUnit+import Text.Megaparsec+import qualified Data.Text as T+import qualified Data.Map as M++main :: IO ()+main = do+  tcounts <- runTestTT (TestList tests)+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess+  where+    tests = [testFindColumn,+             testSelect,+             testCreateTable,+             testDBUpdate+            ]+++testFindColumn :: Test+testFindColumn = TestCase $ do+  let tctx = TableContext $ M.fromList [(TableAlias "s",+                                         (RelationVariable "s" (),+                                          attributesFromList [Attribute "city" TextAtomType, Attribute "status" IntegerAtomType],+                                          mempty+                                          )+                                        )]+  let findCol colName =+        case runConvertM tctx (findColumn colName) of+          Left err -> error (show err)+          Right val -> fst val+  assertEqual "findColumn city" [TableAlias "s"] (findCol (ColumnName ["city"]))+  assertEqual "findColumn s.city" [TableAlias "s"] (findCol (ColumnName ["s", "city"]))++testSelect :: Test+testSelect = TestCase $ do+  -- check that SQL and tutd compile to same thing+  let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples) }+  (tgraph,transId) <- freshTransactionGraph sqlDBContext+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  +  let readTests = [+        -- simple relvar+        ("SELECT * FROM s", "(s)", "(s)"),+        -- simple projection+        ("SELECT city FROM s", "(s{city})", "(s{city})"),+        -- restriction+        ("SELECT city FROM s where status=20",+         "((s where sql_coalesce_bool(sql_equals(@status,20))){city})",+         "((s where status=20){city})"         +        ),+        -- restriction + order by+        ("SELECT status FROM s where status=20 order by status",+         "((s where sql_coalesce_bool(sql_equals(@status,20))){status}) orderby {status}",+         "((s where status=20){status}) orderby {status}"+         ),+        -- restriction with asterisk and qualified name+        ("SELECT * FROM s WHERE \"s\".\"status\"=20",+         "(s where sql_coalesce_bool(sql_equals(@status,20)))",+         "(s where status=20)"),          +        -- join via where clause+        ("SELECT city FROM s, sp where \"s\".\"s#\" = \"sp\".\"s#\"",+         "((((s rename {s# as `s.s#`}) join sp) where sql_coalesce_bool(sql_equals(@`s.s#`, @s#))){city})",+         "(s{city} where city=\"London\" or city=\"Paris\")"+         ),+        -- restriction+        ("SELECT status,city FROM s where status>20",+         "((s where sql_coalesce_bool(sql_gt(@status,20))){status,city})",+         "((s where s#=\"S3\" or s#=\"S5\"){status,city})"),+        -- extension mixed with projection+        ("SELECT city,status,10 FROM s",+         "((s:{attr_3:=10}){city,status,attr_3})",+         "((s:{attr_3:=10}){city,status,attr_3})"         +         ),+        -- column alias+        ("SELECT city AS x FROM s",+         "((s rename {city as x}){x})",+         "((s rename {city as x}){x})"         +         ),+        -- case insensitivity+        ("sElECt CitY aS X FRoM s",+         "((s rename {city as x}){x})",+         "((s rename {city as x}){x})"         +        ),+        --column from aliased table+        ("SELECT sup.city FROM s AS sup",+         "(with (sup as s) ((sup rename {city as `sup.city`}){`sup.city`}))",+         "((s rename {city as `sup.city`}){`sup.city`})"),+        --projection with alias+        ("SELECT sup.city,sup.sname FROM s AS sup",+         "(with (sup as s) ((sup rename {city as `sup.city`,sname as `sup.sname`}){`sup.city`,`sup.sname`}))",+         "((s rename {city as `sup.city`, sname as `sup.sname`}){`sup.city`,`sup.sname`})"+         ),+        ("SELECT sup.* FROM s as sup",+         "(with (sup as s) (sup{all from sup}))",+         "(s)"+         ),+        -- natural join+        ("SELECT * FROM s NATURAL JOIN sp",+         "(s join sp)",+         "(s join sp)"),+        -- cross join+        ("SELECT * FROM s CROSS JOIN sp",+         "((s rename {s# as `s.s#`}) join sp)",+         "((s rename {s# as `s.s#`}) join sp)"),         +        -- unaliased join using+        ("SELECT * FROM sp INNER JOIN sp AS sp2 USING (\"s#\")",+         "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))",+         "(with (sp2 as sp) ((sp rename {p# as `sp.p#`, qty as `sp.qty`}) join (sp2 rename {p# as `sp2.p#`, qty as `sp2.qty`})))"),+        -- unaliased join+        ("SELECT * FROM sp JOIN s ON s.s# = sp.s#",+         "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})",+         "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s.s#`,@`sp.s#`))}) where join_1=True) {all but join_1})"         +         ),+        -- aliased join on+        ("SELECT * FROM sp AS sp2 JOIN s AS s2 ON s2.s# = sp2.s#",+         "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s2.s#`,@`sp2.s#`))}) where join_1=True) {all but join_1})",+         "(with (s2 as s, sp2 as sp) ((((s2 rename {s# as `s2.s#`,sname as `s2.sname`,city as `s2.city`,status as `s2.status`}) join (sp2 rename {s# as `sp2.s#`,p# as `sp2.p#`,qty as `sp2.qty`})):{join_1:=sql_coalesce_bool(sql_equals(@`s2.s#`,@`sp2.s#`))}) where join_1=True) {all but join_1})"),         +        -- formula extension+        ("SELECT status+10 FROM s",+         "((s : {attr_1:=sql_add(@status,10)}) { attr_1 })",+         "((s : {attr_1:=sql_add(@status,10)}) { attr_1 })"),+        -- extension and formula+        ("SELECT status+10,city FROM s",+         "((s : {attr_1:=sql_add(@status,10)}) {city,attr_1})",+         "((s : {attr_1:=sql_add(@status,10)}) {city,attr_1})"),+        -- complex join condition+        ("SELECT * FROM sp JOIN s ON s.s# = sp.s# AND s.s# = sp.s#",+         "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_and(sql_equals(@`s.s#`,@`sp.s#`),sql_equals(@`s.s#`,@`sp.s#`)))}) where join_1=True) {all but join_1})",+          "(((((s rename {s# as `s.s#`,sname as `s.sname`,city as `s.city`,status as `s.status`}) join (sp rename {s# as `sp.s#`,p# as `sp.p#`,qty as `sp.qty`})):{join_1:=sql_coalesce_bool(sql_and(sql_equals(@`s.s#`,@`sp.s#`),sql_equals(@`s.s#`,@`sp.s#`)))}) where join_1=True) {all but join_1})"),+        -- any, all, some+        -- IN()+        ("SELECT * FROM s WHERE s# IN ('S1','S2')",+         "(s where sql_coalesce_bool(sql_or(sql_equals(@s#,\"S1\"),sql_equals(@s#,\"S2\"))))",+         "(s where s#=\"S1\" or s#=\"S2\")"    +         ),+        -- NOT IN()+        ("SELECT * FROM s WHERE s# NOT IN ('S1','S2')",+         "(s where not sql_coalesce_bool(sql_or(sql_equals(@s#,\"S1\"),sql_equals(@s#,\"S2\"))))",+         "(s where not (eq(@s#,\"S1\") or eq(@s#,\"S2\")))"+         ),+        -- function application+        ("SELECT abs(-4)",+         "((relation{}{tuple{}}:{attr_1:=sql_abs(sql_negate(4))}){attr_1})",+         "(relation{tuple{attr_1 SQLJust 4}})"+         ),+        -- where not exists+        -- group by with max aggregate+        ("SELECT city,max(status) FROM s GROUP BY city",+         "((s group ({all but city} as `_sql_aggregate`) : {attr_2:=sql_max(@`_sql_aggregate`{status})}){city,attr_2})",+         "(relation{city Text, attr_2 SQLNullable Integer}{tuple{city \"London\", attr_2 SQLJust 20}, tuple{city \"Paris\", attr_2 SQLJust 30}, tuple{city \"Athens\", attr_2 SQLJust 30}})"+         ),+        -- group by with aggregate max column alias+        ("SELECT city,max(status) as status FROM s GROUP BY city",+         "((s group ({all but city} as `_sql_aggregate`) : {status:=sql_max(@`_sql_aggregate`{status})}){city,status})",+         "(relation{city Text, status SQLNullable Integer}{tuple{city \"London\", status SQLJust 20}, tuple{city \"Paris\", status SQLJust 30}, tuple{city \"Athens\", status SQLJust 30}})"),+        -- aggregate max without grouping+        ("SELECT max(status) as status FROM s",+         "(((s group ({all but } as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } )}){ status })",+         "(relation{status SQLNullable Integer}{tuple{status SQLJust 30}})"),+        -- group by having max+        ("select city,max(status) as status from s group by city having max(status)=30",+         "((((s group ({all but city} as `_sql_aggregate`)):{status:=sql_max( (@`_sql_aggregate`){ status } ), `_sql_having`:=sql_coalesce_bool( sql_equals( sql_max( (@`_sql_aggregate`){ status } ), 30 ) )}){ city, status }) where `_sql_having`=True)",+         "(relation{city Text,status SQLNullable Integer}{tuple{city \"Athens\",status SQLJust 30},tuple{city \"Paris\",status SQLJust 30}})"),+        -- count(*) aggregate+        ("select count(*) as c from s",+         "(((s group ({all but } as `_sql_aggregate`)):{c:=sql_count( @`_sql_aggregate` )}){ c })",+         "(relation{tuple{c 5}})"+        ),+        -- count(city) aggregate counts how many cities are not null+        ("select count(city) as c from s",+         "(((s group ({all but } as `_sql_aggregate`)):{c:=sql_count( ((@`_sql_aggregate`) where not( sql_isnull( @city ) )) )}){ c })",+         "(relation{tuple{c 5}})"+         ),+        -- case when+        ("SELECT city,case when city='London' then true else false end as islondon from s",+         "((s:{islondon:=if sql_coalesce_bool( sql_equals( @city, \"London\" ) ) then True else False}){ city, islondon })",+         "(relation{tuple{city \"London\", islondon True},tuple{city \"Paris\", islondon False},tuple{city \"Athens\", islondon False}})"+         ),+        -- union+        ("SELECT * FROM s union select * from s",+         "(s union s)",+         "(s)"+         ),+        -- intersect+        ("select city from s intersect select 'London' as city",+         "((s{ city }) join ((relation{  }{ tuple{  } }:{city:=\"London\"}){ city }))",+         "(relation{tuple{city \"London\"}})"+         ),+        -- except+        ("select city from s except select 'London' as city",+         "((s{city}) minus ((relation{}{tuple{}}:{city:=\"London\"}){city}))",+         "(relation{tuple{city \"Athens\"}, tuple{city \"Paris\"}})"+         ),+        -- limit        +        ("SELECT * FROM s LIMIT 10",+         "(s) limit 10",+         "(s) limit 10"         +         ),+        -- offset+        ("SELECT * FROM s OFFSET 10",+         "(s) offset 10",+         "(s) offset 10"         +         ),+        -- limit offset+        ("SELECT * FROM s LIMIT 10 OFFSET 20",+         "(s) limit 10 offset 20",+         "(s) limit 10 offset 20"+         ),+        -- order by+        ("SELECT * FROM s ORDER BY status",+         "(s) orderby {status}",+         "(s) orderby {status}"         +         ),+        -- order by descending+        ("SELECT * FROM s ORDER BY status DESC,city",+         "(s) orderby {status descending,city}",+         "(s) orderby {status descending,city}"         +        ),+        -- CTEs+        ("WITH x AS (SELECT * FROM s) SELECT * FROM x",+         "(with (x as s) x)",+         "(s)"+         ),+        -- SELECT with no table expression+        ("SELECT 1,2,3",+         "((relation{}{tuple{}}:{attr_1:=1,attr_2:=2,attr_3:=3}){attr_1,attr_2,attr_3})",+         "(relation{tuple{attr_1 1, attr_2 2, attr_3 3}})"+         ),+        -- where exists+        -- complication: we need to add attribute renamers due to the subselect+        ("SELECT * FROM s WHERE EXISTS (SELECT * FROM sp WHERE \"s\".\"s#\"=\"sp\".\"s#\")",+         "(s where (((sp rename {s# as `sp.s#`}) where sql_coalesce_bool(sql_equals(@`s#`, @`sp.s#`))){}))",+         "(s where not (s#=\"S5\"))"+         ),+        -- basic projection NULL+        ("SELECT NULL", -- convert to null of text type by default+         "((relation{}{tuple{}}:{attr_1:=SQLNullOfUnknownType}){attr_1})",+         "((true:{attr_1:=SQLNullOfUnknownType}){attr_1})"+         ),+        -- restriction NULL+        ("SELECT * FROM s WHERE s# IS NULL",+         "(s where sql_coalesce_bool(sql_isnull(@s#)))",+         "(s where false)"),+        ("SELECT * FROM snull WHERE city IS NULL",+         "(snull where sql_coalesce_bool(sql_isnull(@city)))",+         "(snull where s#=\"S2\")"),+        -- restriction IS NOT NULL+        ("SELECT city FROM s WHERE city IS NOT NULL",+         "(((s where not sql_coalesce_bool(sql_isnull(@city)))){city})",+         "(s{city})"+         ),+        -- some basic NULL logic+        ("SELECT NULL AND FALSE",+         "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNullOfUnknownType,False)}){attr_1})",+         "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust False}})"),+        ("SELECT NULL AND TRUE",+         "((relation{}{tuple{}}:{attr_1:=sql_and(SQLNullOfUnknownType,True)}){attr_1})",+         "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})"),+        ("SELECT NULL OR FALSE",+         "((relation{}{tuple{}}:{attr_1:=sql_or(SQLNullOfUnknownType,False)}){attr_1})",+         "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLNull}})"),+        ("SELECT NULL OR TRUE",+         "((relation{}{tuple{}}:{attr_1:=sql_or(SQLNullOfUnknownType,True)}){attr_1})",+         "(relation{attr_1 SQLNullable Bool}{tuple{attr_1 SQLJust True}})")+        ]+      gfEnv = GraphRefRelationalExprEnv {+        gre_context = Just sqlDBContext,+        gre_graph = tgraph,+        gre_extra = mempty }+      typeF expr = do+        let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr)+        runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)+      parseTutd tutd = do+        case parse (dataFrameP <* eof) "test" tutd of+          Left err -> assertFailure (errorBundlePretty err)+          Right x -> do+            pure x        +      check (sql, equivalent_tutd, confirmation_tutd) = do+        print sql+        --parse SQL+        query <- case parse (queryP <* eof) "test" sql of+          Left err -> assertFailure (errorBundlePretty err)+          Right x -> do+            --print ("parsed SQL:"::String, x)+            pure x+        --parse tutd+        tutdAsDFExpr <- parseTutd equivalent_tutd+        queryAsDFExpr <- case evalConvertM mempty (convertQuery typeF query) of+          Left err -> assertFailure (show err)+          Right x -> do+            --print ("convert SQL->tutd:"::String, x)+            pure x+        confirmationDFExpr <- parseTutd confirmation_tutd++        --print ("selectAsRelExpr"::String, queryAsRelExpr)+        --print ("expected: "::String, pretty tutdAsDFExpr)+        --print ("actual  : "::String, pretty queryAsDFExpr)+        assertEqual (T.unpack sql) tutdAsDFExpr queryAsDFExpr+        --check that the expression can actually be executed+        eEvald <- executeDataFrameExpr sess conn tutdAsDFExpr+        sqlResult <- case eEvald of+          Left err -> assertFailure (show err <> ": " <> show tutdAsDFExpr)+          Right rel -> pure rel+        eConfirmationEvald <- executeDataFrameExpr sess conn confirmationDFExpr+--        print ("confirmation"::String, confirmation_tutd)+        confirmationResult <- case eConfirmationEvald of+          Left err -> assertFailure (show err <> ": " <> show confirmationDFExpr)+          Right rel -> pure rel+        assertEqual "SQL result confirmation" confirmationResult sqlResult+  mapM_ check readTests++testCreateTable :: Test+testCreateTable = TestCase $ do+  let sqlDBContext = dateExamples { relationVariables = M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples) }+  (tgraph,transId) <- freshTransactionGraph sqlDBContext++  let createTableTests = [+        --no columns+        ("create table test()",+          "test :: {}"+        ),+        --simple column+        ("create table test(col1 integer)",+         "test :: {col1 SQLNullable Integer}"+         ),+        --not null+        ("create table test(col1 integer not null)",+         "test :: {col1 Integer}"+        ),+        ("create table test(col1 integer, \"col2\" text not null)",+         "test :: {col1 SQLNullable Integer, col2 Text}"+        ),+        -- foreign key "references"+        ("create table test(col1 integer, col2 integer references test2(pk))",+         "test :: {col1 SQLNullable Integer, col2 SQLNullable Integer}; foreign key test_col2__test2_pk_fk test{col2} in test2{pk}"),+        -- uniqueness constraint+        ("create table test(col1 integer unique)",+         "test :: {col1 SQLNullable Integer};  key test_col1_unique {col1} test where not(sql_isnull(@col1))"),+        -- primary key (equivalent to uniqueness constraint + not null)+        ("create table test(col1 integer primary key)",+         "test :: {col1 Integer}; key test_col1_key {col1} test")+        ]+      parseTutd tutd = do+        case parse (multipleDatabaseContextExprP <* eof) "test" tutd of+          Left err -> assertFailure (errorBundlePretty err)+          Right x -> do+            pure x+      gfEnv = GraphRefRelationalExprEnv {+        gre_context = Just sqlDBContext,+        gre_graph = tgraph,+        gre_extra = mempty }+      typeF expr = do+        let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr)+        runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)+            +      check (sql, equivalent_tutd) = do+        --parse SQL+        query <- case parse (createTableP <* eof) "test" sql of+          Left err -> assertFailure (errorBundlePretty err)+          Right x -> do+            --print ("parsed SQL:"::String, x)+            pure x+        --parse tutd+        tutdAsDFExpr <- parseTutd equivalent_tutd+        queryAsDFExpr <- case evalConvertM mempty (convertCreateTable typeF query) of+          Left err -> assertFailure (show err)+          Right x -> do+            --print ("convert SQL->tutd:"::String, x)+            pure x+        print sql+        assertEqual "create table SQL" tutdAsDFExpr queryAsDFExpr++  mapM_ check createTableTests++testDBUpdate :: Test+testDBUpdate = TestCase $ do+  let sqlDBContext = dateExamples { relationVariables =+                                      M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples),+                                    typeConstructorMapping = typeConstructorMapping dateExamples <> nullTypeConstructorMapping+                                  }+  (tgraph,transId) <- freshTransactionGraph sqlDBContext++  let updateTests = [+        -- simple insert with no nulls+        ("insert into s(city,status) values(\'New York\',15);",+         "insert s relation{tuple{attr_1 \"New York\", attr_2 15}} rename {attr_1 as city, attr_2 as status}"+        ),+        -- simple insert into nullable column with value+        ("insert into snull(\"s#\",sname,status,city) values ('S6','Smith',20,'New York');",+         "insert snull ((relation{tuple{attr_1 \"S6\", attr_2 \"Smith\", attr_3 20, attr_4 \"New York\"}} rename {attr_1 as s#, attr_2 as sname, attr_3 as status}) : {city:=SQLJust @attr_4}){all but attr_4}" +         ),+        -- simple insert into nullable column with NULL+        ("insert into snull(\"s#\",sname,status,city) values ('S6','Smith',20,NULL);",+         "insert snull ((relation{tuple{attr_1 \"S6\", attr_2 \"Smith\", attr_3 20, attr_4 SQLNullOfUnknownType}} rename {attr_1 as s#, attr_2 as sname, attr_3 as status}):{city:=SQLNull}){all but attr_4}" +         ),+        -- simple update+        ("update s set city='New York' where status=20;",+         "update s where sql_coalesce_bool(sql_equals(@status,20)) (city:=\"New York\")"+        ),+        --simple delete+        ("delete from s where city='New York';",+         "delete s where sql_coalesce_bool(sql_equals(@city,\"New York\"))"+         )+        ]++      parseTutd tutd = do+        case parse (multipleDatabaseContextExprP <* eof) "test" tutd of+          Left err -> assertFailure (errorBundlePretty err)+          Right x -> do+            pure x+      gfEnv = GraphRefRelationalExprEnv {+        gre_context = Just sqlDBContext,+        gre_graph = tgraph,+        gre_extra = mempty }+{-      typeF = +        let reEnv = mkRelationalExprEnv sqlDBContext tgraph in+          optimizeAndEvalRelationalExpr reEnv-}+      typeF expr = do+        let gfExpr = runProcessExprM (TransactionMarker transId) (processRelationalExpr expr)+        runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)+            +      check (sql, equivalent_tutd) = do+        --parse SQL+        query <- case parse (dbUpdateP <* semi <* eof) "test" sql of+          Left err -> assertFailure (errorBundlePretty err)+          Right x -> do+            --print ("parsed SQL:"::String, x)+            pure x+        --parse tutd+        tutdAsDFExpr <- parseTutd equivalent_tutd+        queryAsDFExpr <- case evalConvertM mempty (convertDBUpdate typeF query) of+          Left err -> assertFailure (show err)+          Right x -> do+            --print ("convert SQL->tutd:"::String, x)+            pure x+        print sql+        assertEqual "db update SQL" tutdAsDFExpr queryAsDFExpr++  mapM_ check updateTests++{-+testTransactionGraphOps :: Test+testTransactionGraphOps = TestCase $ do+  let sqlDBContext = dateExamples { relationVariables =+                                      M.insert "snull" (ExistingRelation sNullRelVar) (relationVariables dateExamples),+                                    typeConstructorMapping = typeConstructorMapping dateExamples <> nullTypeConstructorMapping+                                  }+  (tgraph,transId) <- freshTransactionGraph sqlDBContext++  let graphTests = [("begin;create table x(a integer not null);commit;",+                     "(x==relation{a integer})")+                   ]+-}+  +--  assertEqual "SELECT * FROM test"  (Right (Select {distinctness = Nothing, projectionClause = [(Identifier (QualifiedProjectionName [Asterisk]),Nothing)], tableExpr = Just (TableExpr {fromClause = [SimpleTableRef (QualifiedName ["test"])], whereClause = Nothing, groupByClause = [], havingClause = Nothing, orderByClause = [], limitClause = Nothing, offsetClause = Nothing})})) (p "SELECT * FROM test")+dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection)+dateExamplesConnection callback = do+  dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback [] sqlDatabaseContext)+  case dbconn of +    Left err -> error (show err)+    Right conn -> do+      eSessionId <- createSessionAtHead conn "master"+      case eSessionId of+        Left err -> error (show err)+        Right sessionId -> do+          executeDatabaseContextExpr sessionId conn (databaseContextAsDatabaseContextExpr dateExamples) >>= eitherFail+          --add a relvar with some nulls+          executeDatabaseContextExpr sessionId conn addNullTable >>= eitherFail+          commit sessionId conn >>= eitherFail+          pure (sessionId, conn)++eitherFail :: Either RelationalError a -> IO ()+eitherFail (Left err) = assertFailure (show err)+eitherFail (Right _) = pure ()++addNullTable :: DatabaseContextExpr+addNullTable = Assign "snull" (ExistingRelation sNullRelVar)++-- snull := relation{s# Text, sname Text, status Integer, city SQLNullable Text}{tuple{s# "S1", sname "Smith", status 20, city SQLNull}}+sNullRelVar :: Relation+sNullRelVar =+  case mkRelationFromList attrs atomMatrix of+      Left err -> error (show err)+      Right rel -> rel+  where+    attrs = A.attributesFromList [Attribute "s#" TextAtomType,+                                  Attribute "sname" TextAtomType,+                                  Attribute "status" IntegerAtomType,+                                  Attribute "city" (nullAtomType TextAtomType)]+    atomMatrix = [+      [TextAtom "S1", TextAtom "Smith", IntegerAtom 20, nullAtom TextAtomType (Just (TextAtom "London"))],+      [TextAtom "S2", TextAtom "Jones", IntegerAtom 10, nullAtom TextAtomType Nothing]+      ]