project-m36 0.9.4 → 0.9.5

raw patch · 48 files changed

+570/−266 lines, 48 filesdep +fast-builderdep +scientificdep +time-compatdep −hashable-timedep ~basedep ~curryer-rpcdep ~ghcPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: fast-builder, scientific, time-compat

Dependencies removed: hashable-time

Dependency ranges changed: base, curryer-rpc, ghc, winery

API changes (from Hackage documentation)

Files

• Changelog.markdown +9/−0
• README.markdown +2/−1
• examples/DerivingCustomTupleable.hs +0/−1
• examples/blog.hs +2/−2
• project-m36.cabal +31/−29
• src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +6/−0
• src/bin/ProjectM36/Server/WebSocket/websocket-server.hs +2/−2
• src/bin/TutorialD/Interpreter/RelationalExpr.hs +8/−13
• src/bin/TutorialD/Interpreter/Types.hs +2/−2
• src/bin/TutorialD/Printer.hs +4/−2
• src/lib/ProjectM36/Arbitrary.hs +4/−0
• src/lib/ProjectM36/Atom.hs +1/−0
• src/lib/ProjectM36/AtomFunction.hs +5/−1
• src/lib/ProjectM36/AtomFunctionError.hs +1/−0
• src/lib/ProjectM36/AtomFunctions/Primitive.hs +89/−20
• src/lib/ProjectM36/AtomType.hs +14/−12
• src/lib/ProjectM36/Atomable.hs +1/−0
• src/lib/ProjectM36/Base.hs +42/−25
• src/lib/ProjectM36/Client.hs +6/−8
• src/lib/ProjectM36/DataFrame.hs +2/−4
• src/lib/ProjectM36/DataTypes/ByteString.hs +5/−2
• src/lib/ProjectM36/DataTypes/DateTime.hs +6/−2
• src/lib/ProjectM36/DataTypes/Day.hs +10/−2
• src/lib/ProjectM36/DataTypes/Either.hs +4/−1
• src/lib/ProjectM36/DataTypes/Interval.hs +12/−4
• src/lib/ProjectM36/DataTypes/List.hs +9/−3
• src/lib/ProjectM36/DataTypes/Maybe.hs +8/−2
• src/lib/ProjectM36/DataTypes/NonEmptyList.hs +9/−3
• src/lib/ProjectM36/DataTypes/Primitive.hs +5/−2
• src/lib/ProjectM36/DataTypes/Sorting.hs +2/−0
• src/lib/ProjectM36/IsomorphicSchema.hs +27/−4
• src/lib/ProjectM36/Persist.hs +11/−9
• src/lib/ProjectM36/Relation/Parse/CSV.hs +1/−0
• src/lib/ProjectM36/RelationalExpression.hs +16/−1
• src/lib/ProjectM36/ScriptSession.hs +77/−67
• src/lib/ProjectM36/Serialise/Base.hs +7/−1
• src/lib/ProjectM36/StaticOptimizer.hs +4/−1
• src/lib/ProjectM36/Trace.hs +10/−0
• src/lib/ProjectM36/Transaction/Persist.hs +14/−10
• src/lib/ProjectM36/TransactionGraph.hs +1/−3
• src/lib/ProjectM36/TransactionGraph/Merge.hs +2/−1
• src/lib/ProjectM36/TransactionGraph/Persist.hs +17/−5
• test/IsomorphicSchema.hs +17/−3
• test/Relation/Basic.hs +28/−1
• test/Server/Main.hs +2/−1
• test/Server/WebSocket.hs +2/−1
• test/TutorialD/InterpreterTest.hs +32/−14
• test/TutorialD/PrinterTest.hs +1/−1

@@ -1,3 +1,12 @@+# 2022-08-19 (v0.9.5)+  +* removed necessity for caret "^" when using boolean atom expressions in restriction predicates+* `True` and `False` are now value constructors for `Bool` atom values (previously `t` and `f); changed for better discoverability by Haskell developers+* add `Scientific` data type for arbitrary-precision values (backed by Data.Scientific)+* add support for GHC 9.0 and GHC 9.2+* drop support for GHC < 8.10.7+* fix relational equality when the relation includes a nested relation+	 # 2021-12-05 (v0.9.4)  * fix bug which [caused tuple storage to be duplicated unnecessarily](https://github.com/agentm/project-m36/pull/328)

@@ -61,6 +61,7 @@ 1. [Developer's Change Log](Changelog.markdown) 1. [Simple Client API](docs/simple_api.markdown) 1. [CSV Import/Export](docs/import_export_csv.markdown)+1. [Developer Setup](docs/dev_setup.markdown)  ### Database Comparisons @@ -94,7 +95,7 @@  ## Development -Project:M36 is developed in Haskell and compiled with GHC 8.6 or later.+Project:M36 is developed in Haskell and compiled with GHC 8.8 or later.  ## Related Projects 

@@ -4,7 +4,6 @@ import ProjectM36.Atomable (Atomable) import Control.DeepSeq (NFData) import Data.Text (Text)-import GHC.Generics (Generic) import Codec.Winery  newtype BlogId = BlogId { getBlogId :: Int }

@@ -29,7 +29,7 @@ import Text.Blaze.Html.Renderer.Text import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status-import Data.Time.Format+import Data.Time.Format.ISO8601  --define your data types data Blog = Blog {@@ -166,7 +166,7 @@                                                           blogRestrictionExpr                                                            (RelationVariable "blog" ())))   let render = html . renderHtml-      formatStamp = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))+      formatStamp = iso8601Show --formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))   case eRel of      Left err -> render500 (toHtml (show err))     --handle successful query execution

@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36-Version: 0.9.4+Version: 0.9.5 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@@ -35,9 +35,9 @@      Default: True  Library-    Build-Depends: base>=4.8 && < 4.15, 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, hashable-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, curryer-rpc, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible+    Build-Depends: base>=4.8 && < 4.17, 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.2.2, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible, fast-builder, scientific, time-compat >= 1.9.6.1     if flag(haskell-scripting)-        Build-Depends: ghc >= 8.2 && < 8.11+        Build-Depends: ghc >= 8.2 && < 9.3         CPP-Options: -DPM36_HASKELL_SCRIPTING     if impl(ghc>= 8) && flag(haskell-scripting)       build-depends:@@ -130,27 +130,28 @@                      ProjectM36.GraphRefRelationalExpr,                      ProjectM36.NormalizeExpr,                      ProjectM36.TransactionInfo,-                     ProjectM36.WithNameExpr+                     ProjectM36.WithNameExpr, +                     ProjectM36.Trace     GHC-Options: -Wall -rdynamic     if os(windows)       Build-Depends: Win32 >= 2.5.4.1       Other-Modules: ProjectM36.Win32Handle     else       --219-  too many exported symbols under Windows and GHC 8.4-      GHC-Options: -rdynamic -fexternal-interpreter+      GHC-Options: -rdynamic -fexternal-interpreter -eventlog       C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c       Build-Depends: unix     CC-Options: -fPIC     Hs-Source-Dirs: ./src/lib     Default-Language: Haskell2010-    Default-Extensions: OverloadedStrings, CPP+    Default-Extensions: OverloadedStrings, CPP, LambdaCase     if !flag(stack)-      Build-Depends: deferred-folds+      Build-Depends: deferred-folds   Executable tutd     if flag(haskell-scripting)-        Build-Depends: ghc >= 8.2 && < 8.11-    Build-Depends: base >=4.8 && <5.0,+        Build-Depends: ghc >= 8.2 && < 9.3+    Build-Depends: base >=4.8,                    ghc-paths,                    project-m36,                    containers,@@ -165,7 +166,6 @@                    vector,                    text,                    time,-                   hashable-time,                    bytestring,                    stm,                    deepseq,@@ -210,21 +210,23 @@                    TutorialD.Interpreter.Types,                    TutorialD.Interpreter.SchemaOperator,                    TutorialD.Interpreter.TransGraphRelationalOperator,-                   TutorialD.Interpreter.SchemaOperator+                   TutorialD.Interpreter.SchemaOperator,                    TutorialD.Printer     main-is: TutorialD/tutd.hs     CC-Options: -fPIC     if os(windows)-      GHC-Options: -Wall -threaded+      GHC-Options: -Wall -threaded -eventlog -rtsopts     else-      GHC-Options: -Wall -threaded -rdynamic+      GHC-Options: -Wall -threaded -rdynamic -eventlog -rtsopts+    if flag(profiler)+      GHC-Prof-Options: -fprof-auto -rtsopts -threaded     Hs-Source-Dirs: ./src/bin     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings  Executable project-m36-server     if flag(haskell-scripting)-        Build-Depends: ghc >= 8.2 && < 8.11+        Build-Depends: ghc >= 8.2 && < 9.3     Build-Depends: base,                    ghc-paths,                    transformers,@@ -239,7 +241,6 @@                    parallel,                    bytestring,                    optparse-applicative,-                   hashable-time,                    time,                    text,                    deepseq-generics,@@ -251,12 +252,13 @@                    http-api-data,                    stm-containers,                    list-t,-                   base64-bytestring+                   base64-bytestring,+                   scientific     Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs     if os(windows)       GHC-Options: -Wall -threaded -rtsopts     else-      GHC-Options: -Wall -threaded -rtsopts -rdynamic      +      GHC-Options: -Wall -threaded -rtsopts -rdynamic     if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall     Default-Language: Haskell2010@@ -265,7 +267,7 @@ Executable bigrel     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators+    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, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators     Other-Modules: TutorialD.Interpreter.Base,                    TutorialD.Interpreter.DatabaseContextExpr,                    TutorialD.Interpreter.RelationalExpr,@@ -274,11 +276,11 @@     GHC-Options: -Wall -threaded -rtsopts     HS-Source-Dirs: ./src/bin     if flag(profiler)-      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall+      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall -eventlog  Common commontest     Default-Language: Haskell2010-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring,cryptohash-sha256+    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, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256, scientific     Default-Extensions: OverloadedStrings     GHC-Options: -Wall -threaded     Hs-Source-Dirs: test, src/bin@@ -311,7 +313,7 @@     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-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-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+    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@@ -383,28 +385,28 @@ Executable Example-SimpleClient     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-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, ghc, ghc-paths, project-m36, random, MonadRandom+    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, ghc, ghc-paths, project-m36, random, MonadRandom     Main-Is: examples/SimpleClient.hs     GHC-Options: -Wall -threaded  Executable Example-OutOfTheTarpit     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-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, 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, winery     Main-Is: examples/out_of_the_tarpit.hs     GHC-Options: -Wall -threaded  Executable Example-Blog     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-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, blaze-html, http-types, winery     Main-Is: examples/blog.hs     GHC-Options: -Wall -threaded  Executable Example-Hair     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-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, 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, winery     Main-Is: examples/hair.hs     GHC-Options: -Wall -threaded @@ -418,7 +420,7 @@ Executable Example-CustomTupleable     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-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, 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, winery     Main-Is: examples/CustomTupleable.hs     GHC-Options: -Wall -threaded @@ -440,7 +442,7 @@  Executable project-m36-websocket-server     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+    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     GHC-Options: -Wall -threaded@@ -489,7 +491,7 @@ Executable handles     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256+    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, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256     main-is: benchmark/Handles.hs     Other-Modules: TutorialD.Interpreter,       TutorialD.Interpreter.Base,@@ -507,7 +509,7 @@       TutorialD.Interpreter.SchemaOperator,       TutorialD.Interpreter.TransGraphRelationalOperator,       TutorialD.Interpreter.TransactionGraphOperator,-      TutorialD.Interpreter.Types+      TutorialD.Interpreter.Types,       TutorialD.Printer     GHC-Options: -Wall -threaded -rtsopts     HS-Source-Dirs: ./src/bin

