diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,11 @@ +# 2019-09-07 (v0.7) + +* fix case sensitivity issue with relation variables in tutd +* fix multibyte escaping in data frames +* fix broken instances of `Atomable [a]` +* fix `TypeConstructor` validation of argument count +* add help option to executables + # 2019-01-08 (v0.6) * fix atom type parsing to support more complex data types diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -26,10 +26,6 @@ [![asciicast](https://asciinema.org/a/3syu35c8cydm403292a74l1n5.png)](https://asciinema.org/a/3syu35c8cydm403292a74l1n5) -## Try It! - -You can experiment instantly with Project:M36 straight from your browser at [try.project-m36.io](https://try.project-m36.io)! - ## Use-Cases Project:M36 supports multiple frontends which target different audiences. @@ -57,6 +53,7 @@ 1. [15 Minute Tutorial](docs/15_minute_tutorial.markdown) 1. [Developer's Change Log](Changelog.markdown) 1. [Simple Client API](docs/simple_api.markdown) +1. [CSV Import/Export](docs/import_export_csv.markdown) ### Database Comparisons @@ -84,10 +81,11 @@ 1. [WebSocket Server](docs/websocket_server.markdown) 1. [Jupyter Notebook Kernel](docs/jupyter_kernel.markdown) +1. [Persistent Driver](https://github.com/YuMingLiao/persistent-project-m36) ## Development -Project:M36 is developed in Haskell and compiled with GHC 8.0.2 or later. +Project:M36 is developed in Haskell and compiled with GHC 8.2.2 or later. ## Related Projects diff --git a/examples/blog.hs b/examples/blog.hs --- a/examples/blog.hs +++ b/examples/blog.hs @@ -1,5 +1,5 @@ -- a simple example of a blog schema -{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, CPP #-} import ProjectM36.Client import ProjectM36.Base @@ -17,7 +17,9 @@ import Data.Time.Calendar import Control.DeepSeq import Data.Proxy +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import Data.List import Control.Monad (when, forM_) diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,5 +1,5 @@ Name: project-m36 -Version: 0.6 +Version: 0.7 License: PublicDomain Build-Type: Simple Homepage: https://github.com/agentm/project-m36 @@ -29,7 +29,9 @@ Default: False Library - Build-Depends: base>=4.8 && < 4.12, ghc >= 7.8 && < 8.5, 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, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256 + Build-Depends: base>=4.8 && < 4.13, ghc >= 8.2 && < 8.7, 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, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256 + if impl(ghc>= 8.6) + Build-Depends: deferred-folds Exposed-Modules: ProjectM36.Error, ProjectM36.Transaction, ProjectM36.TransactionGraph, @@ -112,19 +114,19 @@ GHC-Options: -rdynamic C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c Build-Depends: unix - CC-Options: -fPIC + CC-Options: -fPIC Hs-Source-Dirs: ./src/lib Default-Language: Haskell2010 Default-Extensions: OverloadedStrings, CPP if impl(ghc>= 8) build-depends: ghc-boot, ghci - if !flag(stack) + if !flag(stack) Build-Depends: deferred-folds Executable tutd Build-Depends: base >=4.8 && <5.0, - ghc >= 7.8 && < 8.5, + ghc >= 7.8 && < 8.7, ghc-paths, project-m36, containers, @@ -152,14 +154,15 @@ directory, filepath, temporary, - megaparsec >= 5.2.0 && < 7, + megaparsec >= 5.2.0 && < 8, haskeline, random, MonadRandom, base64-bytestring, optparse-applicative, attoparsec, stm-containers >= 1.0.0, - list-t + list-t, + parser-combinators Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, @@ -187,7 +190,7 @@ Executable project-m36-server Build-Depends: base, - ghc >= 7.8 && < 8.5, + ghc >= 7.8 && < 8.7, ghc-paths, project-m36, binary, @@ -217,7 +220,7 @@ list-t, base64-bytestring Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs - GHC-Options: -Wall -threaded -rtsopts + GHC-Options: -Wall -threaded -rtsopts if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall Default-Language: Haskell2010 @@ -226,7 +229,7 @@ Executable bigrel Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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, @@ -253,7 +256,7 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/TutorialD/Interpreter.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 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 GHC-Options: -Wall -threaded Hs-Source-Dirs: ./src/bin, ., test @@ -264,7 +267,7 @@ type: exitcode-stdio-1.0 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs - Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time + Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time, parser-combinators GHC-Options: -Wall -threaded Hs-Source-Dirs: ./src/bin, ./test, . @@ -274,7 +277,7 @@ type: exitcode-stdio-1.0 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs - Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time + Build-Depends: base, HUnit, project-m36, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups, time, parser-combinators GHC-Options: -Wall -threaded Hs-Source-Dirs: ./src/bin, ./test, . @@ -299,7 +302,7 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/TransactionGraph/Persist.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, random, MonadRandom, semigroups + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, random, MonadRandom, semigroups, parser-combinators Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples Hs-Source-Dirs: ., ./src/bin GHC-Options: -Wall -threaded @@ -317,7 +320,7 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/TutorialD/Interpreter/Import/TutorialD.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, random, MonadRandom, semigroups + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36, random, MonadRandom, semigroups, parser-combinators Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples GHC-Options: -Wall -threaded Hs-Source-Dirs: ., ./src/bin @@ -397,14 +400,14 @@ Default-Extensions: OverloadedStrings type: exitcode-stdio-1.0 main-is: test/scripts.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36, random, MonadRandom, semigroups + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples GHC-Options: -Wall -threaded Hs-Source-Dirs: ., ./src/bin 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, network-transport-tcp, semigroups, attoparsec + 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, network-transport-tcp, semigroups, attoparsec, parser-combinators 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 GHC-Options: -Wall -threaded @@ -415,7 +418,7 @@ Default-Language: Haskell2010 type: exitcode-stdio-1.0 main-is: test/Server/WebSocket.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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, network-transport-tcp, semigroups + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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, network-transport-tcp, semigroups, parser-combinators Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator Default-Extensions: OverloadedStrings GHC-Options: -Wall -threaded @@ -434,7 +437,7 @@ Default-Language: Haskell2010 type: exitcode-stdio-1.0 main-is: test/Relation/Atomable.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types Default-Extensions: OverloadedStrings GHC-Options: -Wall -threaded @@ -453,7 +456,7 @@ Default-Language: Haskell2010 type: exitcode-stdio-1.0 main-is: test/TransactionGraph/Automerge.hs - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types Default-Extensions: OverloadedStrings GHC-Options: -Wall -threaded @@ -481,7 +484,7 @@ Executable handles Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 main-is: benchmark/Handles.hs Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, @@ -504,13 +507,13 @@ HS-Source-Dirs: ./src/bin if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall - + Test-Suite test-dataframe Default-Language: Haskell2010 Main-Is: test/DataFrame.hs type: exitcode-stdio-1.0 Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, 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 Default-Extensions: OverloadedStrings GHC-Options: -Wall -threaded Hs-Source-Dirs: ./src/bin, ., test/ diff --git a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs --- a/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +++ b/src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs @@ -1,5 +1,5 @@ --create a bunch of orphan instances for use with the websocket server -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module ProjectM36.Server.RemoteCallTypes.Json where import ProjectM36.AtomFunctionError diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, CPP #-} module ProjectM36.Server.WebSocket where -- while the tutd client performs TutorialD parsing on the client, the websocket server will pass tutd to be parsed and executed on the server- otherwise I have to pull in ghcjs as a dependency to allow client-side parsing- that's not appealing because then the frontend is not language-agnostic, but this could change in the future, perhaps by sending different messages over the websocket -- ideally, the wire protocol should not be exposed to a straight string-based API ala SQL, so we could make perhaps a javascript DSL which compiles to the necessary JSON- anaylyze tradeoffs @@ -23,8 +23,12 @@ import Text.Megaparsec.Error import Data.Functor +#if MIN_VERSION_megaparsec(7,0,0) +import Data.List.NonEmpty as NE +#endif + websocketProxyServer :: Port -> Hostname -> WS.ServerApp -websocketProxyServer port host pending = do +websocketProxyServer port host pending = do conn <- WS.acceptRequest pending let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text) --phase 1- accept database name for connection @@ -33,10 +37,10 @@ if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text) else do let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg - bracket (createConnection conn dbname port host) + bracket (createConnection conn dbname port host) (\case Right dbconn -> close dbconn - Left _ -> pure ()) $ \case + Left _ -> pure ()) $ \case Left err -> sendError conn err Right dbconn -> do eSessionId <- createSessionAtHead dbconn "master" @@ -47,31 +51,38 @@ _ <- forever $ do pInfo <- promptInfo sessionId dbconn --figure out why sending three times during startup is necessary - sendPromptInfo pInfo conn sendPromptInfo pInfo conn + sendPromptInfo pInfo conn msg <- WS.receiveData conn :: IO T.Text case parseOnly parseExecuteMessage msg of Left _ -> unexpectedMsg Right (presentation, tutdString) -> case parseTutorialD tutdString of - Left err -> handleOpResult conn dbconn presentation (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err))) + Left err -> handleOpResult conn dbconn presentation +#if MIN_VERSION_megaparsec(7,0,0) + (DisplayErrorResult + ("parse error: " `T.append` T.pack + (parseErrorPretty . NE.head . bundleErrors $ err))) +#else + (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err))) +#endif Right parsed -> do - let timeoutFilter exc = if exc == RequestTimeoutException - then Just exc + let timeoutFilter exc = if exc == RequestTimeoutException + then Just exc else Nothing responseHandler = do result <- evalTutorialD sessionId dbconn SafeEvaluation parsed pInfo' <- promptInfo sessionId dbconn - sendPromptInfo pInfo' conn + sendPromptInfo pInfo' conn handleOpResult conn dbconn presentation result catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn presentation (DisplayErrorResult "Request Timed Out.")) pure () - -notificationCallback :: WS.Connection -> NotificationCallback + +notificationCallback :: WS.Connection -> NotificationCallback notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName, "evaldnotification" .= evaldNotif ])) - + --this creates a new database for each connection- perhaps not what we want (?) createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection) createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn)) @@ -100,32 +111,32 @@ texto = ["text" .= showDataFrame df | textPresentation presentation] htmlo = ["html" .= dataFrameAsHTML df | htmlPresentation presentation] WS.sendTextData conn (encode (object ["displaydataframe" .= object (jsono ++ texto ++ htmlo)])) - + -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) promptInfo sessionId conn = do - eHeadName <- headName sessionId conn + eHeadName <- headName sessionId conn eSchemaName <- currentSchemaName sessionId conn pure (either (const "") id eHeadName, either (const "") id eSchemaName) - + sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO () sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]])) --a returning relation can be returned as JSON, Text (for consoles), or HTML data Presentation = Presentation { - jsonPresentation :: Bool, + jsonPresentation :: Bool, textPresentation :: Bool, htmlPresentation :: Bool } - + data PresentationFlag = JSONFlag | TextFlag | HTMLFlag - + parseExecuteMessage :: Parser (Presentation, T.Text) parseExecuteMessage = do _ <- string "executetutd/" flags <- sepBy ((string "json" $> JSONFlag) <|> (string "text" $> TextFlag) <|> (string "html" $> HTMLFlag)) "+" - let presentation = foldr (\flag acc -> case flag of + let presentation = foldr (\flag acc -> case flag of JSONFlag -> acc {jsonPresentation = True} TextFlag -> acc {textPresentation = True} HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags diff --git a/src/bin/TutorialD/Interpreter.hs b/src/bin/TutorialD/Interpreter.hs --- a/src/bin/TutorialD/Interpreter.hs +++ b/src/bin/TutorialD/Interpreter.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, LambdaCase #-} +{-# LANGUAGE GADTs, LambdaCase, CPP #-} module TutorialD.Interpreter where import TutorialD.Interpreter.Base import TutorialD.Interpreter.RODatabaseContextOperator @@ -28,7 +28,9 @@ import System.Directory (getHomeDirectory) import qualified Data.Text as T import System.IO (hPutStrLn, stderr) +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import Data.List (isPrefixOf) import Control.Exception import System.Exit @@ -59,7 +61,7 @@ fmap ImportDBContextOp (tutdImportP <* eof) <|> fmap RelVarExportOp (exportCSVP <* eof) <|> fmap DatabaseContextIOExprOp (dbContextIOExprP <* eof) - + -- the safe interpreter never reads or writes the file system safeInterpreterParserP :: Parser ParsedOperation safeInterpreterParserP = fmap RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|> @@ -76,7 +78,7 @@ promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): " where transInfo = either (const "") id eHeadName <> "/" <> either (const "") id eSchemaName - + parseTutorialD :: T.Text -> Either ParserError ParsedOperation parseTutorialD = parse interpreterParserP "" @@ -104,20 +106,20 @@ else pure res _ -> pure res - - (DatabaseContextExprOp execOp) -> - eHandler $ C.executeDatabaseContextExpr sessionId conn execOp - - (DatabaseContextIOExprOp execOp) -> + + (DatabaseContextExprOp execOp) -> + eHandler $ C.executeDatabaseContextExpr sessionId conn execOp + + (DatabaseContextIOExprOp execOp) -> if needsSafe then unsafeError else eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp - + (GraphOp execOp) -> do -- warn if the graph op could cause uncommited changes to be discarded eIsDirty <- C.disconnectedTransactionIsDirty sessionId conn - let runGraphOp = eHandler $ C.executeGraphExpr sessionId conn execOp + let runGraphOp = eHandler $ C.executeGraphExpr sessionId conn execOp settings = Settings {complete = noCompletion, historyFile = Nothing, autoAddHistory = False} @@ -141,20 +143,20 @@ pure (DisplayErrorResult "Graph operation cancelled.") else runGraphOp - + (ConvenienceGraphOp execOp) -> eHandler $ evalConvenienceGraphOp sessionId conn execOp (ROGraphOp execOp) -> do opResult <- evalROGraphOp sessionId conn execOp - case opResult of + case opResult of Left err -> barf err Right rel -> pure (DisplayRelationResult rel) - + (SchemaOp execOp) -> eHandler $ evalSchemaOperator sessionId conn execOp - - (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> + + (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> if needsSafe then unsafeError else do @@ -172,8 +174,8 @@ case exprErr of Left err -> barf err Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr) - - (ImportDBContextOp execOp) -> + + (ImportDBContextOp execOp) -> if needsSafe then unsafeError else do @@ -181,15 +183,15 @@ case eErr of Left err -> barf err Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs) - - (InfoOp execOp) -> + + (InfoOp execOp) -> if needsSafe then unsafeError else case evalInformationOperator execOp of Left err -> pure (DisplayErrorResult err) Right info -> pure (DisplayResult info) - + (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) -> --eval relexpr to relation and pass to export function if needsSafe then @@ -219,11 +221,11 @@ case eErr of Left err -> barf err Right () -> return QuietSuccessResult - -type GhcPkgPath = String + +type GhcPkgPath = String type TutorialDExec = String type CheckFS = Bool - + data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] CheckFS | RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS @@ -254,12 +256,12 @@ Just line -> do runTutorialD sessionId conn (Just (T.length prompt)) (T.pack line) reprLoop config sessionId conn - + runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () -runTutorialD sessionId conn mPromptLength tutd = +runTutorialD sessionId conn mPromptLength tutd = case parseTutorialD tutd of - Left err -> + Left err -> displayOpResult $ DisplayParseErrorResult mPromptLength err Right parsed -> catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveGeneric, CPP #-} module TutorialD.Interpreter.Base ( - module TutorialD.Interpreter.Base, + module TutorialD.Interpreter.Base, module Text.Megaparsec, -#if MIN_VERSION_megaparsec(6,0,0) +#if MIN_VERSION_megaparsec(6,0,0) module Text.Megaparsec.Char, module Control.Applicative #else @@ -35,7 +35,9 @@ import System.IO import ProjectM36.Relation.Show.Term import GHC.Generics +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import qualified Data.UUID as U import Control.Monad.Random import Data.List.NonEmpty as NE @@ -43,11 +45,17 @@ import Data.Time.Format import Control.Monad (void) +#if !MIN_VERSION_megaparsec(7,0,0) +anySingle :: Parsec Void Text (Token Text) +anySingle = anyChar +#endif + + displayOpResult :: TutorialDOperatorResult -> IO () displayOpResult QuitResult = return () displayOpResult (DisplayResult out) = TIO.putStrLn out displayOpResult (DisplayIOResult ioout) = ioout -displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in +displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in outputf stderr ("ERR: " <> err) displayOpResult QuietSuccessResult = return () displayOpResult (DisplayRelationResult rel) = do @@ -55,8 +63,13 @@ let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen TIO.putStrLn (showRelation randomlySortedRel) displayOpResult (DisplayParseErrorResult mPromptLength err) = do - let errString = T.pack (parseErrorPretty err) - errorIndent = unPos (sourceColumn (NE.head (errorPos err))) +#if MIN_VERSION_megaparsec(7,0,0) + let errorIndent = errorOffset . NE.head . bundleErrors $ err + errString = T.pack (parseErrorPretty . NE.head . bundleErrors $ err) +#else + let errorIndent = unPos (sourceColumn (NE.head (errorPos err))) + errString = T.pack (parseErrorPretty err) +#endif pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^" maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength TIO.putStr ("ERR:" <> errString) @@ -71,7 +84,7 @@ spaceConsumer :: Parser () spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}") - + opChar :: Parser Char opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces @@ -90,9 +103,13 @@ identifier :: Parser Text identifier = do istart <- letterChar <|> char '_' - irest <- many (alphaNumChar <|> char '_' <|> char '#') + identifierRemainder istart + +identifierRemainder :: Char -> Parser Text +identifierRemainder c = do + rest <- many (alphaNumChar <|> char '_' <|> char '#') spaceConsumer - pure (pack (istart:irest)) + pure (pack (c:rest)) symbol :: ParseStr -> Parser Text #if MIN_VERSION_megaparsec(6,0,0) @@ -137,20 +154,12 @@ float = Lex.float capitalizedIdentifier :: Parser Text -capitalizedIdentifier = do - fletter <- upperChar - restOfIdentifier_ fletter - -restOfIdentifier_ :: Char -> Parser Text -restOfIdentifier_ fletter = do - rest <- option "" identifier - spaceConsumer - pure (T.cons fletter rest) - +capitalizedIdentifier = + upperChar >>= identifierRemainder + uncapitalizedIdentifier :: Parser Text -uncapitalizedIdentifier = do - fletter <- lowerChar - restOfIdentifier_ fletter +uncapitalizedIdentifier = + lowerChar >>= identifierRemainder showRelationAttributes :: Attributes -> Text showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}" @@ -158,12 +167,14 @@ showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType attrsL = V.toList attrs -type PromptLength = Int +type PromptLength = Int -#if MIN_VERSION_megaparsec(6,0,0) +#if MIN_VERSION_megaparsec(7,0,0) +type ParserError = ParseErrorBundle T.Text Void +#elif MIN_VERSION_megaparsec(6,0,0) type ParserError = ParseError Char Void -#else -type ParserError = ParseError Char Dec +#else +type ParserError = ParseError Char Dec #endif data TutorialDOperatorResult = QuitResult | @@ -175,15 +186,15 @@ DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text QuietSuccessResult deriving (Generic) - + type TransactionGraphWasUpdated = Bool --allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying tripleQuotedString :: Parser Text tripleQuotedString = do _ <- tripleQuote - pack <$> manyTill anyChar (try (tripleQuote >> notFollowedBy quote)) - + pack <$> manyTill anySingle (try (tripleQuote >> notFollowedBy quote)) + normalQuotedString :: Parser Text normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote) @@ -192,7 +203,7 @@ uuidP :: Parser U.UUID uuidP = do - uuidStart <- count 8 hexDigitChar + uuidStart <- count 8 hexDigitChar _ <- char '-' -- min 28 with no dashes, maximum 4 dashes uuidMid1 <- count 4 hexDigitChar _ <- char '-' @@ -212,4 +223,3 @@ case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\"" Just stamp -> pure stamp - diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs --- a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module TutorialD.Interpreter.DatabaseContextExpr where import ProjectM36.Base import TutorialD.Interpreter.Base @@ -12,7 +13,9 @@ import qualified ProjectM36.RelationalExpression as RE import ProjectM36.Key import ProjectM36.FunctionalDependency +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import Data.Functor --parsers which create "database expressions" which modify the database context (such as relvar assignment) @@ -42,7 +45,7 @@ assignP :: Parser DatabaseContextExpr assignP = do relVarName <- try $ do - relVarName <- identifier + relVarName <- relVarNameP reservedOp ":=" return relVarName Assign relVarName <$> relExprP @@ -57,13 +60,13 @@ insertP :: Parser DatabaseContextExpr insertP = do reservedOp "insert" - relvar <- identifier + relvar <- relVarNameP Insert relvar <$> relExprP defineP :: Parser DatabaseContextExpr defineP = do relVarName <- try $ do - relVarName <- identifier + relVarName <- relVarNameP reservedOp "::" return relVarName Define relVarName <$> makeAttributeExprsP @@ -71,17 +74,17 @@ undefineP :: Parser DatabaseContextExpr undefineP = do reservedOp "undefine" - Undefine <$> identifier + Undefine <$> relVarNameP deleteP :: Parser DatabaseContextExpr deleteP = do reservedOp "delete" - Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP) + Delete <$> relVarNameP <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP) updateP :: Parser DatabaseContextExpr updateP = do reservedOp "update" - relVarName <- identifier + relVarName <- relVarNameP predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer) attributeAssignments <- M.fromList <$> parens (sepBy attributeAssignmentP comma) return $ Update relVarName attributeAssignments predicate @@ -164,7 +167,7 @@ removeTypeConstructorP :: Parser DatabaseContextExpr removeTypeConstructorP = do reserved "undata" - RemoveTypeConstructor <$> identifier + RemoveTypeConstructor <$> typeConstructorNameP removeAtomFunctionP :: Parser DatabaseContextExpr removeAtomFunctionP = do @@ -176,10 +179,13 @@ reserved "removedatabasecontextfunction" RemoveDatabaseContextFunction <$> quotedString +functionNameP :: Parser AtomFunctionName +functionNameP = uncapitalizedIdentifier + executeDatabaseContextFunctionP :: Parser DatabaseContextExpr executeDatabaseContextFunctionP = do reserved "execute" - funcName <- identifier + funcName <- functionNameP args <- parens (sepBy atomExprP comma) pure (ExecuteDatabaseContextFunction funcName args) diff --git a/src/bin/TutorialD/Interpreter/Export/Base.hs b/src/bin/TutorialD/Interpreter/Export/Base.hs --- a/src/bin/TutorialD/Interpreter/Export/Base.hs +++ b/src/bin/TutorialD/Interpreter/Export/Base.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE CPP #-} module TutorialD.Interpreter.Export.Base where import ProjectM36.Base import ProjectM36.Error +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif data RelVarDataExportOperator = RelVarDataExportOperator RelationalExpr FilePath (RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError)) diff --git a/src/bin/TutorialD/Interpreter/Import/Base.hs b/src/bin/TutorialD/Interpreter/Import/Base.hs --- a/src/bin/TutorialD/Interpreter/Import/Base.hs +++ b/src/bin/TutorialD/Interpreter/Import/Base.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE CPP #-} module TutorialD.Interpreter.Import.Base where import ProjectM36.Base import ProjectM36.Error +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif -- | import data into a relation variable data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (RelVarName -> TypeConstructorMapping -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr)) diff --git a/src/bin/TutorialD/Interpreter/RelationalExpr.hs b/src/bin/TutorialD/Interpreter/RelationalExpr.hs --- a/src/bin/TutorialD/Interpreter/RelationalExpr.hs +++ b/src/bin/TutorialD/Interpreter/RelationalExpr.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE CPP #-} + module TutorialD.Interpreter.RelationalExpr where import Text.Megaparsec +#if MIN_VERSION_megaparsec(7,0,0) +import Control.Monad.Combinators.Expr +#else import Text.Megaparsec.Expr +#endif import ProjectM36.Base import TutorialD.Interpreter.Base import TutorialD.Interpreter.Types @@ -12,12 +18,12 @@ --used in projection attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a) -attributeListP = +attributeListP = (reservedOp "all but" >> - InvertedAttributeNames . S.fromList <$> sepBy identifier comma) <|> + InvertedAttributeNames . S.fromList <$> sepBy attributeNameP comma) <|> (reservedOp "all from" >> RelationalExprAttributeNames <$> relExprP) <|> - (AttributeNames . S.fromList <$> sepBy identifier comma) + (AttributeNames . S.fromList <$> sepBy attributeNameP comma) makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) makeRelationP = do @@ -26,12 +32,12 @@ tupleExprs <- braces (sepBy tupleExprP comma) <|> pure [] pure $ MakeRelationFromExprs attrExprs tupleExprs - + --abstract data type parser- in this context, the type constructor must not include any type arguments --Either Text Int adTypeConstructorP :: Parser TypeConstructor adTypeConstructorP = do - tConsName <- capitalizedIdentifier + tConsName <- typeConstructorNameP tConsArgs <- many typeConstructorP pure $ ADTypeConstructor tConsName tConsArgs @@ -41,25 +47,25 @@ attrAssocs <- braces (sepBy tupleAtomExprP comma) --detect duplicate attribute names let dupAttrNames = dupes (sort (map fst attrAssocs)) - if not (null dupAttrNames) then + if not (null dupAttrNames) then fail ("Attribute names duplicated: " ++ show dupAttrNames) else pure (TupleExpr (M.fromList attrAssocs)) tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a) tupleAtomExprP = do - attributeName <- identifier + attributeName <- attributeNameP atomExpr <- atomExprP pure (attributeName, atomExpr) - + projectP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) projectP = Project <$> braces attributeListP renameClauseP :: Parser (T.Text, T.Text) renameClauseP = do - oldAttr <- identifier + oldAttr <- attributeNameP reservedOp "as" - newAttr <- identifier + newAttr <- attributeNameP pure (oldAttr, newAttr) renameP :: Parser (RelationalExprBase a -> RelationalExprBase a) @@ -68,7 +74,7 @@ renameList <- braces (sepBy renameClauseP comma) case renameList of [] -> pure (Restrict TruePredicate) --no-op when rename list is empty - renames -> + renames -> pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) @@ -78,7 +84,7 @@ groupClauseP = do attrs <- braces attributeListP reservedOp "as" - newAttrName <- identifier + newAttrName <- attributeNameP pure (attrs, newAttrName) groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) @@ -91,26 +97,26 @@ ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a) ungroupP = do reservedOp "ungroup" - Ungroup <$> identifier + Ungroup <$> attributeNameP extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) extendP = do reservedOp ":" Extend <$> braces extendTupleExpressionP - + semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a) semijoinP = do reservedOp "semijoin" <|> reservedOp "matching" - pure (\exprA exprB -> + pure (\exprA exprB -> Project (RelationalExprAttributeNames exprA) (Join exprA exprB)) - -antijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a) + +antijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a) antijoinP = do reservedOp "not matching" <|> reservedOp "antijoin" pure (\exprA exprB -> Difference exprA ( Project (RelationalExprAttributeNames exprA) (Join exprA exprB))) - + relOperators :: RelationalMarkerExpr a => [[Operator Parser (RelationalExprBase a)]] relOperators = [ [Postfix projectP], @@ -130,8 +136,15 @@ relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators +--allow for additional characters +attributeNameP :: Parser AttributeName +attributeNameP = uncapitalizedIdentifier + +relVarNameP :: Parser RelVarName +relVarNameP = uncapitalizedIdentifier + relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) -relVarP = RelationVariable <$> identifier <*> parseMarkerP +relVarP = RelationVariable <$> relVarNameP <*> parseMarkerP relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relTerm = parens relExprP @@ -152,13 +165,13 @@ <|> relationalBooleanExprP relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) -relationalBooleanExprP = +relationalBooleanExprP = --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 - attributeName <- identifier + attributeName <- attributeNameP reservedOp "=" AttributeEqualityPredicate attributeName <$> atomExprP @@ -175,7 +188,7 @@ attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a) attributeExtendTupleExpressionP = do - newAttr <- identifier + newAttr <- attributeNameP reservedOp ":=" AttributeExtendTupleExpr newAttr <$> atomExprP @@ -193,27 +206,27 @@ attributeAtomExprP :: Parser (AtomExprBase a) attributeAtomExprP = do _ <- string "@" - AttributeAtomExpr <$> identifier + AttributeAtomExpr <$> attributeNameP nakedAtomExprP :: Parser (AtomExprBase a) nakedAtomExprP = NakedAtomExpr <$> atomP constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a) constructedAtomExprP consume = do - dConsName <- capitalizedIdentifier + dConsName <- dataConstructorNameP dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure [] ConstructedAtomExpr dConsName dConsArgs <$> parseMarkerP - + -- used only for primitive type parsing ? atomP :: Parser Atom -atomP = stringAtomP <|> - doubleAtomP <|> - integerAtomP <|> +atomP = stringAtomP <|> + doubleAtomP <|> + integerAtomP <|> boolAtomP - + functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) -functionAtomExprP = - FunctionAtomExpr <$> identifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP +functionAtomExprP = + FunctionAtomExpr <$> uncapitalizedIdentifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) relationalAtomExprP = RelationAtomExpr <$> relExprP @@ -221,7 +234,7 @@ stringAtomP :: Parser Atom stringAtomP = TextAtom <$> quotedString -doubleAtomP :: Parser Atom +doubleAtomP :: Parser Atom doubleAtomP = DoubleAtom <$> try float integerAtomP :: Parser Atom @@ -231,20 +244,19 @@ boolAtomP = do val <- char 't' <|> char 'f' return $ BoolAtom (val == 't') - + relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) relationAtomExprP = RelationAtomExpr <$> makeRelationP withMacroExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) withMacroExprP = do reservedOp "with" - views <- parens (sepBy1 createViewP comma) + views <- parens (sepBy1 createViewP comma) With views <$> relExprP createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a) -createViewP = do - name <- identifier +createViewP = do + name <- relVarNameP reservedOp "as" expr <- relExprP pure (name, expr) - diff --git a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs --- a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module TutorialD.Interpreter.TransGraphRelationalOperator where import ProjectM36.TransGraphRelationalExpression diff --git a/src/bin/TutorialD/Interpreter/Types.hs b/src/bin/TutorialD/Interpreter/Types.hs --- a/src/bin/TutorialD/Interpreter/Types.hs +++ b/src/bin/TutorialD/Interpreter/Types.hs @@ -9,18 +9,24 @@ instance RelationalMarkerExpr () where parseMarkerP = pure () - + +typeConstructorNameP :: Parser TypeConstructorName +typeConstructorNameP = capitalizedIdentifier + +dataConstructorNameP :: Parser DataConstructorName +dataConstructorNameP = capitalizedIdentifier + -- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments. -- data *Either a b* = Left a | Right b typeConstructorDefP :: Parser TypeConstructorDef -typeConstructorDefP = ADTypeConstructorDef <$> capitalizedIdentifier <*> typeVarNamesP +typeConstructorDefP = ADTypeConstructorDef <$> typeConstructorNameP <*> typeVarNamesP typeVarNamesP :: Parser [TypeVarName] typeVarNamesP = many uncapitalizedIdentifier -- data Either a b = *Left a* | *Right b* dataConstructorDefP :: Parser DataConstructorDef -dataConstructorDefP = DataConstructorDef <$> capitalizedIdentifier <*> many dataConstructorDefArgP +dataConstructorDefP = DataConstructorDef <$> typeConstructorNameP <*> many dataConstructorDefArgP -- data *Either a b* = Left *a* | Right *b* dataConstructorDefArgP :: Parser DataConstructorDefArg @@ -47,7 +53,7 @@ monoTypeConstructorP monoTypeConstructorP :: Parser TypeConstructor -monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|> +monoTypeConstructorP = ADTypeConstructor <$> typeConstructorNameP <*> pure [] <|> TypeVariable <$> uncapitalizedIdentifier diff --git a/src/bin/TutorialD/tutd.hs b/src/bin/TutorialD/tutd.hs --- a/src/bin/TutorialD/tutd.hs +++ b/src/bin/TutorialD/tutd.hs @@ -7,7 +7,9 @@ import System.IO import Options.Applicative import System.Exit +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import Data.Maybe import qualified Data.Text as T @@ -23,6 +25,7 @@ parseHeadName :: Parser HeadName parseHeadName = option auto (long "head" <> help "Start session at head name." <> + metavar "GRAPH HEAD NAME" <> value "master" ) @@ -31,8 +34,10 @@ strOption (long "host" <> short 'h' <> help "Remote host name" <> + metavar "HOSTNAME" <> value "127.0.0.1") <*> option auto (long "port" <> + metavar "PORT NUMBER" <> short 'p' <> help "Remote port" <> value defaultServerPort) @@ -41,11 +46,12 @@ parseTutDExec :: Parser (Maybe TutorialDExec) parseTutDExec = optional $ strOption (long "exec-tutd" <> short 'e' <> + metavar "TUTORIALD" <> help "Execute TutorialD expression and exit" ) opts :: ParserInfo InterpreterConfig -opts = info parseArgs idm +opts = info (parseArgs <**> helpOption) idm connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths diff --git a/src/bin/benchmark/Handles.hs b/src/bin/benchmark/Handles.hs --- a/src/bin/benchmark/Handles.hs +++ b/src/bin/benchmark/Handles.hs @@ -6,13 +6,15 @@ import TutorialD.Interpreter import TutorialD.Interpreter.Base hiding (Parser, option) import qualified Data.Text as T +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import Control.Monad data HandlesArgs = HandlesArgs { openCloseCount :: Int, transactionCount :: Int, - dbdir :: FilePath, + dbdir :: FilePath, tutdSetup :: String, tutdIterate :: String } @@ -38,13 +40,13 @@ main :: IO () main = do args <- execParser $ info (helper <*> parseArgs) fullDesc - replicateM_ (openCloseCount args) (runOpenClose + replicateM_ (openCloseCount args) (runOpenClose (T.pack (tutdSetup args)) (T.pack (tutdIterate args)) - (transactionCount args) + (transactionCount args) (dbdir args)) - -runOpenClose :: T.Text -> T.Text -> Int -> FilePath -> IO () + +runOpenClose :: T.Text -> T.Text -> Int -> FilePath -> IO () runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback [] eConn <- connectProjectM36 connInfo @@ -54,7 +56,7 @@ eSess <- createSessionAtHead conn "master" case eSess of Left err -> error (show err) - Right session -> + Right session -> --database setup case parseTutorialD tutdSetup' of Left err -> error (show err) @@ -62,14 +64,19 @@ res <- evalTutorialD session conn UnsafeEvaluation parsed case res of DisplayErrorResult err -> error (T.unpack err) - DisplayParseErrorResult _ err -> error (parseErrorPretty err) - _ -> do + DisplayParseErrorResult _ err -> +#if MIN_VERSION_megaparsec(7,0,0) + error (errorBundlePretty err) +#else + error (parseErrorPretty err) +#endif + _ -> do replicateM_ tCount (runTransaction tutdIterate' session conn) close conn printFdCount - + runTransaction :: T.Text -> SessionId -> Connection -> IO () -runTransaction tutdIterate' sess conn = +runTransaction tutdIterate' sess conn = --run tutd on every iteration case parseTutorialD tutdIterate' of Left err -> error (show err) @@ -77,10 +84,14 @@ res <- evalTutorialD sess conn UnsafeEvaluation parsed case res of DisplayErrorResult err -> error (T.unpack err) - DisplayParseErrorResult _ err -> error (parseErrorPretty err) - _ -> do - eErr <- commit sess conn + DisplayParseErrorResult _ err -> +#if MIN_VERSION_megaparsec(7,0,0) + error (errorBundlePretty err) +#else + error (parseErrorPretty err) +#endif + _ -> do + eErr <- commit sess conn case eErr of Left err -> error (show err) Right _ -> printFdCount - diff --git a/src/bin/benchmark/bigrel.hs b/src/bin/benchmark/bigrel.hs --- a/src/bin/benchmark/bigrel.hs +++ b/src/bin/benchmark/bigrel.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import ProjectM36.Base import ProjectM36.Relation @@ -22,7 +22,9 @@ import Control.Monad.State import Control.DeepSeq import Data.Text hiding (map) +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif {- dumpcsv :: Relation -> IO () diff --git a/src/lib/ProjectM36/Atom.hs b/src/lib/ProjectM36/Atom.hs --- a/src/lib/ProjectM36/Atom.hs +++ b/src/lib/ProjectM36/Atom.hs @@ -3,7 +3,9 @@ import ProjectM36.Error import ProjectM36.DataTypes.Interval import qualified Data.Text as T +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif relationForAtom :: Atom -> Either RelationalError Relation relationForAtom (RelationAtom rel) = Right rel diff --git a/src/lib/ProjectM36/AtomType.hs b/src/lib/ProjectM36/AtomType.hs --- a/src/lib/ProjectM36/AtomType.hs +++ b/src/lib/ProjectM36/AtomType.hs @@ -139,14 +139,37 @@ -- check that type vars on the right also appear on the left -- check that the data constructor names are unique -validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> [RelationalError] -validateTypeConstructorDef tConsDef dConsList = execWriter $ do +validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> TypeConstructorMapping -> Either RelationalError () +validateTypeConstructorDef tConsDef dConsList tConsMap = do let duplicateDConsNames = dupes (L.sort (map DCD.name dConsList)) - mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames] + unless (null duplicateDConsNames) (Left (someErrors (map DataConstructorNameInUseError duplicateDConsNames))) let leftSideVars = S.fromList (TCD.typeVars tConsDef) rightSideVars = S.unions (map DCD.typeVars dConsList) varsDiff = S.difference leftSideVars rightSideVars - mapM_ tell [map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)] + when (S.size varsDiff > 0) (Left (someErrors (map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)))) + mapM_ (\dConsDef -> validateDataConstructorDef dConsDef tConsDef tConsMap) dConsList + +--check that the data constructor names are not in use (recursively) +validateDataConstructorDef :: DataConstructorDef -> TypeConstructorDef -> TypeConstructorMapping -> Either RelationalError () +validateDataConstructorDef (DataConstructorDef dConsName dConsDefArgs) tConsDef tConsMap = + case findDataConstructor dConsName tConsMap of + Just _ -> Left (DataConstructorNameInUseError dConsName) + Nothing -> + mapM_ (\arg -> validateDataConstructorDefArg arg tConsDef tConsMap) dConsDefArgs + + +validateDataConstructorDefArg :: DataConstructorDefArg -> TypeConstructorDef -> TypeConstructorMapping -> Either RelationalError () +validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor _ _)) _ _ = Right () +validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg (TypeVariable _)) _ _ = Right () +validateDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) tConsDef tConsMap = case findTypeConstructor (TC.name tCons) tConsMap of + Nothing -> + when (TC.name tCons /= TCD.name tConsDef) (Left (NoSuchTypeConstructorName (TC.name tCons))) --allows for recursively-defined types + Just (ADTypeConstructorDef _ tConsArgs, _) -> do --validate that the argument count matches- type matching can occur later + let existingCount = length tConsArgs + newCount = length (TC.arguments tCons) + when (newCount /= existingCount) (Left (ConstructedAtomArgumentCountMismatchError existingCount newCount)) + Just (PrimitiveTypeConstructorDef _ _, _) -> pure () +validateDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) _ _ = Right () atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False diff --git a/src/lib/ProjectM36/Atomable.hs b/src/lib/ProjectM36/Atomable.hs --- a/src/lib/ProjectM36/Atomable.hs +++ b/src/lib/ProjectM36/Atomable.hs @@ -56,7 +56,7 @@ -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database. toAddTypeExpr :: proxy a -> DatabaseContextExpr default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => proxy a -> DatabaseContextExpr - toAddTypeExpr _ = toAddTypeExprG (from (undefined :: a)) (toAtomType (Proxy :: Proxy a)) + toAddTypeExpr _ = toAddTypeExprG (from (error "insufficient laziness" :: a)) (toAtomType (Proxy :: Proxy a)) instance Atomable Integer where toAtom = IntegerAtom @@ -148,10 +148,10 @@ --convert to ADT list instance Atomable a => Atomable [a] where toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (Proxy :: Proxy a))) [] - toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType (Proxy :: Proxy a))) (map toAtom (x:xs)) + toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType (Proxy :: Proxy a))) (toAtom x: [toAtom xs]) fromAtom (ConstructedAtom "Empty" _ _) = [] - fromAtom (ConstructedAtom "Cons" _ (x:xs)) = fromAtom x:map fromAtom xs + fromAtom (ConstructedAtom "Cons" _ [x,y]) = fromAtom x:fromAtom y fromAtom _ = error "improper fromAtom [a]" toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (Proxy :: Proxy a))) @@ -184,17 +184,17 @@ instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where toAtomG (M1 v) = toAtomG v fromAtomG atom args = M1 <$> fromAtomG atom args - toAtomsG = undefined + toAtomsG = error "invalid toAtomsG in M1 D" toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives? where typeName = datatypeName (undefined :: M1 D c a x) - toAddTypeExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors + toAddTypeExprG ~(M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors where tcDef = ADTypeConstructorDef tcName [] dataConstructors = getConstructorsG v toAddTypeExprG _ _ = NoOperation - getConstructorsG (M1 v) = getConstructorsG v - getConstructorArgsG = undefined + getConstructorsG ~(M1 v) = getConstructorsG v + getConstructorArgsG = error "invalid getConstructorArgsG in M1 D" --constructor metadata instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where @@ -209,11 +209,11 @@ Nothing where dName = T.pack (conName (undefined :: M1 C c a x)) - fromAtomG _ _ = error "unsupported generic traversal" - toAtomsG = undefined - toAtomTypeG = undefined - toAddTypeExprG = undefined - getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs] + fromAtomG _ _ = error "invalid fromAtomG in M1 C" + toAtomsG = error "invalid toAtomsG in M1 C" + toAtomTypeG = error "invalid toAtomTypeG in M1 C" + toAddTypeExprG = error "invalid toAddTypeExprG in M1 C" + getConstructorsG ~(M1 v) = [DataConstructorDef (T.pack dName) dArgs] where dName = conName (undefined :: M1 C c a x) dArgs = getConstructorArgsG v @@ -225,9 +225,9 @@ fromAtomG atom args = M1 <$> fromAtomG atom args toAtomsG (M1 v) = toAtomsG v toAtomTypeG (M1 v) = toAtomTypeG v - toAddTypeExprG _ _ = undefined - getConstructorsG = undefined - getConstructorArgsG (M1 v) = getConstructorArgsG v + toAddTypeExprG = error "invalid toAddTypeExprG in M1 S" + getConstructorsG = error "invalid getConstructorsG in M1 S" + getConstructorArgsG ~(M1 v) = getConstructorArgsG v -- field data metadata instance (Atomable a) => AtomableG (K1 c a) where @@ -237,9 +237,9 @@ headatom [] = error "no more atoms for constructor!" toAtomsG (K1 v) = [toAtom v] toAtomTypeG _ = toAtomType (Proxy :: Proxy a) - toAddTypeExprG _ _ = undefined - getConstructorsG = undefined - getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons] + toAddTypeExprG = error "invalid toAddTypeExprG in K1" + getConstructorsG = error "invalid getConstructorsG in K1" + getConstructorArgsG ~(K1 _) = [DataConstructorDefTypeConstructorArg tCons] where tCons = typeToTypeConstructor $ toAtomType (Proxy :: Proxy a) @@ -261,39 +261,38 @@ typeToTypeConstructor (TypeVariableType tvName) = TypeVariable tvName instance AtomableG U1 where - toAtomG = undefined + toAtomG = error "invalid toAtomG in U1" fromAtomG _ _ = pure U1 toAtomsG _ = [] - toAtomTypeG = undefined - toAddTypeExprG = undefined - getConstructorsG = undefined + toAtomTypeG = error "invalid toAtomTypeG in U1" + toAddTypeExprG = error "invalid toAddTypeExprG in U1" + getConstructorsG = error "invalid getConstructorsG in U1" getConstructorArgsG _ = [] -- product types instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where toAtomG = undefined - fromAtomG atom args = (:*:) <$> fromAtomG atom [headatom args] <*> fromAtomG atom (tailatoms args) - where headatom (x:_) = x - headatom [] = error "no more atoms in head for product!" - tailatoms (_:xs) = xs - tailatoms [] = error "no more atoms in tail for product!" - toAtomTypeG = undefined + fromAtomG atom args = (:*:) <$> fromAtomG atom splitargs1 <*> fromAtomG atom splitargs2 + where splitargs1 = take splitpoint args + splitargs2 = drop splitpoint args + splitpoint = length args `div` 2 + toAtomTypeG = error "invalid toAtomTypeG in :*:" toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y - toAddTypeExprG _ _ = undefined - getConstructorsG = undefined - getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y + toAddTypeExprG = error "invalid toAddTypeExprG in :*:" + getConstructorsG = error "invalid getConstructorsG in :*:" + getConstructorArgsG ~(x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y -- sum types instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where toAtomG (L1 x) = toAtomG x toAtomG (R1 x) = toAtomG x fromAtomG atom args = (L1 <$> fromAtomG atom args) <|> (R1 <$> fromAtomG atom args) - toAtomTypeG = undefined + toAtomTypeG = error "invalid toAtomTypeG in :+:" toAtomsG (L1 x) = toAtomsG x toAtomsG (R1 x) = toAtomsG x - toAddTypeExprG _ _ = undefined + toAddTypeExprG = error "invalid toAddTypeExprG in :+:" getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x) - getConstructorArgsG = undefined + getConstructorArgsG = error "invalid getConstructorArgsG in :+:" --this represents the unimplemented generics traversals which should never be called {- diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,TypeSynonymInstances,FlexibleInstances,OverloadedStrings #-} +{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module ProjectM36.Base where diff --git a/src/lib/ProjectM36/Client.hs b/src/lib/ProjectM36/Client.hs --- a/src/lib/ProjectM36/Client.hs +++ b/src/lib/ProjectM36/Client.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, BangPatterns, PackageImports #-} +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, BangPatterns, MonoLocalBinds #-} {-| Module: ProjectM36.Client @@ -163,7 +163,6 @@ import qualified ProjectM36.Session as Sess import ProjectM36.Session import ProjectM36.Sessions -import "list-t" ListT import Data.Binary (Binary) import GHC.Generics (Generic) import Control.DeepSeq (force) diff --git a/src/lib/ProjectM36/DataFrame.hs b/src/lib/ProjectM36/DataFrame.hs --- a/src/lib/ProjectM36/DataFrame.hs +++ b/src/lib/ProjectM36/DataFrame.hs @@ -18,7 +18,9 @@ import qualified Data.Text as T import Data.Binary import Control.Arrow +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif data AttributeOrderExpr = AttributeOrderExpr AttributeName Order deriving (Show, Generic, Binary) data AttributeOrder = AttributeOrder AttributeName Order deriving (Show, Generic, Binary) @@ -161,6 +163,7 @@ where tupleFrag tup = "" <> atomAsHTML (snd tup) <> "" atomAsHTML (RelationAtom rel) = RelHTML.relationAsHTML rel + atomAsHTML (TextAtom t) = """ <> t <> """ atomAsHTML atom = atomToText atom attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text diff --git a/src/lib/ProjectM36/FileLock.hs b/src/lib/ProjectM36/FileLock.hs --- a/src/lib/ProjectM36/FileLock.hs +++ b/src/lib/ProjectM36/FileLock.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NamedFieldPuns #-} +{-# LANGUAGE CPP #-} --cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking --hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite module ProjectM36.FileLock where diff --git a/src/lib/ProjectM36/IsomorphicSchema.hs b/src/lib/ProjectM36/IsomorphicSchema.hs --- a/src/lib/ProjectM36/IsomorphicSchema.hs +++ b/src/lib/ProjectM36/IsomorphicSchema.hs @@ -14,7 +14,9 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.List as L +#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 diff --git a/src/lib/ProjectM36/Key.hs b/src/lib/ProjectM36/Key.hs --- a/src/lib/ProjectM36/Key.hs +++ b/src/lib/ProjectM36/Key.hs @@ -2,7 +2,9 @@ import ProjectM36.Base import ProjectM36.Relation import qualified Data.Set as S +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif {- keys can be implemented using inclusion dependencies as well: the count of the projection of the keys' attributes must be equal to the count of the tuples- p. 120 Database in Depth diff --git a/src/lib/ProjectM36/Relation/Show/HTML.hs b/src/lib/ProjectM36/Relation/Show/HTML.hs --- a/src/lib/ProjectM36/Relation/Show/HTML.hs +++ b/src/lib/ProjectM36/Relation/Show/HTML.hs @@ -8,7 +8,9 @@ import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Text.IO as TIO +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import qualified Data.Vector as V attributesAsHTML :: Attributes -> Text @@ -51,6 +53,7 @@ where tupleFrag tup = "" <> atomAsHTML (snd tup) <> "" atomAsHTML (RelationAtom rel) = relationAsHTML rel + atomAsHTML (TextAtom t) = """ <> t <> """ atomAsHTML atom = atomToText atom tupleSetAsHTML :: RelationTupleSet -> Text diff --git a/src/lib/ProjectM36/Relation/Show/Term.hs b/src/lib/ProjectM36/Relation/Show/Term.hs --- a/src/lib/ProjectM36/Relation/Show/Term.hs +++ b/src/lib/ProjectM36/Relation/Show/Term.hs @@ -9,7 +9,9 @@ import qualified Data.List as L import qualified Data.Text as T import Control.Arrow hiding (left) +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import ProjectM36.WCWidth --guess the width that the character will appear as in the terminal boxV :: StringType diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -430,14 +430,14 @@ let oldTypes = typeConstructorMapping currentContext tConsName = TCD.name tConsDef -- validate that the constructor's types exist - case validateTypeConstructorDef tConsDef dConsDefList of - errs@(_:_) -> pure (Left (someErrors errs)) - [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName)) - | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName)) - | otherwise -> do - let newTypes = oldTypes ++ [(tConsDef, dConsDefList)] - putStateContext $ currentContext { typeConstructorMapping = newTypes } - pure (Right ()) + case validateTypeConstructorDef tConsDef dConsDefList oldTypes of + Left err -> pure (Left err) + Right _ | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName)) + | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName)) + | otherwise -> do + let newTypes = oldTypes ++ [(tConsDef, dConsDefList)] + putStateContext $ currentContext { typeConstructorMapping = newTypes } + pure (Right ()) -- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive. evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do diff --git a/src/lib/ProjectM36/ScriptSession.hs b/src/lib/ProjectM36/ScriptSession.hs --- a/src/lib/ProjectM36/ScriptSession.hs +++ b/src/lib/ProjectM36/ScriptSession.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} +{-# LANGUAGE MagicHash, UnboxedTuples, KindSignatures, DataKinds #-} module ProjectM36.ScriptSession where import ProjectM36.Error @@ -33,7 +33,7 @@ #if __GLASGOW_HASKELL__ >= 802 import Type #elif __GLASGOW_HASKELL__ >= 710 -import Type hiding (pprTyThing) +import Type hiding (pprTyThing) #else #endif @@ -42,11 +42,11 @@ import Encoding data ScriptSession = ScriptSession { - hscEnv :: HscEnv, + hscEnv :: HscEnv, atomFunctionBodyType :: Type, dbcFunctionBodyType :: Type } - + newtype ScriptSessionError = ScriptSessionLoadError GhcException deriving (Show) @@ -70,18 +70,18 @@ homeDir ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb", homeDir ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db" ] - + let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths) - - let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted , - ghcLink = LinkInMemory, + + let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted , + ghcLink = LinkInMemory, safeHaskell = Sf_Trustworthy, safeInfer = True, safeInferred = True, --verbosity = 3, -#if __GLASGOW_HASKELL__ >= 800 +#if __GLASGOW_HASKELL__ >= 800 trustFlags = map TrustPackage required_packages, -#endif +#endif packageFlags = packageFlags dflags ++ packages, #if __GLASGOW_HASKELL__ >= 802 packageDBFlags = map PackageDB localPkgPaths @@ -94,11 +94,11 @@ applyXopts flags = foldl xopt_set flags xopts #if __GLASGOW_HASKELL__ >= 800 xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables] -#else +#else xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables] #endif gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust] - required_packages = ["base", + required_packages = ["base", "containers", "Glob", "directory", @@ -120,11 +120,15 @@ --liftIO $ traceShowM (showSDoc dflags' (ppr packages)) _ <- setSessionDynFlags dflags' let safeImportDecl mn mQual = ImportDecl { -#if __GLASGOW_HASKELL__ >= 802 +#if __GLASGOW_HASKELL__ >= 802 ideclSourceSrc = NoSourceText, #else ideclSourceSrc = Nothing, #endif + +#if __GLASGOW_HASKELL__ >= 806 + ideclExt = NoExt, +#endif ideclName = noLoc mn, ideclPkgQual = Nothing, ideclSource = False, @@ -134,6 +138,9 @@ ideclAs = mQual, ideclHiding = Nothing } +#if __GLASGOW_HASKELL__ >= 806 + :: ImportDecl (GhcPass (c :: Pass)) +#endif unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [ "Prelude", "Data.Map", @@ -150,7 +157,7 @@ mkModName = noLoc . mkModuleName #else mkModName = mkModuleName -#endif +#endif qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModName qualNam))) [ ("Data.Text", "T") ] @@ -164,7 +171,7 @@ addImport moduleNam = do ctx <- getContext setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx ) - + showType :: DynFlags -> Type -> String showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty) @@ -189,33 +196,33 @@ mErr <- typeCheckScript funcType script case mErr of Just err -> pure (Left err) - Nothing -> + Nothing -> --catch exception here --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example. -- we can't use dynCompileExpr here because Right . unsafeCoerce <$> compileExpr sScript - -typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError) + +typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError) typeCheckScript expectedType inp = do - dflags <- getSessionDynFlags + dflags <- getSessionDynFlags --catch exception for SyntaxError #if __GLASGOW_HASKELL__ >= 802 - funcType <- GHC.exprType TM_Inst (unpack inp) -#else + funcType <- GHC.exprType TM_Inst (unpack inp) +#else funcType <- GHC.exprType (unpack inp) #endif - --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType + --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType if eqType funcType expectedType then pure Nothing else pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType))) - + mangleSymbol :: Maybe String -> String -> String -> String mangleSymbol pkg module' valsym = prefixUnderscore ++ maybe "" (\p -> zEncodeString p ++ "_") pkg ++ zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure" - + type ModName = String type FuncName = String @@ -223,7 +230,7 @@ loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a) loadFunction modName funcName objPath = do -#if __GLASGOW_HASKELL__ >= 802 +#if __GLASGOW_HASKELL__ >= 802 initObjLinker RetainCAFs #else initObjLinker @@ -235,8 +242,8 @@ Nothing -> pure (Left LoadSymbolError) Just (Ptr addr) -> case addrToAny# addr of (# hval #) -> pure (Right hval) - -prefixUnderscore :: String + +prefixUnderscore :: String prefixUnderscore = case (os,arch) of ("mingw32","x86_64") -> "" diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -55,11 +55,7 @@ --unhandledMessagePolicy = Log } where - testModeHandlers = if not testBool then - [] - else - [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn)] - + testModeHandlers = [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn) | testBool] initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar EndPointAddress), EndPointAddress) Connection initServer (conn, dbname, mAddressMVar, saddress) = do diff --git a/src/lib/ProjectM36/Server/EntryPoints.hs b/src/lib/ProjectM36/Server/EntryPoints.hs --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE MonoLocalBinds #-} module ProjectM36.Server.EntryPoints where import ProjectM36.Base hiding (inclusionDependencies) import ProjectM36.IsomorphicSchema import ProjectM36.Client as C import ProjectM36.Error -import ProjectM36.DataFrame import Control.Distributed.Process (Process, ProcessId) import Control.Distributed.Process.ManagedProcess (ProcessReply) import Control.Distributed.Process.ManagedProcess.Server (reply) diff --git a/src/lib/ProjectM36/Server/ParseArgs.hs b/src/lib/ProjectM36/Server/ParseArgs.hs --- a/src/lib/ProjectM36/Server/ParseArgs.hs +++ b/src/lib/ProjectM36/Server/ParseArgs.hs @@ -3,18 +3,20 @@ import ProjectM36.Client import Options.Applicative import ProjectM36.Server.Config +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig -parseArgsWithDefaults defaults = ServerConfig <$> - parsePersistenceStrategy <*> - parseCheckFS <*> - parseDatabaseName <*> - parseHostname (bindHost defaults) <*> - parsePort (bindPort defaults) <*> - many parseGhcPkgPath <*> - parseTimeout (perRequestTimeout defaults) <*> - pure False +parseArgsWithDefaults defaults = ServerConfig <$> + parsePersistenceStrategy <*> + parseCheckFS <*> + parseDatabaseName <*> + parseHostname (bindHost defaults) <*> + parsePort (bindPort defaults) <*> + many parseGhcPkgPath <*> + parseTimeout (perRequestTimeout defaults) <*> + parseTestMode parsePersistenceStrategy :: Parser PersistenceStrategy parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|> @@ -29,6 +31,9 @@ fsyncOpt = switch (short 'f' <> long "fsync" <> help "Fsync all new transactions.") + +parseTestMode :: Parser Bool +parseTestMode = flag True False (long "test-mode" <> hidden) parseCheckFS :: Parser Bool parseCheckFS = flag True False (long "disable-fscheck" <> @@ -38,7 +43,7 @@ parseDatabaseName = strOption (short 'n' <> long "database" <> metavar "DATABASE_NAME") - + parseHostname :: Hostname -> Parser Hostname parseHostname defHostname = strOption (short 'h' <> long "hostname" <> @@ -64,4 +69,11 @@ parseConfig = parseConfigWithDefaults defaultServerConfig parseConfigWithDefaults :: ServerConfig -> IO ServerConfig -parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults) idm) +parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults <**> helpOption) idm) + + +helpOption :: Parser (a -> a) +helpOption = abortOption ShowHelpText $ mconcat + [ long "help" + , help "Show this help text" + , hidden ] diff --git a/src/lib/ProjectM36/Sessions.hs b/src/lib/ProjectM36/Sessions.hs --- a/src/lib/ProjectM36/Sessions.hs +++ b/src/lib/ProjectM36/Sessions.hs @@ -7,17 +7,18 @@ #else import qualified STMContainers.Map as StmMap import qualified STMContainers.Set as StmSet -#endif -import "list-t" ListT +#endif import ProjectM36.Attribute import ProjectM36.Base import ProjectM36.Session import ProjectM36.Relation import ProjectM36.Error import qualified Data.UUID as U -import qualified Control.Foldl as Foldl #if MIN_VERSION_stm_containers(1,0,0) +import qualified Control.Foldl as Foldl import qualified DeferredFolds.UnfoldlM as UF +#else +import "list-t" ListT #endif type Sessions = StmMap.Map SessionId Session @@ -46,5 +47,3 @@ let atomMatrix = map (\(sessionId, session) -> [uuidAtom sessionId, uuidAtom (parentId session)]) sessionAssocs pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" TextAtomType, Attribute "parentCommit" TextAtomType]) atomMatrix - - diff --git a/src/lib/ProjectM36/TransGraphRelationalExpression.hs b/src/lib/ProjectM36/TransGraphRelationalExpression.hs --- a/src/lib/ProjectM36/TransGraphRelationalExpression.hs +++ b/src/lib/ProjectM36/TransGraphRelationalExpression.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --really, a better name for this module could be "TransTransactionGraphRelationalExpr", but that name is too long module ProjectM36.TransGraphRelationalExpression where diff --git a/src/lib/ProjectM36/TransactionGraph.hs b/src/lib/ProjectM36/TransactionGraph.hs --- a/src/lib/ProjectM36/TransactionGraph.hs +++ b/src/lib/ProjectM36/TransactionGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, CPP #-} module ProjectM36.TransactionGraph where import ProjectM36.Base import ProjectM36.Error @@ -21,7 +21,9 @@ import GHC.Generics import Data.Binary import Data.Either (lefts, rights, isRight) +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import Control.Arrow import Data.Maybe @@ -486,7 +488,7 @@ backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do trans <- transactionForId currentTid graph let parents = S.toAscList (transactionParentIds trans) - if length parents < 1 then + if null parents then Left RootTransactionTraversalError else do parentTrans <- transactionForId (head parents) graph diff --git a/src/lib/ProjectM36/TransactionGraph/Persist.hs b/src/lib/ProjectM36/TransactionGraph/Persist.hs --- a/src/lib/ProjectM36/TransactionGraph/Persist.hs +++ b/src/lib/ProjectM36/TransactionGraph/Persist.hs @@ -24,7 +24,9 @@ import qualified Data.ByteString as BS import qualified Data.Text.Encoding as TE import Data.ByteString (ByteString) +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import qualified Crypto.Hash.SHA256 as SHA256 import Control.Arrow import Data.Time.Clock diff --git a/src/lib/ProjectM36/Tuple.hs b/src/lib/ProjectM36/Tuple.hs --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -86,7 +86,7 @@ mapper = mkRelationTuple attrs mkRelationTupleFromMap :: M.Map AttributeName Atom -> RelationTuple -mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (\attrName -> attrMap M.! attrName) attrNames) +mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (attrMap M.!) attrNames) where attrNames = V.fromList (M.keys attrMap) attrs = V.map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames diff --git a/src/lib/ProjectM36/Tupleable.hs b/src/lib/ProjectM36/Tupleable.hs --- a/src/lib/ProjectM36/Tupleable.hs +++ b/src/lib/ProjectM36/Tupleable.hs @@ -4,13 +4,16 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} module ProjectM36.Tupleable where import Data.Foldable import Data.List (partition) import qualified Data.Map as Map +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif import Data.Proxy import qualified Data.Text as T import qualified Data.Vector as V diff --git a/test/Relation/Atomable.hs b/test/Relation/Atomable.hs --- a/test/Relation/Atomable.hs +++ b/test/Relation/Atomable.hs @@ -1,5 +1,5 @@ --Test Atomable typeclass which allows users to use existing Haskell datatypes to marshal them to and from the database as ConstructedAtoms. -{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings, TypeApplications #-} import Test.HUnit import ProjectM36.Client import Data.Binary @@ -47,15 +47,35 @@ data Test8T = Test8C Test1T deriving (Show, Generic, Eq, Binary, NFData, Atomable) - + +data User = User + { userFirstName :: Text + , userLastName :: Text + } deriving (Eq, Ord, Show, Generic, NFData, Binary, Atomable) + +data Test9_4T = Test9_4C { + f9_41 :: Int, + f9_42 :: Int, + f9_43 :: Int, + f9_44 :: Int } + deriving (Show, Generic, Eq, Binary, NFData, Atomable) + +data Test9_5T = Test9_5C { + f9_51 :: Int, + f9_52 :: Int, + f9_53 :: Int, + f9_54 :: Int, + f9_55 :: Int + } + deriving (Show, Generic, Eq, Binary, NFData, Atomable) + main :: IO () main = do tcounts <- runTestTT testList if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess testList :: Test -testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues] - +testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testSimpleList, testListInstance, testNonEmptyInstance, testADT6Maybe, testADT7Either, testNonPrimitiveValues, testRecordType, testManyFields] -- test some basic data types like int, day, etc. testBasicMarshaling :: Test @@ -140,6 +160,12 @@ let example = TestListC [3,4,5] assertEqual "List instance" example (fromAtom (toAtom example)) +testSimpleList :: Test +testSimpleList = TestCase $ do + let example = toAtom @[Integer] [1,2,3] + expected = ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 1,ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 2,ConstructedAtom "Cons" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) [IntegerAtom 3,ConstructedAtom "Empty" (ConstructedAtomType "List" (M.fromList [("a",IntegerAtomType)])) []]]] + assertEqual "simple list" expected example + testNonEmptyInstance :: Test testNonEmptyInstance = TestCase $ do let example = TestNonEmptyC [3,4,5] @@ -149,3 +175,23 @@ testNonPrimitiveValues = TestCase $ do let example = Test8C (Test1C 3) assertEqual "non-primitive values" example (fromAtom (toAtom example)) + +testRecordType :: Test +testRecordType = TestCase $ do + let example = User { userFirstName = "Bob" + ,userLastName = "Smith" + } + assertEqual "User record" example (fromAtom (toAtom example)) + let expected = AddTypeConstructor (ADTypeConstructorDef "User" []) [DataConstructorDef "User" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType),DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Text" TextAtomType)]] + + assertEqual "User record to database context expr" expected (toAddTypeExpr (Proxy :: Proxy User)) + +--test both odd and even product types with more than 2 fields +testManyFields :: Test +testManyFields = TestCase $ do + let example4 = Test9_4C 1 2 3 4 + assertEqual "four fields product type" example4 (fromAtom (toAtom example4)) + + let example5 = Test9_5C 1 2 3 4 5 + assertEqual "five fields product type" example5 (fromAtom (toAtom example5)) + diff --git a/test/Relation/Export/CSV.hs b/test/Relation/Export/CSV.hs --- a/test/Relation/Export/CSV.hs +++ b/test/Relation/Export/CSV.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + import ProjectM36.Base import ProjectM36.Relation.Show.CSV import ProjectM36.Relation.Parse.CSV @@ -11,7 +13,11 @@ import Test.HUnit import Data.Time.Calendar import Data.Time.Clock + +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid +#endif + {- import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TE @@ -19,9 +25,9 @@ import qualified Data.ByteString.Lazy as BS -} -main :: IO () -main = do - tcounts <- runTestTT $ TestList [testCSVExport, +main :: IO () +main = do + tcounts <- runTestTT $ TestList [testCSVExport, testADTExport] if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess @@ -31,8 +37,8 @@ case res of Left err -> assertFailure (show err) >> undefined Right val -> pure val - -testADTExport :: Test + +testADTExport :: Test testADTExport = TestCase $ do let adtCSV = "a\nCons 4 (Cons 5 Empty)\n" attrs = A.attributesFromList [Attribute "a" (listAtomType IntegerAtomType)] @@ -40,17 +46,17 @@ case csvAsRelation attrs basicTypeConstructorMapping adtCSV of Left err -> assertFailure ("import failure: " <> show err) Right rel -> assertEqual "import cons list" expectedRel (Right rel) - + --round-trip various atom types through CSV export/import testCSVExport :: Test testCSVExport = TestCase $ do now <- getCurrentTime - testInterval <- assertEither $ pure (createInterval - (DateTimeAtom now) + testInterval <- assertEither $ pure (createInterval + (DateTimeAtom now) (DateTimeAtom (addUTCTime 86400 now)) True False) - let attrs = A.attributesFromList [Attribute "textattr" TextAtomType, + let attrs = A.attributesFromList [Attribute "textattr" TextAtomType, Attribute "integerattr" IntegerAtomType, Attribute "dayattr" DayAtomType, Attribute "datetimeattr" DateTimeAtomType, @@ -61,8 +67,8 @@ ] sampleByteString = "\1\0\244\34\150" relOrErr = mkRelationFromList attrs [ - [TextAtom "text atom with \"quote\"", - IntegerAtom 123, + [TextAtom "text atom with \"quote\"", + IntegerAtom 123, DayAtom (fromGregorian 2017 4 10), DateTimeAtom now, ByteStringAtom sampleByteString, @@ -70,19 +76,19 @@ listCons TextAtomType [TextAtom "text1", TextAtom "text2"], testInterval ], - [TextAtom "second text atom with 漢字", - IntegerAtom 314, + [TextAtom "second text atom with 漢字", + IntegerAtom 314, DayAtom (fromGregorian 1001 6 28), DateTimeAtom (addUTCTime 360 now), - ByteStringAtom sampleByteString, + ByteStringAtom sampleByteString, listCons IntegerAtomType [IntegerAtom 10, IntegerAtom 11, IntegerAtom 12], listCons TextAtomType [TextAtom "text5\"", TextAtom "text6\r\n"], testInterval ]] - - case relOrErr of + + case relOrErr of Left err -> assertFailure $ "export relation creation failure: " ++ show err - Right rel -> + Right rel -> case relationAsCSV rel of Left err -> assertFailure $ "export failed: " ++ show err Right csvData -> @@ -91,4 +97,3 @@ case csvAsRelation attrs basicTypeConstructorMapping csvData of -- import csv data back to relation Left err -> assertFailure $ "re-import failed: " ++ show err Right rel' -> assertEqual "relation CSV comparison" rel rel' - diff --git a/test/Relation/Tupleable.hs b/test/Relation/Tupleable.hs --- a/test/Relation/Tupleable.hs +++ b/test/Relation/Tupleable.hs diff --git a/test/TutorialD/Interpreter.hs b/test/TutorialD/Interpreter.hs --- a/test/TutorialD/Interpreter.hs +++ b/test/TutorialD/Interpreter.hs @@ -73,7 +73,9 @@ testNonEmptyListType, testUnresolvedAtomTypes, testWithClause, - testAtomFunctionArgumentMismatch + testAtomFunctionArgumentMismatch, + testInvalidDataConstructor, + testBasicList ] simpleRelTests = [("x:=true", Right relationTrue), ("x:=false", Right relationFalse), @@ -642,3 +644,15 @@ --wrong argument count let err2 = "FunctionArgumentCountMismatchError" expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)" + +testInvalidDataConstructor :: Test +testInvalidDataConstructor = TestCase $ do + --test that a referenced TypeConstructor in a DataConstructor definition matches the expected count of arguments + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + let err1 = "ConstructedAtomArgumentCountMismatchError" + expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "data TestT = TestT Maybe Int" + +testBasicList :: Test +testBasicList = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD sessionId dbconn "x := relation{tuple{ a (Cons 1 (Cons 2 Empty)) }}" diff --git a/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs b/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs --- a/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs +++ b/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs @@ -38,7 +38,7 @@ (sess, conn) <- dateExamplesConnection emptyNotificationCallback let addfunc = "adddatabasecontextfunction \"bomb\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] _ -> error \"boom\") :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\"" executeTutorialD sess conn addfunc - expectTutorialDErr sess conn (\err -> "UnhandledExceptionError" `T.isPrefixOf` err) "execute bomb()" + expectTutorialDErr sess conn ("UnhandledExceptionError" `T.isPrefixOf`) "execute bomb()" testDBCFunctionWithAtomArguments :: Test