diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,12 @@ +# 2022-08-19 (v0.9.5) + +* removed necessity for caret "^" when using boolean atom expressions in restriction predicates +* `True` and `False` are now value constructors for `Bool` atom values (previously `t` and `f); changed for better discoverability by Haskell developers +* add `Scientific` data type for arbitrary-precision values (backed by Data.Scientific) +* add support for GHC 9.0 and GHC 9.2 +* drop support for GHC < 8.10.7 +* fix relational equality when the relation includes a nested relation + # 2021-12-05 (v0.9.4) * fix bug which [caused tuple storage to be duplicated unnecessarily](https://github.com/agentm/project-m36/pull/328) diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -61,6 +61,7 @@ 1. [Developer's Change Log](Changelog.markdown) 1. [Simple Client API](docs/simple_api.markdown) 1. [CSV Import/Export](docs/import_export_csv.markdown) +1. [Developer Setup](docs/dev_setup.markdown) ### Database Comparisons @@ -94,7 +95,7 @@ ## Development -Project:M36 is developed in Haskell and compiled with GHC 8.6 or later. +Project:M36 is developed in Haskell and compiled with GHC 8.8 or later. ## Related Projects diff --git a/examples/DerivingCustomTupleable.hs b/examples/DerivingCustomTupleable.hs --- a/examples/DerivingCustomTupleable.hs +++ b/examples/DerivingCustomTupleable.hs @@ -4,7 +4,6 @@ import ProjectM36.Atomable (Atomable) import Control.DeepSeq (NFData) import Data.Text (Text) -import GHC.Generics (Generic) import Codec.Winery newtype BlogId = BlogId { getBlogId :: Int } diff --git a/examples/blog.hs b/examples/blog.hs --- a/examples/blog.hs +++ b/examples/blog.hs @@ -29,7 +29,7 @@ import Text.Blaze.Html.Renderer.Text import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status -import Data.Time.Format +import Data.Time.Format.ISO8601 --define your data types data Blog = Blog { @@ -166,7 +166,7 @@ blogRestrictionExpr (RelationVariable "blog" ()))) let render = html . renderHtml - formatStamp = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) + formatStamp = iso8601Show --formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) case eRel of Left err -> render500 (toHtml (show err)) --handle successful query execution diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36 -Version: 0.9.4 +Version: 0.9.5 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple @@ -35,9 +35,9 @@ Default: True Library - Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery, curryer-rpc, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible + Build-Depends: base>=4.8 && < 4.17, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery >= 1.4, curryer-rpc>=0.2.2, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible, fast-builder, scientific, time-compat >= 1.9.6.1 if flag(haskell-scripting) - Build-Depends: ghc >= 8.2 && < 8.11 + Build-Depends: ghc >= 8.2 && < 9.3 CPP-Options: -DPM36_HASKELL_SCRIPTING if impl(ghc>= 8) && flag(haskell-scripting) build-depends: @@ -130,27 +130,28 @@ ProjectM36.GraphRefRelationalExpr, ProjectM36.NormalizeExpr, ProjectM36.TransactionInfo, - ProjectM36.WithNameExpr + ProjectM36.WithNameExpr, + ProjectM36.Trace GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.5.4.1 Other-Modules: ProjectM36.Win32Handle else --219- too many exported symbols under Windows and GHC 8.4 - GHC-Options: -rdynamic -fexternal-interpreter + GHC-Options: -rdynamic -fexternal-interpreter -eventlog C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c Build-Depends: unix CC-Options: -fPIC Hs-Source-Dirs: ./src/lib Default-Language: Haskell2010 - Default-Extensions: OverloadedStrings, CPP + Default-Extensions: OverloadedStrings, CPP, LambdaCase if !flag(stack) - Build-Depends: deferred-folds + Build-Depends: deferred-folds Executable tutd if flag(haskell-scripting) - Build-Depends: ghc >= 8.2 && < 8.11 - Build-Depends: base >=4.8 && <5.0, + Build-Depends: ghc >= 8.2 && < 9.3 + Build-Depends: base >=4.8, ghc-paths, project-m36, containers, @@ -165,7 +166,6 @@ vector, text, time, - hashable-time, bytestring, stm, deepseq, @@ -210,21 +210,23 @@ TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TransGraphRelationalOperator, - TutorialD.Interpreter.SchemaOperator + TutorialD.Interpreter.SchemaOperator, TutorialD.Printer main-is: TutorialD/tutd.hs CC-Options: -fPIC if os(windows) - GHC-Options: -Wall -threaded + GHC-Options: -Wall -threaded -eventlog -rtsopts else - GHC-Options: -Wall -threaded -rdynamic + GHC-Options: -Wall -threaded -rdynamic -eventlog -rtsopts + if flag(profiler) + GHC-Prof-Options: -fprof-auto -rtsopts -threaded Hs-Source-Dirs: ./src/bin Default-Language: Haskell2010 Default-Extensions: OverloadedStrings Executable project-m36-server if flag(haskell-scripting) - Build-Depends: ghc >= 8.2 && < 8.11 + Build-Depends: ghc >= 8.2 && < 9.3 Build-Depends: base, ghc-paths, transformers, @@ -239,7 +241,6 @@ parallel, bytestring, optparse-applicative, - hashable-time, time, text, deepseq-generics, @@ -251,12 +252,13 @@ http-api-data, stm-containers, list-t, - base64-bytestring + base64-bytestring, + scientific Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs if os(windows) GHC-Options: -Wall -threaded -rtsopts else - GHC-Options: -Wall -threaded -rtsopts -rdynamic + GHC-Options: -Wall -threaded -rtsopts -rdynamic if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall Default-Language: Haskell2010 @@ -265,7 +267,7 @@ Executable bigrel Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.RelationalExpr, @@ -274,11 +276,11 @@ GHC-Options: -Wall -threaded -rtsopts HS-Source-Dirs: ./src/bin if flag(profiler) - GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall + GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall -eventlog Common commontest Default-Language: Haskell2010 - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring,cryptohash-sha256 + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256, scientific Default-Extensions: OverloadedStrings GHC-Options: -Wall -threaded Hs-Source-Dirs: test, src/bin @@ -311,7 +313,7 @@ type: exitcode-stdio-1.0 main-is: TutorialD/InterpreterTest.hs Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, scientific Test-Suite test-tutoriald-atomfunctionscript import: commontest @@ -383,28 +385,28 @@ Executable Example-SimpleClient Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36, random, MonadRandom + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36, random, MonadRandom Main-Is: examples/SimpleClient.hs GHC-Options: -Wall -threaded Executable Example-OutOfTheTarpit Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery Main-Is: examples/out_of_the_tarpit.hs GHC-Options: -Wall -threaded Executable Example-Blog Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery Main-Is: examples/blog.hs GHC-Options: -Wall -threaded Executable Example-Hair Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery Main-Is: examples/hair.hs GHC-Options: -Wall -threaded @@ -418,7 +420,7 @@ Executable Example-CustomTupleable Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery Main-Is: examples/CustomTupleable.hs GHC-Options: -Wall -threaded @@ -440,7 +442,7 @@ Executable project-m36-websocket-server Default-Language: Haskell2010 - Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls + Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls, scientific Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer GHC-Options: -Wall -threaded @@ -489,7 +491,7 @@ Executable handles Default-Language: Haskell2010 Default-Extensions: OverloadedStrings - Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256 + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256 main-is: benchmark/Handles.hs Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, @@ -507,7 +509,7 @@ TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, - TutorialD.Interpreter.Types + TutorialD.Interpreter.Types, TutorialD.Printer GHC-Options: -Wall -threaded -rtsopts HS-Source-Dirs: ./src/bin 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 @@ -18,6 +18,7 @@ import Data.Text.Encoding import Data.Time.Calendar import Data.UUID +import Data.Scientific instance ToJSON RelationalExpr instance FromJSON RelationalExpr @@ -92,6 +93,8 @@ "val" .= i ] toJSON atom@(DoubleAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] + toJSON atom@(ScientificAtom i) = object [ "type" .= atomTypeForAtom atom, + "val" .= (coefficient i, base10Exponent i) ] toJSON atom@(TextAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] toJSON atom@(DayAtom i) = object [ "type" .= atomTypeForAtom atom, @@ -123,6 +126,9 @@ RelationAtomType _ -> RelationAtom <$> o .: "val" IntAtomType -> IntAtom <$> o .: "val" IntegerAtomType -> IntegerAtom <$> o .: "val" + ScientificAtomType -> do + (c,e) <- o .: "val" + pure (ScientificAtom (scientific c e)) DoubleAtomType -> DoubleAtom <$> o .: "val" TextAtomType -> TextAtom <$> o .: "val" DayAtomType -> do diff --git a/src/bin/ProjectM36/Server/WebSocket/websocket-server.hs b/src/bin/ProjectM36/Server/WebSocket/websocket-server.hs --- a/src/bin/ProjectM36/Server/WebSocket/websocket-server.hs +++ b/src/bin/ProjectM36/Server/WebSocket/websocket-server.hs @@ -2,7 +2,7 @@ import Control.Concurrent import Control.Exception -import Control.Monad (when) +import Control.Monad (when, void) import Data.Maybe (isJust) import Data.String (fromString) import Network.HTTP.Types (status400) @@ -35,7 +35,7 @@ when (isJust configCertificateFile /= isJust configKeyFile) $ throwIO $ ErrorCall "TLS_CERTIFICATE_PATH and TLS_KEY_PATH must be set in tandem" - _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure) + _ <- forkFinally (void (launchServer serverConfig' (Just addressMVar))) (either throwIO pure) --wait for server to be listening addr <- takeMVar addressMVar let port = 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 @@ -150,16 +150,13 @@ relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators -relVarNameP :: Parser RelVarName -relVarNameP = try uncapitalizedIdentifier <|> quotedIdentifier - relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relVarP = RelationVariable <$> relVarNameP <*> parseMarkerP relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relTerm = parens relExprP <|> makeRelationP - <|> relVarP + <|> (relVarP <* notFollowedBy "(") restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) restrictionPredicateP = makeExprParser predicateTerm predicateOperators @@ -170,14 +167,14 @@ [InfixL (reservedOp "or" >> return OrPredicate)] ] predicateTerm = try (parens restrictionPredicateP) - <|> try restrictionAtomExprP <|> try restrictionAttributeEqualityP - <|> relationalBooleanExprP + <|> try relationalBooleanExprP + <|> restrictionAtomExprP + relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) -relationalBooleanExprP = +relationalBooleanExprP = RelationalExprPredicate <$> (parens relExprP <|> relTerm) --we can't actually detect if the type is relational boolean, so we just pass it to the next phase - RelationalExprPredicate <$> (parens relExprP <|> relTerm) restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) restrictionAttributeEqualityP = do @@ -185,10 +182,8 @@ reservedOp "=" AttributeEqualityPredicate attributeName <$> atomExprP -restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean" -restrictionAtomExprP = do - _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar - (try (char 't') >> pure TruePredicate) <|> (try (char 'f') >> pure (NotPredicate TruePredicate)) <|> AtomExprPredicate <$> atomExprP +restrictionAtomExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean" +restrictionAtomExprP = AtomExprPredicate <$> consumeAtomExprP False multiTupleExpressionP :: RelationalMarkerExpr a => Parser [ExtendTupleExprBase a] multiTupleExpressionP = sepBy extendTupleExpressionP comma @@ -254,7 +249,7 @@ boolAtomP :: Parser Atom boolAtomP = do v <- identifier - if v == "t" || v == "f" then + if v == "True" || v == "False" then pure $ BoolAtom (v == "t") else fail "invalid boolAtom" 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 @@ -69,5 +69,5 @@ TypeVariable <$> typeVariableIdentifierP - - +relVarNameP :: Parser RelVarName +relVarNameP = try uncapitalizedIdentifier <|> quotedIdentifier diff --git a/src/bin/TutorialD/Printer.hs b/src/bin/TutorialD/Printer.hs --- a/src/bin/TutorialD/Printer.hs +++ b/src/bin/TutorialD/Printer.hs @@ -19,6 +19,7 @@ instance Pretty Atom where pretty (IntegerAtom x) = pretty x pretty (IntAtom x) = "int" <> parensList [pretty x] + pretty (ScientificAtom s) = "scientific" <> parensList [dquotes (pretty (show s))] pretty (DoubleAtom x) = pretty x pretty (TextAtom x) = dquotes (pretty x) pretty (DayAtom x) = "fromGregorian" <> parensList [pretty a, pretty b, pretty c] @@ -26,7 +27,7 @@ (a,b,c) = toGregorian x pretty (DateTimeAtom time) = "dateTimeFromEpochSeconds" <> parensList [pretty @Integer (round (utcTimeToPOSIXSeconds time))] pretty (ByteStringAtom bs) = "bytestring" <> parensList [dquotes (pretty (TE.decodeUtf8 (B64.encode bs)))] - pretty (BoolAtom x) = if x then "t" else "f" + pretty (BoolAtom x) = if x then "True" else "False" pretty (UUIDAtom u) = pretty u pretty (RelationAtom x) = pretty x pretty (RelationalExprAtom re) = pretty re @@ -70,7 +71,7 @@ pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet) instance Pretty Attribute where - pretty (Attribute n aTy) = pretty n <+> pretty (show aTy) -- workaround + pretty (Attribute n aTy) = pretty n <+> pretty aTy instance Pretty RelationalExpr where pretty (RelationVariable n _) = pretty n @@ -129,6 +130,7 @@ instance Pretty AtomType where pretty IntAtomType = "Int" pretty IntegerAtomType = "Integer" + pretty ScientificAtomType = "Scientific" pretty DoubleAtomType = "Double" pretty TextAtomType = "Text" pretty DayAtomType = "Day" diff --git a/src/lib/ProjectM36/Arbitrary.hs b/src/lib/ProjectM36/Arbitrary.hs --- a/src/lib/ProjectM36/Arbitrary.hs +++ b/src/lib/ProjectM36/Arbitrary.hs @@ -18,10 +18,14 @@ import Data.Time import Control.Monad.Reader import Data.UUID +import Data.Scientific arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom) arbitrary' IntegerAtomType = Right . IntegerAtom <$> lift (arbitrary :: Gen Integer) + +arbitrary' ScientificAtomType = + Right . ScientificAtom <$> lift (arbitrary :: Gen Scientific) arbitrary' (RelationAtomType attrs) = do tcMap <-ask 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 @@ -14,6 +14,7 @@ atomToText :: Atom -> T.Text atomToText (IntegerAtom i) = (T.pack . show) i atomToText (IntAtom i) = (T.pack . show) i +atomToText (ScientificAtom s) = (T.pack . show) s atomToText (DoubleAtom i) = (T.pack . show) i atomToText (TextAtom i) = (T.pack . show) i --quotes necessary for ConstructedAtom subatoms atomToText (DayAtom i) = (T.pack . show) i diff --git a/src/lib/ProjectM36/AtomFunction.hs b/src/lib/ProjectM36/AtomFunction.hs --- a/src/lib/ProjectM36/AtomFunction.hs +++ b/src/lib/ProjectM36/AtomFunction.hs @@ -29,7 +29,11 @@ emptyAtomFunction :: FunctionName -> AtomFunction emptyAtomFunction name = Function { funcName = name, funcType = [TypeVariableType "a", TypeVariableType "a"], - funcBody = FunctionBuiltInBody (\(x:_) -> pure x) } + funcBody = FunctionBuiltInBody $ + \case + x:_ -> pure x + _ -> Left AtomFunctionTypeMismatchError + } -- | AtomFunction constructor for compiled-in functions. diff --git a/src/lib/ProjectM36/AtomFunctionError.hs b/src/lib/ProjectM36/AtomFunctionError.hs --- a/src/lib/ProjectM36/AtomFunctionError.hs +++ b/src/lib/ProjectM36/AtomFunctionError.hs @@ -6,6 +6,7 @@ data AtomFunctionError = AtomFunctionUserError String | AtomFunctionTypeMismatchError | + AtomFunctionParseError String | InvalidIntervalOrderingError | InvalidIntervalBoundariesError | InvalidIntBoundError | diff --git a/src/lib/ProjectM36/AtomFunctions/Primitive.hs b/src/lib/ProjectM36/AtomFunctions/Primitive.hs --- a/src/lib/ProjectM36/AtomFunctions/Primitive.hs +++ b/src/lib/ProjectM36/AtomFunctions/Primitive.hs @@ -9,28 +9,45 @@ import Control.Monad import qualified Data.UUID as U import qualified Data.Text as T +import qualified Data.Attoparsec.Text as APT +import Data.Scientific primitiveAtomFunctions :: AtomFunctions primitiveAtomFunctions = HS.fromList [ --match on any relation type Function { funcName = "add", funcType = [IntegerAtomType, IntegerAtomType, IntegerAtomType], - funcBody = body (\(IntegerAtom i1:IntegerAtom i2:_) -> pure (IntegerAtom (i1 + i2)))}, + funcBody = body (\case + IntegerAtom i1:IntegerAtom i2:_ -> pure (IntegerAtom (i1 + i2)) + _ -> Left AtomFunctionTypeMismatchError)}, Function { funcName = "id", funcType = [TypeVariableType "a", TypeVariableType "a"], - funcBody = body (\(x:_) -> pure x)}, + funcBody = body (\case + x:_ -> pure x + _ -> Left AtomFunctionTypeMismatchError + )}, Function { funcName = "sum", funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, - funcBody = body (\(RelationAtom rel:_) -> relationSum rel)}, + funcBody = body $ relationAtomFunc relationSum + }, Function { funcName = "count", funcType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType, - funcBody = body (\(RelationAtom relIn:_) -> relationCount relIn)}, + funcBody = body $ relationAtomFunc relationCount + }, Function { funcName = "max", funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, - funcBody = body (\(RelationAtom relIn:_) -> relationMax relIn)}, + funcBody = body $ relationAtomFunc relationMax + }, Function { funcName = "min", funcType = foldAtomFuncType IntegerAtomType IntegerAtomType, - funcBody = body (\(RelationAtom relIn:_) -> relationMin relIn)}, + funcBody = body $ relationAtomFunc relationMin + }, + Function { funcName = "eq", + funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType], + funcBody = body $ \case + [i1,i2] -> pure (BoolAtom (i1 == i2)) + _ -> Left AtomFunctionTypeMismatchError + }, Function { funcName = "lt", funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType], funcBody = body $ integerAtomFuncLessThan False}, @@ -45,31 +62,42 @@ funcBody = body $ integerAtomFuncLessThan True >=> boolAtomNot}, Function { funcName = "not", funcType = [BoolAtomType, BoolAtomType], - funcBody = body $ \(b:_) -> boolAtomNot b }, + funcBody = body $ \case + [b] -> boolAtomNot b + _ -> Left AtomFunctionTypeMismatchError + }, Function { funcName = "int", funcType = [IntegerAtomType, IntAtomType], funcBody = - body $ \(IntegerAtom v:_) -> - if v < fromIntegral (maxBound :: Int) then - - pure (IntAtom (fromIntegral v)) - else - Left InvalidIntBoundError + body $ \case + [IntegerAtom v] -> + if v < fromIntegral (maxBound :: Int) then + pure (IntAtom (fromIntegral v)) + else + Left InvalidIntBoundError + _ -> Left AtomFunctionTypeMismatchError }, Function { funcName = "integer", funcType = [IntAtomType, IntegerAtomType], - funcBody = body $ \(IntAtom v:_) -> Right $ IntegerAtom $ fromIntegral v}, + funcBody = body $ \case + [IntAtom v] -> Right $ IntegerAtom $ fromIntegral v + _ -> Left AtomFunctionTypeMismatchError + }, Function { funcName = "uuid", funcType = [TextAtomType, UUIDAtomType], - funcBody = body $ \(TextAtom v:_) -> - let mUUID = U.fromString (T.unpack v) in - case mUUID of - Just u -> pure $ UUIDAtom u - Nothing -> Left $ InvalidUUIDString v + funcBody = body $ \case + [TextAtom v] -> + let mUUID = U.fromString (T.unpack v) in + case mUUID of + Just u -> pure $ UUIDAtom u + Nothing -> Left $ InvalidUUIDString v + _ -> Left AtomFunctionTypeMismatchError } - ] + ] <> scientificAtomFunctions where body = FunctionBuiltInBody + relationAtomFunc f [RelationAtom x] = f x + relationAtomFunc _ _ = Left AtomFunctionTypeMismatchError integerAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom integerAtomFuncLessThan equality (IntegerAtom i1:IntegerAtom i2:_) = pure (BoolAtom (i1 `op` i2)) @@ -112,3 +140,44 @@ castInteger :: Atom -> Integer castInteger (IntegerAtom i) = i castInteger _ = error "attempted to cast non-IntegerAtom to Int" + + +scientificAtomFunctions :: AtomFunctions +scientificAtomFunctions = HS.fromList [ + Function { funcName = "read_scientific", + funcType = [TextAtomType, ScientificAtomType], + funcBody = body $ \case + TextAtom t:_ -> + case APT.parseOnly (APT.scientific <* APT.endOfInput) t of + Left err -> Left (AtomFunctionParseError err) + Right sci -> pure (ScientificAtom sci) + _ -> Left AtomFunctionTypeMismatchError + }, + Function { funcName = "scientific", + funcType = [IntegerAtomType, IntAtomType, ScientificAtomType], + funcBody = body $ \case + [IntegerAtom c,IntAtom e] -> pure (ScientificAtom $ scientific c e) + _ -> Left AtomFunctionTypeMismatchError + }, + Function { funcName = "scientific_add", + funcType = binaryFuncType, + funcBody = binaryFuncBody (+) + }, + Function { funcName = "scientific_subtract", + funcType = binaryFuncType, + funcBody = binaryFuncBody (-) + }, + Function { funcName = "scientific_multiply", + funcType = binaryFuncType, + funcBody = binaryFuncBody (*) + }, + Function { funcName = "scientific_divide", + funcType = binaryFuncType, + funcBody = binaryFuncBody (/) + } + ] + where body = FunctionBuiltInBody + binaryFuncType = [ScientificAtomType, ScientificAtomType, ScientificAtomType] + binaryFuncBody op = body $ \case + [ScientificAtom s1, ScientificAtom s2] -> pure (ScientificAtom (s1 `op` s2)) + _ -> Left AtomFunctionTypeMismatchError 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 @@ -204,10 +204,11 @@ --reconcile the atom-in types with the type constructors isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Either RelationalError () -isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Left (AtomTypeMismatchError expectedAType aType) else pure () +isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = + when (expectedAType /= aType) $ Left (AtomTypeMismatchError expectedAType aType) --lookup constructor name and check if the incoming atom types are valid -isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Left (TypeConstructorNameMismatch expectedTConsName tConsName) else pure () +isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = when (tConsName /= expectedTConsName) $ Left (TypeConstructorNameMismatch expectedTConsName tConsName) isValidAtomTypeForTypeConstructor (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) tConsMap = do evaldAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap M.empty) attrExprs @@ -320,10 +321,7 @@ validateAttributes :: TypeConstructorMapping -> Attributes -> Either RelationalError () validateAttributes tConss attrs = - if not (null errs) then - Left (someErrors errs) - else - pure () + unless (null errs) $ Left (someErrors errs) where errs = lefts $ map (`validateAtomType` tConss) (A.atomTypesList attrs) @@ -410,12 +408,15 @@ resolveTypeVariable _ _ = M.empty resolveFunctionReturnValue :: FunctionName -> TypeVarMap -> AtomType -> Either RelationalError AtomType -resolveFunctionReturnValue funcName' tvMap (ConstructedAtomType tCons retMap) = do - let diff = M.difference retMap tvMap - if M.null diff then - pure (ConstructedAtomType tCons (M.intersection tvMap retMap)) - else - Left (AtomFunctionTypeVariableResolutionError funcName' (fst (head (M.toList diff)))) +resolveFunctionReturnValue funcName' tvMap ctype@(ConstructedAtomType tCons retMap) = + if isResolvedType ctype then + pure ctype + else do + let diff = M.difference retMap tvMap + if M.null diff then + pure (ConstructedAtomType tCons (M.intersection tvMap retMap)) + else + Left (AtomFunctionTypeVariableResolutionError funcName' (fst (head (M.toList diff)))) resolveFunctionReturnValue funcName' tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName' tvName) Just typ -> pure typ @@ -436,6 +437,7 @@ case typ of IntAtomType -> True IntegerAtomType -> True + ScientificAtomType -> True DoubleAtomType -> True TextAtomType -> True DayAtomType -> True 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 @@ -241,6 +241,7 @@ typeToTypeConstructor :: AtomType -> TypeConstructor typeToTypeConstructor x@IntAtomType = PrimitiveTypeConstructor "Int" x typeToTypeConstructor x@IntegerAtomType = PrimitiveTypeConstructor "Integer" x +typeToTypeConstructor x@ScientificAtomType = PrimitiveTypeConstructor "Scientific" x typeToTypeConstructor x@DoubleAtomType = PrimitiveTypeConstructor "Double" x typeToTypeConstructor x@TextAtomType = PrimitiveTypeConstructor "Text" x typeToTypeConstructor x@DayAtomType = PrimitiveTypeConstructor "Day" x 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,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module ProjectM36.Base where @@ -20,12 +20,13 @@ import qualified Data.List as L import Data.Text (Text) import Data.Time.Clock -import Data.Hashable.Time () +import Data.Time.Clock.Compat () import Data.Time.Calendar (Day) import Data.Typeable import Data.ByteString (ByteString) import qualified Data.List.NonEmpty as NE import Data.Vector.Instances () +import Data.Scientific type StringType = Text @@ -44,25 +45,27 @@ #endif -- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys. -data Atom = IntegerAtom Integer | - IntAtom Int | - DoubleAtom Double | - TextAtom Text | - DayAtom Day | - DateTimeAtom UTCTime | - ByteStringAtom ByteString | - BoolAtom Bool | - UUIDAtom UUID | - RelationAtom Relation | - RelationalExprAtom RelationalExpr | --used for returning inc deps - ConstructedAtom DataConstructorName AtomType [Atom] +data Atom = IntegerAtom !Integer | + IntAtom !Int | + ScientificAtom !Scientific | + DoubleAtom !Double | + TextAtom !Text | + DayAtom !Day | + DateTimeAtom !UTCTime | + ByteStringAtom !ByteString | + BoolAtom !Bool | + UUIDAtom !UUID | + RelationAtom !Relation | + RelationalExprAtom !RelationalExpr | --used for returning inc deps + ConstructedAtom !DataConstructorName !AtomType [Atom] deriving (Eq, Show, Typeable, NFData, Generic, Read) instance Hashable Atom where hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms `hashWithSalt` dConsName --AtomType is not hashable hashWithSalt salt (IntAtom i) = salt `hashWithSalt` i - hashWithSalt salt (IntegerAtom i) = salt `hashWithSalt` i + hashWithSalt salt (IntegerAtom i) = salt `hashWithSalt` i + hashWithSalt salt (ScientificAtom s) = salt `hashWithSalt` s hashWithSalt salt (DoubleAtom d) = salt `hashWithSalt` d hashWithSalt salt (TextAtom t) = salt `hashWithSalt` t hashWithSalt salt (DayAtom d) = salt `hashWithSalt` d @@ -77,6 +80,7 @@ -- | The AtomType uniquely identifies the type of a atom. data AtomType = IntAtomType | IntegerAtomType | + ScientificAtomType | DoubleAtomType | TextAtomType | DayAtomType | @@ -102,6 +106,10 @@ isRelationAtomType (RelationAtomType _) = True isRelationAtomType _ = False +-- subrelations sometimes require special paths +attributesContainRelationAtomType :: Attributes -> Bool +attributesContainRelationAtomType attrs = V.null (V.filter (\(Attribute _ t) -> isRelationAtomType t) (attributesVec attrs)) + -- | The AttributeName is the name of an attribute in a relation. type AttributeName = StringType @@ -124,7 +132,9 @@ attributesSet = HS.fromList . V.toList . attributesVec instance Show Attributes where - show attrs = "attributesFromList [" <> L.intercalate ", " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]" + showsPrec d attrs = showString $ parens $ "attributesFromList [" <> L.intercalate ", " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]" + where parens x | d > 0 = "(" <> x <> ")" + parens x = x --when attribute ordering is irrelevant instance Eq Attributes where @@ -136,8 +146,12 @@ sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed (attributesVec attrs)) -- | The relation's tuple set is the body of the relation. -newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Read) +newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Show, Generic, Read) +-- we cannot derive Hashable for tuplesets; we need to hash the unordered set of tuples +instance Hashable RelationTupleSet where + hashWithSalt s tupSet = hashWithSalt s (HS.fromList (asList tupSet)) + instance Read Relation where readsPrec = error "relation read not supported" @@ -187,7 +201,7 @@ instance Hashable Relation where hashWithSalt salt (Relation attrs tupSet) = salt `hashWithSalt` sortedAttrs `hashWithSalt` - asList tupSet + HS.fromList (asList tupSet) where sortedAttrs = map snd (sortedAttributesIndices attrs) @@ -579,19 +593,20 @@ f1 == f2 = funcName f1 == funcName f2 instance Hashable (Function a) where - hashWithSalt salt func = salt `hashWithSalt` funcName func `hashWithSalt` funcType func `hashWithSalt` funcBody func - + hashWithSalt salt func = salt `hashWithSalt` funcName func `hashWithSalt` funcType func `hashWithSalt` hashfuncbody + where + hashfuncbody = + case funcBody func of + (FunctionScriptBody script _) -> salt `hashWithSalt` script + (FunctionBuiltInBody _) -> salt + (FunctionObjectLoadedBody fp modName entryFunc _) -> salt `hashWithSalt` (fp, modName, entryFunc) + data FunctionBody a = FunctionScriptBody FunctionBodyScript a | FunctionBuiltInBody a | FunctionObjectLoadedBody FilePath ObjectModuleName ObjectFileEntryFunctionName a deriving Generic -instance Hashable (FunctionBody a) where - salt `hashWithSalt` (FunctionScriptBody script _) = salt `hashWithSalt` script - salt `hashWithSalt` (FunctionBuiltInBody _) = salt - salt `hashWithSalt` (FunctionObjectLoadedBody fp modName entryFunc _) = salt `hashWithSalt` (fp, modName, entryFunc) - instance NFData a => NFData (FunctionBody a) where rnf (FunctionScriptBody script _) = rnf script rnf (FunctionBuiltInBody _) = rnf () @@ -607,6 +622,7 @@ attrTypeVars (Attribute _ aType) = case aType of IntAtomType -> S.empty IntegerAtomType -> S.empty + ScientificAtomType -> S.empty DoubleAtomType -> S.empty TextAtomType -> S.empty DayAtomType -> S.empty @@ -632,6 +648,7 @@ atomTypeVars :: AtomType -> S.Set TypeVarName atomTypeVars IntAtomType = S.empty atomTypeVars IntegerAtomType = S.empty +atomTypeVars ScientificAtomType = S.empty atomTypeVars DoubleAtomType = S.empty atomTypeVars TextAtomType = S.empty atomTypeVars DayAtomType = S.empty 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 @@ -290,7 +290,9 @@ [] -> error ("DNS resolution failed for" <> hostName <> ":" <> servicePort) addrInfo:_ -> do --supports IPv4 only for now - let (SockAddrInet port addr) = addrAddress addrInfo + let (port, addr) = case addrAddress addrInfo of + SockAddrInet p a -> (p, a) + _ -> error "no IPv4 address available (IPv6 not implemented)" notificationHandlers = [RPC.ClientAsyncRequestHandler $ \(NotificationMessage notifications') -> @@ -709,8 +711,8 @@ -- | Write the transaction graph to disk. This function can be used to incrementally write new transactions to disk. processTransactionGraphPersistence :: PersistenceStrategy -> [TransactionId] -> TransactionGraph -> IO () processTransactionGraphPersistence NoPersistence _ _ = pure () -processTransactionGraphPersistence (MinimalPersistence dbdir) transIds graph = transactionGraphPersist NoDiskSync dbdir transIds graph >> pure () -processTransactionGraphPersistence (CrashSafePersistence dbdir) transIds graph = transactionGraphPersist FsyncDiskSync dbdir transIds graph >> pure () +processTransactionGraphPersistence (MinimalPersistence dbdir) transIds graph = void $ transactionGraphPersist NoDiskSync dbdir transIds graph +processTransactionGraphPersistence (CrashSafePersistence dbdir) transIds graph = void $ transactionGraphPersist FsyncDiskSync dbdir transIds graph readGraphTransactionIdDigest :: PersistenceStrategy -> IO LockFileHash readGraphTransactionIdDigest NoPersistence = error "attempt to read digest from transaction log without persistence enabled" @@ -822,11 +824,7 @@ if Sess.schemaName session == defaultSchemaName then pure $ RE.relationVariablesAsRelation context graph else - case Schema.relationVariablesInSchema schema of - Left err -> pure (Left err) - Right relvars -> do - let schemaContext = context {relationVariables = relvars } - pure $ RE.relationVariablesAsRelation schemaContext graph + pure $ Schema.relationVariablesAsRelationInSchema context schema graph relationVariablesAsRelation sessionId conn@(RemoteConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId) 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 @@ -17,6 +17,7 @@ import Data.Maybe import qualified Data.Text as T import Control.Arrow +import Control.Monad (unless) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif @@ -52,10 +53,7 @@ sortDataFrameBy :: [AttributeOrder] -> DataFrame -> Either RelationalError DataFrame sortDataFrameBy attrOrders frame = do attrs <- mapM (\(AttributeOrder nam _) -> A.attributeForName nam (attributes frame)) attrOrders - mapM_ (\attr -> if not (isSortableAtomType (atomType attr)) then - Left (AttributeNotSortableError attr) - else - pure ()) attrs + mapM_ (\attr -> unless (isSortableAtomType (atomType attr)) $ Left (AttributeNotSortableError attr)) attrs pure $ DataFrame attrOrders (attributes frame) (sortTuplesBy (compareTupleByAttributeOrders attrOrders) (tuples frame)) sortTuplesBy :: (DataFrameTuple -> DataFrameTuple -> Ordering) -> [DataFrameTuple] -> [DataFrameTuple] diff --git a/src/lib/ProjectM36/DataTypes/ByteString.hs b/src/lib/ProjectM36/DataTypes/ByteString.hs --- a/src/lib/ProjectM36/DataTypes/ByteString.hs +++ b/src/lib/ProjectM36/DataTypes/ByteString.hs @@ -10,9 +10,12 @@ bytestringAtomFunctions = HS.fromList [ Function { funcName = "bytestring", funcType = [TextAtomType, ByteStringAtomType], - funcBody = compiledAtomFunctionBody $ \(TextAtom textIn:_) -> case B64.decode (TE.encodeUtf8 textIn) of + funcBody = compiledAtomFunctionBody $ + \case + TextAtom textIn:_ -> case B64.decode (TE.encodeUtf8 textIn) of Left err -> Left (AtomFunctionBytesDecodingError err) - Right bs -> pure (ByteStringAtom bs) + Right bs -> pure (ByteStringAtom bs) + _ -> Left AtomFunctionTypeMismatchError } ] diff --git a/src/lib/ProjectM36/DataTypes/DateTime.hs b/src/lib/ProjectM36/DataTypes/DateTime.hs --- a/src/lib/ProjectM36/DataTypes/DateTime.hs +++ b/src/lib/ProjectM36/DataTypes/DateTime.hs @@ -1,6 +1,7 @@ module ProjectM36.DataTypes.DateTime where import ProjectM36.Base import ProjectM36.AtomFunctionBody +import ProjectM36.AtomFunctionError import qualified Data.HashSet as HS import Data.Time.Clock.POSIX @@ -8,7 +9,10 @@ dateTimeAtomFunctions = HS.fromList [ Function { funcName = "dateTimeFromEpochSeconds", funcType = [IntegerAtomType, DateTimeAtomType], - funcBody = compiledAtomFunctionBody $ \(IntegerAtom epoch:_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch))) - }] + funcBody = compiledAtomFunctionBody $ + \case + IntegerAtom epoch:_ -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch))) + _ -> Left AtomFunctionTypeMismatchError + }] diff --git a/src/lib/ProjectM36/DataTypes/Day.hs b/src/lib/ProjectM36/DataTypes/Day.hs --- a/src/lib/ProjectM36/DataTypes/Day.hs +++ b/src/lib/ProjectM36/DataTypes/Day.hs @@ -1,17 +1,25 @@ module ProjectM36.DataTypes.Day where import ProjectM36.Base import ProjectM36.AtomFunctionBody +import ProjectM36.AtomFunctionError import qualified Data.HashSet as HS import Data.Time.Calendar + dayAtomFunctions :: AtomFunctions dayAtomFunctions = HS.fromList [ Function { funcName = "fromGregorian", funcType = [IntegerAtomType, IntegerAtomType, IntegerAtomType, DayAtomType], - funcBody = compiledAtomFunctionBody $ \(IntegerAtom year:IntegerAtom month:IntegerAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) + funcBody = compiledAtomFunctionBody $ + \case + IntegerAtom year:IntegerAtom month:IntegerAtom day:_ -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) + _ -> Left AtomFunctionTypeMismatchError }, Function { funcName = "dayEarlierThan", funcType = [DayAtomType, DayAtomType, BoolAtomType], - funcBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB)) + funcBody = compiledAtomFunctionBody $ + \case + ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_ -> pure (BoolAtom (dayA < dayB)) + _ -> Left AtomFunctionTypeMismatchError } ] diff --git a/src/lib/ProjectM36/DataTypes/Either.hs b/src/lib/ProjectM36/DataTypes/Either.hs --- a/src/lib/ProjectM36/DataTypes/Either.hs +++ b/src/lib/ProjectM36/DataTypes/Either.hs @@ -1,6 +1,7 @@ module ProjectM36.DataTypes.Either where import ProjectM36.Base import ProjectM36.AtomFunction +import ProjectM36.AtomFunctionError import qualified Data.HashSet as HS import qualified Data.Map as M @@ -14,5 +15,7 @@ eitherAtomFunctions :: AtomFunctions eitherAtomFunctions = HS.fromList [ - compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \(ConstructedAtom dConsName _ _:_) -> pure (BoolAtom (dConsName == "Left")) + compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \case + (ConstructedAtom dConsName _ _:_) -> pure (BoolAtom (dConsName == "Left")) + _ -> Left AtomFunctionTypeMismatchError ] diff --git a/src/lib/ProjectM36/DataTypes/Interval.hs b/src/lib/ProjectM36/DataTypes/Interval.hs --- a/src/lib/ProjectM36/DataTypes/Interval.hs +++ b/src/lib/ProjectM36/DataTypes/Interval.hs @@ -29,6 +29,7 @@ supportsInterval typ = case typ of IntAtomType -> True IntegerAtomType -> True + ScientificAtomType -> True DoubleAtomType -> True TextAtomType -> False -- just because it supports ordering, doesn't mean it makes sense in an interval DayAtomType -> True @@ -44,7 +45,8 @@ supportsOrdering :: AtomType -> Bool supportsOrdering typ = case typ of IntAtomType -> True - IntegerAtomType -> True + IntegerAtomType -> True + ScientificAtomType -> True DoubleAtomType -> True TextAtomType -> True DayAtomType -> True @@ -100,20 +102,26 @@ BoolAtomType, BoolAtomType, intervalAtomType (TypeVariableType "a")], - funcBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do + funcBody = compiledAtomFunctionBody $ + \case + (atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do let aType = atomTypeForAtom atom1 if supportsInterval aType then createInterval atom1 atom2 bopen eopen else Left (AtomTypeDoesNotSupportIntervalError (prettyAtomType aType)) + _ -> Left AtomFunctionTypeMismatchError }, Function { funcName = "interval_overlaps", funcType = [intervalAtomType (TypeVariableType "a"), intervalAtomType (TypeVariableType "a"), BoolAtomType], - funcBody = compiledAtomFunctionBody $ \(i1@ConstructedAtom{}:i2@ConstructedAtom{}:_) -> - BoolAtom <$> intervalOverlaps i1 i2 + funcBody = compiledAtomFunctionBody $ + \case + i1@ConstructedAtom{}:i2@ConstructedAtom{}:_ -> + BoolAtom <$> intervalOverlaps i1 i2 + _ -> Left AtomFunctionTypeMismatchError }] isIntervalAtomType :: AtomType -> Bool diff --git a/src/lib/ProjectM36/DataTypes/List.hs b/src/lib/ProjectM36/DataTypes/List.hs --- a/src/lib/ProjectM36/DataTypes/List.hs +++ b/src/lib/ProjectM36/DataTypes/List.hs @@ -37,13 +37,19 @@ Function { funcName = "length", funcType = [listAtomType (TypeVariableType "a"), IntAtomType], - funcBody = FunctionBuiltInBody (\(listAtom:_) -> - IntAtom . fromIntegral <$> listLength listAtom) + funcBody = FunctionBuiltInBody $ + \case + (listAtom:_) -> + IntAtom . fromIntegral <$> listLength listAtom + _ -> Left AtomFunctionTypeMismatchError }, Function { funcName = "maybeHead", funcType = [listAtomType (TypeVariableType "a"), maybeAtomType (TypeVariableType "a")], - funcBody = FunctionBuiltInBody (\(listAtom:_) -> listMaybeHead listAtom) + funcBody = FunctionBuiltInBody $ + \case + (listAtom:_) -> listMaybeHead listAtom + _ -> Left AtomFunctionTypeMismatchError } ] diff --git a/src/lib/ProjectM36/DataTypes/Maybe.hs b/src/lib/ProjectM36/DataTypes/Maybe.hs --- a/src/lib/ProjectM36/DataTypes/Maybe.hs +++ b/src/lib/ProjectM36/DataTypes/Maybe.hs @@ -19,12 +19,18 @@ Function { funcName ="isJust", funcType = [maybeAtomType (TypeVariableType "a"), BoolAtomType], - funcBody = FunctionBuiltInBody $ \(ConstructedAtom dConsName _ _:_) -> pure $ BoolAtom (dConsName /= "Nothing") + funcBody = FunctionBuiltInBody $ + \case + ConstructedAtom dConsName _ _:_ -> pure $ BoolAtom (dConsName /= "Nothing") + _ -> Left AtomFunctionTypeMismatchError }, Function { funcName = "fromMaybe", funcType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "a"], - funcBody = FunctionBuiltInBody $ \(defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal + funcBody = FunctionBuiltInBody $ + \case + (defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal + _ ->Left AtomFunctionTypeMismatchError } ] diff --git a/src/lib/ProjectM36/DataTypes/NonEmptyList.hs b/src/lib/ProjectM36/DataTypes/NonEmptyList.hs --- a/src/lib/ProjectM36/DataTypes/NonEmptyList.hs +++ b/src/lib/ProjectM36/DataTypes/NonEmptyList.hs @@ -42,12 +42,18 @@ Function { funcName = "nonEmptyListLength", funcType = [nonEmptyListAtomType (TypeVariableType "a"), IntAtomType], - funcBody = FunctionBuiltInBody (\(nonEmptyListAtom:_) -> - IntAtom . fromIntegral <$> nonEmptyListLength nonEmptyListAtom) + funcBody = FunctionBuiltInBody $ + \case + (nonEmptyListAtom:_) -> + IntAtom . fromIntegral <$> nonEmptyListLength nonEmptyListAtom + _ -> Left AtomFunctionTypeMismatchError }, Function { funcName = "nonEmptyListHead", funcType = [nonEmptyListAtomType (TypeVariableType "a"), TypeVariableType "a"], - funcBody = FunctionBuiltInBody (\(nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom) + funcBody = FunctionBuiltInBody $ + \case + (nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom + _ -> Left AtomFunctionTypeMismatchError } ] diff --git a/src/lib/ProjectM36/DataTypes/Primitive.hs b/src/lib/ProjectM36/DataTypes/Primitive.hs --- a/src/lib/ProjectM36/DataTypes/Primitive.hs +++ b/src/lib/ProjectM36/DataTypes/Primitive.hs @@ -2,19 +2,21 @@ import ProjectM36.Base primitiveTypeConstructorMapping :: TypeConstructorMapping -primitiveTypeConstructorMapping = map (\(name, aType) -> +primitiveTypeConstructorMapping = boolMapping : map (\(name, aType) -> (PrimitiveTypeConstructorDef name aType, [])) prims where prims = [("Integer", IntegerAtomType), ("Int", IntAtomType), ("Text", TextAtomType), ("Double", DoubleAtomType), - ("Bool", BoolAtomType), ("UUID", UUIDAtomType), ("ByteString", ByteStringAtomType), ("DateTime", DateTimeAtomType), ("Day", DayAtomType) ] + boolMapping = (PrimitiveTypeConstructorDef "Bool" BoolAtomType, + [DataConstructorDef "True" [], + DataConstructorDef "False" []]) intTypeConstructor :: TypeConstructor intTypeConstructor = PrimitiveTypeConstructor "Int" IntAtomType @@ -38,6 +40,7 @@ atomTypeForAtom :: Atom -> AtomType atomTypeForAtom (IntAtom _) = IntAtomType atomTypeForAtom (IntegerAtom _) = IntegerAtomType +atomTypeForAtom (ScientificAtom _) = ScientificAtomType atomTypeForAtom (DoubleAtom _) = DoubleAtomType atomTypeForAtom (TextAtom _) = TextAtomType atomTypeForAtom (DayAtom _) = DayAtomType diff --git a/src/lib/ProjectM36/DataTypes/Sorting.hs b/src/lib/ProjectM36/DataTypes/Sorting.hs --- a/src/lib/ProjectM36/DataTypes/Sorting.hs +++ b/src/lib/ProjectM36/DataTypes/Sorting.hs @@ -5,6 +5,7 @@ compareAtoms (IntegerAtom i1) (IntegerAtom i2) = compare i1 i2 compareAtoms (IntAtom i1) (IntAtom i2) = compare i1 i2 compareAtoms (DoubleAtom d1) (DoubleAtom d2) = compare d1 d2 +compareAtoms (ScientificAtom s1) (ScientificAtom s2) = compare s1 s2 compareAtoms (TextAtom t1) (TextAtom t2) = compare t1 t2 compareAtoms (DayAtom d1) (DayAtom d2) = compare d1 d2 compareAtoms (DateTimeAtom d1) (DateTimeAtom d2) = compare d1 d2 @@ -20,6 +21,7 @@ IntAtomType -> True IntegerAtomType -> True DoubleAtomType -> True + ScientificAtomType -> True TextAtomType -> True DayAtomType -> True DateTimeAtomType -> True 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 @@ -12,9 +12,13 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.List as L +import qualified Data.Vector as V +import qualified ProjectM36.Attribute as A +import ProjectM36.AtomType #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif + -- isomorphic schemas offer bi-directional functors between two schemas --TODO: note that renaming a relvar should alter any stored isomorphisms as well @@ -79,9 +83,10 @@ -- | Check that all mentioned relvars are actually present in the current schema. validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError () -validateRelationalExprInSchema schema relExprIn = relExprMogrify (\case - RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv) - ex -> Right ex) relExprIn >> pure () +validateRelationalExprInSchema schema relExprIn = + void $ relExprMogrify (\case + RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv) + ex -> Right ex) relExprIn where validRelVarNames = isomorphsInRelVarNames (isomorphs schema) @@ -93,7 +98,7 @@ foldM processRelExpr relExprIn (isomorphs schema) validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError () -validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) >> pure () +validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do @@ -265,6 +270,24 @@ pure (M.union newRvMap (M.fromList rvAssocs)) +-- | Show metadata about the relation variables in the isomorphic schema. +relationVariablesAsRelationInSchema :: DatabaseContext -> Schema -> TransactionGraph -> Either RelationalError Relation +relationVariablesAsRelationInSchema concreteDbContext schema graph = do + rvDefsInConcreteSchema <- relationVariablesInSchema schema + let gfEnv = freshGraphRefRelationalExprEnv (Just concreteDbContext) graph + typAssocs <- forM (M.toList rvDefsInConcreteSchema) $ \(rv, gfExpr) -> do + typ <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr) + pure (rv, typ) + let tups = map relVarToAtomList typAssocs + subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType] + attrs = A.attributesFromList [Attribute "name" TextAtomType, + Attribute "attributes" (RelationAtomType subrelAttrs)] + relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributesVec (attributes rel))] + attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))] + attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of + Left err -> error ("relationVariablesAsRelation pooped " ++ show err) + Right rel -> RelationAtom rel + mkRelationFromList attrs tups {- proposal diff --git a/src/lib/ProjectM36/Persist.hs b/src/lib/ProjectM36/Persist.hs --- a/src/lib/ProjectM36/Persist.hs +++ b/src/lib/ProjectM36/Persist.hs @@ -1,13 +1,14 @@ {-# LANGUAGE ForeignFunctionInterface, CPP #-} --this module is related to persisting Project:M36 structures to disk and not related to the persistent library module ProjectM36.Persist (writeFileSync, - writeBSFileSync, + writeSerialiseSync, renameSync, printFdCount, DiskSync(..)) where -- on Windows, use FlushFileBuffers and MoveFileEx import qualified Data.Text as T - +import Codec.Winery +import qualified Data.ByteString.FastBuilder as BB #if defined(linux_HOST_OS) # define FDCOUNTSUPPORTED 1 # define FDDIR "/proc/self/fd" @@ -35,8 +36,8 @@ import Foreign.C #endif -import System.IO (withFile, IOMode(WriteMode), Handle) -import qualified Data.ByteString as BS' +import System.IO (withFile, IOMode(WriteMode), Handle, withBinaryFile) +import qualified Data.ByteString as BS import qualified Data.Text.Encoding as TE #if defined(mingw32_HOST_OS) @@ -52,7 +53,7 @@ writeFileSync sync path strOut = withFile path WriteMode handler where handler handle = do - BS'.hPut handle (TE.encodeUtf8 strOut) + BS.hPut handle (TE.encodeUtf8 strOut) syncHandle sync handle renameSync :: DiskSync -> FilePath -> FilePath -> IO () @@ -99,10 +100,11 @@ syncDirectory FsyncDiskSync path = directoryFsync path syncDirectory NoDiskSync _ = pure () -writeBSFileSync :: DiskSync -> FilePath -> BS'.ByteString -> IO () -writeBSFileSync sync path bstring = - withFile path WriteMode $ \handle -> do - BS'.hPut handle bstring +--uses lazy bytestring to write to file +writeSerialiseSync :: Serialise a => DiskSync -> FilePath -> a -> IO () +writeSerialiseSync sync path val = + withBinaryFile path WriteMode $ \handle -> do + BB.hPutBuilder handle $ toBuilderWithSchema val syncHandle sync handle directoryFsync :: FilePath -> IO () diff --git a/src/lib/ProjectM36/Relation/Parse/CSV.hs b/src/lib/ProjectM36/Relation/Parse/CSV.hs --- a/src/lib/ProjectM36/Relation/Parse/CSV.hs +++ b/src/lib/ProjectM36/Relation/Parse/CSV.hs @@ -60,6 +60,7 @@ parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom) parseCSVAtomP _ _ IntegerAtomType = Right . IntegerAtom <$> APT.decimal parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal +parseCSVAtomP _ _ ScientificAtomType = Right . ScientificAtom <$> APT.scientific parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double parseCSVAtomP _ _ TextAtomType = Right . TextAtom <$> (quotedString <|> takeToEndOfData) 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 @@ -862,6 +862,9 @@ let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr) pure (RelationAtom relAtom) +evalGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _) + | tOrF == "True" = pure (BoolAtom True) + | tOrF == "False" = pure (BoolAtom False) evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do --why is the tid unused here? suspicious let mergeEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) cons) @@ -893,15 +896,27 @@ Right func -> do let funcRetType = last (funcType func) funcArgTypes = init (funcType func) + funArgCount = length funcArgTypes + inArgCount = length atomArgs + when (funArgCount /= inArgCount) (throwError (FunctionArgumentCountMismatchError funArgCount inArgCount)) argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs + mapM_ (\(fArg,arg,argCount) -> do + let handler :: RelationalError -> GraphRefRelationalExprM AtomType + handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType) + handler err = throwError err + lift (except $ atomTypeVerify fArg arg) `catchError` handler + ) (zip3 funcArgTypes argTypes [1..]) let eTvMap = resolveTypeVariables funcArgTypes argTypes case eTvMap of Left err -> throwError err - Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName' tvMap funcRetType + Right tvMap -> + lift $ except $ resolveFunctionReturnValue funcName' tvMap funcRetType typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr) pure (RelationAtomType (attributes relType)) -- grab the type of the data constructor, then validate that the args match the expected types +typeForGraphRefAtomExpr _ (ConstructedAtomExpr tOrF [] _) | tOrF `elem` ["True", "False"] = + pure BoolAtomType typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) = do argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs 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 @@ -19,30 +19,47 @@ import Data.Maybe import GHC.Paths (libdir) import System.Environment -#if __GLASGOW_HASKELL__ >= 800 -import GHC.LanguageExtensions -import GHCi.ObjLink -#else -import ObjLink -#endif -#if __GLASGOW_HASKELL__ >= 802 -import BasicTypes -#endif -import DynFlags -import Panic -import Outputable --hiding ((<>)) -import PprTyThing + import Unsafe.Coerce -#if __GLASGOW_HASKELL__ >= 802 -import Type -#elif __GLASGOW_HASKELL__ >= 710 -import Type hiding (pprTyThing) +import GHC.LanguageExtensions (Extension(OverloadedStrings,ExtendedDefaultRules,ImplicitPrelude,ScopedTypeVariables)) + +#if MIN_VERSION_ghc(9,2,0) +-- GHC 9.2.2 +import GHC.Utils.Panic (handleGhcException) +import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) +import GHC.Types.SourceText (SourceText(NoSourceText)) +import GHC.Unit.Types (IsBootInterface(NotBoot)) +import GHC.Driver.Ppr (showSDocForUser) +import GHC.Core.Type (eqType) +import GHC.Types.TyThing.Ppr (pprTypeForUser) +import GHC.Utils.Encoding (zEncodeString) +import GHC.Unit.State (emptyUnitState) +#elif MIN_VERSION_ghc(9,0,0) +-- GHC 9.0.0 +import GHC.Utils.Panic (handleGhcException) +import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) +import GHC.Types.Basic (SourceText(NoSourceText)) +import GHC.Unit.Types (IsBootInterface(NotBoot)) +import GHC.Core.Type (eqType) +import GHC.Utils.Outputable (showSDocForUser) +import GHC.Utils.Encoding (zEncodeString) +import GHC.Core.Ppr.TyThing (pprTypeForUser) #else +-- GHC 8.10.7 +import BasicTypes (SourceText(NoSourceText)) +import Outputable (showSDocForUser) +import PprTyThing (pprTypeForUser) +import Type (eqType) +import Encoding (zEncodeString) +import Panic (handleGhcException) +import DynFlags (projectVersion, PkgConfRef(PkgConfFile), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming), PackageDBFlag(PackageDB)) #endif + import GHC.Exts (addrToAny#) import GHC.Ptr (Ptr(..)) -import Encoding +import GHCi.ObjLink (initObjLinker, ShouldRetainCAFs(RetainCAFs), resolveObjs, lookupSymbol, loadDLL, loadObj) #endif +-- endif for SCRIPTING FLAG data ScriptSession = ScriptSession { #ifdef PM36_HASKELL_SCRIPTING @@ -90,33 +107,35 @@ homeDir ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb" --homeDir ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db" ] - - let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir) +#if MIN_VERSION_ghc(9,0,0) + let pkgConf = PkgDbPath +#else + let pkgConf = PkgConfFile +#endif + let localPkgPaths = map pkgConf (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir) - let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted , + let dflags' = applyGopts . applyXopts $ dflags { +#if MIN_VERSION_ghc(9,2,0) + backend = Interpreter, +#else + hscTarget = HscInterpreted , +#endif ghcLink = LinkInMemory, safeHaskell = Sf_Trustworthy, safeInfer = True, safeInferred = True, --verbosity = 3, -#if __GLASGOW_HASKELL__ >= 800 + trustFlags = map TrustPackage required_packages, -#endif packageFlags = packageFlags dflags ++ packages, -#if __GLASGOW_HASKELL__ >= 802 packageDBFlags = map PackageDB localPkgPaths -#else - extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf]) -#endif - } +-- extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf]) + } + applyGopts flags = foldl gopt_set flags gopts applyXopts flags = foldl xopt_set flags xopts -#if __GLASGOW_HASKELL__ >= 800 xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables] -#else - xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables] -#endif gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust] required_packages = ["base", "containers", @@ -131,42 +150,42 @@ "time", "project-m36", "bytestring"] -#if __GLASGOW_HASKELL__ >= 800 packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages -#else - packages = map TrustPackage required_packages -#endif --liftIO $ traceShowM (showSDoc dflags' (ppr packages)) _ <- setSessionDynFlags dflags' - let safeImportDecl mn mQual = ImportDecl { -#if __GLASGOW_HASKELL__ >= 802 + let safeImportDecl :: String -> Maybe String -> ImportDecl (GhcPass 'Parsed) + safeImportDecl fullModuleName mQualifiedName = ImportDecl { ideclSourceSrc = NoSourceText, -#else - ideclSourceSrc = Nothing, -#endif -#if __GLASGOW_HASKELL__ >= 810 +#if MIN_VERSION_ghc(9,2,0) + ideclExt = noAnn, +#else ideclExt = noExtField, -#elif __GLASGOW_HASKELL__ >= 806 - ideclExt = NoExt, #endif - ideclName = noLoc mn, +#if MIN_VERSION_ghc(9,2,0) + --GenLocated SrcSpanAnnA ModuleName + ideclName = noLocA (mkModuleName fullModuleName), +#else + ideclName = noLoc (mkModuleName fullModuleName), +#endif ideclPkgQual = Nothing, +#if MIN_VERSION_ghc(9,0,0) + ideclSource = NotBoot, +#else ideclSource = False, +#endif + ideclSafe = True, ideclImplicit = False, -#if __GLASGOW_HASKELL__ >= 810 - ideclQualified = if isJust mQual then QualifiedPre else NotQualified, + ideclQualified = if isJust mQualifiedName then QualifiedPre else NotQualified, +#if MIN_VERSION_ghc(9,2,0) + ideclAs = Just (noLocA (mkModuleName fullModuleName)), #else - ideclQualified = isJust mQual, + ideclAs = noLoc . mkModuleName <$> mQualifiedName, #endif - ideclAs = mQual, ideclHiding = Nothing } -#if __GLASGOW_HASKELL__ >= 806 - :: ImportDecl (GhcPass (c :: Pass)) -#endif - unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [ + unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl modn Nothing) [ "Prelude", "Data.Map", "Data.Either", @@ -178,12 +197,7 @@ "ProjectM36.DatabaseContextFunctionError", "ProjectM36.DatabaseContextFunctionUtils", "ProjectM36.RelationalExpression"] -#if __GLASGOW_HASKELL__ >= 802 - mkModName = noLoc . mkModuleName -#else - mkModName = mkModuleName -#endif - qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModName qualNam))) [ + qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl modn (Just qualNam)) [ ("Data.Text", "T") ] setContext (unqualifiedModules ++ qualifiedModules) @@ -198,7 +212,11 @@ setContext (IIDecl (simpleImportDecl (mkModuleName moduleNam)) : ctx) showType :: DynFlags -> Type -> String +#if MIN_VERSION_ghc(9,2,0) +showType dflags ty = showSDocForUser dflags emptyUnitState alwaysQualify (pprTypeForUser ty) +#else showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty) +#endif mkTypeForName :: String -> Ghc Type mkTypeForName name = do @@ -231,11 +249,7 @@ typeCheckScript expectedType inp = do dflags <- getSessionDynFlags --catch exception for SyntaxError -#if __GLASGOW_HASKELL__ >= 802 funcType <- GHC.exprType TM_Inst (unpack inp) -#else - funcType <- GHC.exprType (unpack inp) -#endif --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType if eqType funcType expectedType then pure Nothing @@ -271,11 +285,7 @@ loadFunction :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a) loadFunction loadMode modName funcName objPath = do -#if __GLASGOW_HASKELL__ >= 802 initObjLinker RetainCAFs -#else - initObjLinker -#endif let loadFuncForSymbol = do _ <- resolveObjs ptr <- lookupSymbol (mangleSymbol Nothing modName funcName) diff --git a/src/lib/ProjectM36/Serialise/Base.hs b/src/lib/ProjectM36/Serialise/Base.hs --- a/src/lib/ProjectM36/Serialise/Base.hs +++ b/src/lib/ProjectM36/Serialise/Base.hs @@ -11,9 +11,12 @@ import Data.Proxy import Data.Word import ProjectM36.Attribute as A -import qualified Data.List.NonEmpty as NE import qualified Data.Vector as V import Data.Time.Calendar (Day,toGregorian,fromGregorian) +#if MIN_VERSION_winery(1,4,0) +#else +import qualified Data.List.NonEmpty as NE +#endif deriving via WineryVariant Atom instance Serialise Atom deriving via WineryVariant AtomType instance Serialise AtomType @@ -55,6 +58,8 @@ extractor = fromWordsTup <$> extractor decodeCurrent = fromWordsTup <$> decodeCurrent +#if MIN_VERSION_winery(1,4,0) +#else instance Serialise a => Serialise (NE.NonEmpty a) where schemaGen _ = SVector <$> getSchema (Proxy @a) toBuilder xs = varInt (length xs) <> foldMap toBuilder xs @@ -63,6 +68,7 @@ n <- decodeVarInt l <- replicateM n decodeCurrent pure (NE.fromList l) +#endif fromGregorianTup :: (Integer, Int, Int) -> Day fromGregorianTup (a, b, c) = fromGregorian a b c diff --git a/src/lib/ProjectM36/StaticOptimizer.hs b/src/lib/ProjectM36/StaticOptimizer.hs --- a/src/lib/ProjectM36/StaticOptimizer.hs +++ b/src/lib/ProjectM36/StaticOptimizer.hs @@ -525,7 +525,10 @@ optFinalExpr = case finalExpr of Restrict _ subexpr -> applyStaticRestrictionCollapse subexpr otherExpr -> otherExpr - andPreds = foldr (\(Restrict subpred _) acc -> AndPredicate acc subpred) firstPred (tail restrictions) in + andPreds = foldr folder firstPred (tail restrictions) + folder (Restrict subpred _) acc = AndPredicate acc subpred + folder _ _ = error "unexpected restriction expression in optimization phase" + in Restrict andPreds optFinalExpr sequentialRestrictions :: RelationalExprBase a -> [RelationalExprBase a] diff --git a/src/lib/ProjectM36/Trace.hs b/src/lib/ProjectM36/Trace.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/Trace.hs @@ -0,0 +1,10 @@ +module ProjectM36.Trace where +import Debug.Trace (traceEventIO) +-- utility module to enable easy enabling/disabling of eventlog data + +-- | Utility function for tracing with ghc-events-analyze using START and STOP markers +traceBlock :: String -> IO () -> IO () +traceBlock label m = do + traceEventIO ("START " <> label) + m + traceEventIO ("STOP " <> label) diff --git a/src/lib/ProjectM36/Transaction/Persist.hs b/src/lib/ProjectM36/Transaction/Persist.hs --- a/src/lib/ProjectM36/Transaction/Persist.hs +++ b/src/lib/ProjectM36/Transaction/Persist.hs @@ -1,16 +1,18 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} #ifdef PM36_HASKELL_SCRIPTING {-# LANGUAGE TypeApplications #-} #endif module ProjectM36.Transaction.Persist where +import ProjectM36.Trace import ProjectM36.Base import ProjectM36.Error import ProjectM36.Transaction import ProjectM36.DatabaseContextFunction import ProjectM36.AtomFunction -import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync) +import ProjectM36.Persist (DiskSync, renameSync, writeSerialiseSync) import ProjectM36.Function import qualified Data.Map as M import qualified Data.HashSet as HS @@ -109,14 +111,14 @@ writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO () writeRelVars sync transDir relvars = do let path = relvarsPath transDir - writeBSFileSync sync path (serialise relvars) + traceBlock "write relvars" $ writeSerialiseSync sync path relvars readRelVars :: FilePath -> IO RelationVariables readRelVars transDir = readFileDeserialise (relvarsPath transDir) writeFuncs :: Traversable t => DiskSync -> FilePath -> t (Function a) -> IO () -writeFuncs sync funcWritePath funcs = do +writeFuncs sync funcWritePath funcs = traceBlock "write functions" $ do funcs' <- forM funcs $ \fun -> do case funcBody fun of FunctionScriptBody{} -> pure fun @@ -134,7 +136,7 @@ Just (ObjectFileInfo (objPath, modName, entryFunc)) FunctionScriptBody{} -> Nothing FunctionBuiltInBody{} -> Nothing - writeBSFileSync sync funcWritePath (serialise $ fmap functionData (toList funcs')) + writeSerialiseSync sync funcWritePath (fmap functionData (toList funcs')) readFuncs :: FilePath -> FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> IO (HS.HashSet (Function a)) readFuncs transDir funcPath precompiledFunctions mScriptSession = do @@ -223,11 +225,12 @@ #endif writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO () -writeIncDep sync transDir (incDepName, incDep) = - writeBSFileSync sync (incDepsDir transDir T.unpack incDepName) $ serialise incDep +writeIncDep sync transDir (incDepName, incDep) = do + writeSerialiseSync sync (incDepsDir transDir T.unpack incDepName) incDep writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO () -writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toList incdeps +writeIncDeps sync transDir incdeps = + traceBlock "write incdeps" $ mapM_ (writeIncDep sync transDir) $ M.toList incdeps readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency) readIncDep transDir incdepName = do @@ -249,11 +252,12 @@ writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO () writeSubschemas sync transDir sschemas = do let sschemasPath = subschemasPath transDir - writeBSFileSync sync sschemasPath (serialise sschemas) + traceBlock "write subschemas" $ writeSerialiseSync sync sschemasPath sschemas writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO () -writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in - writeBSFileSync sync atPath $ serialise types +writeTypeConstructorMapping sync path types = do + let atPath = typeConsPath path + traceBlock "write tconsmap" $ writeSerialiseSync sync atPath types readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping readTypeConstructorMapping path = do 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 @@ -621,10 +621,8 @@ validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError () validateMerkleHash trans graph = - if expectedHash /= actualHash then + when (expectedHash /= actualHash) $ Left (MerkleValidationError (transactionId trans) expectedHash actualHash) - else - pure () where expectedHash = merkleHash (transactionInfo trans) actualHash = calculateMerkleHash trans graph diff --git a/src/lib/ProjectM36/TransactionGraph/Merge.hs b/src/lib/ProjectM36/TransactionGraph/Merge.hs --- a/src/lib/ProjectM36/TransactionGraph/Merge.hs +++ b/src/lib/ProjectM36/TransactionGraph/Merge.hs @@ -8,6 +8,7 @@ import qualified Data.Map as M import qualified ProjectM36.TypeConstructorDef as TCD import qualified Data.HashSet as HS +import qualified Data.Text as T data MergePreference = PreferFirst | PreferSecond | PreferNeither @@ -69,7 +70,7 @@ let findType tcm = case filter (\(t,_) -> TCD.name t == name) tcm of [] -> Nothing [x] -> Just x - _ -> error "multiple names matching in TypeConstructorMapping" + _ -> error $ "multiple names matching in TypeConstructorMapping for " <> T.unpack name lookupA = findType typesA lookupB = findType typesB cat t = pure (t : acc) 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 @@ -32,6 +32,7 @@ import Data.Time.Clock import Data.Text.Read import System.FilePath.Glob +import Data.Tuple type LockFileHash = ByteString @@ -143,14 +144,21 @@ headsStrLines = map headFileStr $ M.toList (transactionHeadsForGraph graph) writeFileSync sync tempHeadsPath $ T.intercalate "\n" headsStrLines renameSync sync tempHeadsPath (headsPath dbdir) - + transactionGraphHeadsLoad :: FilePath -> IO [(HeadName,TransactionId)] transactionGraphHeadsLoad dbdir = do headsData <- readFile (headsPath dbdir) - let headsAssocs = map (\l -> let [headName, uuidStr] = words l in - (headName,uuidStr) - ) (lines headsData) + let headsAssocs = map twowords (lines headsData) return [(T.pack headName, uuid) | (headName, Just uuid) <- map (second U.fromString) headsAssocs] + +data Pos = One | Two + +twowords :: String -> (String, String) +twowords s = swap $ snd $ foldr twowordfolder (One, ("","")) s + where + twowordfolder ' ' (One, acc) = (Two,acc) + twowordfolder c (One, (a, b)) = (One, (c:a, b)) + twowordfolder c (Two, (a, b)) = (Two, (a, c:b)) {- load any transactions which are not already part of the incoming transaction graph @@ -212,7 +220,10 @@ readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])]) readGraphTransactionIdFile dbdir = do --read in all transactions' uuids - let grapher line = let tid:epochText:parentIds' = T.words line in + let grapher line = let (tid,epochText,parentIds') = case T.words line of + x:y:zs -> (x,y,zs) + _ -> error "failed to parse transaction id file" + in (readUUID tid, readEpoch epochText, map readUUID parentIds') readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText) readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t))) @@ -228,4 +239,5 @@ case TE.decodeUtf8' fileBytes of Left err -> error (show err) Right utf8Bytes -> pure utf8Bytes + diff --git a/test/IsomorphicSchema.hs b/test/IsomorphicSchema.hs --- a/test/IsomorphicSchema.hs +++ b/test/IsomorphicSchema.hs @@ -7,10 +7,11 @@ import ProjectM36.TransactionGraph import ProjectM36.StaticOptimizer import qualified ProjectM36.DatabaseContext as DBC -import qualified ProjectM36.Attribute as A +import ProjectM36.Attribute (attributesFromList) import System.Exit import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.Vector as V testList :: Test testList = TestList [testIsoRename, testIsoRestrict, testIsoUnion, testSchemaValidation] @@ -67,7 +68,7 @@ testIsoRestrict = TestCase $ do -- create a emp relation which is restricted into two boss, nonboss rel vars -- the virtual schema has an employee - let empattrs = A.attributesFromList [Attribute "name" TextAtomType, + let empattrs = attributesFromList [Attribute "name" TextAtomType, Attribute "boss" TextAtomType] (graph, transId) <- freshTransactionGraph DBC.empty emprel <- assertEither $ mkRelationFromList empattrs @@ -85,6 +86,7 @@ ("boss", ExistingRelation bossRel)] } isomorphsAtoB = [IsoRestrict "employee" predicate ("boss", "nonboss")] + schemaB = Schema isomorphsAtoB bossq = RelationVariable "boss" () nonbossq = RelationVariable "nonboss" () employeeq = RelationVariable "employee" () @@ -108,13 +110,24 @@ processedExpr <- assertEither (processRelationalExprInSchema (Schema isomorphsAtoB) (RelationVariable "employee" ())) let processedRel = runRelationalExprM postInsertEnv (evalRelationalExpr processedExpr) assertEqual "insert bob boss" expectedRel processedRel + + -- test that we can render isomorphic schema metadata + let rvTypes = relationVariablesAsRelationInSchema baseContext schemaB graph + rvattrs = attributesFromList [Attribute "name" TextAtomType, Attribute "attributes" (RelationAtomType subrelattrs)] + subrelattrs = attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType] + expectedTypes = mkRelationFromList rvattrs + [[TextAtom "employee", + RelationAtom (Relation subrelattrs + (RelationTupleSet [RelationTuple subrelattrs (V.fromList [TextAtom "boss",TextAtom "Text"]), + RelationTuple subrelattrs (V.fromList [TextAtom "name",TextAtom "Text"])]))]] + assertEqual "relationVariablesAsRelationInSchema" expectedTypes rvTypes testIsoUnion :: Test testIsoUnion = TestCase $ do --create motors relation which is split into low-power (<50 horsepower) and high-power (>=50 horsepower) motors --the schema is contains the split relvars (graph, _) <- freshTransactionGraph DBC.empty - motorsRel <- assertEither $ mkRelationFromList (A.attributesFromList [Attribute "name" TextAtomType, + motorsRel <- assertEither $ mkRelationFromList (attributesFromList [Attribute "name" TextAtomType, Attribute "power" IntegerAtomType]) [[TextAtom "Puny", IntegerAtom 10], [TextAtom "Scooter", IntegerAtom 49], @@ -136,3 +149,4 @@ highpowerRel <- assertEither (relResult highpowerExpr) assertEqual "lowpower relation difference" (Right lowpowerRel) lowmotors assertEqual "highpower relation difference" (Right highpowerRel) highmotors + diff --git a/test/Relation/Basic.hs b/test/Relation/Basic.hs --- a/test/Relation/Basic.hs +++ b/test/Relation/Basic.hs @@ -7,12 +7,14 @@ import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph import ProjectM36.Tuple +import ProjectM36.Attribute (attributesFromList) import qualified ProjectM36.DatabaseContext as DBC import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.Set as S import System.Exit +import Data.Hashable (hashWithSalt) testList :: Test @@ -24,7 +26,8 @@ testRelation "supplierProducts" supplierProductsRel, testMkRelationFromExprsBadAttrs, testExistingRelationType, - testReorderTuple + testReorderTuple, + testRelationEquality ] main :: IO () @@ -117,3 +120,27 @@ actual = reorderTuple attrs2 tup1 expected = mkRelationTuple attrs2 (V.fromList [TextAtom "test", IntAtom 4]) assertEqual "reorderTuple" expected actual + +testRelationEquality :: Test +testRelationEquality = TestCase $ do + -- relations with changed orders of tuples must hash to the same value and be equal, even in lieu of subrelations + let r1 = Relation rattrs $ RelationTupleSet {asList = [RelationTuple subrelattrs + (V.fromList [RelationAtom subrel1])] + } + rattrs = attributesFromList [Attribute "x" (RelationAtomType subrelattrs)] + + r2 = Relation rattrs $ RelationTupleSet {asList = [RelationTuple subrelattrs + (V.fromList [RelationAtom subrel2])] + } + subrelattrs = attributesFromList [Attribute "y" IntAtomType] + subrel1 = Relation subrelattrs tupset1 + tupset1 = RelationTupleSet [RelationTuple subrelattrs (V.fromList [IntAtom 3]), + RelationTuple subrelattrs (V.fromList [IntAtom 4])] + subrel2 = Relation subrelattrs tupset2 + tupset2 = RelationTupleSet [RelationTuple subrelattrs (V.fromList [IntAtom 4]), + RelationTuple subrelattrs (V.fromList [IntAtom 3])] + + assertEqual "relation eq" r1 r2 + assertEqual "relation hash" (hashWithSalt 0 r1) (hashWithSalt 0 r2) + assertEqual "tupset eq" tupset1 tupset2 + assertEqual "tupset hash" (hashWithSalt 0 tupset1) (hashWithSalt 0 tupset2) diff --git a/test/Server/Main.hs b/test/Server/Main.hs --- a/test/Server/Main.hs +++ b/test/Server/Main.hs @@ -19,6 +19,7 @@ import Control.Exception import System.IO.Temp import System.FilePath +import Control.Monad (void) #if defined(linux_HOST_OS) import System.Directory #endif @@ -89,7 +90,7 @@ checkFS = False --not stricly needed for these tests } - launchServer config (Just addressMVar) >> pure () + void $ launchServer config (Just addressMVar) (SockAddrInet port _) <- takeMVar addressMVar --liftIO $ putStrLn ("launched server on " ++ show endPointAddress) pure (fromIntegral port, tid) diff --git a/test/Server/WebSocket.hs b/test/Server/WebSocket.hs --- a/test/Server/WebSocket.hs +++ b/test/Server/WebSocket.hs @@ -18,6 +18,7 @@ import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import ProjectM36.Relation +import Control.Monad (void) --start the websocket server -- run some tutoriald against it @@ -30,7 +31,7 @@ checkFS = False} testDatabaseName = "test" -- start normal server - _ <- forkIO (launchServer config (Just addressMVar) >> pure ()) + void $ forkIO (void $ launchServer config (Just addressMVar)) (SockAddrInet dbPort _) <- takeMVar addressMVar let wsServerHost = "127.0.0.1" wsServerPort = 8889 diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -29,12 +29,13 @@ import Data.Text.Encoding as TE import Control.Concurrent import qualified Data.Set as S -import Data.Text hiding (map) +import Data.Text (unpack, Text) import qualified Data.Text as T import Data.Time.Clock.POSIX hiding (getCurrentTime) import Data.Time.Clock (getCurrentTime) import Data.Time.Calendar (fromGregorian) import Data.Either +import Data.Scientific main :: IO () main = do @@ -84,7 +85,8 @@ testSelfReferencingUncommittedContext, testUnionAndIntersectionAttributeExprs, testUndefineConstraints, - testQuotedRelVarNames + testQuotedRelVarNames, + testScientific ] simpleRelTests :: Test @@ -113,8 +115,10 @@ ("x:=true where false or false", Right relationFalse), ("x:=true where true and false", Right relationFalse), ("x:=true where false and true", Right relationFalse), - ("x:=true where ^t and ^f", Right relationFalse), + ("x:=true where True and False", Right relationFalse), ("x:=true where true and true", Right relationTrue), + ("x:=true where true and True", Right relationTrue), + ("x:=true where True and true", Right relationTrue), -- flip these around to catch parser bugs ("x:=true=true", Right relationTrue), ("x:=true=false", Right relationFalse), ("x:=true; undefine x", Left (RelVarNotDefinedError "x")), @@ -175,11 +179,11 @@ ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])), ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])), --boolean function restriction - ("x:=s where ^lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]), - ("x:=s where ^gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], + ("x:=s where lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]), + ("x:=s where gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]), - ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntegerAtomType BoolAtomType), - ("x:=s where ^not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]), + ("x:=s where sum(@status)", Left $ AtomFunctionTypeError "sum" 1 (RelationAtomType (attributesFromList [Attribute "_" IntegerAtomType])) IntegerAtomType), + ("x:=s where not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]), --test "all but" attribute inversion syntax ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue), --test key syntax @@ -430,7 +434,7 @@ testSchemaExpr = TestCase $ do (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback mapM_ (executeTutorialD sessionId dbconn) [ - ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" ^gte(17,@weight))", + ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" gte(17,@weight))", ":setschema test", "" ] @@ -524,12 +528,12 @@ testIntervalAtom = TestCase $ do --test interval creation (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback - executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,f,f), b interval(4,5,f,f)}, tuple{n 2,a interval(3,4,t,t), b interval(4,5,t,t)}}" + executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,False,False), b interval(4,5,False,False)}, tuple{n 2,a interval(3,4,True,True), b interval(4,5,True,True)}}" --test failed interval creation let err1 = "AtomFunctionUserError InvalidIntervalOrderingError" err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError \"Text\")" - expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}" - expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}" + expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,False,False)}}" + expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",False,False)}}" --test interval_overlaps executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}" @@ -681,12 +685,12 @@ testAtomFunctionArgumentMismatch :: Test testAtomFunctionArgumentMismatch = TestCase $ do (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback - let err1 = "AtomTypeMismatchError" + let err1 = "AtomFunctionTypeError" --atom function type mismatch - expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where ^gt(@a,1.5)" + expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where gt(@a,1.5)" --wrong argument count let err2 = "FunctionArgumentCountMismatchError" - expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)" + expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where gt(@a,1,3)" testInvalidDataConstructor :: Test testInvalidDataConstructor = TestCase $ do @@ -751,3 +755,17 @@ let qAttrExpected = Right (Assign "test" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "\28450\23383" (NakedAtomExpr (TextAtom "test")))]))) assertEqual "quoted attribute" qAttrExpected (parseDBExpr "test:=relation{tuple{`漢字` \"test\"}}") assertBool "invalid quoted rv" (isLeft (parseDBExpr "`TEST:=true")) + +testScientific :: Test +testScientific = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + let getX = executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) + executeTutorialD sessionId dbconn "x:=relation{tuple{a scientific(1,int(100))}}" + createSciRel <- getX + let expectedRel = mkRelationFromList attrs [[ScientificAtom (scientific 1 100)]] + attrs = attributesFromList [Attribute "a" ScientificAtomType] + assertEqual "scientific creation" expectedRel createSciRel + --test some math functions + executeTutorialD sessionId dbconn "x:=relation{tuple{a scientific_add(scientific(2,int(100)),scientific(1,int(100)))}}" + addSciRel <- getX + assertEqual "scientific add" (mkRelationFromList attrs [[ScientificAtom (scientific 3 100)]]) addSciRel diff --git a/test/TutorialD/PrinterTest.hs b/test/TutorialD/PrinterTest.hs --- a/test/TutorialD/PrinterTest.hs +++ b/test/TutorialD/PrinterTest.hs @@ -16,7 +16,7 @@ testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntegerAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntegerAtom 1))) (RelationVariable "true" ()))), testPretty "relation{tuple{a fromGregorian(2014, 2, 4)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "fromGregorian" [NakedAtomExpr (IntegerAtom 2014),NakedAtomExpr (IntegerAtom 2),NakedAtomExpr (IntegerAtom 4)] ())])])), testPretty "relation{tuple{a bytestring(\"dGVzdGRhdGE=\")}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "bytestring" [NakedAtomExpr (TextAtom "dGVzdGRhdGE=")] ())])])), - testPretty "relation{tuple{a t}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (BoolAtom True))])])), + testPretty "relation{tuple{a True}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "True" [] ())])])), testPretty "relation{tuple{a Cons 4 (Cons 5 Empty)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 4),ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 5),ConstructedAtomExpr "Empty" [] ()] ()] ())])])), testPretty "relation{a Int, b Text, c Bool}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (ADTypeConstructor "Int" []) (),AttributeAndTypeNameExpr "b" (ADTypeConstructor "Text" []) (),AttributeAndTypeNameExpr "c" (ADTypeConstructor "Bool" []) ()]) (TupleExprs () [])), testPretty "relation{a relation{b Int}}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (RelationAtomTypeConstructor [AttributeAndTypeNameExpr "b" (ADTypeConstructor "Int" []) ()]) ()]) (TupleExprs () []))