@@ -18,6 +18,7 @@ import Data.Text.Encoding import Data.Time.Calendar import Data.UUID+import Data.Scientific  instance ToJSON RelationalExpr instance FromJSON RelationalExpr@@ -92,6 +93,8 @@                                      "val" .= i ]   toJSON atom@(DoubleAtom i) = object [ "type" .= atomTypeForAtom atom,                                         "val" .= i ]+  toJSON atom@(ScientificAtom i) = object [ "type" .= atomTypeForAtom atom,+                                        "val" .= (coefficient i, base10Exponent i) ]   toJSON atom@(TextAtom i) = object [ "type" .= atomTypeForAtom atom,                                       "val" .= i ]   toJSON atom@(DayAtom i) = object [ "type" .= atomTypeForAtom atom,@@ -123,6 +126,9 @@       RelationAtomType _ -> RelationAtom <$> o .: "val"       IntAtomType -> IntAtom <$> o .: "val"       IntegerAtomType -> IntegerAtom <$> o .: "val"+      ScientificAtomType -> do+        (c,e) <- o .: "val"+        pure (ScientificAtom (scientific c e))       DoubleAtomType -> DoubleAtom <$> o .: "val"       TextAtomType -> TextAtom <$> o .: "val"       DayAtomType -> do

@@ -2,7 +2,7 @@  import Control.Concurrent import Control.Exception-import Control.Monad (when)+import Control.Monad (when, void) import Data.Maybe (isJust) import Data.String (fromString) import Network.HTTP.Types (status400)@@ -35,7 +35,7 @@   when (isJust configCertificateFile /= isJust configKeyFile) $     throwIO $ ErrorCall "TLS_CERTIFICATE_PATH and TLS_KEY_PATH must be set in tandem" -  _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)+  _ <- forkFinally (void (launchServer serverConfig' (Just addressMVar))) (either throwIO pure)   --wait for server to be listening   addr <- takeMVar addressMVar   let port =

@@ -150,16 +150,13 @@ relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators -relVarNameP :: Parser RelVarName-relVarNameP = try uncapitalizedIdentifier <|> quotedIdentifier- relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relVarP = RelationVariable <$> relVarNameP <*> parseMarkerP  relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relTerm = parens relExprP           <|> makeRelationP-          <|> relVarP+          <|> (relVarP <* notFollowedBy "(")  restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) restrictionPredicateP = makeExprParser predicateTerm predicateOperators@@ -170,14 +167,14 @@       [InfixL (reservedOp "or" >> return OrPredicate)]       ]     predicateTerm = try (parens restrictionPredicateP)-                    <|> try restrictionAtomExprP                     <|> try restrictionAttributeEqualityP-                    <|> relationalBooleanExprP+                    <|> try relationalBooleanExprP+                    <|> restrictionAtomExprP                                         + relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)-relationalBooleanExprP =+relationalBooleanExprP = RelationalExprPredicate <$> (parens relExprP <|> relTerm)   --we can't actually detect if the type is relational boolean, so we just pass it to the next phase-  RelationalExprPredicate <$> (parens relExprP <|> relTerm)  restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) restrictionAttributeEqualityP = do@@ -185,10 +182,8 @@   reservedOp "="   AttributeEqualityPredicate attributeName <$> atomExprP -restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"-restrictionAtomExprP = do-  _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar-  (try (char 't') >> pure TruePredicate) <|> (try (char 'f') >> pure (NotPredicate TruePredicate)) <|> AtomExprPredicate <$> atomExprP+restrictionAtomExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"+restrictionAtomExprP = AtomExprPredicate <$> consumeAtomExprP False  multiTupleExpressionP :: RelationalMarkerExpr a => Parser [ExtendTupleExprBase a] multiTupleExpressionP = sepBy extendTupleExpressionP comma@@ -254,7 +249,7 @@ boolAtomP :: Parser Atom boolAtomP = do   v <- identifier-  if v == "t" || v == "f" then+  if v == "True" || v == "False" then     pure $ BoolAtom (v == "t")         else     fail "invalid boolAtom"

@@ -69,5 +69,5 @@                        TypeVariable <$> typeVariableIdentifierP                     --+relVarNameP :: Parser RelVarName+relVarNameP = try uncapitalizedIdentifier <|> quotedIdentifier

@@ -19,6 +19,7 @@ instance Pretty Atom where   pretty (IntegerAtom x) = pretty x   pretty (IntAtom x) = "int" <> parensList [pretty x]+  pretty (ScientificAtom s) = "scientific" <> parensList [dquotes (pretty (show s))]   pretty (DoubleAtom x) = pretty x   pretty (TextAtom x) = dquotes (pretty x)   pretty (DayAtom x) = "fromGregorian" <> parensList [pretty a, pretty b, pretty c]@@ -26,7 +27,7 @@       (a,b,c) = toGregorian x   pretty (DateTimeAtom time) = "dateTimeFromEpochSeconds" <> parensList [pretty @Integer (round (utcTimeToPOSIXSeconds time))]   pretty (ByteStringAtom bs) = "bytestring" <> parensList [dquotes (pretty (TE.decodeUtf8 (B64.encode bs)))]-  pretty (BoolAtom x) = if x then "t" else "f"+  pretty (BoolAtom x) = if x then "True" else "False"   pretty (UUIDAtom u) = pretty u   pretty (RelationAtom x) = pretty x   pretty (RelationalExprAtom re) = pretty re@@ -70,7 +71,7 @@   pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet)  instance Pretty Attribute where-  pretty (Attribute n aTy) = pretty n <+> pretty (show aTy)  -- workaround+  pretty (Attribute n aTy) = pretty n <+> pretty aTy  instance Pretty RelationalExpr where   pretty (RelationVariable n _) = pretty n@@ -129,6 +130,7 @@ instance Pretty AtomType where   pretty IntAtomType = "Int"   pretty IntegerAtomType = "Integer"+  pretty ScientificAtomType = "Scientific"   pretty DoubleAtomType = "Double"   pretty TextAtomType = "Text"   pretty DayAtomType = "Day"

@@ -18,10 +18,14 @@ import Data.Time import Control.Monad.Reader import Data.UUID+import Data.Scientific  arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom) arbitrary' IntegerAtomType =    Right . IntegerAtom <$> lift (arbitrary :: Gen Integer)++arbitrary' ScientificAtomType =+  Right . ScientificAtom <$> lift (arbitrary :: Gen Scientific)  arbitrary' (RelationAtomType attrs)  = do   tcMap <-ask

@@ -14,6 +14,7 @@ atomToText :: Atom -> T.Text atomToText (IntegerAtom i) = (T.pack . show) i atomToText (IntAtom i) = (T.pack . show) i+atomToText (ScientificAtom s) = (T.pack . show) s atomToText (DoubleAtom i) = (T.pack . show) i atomToText (TextAtom i) = (T.pack . show) i --quotes necessary for ConstructedAtom subatoms atomToText (DayAtom i) = (T.pack . show) i

@@ -29,7 +29,11 @@ emptyAtomFunction :: FunctionName -> AtomFunction emptyAtomFunction name = Function { funcName = name,                                     funcType = [TypeVariableType "a", TypeVariableType "a"],-                                    funcBody = FunctionBuiltInBody (\(x:_) -> pure x) }+                                    funcBody = FunctionBuiltInBody $+                                               \case+                                                 x:_ -> pure x+                                                 _ -> Left AtomFunctionTypeMismatchError+                                  }                                                                                       -- | AtomFunction constructor for compiled-in functions.

@@ -6,6 +6,7 @@  data AtomFunctionError = AtomFunctionUserError String |                          AtomFunctionTypeMismatchError |+                         AtomFunctionParseError String |                          InvalidIntervalOrderingError |                          InvalidIntervalBoundariesError |                          InvalidIntBoundError |

@@ -9,28 +9,45 @@ import Control.Monad import qualified Data.UUID as U import qualified Data.Text as T+import qualified Data.Attoparsec.Text as APT+import Data.Scientific  primitiveAtomFunctions :: AtomFunctions primitiveAtomFunctions = HS.fromList [   --match on any relation type   Function { funcName = "add",              funcType = [IntegerAtomType, IntegerAtomType, IntegerAtomType],-             funcBody = body (\(IntegerAtom i1:IntegerAtom i2:_) -> pure (IntegerAtom (i1 + i2)))},+             funcBody = body (\case+                                 IntegerAtom i1:IntegerAtom i2:_ -> pure (IntegerAtom (i1 + i2))+                                 _ -> Left AtomFunctionTypeMismatchError)},     Function { funcName = "id",                funcType = [TypeVariableType "a", TypeVariableType "a"],-               funcBody = body (\(x:_) -> pure x)},+               funcBody = body (\case+                                   x:_ -> pure x+                                   _ -> Left AtomFunctionTypeMismatchError+                               )},     Function { funcName = "sum",                funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,-               funcBody = body (\(RelationAtom rel:_) -> relationSum rel)},+               funcBody = body $ relationAtomFunc relationSum+             },     Function { funcName = "count",                funcType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType,-               funcBody = body (\(RelationAtom relIn:_) -> relationCount relIn)},+               funcBody = body $ relationAtomFunc relationCount+             },     Function { funcName = "max",                funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,-               funcBody = body (\(RelationAtom relIn:_) -> relationMax relIn)},+               funcBody = body $ relationAtomFunc relationMax +             },     Function { funcName = "min",                funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,-               funcBody = body (\(RelationAtom relIn:_) -> relationMin relIn)},+               funcBody = body $ relationAtomFunc relationMin+             },+    Function { funcName = "eq",+               funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+               funcBody = body $ \case+                                         [i1,i2] -> pure (BoolAtom (i1 == i2))+                                         _ -> Left AtomFunctionTypeMismatchError+             },     Function { funcName = "lt",                funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],                funcBody = body $ integerAtomFuncLessThan False},@@ -45,31 +62,42 @@                funcBody = body $ integerAtomFuncLessThan True >=> boolAtomNot},     Function { funcName = "not",                funcType = [BoolAtomType, BoolAtomType],-               funcBody = body $ \(b:_) -> boolAtomNot b },+               funcBody = body $ \case+                                         [b] -> boolAtomNot b+                                         _ -> Left AtomFunctionTypeMismatchError+             },     Function { funcName = "int",                funcType = [IntegerAtomType, IntAtomType],                funcBody =-                 body $ \(IntegerAtom v:_) ->-                          if v < fromIntegral (maxBound :: Int) then-                            -                            pure (IntAtom (fromIntegral v))-                          else-                            Left InvalidIntBoundError+                 body $ \case+                                [IntegerAtom v] ->+                                  if v < fromIntegral (maxBound :: Int) then+                                    pure (IntAtom (fromIntegral v))+                                  else+                                    Left InvalidIntBoundError+                                _ -> Left AtomFunctionTypeMismatchError              },     Function { funcName = "integer",                funcType = [IntAtomType, IntegerAtomType],-               funcBody = body $ \(IntAtom v:_) -> Right $ IntegerAtom $ fromIntegral v},+               funcBody = body $ \case+                 [IntAtom v] -> Right $ IntegerAtom $ fromIntegral v+                 _ -> Left AtomFunctionTypeMismatchError+             },     Function { funcName = "uuid",                funcType = [TextAtomType, UUIDAtomType],-               funcBody = body $ \(TextAtom v:_) ->-                 let mUUID = U.fromString (T.unpack v) in-                   case mUUID of-                     Just u -> pure $ UUIDAtom u-                     Nothing -> Left $ InvalidUUIDString v+               funcBody = body $ \case+                 [TextAtom v] ->+                   let mUUID = U.fromString (T.unpack v) in+                     case mUUID of+                       Just u -> pure $ UUIDAtom u+                       Nothing -> Left $ InvalidUUIDString v+                 _ -> Left AtomFunctionTypeMismatchError              }-  ]+  ] <> scientificAtomFunctions   where     body = FunctionBuiltInBody+    relationAtomFunc f [RelationAtom x] = f x+    relationAtomFunc _ _ = Left AtomFunctionTypeMismatchError                           integerAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom integerAtomFuncLessThan equality (IntegerAtom i1:IntegerAtom i2:_) = pure (BoolAtom (i1 `op` i2))@@ -112,3 +140,44 @@ castInteger :: Atom -> Integer castInteger (IntegerAtom i) = i  castInteger _ = error "attempted to cast non-IntegerAtom to Int"+++scientificAtomFunctions :: AtomFunctions+scientificAtomFunctions = HS.fromList [+  Function { funcName = "read_scientific",+             funcType = [TextAtomType, ScientificAtomType],+             funcBody = body $ \case+               TextAtom t:_ ->+                 case APT.parseOnly (APT.scientific <* APT.endOfInput) t of+                   Left err -> Left (AtomFunctionParseError err)+                   Right sci -> pure (ScientificAtom sci)+               _ -> Left AtomFunctionTypeMismatchError+           },+  Function { funcName = "scientific",+             funcType = [IntegerAtomType, IntAtomType, ScientificAtomType],+             funcBody = body $ \case+               [IntegerAtom c,IntAtom e] -> pure (ScientificAtom $ scientific c e)+               _ -> Left AtomFunctionTypeMismatchError+           },+  Function { funcName = "scientific_add",+             funcType = binaryFuncType,+             funcBody = binaryFuncBody (+)+           },+  Function { funcName = "scientific_subtract",+             funcType = binaryFuncType,+             funcBody = binaryFuncBody (-)+           },+  Function { funcName = "scientific_multiply",+             funcType = binaryFuncType,+             funcBody = binaryFuncBody (*)+           },+  Function { funcName = "scientific_divide",+             funcType = binaryFuncType,+             funcBody = binaryFuncBody (/)+           }+  ]+  where body = FunctionBuiltInBody+        binaryFuncType = [ScientificAtomType, ScientificAtomType, ScientificAtomType]+        binaryFuncBody op = body $ \case+          [ScientificAtom s1, ScientificAtom s2] -> pure (ScientificAtom (s1 `op` s2))+          _ -> Left AtomFunctionTypeMismatchError

@@ -204,10 +204,11 @@  --reconcile the atom-in types with the type constructors isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Either RelationalError ()-isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Left (AtomTypeMismatchError expectedAType aType) else pure ()+isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ =+  when (expectedAType /= aType) $ Left (AtomTypeMismatchError expectedAType aType)  --lookup constructor name and check if the incoming atom types are valid-isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ =  if tConsName /= expectedTConsName then Left (TypeConstructorNameMismatch expectedTConsName tConsName) else pure ()+isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ =  when (tConsName /= expectedTConsName) $ Left (TypeConstructorNameMismatch expectedTConsName tConsName)  isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) tConsMap = do   evaldAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap M.empty) attrExprs@@ -320,10 +321,7 @@  validateAttributes :: TypeConstructorMapping -> Attributes -> Either RelationalError () validateAttributes tConss attrs =-  if not (null errs) then-    Left (someErrors errs)-  else-    pure ()+  unless (null errs) $ Left (someErrors errs)   where     errs = lefts $ map (`validateAtomType` tConss) (A.atomTypesList attrs) @@ -410,12 +408,15 @@ resolveTypeVariable _ _ = M.empty  resolveFunctionReturnValue :: FunctionName -> TypeVarMap -> AtomType -> Either RelationalError AtomType-resolveFunctionReturnValue funcName' tvMap (ConstructedAtomType tCons retMap) = do-  let diff = M.difference retMap tvMap-  if M.null diff then-    pure (ConstructedAtomType tCons (M.intersection tvMap retMap))-    else-    Left (AtomFunctionTypeVariableResolutionError funcName' (fst (head (M.toList diff))))+resolveFunctionReturnValue funcName' tvMap ctype@(ConstructedAtomType tCons retMap) =+  if isResolvedType ctype then+    pure ctype+    else do+    let diff = M.difference retMap tvMap+    if M.null diff then+      pure (ConstructedAtomType tCons (M.intersection tvMap retMap))+      else+      Left (AtomFunctionTypeVariableResolutionError funcName' (fst (head (M.toList diff)))) resolveFunctionReturnValue funcName' tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of   Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName' tvName)   Just typ -> pure typ@@ -436,6 +437,7 @@   case typ of     IntAtomType -> True     IntegerAtomType -> True+    ScientificAtomType -> True     DoubleAtomType -> True     TextAtomType -> True     DayAtomType -> True

@@ -241,6 +241,7 @@ typeToTypeConstructor :: AtomType -> TypeConstructor typeToTypeConstructor x@IntAtomType = PrimitiveTypeConstructor "Int" x typeToTypeConstructor x@IntegerAtomType = PrimitiveTypeConstructor "Integer" x+typeToTypeConstructor x@ScientificAtomType = PrimitiveTypeConstructor "Scientific" x typeToTypeConstructor x@DoubleAtomType = PrimitiveTypeConstructor "Double" x typeToTypeConstructor x@TextAtomType = PrimitiveTypeConstructor "Text" x typeToTypeConstructor x@DayAtomType = PrimitiveTypeConstructor "Day" x

@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module ProjectM36.Base where@@ -20,12 +20,13 @@ import qualified Data.List as L import Data.Text (Text) import Data.Time.Clock-import Data.Hashable.Time ()+import Data.Time.Clock.Compat () import Data.Time.Calendar (Day) import Data.Typeable import Data.ByteString (ByteString) import qualified Data.List.NonEmpty as NE import Data.Vector.Instances ()+import Data.Scientific  type StringType = Text @@ -44,25 +45,27 @@ #endif  -- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.-data Atom = IntegerAtom Integer |-            IntAtom Int |-            DoubleAtom Double |-            TextAtom Text |-            DayAtom Day |-            DateTimeAtom UTCTime |-            ByteStringAtom ByteString |-            BoolAtom Bool |-            UUIDAtom UUID |-            RelationAtom Relation |-            RelationalExprAtom RelationalExpr | --used for returning inc deps-            ConstructedAtom DataConstructorName AtomType [Atom]+data Atom = IntegerAtom !Integer |+            IntAtom !Int |+            ScientificAtom !Scientific |+            DoubleAtom !Double |+            TextAtom !Text |+            DayAtom !Day |+            DateTimeAtom !UTCTime |+            ByteStringAtom !ByteString |+            BoolAtom !Bool |+            UUIDAtom !UUID |+            RelationAtom !Relation |+            RelationalExprAtom !RelationalExpr | --used for returning inc deps+            ConstructedAtom !DataConstructorName !AtomType [Atom]             deriving (Eq, Show, Typeable, NFData, Generic, Read)                       instance Hashable Atom where                        hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms                                                           `hashWithSalt` dConsName --AtomType is not hashable   hashWithSalt salt (IntAtom i) = salt `hashWithSalt` i-  hashWithSalt salt (IntegerAtom i) = salt `hashWithSalt` i  +  hashWithSalt salt (IntegerAtom i) = salt `hashWithSalt` i+  hashWithSalt salt (ScientificAtom s) = salt `hashWithSalt` s   hashWithSalt salt (DoubleAtom d) = salt `hashWithSalt` d   hashWithSalt salt (TextAtom t) = salt `hashWithSalt` t   hashWithSalt salt (DayAtom d) = salt `hashWithSalt` d@@ -77,6 +80,7 @@ -- | The AtomType uniquely identifies the type of a atom. data AtomType = IntAtomType |                 IntegerAtomType |+                ScientificAtomType |                 DoubleAtomType |                 TextAtomType |                 DayAtomType |@@ -102,6 +106,10 @@ isRelationAtomType (RelationAtomType _) = True isRelationAtomType _ = False +-- subrelations sometimes require special paths+attributesContainRelationAtomType :: Attributes -> Bool+attributesContainRelationAtomType attrs = V.null (V.filter (\(Attribute _ t) -> isRelationAtomType t) (attributesVec attrs))+ -- | The AttributeName is the name of an attribute in a relation. type AttributeName = StringType @@ -124,7 +132,9 @@ attributesSet = HS.fromList . V.toList . attributesVec  instance Show Attributes where-  show attrs = "attributesFromList [" <> L.intercalate ", " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]"+  showsPrec d attrs = showString $ parens $ "attributesFromList [" <> L.intercalate ", " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]"+    where parens x | d > 0 = "(" <> x <> ")"+          parens x = x  --when attribute ordering is irrelevant instance Eq Attributes where@@ -136,8 +146,12 @@ sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed (attributesVec attrs))  -- | The relation's tuple set is the body of the relation.-newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Read)+newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Show, Generic, Read) +-- we cannot derive Hashable for tuplesets; we need to hash the unordered set of tuples+instance Hashable RelationTupleSet where+  hashWithSalt s tupSet = hashWithSalt s (HS.fromList (asList tupSet))+         instance Read Relation where   readsPrec = error "relation read not supported" @@ -187,7 +201,7 @@ instance Hashable Relation where                                  hashWithSalt salt (Relation attrs tupSet) = salt `hashWithSalt`                                                sortedAttrs `hashWithSalt`-                                              asList tupSet+                                              HS.fromList (asList tupSet)     where       sortedAttrs = map snd (sortedAttributesIndices attrs)       @@ -579,19 +593,20 @@   f1 == f2 = funcName f1 == funcName f2  instance Hashable (Function a) where-  hashWithSalt salt func = salt `hashWithSalt` funcName func `hashWithSalt` funcType func `hashWithSalt` funcBody func-+  hashWithSalt salt func = salt `hashWithSalt` funcName func `hashWithSalt` funcType func `hashWithSalt` hashfuncbody +   where+    hashfuncbody =+      case funcBody func of+        (FunctionScriptBody script _) -> salt `hashWithSalt` script+        (FunctionBuiltInBody _) -> salt+        (FunctionObjectLoadedBody fp modName entryFunc _) -> salt `hashWithSalt` (fp, modName, entryFunc)+   data FunctionBody a =   FunctionScriptBody FunctionBodyScript a |   FunctionBuiltInBody a |   FunctionObjectLoadedBody FilePath ObjectModuleName ObjectFileEntryFunctionName a   deriving Generic -instance Hashable (FunctionBody a) where-  salt `hashWithSalt` (FunctionScriptBody script _) = salt `hashWithSalt` script-  salt `hashWithSalt` (FunctionBuiltInBody _) = salt-  salt `hashWithSalt` (FunctionObjectLoadedBody fp modName entryFunc _) = salt `hashWithSalt` (fp, modName, entryFunc)- instance NFData a => NFData (FunctionBody a) where   rnf (FunctionScriptBody script _) = rnf script   rnf (FunctionBuiltInBody _) = rnf ()@@ -607,6 +622,7 @@ attrTypeVars (Attribute _ aType) = case aType of   IntAtomType -> S.empty   IntegerAtomType -> S.empty+  ScientificAtomType -> S.empty   DoubleAtomType -> S.empty   TextAtomType -> S.empty   DayAtomType -> S.empty@@ -632,6 +648,7 @@ atomTypeVars :: AtomType -> S.Set TypeVarName atomTypeVars IntAtomType = S.empty atomTypeVars IntegerAtomType = S.empty+atomTypeVars ScientificAtomType = S.empty atomTypeVars DoubleAtomType = S.empty atomTypeVars TextAtomType = S.empty atomTypeVars DayAtomType = S.empty

@@ -290,7 +290,9 @@     [] -> error ("DNS resolution failed for" <> hostName <> ":" <> servicePort)     addrInfo:_ -> do       --supports IPv4 only for now-      let (SockAddrInet port addr) = addrAddress addrInfo+      let (port, addr) = case addrAddress addrInfo of+                           SockAddrInet p a -> (p, a)+                           _ -> error "no IPv4 address available (IPv6 not implemented)"           notificationHandlers =             [RPC.ClientAsyncRequestHandler $              \(NotificationMessage notifications') ->@@ -709,8 +711,8 @@ -- | Write the transaction graph to disk. This function can be used to incrementally write new transactions to disk. processTransactionGraphPersistence :: PersistenceStrategy -> [TransactionId] -> TransactionGraph -> IO () processTransactionGraphPersistence NoPersistence _ _ = pure ()-processTransactionGraphPersistence (MinimalPersistence dbdir) transIds graph = transactionGraphPersist NoDiskSync dbdir transIds graph >> pure ()-processTransactionGraphPersistence (CrashSafePersistence dbdir) transIds graph = transactionGraphPersist FsyncDiskSync dbdir transIds graph >> pure ()+processTransactionGraphPersistence (MinimalPersistence dbdir) transIds graph = void $ transactionGraphPersist NoDiskSync dbdir transIds graph+processTransactionGraphPersistence (CrashSafePersistence dbdir) transIds graph = void $ transactionGraphPersist FsyncDiskSync dbdir transIds graph  readGraphTransactionIdDigest :: PersistenceStrategy -> IO LockFileHash readGraphTransactionIdDigest NoPersistence = error "attempt to read digest from transaction log without persistence enabled"@@ -822,11 +824,7 @@         if Sess.schemaName session == defaultSchemaName then           pure $ RE.relationVariablesAsRelation context graph           else-          case Schema.relationVariablesInSchema schema of-            Left err -> pure (Left err)-            Right relvars -> do-              let schemaContext = context {relationVariables = relvars }-              pure $ RE.relationVariablesAsRelation schemaContext graph +          pure $ Schema.relationVariablesAsRelationInSchema context schema graph        relationVariablesAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId) 

@@ -17,6 +17,7 @@ import Data.Maybe import qualified Data.Text as T import Control.Arrow+import Control.Monad (unless) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -52,10 +53,7 @@ sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame sortDataFrameBy attrOrders frame = do   attrs <- mapM (\(AttributeOrder nam _) -> A.attributeForName nam (attributes frame)) attrOrders -  mapM_ (\attr -> if not (isSortableAtomType (atomType attr)) then-            Left (AttributeNotSortableError attr)-            else-            pure ()) attrs+  mapM_ (\attr -> unless (isSortableAtomType (atomType attr)) $ Left (AttributeNotSortableError attr)) attrs   pure $ DataFrame attrOrders (attributes frame) (sortTuplesBy (compareTupleByAttributeOrders attrOrders) (tuples frame))  sortTuplesBy :: (DataFrameTuple -> DataFrameTuple -> Ordering) -> [DataFrameTuple] -> [DataFrameTuple]

@@ -10,9 +10,12 @@ bytestringAtomFunctions = HS.fromList [   Function { funcName = "bytestring",              funcType = [TextAtomType, ByteStringAtomType],-             funcBody = compiledAtomFunctionBody $ \(TextAtom textIn:_) -> case B64.decode (TE.encodeUtf8 textIn) of+             funcBody = compiledAtomFunctionBody $+             \case+               TextAtom textIn:_ -> case B64.decode (TE.encodeUtf8 textIn) of                    Left err -> Left (AtomFunctionBytesDecodingError err)-                   Right bs -> pure (ByteStringAtom bs) +                   Right bs -> pure (ByteStringAtom bs)+               _ -> Left AtomFunctionTypeMismatchError                }   ]        

@@ -1,6 +1,7 @@ module ProjectM36.DataTypes.DateTime where import ProjectM36.Base import ProjectM36.AtomFunctionBody+import ProjectM36.AtomFunctionError import qualified Data.HashSet as HS import Data.Time.Clock.POSIX @@ -8,7 +9,10 @@ dateTimeAtomFunctions = HS.fromList [ Function {                                      funcName = "dateTimeFromEpochSeconds",                                      funcType = [IntegerAtomType, DateTimeAtomType],-                                     funcBody = compiledAtomFunctionBody $ \(IntegerAtom epoch:_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))-                                                                                                       }]+                                     funcBody = compiledAtomFunctionBody $+                                       \case+                                         IntegerAtom epoch:_ -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))+                                         _ -> Left AtomFunctionTypeMismatchError+                                     }]                                                   

@@ -1,17 +1,25 @@ module ProjectM36.DataTypes.Day where import ProjectM36.Base import ProjectM36.AtomFunctionBody+import ProjectM36.AtomFunctionError import qualified Data.HashSet as HS import Data.Time.Calendar + dayAtomFunctions :: AtomFunctions dayAtomFunctions = HS.fromList [   Function { funcName = "fromGregorian",                  funcType = [IntegerAtomType, IntegerAtomType, IntegerAtomType, DayAtomType],-                 funcBody = compiledAtomFunctionBody $ \(IntegerAtom year:IntegerAtom month:IntegerAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))+                 funcBody = compiledAtomFunctionBody $+                            \case+                              IntegerAtom year:IntegerAtom month:IntegerAtom day:_ -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))+                              _ -> Left AtomFunctionTypeMismatchError                  },   Function { funcName = "dayEarlierThan",                  funcType = [DayAtomType, DayAtomType, BoolAtomType],-                 funcBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB))+                 funcBody = compiledAtomFunctionBody $+                            \case+                              ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_ -> pure (BoolAtom (dayA < dayB))+                              _ -> Left AtomFunctionTypeMismatchError                }   ]

@@ -1,6 +1,7 @@ module ProjectM36.DataTypes.Either where import ProjectM36.Base import ProjectM36.AtomFunction+import ProjectM36.AtomFunctionError import qualified Data.HashSet as HS import qualified Data.Map as M        @@ -14,5 +15,7 @@         eitherAtomFunctions :: AtomFunctions                                eitherAtomFunctions = HS.fromList [-  compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \(ConstructedAtom dConsName _ _:_) -> pure (BoolAtom (dConsName == "Left"))+  compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \case+        (ConstructedAtom dConsName _ _:_) -> pure (BoolAtom (dConsName == "Left"))+        _ -> Left AtomFunctionTypeMismatchError   ]

@@ -29,6 +29,7 @@ supportsInterval typ = case typ of   IntAtomType -> True   IntegerAtomType -> True+  ScientificAtomType -> True   DoubleAtomType -> True   TextAtomType -> False -- just because it supports ordering, doesn't mean it makes sense in an interval   DayAtomType -> True               @@ -44,7 +45,8 @@ supportsOrdering :: AtomType -> Bool   supportsOrdering typ = case typ of   IntAtomType -> True-  IntegerAtomType -> True  +  IntegerAtomType -> True+  ScientificAtomType -> True   DoubleAtomType -> True   TextAtomType -> True   DayAtomType -> True               @@ -100,20 +102,26 @@                           BoolAtomType,                           BoolAtomType,                           intervalAtomType (TypeVariableType "a")],-             funcBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do+             funcBody = compiledAtomFunctionBody $+             \case+               (atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do                    let aType = atomTypeForAtom atom1                     if supportsInterval aType then                      createInterval atom1 atom2 bopen eopen                      else                      Left (AtomTypeDoesNotSupportIntervalError (prettyAtomType aType))+               _ -> Left AtomFunctionTypeMismatchError                },   Function {     funcName = "interval_overlaps",     funcType = [intervalAtomType (TypeVariableType "a"),                     intervalAtomType (TypeVariableType "a"),                     BoolAtomType],-    funcBody = compiledAtomFunctionBody $ \(i1@ConstructedAtom{}:i2@ConstructedAtom{}:_) -> -      BoolAtom <$> intervalOverlaps i1 i2+    funcBody = compiledAtomFunctionBody $+      \case+        i1@ConstructedAtom{}:i2@ConstructedAtom{}:_ -> +          BoolAtom <$> intervalOverlaps i1 i2+        _ -> Left AtomFunctionTypeMismatchError     }]                          isIntervalAtomType :: AtomType -> Bool

@@ -37,13 +37,19 @@   Function {      funcName = "length",      funcType = [listAtomType (TypeVariableType "a"), IntAtomType],-     funcBody = FunctionBuiltInBody (\(listAtom:_) ->-                                                 IntAtom . fromIntegral <$> listLength listAtom)+     funcBody = FunctionBuiltInBody $+       \case+               (listAtom:_) ->+                 IntAtom . fromIntegral <$> listLength listAtom+               _ -> Left AtomFunctionTypeMismatchError      },   Function {     funcName = "maybeHead",     funcType = [listAtomType (TypeVariableType "a"), maybeAtomType (TypeVariableType "a")],-    funcBody = FunctionBuiltInBody (\(listAtom:_) -> listMaybeHead listAtom)+    funcBody = FunctionBuiltInBody $+               \case+                 (listAtom:_) -> listMaybeHead listAtom+                 _ -> Left AtomFunctionTypeMismatchError     }   ]                     

@@ -19,12 +19,18 @@   Function {      funcName ="isJust",      funcType = [maybeAtomType (TypeVariableType "a"), BoolAtomType],-     funcBody = FunctionBuiltInBody $ \(ConstructedAtom dConsName _ _:_) -> pure $ BoolAtom (dConsName /= "Nothing")+     funcBody = FunctionBuiltInBody $+       \case+               ConstructedAtom dConsName _ _:_ -> pure $ BoolAtom (dConsName /= "Nothing")+               _ -> Left AtomFunctionTypeMismatchError      },   Function {      funcName = "fromMaybe",      funcType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "a"],-     funcBody = FunctionBuiltInBody $ \(defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal+     funcBody = FunctionBuiltInBody $+       \case+         (defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal+         _ ->Left AtomFunctionTypeMismatchError               }   ] 

@@ -42,12 +42,18 @@   Function {      funcName = "nonEmptyListLength",      funcType = [nonEmptyListAtomType (TypeVariableType "a"), IntAtomType],-     funcBody = FunctionBuiltInBody (\(nonEmptyListAtom:_) ->-                                                 IntAtom . fromIntegral <$> nonEmptyListLength nonEmptyListAtom)+     funcBody = FunctionBuiltInBody $+       \case+         (nonEmptyListAtom:_) ->+           IntAtom . fromIntegral <$> nonEmptyListLength nonEmptyListAtom+         _ -> Left AtomFunctionTypeMismatchError      },   Function {     funcName = "nonEmptyListHead",     funcType = [nonEmptyListAtomType (TypeVariableType "a"), TypeVariableType "a"],-    funcBody = FunctionBuiltInBody (\(nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom)+    funcBody = FunctionBuiltInBody $+      \case+        (nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom+        _ -> Left AtomFunctionTypeMismatchError     }   ]

@@ -2,19 +2,21 @@ import ProjectM36.Base  primitiveTypeConstructorMapping :: TypeConstructorMapping-primitiveTypeConstructorMapping = map (\(name, aType) ->+primitiveTypeConstructorMapping = boolMapping : map (\(name, aType) ->                                   (PrimitiveTypeConstructorDef name aType, [])) prims   where     prims = [("Integer", IntegerAtomType),              ("Int", IntAtomType),              ("Text", TextAtomType),              ("Double", DoubleAtomType),-             ("Bool", BoolAtomType),              ("UUID", UUIDAtomType),              ("ByteString", ByteStringAtomType),              ("DateTime", DateTimeAtomType),              ("Day", DayAtomType)             ]+    boolMapping = (PrimitiveTypeConstructorDef "Bool" BoolAtomType,+                   [DataConstructorDef "True" [],+                    DataConstructorDef "False" []])              intTypeConstructor :: TypeConstructor             intTypeConstructor = PrimitiveTypeConstructor "Int" IntAtomType@@ -38,6 +40,7 @@ atomTypeForAtom :: Atom -> AtomType atomTypeForAtom (IntAtom _) = IntAtomType atomTypeForAtom (IntegerAtom _) = IntegerAtomType+atomTypeForAtom (ScientificAtom _) = ScientificAtomType atomTypeForAtom (DoubleAtom _) = DoubleAtomType atomTypeForAtom (TextAtom _) = TextAtomType atomTypeForAtom (DayAtom _) = DayAtomType

@@ -5,6 +5,7 @@ compareAtoms (IntegerAtom i1) (IntegerAtom i2) = compare i1 i2 compareAtoms (IntAtom i1) (IntAtom i2) = compare i1 i2 compareAtoms (DoubleAtom d1) (DoubleAtom d2) = compare d1 d2+compareAtoms (ScientificAtom s1) (ScientificAtom s2) = compare s1 s2 compareAtoms (TextAtom t1) (TextAtom t2) = compare t1 t2 compareAtoms (DayAtom d1) (DayAtom d2) = compare d1 d2 compareAtoms (DateTimeAtom d1) (DateTimeAtom d2) = compare d1 d2@@ -20,6 +21,7 @@   IntAtomType -> True   IntegerAtomType -> True   DoubleAtomType -> True+  ScientificAtomType -> True   TextAtomType -> True   DayAtomType -> True   DateTimeAtomType -> True

@@ -12,9 +12,13 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.List as L+import qualified Data.Vector as V+import qualified ProjectM36.Attribute as A+import ProjectM36.AtomType #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif+ -- isomorphic schemas offer bi-directional functors between two schemas  --TODO: note that renaming a relvar should alter any stored isomorphisms as well@@ -79,9 +83,10 @@  -- | Check that all mentioned relvars are actually present in the current schema. validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError ()-validateRelationalExprInSchema schema relExprIn = relExprMogrify (\case-                                                                     RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)-                                                                     ex -> Right ex) relExprIn >> pure ()+validateRelationalExprInSchema schema relExprIn =+  void $ relExprMogrify (\case+                            RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)+                            ex -> Right ex) relExprIn   where     validRelVarNames = isomorphsInRelVarNames (isomorphs schema)   @@ -93,7 +98,7 @@   foldM processRelExpr relExprIn (isomorphs schema)    validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()  -validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) >> pure ()+validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema)    processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr   processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do@@ -265,6 +270,24 @@       pure (M.union newRvMap (M.fromList rvAssocs))  +-- | Show metadata about the relation variables in the isomorphic schema.+relationVariablesAsRelationInSchema :: DatabaseContext -> Schema -> TransactionGraph -> Either RelationalError Relation+relationVariablesAsRelationInSchema concreteDbContext schema graph = do+  rvDefsInConcreteSchema <- relationVariablesInSchema schema+  let gfEnv = freshGraphRefRelationalExprEnv (Just concreteDbContext) graph+  typAssocs <- forM (M.toList rvDefsInConcreteSchema) $ \(rv, gfExpr) -> do+    typ <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)+    pure (rv, typ)+  let tups = map relVarToAtomList typAssocs+      subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]+      attrs = A.attributesFromList [Attribute "name" TextAtomType,+                                  Attribute "attributes" (RelationAtomType subrelAttrs)]+      relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributesVec (attributes rel))]+      attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]  +      attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of+        Left err -> error ("relationVariablesAsRelation pooped " ++ show err)+        Right rel -> RelationAtom rel+  mkRelationFromList attrs tups  {- proposal

@@ -1,13 +1,14 @@ {-# LANGUAGE ForeignFunctionInterface, CPP #-} --this module is related to persisting Project:M36 structures to disk and not related to the persistent library module ProjectM36.Persist (writeFileSync, -                           writeBSFileSync,+                           writeSerialiseSync,                            renameSync,                            printFdCount,                            DiskSync(..)) where -- on Windows, use FlushFileBuffers and MoveFileEx import qualified Data.Text as T-+import Codec.Winery+import qualified Data.ByteString.FastBuilder as BB #if defined(linux_HOST_OS) # define FDCOUNTSUPPORTED 1 # define FDDIR "/proc/self/fd"@@ -35,8 +36,8 @@ import Foreign.C #endif -import System.IO (withFile, IOMode(WriteMode), Handle)-import qualified Data.ByteString as BS'+import System.IO (withFile, IOMode(WriteMode), Handle, withBinaryFile)+import qualified Data.ByteString as BS import qualified Data.Text.Encoding as TE  #if defined(mingw32_HOST_OS)@@ -52,7 +53,7 @@ writeFileSync sync path strOut = withFile path WriteMode handler   where     handler handle = do-      BS'.hPut handle (TE.encodeUtf8 strOut)+      BS.hPut handle (TE.encodeUtf8 strOut)       syncHandle sync handle  renameSync :: DiskSync -> FilePath -> FilePath -> IO ()@@ -99,10 +100,11 @@ syncDirectory FsyncDiskSync path = directoryFsync path  syncDirectory NoDiskSync _ = pure () -writeBSFileSync :: DiskSync -> FilePath -> BS'.ByteString -> IO ()-writeBSFileSync sync path bstring =-  withFile path WriteMode $ \handle -> do-    BS'.hPut handle bstring+--uses lazy bytestring to write to file+writeSerialiseSync :: Serialise a => DiskSync -> FilePath -> a -> IO ()+writeSerialiseSync sync path val = +  withBinaryFile path WriteMode $ \handle -> do+    BB.hPutBuilder handle $ toBuilderWithSchema val     syncHandle sync handle    directoryFsync :: FilePath -> IO ()

@@ -60,6 +60,7 @@ parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom) parseCSVAtomP _ _ IntegerAtomType = Right . IntegerAtom <$> APT.decimal parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal+parseCSVAtomP _ _ ScientificAtomType = Right . ScientificAtom <$> APT.scientific parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double parseCSVAtomP _ _ TextAtomType =    Right . TextAtom <$> (quotedString <|> takeToEndOfData)

@@ -862,6 +862,9 @@   let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env   relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)   pure (RelationAtom relAtom)+evalGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _)+  | tOrF == "True" = pure (BoolAtom True)+  | tOrF == "False" = pure (BoolAtom False) evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do --why is the tid unused here? suspicious   let mergeEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn   aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) cons)@@ -893,15 +896,27 @@     Right func -> do       let funcRetType = last (funcType func)           funcArgTypes = init (funcType func)+          funArgCount = length funcArgTypes+          inArgCount = length atomArgs+      when (funArgCount /= inArgCount) (throwError (FunctionArgumentCountMismatchError funArgCount inArgCount))       argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs+      mapM_ (\(fArg,arg,argCount) -> do+                let handler :: RelationalError -> GraphRefRelationalExprM AtomType+                    handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType)+                    handler err = throwError err+                lift (except $ atomTypeVerify fArg arg) `catchError` handler+            ) (zip3 funcArgTypes argTypes [1..])       let eTvMap = resolveTypeVariables funcArgTypes argTypes       case eTvMap of             Left err -> throwError err-            Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName' tvMap funcRetType+            Right tvMap ->+              lift $ except $ resolveFunctionReturnValue funcName' tvMap funcRetType typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do   relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)   pure (RelationAtomType (attributes relType)) -- 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 typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =   do     argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs

@@ -19,30 +19,47 @@ import Data.Maybe import GHC.Paths (libdir) import System.Environment-#if __GLASGOW_HASKELL__ >= 800-import GHC.LanguageExtensions-import GHCi.ObjLink-#else-import ObjLink-#endif-#if __GLASGOW_HASKELL__ >= 802-import BasicTypes-#endif-import DynFlags-import Panic-import Outputable --hiding ((<>))-import PprTyThing+ import Unsafe.Coerce-#if __GLASGOW_HASKELL__ >= 802-import Type-#elif __GLASGOW_HASKELL__ >= 710-import Type hiding (pprTyThing)+import GHC.LanguageExtensions (Extension(OverloadedStrings,ExtendedDefaultRules,ImplicitPrelude,ScopedTypeVariables))++#if MIN_VERSION_ghc(9,2,0)+-- GHC 9.2.2+import GHC.Utils.Panic (handleGhcException)+import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming))+import GHC.Types.SourceText (SourceText(NoSourceText))+import GHC.Unit.Types (IsBootInterface(NotBoot))+import GHC.Driver.Ppr (showSDocForUser)+import GHC.Core.Type (eqType)+import GHC.Types.TyThing.Ppr (pprTypeForUser)+import GHC.Utils.Encoding (zEncodeString)+import GHC.Unit.State (emptyUnitState)+#elif MIN_VERSION_ghc(9,0,0)+-- GHC 9.0.0+import GHC.Utils.Panic (handleGhcException)+import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming))+import GHC.Types.Basic (SourceText(NoSourceText))+import GHC.Unit.Types (IsBootInterface(NotBoot))+import GHC.Core.Type (eqType)+import GHC.Utils.Outputable (showSDocForUser)+import GHC.Utils.Encoding (zEncodeString)+import GHC.Core.Ppr.TyThing (pprTypeForUser) #else+-- GHC 8.10.7+import BasicTypes (SourceText(NoSourceText))+import Outputable (showSDocForUser)+import PprTyThing (pprTypeForUser)+import Type (eqType)+import Encoding (zEncodeString)+import Panic (handleGhcException)+import DynFlags (projectVersion, PkgConfRef(PkgConfFile), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming), PackageDBFlag(PackageDB)) #endif+ import GHC.Exts (addrToAny#) import GHC.Ptr (Ptr(..))-import Encoding+import GHCi.ObjLink (initObjLinker, ShouldRetainCAFs(RetainCAFs), resolveObjs, lookupSymbol, loadDLL, loadObj) #endif+-- endif for SCRIPTING FLAG  data ScriptSession = ScriptSession { #ifdef PM36_HASKELL_SCRIPTING@@ -90,33 +107,35 @@       homeDir </> ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb"       --homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"       ]--    let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir)+#if MIN_VERSION_ghc(9,0,0)+    let pkgConf = PkgDbPath+#else+    let pkgConf = PkgConfFile+#endif+    let localPkgPaths = map pkgConf (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir) -    let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted ,+    let dflags' = applyGopts . applyXopts $ dflags {+#if MIN_VERSION_ghc(9,2,0)+                           backend = Interpreter,+#else  +                           hscTarget = HscInterpreted ,+#endif                            ghcLink = LinkInMemory,                            safeHaskell = Sf_Trustworthy,                            safeInfer = True,                            safeInferred = True,                            --verbosity = 3,-#if __GLASGOW_HASKELL__ >= 800+                            trustFlags = map TrustPackage required_packages,-#endif                            packageFlags = packageFlags dflags ++ packages,-#if __GLASGOW_HASKELL__ >= 802                            packageDBFlags = map PackageDB localPkgPaths-#else-                           extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])-#endif -                         }+--                           extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])+        }+         applyGopts flags = foldl gopt_set flags gopts         applyXopts flags = foldl xopt_set flags xopts-#if __GLASGOW_HASKELL__ >= 800         xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables]-#else-        xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude,  Opt_ScopedTypeVariables]-#endif         gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]         required_packages = ["base",                              "containers",@@ -131,42 +150,42 @@                              "time",                              "project-m36",                              "bytestring"]-#if __GLASGOW_HASKELL__ >= 800         packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages-#else-        packages = map TrustPackage required_packages-#endif   --liftIO $ traceShowM (showSDoc dflags' (ppr packages))     _ <- setSessionDynFlags dflags'-    let safeImportDecl mn mQual = ImportDecl {-#if __GLASGOW_HASKELL__ >= 802+    let safeImportDecl :: String -> Maybe String -> ImportDecl (GhcPass 'Parsed)+        safeImportDecl fullModuleName mQualifiedName = ImportDecl {           ideclSourceSrc = NoSourceText,-#else-          ideclSourceSrc = Nothing,-#endif -#if __GLASGOW_HASKELL__ >= 810+#if MIN_VERSION_ghc(9,2,0)+          ideclExt = noAnn,+#else           ideclExt = noExtField,-#elif __GLASGOW_HASKELL__ >= 806-          ideclExt = NoExt, #endif-          ideclName      = noLoc mn,+#if MIN_VERSION_ghc(9,2,0)+          --GenLocated SrcSpanAnnA ModuleName+          ideclName      = noLocA (mkModuleName fullModuleName),+#else+          ideclName      = noLoc (mkModuleName fullModuleName),+#endif           ideclPkgQual   = Nothing,+#if MIN_VERSION_ghc(9,0,0)+          ideclSource    = NotBoot,+#else           ideclSource    = False,+#endif+           ideclSafe      = True,           ideclImplicit  = False,-#if __GLASGOW_HASKELL__ >= 810-          ideclQualified = if isJust mQual then QualifiedPre else NotQualified,+          ideclQualified = if isJust mQualifiedName then QualifiedPre else NotQualified,+#if MIN_VERSION_ghc(9,2,0)+          ideclAs        = Just (noLocA (mkModuleName fullModuleName)), #else-          ideclQualified = isJust mQual,+          ideclAs        = noLoc . mkModuleName <$> mQualifiedName, #endif-          ideclAs        = mQual,           ideclHiding    = Nothing           }-#if __GLASGOW_HASKELL__ >= 806-          :: ImportDecl (GhcPass (c :: Pass))-#endif-        unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [+        unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl modn Nothing) [           "Prelude",           "Data.Map",           "Data.Either",@@ -178,12 +197,7 @@           "ProjectM36.DatabaseContextFunctionError",           "ProjectM36.DatabaseContextFunctionUtils",           "ProjectM36.RelationalExpression"]-#if __GLASGOW_HASKELL__ >= 802-        mkModName = noLoc . mkModuleName-#else-        mkModName = mkModuleName-#endif-        qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModName qualNam))) [+        qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl modn (Just qualNam)) [           ("Data.Text", "T")           ]     setContext (unqualifiedModules ++ qualifiedModules)@@ -198,7 +212,11 @@   setContext (IIDecl (simpleImportDecl (mkModuleName moduleNam)) : ctx)  showType :: DynFlags -> Type -> String+#if MIN_VERSION_ghc(9,2,0)+showType dflags ty = showSDocForUser dflags emptyUnitState alwaysQualify (pprTypeForUser ty)+#else showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)+#endif  mkTypeForName :: String -> Ghc Type mkTypeForName name = do@@ -231,11 +249,7 @@ typeCheckScript expectedType inp = do   dflags <- getSessionDynFlags   --catch exception for SyntaxError-#if __GLASGOW_HASKELL__ >= 802   funcType <- GHC.exprType TM_Inst (unpack inp)-#else-  funcType <- GHC.exprType (unpack inp)-#endif   --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType   if eqType funcType expectedType then     pure Nothing@@ -271,11 +285,7 @@  loadFunction :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a) loadFunction loadMode modName funcName objPath = do-#if __GLASGOW_HASKELL__ >= 802   initObjLinker RetainCAFs-#else-  initObjLinker-#endif   let loadFuncForSymbol = do             _ <- resolveObjs         ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)

@@ -11,9 +11,12 @@ import Data.Proxy import Data.Word import ProjectM36.Attribute as A-import qualified Data.List.NonEmpty as NE import qualified Data.Vector as V import Data.Time.Calendar (Day,toGregorian,fromGregorian)+#if MIN_VERSION_winery(1,4,0)+#else+import qualified Data.List.NonEmpty as NE+#endif  deriving via WineryVariant Atom instance Serialise Atom deriving via WineryVariant AtomType instance Serialise AtomType@@ -55,6 +58,8 @@   extractor = fromWordsTup <$> extractor   decodeCurrent = fromWordsTup <$> decodeCurrent +#if MIN_VERSION_winery(1,4,0)+#else instance Serialise a => Serialise (NE.NonEmpty a) where   schemaGen _ = SVector <$> getSchema (Proxy @a)   toBuilder xs = varInt (length xs) <> foldMap toBuilder xs@@ -63,6 +68,7 @@     n <- decodeVarInt     l <- replicateM n decodeCurrent     pure (NE.fromList l)+#endif  fromGregorianTup :: (Integer, Int, Int) -> Day fromGregorianTup (a, b, c) = fromGregorian a b c

@@ -525,7 +525,10 @@           optFinalExpr = case finalExpr of                               Restrict _ subexpr -> applyStaticRestrictionCollapse subexpr                               otherExpr -> otherExpr-          andPreds = foldr (\(Restrict subpred _) acc -> AndPredicate acc subpred) firstPred (tail restrictions) in+          andPreds = foldr folder firstPred (tail restrictions)+          folder (Restrict subpred _) acc = AndPredicate acc subpred+          folder _ _ = error "unexpected restriction expression in optimization phase"+      in       Restrict andPreds optFinalExpr        sequentialRestrictions :: RelationalExprBase a -> [RelationalExprBase a]

@@ -0,0 +1,10 @@+module ProjectM36.Trace where+import Debug.Trace (traceEventIO)+-- utility module to enable easy enabling/disabling of eventlog data++-- | Utility function for tracing with ghc-events-analyze using START and STOP markers+traceBlock :: String -> IO () -> IO ()+traceBlock label m = do+  traceEventIO ("START " <> label)+  m+  traceEventIO ("STOP " <> label)

@@ -1,16 +1,18 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-} #ifdef PM36_HASKELL_SCRIPTING {-# LANGUAGE TypeApplications #-} #endif module ProjectM36.Transaction.Persist where+import ProjectM36.Trace import ProjectM36.Base import ProjectM36.Error import ProjectM36.Transaction import ProjectM36.DatabaseContextFunction import ProjectM36.AtomFunction-import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)+import ProjectM36.Persist (DiskSync, renameSync, writeSerialiseSync) import ProjectM36.Function import qualified Data.Map as M import qualified Data.HashSet as HS@@ -109,14 +111,14 @@ writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO () writeRelVars sync transDir relvars = do   let path = relvarsPath transDir-  writeBSFileSync sync path (serialise relvars)+  traceBlock "write relvars" $ writeSerialiseSync sync path relvars  readRelVars :: FilePath -> IO RelationVariables readRelVars transDir =    readFileDeserialise (relvarsPath transDir)  writeFuncs :: Traversable t => DiskSync -> FilePath -> t (Function a) -> IO ()-writeFuncs sync funcWritePath funcs = do+writeFuncs sync funcWritePath funcs = traceBlock "write functions" $ do   funcs' <- forM funcs $ \fun -> do     case funcBody fun of       FunctionScriptBody{} -> pure fun@@ -134,7 +136,7 @@             Just (ObjectFileInfo (objPath, modName, entryFunc))           FunctionScriptBody{} -> Nothing           FunctionBuiltInBody{} -> Nothing-  writeBSFileSync sync funcWritePath (serialise $ fmap functionData (toList funcs'))+  writeSerialiseSync sync funcWritePath (fmap functionData (toList funcs'))  readFuncs :: FilePath -> FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> IO (HS.HashSet (Function a)) readFuncs transDir funcPath precompiledFunctions mScriptSession = do@@ -223,11 +225,12 @@ #endif  writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()  -writeIncDep sync transDir (incDepName, incDep) = -  writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ serialise incDep+writeIncDep sync transDir (incDepName, incDep) = do+  writeSerialiseSync sync (incDepsDir transDir </> T.unpack incDepName) incDep    writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO ()  -writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toList incdeps +writeIncDeps sync transDir incdeps = +  traceBlock "write incdeps" $ mapM_ (writeIncDep sync transDir) $ M.toList incdeps     readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency) readIncDep transDir incdepName = do@@ -249,11 +252,12 @@ writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()   writeSubschemas sync transDir sschemas = do   let sschemasPath = subschemasPath transDir-  writeBSFileSync sync sschemasPath (serialise sschemas)+  traceBlock "write subschemas" $ writeSerialiseSync sync sschemasPath sschemas    writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()  -writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in-  writeBSFileSync sync atPath $ serialise types+writeTypeConstructorMapping sync path types = do+  let atPath = typeConsPath path+  traceBlock "write tconsmap" $ writeSerialiseSync sync atPath types  readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping readTypeConstructorMapping path = do

@@ -621,10 +621,8 @@  validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError () validateMerkleHash trans graph = -  if expectedHash /= actualHash  then+  when (expectedHash /= actualHash) $     Left (MerkleValidationError (transactionId trans) expectedHash actualHash)-  else-    pure ()   where     expectedHash = merkleHash (transactionInfo trans)     actualHash = calculateMerkleHash trans graph

@@ -8,6 +8,7 @@ import qualified Data.Map as M import qualified ProjectM36.TypeConstructorDef as TCD import qualified Data.HashSet as HS+import qualified Data.Text as T  data MergePreference = PreferFirst | PreferSecond | PreferNeither @@ -69,7 +70,7 @@             let findType tcm = case filter (\(t,_) -> TCD.name t == name) tcm of                   [] -> Nothing                   [x] -> Just x-                  _ -> error "multiple names matching in TypeConstructorMapping"+                  _ -> error $ "multiple names matching in TypeConstructorMapping for " <> T.unpack name                 lookupA = findType typesA                 lookupB = findType typesB                 cat t = pure (t : acc)

@@ -32,6 +32,7 @@ import Data.Time.Clock import Data.Text.Read import System.FilePath.Glob+import Data.Tuple  type LockFileHash = ByteString @@ -143,14 +144,21 @@         headsStrLines = map headFileStr $ M.toList (transactionHeadsForGraph graph)     writeFileSync sync tempHeadsPath $ T.intercalate "\n" headsStrLines     renameSync sync tempHeadsPath (headsPath dbdir)-                                                             + transactionGraphHeadsLoad :: FilePath -> IO [(HeadName,TransactionId)] transactionGraphHeadsLoad dbdir = do   headsData <- readFile (headsPath dbdir)-  let headsAssocs = map (\l -> let [headName, uuidStr] = words l in-                          (headName,uuidStr)-                          ) (lines headsData)+  let headsAssocs = map twowords (lines headsData)   return [(T.pack headName, uuid) | (headName, Just uuid) <- map (second U.fromString) headsAssocs]++data Pos = One | Two++twowords :: String -> (String, String)+twowords s = swap $ snd $ foldr twowordfolder (One, ("","")) s+  where+    twowordfolder ' ' (One, acc) = (Two,acc)+    twowordfolder c (One, (a, b)) =  (One, (c:a, b))+    twowordfolder c (Two, (a, b)) = (Two, (a, c:b))    {-   load any transactions which are not already part of the incoming transaction graph@@ -212,7 +220,10 @@ readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])]) readGraphTransactionIdFile dbdir = do   --read in all transactions' uuids-  let grapher line = let tid:epochText:parentIds' = T.words line in+  let grapher line = let (tid,epochText,parentIds') = case T.words line of+                           x:y:zs -> (x,y,zs)+                           _ -> error "failed to parse transaction id file"+                           in         (readUUID tid, readEpoch epochText, map readUUID parentIds')       readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText)       readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t)))@@ -228,4 +239,5 @@       case TE.decodeUtf8' fileBytes of         Left err -> error (show err)         Right utf8Bytes -> pure utf8Bytes+ 

@@ -7,10 +7,11 @@ import ProjectM36.TransactionGraph import ProjectM36.StaticOptimizer import qualified ProjectM36.DatabaseContext as DBC-import qualified ProjectM36.Attribute as A+import ProjectM36.Attribute (attributesFromList) import System.Exit import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Vector as V  testList :: Test testList = TestList [testIsoRename, testIsoRestrict, testIsoUnion, testSchemaValidation]@@ -67,7 +68,7 @@ testIsoRestrict = TestCase $ do   -- create a emp relation which is restricted into two boss, nonboss rel vars   -- the virtual schema has an employee-  let empattrs = A.attributesFromList [Attribute "name" TextAtomType,+  let empattrs = attributesFromList [Attribute "name" TextAtomType,                                         Attribute "boss" TextAtomType]   (graph, transId) <- freshTransactionGraph DBC.empty                    emprel <- assertEither $ mkRelationFromList empattrs@@ -85,6 +86,7 @@                                         ("boss", ExistingRelation bossRel)]         }       isomorphsAtoB = [IsoRestrict "employee" predicate ("boss", "nonboss")]+      schemaB = Schema isomorphsAtoB       bossq = RelationVariable "boss" ()       nonbossq = RelationVariable "nonboss" ()       employeeq = RelationVariable "employee" ()@@ -108,13 +110,24 @@   processedExpr <- assertEither (processRelationalExprInSchema (Schema isomorphsAtoB) (RelationVariable "employee" ()))   let processedRel = runRelationalExprM postInsertEnv (evalRelationalExpr processedExpr)   assertEqual "insert bob boss" expectedRel processedRel++  -- test that we can render isomorphic schema metadata+  let rvTypes = relationVariablesAsRelationInSchema baseContext schemaB graph+      rvattrs = attributesFromList [Attribute "name" TextAtomType, Attribute "attributes" (RelationAtomType subrelattrs)]+      subrelattrs = attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]+      expectedTypes = mkRelationFromList rvattrs +        [[TextAtom "employee",+           RelationAtom (Relation subrelattrs+                          (RelationTupleSet [RelationTuple subrelattrs (V.fromList [TextAtom "boss",TextAtom "Text"]),+                                             RelationTuple subrelattrs (V.fromList [TextAtom "name",TextAtom "Text"])]))]]+  assertEqual "relationVariablesAsRelationInSchema" expectedTypes rvTypes    testIsoUnion :: Test   testIsoUnion = TestCase $ do   --create motors relation which is split into low-power (<50 horsepower) and high-power (>=50 horsepower) motors   --the schema is contains the split relvars   (graph, _) <- freshTransactionGraph DBC.empty-  motorsRel <- assertEither $ mkRelationFromList (A.attributesFromList [Attribute "name" TextAtomType,+  motorsRel <- assertEither $ mkRelationFromList (attributesFromList [Attribute "name" TextAtomType,                                                                         Attribute "power" IntegerAtomType])                 [[TextAtom "Puny", IntegerAtom 10],                 [TextAtom "Scooter", IntegerAtom 49],@@ -136,3 +149,4 @@   highpowerRel <- assertEither (relResult highpowerExpr)   assertEqual "lowpower relation difference" (Right lowpowerRel) lowmotors   assertEqual "highpower relation difference" (Right highpowerRel) highmotors+

@@ -7,12 +7,14 @@ import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.Tuple+import ProjectM36.Attribute (attributesFromList) import qualified ProjectM36.DatabaseContext as DBC import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.Set as S import System.Exit+import Data.Hashable (hashWithSalt)   testList :: Test@@ -24,7 +26,8 @@                      testRelation "supplierProducts" supplierProductsRel,                      testMkRelationFromExprsBadAttrs,                      testExistingRelationType,-                     testReorderTuple+                     testReorderTuple,+                     testRelationEquality                     ]  main :: IO ()           @@ -117,3 +120,27 @@       actual = reorderTuple attrs2 tup1       expected = mkRelationTuple attrs2 (V.fromList [TextAtom "test", IntAtom 4])   assertEqual "reorderTuple" expected actual++testRelationEquality :: Test+testRelationEquality = TestCase $ do+  -- relations with changed orders of tuples must hash to the same value and be equal, even in lieu of subrelations+  let r1 = Relation rattrs $ RelationTupleSet {asList = [RelationTuple subrelattrs+                                                        (V.fromList [RelationAtom subrel1])]+                                             }+      rattrs = attributesFromList [Attribute "x" (RelationAtomType subrelattrs)]++      r2 = Relation rattrs $ RelationTupleSet {asList = [RelationTuple subrelattrs+                                 (V.fromList [RelationAtom subrel2])]+                      }+      subrelattrs = attributesFromList [Attribute "y" IntAtomType]           +      subrel1 = Relation subrelattrs tupset1+      tupset1 = RelationTupleSet [RelationTuple subrelattrs (V.fromList [IntAtom 3]),+                                RelationTuple subrelattrs (V.fromList [IntAtom 4])]+      subrel2 = Relation subrelattrs tupset2+      tupset2 = RelationTupleSet [RelationTuple subrelattrs (V.fromList [IntAtom 4]),+                                  RelationTuple subrelattrs (V.fromList [IntAtom 3])]++  assertEqual "relation eq" r1 r2+  assertEqual "relation hash" (hashWithSalt 0 r1) (hashWithSalt 0 r2)+  assertEqual "tupset eq" tupset1 tupset2+  assertEqual "tupset hash" (hashWithSalt 0 tupset1) (hashWithSalt 0 tupset2)

@@ -19,6 +19,7 @@ import Control.Exception import System.IO.Temp import System.FilePath+import Control.Monad (void) #if defined(linux_HOST_OS) import System.Directory #endif@@ -89,7 +90,7 @@                                          checkFS = False --not stricly needed for these tests                                        }     -      launchServer config (Just addressMVar) >> pure ()+      void $ launchServer config (Just addressMVar)   (SockAddrInet port _) <- takeMVar addressMVar   --liftIO $ putStrLn ("launched server on " ++ show endPointAddress)   pure (fromIntegral port, tid)

@@ -18,6 +18,7 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import ProjectM36.Relation+import Control.Monad (void)  --start the websocket server -- run some tutoriald against it@@ -30,7 +31,7 @@                                      checkFS = False}       testDatabaseName = "test"   -- start normal server-  _ <- forkIO (launchServer config (Just addressMVar) >> pure ())+  void $ forkIO (void $ launchServer config (Just addressMVar))   (SockAddrInet dbPort _) <- takeMVar addressMVar   let wsServerHost = "127.0.0.1"       wsServerPort = 8889

@@ -29,12 +29,13 @@ import Data.Text.Encoding as TE import Control.Concurrent import qualified Data.Set as S-import Data.Text hiding (map)+import Data.Text (unpack, Text) import qualified Data.Text as T import Data.Time.Clock.POSIX hiding (getCurrentTime) import Data.Time.Clock (getCurrentTime) import Data.Time.Calendar (fromGregorian) import Data.Either+import Data.Scientific  main :: IO () main = do@@ -84,7 +85,8 @@       testSelfReferencingUncommittedContext,       testUnionAndIntersectionAttributeExprs,       testUndefineConstraints,-      testQuotedRelVarNames      +      testQuotedRelVarNames,+      testScientific       ]  simpleRelTests :: Test@@ -113,8 +115,10 @@                       ("x:=true where false or false", Right relationFalse),                       ("x:=true where true and false", Right relationFalse),                       ("x:=true where false and true", Right relationFalse),                      -                      ("x:=true where ^t and ^f", Right relationFalse),+                      ("x:=true where True and False", Right relationFalse),                       ("x:=true where true and true", Right relationTrue),+                      ("x:=true where true and True", Right relationTrue),+                      ("x:=true where True and true", Right relationTrue), -- flip these around to catch parser bugs                       ("x:=true=true", Right relationTrue),                       ("x:=true=false", Right relationFalse),                       ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),@@ -175,11 +179,11 @@                            ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),                            ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),                            --boolean function restriction-                           ("x:=s where ^lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),-                           ("x:=s where ^gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],+                           ("x:=s where lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),+                           ("x:=s where gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],                                                                                                        [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),-                           ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntegerAtomType BoolAtomType),-                           ("x:=s where ^not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),+                           ("x:=s where sum(@status)", Left $ AtomFunctionTypeError "sum" 1 (RelationAtomType (attributesFromList [Attribute "_" IntegerAtomType])) IntegerAtomType),+                           ("x:=s where not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),                            --test "all but" attribute inversion syntax                            ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),                            --test key syntax@@ -430,7 +434,7 @@ testSchemaExpr = TestCase $ do   (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback     mapM_ (executeTutorialD sessionId dbconn) [-    ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" ^gte(17,@weight))",+    ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" gte(17,@weight))",     ":setschema test",     ""     ]@@ -524,12 +528,12 @@ testIntervalAtom = TestCase $ do     --test interval creation   (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  -  executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,f,f), b interval(4,5,f,f)}, tuple{n 2,a interval(3,4,t,t), b interval(4,5,t,t)}}"+  executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,False,False), b interval(4,5,False,False)}, tuple{n 2,a interval(3,4,True,True), b interval(4,5,True,True)}}"   --test failed interval creation   let err1 = "AtomFunctionUserError InvalidIntervalOrderingError"       err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError \"Text\")"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}"  +  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,False,False)}}"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",False,False)}}"      --test interval_overlaps   executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}"@@ -681,12 +685,12 @@ testAtomFunctionArgumentMismatch :: Test testAtomFunctionArgumentMismatch = TestCase $ do   (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  let err1 = "AtomTypeMismatchError"+  let err1 = "AtomFunctionTypeError"   --atom function type mismatch-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where ^gt(@a,1.5)"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where gt(@a,1.5)"   --wrong argument count   let err2 = "FunctionArgumentCountMismatchError"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where gt(@a,1,3)"  testInvalidDataConstructor :: Test testInvalidDataConstructor = TestCase $ do@@ -751,3 +755,17 @@   let qAttrExpected = Right (Assign "test" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "\28450\23383" (NakedAtomExpr (TextAtom "test")))])))   assertEqual "quoted attribute" qAttrExpected (parseDBExpr "test:=relation{tuple{`漢字` \"test\"}}")   assertBool "invalid quoted rv" (isLeft (parseDBExpr "`TEST:=true"))++testScientific :: Test+testScientific = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  let getX = executeRelationalExpr sessionId dbconn (RelationVariable "x" ())+  executeTutorialD sessionId dbconn "x:=relation{tuple{a scientific(1,int(100))}}"+  createSciRel <- getX+  let expectedRel = mkRelationFromList attrs [[ScientificAtom (scientific 1 100)]]+      attrs = attributesFromList [Attribute "a" ScientificAtomType]+  assertEqual "scientific creation" expectedRel createSciRel+  --test some math functions+  executeTutorialD sessionId dbconn "x:=relation{tuple{a scientific_add(scientific(2,int(100)),scientific(1,int(100)))}}"+  addSciRel <- getX+  assertEqual "scientific add" (mkRelationFromList attrs [[ScientificAtom (scientific 3 100)]]) addSciRel

@@ -16,7 +16,7 @@   testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntegerAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntegerAtom 1))) (RelationVariable "true" ()))),   testPretty "relation{tuple{a fromGregorian(2014, 2, 4)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "fromGregorian" [NakedAtomExpr (IntegerAtom 2014),NakedAtomExpr (IntegerAtom 2),NakedAtomExpr (IntegerAtom 4)] ())])])),   testPretty "relation{tuple{a bytestring(\"dGVzdGRhdGE=\")}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "bytestring" [NakedAtomExpr (TextAtom "dGVzdGRhdGE=")] ())])])),-  testPretty "relation{tuple{a t}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (BoolAtom True))])])),+  testPretty "relation{tuple{a True}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "True" [] ())])])),   testPretty "relation{tuple{a Cons 4 (Cons 5 Empty)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 4),ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 5),ConstructedAtomExpr "Empty" [] ()] ()] ())])])),   testPretty "relation{a Int, b Text, c Bool}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (ADTypeConstructor "Int" []) (),AttributeAndTypeNameExpr "b" (ADTypeConstructor "Text" []) (),AttributeAndTypeNameExpr "c" (ADTypeConstructor "Bool" []) ()]) (TupleExprs () [])),   testPretty "relation{a relation{b Int}}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (RelationAtomTypeConstructor [AttributeAndTypeNameExpr "b" (ADTypeConstructor "Int" []) ()]) ()]) (TupleExprs () []))