diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,23 @@ +# 2018-06-04 (v0.4) + +* add contributed feature to allow users to [create arbitrary relations](https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown#arbitrary-relation-variables) +* fix type validation bug allowing concrete type with type variables in relations +* improve usability of `Interval a` data type +* allow `Integer` to be parsed as negative in `tutd` console +* support precompiled (Haskell) [`AtomFunction`s](https://github.com/agentm/project-m36/blob/master/docs/atomfunctions.markdown#pre-compiled-atom-functions) and [`DatabaseContextFunction`s](https://github.com/agentm/project-m36/blob/master/docs/database_context_functions.markdown#loading-precompiled-modules) +* make TutorialD scripts read from the filesystem unconditionally read as UTF-8 +* improve support for display of multibyte characters in `tutd` console, especially Chinese +* fix file descriptor leak in file sychronization +* improve reliability by allowing fast-forward commits when using `autoMergeToHead` +* add [`semijoin` and `anitjoin`](https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown#join) support to `tutd` +* added various new static optimizations + +# 2017-11-14 + +* alter websocket server API to allow for multiple representations (JSON, text, or HTML) to be selected and returned simultaneously +* add jupyter kernel for TutorialD interpreter +* fix warnings suggested by new hlint 2.0.10 + # 2017-10-08 (v0.3) * replaced overuse of `undefined` with `Proxy` in `Tupleable` and `Atomable` typeclasses diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -5,7 +5,9 @@ [![Hackage](https://img.shields.io/hackage/v/project-m36.svg)](http://hackage.haskell.org/package/project-m36) [![Hackage dependency status](https://img.shields.io/hackage-deps/v/project-m36.svg)](http://packdeps.haskellers.com/feed?needle=project-m36) [![Build status](https://travis-ci.org/agentm/project-m36.svg?branch=master)](https://travis-ci.org/agentm/project-m36) +[![Windows Build status](https://ci.appveyor.com/api/projects/status/q7jyddd6dy1ibqdo/branch/master?svg=true)](https://ci.appveyor.com/project/agentm/project-m36) + *Software can always be made faster, but rarely can it be made more correct.* ## Introduction @@ -50,6 +52,7 @@ 1. [Installation and Introduction to Project:M36](docs/introduction_to_projectm36.markdown) 1. [Introduction to the Relational Algebra](docs/introduction_to_the_relational_algebra.markdown) +1. [TutorialD via Jupyter Notebook Walkthrough](jupyter/TutorialD%20Notebook%20Walkthrough.ipynb) 1. [TutorialD Tutorial](docs/tutd_tutorial.markdown) 1. [15 Minute Tutorial](docs/15_minute_tutorial.markdown) 1. [Developer's Change Log](Changelog.markdown) @@ -70,12 +73,17 @@ 1. [Serving Remote ProjectM36 Databases](docs/server_mode.markdown) 1. [Using Notifications](docs/using_notifications.markdown) 1. [Merge Transactions](docs/merge_transactions.markdown) -1. [WebSocket Server](docs/websocket_server.markdown) 1. [Atom (Value) Functions](docs/atomfunctions.markdown) 1. [Trans-Graph Relational Expressions](docs/transgraphrelationalexpr.markdown) 1. [Isomorphic Schemas](docs/isomorphic_schemas.markdown) 1. [Replication](docs/replication.markdown) +1. [Basic Operator Benchmarks](https://rawgit.com/agentm/project-m36/master/docs/basic_benchmarks.html) +### Integrations + +1. [WebSocket Server](docs/websocket_server.markdown) +1. [Jupyter Notebook Kernel](docs/jupyter_kernel.markdown) + ## Development Project:M36 is developed in Haskell and compiled with GHC 7.10 or GHC 8.0.2 or later. @@ -89,6 +97,6 @@ ## Suggested Reading -* [Out of the Tarpit](http://shaffner.us/cs/papers/tarpit.pdf): a proposed software architecture which minimizes state and complexity. Project:M36 implements the requirements of this paper. +* [Out of the Tarpit](https://github.com/papers-we-love/papers-we-love/blob/2eb8d21/design/out-of-the-tar-pit.pdf): a proposed software architecture which minimizes state and complexity. Project:M36 implements the requirements of this paper. * [Database Design & Relational Theory: Normal Forms and All That Jazz](http://shop.oreilly.com/product/0636920025276.do): mathematical foundations for the principles of the relational algebra * [Database Explorations: Essays on the Third Manifesto and Related Topics](http://bookstore.trafford.com/Products/SKU-000177853/Database-Explorations.aspx): additional essays and debates on practical approaches to relational algebra engine design diff --git a/cbits/DirectoryFsync.c b/cbits/DirectoryFsync.c --- a/cbits/DirectoryFsync.c +++ b/cbits/DirectoryFsync.c @@ -24,11 +24,13 @@ ret = fstat(fd,&fdstat); if(ret < 0) { + close(fd); return errno; } if(!S_ISDIR(fdstat.st_mode)) { + close(fd); return ENOTDIR; } @@ -39,6 +41,7 @@ #else ret = fsync(fd); #endif + close(fd); if(ret < 0) { return errno; diff --git a/cbits/darwin_statfs.c b/cbits/darwin_statfs.c new file mode 100644 --- /dev/null +++ b/cbits/darwin_statfs.c @@ -0,0 +1,23 @@ +#include +#include +#include + +#ifndef _PROJECT_M36_STATFS_ +#define _PROJECT_M36_STATFS_ +#ifdef __APPLE__ +int cDarwinFSJournaled(const char* path) +{ + struct statfs s = {0}; + int ret = statfs(path, &s); + if(ret < 0) + { + /* error */ + return ret; + } + else + { + return s.f_flags & MNT_JOURNALED; + } +} +#endif +#endif diff --git a/examples/CustomTupleable.hs b/examples/CustomTupleable.hs new file mode 100644 --- /dev/null +++ b/examples/CustomTupleable.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +--this example shows how to implement a non-generics-defined Tupleable instance which is required in scenarios where Haskell-side types are not supported server-side or where one wishes to represent a nested relation +import ProjectM36.Client +import ProjectM36.Tuple +import ProjectM36.Tupleable +import ProjectM36.Relation +import ProjectM36.Atom +import ProjectM36.Attribute as A +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Text (Text) +import GHC.Generics +import Data.Proxy + +--in this contrived example, we wish to represent one relation with a nested relation of comments +data Blog = Blog { + title :: Text, + comments :: S.Set Comment + } deriving (Show) + +data Comment = Comment { + authorName :: Text, + comment :: Text + } deriving (Eq, Show, Generic, Ord) + +instance Tupleable Comment + +instance Tupleable Blog where + toTuple blogentry = + mkRelationTupleFromMap (M.fromList [("title", TextAtom (title blogentry)), + ("comments", RelationAtom relFromComments)]) + where + commentTuples = map toTuple (S.toList (comments blogentry)) + relFromComments = case mkRelationFromTuples (toAttributes (Proxy :: Proxy Comment)) commentTuples of + Left err -> error (show err) + Right rel -> rel + + fromTuple tupIn = do + titleAtom <- atomForAttributeName "title" tupIn + commentsAtom <- atomForAttributeName "comments" tupIn + commentsRel <- relationForAtom commentsAtom + comments' <- mapM fromTuple (tuplesList commentsRel) + pure Blog { + title = atomToText titleAtom, + comments = S.fromList comments'} + + toAttributes _ = A.attributesFromList [Attribute "title" TextAtomType, + Attribute "comments" $ RelationAtomType (toAttributes (Proxy :: Proxy Comment))] + +main :: IO () +main = do + let exampleBlog = Blog { title = "Cat Pics", + comments = S.fromList [Comment {authorName = "Steve", + comment = "great"}, + Comment {authorName = "Bob", + comment = "enough"} + ]} + print (toTuple exampleBlog) + print (fromTuple (toTuple exampleBlog) :: Either RelationalError Blog) + + + + + + + + diff --git a/examples/SimpleClient.hs b/examples/SimpleClient.hs --- a/examples/SimpleClient.hs +++ b/examples/SimpleClient.hs @@ -1,6 +1,7 @@ import ProjectM36.Client import ProjectM36.TupleSet import ProjectM36.Relation.Show.Term +import Data.Text.IO as TIO main :: IO () main = do @@ -32,7 +33,7 @@ eRel <- executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "person" ())) case eRel of Left err -> print err - Right rel -> print (showRelation rel) + Right rel -> TIO.putStrLn (showRelation rel) --7. close the connection close conn diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -1,5 +1,5 @@ Name: project-m36 -Version: 0.3 +Version: 0.4 License: PublicDomain Build-Type: Simple Homepage: https://github.com/agentm/project-m36 @@ -44,6 +44,7 @@ ,vector ,parallel ,monad-parallel + ,exceptions ,transformers ,gnuplot ,binary @@ -56,6 +57,7 @@ ,time ,hashable-time ,old-locale + ,rset --used for CSV parsing ,attoparsec ,either @@ -69,6 +71,8 @@ ,conduit ,resourcet ,http-api-data + -- used for arbitrary tuples + ,QuickCheck --needed for remote access ,distributed-process-client-server >= 0.2.3 ,distributed-process >= 0.6.6 @@ -111,6 +115,7 @@ ProjectM36.Relation.Show.HTML, ProjectM36.StaticOptimizer, ProjectM36.Relation.Show.Term, + ProjectM36.WCWidth, ProjectM36.Relation.Show.CSV, ProjectM36.Relation.Show.Gnuplot, ProjectM36.Relation.Parse.CSV, @@ -120,6 +125,7 @@ ProjectM36.Client.Simple, ProjectM36.Persist, ProjectM36.AtomType, + ProjectM36.AttributeExpr, ProjectM36.AtomFunctions.Basic, ProjectM36.AtomFunctions.Primitive, ProjectM36.Atomable, @@ -147,21 +153,23 @@ ProjectM36.Transaction.Persist, ProjectM36.TypeConstructor, ProjectM36.TypeConstructorDef, - ProjectM36.FileLock - GHC-Options: -Wall + ProjectM36.FileLock, + ProjectM36.FSType, + ProjectM36.Arbitrary + GHC-Options: -Wall -rdynamic if os(windows) Build-Depends: Win32 >= 2.3 Other-Modules: ProjectM36.Win32Handle else - C-sources: cbits/DirectoryFsync.c + C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c Build-Depends: unix - CC-Options: -fPIC + CC-Options: -fPIC Hs-Source-Dirs: ./src/lib Default-Language: Haskell2010 Default-Extensions: OverloadedStrings, CPP if impl(ghc>= 8) build-depends: - ghc-boot + ghc-boot, ghci Executable tutd Build-Depends: base >=4.8 && <5.0, @@ -221,18 +229,11 @@ TutorialD.Interpreter.SchemaOperator main-is: TutorialD/tutd.hs CC-Options: -fPIC - GHC-Options: -Wall + GHC-Options: -Wall -rdynamic Hs-Source-Dirs: ./src/bin Default-Language: Haskell2010 Default-Extensions: OverloadedStrings --- if os(windows) --- Build-Depends: Win32 >= 2.3 && < 2.4 --- Other-Modules: ProjectM36.Win32Handle --- else --- C-sources: ProjectM36/DirectoryFsync.c --- Build-Depends: unix - Executable project-m36-server Build-Depends: base, ghc >= 7.8 && < 8.3, @@ -285,6 +286,17 @@ if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall +Benchmark basic-benchmark + Default-Language: Haskell2010 + Default-Extensions: OverloadedStrings + Build-Depends: base, criterion, project-m36, text, vector, transformers, containers, temporary, directory, filepath + Main-Is: benchmark/Basic.hs + Type: exitcode-stdio-1.0 + GHC-Options: -Wall -threaded -rtsopts + HS-Source-Dirs: ./src/bin + if flag(profiler) + GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall + Test-Suite test-tutoriald Default-Language: Haskell2010 Default-Extensions: OverloadedStrings @@ -422,6 +434,13 @@ Main-Is: examples/hair.hs GHC-Options: -Wall +Executable Example-CustomTupleable + Default-Language: Haskell2010 + Default-Extensions: OverloadedStrings + Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36 + Main-Is: examples/CustomTupleable.hs + GHC-Options: -Wall + Test-Suite test-scripts Default-Language: Haskell2010 Default-Extensions: OverloadedStrings @@ -434,7 +453,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, network-transport-tcp, semigroups + Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, network-transport-tcp, semigroups, attoparsec Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs Other-Modules: ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator GHC-Options: -Wall @@ -484,6 +503,7 @@ type: exitcode-stdio-1.0 main-is: test/TransactionGraph/Automerge.hs Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups + Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types Default-Extensions: OverloadedStrings GHC-Options: -Wall Hs-Source-Dirs: ./src/bin, ., test/ @@ -533,3 +553,5 @@ HS-Source-Dirs: ./src/bin if flag(profiler) GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall + + 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 @@ -80,15 +80,6 @@ "val" .= decodeUtf8 (B64.encode i) ] toJSON atom@(BoolAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] - - toJSON atom@(IntervalAtom b e i1 i2) = object [ "type" .= atomTypeForAtom atom, - "val" .= object [ - "begin" .= toJSON b, - "end" .= toJSON e, - "beginopen" .= i1, - "endopen" .= i2 - ] - ] toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom, "val" .= i ] toJSON (ConstructedAtom dConsName atomtype atomlist) = object [ @@ -103,9 +94,7 @@ case atype of TypeVariableType _ -> fail "cannot pass TypeVariableType over the wire" caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom" - RelationAtomType _ -> do - rel <- o .: "val" - pure $ RelationAtom rel + RelationAtomType _ -> RelationAtom <$> o .: "val" IntAtomType -> IntAtom <$> o .: "val" IntegerAtomType -> IntegerAtom <$> o .: "val" DoubleAtomType -> DoubleAtom <$> o .: "val" @@ -120,12 +109,6 @@ Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err) Right bs -> pure (ByteStringAtom bs) BoolAtomType -> BoolAtom <$> o .: "val" - IntervalAtomType _ -> IntervalAtom <$> - ((o .: "val") >>= (.: "begin")) <*> - ((o .: "val") >>= (.: "end")) <*> - ((o .: "val") >>= (.: "beginopen")) <*> - ((o .: "val") >>= (.: "endopen")) - instance ToJSON Notification instance FromJSON Notification diff --git a/src/bin/ProjectM36/Server/WebSocket.hs b/src/bin/ProjectM36/Server/WebSocket.hs --- a/src/bin/ProjectM36/Server/WebSocket.hs +++ b/src/bin/ProjectM36/Server/WebSocket.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module ProjectM36.Server.WebSocket where -- while the tutd client performs TutorialD parsing on the client, the websocket server will pass tutd to be parsed and executed on the server- otherwise I have to pull in ghcjs as a dependency to allow client-side parsing- that's not appealing because then the frontend is not language-agnostic, but this could change in the future, perhaps by sending different messages over the websocket -- ideally, the wire protocol should not be exposed to a straight string-based API ala SQL, so we could make perhaps a javascript DSL which compiles to the necessary JSON- anaylyze tradeoffs @@ -9,11 +10,17 @@ import qualified Network.WebSockets as WS import ProjectM36.Server.RemoteCallTypes.Json () import ProjectM36.Client.Json () +import ProjectM36.Relation.Show.Term +import ProjectM36.Relation.Show.HTML import Data.Aeson import TutorialD.Interpreter import TutorialD.Interpreter.Base import ProjectM36.Client import Control.Exception +import Data.Attoparsec.Text +import Control.Applicative +import Text.Megaparsec.Error +import Data.Functor websocketProxyServer :: Port -> Hostname -> WS.ServerApp websocketProxyServer port host pending = do @@ -26,10 +33,9 @@ else do let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg bracket (createConnection conn dbname port host) - (\eDBconn -> case eDBconn of - Right dbconn -> close dbconn - Left _ -> pure ()) $ \eDBconn -> - case eDBconn of + (\case + Right dbconn -> close dbconn + Left _ -> pure ()) $ \case Left err -> sendError conn err Right dbconn -> do eSessionId <- createSessionAtHead dbconn "master" @@ -43,12 +49,11 @@ sendPromptInfo pInfo conn sendPromptInfo pInfo conn msg <- WS.receiveData conn :: IO T.Text - let tutdprefix = "executetutd:" - case msg of - _ | tutdprefix `T.isPrefixOf` msg -> do - let tutdString = T.drop (T.length tutdprefix) msg + case parseOnly parseExecuteMessage msg of + Left _ -> unexpectedMsg + Right (presentation, tutdString) -> case parseTutorialD tutdString of - Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err))) + Left err -> handleOpResult conn dbconn presentation (DisplayErrorResult ("parse error: " `T.append` T.pack (parseErrorPretty err))) Right parsed -> do let timeoutFilter exc = if exc == RequestTimeoutException then Just exc @@ -57,9 +62,8 @@ result <- evalTutorialD sessionId dbconn SafeEvaluation parsed pInfo' <- promptInfo sessionId dbconn sendPromptInfo pInfo' conn - handleOpResult conn dbconn result - catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn (DisplayErrorResult "Request Timed Out.")) - _ -> unexpectedMsg + handleOpResult conn dbconn presentation result + catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn presentation (DisplayErrorResult "Request Timed Out.")) pure () notificationCallback :: WS.Connection -> NotificationCallback @@ -74,15 +78,22 @@ sendError :: (ToJSON a) => WS.Connection -> a -> IO () sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err])) -handleOpResult :: WS.Connection -> Connection -> TutorialDOperatorResult -> IO () -handleOpResult conn db QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db -handleOpResult conn _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out])) -handleOpResult _ _ (DisplayIOResult ioout) = ioout -handleOpResult conn _ (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err])) -handleOpResult conn _ (DisplayParseErrorResult _ err) = WS.sendTextData conn (encode (object ["displayparseerrorresult" .= show err])) -handleOpResult conn _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True])) -handleOpResult conn _ (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel])) - +handleOpResult :: WS.Connection -> Connection -> Presentation -> TutorialDOperatorResult -> IO () +handleOpResult conn db _ QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db +handleOpResult conn _ _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out])) +handleOpResult _ _ _ (DisplayIOResult ioout) = ioout +handleOpResult conn _ presentation (DisplayErrorResult err) = do + let jsono = ["json" .= err | jsonPresentation presentation] + texto = ["text" .= err | textPresentation presentation] + htmlo = ["html" .= err | htmlPresentation presentation] + WS.sendTextData conn (encode (object ["displayerror" .= object (jsono ++ texto ++ htmlo)])) +handleOpResult conn _ _ (DisplayParseErrorResult _ err) = WS.sendTextData conn (encode (object ["displayparseerrorresult" .= show err])) +handleOpResult conn _ _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True])) +handleOpResult conn _ presentation (DisplayRelationResult rel) = do + let jsono = ["json" .= rel | jsonPresentation presentation] + texto = ["text" .= showRelation rel | textPresentation presentation] + htmlo = ["html" .= relationAsHTML rel | htmlPresentation presentation] + WS.sendTextData conn (encode (object ["displayrelation" .= object (jsono ++ texto ++ htmlo)])) -- get current schema and head name for client promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName) promptInfo sessionId conn = do @@ -92,3 +103,25 @@ sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO () sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]])) + +--a returning relation can be returned as JSON, Text (for consoles), or HTML +data Presentation = Presentation { + jsonPresentation :: Bool, + textPresentation :: Bool, + htmlPresentation :: Bool } + +data PresentationFlag = JSONFlag | TextFlag | HTMLFlag + +parseExecuteMessage :: Parser (Presentation, T.Text) +parseExecuteMessage = do + _ <- string "executetutd/" + flags <- sepBy ((string "json" $> JSONFlag) <|> + (string "text" $> TextFlag) <|> + (string "html" $> HTMLFlag)) "+" + let presentation = foldr (\flag acc -> case flag of + JSONFlag -> acc {jsonPresentation = True} + TextFlag -> acc {textPresentation = True} + HTMLFlag -> acc {htmlPresentation = True}) (Presentation False False False) flags + _ <- char ':' + tutd <- T.pack <$> manyTill anyChar endOfInput + pure (presentation, tutd) diff --git a/src/bin/TutorialD/Interpreter.hs b/src/bin/TutorialD/Interpreter.hs --- a/src/bin/TutorialD/Interpreter.hs +++ b/src/bin/TutorialD/Interpreter.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs, LambdaCase #-} module TutorialD.Interpreter where import TutorialD.Interpreter.Base import TutorialD.Interpreter.RODatabaseContextOperator @@ -224,9 +224,10 @@ type GhcPkgPath = String type TutorialDExec = String +type CheckFS = Bool -data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] | - RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec) +data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] CheckFS | + RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec) CheckFS outputNotificationCallback :: C.NotificationCallback outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot @@ -244,7 +245,7 @@ eHeadName <- C.headName sessionId conn eSchemaName <- C.currentSchemaName sessionId conn let prompt = promptText eHeadName eSchemaName - catchInterrupt = handleJust (\exc -> case exc of + catchInterrupt = handleJust (\case UserInterrupt -> Just Nothing _ -> Nothing) (\_ -> do hPutStrLn stderr "Statement cancelled. Use \":quit\" to exit tutd." @@ -253,15 +254,15 @@ case maybeLine of Nothing -> return () Just line -> do - runTutorialD sessionId conn (T.pack line) + runTutorialD sessionId conn (Just (T.length prompt)) (T.pack line) reprLoop config sessionId conn -runTutorialD :: C.SessionId -> C.Connection -> T.Text -> IO () -runTutorialD sessionId conn tutd = +runTutorialD :: C.SessionId -> C.Connection -> Maybe PromptLength -> T.Text -> IO () +runTutorialD sessionId conn mPromptLength tutd = case parseTutorialD tutd of Left err -> - displayOpResult $ DisplayParseErrorResult 0 err + displayOpResult $ DisplayParseErrorResult mPromptLength err Right parsed -> catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do evald <- evalTutorialDInteractive sessionId conn UnsafeEvaluation True parsed diff --git a/src/bin/TutorialD/Interpreter/Base.hs b/src/bin/TutorialD/Interpreter/Base.hs --- a/src/bin/TutorialD/Interpreter/Base.hs +++ b/src/bin/TutorialD/Interpreter/Base.hs @@ -22,6 +22,7 @@ import Data.List.NonEmpty as NE import Data.Time.Clock import Data.Time.Format +import Control.Monad (void) displayOpResult :: TutorialDOperatorResult -> IO () displayOpResult QuitResult = return () @@ -34,11 +35,12 @@ gen <- newStdGen let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen TIO.putStrLn (showRelation randomlySortedRel) -displayOpResult (DisplayParseErrorResult promptLength err) = TIO.putStrLn pointyString >> TIO.putStr ("ERR:" <> errString) - where - errString = T.pack (parseErrorPretty err) - errorIndent = unPos (sourceColumn (NE.head (errorPos err))) - pointyString = T.justifyRight (promptLength + fromIntegral errorIndent) '_' "^" +displayOpResult (DisplayParseErrorResult mPromptLength err) = do + let errString = T.pack (parseErrorPretty err) + errorIndent = unPos (sourceColumn (NE.head (errorPos err))) + pointyString len = T.justifyRight (len + fromIntegral errorIndent) '_' "^" + maybe (pure ()) (TIO.putStrLn . pointyString) mPromptLength + TIO.putStr ("ERR:" <> errString) spaceConsumer :: Parser () spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}") @@ -50,7 +52,7 @@ reserved word = try (string word *> notFollowedBy opChar *> spaceConsumer) reservedOp :: String -> Parser () -reservedOp op = try (string op *> notFollowedBy opChar *> spaceConsumer) +reservedOp op = try (spaceConsumer *> string op *> notFollowedBy opChar *> spaceConsumer) parens :: Parser a -> Parser a parens = between (symbol "(") (symbol ")") @@ -92,7 +94,7 @@ -} integer :: Parser Integer -integer = Lex.integer +integer = Lex.signed spaceConsumer Lex.integer float :: Parser Double float = Lex.float @@ -119,12 +121,14 @@ showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType attrsL = V.toList attrs +type PromptLength = Int + data TutorialDOperatorResult = QuitResult | DisplayResult StringType | DisplayIOResult (IO ()) | DisplayRelationResult Relation | DisplayErrorResult StringType | - DisplayParseErrorResult Int (ParseError Char Dec) | -- Int refers to length of prompt text + DisplayParseErrorResult (Maybe PromptLength) (ParseError Char Dec) | -- Int refers to length of prompt text QuietSuccessResult deriving (Generic) diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs --- a/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs @@ -15,6 +15,7 @@ import ProjectM36.Key import ProjectM36.FunctionalDependency import Data.Monoid +import Data.Functor --parsers which create "database expressions" which modify the database context (such as relvar assignment) databaseContextExprP :: Parser DatabaseContextExpr @@ -53,9 +54,8 @@ multilineSep = newline >> pure "\n" multipleDatabaseContextExprP :: Parser DatabaseContextExpr -multipleDatabaseContextExprP = do - exprs <- sepBy1 databaseContextExprP semi - pure $ MultipleExpr exprs +multipleDatabaseContextExprP = + MultipleExpr <$> sepBy1 databaseContextExprP semi insertP :: Parser DatabaseContextExpr insertP = do @@ -76,15 +76,12 @@ undefineP :: Parser DatabaseContextExpr undefineP = do reservedOp "undefine" - relVarName <- identifier - return $ Undefine relVarName + Undefine <$> identifier deleteP :: Parser DatabaseContextExpr deleteP = do reservedOp "delete" - relVarName <- identifier - predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP) - return $ Delete relVarName predicate + Delete <$> identifier <*> option TruePredicate (reservedOp "where" *> restrictionPredicateP) updateP :: Parser DatabaseContextExpr updateP = do @@ -101,7 +98,7 @@ reservedOp "constraint" <|> reservedOp "foreign key" constraintName <- identifier subset <- relExprP - op <- (reservedOp "in" *> pure SubsetOp) <|> (reservedOp "equals" *> pure EqualityOp) + op <- (reservedOp "in" $> SubsetOp) <|> (reservedOp "equals" $> EqualityOp) superset <- relExprP let subsetA = incDepSet constraintName subset superset subsetB = incDepSet (constraintName <> "_eqInvert") superset subset --inverted args for equality constraint @@ -201,14 +198,15 @@ evalDatabaseContextExpr useOptimizer context expr = do optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context) case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of - (Nothing, (context',_, _)) -> Right context' - (Just err, _) -> Left err + (Right (), (context',_, _)) -> Right context' + (Left err, _) -> Left err interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of Left err -> Left $ PM36E.ParseError (T.pack (show err)) - Right parsed -> evalDatabaseContextExpr True context parsed + Right parsed -> + evalDatabaseContextExpr True context parsed {- --no optimization diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs --- a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs @@ -13,6 +13,16 @@ addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr addDatabaseContextFunctionExprP = dbioexprP "adddatabasecontextfunction" AddDatabaseContextFunction + +createArbitraryRelationP :: Parser DatabaseContextIOExpr +createArbitraryRelationP = do + reserved "createarbitraryrelation" + relVarName <- identifier + attrExprs <- makeAttributeExprsP :: Parser [AttributeExpr] + min' <- fromInteger <$> integer + _ <- symbol "-" + max' <- fromInteger <$> integer + pure $ CreateArbitraryRelation relVarName attrExprs (min',max') dbioexprP :: String -> (Text -> [TypeConstructor] -> Text -> DatabaseContextIOExpr) -> Parser DatabaseContextIOExpr dbioexprP res adt = do @@ -26,6 +36,19 @@ atomTypeSignatureP = sepBy typeConstructorP arrow dbContextIOExprP :: Parser DatabaseContextIOExpr -dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP - +dbContextIOExprP = addAtomFunctionExprP <|> + addDatabaseContextFunctionExprP <|> + loadAtomFunctionsP <|> + loadDatabaseContextFunctionsP <|> + createArbitraryRelationP + +loadAtomFunctionsP :: Parser DatabaseContextIOExpr +loadAtomFunctionsP = do + reserved "loadatomfunctions" + LoadAtomFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString + +loadDatabaseContextFunctionsP :: Parser DatabaseContextIOExpr +loadDatabaseContextFunctionsP = do + reserved "loaddatabasecontextfunctions" + LoadDatabaseContextFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString diff --git a/src/bin/TutorialD/Interpreter/Import/TutorialD.hs b/src/bin/TutorialD/Interpreter/Import/TutorialD.hs --- a/src/bin/TutorialD/Interpreter/Import/TutorialD.hs +++ b/src/bin/TutorialD/Interpreter/Import/TutorialD.hs @@ -9,20 +9,24 @@ import qualified ProjectM36.Error as PM36E import qualified Data.Text as T import Control.Exception -import qualified Data.Text.IO as TIO +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE --import a file containing TutorialD database context expressions importTutorialD :: FilePath -> IO (Either RelationalError DatabaseContextExpr) importTutorialD pathIn = do - tutdData <- try (TIO.readFile pathIn) :: IO (Either IOError T.Text) - case tutdData of + eTutdBytes <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString) + case eTutdBytes of Left err -> return $ Left (ImportError $ T.pack (show err)) - Right tutdData' -> - case parse multipleDatabaseContextExprP "import" tutdData' of - --parseErrorPretty is new in megaparsec 5 - Left err -> pure (Left (PM36E.ParseError (T.pack (show err)))) - Right expr -> pure (Right expr) - + Right tutdBytes -> + case TE.decodeUtf8' tutdBytes of + Left err -> pure (Left (ImportError $ T.pack (show err))) + Right tutdUtf8 -> + case parse multipleDatabaseContextExprP "import" tutdUtf8 of + --parseErrorPretty is new in megaparsec 5 + Left err -> pure (Left (PM36E.ParseError (T.pack (show err)))) + Right expr -> pure (Right expr) + tutdImportP :: Parser DatabaseContextDataImportOperator tutdImportP = do reserved ":importtutd" diff --git a/src/bin/TutorialD/Interpreter/InformationOperator.hs b/src/bin/TutorialD/Interpreter/InformationOperator.hs --- a/src/bin/TutorialD/Interpreter/InformationOperator.hs +++ b/src/bin/TutorialD/Interpreter/InformationOperator.hs @@ -4,6 +4,11 @@ import Text.Megaparsec import Text.Megaparsec.Text import TutorialD.Interpreter.Base +-- older versions of stack fail to +#if !defined(VERSION_project_m36) +# warning Failed to discover proper version from cabal_macros.h +# define VERSION_project_m36 "" +#endif -- this module provides information about the current interpreter diff --git a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs --- a/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +++ b/src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs @@ -24,26 +24,25 @@ ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator ShowTypes :: RODatabaseContextOperator ShowRelationVariables :: RODatabaseContextOperator + ShowAtomFunctions :: RODatabaseContextOperator + ShowDatabaseContextFunctions :: RODatabaseContextOperator Quit :: RODatabaseContextOperator deriving (Show) typeP :: Parser RODatabaseContextOperator typeP = do reservedOp ":type" - expr <- relExprP - return $ ShowRelationType expr + ShowRelationType <$> relExprP showRelP :: Parser RODatabaseContextOperator showRelP = do reservedOp ":showexpr" - expr <- relExprP - return $ ShowRelation expr + ShowRelation <$> relExprP showPlanP :: Parser RODatabaseContextOperator showPlanP = do reservedOp ":showplan" - expr <- databaseContextExprP - return $ ShowPlan expr + ShowPlan <$> databaseContextExprP showTypesP :: Parser RODatabaseContextOperator showTypesP = reserved ":showtypes" >> pure ShowTypes @@ -51,6 +50,12 @@ showRelationVariables :: Parser RODatabaseContextOperator showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables +showAtomFunctionsP :: Parser RODatabaseContextOperator +showAtomFunctionsP = reserved ":showatomfunctions" >> pure ShowAtomFunctions + +showDatabaseContextFunctionsP :: Parser RODatabaseContextOperator +showDatabaseContextFunctionsP = reserved ":showdatabasecontextfunctions" >> pure ShowDatabaseContextFunctions + quitP :: Parser RODatabaseContextOperator quitP = do reservedOp ":quit" @@ -59,14 +64,12 @@ showConstraintsP :: Parser RODatabaseContextOperator showConstraintsP = do reservedOp ":constraints" - constraintName <- option "" identifier - return $ ShowConstraint constraintName + ShowConstraint <$> option "" identifier plotRelExprP :: Parser RODatabaseContextOperator plotRelExprP = do reserved ":plotexpr" - expr <- relExprP - return $ PlotRelation expr + PlotRelation <$> relExprP roDatabaseContextOperatorP :: Parser RODatabaseContextOperator roDatabaseContextOperatorP = typeP @@ -76,6 +79,8 @@ <|> showConstraintsP <|> showPlanP <|> showTypesP + <|> showAtomFunctionsP + <|> showDatabaseContextFunctionsP <|> quitP --logically, these read-only operations could happen purely, but not if a remote call is required @@ -127,6 +132,18 @@ evalRODatabaseContextOp sessionId conn ShowRelationVariables = do eRel <- C.relationVariablesAsRelation sessionId conn + case eRel of + Left err -> pure $ DisplayErrorResult (T.pack (show err)) + Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel)) + +evalRODatabaseContextOp sessionId conn ShowAtomFunctions = do + eRel <- C.atomFunctionsAsRelation sessionId conn + case eRel of + Left err -> pure $ DisplayErrorResult (T.pack (show err)) + Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel)) + +evalRODatabaseContextOp sessionId conn ShowDatabaseContextFunctions = do + eRel <- C.databaseContextFunctionsAsRelation sessionId conn case eRel of Left err -> pure $ DisplayErrorResult (T.pack (show err)) Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel)) 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 @@ -11,19 +11,14 @@ import Data.List (sort) import ProjectM36.MiscUtils -class RelationalMarkerExpr a where - parseMarkerP :: Parser a - -instance RelationalMarkerExpr () where - parseMarkerP = pure () - --used in projection -attributeListP :: Parser AttributeNames -attributeListP = do - but <- try (string "all but " <* spaceConsumer) <|> string "" - let constructor = if but == "" then AttributeNames else InvertedAttributeNames - attrs <- sepBy identifier comma - pure $ constructor (S.fromList attrs) +attributeListP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a) +attributeListP = + (reservedOp "all but" >> + InvertedAttributeNames . S.fromList <$> sepBy identifier comma) <|> + (reservedOp "all from" >> + RelationalExprAttributeNames <$> relExprP) <|> + (AttributeNames . S.fromList <$> sepBy identifier comma) makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) makeRelationP = do @@ -32,12 +27,6 @@ tupleExprs <- braces (sepBy tupleExprP comma) <|> pure [] pure $ MakeRelationFromExprs attrExprs tupleExprs ---used in relation creation -makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a] -makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma) - -attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a) -attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP --abstract data type parser- in this context, the type constructor must not include any type arguments --Either Text Int @@ -64,10 +53,8 @@ atomExpr <- atomExprP pure (attributeName, atomExpr) -projectP :: Parser (RelationalExprBase a -> RelationalExprBase a) -projectP = do - attrs <- braces attributeListP - pure $ Project attrs +projectP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) +projectP = Project <$> braces attributeListP renameClauseP :: Parser (T.Text, T.Text) renameClauseP = do @@ -88,14 +75,14 @@ whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP) -groupClauseP :: Parser (AttributeNames, T.Text) +groupClauseP :: RelationalMarkerExpr a => Parser (AttributeNamesBase a, T.Text) groupClauseP = do attrs <- braces attributeListP reservedOp "as" newAttrName <- identifier pure (attrs, newAttrName) -groupP :: Parser (RelationalExprBase a -> RelationalExprBase a) +groupP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) groupP = do reservedOp "group" (groupAttrList, groupAttrName) <- parens groupClauseP @@ -111,9 +98,21 @@ extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a) extendP = do reservedOp ":" - tupleExpr <- braces extendTupleExpressionP - return $ Extend tupleExpr - + Extend <$> braces extendTupleExpressionP + +semijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a) +semijoinP = do + reservedOp "semijoin" <|> reservedOp "matching" + pure (\exprA exprB -> + Project (RelationalExprAttributeNames exprA) (Join exprA exprB)) + +antijoinP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a -> RelationalExprBase a) +antijoinP = do + reservedOp "not matching" <|> reservedOp "antijoin" + pure (\exprA exprB -> + Difference exprA ( + Project (RelationalExprAttributeNames exprA) (Join exprA exprB))) + relOperators :: RelationalMarkerExpr a => [[Operator Parser (RelationalExprBase a)]] relOperators = [ [Postfix projectP], @@ -122,6 +121,8 @@ [Postfix groupP], [Postfix ungroupP], [InfixL (reservedOp "join" >> return Join)], + [InfixL semijoinP], + [InfixL antijoinP], [InfixL (reservedOp "union" >> return Union)], [InfixL (reservedOp "minus" >> return Difference)], [InfixN (reservedOp "=" >> return Equals)], @@ -150,26 +151,23 @@ predicateTerm = try (parens restrictionPredicateP) <|> try restrictionAtomExprP <|> try restrictionAttributeEqualityP - <|> try relationalBooleanExprP - + <|> relationalBooleanExprP relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) -relationalBooleanExprP = do - relexpr <- parens relExprP <|> relTerm +relationalBooleanExprP = --we can't actually detect if the type is relational boolean, so we just pass it to the next phase - return $ RelationalExprPredicate relexpr + RelationalExprPredicate <$> (parens relExprP <|> relTerm) restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a) restrictionAttributeEqualityP = do attributeName <- identifier reservedOp "=" - atomexpr <- atomExprP - return $ AttributeEqualityPredicate attributeName atomexpr + 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 - AtomExprPredicate <$> atomExprP + (try (char 't') >> pure TruePredicate) <|> (try (char 'f') >> pure (NotPredicate TruePredicate)) <|> AtomExprPredicate <$> atomExprP multiTupleExpressionP :: RelationalMarkerExpr a => Parser [ExtendTupleExprBase a] multiTupleExpressionP = sepBy extendTupleExpressionP comma @@ -181,8 +179,7 @@ attributeExtendTupleExpressionP = do newAttr <- identifier reservedOp ":=" - atom <- atomExprP - return $ AttributeExtendTupleExpr newAttr atom + AttributeExtendTupleExpr newAttr <$> atomExprP atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) atomExprP = consumeAtomExprP True @@ -198,8 +195,7 @@ attributeAtomExprP :: Parser (AtomExprBase a) attributeAtomExprP = do _ <- string "@" - attrName <- identifier - return $ AttributeAtomExpr attrName + AttributeAtomExpr <$> identifier nakedAtomExprP :: Parser (AtomExprBase a) nakedAtomExprP = NakedAtomExpr <$> atomP @@ -219,11 +215,8 @@ boolAtomP functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) -functionAtomExprP = do - funcName <- identifier - argList <- parens (sepBy atomExprP comma) - marker <- parseMarkerP - return $ FunctionAtomExpr funcName argList marker +functionAtomExprP = + FunctionAtomExpr <$> identifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) relationalAtomExprP = RelationAtomExpr <$> relExprP diff --git a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs --- a/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs @@ -3,6 +3,7 @@ module TutorialD.Interpreter.TransGraphRelationalOperator where import ProjectM36.TransGraphRelationalExpression import ProjectM36.TransactionGraph +import TutorialD.Interpreter.Types import qualified ProjectM36.Client as C import TutorialD.Interpreter.Base @@ -15,7 +16,7 @@ instance RelationalMarkerExpr TransactionIdLookup where parseMarkerP = string "@" *> transactionIdLookupP - + newtype TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr deriving Show @@ -29,9 +30,7 @@ (string "@" *> (TransactionStampHeadBacktrack <$> utcTimeP)) backtrackP :: Parser Int -backtrackP = do - steps <- integer <|> pure 1 - pure (fromIntegral steps) +backtrackP = fromIntegral <$> integer <|> pure 1 transGraphRelationalOpP :: Parser TransGraphRelationalOperator transGraphRelationalOpP = showTransGraphRelationalOpP diff --git a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs --- a/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +++ b/src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs @@ -6,6 +6,7 @@ import ProjectM36.TransactionGraph hiding (autoMergeToHead) import ProjectM36.Client import ProjectM36.Base +import Data.Functor data ConvenienceTransactionGraphOperator = AutoMergeToHead MergeStrategy HeadName deriving (Show) @@ -21,14 +22,12 @@ jumpToHeadP :: Parser TransactionGraphOperator jumpToHeadP = do reservedOp ":jumphead" - headid <- identifier - return $ JumpToHead headid + JumpToHead <$> identifier jumpToTransactionP :: Parser TransactionGraphOperator jumpToTransactionP = do reservedOp ":jump" - uuid <- uuidP - return $ JumpToTransaction uuid + JumpToTransaction <$> uuidP walkBackToTimeP :: Parser TransactionGraphOperator walkBackToTimeP = do @@ -38,8 +37,7 @@ branchTransactionP :: Parser TransactionGraphOperator branchTransactionP = do reservedOp ":branch" - branchName <- identifier - return $ Branch branchName + Branch <$> identifier deleteBranchP :: Parser TransactionGraphOperator deleteBranchP = do @@ -62,7 +60,7 @@ return ShowGraph mergeTransactionStrategyP :: Parser MergeStrategy -mergeTransactionStrategyP = (reserved "union" *> pure UnionMergeStrategy) <|> +mergeTransactionStrategyP = (reserved "union" $> UnionMergeStrategy) <|> (do reserved "selectedbranch" branch <- identifier 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 @@ -4,9 +4,13 @@ import Text.Megaparsec.Text import Text.Megaparsec import TutorialD.Interpreter.Base -import ProjectM36.DataTypes.Primitive -import qualified Data.Text as T +class RelationalMarkerExpr a where + parseMarkerP :: Parser a + +instance RelationalMarkerExpr () where + parseMarkerP = pure () + -- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments. -- data *Either a b* = Left a | Right b typeConstructorDefP :: Parser TypeConstructorDef @@ -25,25 +29,30 @@ DataConstructorDefTypeConstructorArg <$> typeConstructorP <|> DataConstructorDefTypeVarNameArg <$> uncapitalizedIdentifier ---built-in, nullary type constructors --- Int, Text, etc. -primitiveTypeConstructorP :: Parser TypeConstructor -primitiveTypeConstructorP = choice (map (\(PrimitiveTypeConstructorDef name typ, _) -> do - tName <- try $ symbol (T.unpack name) - pure $ PrimitiveTypeConstructor tName typ) - primitiveTypeConstructorMapping) +-- relation{a Int} in type construction (no tuples parsed) +relationTypeConstructorP :: Parser TypeConstructor +relationTypeConstructorP = do + reserved "relation" + RelationAtomTypeConstructor <$> makeAttributeExprsP + +--used in relation creation +makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a] +makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma) + +attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a) +attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP + -- *Either Int Text*, *Int* typeConstructorP :: Parser TypeConstructor -typeConstructorP = primitiveTypeConstructorP <|> +typeConstructorP = relationTypeConstructorP <|> TypeVariable <$> uncapitalizedIdentifier <|> ADTypeConstructor <$> capitalizedIdentifier <*> many (parens typeConstructorP <|> monoTypeConstructorP) monoTypeConstructorP :: Parser TypeConstructor -monoTypeConstructorP = primitiveTypeConstructorP <|> - ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|> - TypeVariable <$> uncapitalizedIdentifier +monoTypeConstructorP = ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|> + TypeVariable <$> uncapitalizedIdentifier diff --git a/src/bin/TutorialD/tutd.hs b/src/bin/TutorialD/tutd.hs --- a/src/bin/TutorialD/tutd.hs +++ b/src/bin/TutorialD/tutd.hs @@ -2,41 +2,30 @@ import TutorialD.Interpreter import ProjectM36.Base import ProjectM36.Client +import ProjectM36.Server.ParseArgs +import ProjectM36.Server import System.IO import Options.Applicative import System.Exit import Data.Monoid +import Data.Maybe import qualified Data.Text as T +#if !defined(VERSION_project_m36) +# warning Failed to discover proper version from cabal_macros.h +# define VERSION_project_m36 "" +#endif + parseArgs :: Parser InterpreterConfig -parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> parseGhcPkgPaths <|> - RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec +parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> many parseGhcPkgPath <*> parseCheckFS <|> + RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec <*> parseCheckFS -parsePersistenceStrategy :: Parser PersistenceStrategy -parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|> - MinimalPersistence <$> dbdirOpt <|> - pure NoPersistence - where - dbdirOpt = strOption (short 'd' <> - long "database-directory" <> - metavar "DIRECTORY" <> - showDefaultWith show - ) - fsyncOpt = switch (short 'f' <> - long "fsync" <> - help "Fsync all new transactions.") - parseHeadName :: Parser HeadName parseHeadName = option auto (long "head" <> help "Start session at head name." <> value "master" ) - -parseDatabaseName :: Parser DatabaseName -parseDatabaseName = strOption (long "database" <> - short 'n' <> - help "Remote database name") - + parseNodeId :: Parser NodeId parseNodeId = createNodeId <$> strOption (long "host" <> @@ -54,31 +43,29 @@ short 'e' <> help "Execute TutorialD expression and exit" ) - -parseGhcPkgPaths :: Parser [GhcPkgPath] -parseGhcPkgPaths = many (strOption (long "ghc-pkg-dir" <> - metavar "GHC_PACKAGE_DIRECTORY")) opts :: ParserInfo InterpreterConfig opts = info parseArgs idm connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo -connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths -connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback +connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths _) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths +connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback headNameForConfig :: InterpreterConfig -> HeadName -headNameForConfig (LocalInterpreterConfig _ headn _ _) = headn -headNameForConfig (RemoteInterpreterConfig _ _ headn _) = headn +headNameForConfig (LocalInterpreterConfig _ headn _ _ _) = headn +headNameForConfig (RemoteInterpreterConfig _ _ headn _ _) = headn execTutDForConfig :: InterpreterConfig -> Maybe String -execTutDForConfig (LocalInterpreterConfig _ _ t _) = t -execTutDForConfig (RemoteInterpreterConfig _ _ _ t) = t +execTutDForConfig (LocalInterpreterConfig _ _ t _ _) = t +execTutDForConfig (RemoteInterpreterConfig _ _ _ t _) = t -{- -ghcPkgPathsForConfig :: InterpreterConfig -> [GhcPkgPath] -ghcPkgPathsForConfig (LocalInterpreterConfig _ _ paths) = paths -ghcPkgPathsForConfig _ = error "Clients cannot configure remote ghc package paths." --} +checkFSForConfig :: InterpreterConfig -> Bool +checkFSForConfig (LocalInterpreterConfig _ _ _ _ c) = c +checkFSForConfig (RemoteInterpreterConfig _ _ _ _ c) = c + +persistenceStrategyForConfig :: InterpreterConfig -> Maybe PersistenceStrategy +persistenceStrategyForConfig (LocalInterpreterConfig strat _ _ _ _) = Just strat +persistenceStrategyForConfig RemoteInterpreterConfig{} = Nothing errDie :: String -> IO () errDie err = hPutStrLn stderr err >> exitFailure @@ -97,21 +84,25 @@ main = do interpreterConfig <- execParser opts let connInfo = connectionInfoForConfig interpreterConfig - dbconn <- connectProjectM36 connInfo - case dbconn of - Left err -> - errDie ("Failed to create database connection: " ++ show err) - Right conn -> do - let connHeadName = headNameForConfig interpreterConfig - eSessionId <- createSessionAtHead conn connHeadName - case eSessionId of - Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err) - Right sessionId -> - case execTutDForConfig interpreterConfig of - Nothing -> do - printWelcome - _ <- reprLoop interpreterConfig sessionId conn - pure () - Just tutdStr -> - runTutorialD sessionId conn (T.pack tutdStr) + fscheck <- checkFSType (checkFSForConfig interpreterConfig) (fromMaybe NoPersistence (persistenceStrategyForConfig interpreterConfig)) + if not fscheck then + errDie checkFSErrorMsg + else do + dbconn <- connectProjectM36 connInfo + case dbconn of + Left err -> + errDie ("Failed to create database connection: " ++ show err) + Right conn -> do + let connHeadName = headNameForConfig interpreterConfig + eSessionId <- createSessionAtHead conn connHeadName + case eSessionId of + Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err) + Right sessionId -> + case execTutDForConfig interpreterConfig of + Nothing -> do + printWelcome + _ <- reprLoop interpreterConfig sessionId conn + pure () + Just tutdStr -> + runTutorialD sessionId conn Nothing (T.pack tutdStr) diff --git a/src/bin/benchmark/Basic.hs b/src/bin/benchmark/Basic.hs new file mode 100644 --- /dev/null +++ b/src/bin/benchmark/Basic.hs @@ -0,0 +1,106 @@ +import ProjectM36.Base +import Criterion.Main +import qualified ProjectM36.Attribute as A +import ProjectM36.Relation +import ProjectM36.Persist +import ProjectM36.RelationalExpression +import ProjectM36.Error +import ProjectM36.Transaction.Persist +import qualified Data.Text as T +import qualified Data.Vector as V +import Control.Monad.Trans.Reader +import qualified ProjectM36.DatabaseContext as DBC +import qualified Data.Set as S +import Data.Monoid +import System.IO.Temp +import System.FilePath +import System.Directory + +{- +* create a relation +* restrict a relation +* project a relation +* join two relations +-} + +validate :: Either RelationalError a -> a +validate (Left err) = error (show err) +validate (Right x) = x + +createRelation :: Int -> Int -> Either RelationalError Relation +createRelation attributeCount tupleCount = do + let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1] + tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom (fromIntegral tupleX))) + tuples = map tuple [0 .. tupleCount] + mkRelationDeferVerify attrs (RelationTupleSet tuples) + +createRelation' :: Int -> Int -> Relation +createRelation' x y = validate (createRelation x y) + +restrictRelationToOneTuple :: Int -> Relation -> Relation +restrictRelationToOneTuple match rel = validate (runReader (evalRelationalExpr restriction) exprState) + where + exprState = mkRelationalExprState DBC.empty + restriction = Restrict predicateMatch (ExistingRelation rel) + predicateMatch = AttributeEqualityPredicate "a0" (NakedAtomExpr (IntAtom match)) + +restrictRelationToHalfRelation :: Int -> Relation -> Relation +restrictRelationToHalfRelation cutoff rel = validate (runReader (evalRelationalExpr restriction) exprState) + where + exprState = mkRelationalExprState DBC.basicDatabaseContext + restriction = Restrict predicateMatch (ExistingRelation rel) + predicateMatch = AtomExprPredicate (FunctionAtomExpr "lte" [AttributeAtomExpr "a0", NakedAtomExpr (IntAtom cutoff)] ()) + +projectRelationToAttributes :: AttributeNames -> Relation -> Relation +projectRelationToAttributes attrNames rel = validate (runReader (evalRelationalExpr projection) exprState) + where + exprState = mkRelationalExprState DBC.empty + projection = Project attrNames (ExistingRelation rel) + +unionRelations :: Relation -> Relation -> Relation +unionRelations relA relB = validate (relA `union` relB) + +joinRelations :: Relation -> Relation -> Relation +joinRelations relA relB = validate (join relA relB) + +groupRelation :: AttributeNames -> Relation -> Relation +groupRelation attrNames rel = validate (runReader (evalRelationalExpr (Group attrNames "x" (ExistingRelation rel))) exprState) + where + exprState = mkRelationalExprState DBC.empty + +bigRelAttrNames :: Int -> Int -> AttributeNames +bigRelAttrNames start end = AttributeNames (S.fromList (map (\i -> "a" <> T.pack (show i)) [start .. end])) + +main :: IO () +main = do + tmpDir <- getCanonicalTemporaryDirectory + createDirectoryIfMissing False (tmpDir "relvars") + defaultMain [createRel, restrictRel, projectRel, unionRel, joinRel, groupRel, writeRel tmpDir] + where + createRel = bgroup "create" $ map (\tupCount -> bench ("relation 10x" ++ show tupCount) (nf (createRelation' 10) tupCount)) [100, 1000, 10000] + bigrel10000 = createRelation' 10 10000 + bigrel1000 = createRelation' 10 1000 + bigrel100 = createRelation' 10 100 + + restrictRel = bgroup "restrict" [restrictOneTupleRel, restrictHalfTuplesRel] + restrictOneTupleRel = bench "restrict relation 10x10000 to 10x1" (nf (restrictRelationToOneTuple 5000) bigrel10000) + restrictHalfTuplesRel = bench "restrict relation 10x10000 to 10x5000" (nf (restrictRelationToHalfRelation 5000) bigrel10000) + + projectRel = bgroup "project" [projectOneAttr, projectHalfAttrs] + projectOneAttr = bench "project 10x1000 to 1x1000" (nf (projectRelationToAttributes (bigRelAttrNames 0 0)) bigrel1000) + projectHalfAttrs = bench "project 10x1000 to 5x1000" (nf (projectRelationToAttributes (bigRelAttrNames 0 4)) bigrel1000) + + unionRel = bgroup "union" [unionIdenticalRelations1000, unionIdenticalRelations10000] + unionIdenticalRelations1000 = bench "union identical 10x1000" (nf (unionRelations bigrel1000) bigrel1000) + unionIdenticalRelations10000 = bench "union identical 10x10000" (nf (unionRelations bigrel10000) bigrel10000) + + joinRel = bgroup "join" [joinIdenticalRelations100] + joinIdenticalRelations100 = bench "join identical 10x100" (nf (joinRelations bigrel100) bigrel100) + + groupRel = bgroup "group" [group100] + group100 = bench "group 10x100" (nf (groupRelation (bigRelAttrNames 1 9)) bigrel100) + + writeRel tmpDir = bgroup "write" [writeRel10000 tmpDir] + writeRel10000 tmpDir = bench "write 10x1000" $ nfIO (writeRelVar FsyncDiskSync tmpDir ("x", bigrel10000)) + + diff --git a/src/bin/benchmark/Handles.hs b/src/bin/benchmark/Handles.hs --- a/src/bin/benchmark/Handles.hs +++ b/src/bin/benchmark/Handles.hs @@ -1,13 +1,13 @@ {-# LANGUAGE CPP #-} --benchmark test for file handle leaks import ProjectM36.Client +import ProjectM36.Persist import Options.Applicative import TutorialD.Interpreter import TutorialD.Interpreter.Base import qualified Data.Text as T import Text.Megaparsec hiding (option) import Data.Monoid -import System.Directory import Control.Monad data HandlesArgs = HandlesArgs { @@ -85,24 +85,3 @@ Left err -> error (show err) Right _ -> printFdCount ---prints out number of consumed file descriptors -printFdCount :: IO () -#if defined(linux_HOST_OS) -printFdCount = do - fdc <- fdCount - putStrLn ("Fd count: " ++ show fdc) - --getLine >> pure () -#else -printFdCount = putStrLn "Fd count not supported on this OS." -#endif - - -fdCount :: IO Int -#if defined(linux_HOST_OS) -fdCount = do - fds <- getDirectoryContents "/proc/self/fd" - pure ((length fds) - 2) -#else ---not supported on non-linux -fdCount = pure 0 -#endif diff --git a/src/lib/ProjectM36/Arbitrary.hs b/src/lib/ProjectM36/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/Arbitrary.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE ExistentialQuantification,FlexibleInstances,OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module ProjectM36.Arbitrary where +import ProjectM36.Base +import ProjectM36.Error +import ProjectM36.AtomFunctionError +import ProjectM36.AtomType +import ProjectM36.Attribute (atomType) +import ProjectM36.DataConstructorDef as DCD +import ProjectM36.DataTypes.Interval +import qualified Data.Vector as V +import Data.Text (Text,pack) +import Test.QuickCheck +import qualified Data.ByteString.Char8 as B +import Data.Time +import Control.Monad.Reader + +arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom) +arbitrary' IntegerAtomType = + Right . IntegerAtom <$> lift (arbitrary :: Gen Integer) + +arbitrary' (RelationAtomType attrs) = do + tcMap <-ask + maybeRel <- lift $ runReaderT (arbitraryRelation attrs (0,5)) tcMap + case maybeRel of + Left err -> pure $ Left err + Right rel -> pure $ Right $ RelationAtom rel + +arbitrary' IntAtomType = + Right . IntAtom <$> lift (arbitrary :: Gen Int) + +arbitrary' DoubleAtomType = + Right . DoubleAtom <$> lift (arbitrary :: Gen Double) + +arbitrary' TextAtomType = + Right . TextAtom <$> lift (arbitrary :: Gen Text) + +arbitrary' DayAtomType = + Right . DayAtom <$> lift (arbitrary :: Gen Day) + +arbitrary' DateTimeAtomType = + Right . DateTimeAtom <$> lift (arbitrary :: Gen UTCTime) + +arbitrary' ByteStringAtomType = + Right . ByteStringAtom <$> lift (arbitrary :: Gen B.ByteString) + +arbitrary' BoolAtomType = + Right . BoolAtom <$> lift (arbitrary :: Gen Bool) +arbitrary' constructedAtomType@(ConstructedAtomType tcName tvMap) + --special-casing for Interval type + | isIntervalAtomType constructedAtomType = createArbitraryInterval (intervalSubType constructedAtomType) + | otherwise = do + tcMap <- ask + let maybeTCons = findTypeConstructor tcName tcMap + let eitherTCons = maybeToRight (NoSuchTypeConstructorName tcName) maybeTCons + let eitherDCDefs = snd <$> eitherTCons + let eitherGenDCDef = elements <$> eitherDCDefs + case eitherGenDCDef of + Left err -> pure $ Left err + Right genDCDef -> do + dcDef <- lift genDCDef + case resolvedAtomTypesForDataConstructorDefArgs tcMap tvMap dcDef of + Left err -> pure $ Left err + Right atomTypes -> do + let genListOfEitherAtom = mapM (\aTy->runReaderT (arbitrary' aTy) tcMap) atomTypes + listOfEitherAtom <- lift genListOfEitherAtom + let eitherListOfAtom = sequence listOfEitherAtom + case eitherListOfAtom of + Left err -> pure $ Left err + Right listOfAtom -> pure $ Right $ ConstructedAtom (DCD.name dcDef) constructedAtomType listOfAtom +arbitrary' (TypeVariableType _) = error "arbitrary on type variable" + +maybeToRight :: b -> Maybe a -> Either b a +maybeToRight _ (Just x) = Right x +maybeToRight y Nothing = Left y + +instance Arbitrary Text where + arbitrary = pack <$> elements (map (replicate 3) ['A'..'Z']) + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> (arbitrary :: Gen Integer) + +instance Arbitrary UTCTime where + arbitrary = UTCTime <$> arbitrary <*> (secondsToDiffTime <$> choose(0,86400)) + +instance Arbitrary B.ByteString where + arbitrary = B.pack <$> (arbitrary :: Gen String) + +arbitraryRelationTuple :: Attributes -> WithTCMap Gen (Either RelationalError RelationTuple) +arbitraryRelationTuple attris = do + tcMap <- ask + listOfMaybeAType <- lift $ mapM ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList attris) + case sequence listOfMaybeAType of + Left err -> pure $ Left err + Right listOfAttr -> do + let vectorOfAttr = V.fromList listOfAttr + pure $ Right $ RelationTuple attris vectorOfAttr + +arbitraryWithRange :: Gen (Either RelationalError RelationTuple) -> Range -> Gen [Either RelationalError RelationTuple] +arbitraryWithRange genEitherTuple range = do + num <- choose range + vectorOf num genEitherTuple + +arbitraryRelation :: Attributes -> Range -> WithTCMap Gen (Either RelationalError Relation) +arbitraryRelation attris range = do + tcMap <- ask + let genEitherTuple = runReaderT (arbitraryRelationTuple attris) tcMap + listOfEitherTuple <- lift $ arbitraryWithRange genEitherTuple range + let eitherTupleList = sequence listOfEitherTuple + case eitherTupleList of + Left err -> pure $ Left err + Right tupleList -> pure $ Right $ Relation attris $ RelationTupleSet tupleList + +type WithTCMap a = ReaderT TypeConstructorMapping a + +createArbitraryInterval :: AtomType -> WithTCMap Gen (Either RelationalError Atom) +createArbitraryInterval subType = if supportsInterval subType then do + eBegin <- arbitrary' subType + eEnd <- arbitrary' subType + beginopen <- lift (arbitrary :: Gen Bool) + endopen <- lift (arbitrary :: Gen Bool) + case eBegin of + Left err -> pure (Left err) + Right begin -> + case eEnd of + Left err -> pure (Left err) + Right end -> + case createInterval begin end beginopen endopen of + Left _ -> createArbitraryInterval subType + Right val -> pure (Right val) + else + pure $ Left (ProjectM36.Error.AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError (prettyAtomType subType))) 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 @@ -1,10 +1,8 @@ module ProjectM36.Atom where import ProjectM36.Base import ProjectM36.Error +import ProjectM36.DataTypes.Interval import qualified Data.Text as T ---import Data.Time.Calendar ---import Data.Time.Clock ---import Data.ByteString (ByteString) import Data.Monoid relationForAtom :: Atom -> Either RelationalError Relation @@ -15,19 +13,23 @@ atomToText (IntegerAtom i) = (T.pack . show) i atomToText (IntAtom i) = (T.pack . show) i atomToText (DoubleAtom i) = (T.pack . show) i -atomToText (TextAtom i) = (T.pack . show) i --does this break quoting in CSV export? +atomToText (TextAtom i) = (T.pack . show) i --quotes necessary for ConstructedAtom subatoms atomToText (DayAtom i) = (T.pack . show) i atomToText (DateTimeAtom i) = (T.pack . show) i atomToText (ByteStringAtom i) = (T.pack . show) i atomToText (BoolAtom i) = (T.pack . show) i -atomToText (IntervalAtom b e bo be) = beginp <> begin <> "," <> end <> endp - where beginp = if bo then "(" else "[" - begin = atomToText b - end = atomToText e - endp = if be then ")" else "]" atomToText (RelationAtom i) = (T.pack . show) i -atomToText (ConstructedAtom dConsName _ atoms) = dConsName <> dConsArgs +atomToText (ConstructedAtom dConsName typ atoms) + | isIntervalAtomType typ = case atoms of --special handling for printing intervals + [b, e, BoolAtom bo, BoolAtom be] -> + let beginp = if bo then "(" else "[" + begin = atomToText b + end = atomToText e + endp = if be then ")" else "]" in + beginp <> begin <> "," <> end <> endp + _ -> "invalid interval" + | otherwise = dConsName <> dConsArgs where parensAtomToText a@(ConstructedAtom _ _ []) = atomToText a parensAtomToText a@ConstructedAtom{} = "(" <> atomToText a <> ")" 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 @@ -1,11 +1,17 @@ module ProjectM36.AtomFunction where import ProjectM36.Base import ProjectM36.Error +import ProjectM36.Relation +import ProjectM36.AtomType import ProjectM36.AtomFunctionError +import ProjectM36.ScriptSession import qualified ProjectM36.Attribute as A import qualified Data.HashSet as HS +import qualified Data.Text as T + foldAtomFuncType :: AtomType -> AtomType -> [AtomType] +--the underscore in the attribute name means that any attributes are acceptable foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType] atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction @@ -64,4 +70,15 @@ argsType ++ [ADTypeConstructor "Either" [ ADTypeConstructor "AtomFunctionError" [], retType]]) - + +loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction]) +loadAtomFunctions = loadFunction + +atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation +atomFunctionsAsRelation funcs = mkRelationFromList attrs tups + where tups = map atomFuncToTuple (HS.toList funcs) + attrs = A.attributesFromList [Attribute "name" TextAtomType, + Attribute "arguments" TextAtomType] + atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc), + TextAtom (atomFuncTypeToText aFunc)] + atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc)) 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 @@ -9,6 +9,7 @@ AtomFunctionTypeMismatchError | InvalidIntervalOrderingError | InvalidIntervalBoundariesError | + InvalidIntBoundError | AtomFunctionEmptyRelationError | AtomTypeDoesNotSupportOrderingError Text | AtomTypeDoesNotSupportIntervalError Text | 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 @@ -43,7 +43,15 @@ atomFuncBody = body $ integerAtomFuncLessThan True >=> boolAtomNot}, AtomFunction { atomFuncName = "not", atomFuncType = [BoolAtomType, BoolAtomType], - atomFuncBody = body $ \(b:_) -> boolAtomNot b } + atomFuncBody = body $ \(b:_) -> boolAtomNot b }, + AtomFunction { atomFuncName = "int", + atomFuncType = [IntegerAtomType, IntAtomType], + atomFuncBody = body $ \(IntegerAtom v:_) -> if v < fromIntegral (maxBound :: Int) then + pure (IntAtom (fromIntegral v)) + else + Left InvalidIntBoundError + } + ] where body = AtomFunctionBody Nothing 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 @@ -6,6 +6,7 @@ import ProjectM36.MiscUtils import ProjectM36.Error import ProjectM36.DataTypes.Primitive +import ProjectM36.AttributeExpr as AE import qualified ProjectM36.Attribute as A import qualified Data.Vector as V import qualified Data.Set as S @@ -37,27 +38,16 @@ atomTypeForDataConstructorName dConsName atomTypesIn tConsList = case findDataConstructor dConsName tConsList of Nothing -> Left (NoSuchDataConstructorError dConsName) - Just (tCons, dCons) -> do - typeVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList - pure (ConstructedAtomType (TCD.name tCons) typeVars) + Just (tCons, dCons) -> + ConstructedAtomType (TCD.name tCons) <$> resolveDataConstructorTypeVars dCons atomTypesIn tConsList atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType -atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss = - case isValidAtomTypeForTypeConstructor aType tCons tConss of - Just err -> Left err - Nothing -> Right aType +atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss = do + isValidAtomTypeForTypeConstructor aType tCons tConss + pure aType atomTypeForDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) aType _ = Right aType --any type is OK ---reconcile the atom-in types with the type constructors -isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Maybe RelationalError -isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing - ---lookup constructor name and check if the incoming atom types are valid -isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ = if tConsName /= expectedTConsName then Just (TypeConstructorNameMismatch expectedTConsName tConsName) else Nothing - -isValidAtomTypeForTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons)) - -- | Used to determine if the atom arguments can be used with the data constructor. -- | This is the entry point for type-checking from RelationalExpression.hs. atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType @@ -65,10 +55,9 @@ --lookup the data constructor case findDataConstructor dConsName tConss of Nothing -> Left (NoSuchDataConstructorError dConsName) - Just (tCons, dCons) -> do + Just (tCons, dCons) -> --validate that the type constructor arguments are fulfilled in the data constructor - typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss - pure (ConstructedAtomType (TCD.name tCons) typeVars) + ConstructedAtomType (TCD.name tCons) <$> resolveDataConstructorTypeVars dCons atomArgTypes tConss -- | Walks the data and type constructors to extract the type variable map. resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap @@ -116,8 +105,26 @@ Right pVarMap' else Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap')) -resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ) +resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = case typ of + TypeVariableType nam -> Left (TypeConstructorTypeVarMissing nam) + _ -> Right (M.singleton tvName typ) +resolveTypeConstructorTypeVars (ADTypeConstructor tConsName []) typ tConss = case findTypeConstructor tConsName tConss of + Just (PrimitiveTypeConstructorDef _ _, _) -> Right M.empty + _ -> Left (TypeConstructorAtomTypeMismatch tConsName typ) + resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ) + +resolveTypeConstructorTypeVars (RelationAtomTypeConstructor attrExprs) typ tConsMap = + case typ of + RelationAtomType attrs -> + --resolve any typevars in the attrExprs + M.unions <$> mapM (\(expectedAtomType, attrExpr) -> resolveAttributeExprTypeVars attrExpr expectedAtomType tConsMap) (zip (A.atomTypesList attrs) attrExprs) + otherType -> Left (AtomTypeMismatchError typ otherType) + +--used when recursing down sub-relation type definition +resolveAttributeExprTypeVars :: AttributeExprBase a -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap +resolveAttributeExprTypeVars (NakedAttributeExpr attr) aType _ = pure $ resolveTypeVariable (A.atomType attr) aType +resolveAttributeExprTypeVars (AttributeAndTypeNameExpr _ tCons _) aType tConsMap = resolveTypeConstructorTypeVars tCons aType tConsMap -- check that type vars on the right also appear on the left -- check that the data constructor names are unique @@ -132,21 +139,50 @@ pure () +atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType +atomTypeForTypeConstructor = atomTypeForTypeConstructorValidate False + -- | Create an atom type iff all type variables are provided. -- Either Int Text -> ConstructedAtomType "Either" {Int , Text} -atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType -atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ _ = Right aType -atomTypeForTypeConstructor (TypeVariable tvname) _ tvMap = case M.lookup tvname tvMap of - Nothing -> Right (TypeVariableType tvname) +atomTypeForTypeConstructorValidate :: Bool -> TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType +atomTypeForTypeConstructorValidate _ (PrimitiveTypeConstructor _ aType) _ _ = Right aType +atomTypeForTypeConstructorValidate validate (TypeVariable tvname) _ tvMap = case M.lookup tvname tvMap of + Nothing -> if validate then + Left (TypeConstructorTypeVarMissing tvname) + else + pure (TypeVariableType tvname) Just typ -> Right typ -atomTypeForTypeConstructor tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of +atomTypeForTypeConstructorValidate _ (RelationAtomTypeConstructor attrExprs) tConsMap tvMap = do + resolvedAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap tvMap) attrExprs + let attrs = zipWith Attribute (map AE.attributeName attrExprs) resolvedAtomTypes + pure (RelationAtomType (A.attributesFromList attrs)) +atomTypeForTypeConstructorValidate val tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons)) + Just (PrimitiveTypeConstructorDef _ aType, _) -> Right aType Just (tConsDef, _) -> do - tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructor tConsArg tConss tvMap) (TC.arguments tCons) - let pVarNames = TCD.typeVars tConsDef - tConsArgs = M.fromList (zip pVarNames tConsArgTypes) - Right (ConstructedAtomType (TC.name tCons) tConsArgs) + tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructorValidate val tConsArg tConss tvMap) (TC.arguments tCons) + let pVarNames = TCD.typeVars tConsDef + tConsArgs = M.fromList (zip pVarNames tConsArgTypes) + Right (ConstructedAtomType (TC.name tCons) tConsArgs) + +atomTypeForAttributeExpr :: AttributeExprBase a -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType +atomTypeForAttributeExpr (NakedAttributeExpr attr) _ _ = pure (A.atomType attr) +atomTypeForAttributeExpr (AttributeAndTypeNameExpr _ tCons _) tConsMap tvMap = atomTypeForTypeConstructorValidate True tCons tConsMap tvMap + +--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 () + +--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 (RelationAtomType attrs) (RelationAtomTypeConstructor attrExprs) tConsMap = do + evaldAtomTypes <- mapM (\expr -> atomTypeForAttributeExpr expr tConsMap M.empty) attrExprs + mapM_ (uncurry resolveAtomType) (zip (map A.atomType (V.toList attrs)) evaldAtomTypes) + pure () +isValidAtomTypeForTypeConstructor aType tCons _ = Left (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons)) + findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef]) findTypeConstructor name = foldr tConsFolder Nothing where @@ -156,15 +192,14 @@ accum resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType -resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do - tVarMap <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap - pure (ConstructedAtomType tConsName tVarMap) +resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = + ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then Right typeFromRelation else Left (AtomTypeMismatchError typeFromRelation unresolvedType) --- this could be optimized to reduce new tuple creation- if anyatomtype does not appear, just return the original typevarmap +-- this could be optimized to reduce new tuple creation resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do {- @@ -218,8 +253,13 @@ Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames else Right () - _ -> Right () -validateAtomType _ _ = Right () + _ -> Right () +validateAtomType (RelationAtomType attrs) tConss = do + mapM_ (\attr -> + validateAtomType (A.atomType attr) tConss) (V.toList attrs) + pure () +validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x) +validateAtomType _ _ = pure () validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError () validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms @@ -234,14 +274,13 @@ | otherwise = Right x atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do - _ <- mapM (\(attr1,attr2) -> let name1 = A.attributeName attr1 - name2 = A.attributeName attr2 in + mapM_ (\(attr1,attr2) -> let name1 = A.attributeName attr1 + name2 = A.attributeName attr2 in if notElem "_" [name1, name2] && name1 /= name2 then Left $ AtomTypeMismatchError x y else atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2) return x -atomTypeVerify (IntervalAtomType typA) (IntervalAtomType typB) = atomTypeVerify typA typB atomTypeVerify x y = if x == y then Right x else @@ -255,14 +294,15 @@ prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}" prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap)) where + showTypeVars (_, TypeVariableType x) = " " <> x showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")" -- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?) -prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?" -prettyAtomType (IntervalAtomType tv) = "Interval (" <> prettyAtomType tv <> ")" +prettyAtomType (TypeVariableType x) = x prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName where fullName = (T.pack . show) aType prettyAttribute :: Attribute -> T.Text +prettyAttribute (Attribute _ (TypeVariableType x)) = x prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr) resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap @@ -282,7 +322,6 @@ resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap resolveTypeVariable (TypeVariableType tv) typ = M.singleton tv typ -resolveTypeVariable (IntervalAtomType ityp) typ = resolveTypeVariable ityp typ resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap resolveTypeVariable _ _ = M.empty @@ -293,7 +332,6 @@ pure (ConstructedAtomType tCons (M.intersection tvMap retMap)) else Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff)))) -resolveFunctionReturnValue funcName tvMap (IntervalAtomType tv) = IntervalAtomType <$> resolveFunctionReturnValue funcName tvMap tv resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName) Just typ -> pure typ @@ -308,3 +346,4 @@ resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameArg tvName) = case M.lookup tvName tvMap of Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName) Just typ -> Right typ + 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 @@ -229,7 +229,7 @@ where tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType primitiveAType = toAtomType (Proxy :: Proxy a) - primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping) + primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) acc -> if typ == primitiveAType then Just name else acc) Nothing primitiveTypeConstructorMapping) instance AtomableG U1 where toAtomG = undefined diff --git a/src/lib/ProjectM36/Attribute.hs b/src/lib/ProjectM36/Attribute.hs --- a/src/lib/ProjectM36/Attribute.hs +++ b/src/lib/ProjectM36/Attribute.hs @@ -29,6 +29,9 @@ atomTypes :: Attributes -> V.Vector AtomType atomTypes = V.map atomType +atomTypesList :: Attributes -> [AtomType] +atomTypesList = V.toList . atomTypes + --hm- no error-checking here addAttribute :: Attribute -> Attributes -> Attributes addAttribute attr attrs = attrs `V.snoc` attr @@ -71,6 +74,16 @@ Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName)) Just attr -> Right attr +--similar to attributesForNames, but returns error if some names are missing +projectionAttributesForNames :: S.Set AttributeName -> Attributes -> Either RelationalError Attributes +projectionAttributesForNames names attrsIn = + if not (S.null missingNames) then + Left (NoSuchAttributeNamesError missingNames) + else + Right (attributesForNames names attrsIn) + where + missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn))) + attributesForNames :: S.Set AttributeName -> Attributes -> Attributes attributesForNames attrNameSet = V.filter filt where @@ -99,10 +112,13 @@ attributeNamesNotContained :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName attributeNamesNotContained subset superset = S.filter (`S.notMember` superset) subset --- this is sorted so the tuples know in which order to output- the ordering is arbitrary -sortedAttributeNameList :: S.Set AttributeName -> [AttributeName] -sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet +-- useful for display +orderedAttributes :: Attributes -> [Attribute] +orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList attrs) +orderedAttributeNames :: Attributes -> [AttributeName] +orderedAttributeNames attrs = map attributeName (orderedAttributes attrs) + -- take two attribute sets and return an attribute set with the attributes which do not match attributesDifference :: Attributes -> Attributes -> Attributes attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB) @@ -122,7 +138,7 @@ collapsedAttrs = vectorUniqueify attrs attributesEqual :: Attributes -> Attributes -> Bool -attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2) +attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2) attributesAsMap :: Attributes -> M.Map AttributeName Attribute attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs) diff --git a/src/lib/ProjectM36/AttributeExpr.hs b/src/lib/ProjectM36/AttributeExpr.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/AttributeExpr.hs @@ -0,0 +1,7 @@ +module ProjectM36.AttributeExpr where +import ProjectM36.Base +import ProjectM36.Attribute as A + +attributeName :: AttributeExprBase a -> AttributeName +attributeName (AttributeAndTypeNameExpr nam _ _) = nam +attributeName (NakedAttributeExpr attr) = A.attributeName attr diff --git a/src/lib/ProjectM36/AttributeNames.hs b/src/lib/ProjectM36/AttributeNames.hs --- a/src/lib/ProjectM36/AttributeNames.hs +++ b/src/lib/ProjectM36/AttributeNames.hs @@ -1,38 +1,10 @@ module ProjectM36.AttributeNames where -import qualified ProjectM36.Attribute as A import ProjectM36.Base -import ProjectM36.Error import qualified Data.Set as S ---AttributeNames is a data structure which can represent inverted projection attributes +--AttributeNames is a data structure which can represent inverted projection attributes and attribute names derived from relational expressions empty :: AttributeNames empty = AttributeNames S.empty all :: AttributeNames all = InvertedAttributeNames S.empty - ---check that the attribute names are actually in the attributes -projectionAttributesForAttributeNames :: Attributes -> AttributeNames -> Either RelationalError Attributes -projectionAttributesForAttributeNames attrs (AttributeNames attrNameSet) = do - let nonExistentAttributeNames = A.attributeNamesNotContained attrNameSet (A.attributeNameSet attrs) - if not $ S.null nonExistentAttributeNames then - Left $ AttributeNamesMismatchError nonExistentAttributeNames - else - return $ A.attributesForNames attrNameSet attrs -projectionAttributesForAttributeNames attrs (InvertedAttributeNames unselectedAttrNameSet) = do - let nonExistentAttributeNames = A.attributeNamesNotContained unselectedAttrNameSet (A.attributeNameSet attrs) - if not $ S.null nonExistentAttributeNames then - Left $ AttributeNamesMismatchError nonExistentAttributeNames - else - return $ A.attributesForNames (A.nonMatchingAttributeNameSet unselectedAttrNameSet (A.attributeNameSet attrs)) attrs -projectionAttributesForAttributeNames attrs (UnionAttributeNames namesA namesB) = do - attrsA <- projectionAttributesForAttributeNames attrs namesA - attrsB <- projectionAttributesForAttributeNames attrs namesB - pure (A.union attrsA attrsB) -projectionAttributesForAttributeNames attrs (IntersectAttributeNames namesA namesB) = A.intersection <$> projectionAttributesForAttributeNames attrs namesA <*> projectionAttributesForAttributeNames attrs namesB - -invertAttributeNames :: AttributeNames -> AttributeNames -invertAttributeNames (AttributeNames names) = InvertedAttributeNames names -invertAttributeNames (InvertedAttributeNames names) = AttributeNames names -invertAttributeNames (UnionAttributeNames namesA namesB) = IntersectAttributeNames (invertAttributeNames namesA) (invertAttributeNames namesB) -invertAttributeNames (IntersectAttributeNames namesA namesB) = UnionAttributeNames (invertAttributeNames namesA) (invertAttributeNames namesB) 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,5 +1,6 @@ -{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,TypeSynonymInstances,FlexibleInstances,OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module ProjectM36.Base where import ProjectM36.DatabaseContextFunctionError import ProjectM36.AtomFunctionError @@ -23,7 +24,6 @@ import Data.Hashable.Time () import Data.Typeable import Data.ByteString (ByteString) - type StringType = Text -- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys. @@ -35,13 +35,10 @@ DateTimeAtom UTCTime | ByteStringAtom ByteString | BoolAtom Bool | - IntervalAtom Atom Atom OpenInterval OpenInterval | RelationAtom Relation | ConstructedAtom DataConstructorName AtomType [Atom] deriving (Eq, Show, Binary, Typeable, NFData, Generic) -type OpenInterval = Bool - instance Hashable Atom where hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms `hashWithSalt` dConsName --AtomType is not hashable @@ -53,14 +50,11 @@ hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b - hashWithSalt salt (IntervalAtom a1 a2 bo be) = salt `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` bo `hashWithSalt` be hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r instance Binary UTCTime where put utc = put $ toRational (utcTimeToPOSIXSeconds utc) - get = do - r <- get :: Get Rational - return (posixSecondsToUTCTime (fromRational r)) + get = posixSecondsToUTCTime . fromRational <$> (get :: Get Rational) instance Binary Day where put day = put $ toGregorian day @@ -78,7 +72,6 @@ DateTimeAtomType | ByteStringAtomType | BoolAtomType | - IntervalAtomType AtomType | RelationAtomType Attributes | ConstructedAtomType TypeConstructorName TypeVarMap | TypeVariableType TypeVarName @@ -197,7 +190,7 @@ --- | Reference a relation variable by its name. RelationVariable RelVarName a | --- | Create a projection over attribute names. (Note that the 'AttributeNames' structure allows for the names to be inverted.) - Project AttributeNames (RelationalExprBase a) | + Project (AttributeNamesBase a) (RelationalExprBase a) | --- | Create a union of two relational expressions. The expressions should have identical attributes. Union (RelationalExprBase a) (RelationalExprBase a) | --- | Create a join of two relational expressions. The join occurs on attributes which are identical. If the expressions have no overlapping attributes, the join becomes a cross-product of both tuple sets. @@ -207,7 +200,7 @@ --- | Return a relation containing all tuples of the first argument which do not appear in the second argument (minus). Difference (RelationalExprBase a) (RelationalExprBase a) | --- | Create a sub-relation composed of the first argument's attributes which will become an attribute of the result expression. The unreferenced attributes are not altered in the result but duplicate tuples in the projection of the expression minus the attribute names are compressed into one. For more information, - Group AttributeNames AttributeName (RelationalExprBase a) | + Group (AttributeNamesBase a) AttributeName (RelationalExprBase a) | --- | Create an expression to unwrap a sub-relation contained within at an attribute's name. Note that this is not always an inverse of a group operation. Ungroup AttributeName (RelationalExprBase a) | --- | Filter the tuples of the relational expression to only retain the tuples which evaluate against the restriction predicate to true. @@ -240,9 +233,11 @@ deriving (Show, Generic, Binary, Eq, NFData) -- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int -data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] | - PrimitiveTypeConstructor TypeConstructorName AtomType | - TypeVariable TypeVarName +type TypeConstructor = TypeConstructorBase () +data TypeConstructorBase a = ADTypeConstructor TypeConstructorName [TypeConstructor] | + PrimitiveTypeConstructor TypeConstructorName AtomType | + RelationAtomTypeConstructor [AttributeExprBase a] | + TypeVariable TypeVarName deriving (Show, Generic, Binary, Eq, NFData) type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)] @@ -334,12 +329,17 @@ MultipleExpr [DatabaseContextExpr] deriving (Show, Eq, Binary, Generic) +type ObjModuleName = StringType +type ObjFunctionName = StringType +type Range = (Int,Int) -- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr. data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript | - AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript + LoadAtomFunctions ObjModuleName ObjFunctionName FilePath | + AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript | + LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath | + CreateArbitraryRelation RelVarName [AttributeExpr] Range deriving (Show, Eq, Generic, Binary) - type RestrictionPredicateExpr = RestrictionPredicateExprBase () -- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation. @@ -461,11 +461,15 @@ showArgTypes = L.intercalate "->" (map show (atomFuncType aFunc)) -- | The 'AttributeNames' structure represents a set of attribute names or the same set of names but inverted in the context of a relational expression. For example, if a relational expression has attributes named "a", "b", and "c", the 'InvertedAttributeNames' of ("a","c") is ("b"). -data AttributeNames = AttributeNames (S.Set AttributeName) | - InvertedAttributeNames (S.Set AttributeName) | - UnionAttributeNames AttributeNames AttributeNames | - IntersectAttributeNames AttributeNames AttributeNames - deriving (Eq, Show, Generic, Binary, NFData) +data AttributeNamesBase a = AttributeNames (S.Set AttributeName) | + InvertedAttributeNames (S.Set AttributeName) | + UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) | + IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) | + RelationalExprAttributeNames (RelationalExprBase a) -- use attribute names from the relational expression's type + deriving (Eq, Show, Generic, NFData) + +type AttributeNames = AttributeNamesBase () +instance Binary AttributeNames -- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all. data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory-only database @@ -521,3 +525,41 @@ instance Eq DatabaseContextFunction where f1 == f2 = dbcFuncName f1 == dbcFuncName f2 + +attrTypeVars :: Attribute -> S.Set TypeVarName +attrTypeVars (Attribute _ aType) = case aType of + IntAtomType -> S.empty + IntegerAtomType -> S.empty + DoubleAtomType -> S.empty + TextAtomType -> S.empty + DayAtomType -> S.empty + DateTimeAtomType -> S.empty + ByteStringAtomType -> S.empty + BoolAtomType -> S.empty + (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList attrs)) + (ConstructedAtomType _ tvMap) -> M.keysSet tvMap + (TypeVariableType nam) -> S.singleton nam + +typeVars :: TypeConstructor -> S.Set TypeVarName +typeVars (PrimitiveTypeConstructor _ _) = S.empty +typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args) +typeVars (TypeVariable v) = S.singleton v +typeVars (RelationAtomTypeConstructor attrExprs) = S.unions (map attrExprTypeVars attrExprs) + +attrExprTypeVars :: AttributeExprBase a -> S.Set TypeVarName +attrExprTypeVars (AttributeAndTypeNameExpr _ tCons _) = typeVars tCons +attrExprTypeVars (NakedAttributeExpr attr) = attrTypeVars attr + +atomTypeVars :: AtomType -> S.Set TypeVarName +atomTypeVars IntAtomType = S.empty +atomTypeVars IntegerAtomType = S.empty +atomTypeVars DoubleAtomType = S.empty +atomTypeVars TextAtomType = S.empty +atomTypeVars DayAtomType = S.empty +atomTypeVars DateTimeAtomType = S.empty +atomTypeVars ByteStringAtomType = S.empty +atomTypeVars BoolAtomType = S.empty +atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs)) +atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap +atomTypeVars (TypeVariableType nam) = S.singleton nam + 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 @@ -25,6 +25,7 @@ typeForRelationalExpr, inclusionDependencies, ProjectM36.Client.typeConstructorMapping, + ProjectM36.Client.databaseContextFunctionsAsRelation, planForDatabaseContextExpr, currentSchemaName, SchemaName, @@ -32,6 +33,7 @@ setCurrentSchemaName, transactionGraphAsRelation, relationVariablesAsRelation, + ProjectM36.Client.atomFunctionsAsRelation, disconnectedTransactionIsDirty, headName, remoteDBLookupName, @@ -76,10 +78,10 @@ databaseContextExprForForeignKey, createScriptedAtomFunction, AttributeExprBase(..), - TypeConstructor(..), + TypeConstructorBase(..), TypeConstructorDef(..), DataConstructorDef(..), - AttributeNames(..), + AttributeNamesBase(..), RelVarName, IncDepName, InclusionDependency(..), @@ -98,9 +100,10 @@ import qualified ProjectM36.Base as B import ProjectM36.Error import ProjectM36.Atomable -import ProjectM36.AtomFunction +import ProjectM36.AtomFunction as AF import ProjectM36.StaticOptimizer import ProjectM36.Key +import ProjectM36.DatabaseContextFunction as DCF import qualified ProjectM36.IsomorphicSchema as Schema import Control.Monad.State import Control.Monad.Trans.Reader @@ -110,7 +113,7 @@ import ProjectM36.TransactionGraph import qualified ProjectM36.Transaction as Trans import ProjectM36.TransactionGraph.Persist -import ProjectM36.Attribute hiding (atomTypes) +import ProjectM36.Attribute import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr) import ProjectM36.Persist (DiskSync(..)) import ProjectM36.FileLock @@ -330,8 +333,7 @@ liftIO $ putMVar connStatus (Left LoginError) else liftIO $ putMVar connStatus (Right $ RemoteProcessConnection RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport}) - status <- takeMVar connStatus - pure status + takeMVar connStatus connectPersistentProjectM36 :: PersistenceStrategy -> DiskSync -> @@ -481,9 +483,8 @@ serverProcessId = rProcessId conf sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session) -sessionForSessionId sessionId sessions = do - maybeSession <- STMMap.lookup sessionId sessions - pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession +sessionForSessionId sessionId sessions = + maybe (Left $ NoSuchSessionError sessionId) Right <$> STMMap.lookup sessionId sessions schemaForSessionId :: Session -> STM (Either RelationalError Schema) schemaForSessionId session = do @@ -542,9 +543,13 @@ Right expr case expr' of Left err -> pure (Left err) - Right expr'' -> case runReader (RE.evalRelationalExpr expr'') (RE.mkRelationalExprState (Sess.concreteDatabaseContext session)) of + Right expr'' -> case optimizeRelationalExpr (Sess.concreteDatabaseContext session) expr'' of Left err -> pure (Left err) - Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here + Right optExpr -> do + let evald = runReader (RE.evalRelationalExpr optExpr) (RE.mkRelationalExprState (Sess.concreteDatabaseContext session)) + case evald of + Left err -> pure (Left err) + Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here executeRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr) -- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph. @@ -561,10 +566,15 @@ Schema.processDatabaseContextExprInSchema schema expr case expr' of Left err -> pure (Left err) - Right expr'' -> case runState (RE.evalDatabaseContextExpr expr'') (RE.freshDatabaseState (Sess.concreteDatabaseContext session)) of - (Just err,_) -> pure (Left err) - (Nothing, (_,_,False)) -> pure (Right ()) --optimization- if nothing was dirtied, nothing to do - (Nothing, (!context',_,True)) -> do + Right expr'' -> case runState (do + eOptExpr <- applyStaticDatabaseOptimization expr'' + case eOptExpr of + Left err -> pure (Left err) + Right optExpr -> + RE.evalDatabaseContextExpr optExpr) (RE.freshDatabaseState (Sess.concreteDatabaseContext session)) of + (Left err,_) -> pure (Left err) + (Right (), (_,_,False)) -> pure (Right ()) --optimization- if nothing was dirtied, nothing to do + (Right (), (!context',_,True)) -> do let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr newSchemas = Schemas context' newSubschemas @@ -573,7 +583,7 @@ pure (Right ()) executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr) --- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). +-- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead. autoMergeToHead :: SessionId -> Connection -> MergeStrategy -> HeadName -> IO (Either RelationalError ()) autoMergeToHead sessionId (InProcessConnection conf) strat headName' = do let sessions = ipSessions conf @@ -585,11 +595,21 @@ eSession <- sessionForSessionId sessionId sessions case eSession of Left err -> pure (Left err) - Right session -> - case Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph of - Left err -> pure (Left err) - Right (discon', graph') -> - pure (Right (discon', graph', [id1, id2, id3])) + Right session -> + case Graph.transactionForHead headName' graph of + Nothing -> pure (Left (NoSuchHeadNameError headName')) + Just headTrans -> do + --attempt fast-forward commit, if possible + let graphInfo = if Sess.parentId session == transactionId headTrans then do + ret <- Graph.evalGraphOp stamp id1 (Sess.disconnectedTransaction session) graph Commit + pure (ret, [id1]) + else do + ret <- Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph + pure (ret, [id1,id2,id3]) + case graphInfo of + Left err -> pure (Left err) + Right ((discon', graph'), transactionIdsAdded) -> + pure (Right (discon', graph', transactionIdsAdded)) autoMergeToHead sessionId conn@(RemoteProcessConnection _) strat headName' = remoteCall conn (ExecuteAutoMergeToHead sessionId strat headName') -- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented. @@ -842,7 +862,7 @@ Right (session, _) -> --warning, no schema support for typeconstructors pure (Right (B.typeConstructorMapping (Sess.concreteDatabaseContext session))) typeConstructorMapping sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId) - + -- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated. planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError DatabaseContextExpr) planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do @@ -871,9 +891,8 @@ eSession <- sessionForSessionId sessionId sessions case eSession of Left err -> pure $ Left err - Right session -> do - graph <- readTVar tvar - pure $ graphAsRelation (Sess.disconnectedTransaction session) graph + Right session -> + graphAsRelation (Sess.disconnectedTransaction session) <$> readTVar tvar transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId) @@ -894,7 +913,32 @@ Left err -> pure (Left err) Right relvars -> pure $ R.relationVariablesAsRelation relvars -relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId) +relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId) + +-- | Returns the names and types of the atom functions in the current 'Session'. +atomFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) +atomFunctionsAsRelation sessionId (InProcessConnection conf) = do + let sessions = ipSessions conf + atomically $ do + eSession <- sessionAndSchema sessionId sessions + case eSession of + Left err -> pure (Left err) + Right (session, _) -> + pure (AF.atomFunctionsAsRelation (atomFunctions (concreteDatabaseContext session))) + +atomFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId) + +databaseContextFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation) +databaseContextFunctionsAsRelation sessionId (InProcessConnection conf) = do + let sessions = ipSessions conf + atomically $ do + eSession <- sessionAndSchema sessionId sessions + case eSession of + Left err -> pure (Left err) + Right (session, _) -> + pure (DCF.databaseContextFunctionsAsRelation (dbcFunctions (concreteDatabaseContext session))) + +databaseContextFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveDatabaseContextFunctionSummary sessionId) -- | Returns the transaction id for the connection's disconnected transaction committed parent transaction. headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId) diff --git a/src/lib/ProjectM36/Client/Simple.hs b/src/lib/ProjectM36/Client/Simple.hs --- a/src/lib/ProjectM36/Client/Simple.hs +++ b/src/lib/ProjectM36/Client/Simple.hs @@ -72,7 +72,7 @@ withTransaction :: DbConn -> Db a -> IO (Either DbError a) withTransaction sessconn = withTransactionUsing sessconn UnionMergeStrategy --- | Same a 'withTransaction' except that the merge strategy can be specified. +-- | Same as 'withTransaction' except that the merge strategy can be specified. withTransactionUsing :: DbConn -> MergeStrategy -> Db a -> IO (Either DbError a) withTransactionUsing (sess, conn) strat dbm = do eHeadName <- C.headName sess conn @@ -84,7 +84,7 @@ handler :: TransactionCancelled -> IO (Either DbError a) handler (TransactionCancelled err) = pure (Left err) handle handler $ do - ret <- C.withTransaction sess conn (block >>= pure . Right) successFunc + ret <- C.withTransaction sess conn (Right <$> block) successFunc case ret of Left err -> pure (Left (RelError err)) Right val -> pure (Right val) diff --git a/src/lib/ProjectM36/DataConstructorDef.hs b/src/lib/ProjectM36/DataConstructorDef.hs --- a/src/lib/ProjectM36/DataConstructorDef.hs +++ b/src/lib/ProjectM36/DataConstructorDef.hs @@ -1,6 +1,5 @@ module ProjectM36.DataConstructorDef where -import ProjectM36.Base -import qualified ProjectM36.TypeConstructor as TC +import ProjectM36.Base as B import qualified Data.Set as S emptyDataConstructor :: DataConstructorName -> DataConstructorDef @@ -16,6 +15,6 @@ typeVars (DataConstructorDef _ tConsArgs) = S.unions $ map typeVarsInDefArg tConsArgs typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName -typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = TC.typeVars tCons +typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = B.typeVars tCons typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName diff --git a/src/lib/ProjectM36/DataTypes/Basic.hs b/src/lib/ProjectM36/DataTypes/Basic.hs --- a/src/lib/ProjectM36/DataTypes/Basic.hs +++ b/src/lib/ProjectM36/DataTypes/Basic.hs @@ -1,10 +1,10 @@ -- wraps up primitives plus other basic data types module ProjectM36.DataTypes.Basic where import ProjectM36.DataTypes.Primitive -import ProjectM36.DataTypes.Day import ProjectM36.DataTypes.Either import ProjectM36.DataTypes.Maybe import ProjectM36.DataTypes.List +import ProjectM36.DataTypes.Interval import ProjectM36.Base basicTypeConstructorMapping :: TypeConstructorMapping @@ -12,6 +12,6 @@ maybeTypeConstructorMapping ++ eitherTypeConstructorMapping ++ listTypeConstructorMapping ++ - dayTypeConstructorMapping + intervalTypeConstructorMapping 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 @@ -7,14 +7,11 @@ dayAtomFunctions :: AtomFunctions dayAtomFunctions = HS.fromList [ AtomFunction { atomFuncName = "fromGregorian", - atomFuncType = [IntAtomType, IntAtomType, IntAtomType, DayAtomType], - atomFuncBody = compiledAtomFunctionBody $ \(IntAtom year:IntAtom month:IntAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) + atomFuncType = [IntegerAtomType, IntegerAtomType, IntegerAtomType, DayAtomType], + atomFuncBody = compiledAtomFunctionBody $ \(IntegerAtom year:IntegerAtom month:IntegerAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) }, AtomFunction { atomFuncName = "dayEarlierThan", atomFuncType = [DayAtomType, DayAtomType, BoolAtomType], atomFuncBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB)) } ] - -dayTypeConstructorMapping :: TypeConstructorMapping -dayTypeConstructorMapping = [] -- use fromGregorian 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 @@ -6,7 +6,24 @@ import ProjectM36.DataTypes.Primitive import ProjectM36.AtomFunctionError import qualified Data.HashSet as HS +import qualified Data.Map as M +import Control.Monad (when) +import Data.Maybe +type OpenInterval = Bool + +intervalSubType :: AtomType -> AtomType +intervalSubType typ = if isIntervalAtomType typ then + case typ of + ConstructedAtomType _ tvMap -> + fromMaybe err (M.lookup "a" tvMap) + _ -> err + else + err + where + err = error "intervalSubType on non-interval type" + + -- in lieu of typeclass support, we just hard-code the types which can be part of an interval supportsInterval :: AtomType -> Bool supportsInterval typ = case typ of @@ -18,7 +35,6 @@ DateTimeAtomType -> True ByteStringAtomType -> False BoolAtomType -> False - IntervalAtomType _ -> False RelationAtomType _ -> False ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this TypeVariableType _ -> False @@ -33,7 +49,6 @@ DateTimeAtomType -> True ByteStringAtomType -> False BoolAtomType -> False - IntervalAtomType _ -> False RelationAtomType _ -> False ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this TypeVariableType _ -> False @@ -67,7 +82,11 @@ else Right valid LT -> Right valid - where valid = IntervalAtom atom1 atom2 bopen eopen + where valid = ConstructedAtom "Interval" iType [atom1, atom2, BoolAtom bopen, BoolAtom eopen] + iType = intervalAtomType (atomTypeForAtom atom1) + +intervalAtomType :: AtomType -> AtomType +intervalAtomType typ = ConstructedAtomType "Interval" (M.singleton "a" typ) intervalAtomFunctions :: AtomFunctions intervalAtomFunctions = HS.fromList [ @@ -76,7 +95,7 @@ TypeVariableType "a", BoolAtomType, BoolAtomType, - IntervalAtomType (TypeVariableType "a")], + intervalAtomType (TypeVariableType "a")], atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do let aType = atomTypeForAtom atom1 if supportsInterval aType then @@ -86,23 +105,40 @@ }, AtomFunction { atomFuncName = "interval_overlaps", - atomFuncType = [IntervalAtomType (TypeVariableType "a"), - IntervalAtomType (TypeVariableType "a"), + atomFuncType = [intervalAtomType (TypeVariableType "a"), + intervalAtomType (TypeVariableType "a"), BoolAtomType], - atomFuncBody = compiledAtomFunctionBody $ \(i1@IntervalAtom{}:i2@IntervalAtom{}:_) -> do - res <- intervalOverlaps i1 i2 - pure (BoolAtom res) + atomFuncBody = compiledAtomFunctionBody $ \(i1@ConstructedAtom{}:i2@ConstructedAtom{}:_) -> + BoolAtom <$> intervalOverlaps i1 i2 }] - - + +isIntervalAtomType :: AtomType -> Bool +isIntervalAtomType (ConstructedAtomType nam tvMap) = + nam == "Interval" && M.keys tvMap == ["a"] && case M.lookup "a" tvMap of + Nothing -> False + Just subType -> supportsInterval subType || subType == TypeVariableType "a" +isIntervalAtomType _ = False + intervalOverlaps :: Atom -> Atom -> Either AtomFunctionError Bool -intervalOverlaps (IntervalAtom i1start i1end i1startopen i1endopen) (IntervalAtom i2start i2end i2startopen i2endopen) = do - cmp1 <- atomCompare i1start i2end - cmp2 <- atomCompare i2start i1end - let startcmp = if i1startopen || i2endopen then oplt else oplte - endcmp = if i2startopen || i1endopen then oplt else oplte - oplte op = op == LT || op == EQ - oplt op = op == LT - pure (startcmp cmp1 && endcmp cmp2) +intervalOverlaps (ConstructedAtom dCons1 typ1 [i1start, + i1end, + BoolAtom i1startopen, + BoolAtom i1endopen]) (ConstructedAtom dCons2 typ2 + [i2start, + i2end, + BoolAtom i2startopen, + BoolAtom i2endopen]) = do + when (dCons1 /= "Interval" || dCons2 /= "Interval" || not (isIntervalAtomType typ1) || not (isIntervalAtomType typ2)) (Left AtomFunctionTypeMismatchError) + cmp1 <- atomCompare i1start i2end + cmp2 <- atomCompare i2start i1end + let startcmp = if i1startopen || i2endopen then oplt else oplte + endcmp = if i2startopen || i1endopen then oplt else oplte + oplte op = op == LT || op == EQ + oplt op = op == LT + pure (startcmp cmp1 && endcmp cmp2) intervalOverlaps _ _ = Left AtomFunctionTypeMismatchError +intervalTypeConstructorMapping :: TypeConstructorMapping +intervalTypeConstructorMapping = [(ADTypeConstructorDef "Interval" ["a"], [])] + + 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,9 +37,8 @@ AtomFunction { atomFuncName = "length", atomFuncType = [listAtomType (TypeVariableType "a"), IntAtomType], - atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> do - c <- listLength listAtom - pure (IntAtom (fromIntegral c))) + atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> + IntAtom . fromIntegral <$> listLength listAtom) }, AtomFunction { atomFuncName = "maybeHead", 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 @@ -10,7 +10,9 @@ ("Text", TextAtomType), ("Double", DoubleAtomType), ("Bool", BoolAtomType), - ("ByteString", ByteStringAtomType) + ("ByteString", ByteStringAtomType), + ("DateTime", DateTimeAtomType), + ("Day", DayAtomType) ] intTypeConstructor :: TypeConstructor @@ -35,6 +37,5 @@ atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType atomTypeForAtom (BoolAtom _) = BoolAtomType -atomTypeForAtom (IntervalAtom a _ _ _) = IntervalAtomType (atomTypeForAtom a) atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs atomTypeForAtom (ConstructedAtom _ aType _) = aType diff --git a/src/lib/ProjectM36/DatabaseContextFunction.hs b/src/lib/ProjectM36/DatabaseContextFunction.hs --- a/src/lib/ProjectM36/DatabaseContextFunction.hs +++ b/src/lib/ProjectM36/DatabaseContextFunction.hs @@ -2,8 +2,13 @@ --implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr import ProjectM36.Base import ProjectM36.Error +import ProjectM36.Attribute as A +import ProjectM36.Relation +import ProjectM36.AtomType import qualified Data.HashSet as HS import qualified Data.Map as M +import ProjectM36.ScriptSession +import qualified Data.Text as T emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction emptyDatabaseContextFunction name = DatabaseContextFunction { @@ -54,3 +59,17 @@ createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg]) + +loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction]) +loadDatabaseContextFunctions = loadFunction + +databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation +databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups + where + attrs = A.attributesFromList [Attribute "name" TextAtomType, + Attribute "arguments" TextAtomType] + tups = map dbcFuncToTuple (HS.toList dbcFuncs) + dbcFuncToTuple func = [TextAtom (dbcFuncName func), + TextAtom (dbcTextType (dbcFuncType func))] + dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"]) + diff --git a/src/lib/ProjectM36/DatabaseContextFunctionUtils.hs b/src/lib/ProjectM36/DatabaseContextFunctionUtils.hs --- a/src/lib/ProjectM36/DatabaseContextFunctionUtils.hs +++ b/src/lib/ProjectM36/DatabaseContextFunctionUtils.hs @@ -8,8 +8,8 @@ executeDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext executeDatabaseContextExpr expr context = case runState (evalDatabaseContextExpr expr) (freshDatabaseState context) of - (Nothing, (context', _, _)) -> pure context' - (Just err, _) -> error (show err) + (Right (), (context', _, _)) -> pure context' + (Left err, _) -> error (show err) executeRelationalExpr :: RelationalExpr -> DatabaseContext -> Either RelationalError Relation executeRelationalExpr expr context = runReader (evalRelationalExpr expr) (mkRelationalExprState context) diff --git a/src/lib/ProjectM36/DateExamples.hs b/src/lib/ProjectM36/DateExamples.hs --- a/src/lib/ProjectM36/DateExamples.hs +++ b/src/lib/ProjectM36/DateExamples.hs @@ -22,10 +22,13 @@ suppliers = suppliersRel products = productsRel supplierProducts = supplierProductsRel - dateIncDeps = M.fromList [("s_pkey", simplePKey ["s#"] "s"), - ("p_pkey", simplePKey ["p#"] "p"), - ("sp_pkey", simplePKey ["s#", "p#"] "sp") - ] + dateIncDeps = M.fromList [ + ("s_pkey", simplePKey ["s#"] "s"), + ("p_pkey", simplePKey ["p#"] "p"), + ("sp_pkey", simplePKey ["s#", "p#"] "sp"), + ("s_sp_fk", inclusionDependencyForForeignKey ("sp", ["s#"]) ("s", ["s#"])), + ("p_sp_fk", inclusionDependencyForForeignKey ("sp", ["p#"]) ("p", ["p#"])) + ] simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName ()) suppliersRel :: Relation diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -14,6 +14,8 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName) | TupleAttributeCountMismatchError Int --attribute name + | EmptyAttributesError + | DuplicateAttributeNamesError (S.Set AttributeName) | TupleAttributeTypeMismatchError Attributes | AttributeCountMismatchError Int | AttributeNamesMismatchError (S.Set AttributeName) @@ -22,7 +24,7 @@ | CouldNotInferAttributes | RelVarNotDefinedError RelVarName | RelVarAlreadyDefinedError RelVarName - | RelVarAssignmentTypeMismatchError Attributes Attributes --expected, found + | RelationTypeMismatchError Attributes Attributes --expected, found | InclusionDependencyCheckError IncDepName | InclusionDependencyNameInUseError IncDepName | InclusionDependencyNameNotInUseError IncDepName @@ -83,6 +85,7 @@ | UnhandledExceptionError String | MergeTransactionError MergeError | ScriptError ScriptCompilationError + | LoadFunctionError | DatabaseContextFunctionUserError DatabaseContextFunctionError | DatabaseLoadError PersistenceError diff --git a/src/lib/ProjectM36/FSType.hs b/src/lib/ProjectM36/FSType.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/FSType.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE CPP #-} +-- confirm that the filesystem type is a journaled FS type expected by Project:M36 +-- use statfs on Linux and macOS and GetVolumeInformation on Windows +-- this could still be fooled with symlinks or by disabling journaling on filesystems that support that +module ProjectM36.FSType where + +#if defined(mingw32_HOST_OS) +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# endif +import System.Win32.Types +import Foreign.ForeignPtr +import Data.Word +import Data.Bits +import Foreign.Storable + +foreign import WINDOWS_CCONV unsafe "windows.h GetVolumePathNameW" + c_GetVolumePathName :: LPCTSTR -> LPTSTR -> DWORD -> IO BOOL + +foreign import WINDOWS_CCONV unsafe "windows.h GetVolumeInformationW" + c_GetVolumeInformation :: LPCTSTR -> LPTSTR -> DWORD -> LPDWORD -> LPDWORD -> LPDWORD -> LPTSTR -> DWORD -> IO BOOL + +#define FILE_SUPPORTS_USN_JOURNAL 0x02000000 + +getVolumePathName :: FilePath -> IO String +getVolumePathName path = do + let maxpathlen = 260 --ANSI MAX_PATH- we only care about the drive name anyway + withTString path $ \c_path -> do + fp_pathout <- mallocForeignPtrBytes maxpathlen + withForeignPtr fp_pathout $ \pathout -> do + failIfFalse_ ("GetVolumePathNameW " ++ path) (c_GetVolumePathName c_path pathout (fromIntegral maxpathlen)) + peekTString pathout + +fsTypeSupportsJournaling :: FilePath -> IO Bool +fsTypeSupportsJournaling path = do + -- get the drive path of the incoming path + drive <- getVolumePathName path + withTString drive $ \c_drive -> do + foreign_flags <- mallocForeignPtrBytes 8 + withForeignPtr foreign_flags $ \ptr_fsFlags -> do + failIfFalse_ (unwords ["GetVolumeInformationW", path]) (c_GetVolumeInformation c_drive nullPtr 0 nullPtr nullPtr ptr_fsFlags nullPtr 0) + fsFlags <- peekByteOff ptr_fsFlags 0 :: IO Word64 + pure (fsFlags .&. FILE_SUPPORTS_USN_JOURNAL /= 0) + +#elif darwin_HOST_OS +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types + +--Darwin reports journaling directly in the fs flags + +type CStatFS = () +foreign import ccall unsafe "cDarwinFSJournaled" + c_DarwinFSJournaled :: CString -> IO CInt + +fsTypeSupportsJournaling :: FilePath -> IO Bool +fsTypeSupportsJournaling path = + withCString path $ \c_path -> do + ret <- throwErrnoIfMinus1 "statfs" (c_DarwinFSJournaled c_path) + pure (ret > (0 :: CInt)) + +#elif linux_HOST_OS +import Foreign +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types + +#include "MachDeps.h" +--Linux cannot report journaling, so we just check the filesystem type as a proxy +type CStatFS = () +foreign import ccall unsafe "sys/vfs.h statfs" + c_statfs :: CString -> Ptr CStatFS -> IO CInt + +#if WORD_SIZE_IN_BITS == 64 +type CFSType = Word64 +sizeofStructStatFS :: Int +sizeofStructStatFS = 120 +#else +#error 32-bit not supported due to sizeof struct statfs missing +type CFSType = Word32 +sizeofStructStatFS :: Int +sizeofStructStatFS = undefined +#endif + +fsTypeSupportsJournaling :: FilePath -> IO Bool +fsTypeSupportsJournaling path = do + struct_statfs <- mallocForeignPtrBytes sizeofStructStatFS + withCString path $ \c_path -> do + withForeignPtr struct_statfs $ \ptr_statfs -> do + throwErrnoIfMinus1_ "statfs" (c_statfs c_path ptr_statfs) + cfstype <- peekByteOff ptr_statfs 0 :: IO CFSType + let journaledFS = [0xEF53, --EXT3+4 + 0x5346544e, --NTFS + 0x52654973, --REISERFS + 0x58465342, --XFS + 0x3153464a --JFS + ] + pure (elem cfstype journaledFS) +#endif + diff --git a/src/lib/ProjectM36/FileLock.hs b/src/lib/ProjectM36/FileLock.hs --- a/src/lib/ProjectM36/FileLock.hs +++ b/src/lib/ProjectM36/FileLock.hs @@ -2,11 +2,9 @@ --cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking --hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite module ProjectM36.FileLock where -import System.IO #if defined(mingw32_HOST_OS) -import ProjectM36.Win32Handle import System.Win32.Types import Foreign.Marshal.Alloc import System.Win32.File @@ -24,19 +22,24 @@ foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL -type LockFile = Handle +type LockFile = HANDLE openLockFile :: FilePath -> IO LockFile -openLockFile path = openFile path ReadMode +openLockFile path = createFile path + (gENERIC_READ .|. gENERIC_WRITE) + (fILE_SHARE_READ .|. fILE_SHARE_WRITE) + Nothing + oPEN_ALWAYS + fILE_ATTRIBUTE_NORMAL + Nothing closeLockFile :: LockFile -> IO () closeLockFile file = do - unlockFile file - hClose file + closeHandle file --swiped from System.FileLock package -lockFile :: Handle -> LockType -> IO () -lockFile handle lock = withHandleToHANDLE handle $ \winHandle -> do +lockFile :: HANDLE -> LockType -> IO () +lockFile winHandle lock = do let exFlag = case lock of WriteLock -> 2 ReadLock -> 0 @@ -45,28 +48,21 @@ allocaBytes sizeof_OVERLAPPED $ \op -> do zeroMemory op $ fromIntegral sizeof_OVERLAPPED - res <- c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op - if res then - pure () - else - error "failed to wait for database lock" + failIfFalse_ "LockFileEx" $ c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op -unlockFile :: Handle -> IO () -unlockFile handle = withHandleToHANDLE handle $ \winHandle -> do +unlockFile :: HANDLE -> IO () +unlockFile winHandle = do let sizeof_OVERLAPPED = 32 allocaBytes sizeof_OVERLAPPED $ \op -> do zeroMemory op $ fromIntegral sizeof_OVERLAPPED - res <- c_unlockFileEx winHandle 0 1 0 op - if res then - pure () - else - error ("failed to unlock database lock: " ++ show res) + failIfFalse_ "UnlockFileEx" $ c_unlockFileEx winHandle 0 1 0 op #else --all of this complicated nonsense is fixed if we switch to GHC 8.2 which includes native flock support on handles import qualified System.Posix.IO as P import System.Posix.Types import System.Posix.Files +import System.IO lockStruct :: P.LockRequest -> P.FileLock lockStruct req = (req, AbsoluteSeek, 0, 0) @@ -79,8 +75,7 @@ LockFile <$> P.createFile path ownerWriteMode closeLockFile :: LockFile -> IO () -closeLockFile l@(LockFile fd) = do - unlockFile l +closeLockFile (LockFile fd) = P.closeFd fd --blocks on lock, if necessary @@ -96,6 +91,6 @@ P.waitToSetLock fd (lockStruct P.Unlock) #endif -data LockType = ReadLock | WriteLock +data LockType = ReadLock | WriteLock deriving (Show) 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass, LambdaCase #-} module ProjectM36.IsomorphicSchema where import ProjectM36.Base import ProjectM36.Error @@ -82,9 +82,9 @@ -- | Check that all mentioned relvars are actually present in the current schema. validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError () -validateRelationalExprInSchema schema relExprIn = relExprMogrify (\expr -> case expr of - RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv) - ex -> Right ex) relExprIn >> pure () +validateRelationalExprInSchema schema relExprIn = relExprMogrify (\case + RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv) + ex -> Right ex) relExprIn >> pure () where validRelVarNames = isomorphsInRelVarNames (isomorphs schema) @@ -133,16 +133,16 @@ -- | Morph a relational expression in one schema to another isomorphic schema. relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr) -relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \expr -> case expr of +relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \case RelationVariable rv () | rv == relIn -> Right (Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ())) orig -> Right orig -relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \expr -> case expr of +relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \case --only the true predicate portion appears in the virtual schema RelationVariable rv () | rv == relInT -> Right (Restrict predi (RelationVariable relTarget ())) RelationVariable rv () | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget ())) orig -> Right orig -relExprMorph (IsoRename relIn relOut) = \expr -> case expr of +relExprMorph (IsoRename relIn relOut) = \case RelationVariable rv () | rv == relIn -> Right (RelationVariable relOut ()) orig -> Right orig @@ -254,7 +254,7 @@ -- also, it's inverse to IsoRestrict which adds two constraints at the base level -- for IsoRestrict, consider hiding the two, generated constraints since they can never be thrown in the isomorphic schema inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies -inclusionDependenciesInSchema schema incDeps = mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps) >>= pure . M.fromList +inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps) relationVariablesInSchema :: Schema -> DatabaseContext -> Either RelationalError RelationVariables relationVariablesInSchema schema@(Schema morphs) context = foldM transform M.empty morphs @@ -324,8 +324,8 @@ incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps)) in case runState (evalDatabaseContextExpr incDepExprs) (context, M.empty, False) of - (Just err, _) -> Left err - (Nothing, (newContext,_,_)) -> pure (newSchemas, newContext) --need to propagate dirty flag here + (Left err, _) -> Left err + (Right (), (newContext,_,_)) -> pure (newSchemas, newContext) --need to propagate dirty flag here where newSchema = Schema morphs valid = validateSchema newSchema context diff --git a/src/lib/ProjectM36/Key.hs b/src/lib/ProjectM36/Key.hs --- a/src/lib/ProjectM36/Key.hs +++ b/src/lib/ProjectM36/Key.hs @@ -39,12 +39,15 @@ -- | Create a foreign key constraint from the first relation variable and attributes to the second. databaseContextExprForForeignKey :: IncDepName -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> DatabaseContextExpr -databaseContextExprForForeignKey fkName (rvA, attrsA) (rvB, attrsB) = - AddInclusionDependency fkName (InclusionDependency - (renameIfNecessary attrsB attrsA (Project (attrsL attrsA) - (RelationVariable rvA ()))) - (Project (attrsL attrsB) - (RelationVariable rvB ()))) +databaseContextExprForForeignKey fkName infoA infoB = + AddInclusionDependency fkName (inclusionDependencyForForeignKey infoA infoB) + +inclusionDependencyForForeignKey :: (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> InclusionDependency +inclusionDependencyForForeignKey (rvA, attrsA) (rvB, attrsB) = + InclusionDependency ( + renameIfNecessary attrsB attrsA (Project (attrsL attrsA) + (RelationVariable rvA ()))) ( + Project (attrsL attrsB) (RelationVariable rvB ())) where attrsL = AttributeNames . S.fromList renameIfNecessary attrsExpected attrsExisting expr = foldr folder expr (zip attrsExpected attrsExisting) @@ -52,3 +55,13 @@ expr else Rename attrExisting attrExpected expr + +-- if the constraint is a foreign key constraint, then return the relations and attributes involved - this only detects foreign keys created with `databaseContextExprForForeignKey` +isForeignKeyFor :: InclusionDependency -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> Bool +isForeignKeyFor incDep infoA infoB = incDep == checkIncDep + where + checkIncDep = inclusionDependencyForForeignKey infoA infoB + + + + diff --git a/src/lib/ProjectM36/MiscUtils.hs b/src/lib/ProjectM36/MiscUtils.hs --- a/src/lib/ProjectM36/MiscUtils.hs +++ b/src/lib/ProjectM36/MiscUtils.hs @@ -7,3 +7,9 @@ dupes [x,y] = [x | x == y] dupes (x:y:xs) = dupes(x:[y]) ++ dupes(y : xs) +--Data.Vector.indexed but for lists +indexed :: [a] -> [(Int, a)] +indexed = go 0 + where + go _ [] = [] + go i (v:ys) = (i,v):go (i+1) ys 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 @@ -2,11 +2,26 @@ --this module is related to persisting Project:M36 structures to disk and not related to the persistent library module ProjectM36.Persist (writeFileSync, writeBSFileSync, - renameSync, + renameSync, + printFdCount, DiskSync(..)) where -- on Windows, use FlushFileBuffers and MoveFileEx -import qualified Data.Text.IO as TIO -import Data.Text +import qualified Data.Text as T + +#if defined(linux_HOST_OS) +# define FDCOUNTSUPPORTED 1 +# define FDDIR "/proc/self/fd" +#elif defined(darwin_HOST_OS) +# define FDCOUNTSUPPORTED 1 +# define FDDIR "/dev/fd" +#else +# define FDCOUNTSUPPORTED 0 +#endif + +#if FDCOUNTSUPPORTED +import System.Directory +#endif + #if defined(mingw32_HOST_OS) import qualified System.Win32 as Win32 #else @@ -16,12 +31,14 @@ #else import System.Posix.Unistd (fileSynchronise) #endif -import System.Posix.IO (handleToFd) +import System.Posix.IO (handleToFd, closeFd) import Foreign.C #endif import System.IO (withFile, IOMode(WriteMode), Handle) import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString as BS' +import qualified Data.Text.Encoding as TE #if defined(mingw32_HOST_OS) import ProjectM36.Win32Handle @@ -31,11 +48,12 @@ data DiskSync = NoDiskSync | FsyncDiskSync -writeFileSync :: DiskSync -> FilePath -> Text -> IO() +--using withFile here is OK because we use a WORM strategy- the file is written but not read until after the handle is synced, closed, and unhidden (moved from ".X" to "X") at the top level in the transaction directory +writeFileSync :: DiskSync -> FilePath -> T.Text -> IO() writeFileSync sync path strOut = withFile path WriteMode handler where handler handle = do - TIO.hPutStr handle strOut + BS'.hPut handle (TE.encodeUtf8 strOut) syncHandle sync handle renameSync :: DiskSync -> FilePath -> FilePath -> IO () @@ -58,11 +76,18 @@ #if defined(mingw32_HOST_OS) withHandleToHANDLE handle (\h -> Win32.flushFileBuffers h) #elif defined(linux_HOST_OS) + do --fdatasync doesn't exist on macOS - handleToFd handle >>= fileSynchroniseDataOnly -#else - handleToFd handle >>= fileSynchronise + fd <- handleToFd handle + fileSynchroniseDataOnly fd + closeFd fd +#else + do + fd <- handleToFd handle + fileSynchronise fd + closeFd fd #endif + syncHandle NoDiskSync _ = pure () syncDirectory :: DiskSync -> FilePath -> IO () @@ -82,3 +107,25 @@ directoryFsync path = throwErrnoIfMinus1Retry_ "directoryFsync" (withCString path $ \cpath -> cHSDirectoryFsync cpath) #endif +--prints out number of consumed file descriptors +printFdCount :: IO () +printFdCount = +#if FDCOUNTSUPPORTED + do + fdc <- fdCount + putStrLn ("Fd count: " ++ show fdc) + --getLine >> pure () +#else + putStrLn "Fd count not supported on this OS." +#endif + + +fdCount :: IO Int +#if FDCOUNTSUPPORTED +fdCount = do + fds <- getDirectoryContents FDDIR + pure ((length fds) - 2) +#else +--not supported on non-linux +fdCount = pure 0 +#endif diff --git a/src/lib/ProjectM36/Relation.hs b/src/lib/ProjectM36/Relation.hs --- a/src/lib/ProjectM36/Relation.hs +++ b/src/lib/ProjectM36/Relation.hs @@ -9,9 +9,9 @@ import ProjectM36.Base import ProjectM36.Tuple import qualified ProjectM36.Attribute as A -import qualified ProjectM36.AttributeNames as AS import ProjectM36.TupleSet import ProjectM36.Error +import ProjectM36.MiscUtils --import qualified Control.Parallel.Strategies as P import qualified ProjectM36.TypeConstructorDef as TCD import qualified ProjectM36.DataConstructorDef as DCD @@ -19,6 +19,7 @@ import Data.Either (isRight) import System.Random.Shuffle import Control.Monad.Random +import Data.List (sort) attributes :: Relation -> Attributes attributes (Relation attrs _ ) = attrs @@ -36,20 +37,24 @@ atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation -mkRelationFromList attrs atomMatrix = do - tupSet <- mkTupleSetFromList attrs atomMatrix - return $ Relation attrs tupSet +mkRelationFromList attrs atomMatrix = + Relation attrs <$> mkTupleSetFromList attrs atomMatrix emptyRelationWithAttrs :: Attributes -> Relation emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation -mkRelation attrs tupleSet = - --check that all tuples have the same keys - --check that all tuples have keys (1-N) where N is the attribute count - case verifyTupleSet attrs tupleSet of - Left err -> Left err - Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet +mkRelation attrs tupleSet = + --check that all attributes are unique- this cannot be done when creating attributes because the check can become expensive + let duplicateAttrNames = dupes (sort (map A.attributeName (V.toList attrs))) in + if not (null duplicateAttrNames) then + Left (DuplicateAttributeNamesError (S.fromList duplicateAttrNames)) + else + --check that all tuples have the same keys + --check that all tuples have keys (1-N) where N is the attribute count + case verifyTupleSet attrs tupleSet of + Left err -> Left err + Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet --less safe version of mkRelation skips verifyTupleSet --useful for infinite or thunked tuple sets @@ -78,6 +83,7 @@ else Nothing +-- this is still unncessarily expensive for (bigx union bigx) because each tuple is hashed and compared for equality (when the hashes match), but the major expense is attributesEqual, but we already know that all tuple attributes are equal (it's a precondition) union :: Relation -> Relation -> Either RelationalError Relation union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = if not (A.attributesEqual attrs1 attrs2) @@ -86,16 +92,13 @@ Right $ Relation attrs1 newtuples where newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2) - -project :: AttributeNames -> Relation -> Either RelationalError Relation -project projectionAttrNames rel = - case AS.projectionAttributesForAttributeNames (attributes rel) projectionAttrNames of - Left err -> Left err - Right newAttrs -> relFold (folder newAttrs) (Right $ Relation newAttrs emptyTupleSet) rel - where - folder newAttrs tupleToProject acc = case acc of - Left err -> Left err - Right acc2 -> acc2 `union` Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject]) + +project :: S.Set AttributeName -> Relation -> Either RelationalError Relation +project attrNames rel@(Relation _ tupSet) = do + newAttrs <- A.projectionAttributesForNames attrNames (attributes rel) + let newAttrNameSet = A.attributeNameSet newAttrs + newTupleList = map (tupleProject newAttrNameSet) (asList tupSet) + pure (Relation newAttrs (RelationTupleSet (HS.toList (HS.fromList newTupleList)))) rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) @@ -142,11 +145,11 @@ -} --algorithm: self-join with image relation -group :: AttributeNames -> AttributeName -> Relation -> Either RelationalError Relation +group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation group groupAttrNames newAttrName rel = do - let nonGroupAttrNames = AS.invertAttributeNames groupAttrNames - nonGroupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) nonGroupAttrNames - groupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) groupAttrNames + let nonGroupAttrNames = A.nonMatchingAttributeNameSet groupAttrNames (S.fromList (V.toList (A.attributeNames (attributes rel)))) + nonGroupProjectionAttributes <- A.projectionAttributesForNames nonGroupAttrNames (attributes rel) + groupProjectionAttributes <- A.projectionAttributesForNames groupAttrNames (attributes rel) let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes) matchingRelTuple tupIn = case imageRelationFor tupIn rel of Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2)) @@ -216,8 +219,7 @@ joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2 return $ joinedTupSet ++ accumulator newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1) - newTupSet <- mkTupleSet newAttrs newTupSetList - return $ Relation newAttrs newTupSet + Relation newAttrs <$> mkTupleSet newAttrs newTupSetList -- | Difference takes two relations of the same type and returns a new relation which contains only tuples which appear in the first relation but not the second. difference :: Relation -> Relation -> Either RelationalError Relation @@ -267,7 +269,7 @@ imageRelationFor :: RelationTuple -> Relation -> Either RelationalError Relation imageRelationFor matchTuple rel = do restricted <- restrictEq matchTuple rel --restrict across matching tuples - let projectionAttrNames = AttributeNames $ A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple) + let projectionAttrNames = A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple) project projectionAttrNames restricted --project across attributes not in rel --returns a relation-valued attribute image relation for each tuple in rel1 @@ -315,11 +317,13 @@ -- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders. randomizeTupleOrder :: MonadRandom m => Relation -> m Relation -randomizeTupleOrder (Relation attrs tupSet) = do - newTupSet <- shuffleM (asList tupSet) - pure (Relation attrs (RelationTupleSet newTupSet)) +randomizeTupleOrder (Relation attrs tupSet) = + Relation attrs . RelationTupleSet <$> shuffleM (asList tupSet) -- returns a tuple from the tupleset- this is useful for priming folds over the tuples oneTuple :: Relation -> Maybe RelationTuple oneTuple (Relation _ (RelationTupleSet [])) = Nothing oneTuple (Relation _ (RelationTupleSet (x:_))) = Just x + +tuplesList :: Relation -> [RelationTuple] +tuplesList (Relation _ tupleSet) = asList tupleSet 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 @@ -4,6 +4,7 @@ import ProjectM36.Error import ProjectM36.Relation import ProjectM36.AtomType +import ProjectM36.DataTypes.Interval import qualified ProjectM36.Attribute as A import Data.Csv.Parser @@ -57,12 +58,11 @@ parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom) -parseCSVAtomP _ _ IntegerAtomType = (Right . IntegerAtom) <$> APT.decimal +parseCSVAtomP _ _ IntegerAtomType = Right . IntegerAtom <$> APT.decimal parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double -parseCSVAtomP _ _ TextAtomType = do - s <- quotedString <|> takeToEndOfData - pure (Right (TextAtom s)) +parseCSVAtomP _ _ TextAtomType = + Right . TextAtom <$> (quotedString <|> takeToEndOfData) parseCSVAtomP _ _ DayAtomType = do dString <- T.unpack <$> takeToEndOfData case readMaybe dString of @@ -83,41 +83,45 @@ case readMaybe bString of Nothing -> fail ("invalid BoolAtom string: " ++ bString) Just b -> pure (Right (BoolAtom b)) -parseCSVAtomP attrName tConsMap (IntervalAtomType iType) = do - begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True) - eBeginv <- parseCSVAtomP attrName tConsMap iType - case eBeginv of - Left err -> pure (Left err) - Right beginv -> do - _ <- APT.char ',' - eEndv <- parseCSVAtomP attrName tConsMap iType - case eEndv of - Left err -> pure (Left err) - Right endv -> do - end <- (APT.char ']' >> pure False) <|> (APT.char ')' >> pure True) - pure (Right (IntervalAtom beginv endv begin end)) -parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) = do - dConsName <- capitalizedIdentifier - APT.skipSpace +parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) + | isIntervalAtomType typ = do + begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True) + let iType = intervalSubType typ + eBeginv <- parseCSVAtomP attrName tConsMap iType + case eBeginv of + Left err -> pure (Left err) + Right beginv -> do + _ <- APT.char ',' + eEndv <- parseCSVAtomP attrName tConsMap iType + case eEndv of + Left err -> pure (Left err) + Right endv -> do + end <- (APT.char ']' >> pure False) <|> + (APT.char ')' >> pure True) + pure (Right (ConstructedAtom "Interval" typ [beginv, endv, + BoolAtom begin, BoolAtom end])) + | otherwise = do + dConsName <- capitalizedIdentifier + APT.skipSpace --we need to look up the name right away in order to determine the types of the following arguments -- grab the data constructor - case findDataConstructor dConsName tConsMap of - Nothing -> pure (Left (NoSuchDataConstructorError dConsName)) - Just (_, dConsDef) -> + case findDataConstructor dConsName tConsMap of + Nothing -> pure (Left (NoSuchDataConstructorError dConsName)) + Just (_, dConsDef) -> -- identify the data constructor's expected atom type args - case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of - Left err -> pure (Left err) - Right argAtomTypes -> do - atomArgs <- mapM (\argTyp -> let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp <* APT.skipSpace in - case argTyp of - ConstructedAtomType _ _ -> - parens parseNextAtom <|> - parseNextAtom - _ -> parseNextAtom - ) argAtomTypes - case lefts atomArgs of - [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs))) - errs -> pure (Left (someErrors errs)) + case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of + Left err -> pure (Left err) + Right argAtomTypes -> do + atomArgs <- mapM (\argTyp -> let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp <* APT.skipSpace in + case argTyp of + ConstructedAtomType _ _ -> + parens parseNextAtom <|> + parseNextAtom + _ -> parseNextAtom + ) argAtomTypes + case lefts atomArgs of + [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs))) + errs -> pure (Left (someErrors errs)) parseCSVAtomP attrName _ (RelationAtomType _) = pure (Left (RelationValuedAttributesNotSupportedError [attrName])) parseCSVAtomP _ _ (TypeVariableType x) = pure (Left (TypeConstructorTypeVarMissing x)) diff --git a/src/lib/ProjectM36/Relation/Show/CSV.hs b/src/lib/ProjectM36/Relation/Show/CSV.hs --- a/src/lib/ProjectM36/Relation/Show/CSV.hs +++ b/src/lib/ProjectM36/Relation/Show/CSV.hs @@ -41,7 +41,7 @@ newtype RecordAtom = RecordAtom {unAtom :: Atom} instance ToField RecordAtom where - toField (RecordAtom (TextAtom atomVal)) = TE.encodeUtf8 atomVal --squelch extraneous quotes for text type- the CSV library will add them if necessary + toField (RecordAtom (TextAtom atomVal)) = TE.encodeUtf8 atomVal --without this, CSV text atoms are doubly quoted toField (RecordAtom atomVal) = (TE.encodeUtf8 . atomToText) atomVal diff --git a/src/lib/ProjectM36/Relation/Show/HTML.hs b/src/lib/ProjectM36/Relation/Show/HTML.hs --- a/src/lib/ProjectM36/Relation/Show/HTML.hs +++ b/src/lib/ProjectM36/Relation/Show/HTML.hs @@ -3,22 +3,42 @@ import ProjectM36.Relation import ProjectM36.Tuple import ProjectM36.Atom +import ProjectM36.AtomType import qualified Data.List as L -import ProjectM36.Attribute -import Data.Text (append, Text, pack) +import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Text.IO as TIO +import Data.Monoid +import qualified Data.Vector as V attributesAsHTML :: Attributes -> Text -attributesAsHTML attrs = "" `append` T.concat (map oneAttrHTML attrNameList) `append` "" +attributesAsHTML attrs = "" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "" where - oneAttrHTML attrName = "" `append` attrName `append` "" - attrNameList = sortedAttributeNameList (attributeNameSet attrs) + oneAttrHTML attr = "" <> prettyAttribute attr <> "" relationAsHTML :: Relation -> Text -relationAsHTML rel@(Relation attrNameSet tupleSet) = "" `append` attributesAsHTML attrNameSet `append` tupleSetAsHTML tupleSet `append` "" `append` tablefooter `append` "
" +-- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser +relationAsHTML rel@(Relation attrNameSet tupleSet) + | rel == relationTrue = pm36relcss <> + tablestart <> + "" <> + "" <> + tablefooter <> "" + | rel == relationFalse = pm36relcss <> + tablestart <> + "" <> + tablefooter <> + "" + | otherwise = pm36relcss <> + tablestart <> + attributesAsHTML attrNameSet <> + tupleSetAsHTML tupleSet <> + tablefooter <> + "" where - tablefooter = "" `append` pack (show (cardinality rel)) `append` " tuples" + pm36relcss = "" + tablefooter = "" <> pack (show (cardinality rel)) <> " tuples" + tablestart = "" writeHTML :: Text -> IO () writeHTML = TIO.writeFile "/home/agentm/rel.html" @@ -27,11 +47,14 @@ writeRel = writeHTML . relationAsHTML tupleAsHTML :: RelationTuple -> Text -tupleAsHTML tuple = "" `append` T.concat (L.map tupleFrag (tupleSortedAssocs tuple)) `append` "" +tupleAsHTML tuple = "" <> T.concat (L.map tupleFrag (tupleAssocs tuple)) <> "" where - tupleFrag tup = "" + tupleFrag tup = "" + atomAsHTML (RelationAtom rel) = relationAsHTML rel + atomAsHTML atom = atomToText atom tupleSetAsHTML :: RelationTupleSet -> Text tupleSetAsHTML tupSet = foldr folder "" (asList tupSet) where - folder tuple acc = acc `append` tupleAsHTML tuple + folder tuple acc = acc <> tupleAsHTML tuple + diff --git a/src/lib/ProjectM36/Relation/Show/Term.hs b/src/lib/ProjectM36/Relation/Show/Term.hs --- a/src/lib/ProjectM36/Relation/Show/Term.hs +++ b/src/lib/ProjectM36/Relation/Show/Term.hs @@ -8,8 +8,9 @@ import ProjectM36.Attribute hiding (null) import qualified Data.List as L import qualified Data.Text as T -import qualified Data.Vector as V import Control.Arrow hiding (left) +import Data.Monoid +import ProjectM36.WCWidth --guess the width that the character will appear as in the terminal boxV :: StringType boxV = "│" @@ -78,14 +79,14 @@ 0 else L.maximum (lengths row) - lengths row = map T.length (breakLines row) + lengths row = map stringDisplayLength (breakLines row) allRows = header : body relationAsTable :: Relation -> Table relationAsTable rel@(Relation _ tupleSet) = (header, body) where - oAttrs = orderedAttributes rel - oAttrNames = orderedAttributeNames rel + oAttrs = orderedAttributes (attributes rel) + oAttrNames = orderedAttributeNames (attributes rel) header = map prettyAttribute oAttrs body :: [[Cell]] body = L.foldl' tupleFolder [] (asList tupleSet) @@ -103,6 +104,7 @@ showAtom :: Int -> Atom -> StringType showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && not (null atoms)) $ T.concat (L.intersperse " " (dConsName : map (showAtom 1) atoms)) +showAtom _ (TextAtom t) = "\"" <> t <> "\"" showAtom _ atom = atomToText atom renderTable :: Table -> StringType @@ -121,13 +123,14 @@ renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (`repeatString` boxH) columnLocations)) `T.append` end +--pad a block of potentially multi-lined text leftPaddedString :: Int -> Int -> StringType -> StringType leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then repeatString size " " else paddedLines !! lineNum where - paddedLines = map (\line -> line `T.append` repeatString (size - T.length line) " ") (breakLines str) + paddedLines = map (\line -> line `T.append` repeatString (size - stringDisplayLength line) " ") (breakLines str) renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1] @@ -143,14 +146,19 @@ rowHeightMatrix = zip cellMatrix (tail rowLocations) renderBottomBar = renderHBar boxBL boxBB boxBR columnLocations -orderedAttributes :: Relation -> [Attribute] -orderedAttributes rel = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList (attributes rel)) - -orderedAttributeNames :: Relation -> [AttributeName] -orderedAttributeNames rel = map attributeName (orderedAttributes rel) - repeatString :: Int -> StringType -> StringType repeatString c s = T.concat (replicate c s) showRelation :: Relation -> StringType showRelation rel = renderTable (relationAsTable rel) + +--use wcwidth to guess the string width in the terminal- many CJK characters can take multiple columns in a fixed width font +stringDisplayLength :: StringType -> Int +stringDisplayLength = T.foldr charSize 0 + where + charSize char accum = let w = wcwidth char in + accum + if w < 0 then + 1 + else + w + 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 @@ -11,9 +11,11 @@ import ProjectM36.DataTypes.Primitive import ProjectM36.AtomFunction import ProjectM36.DatabaseContextFunction +import ProjectM36.Arbitrary import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.HashSet as HS +import qualified Data.Set as S import Control.Monad.State hiding (join) import Control.Exception import Data.Maybe @@ -24,7 +26,7 @@ import qualified ProjectM36.TypeConstructorDef as TCD import Control.Monad.Trans.Except import Control.Monad.Trans.Reader - +import Test.QuickCheck import GHC import GHC.Paths @@ -113,10 +115,14 @@ Nothing -> Left $ RelVarNotDefinedError name evalRelationalExpr (Project attrNames expr) = do - rel <- evalRelationalExpr expr - case rel of - Right rel2 -> return $ project attrNames rel2 - Left err -> return $ Left err + eAttrNameSet <- evalAttributeNames attrNames expr + case eAttrNameSet of + Left err -> pure (Left err) + Right attrNameSet -> do + rel <- evalRelationalExpr expr + case rel of + Right rel2 -> pure $ project attrNameSet rel2 + Left err -> pure $ Left err evalRelationalExpr (Union exprA exprB) = do relA <- evalRelationalExpr exprA @@ -156,9 +162,8 @@ -- if the mAttrExprs is Nothing, then we should attempt to infer the tuple attributes from the first tuple itself- note that this is not always possible runExceptT $ do mAttrs <- case mAttrExprs of - Just _ -> do - attrs <- mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs) - pure (Just (A.attributesFromList attrs)) + Just _ -> + Just . A.attributesFromList <$> mapM (either throwE pure . evalAttrExpr tConss) (fromMaybe [] mAttrExprs) Nothing -> pure Nothing tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs let attrs = fromMaybe firstTupleAttrs mAttrs @@ -173,11 +178,15 @@ Right rel -> return $ rename oldAttrName newAttrName rel Left err -> return $ Left err -evalRelationalExpr (Group oldAttrNameSet newAttrName relExpr) = do - evald <- evalRelationalExpr relExpr - case evald of - Right rel -> return $ group oldAttrNameSet newAttrName rel - Left err -> return $ Left err +evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do + eOldAttrNameSet <- evalAttributeNames oldAttrNames relExpr + case eOldAttrNameSet of + Left err -> pure (Left err) + Right oldAttrNameSet -> do + evald <- evalRelationalExpr relExpr + case evald of + Right rel -> return $ group oldAttrNameSet newAttrName rel + Left err -> return $ Left err evalRelationalExpr (Ungroup attrName relExpr) = do evald <- evalRelationalExpr relExpr @@ -228,46 +237,53 @@ Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel --helper function to process relation variable creation/assignment -setRelVar :: RelVarName -> Relation -> DatabaseState (Maybe RelationalError) +setRelVar :: RelVarName -> Relation -> DatabaseState (Either RelationalError ()) setRelVar relVarName rel = do currentContext <- getStateContext let newRelVars = M.insert relVarName rel $ relationVariables currentContext potentialContext = currentContext { relationVariables = newRelVars } case checkConstraints potentialContext of - Just err -> return $ Just err - Nothing -> do + Left err -> pure (Left err) + Right _ -> do putStateContext potentialContext - return Nothing + return (Right ()) -- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation -deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError) +deleteRelVar :: RelVarName -> DatabaseState (Either RelationalError ()) deleteRelVar relVarName = do currContext <- getStateContext let relVars = relationVariables currContext if M.notMember relVarName relVars then - pure Nothing + pure (Right ()) else do let newRelVars = M.delete relVarName relVars newContext = currContext { relationVariables = newRelVars } putStateContext newContext - pure Nothing + pure (Right ()) -evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe RelationalError) -evalDatabaseContextExpr NoOperation = pure Nothing +evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Either RelationalError ()) +evalDatabaseContextExpr NoOperation = pure (Right ()) evalDatabaseContextExpr (Define relVarName attrExprs) = do relvars <- fmap relationVariables getStateContext tConss <- fmap typeConstructorMapping getStateContext let eAttrs = map (evalAttrExpr tConss) attrExprs - case lefts eAttrs of - err:_ -> pure (Just err) - [] -> case M.member relVarName relvars of - True -> return (Just (RelVarAlreadyDefinedError relVarName)) - False -> setRelVar relVarName emptyRelation >> pure Nothing - where - attrs = A.attributesFromList (rights eAttrs) - emptyRelation = Relation attrs emptyTupleSet + attrErrs = lefts eAttrs + attrsList = rights eAttrs + if not (null attrErrs) then + pure (Left (someErrors attrErrs)) + else do + let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList + if not (null atomTypeErrs) then + pure (Left (someErrors atomTypeErrs)) + else + case M.member relVarName relvars of + True -> pure (Left (RelVarAlreadyDefinedError relVarName)) + False -> setRelVar relVarName emptyRelation >> pure (Right ()) + where + attrs = A.attributesFromList attrsList + emptyRelation = Relation attrs emptyTupleSet evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName @@ -278,7 +294,7 @@ relVarTable = relationVariables context value = runReader (evalRelationalExpr expr) (RelationalExprStateElems context) case value of - Left err -> return $ Just err + Left err -> pure (Left err) Right rel -> case existingRelVar of Nothing -> setRelVar relVarName rel Just existingRel -> let expectedAttributes = attributes existingRel @@ -286,7 +302,7 @@ if A.attributesEqual expectedAttributes foundAttributes then setRelVar relVarName rel else - return $ Just (RelVarAssignmentTypeMismatchError expectedAttributes foundAttributes) + pure (Left (RelationTypeMismatchError expectedAttributes foundAttributes)) evalDatabaseContextExpr (Insert relVarName relExpr) = do context <- getStateContext @@ -295,11 +311,11 @@ unioned = runReader (evalRelationalExpr unionexp) (RelationalExprStateElems context) origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context) case unioned of - Left err -> pure (Just err) + Left err -> pure (Left err) Right unioned' -> case origRel of - Left err -> pure (Just err) + Left err -> pure (Left err) Right origRel' -> if cardinality unioned' == cardinality origRel' then --no tuples actually inserted - pure Nothing + pure (Right ()) else evalDatabaseContextExpr $ Assign relVarName (ExistingRelation unioned') @@ -309,11 +325,11 @@ let updatedRel = runReader (evalRelationalExpr (Restrict (NotPredicate predicate) rv)) (RelationalExprStateElems context) origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context) case updatedRel of - Left err -> pure (Just err) + Left err -> pure (Left err) Right updatedRel' -> case origRel of - Left err -> pure (Just err) + Left err -> pure (Left err) Right origRel' -> if cardinality origRel' == cardinality updatedRel' then - pure Nothing + pure (Right ()) else setRelVar relVarName updatedRel' @@ -322,10 +338,10 @@ context <- getStateContext let relVarTable = relationVariables context case M.lookup relVarName relVarTable of - Nothing -> return $ Just (RelVarNotDefinedError relVarName) + Nothing -> pure (Left (RelVarNotDefinedError relVarName)) Just rel -> case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of - Left err -> return $ Just err + Left err -> pure (Left err) Right predicateFunc -> do let ret = do restrictedPortion <- restrict predicateFunc rel @@ -337,8 +353,8 @@ updatedRel <- updatedPortion `union` unrestrictedPortion pure (Just updatedRel) case ret of - Left err -> pure (Just err) - Right Nothing -> pure Nothing + Left err -> pure (Left err) + Right Nothing -> pure (Right ()) Right (Just updatedRel) -> setRelVar relVarName updatedRel evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do @@ -346,48 +362,48 @@ let currDeps = inclusionDependencies currContext newDeps = M.insert newDepName newDep currDeps if M.member newDepName currDeps then - return $ Just (InclusionDependencyNameInUseError newDepName) + pure (Left (InclusionDependencyNameInUseError newDepName)) else do let potentialContext = currContext { inclusionDependencies = newDeps } case checkConstraints potentialContext of - Just err -> return $ Just err - Nothing -> do + Left err -> pure (Left err) + Right _ -> do putStateContext potentialContext - return Nothing + return (Right ()) evalDatabaseContextExpr (RemoveInclusionDependency depName) = do currContext <- getStateContext let currDeps = inclusionDependencies currContext newDeps = M.delete depName currDeps if M.notMember depName currDeps then - return $ Just (InclusionDependencyNameNotInUseError depName) + pure (Left (InclusionDependencyNameNotInUseError depName)) else do putStateContext $ currContext {inclusionDependencies = newDeps } - return Nothing + return (Right ()) -- | Add a notification which will send the resultExpr when triggerExpr changes between commits. evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do currentContext <- getStateContext let nots = notifications currentContext if M.member notName nots then - return $ Just (NotificationNameInUseError notName) + pure (Left (NotificationNameInUseError notName)) else do let newNotifications = M.insert notName newNotification nots newNotification = Notification { changeExpr = triggerExpr, reportOldExpr = resultOldExpr, reportNewExpr = resultNewExpr} putStateContext $ currentContext { notifications = newNotifications } - return Nothing + return (Right ()) evalDatabaseContextExpr (RemoveNotification notName) = do currentContext <- getStateContext let nots = notifications currentContext if M.notMember notName nots then - return $ Just (NotificationNameNotInUseError notName) + pure (Left (NotificationNameNotInUseError notName)) else do let newNotifications = M.delete notName nots putStateContext $ currentContext { notifications = newNotifications } - return Nothing + pure (Right ()) -- | Adds type and data constructors to the database context. -- validate that the type *and* constructor names are unique! not yet implemented! @@ -397,57 +413,56 @@ tConsName = TCD.name tConsDef -- validate that the constructor's types exist case validateTypeConstructorDef tConsDef dConsDefList of - errs@(_:_) -> pure $ Just (someErrors errs) - [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure $ Just (InvalidAtomTypeName tConsName) - | isJust (findTypeConstructor tConsName oldTypes) -> pure $ Just (AtomTypeNameInUseError tConsName) + errs@(_:_) -> pure (Left (someErrors errs)) + [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName)) + | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName)) | otherwise -> do let newTypes = oldTypes ++ [(tConsDef, dConsDefList)] putStateContext $ currentContext { typeConstructorMapping = newTypes } - pure Nothing + pure (Right ()) -- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive. evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do currentContext <- getStateContext let oldTypes = typeConstructorMapping currentContext if isNothing (findTypeConstructor tConsName oldTypes) then - pure $ Just (AtomTypeNameNotInUseError tConsName) + pure (Left (AtomTypeNameNotInUseError tConsName)) else do let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes putStateContext $ currentContext { typeConstructorMapping = newTypes } - pure Nothing + pure (Right ()) evalDatabaseContextExpr (MultipleExpr exprs) = do --the multiple expressions must pass the same context around- not the old unmodified context evald <- forM exprs evalDatabaseContextExpr --some lifting magic needed here - case catMaybes evald of - [] -> pure Nothing - err:_ -> pure (Just err) + case lefts evald of + [] -> pure (Right ()) + errs -> pure (Left (someErrors errs)) evalDatabaseContextExpr (RemoveAtomFunction funcName) = do currentContext <- getStateContext let atomFuncs = atomFunctions currentContext case atomFunctionForName funcName atomFuncs of - Left err -> pure (Just err) + Left err -> pure (Left err) Right realFunc -> if isScriptedAtomFunction realFunc then do let updatedFuncs = HS.delete realFunc atomFuncs putStateContext (currentContext {atomFunctions = updatedFuncs }) - pure Nothing + pure (Right ()) else - pure (Just (PrecompiledFunctionRemoveError funcName)) - + pure (Left (PrecompiledFunctionRemoveError funcName)) evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do context <- getStateContext let dbcFuncs = dbcFunctions context case databaseContextFunctionForName funcName dbcFuncs of - Left err -> pure (Just err) + Left err -> pure (Left err) Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do let updatedFuncs = HS.delete realFunc dbcFuncs putStateContext (context { dbcFunctions = updatedFuncs }) - pure Nothing + pure (Right ()) else - pure (Just (PrecompiledFunctionRemoveError funcName)) + pure (Left (PrecompiledFunctionRemoveError funcName)) evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do context <- getStateContext @@ -456,16 +471,16 @@ eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs eFunc = databaseContextFunctionForName funcName (dbcFunctions context) case eFunc of - Left err -> pure (Just err) + Left err -> pure (Left err) Right func -> do let expectedArgCount = length (dbcFuncType func) actualArgCount = length atomArgExprs if expectedArgCount /= actualArgCount then - pure (Just (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)) + pure (Left (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)) else --check that the atom types are valid case lefts eAtomTypes of - _:_ -> pure (Just (someErrors (lefts eAtomTypes))) + _:_ -> pure (Left (someErrors (lefts eAtomTypes))) [] -> do let atomTypes = rights eAtomTypes let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of @@ -474,13 +489,13 @@ typeErrors = catMaybes mValidTypes eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs if length (lefts eAtomArgs) > 1 then - pure (Just (someErrors (lefts eAtomArgs))) + pure (Left (someErrors (lefts eAtomArgs))) else if not (null typeErrors) then - pure (Just (someErrors typeErrors)) + pure (Left (someErrors typeErrors)) else case evalDatabaseContextFunction func (rights eAtomArgs) context of - Left err -> pure (Just err) - Right newContext -> putStateContext newContext >> pure Nothing + Left err -> pure (Left err) + Right newContext -> putStateContext newContext >> pure (Right ()) evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext) evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = @@ -498,7 +513,7 @@ pure $ case eCompiledFunc of Left err -> Left (ScriptError err) Right compiledFunc -> do - funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons + funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructorValidate False funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons let updatedFuncs = HS.insert newAtomFunc atomFuncs newContext = currentContext { atomFunctions = updatedFuncs } newAtomFunc = AtomFunction { atomFuncName = funcName, @@ -554,8 +569,42 @@ Right eContext -> case eContext of Left err -> pure (Left err) Right context' -> pure (Right context') - - +evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do + eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath + case eLoadFunc of + Left LoadSymbolError -> pure (Left LoadFunctionError) + Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs } + mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc) + in pure (Right newContext) +evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do + eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath + case eLoadFunc of + Left LoadSymbolError -> pure (Left LoadFunctionError) + Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs } + mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc) + in pure (Right newContext) + +evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) = + --Define + case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of + (Left err,_) -> pure (Left err) + (Right (), elems@(ctx,_,_)) -> do + --Assign + let existingRelVar = M.lookup relVarName relVarTable + relVarTable = relationVariables ctx + case existingRelVar of + Nothing -> pure $ Left (RelVarNotDefinedError relVarName) + Just existingRel -> do + let expectedAttributes = attributes existingRel + let tcMap = typeConstructorMapping ctx + eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap + case eitherRel of + Left err -> pure $ Left err + Right rel -> + case runState (setRelVar relVarName rel) elems of + (Left err,_) -> pure (Left err) + (Right (), (ctx',_,_)) -> pure $ Right ctx' + updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple updateTupleWithAtomExprs exprMap context tupIn = do --resolve all atom exprs @@ -566,22 +615,26 @@ pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn) --run verification on all constraints -checkConstraints :: DatabaseContext -> Maybe RelationalError -checkConstraints context = case failures of - [] -> Nothing - l:_ -> Just l +checkConstraints :: DatabaseContext -> Either RelationalError () +checkConstraints context = do + mapM_ (uncurry checkIncDep) (M.toList deps) + pure () where - failures = M.elems $ M.mapMaybeWithKey checkIncDep deps deps = inclusionDependencies context - eval expr = runReader (evalRelationalExpr expr) (RelationalExprStateElems context) + eval expr = evalReader (evalRelationalExpr expr) + evalReader f = runReader f (RelationalExprStateElems context) checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do + --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear. + typeSub <- evalReader (typeForRelationalExpr subsetExpr) + typeSuper <- evalReader (typeForRelationalExpr supersetExpr) + when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper))) let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr) case eval checkExpr of - Left err -> Just err + Left err -> Left err Right resultRel -> if resultRel == relationTrue then - Nothing + pure () else - Just $ InclusionDependencyCheckError depName + Left (InclusionDependencyCheckError depName) -- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing -- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation @@ -634,9 +687,7 @@ predicateRestrictionFilter attrs (NotPredicate expr) = runExceptT $ do exprv <- liftE (predicateRestrictionFilter attrs expr) - pure (\x -> do - ev <- exprv x - pure (not ev)) + pure (fmap not . exprv) --optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do @@ -738,7 +789,7 @@ if expectedArgCount /= actualArgCount then throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount) else do - _ <- mapM (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes)) + mapM_ (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes)) evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments case evalAtomFunction func evaldArgs of Left err -> throwE (AtomFunctionUserError err) @@ -801,8 +852,7 @@ runExceptT $ do argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs context <- fmap stateElemsContext (lift ask) - aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes) - pure aType + either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes) -- | Validate that the type of the AtomExpr matches the expected type. verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType) @@ -845,7 +895,8 @@ -- | Look up the type's name and create a new attribute. evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do - aType <- atomTypeForTypeConstructor tCons aTypes M.empty + aType <- atomTypeForTypeConstructorValidate True tCons aTypes M.empty + validateAtomType aType aTypes Right (Attribute attrName aType) evalAttrExpr _ (NakedAttributeExpr attr) = Right attr @@ -872,3 +923,51 @@ _ <- either throwE pure (validateTuple tup' tConss) pure tup' +evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName)) +evalAttributeNames attrNames expr = do + eExprType <- typeForRelationalExpr expr + case eExprType of + Left err -> pure (Left err) + Right exprTyp -> do + let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp))) + case attrNames of + AttributeNames names -> + case A.projectionAttributesForNames names (attributes exprTyp) of + Left err -> pure (Left err) + Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs)))) + + InvertedAttributeNames names -> do + let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet + if not (S.null nonExistentAttributeNames) then + pure (Left (AttributeNamesMismatchError nonExistentAttributeNames)) + else + pure (Right (A.nonMatchingAttributeNameSet names typeNameSet)) + + UnionAttributeNames namesA namesB -> do + eNameSetA <- evalAttributeNames namesA expr + case eNameSetA of + Left err -> pure (Left err) + Right nameSetA -> do + eNameSetB <- evalAttributeNames namesB expr + case eNameSetB of + Left err -> pure (Left err) + Right nameSetB -> + pure (Right (S.union nameSetA nameSetB)) + + IntersectAttributeNames namesA namesB -> do + eNameSetA <- evalAttributeNames namesA expr + case eNameSetA of + Left err -> pure (Left err) + Right nameSetA -> do + eNameSetB <- evalAttributeNames namesB expr + case eNameSetB of + Left err -> pure (Left err) + Right nameSetB -> + pure (Right (S.intersection nameSetA nameSetB)) + + RelationalExprAttributeNames attrExpr -> do + eAttrExprType <- typeForRelationalExpr attrExpr + case eAttrExprType of + Left err -> pure (Left err) + Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType))) + diff --git a/src/lib/ProjectM36/ScriptSession.hs b/src/lib/ProjectM36/ScriptSession.hs --- a/src/lib/ProjectM36/ScriptSession.hs +++ b/src/lib/ProjectM36/ScriptSession.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} module ProjectM36.ScriptSession where import ProjectM36.Error @@ -9,6 +10,7 @@ import Control.Monad.IO.Class import System.FilePath.Glob import System.FilePath +import System.Info (os, arch) import Data.Text (Text, unpack) import Data.Maybe @@ -16,14 +18,21 @@ import GHC.Paths (libdir) #if __GLASGOW_HASKELL__ >= 800 import GHC.LanguageExtensions +import GHCi.ObjLink +#else +import ObjLink #endif import DynFlags import Panic import Outputable --hiding ((<>)) import PprTyThing import Unsafe.Coerce -import Type hiding (pprTyThing) +import Type +import GHC.Exts (addrToAny#) +import GHC.Ptr (Ptr(..)) +import Encoding + data ScriptSession = ScriptSession { hscEnv :: HscEnv, atomFunctionBodyType :: Type, @@ -46,7 +55,11 @@ sandboxPkgPaths <- liftIO $ concat <$> mapM glob [ "./dist-newstyle/packagedb/ghc-" ++ ghcVersion, - ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d", + ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d", + ".stack-work/install/*/*/" ++ ghcVersion ++ "/pkgdb", + ".stack-work/install/*/pkgdb/", --windows stack build + "C:/sr/snapshots/b201cfe6/pkgdb", --windows stack build- ideally, we could run `stack path --snapshot-pkg-db, but this is sufficient to pass CI + homeDir ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb", homeDir ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db" ] @@ -154,12 +167,11 @@ mErr <- typeCheckScript funcType script case mErr of Just err -> pure (Left err) - Nothing -> do + Nothing -> --catch exception here --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example. -- we can't use dynCompileExpr here because - func <- compileExpr sScript - pure $ Right (unsafeCoerce func) + Right . unsafeCoerce <$> compileExpr sScript typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError) typeCheckScript expectedType inp = do @@ -171,4 +183,35 @@ pure Nothing else pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType))) + +mangleSymbol :: Maybe String -> String -> String -> String +mangleSymbol pkg module' valsym = + prefixUnderscore ++ + maybe "" (\p -> zEncodeString p ++ "_") pkg ++ + zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure" +type ModName = String +type FuncName = String + +data LoadSymbolError = LoadSymbolError + +loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a) +loadFunction modName funcName objPath = do + initObjLinker + loadObj objPath + _ <- resolveObjs + ptr <- lookupSymbol (mangleSymbol Nothing modName funcName) + case ptr of + Nothing -> pure (Left LoadSymbolError) + Just (Ptr addr) -> case addrToAny# addr of + (# hval #) -> pure (Right hval) + +prefixUnderscore :: String +prefixUnderscore = + case (os,arch) of + ("mingw32","x86_64") -> "" + ("cygwin","x86_64") -> "" + ("mingw32",_) -> "_" + ("darwin",_) -> "_" + ("cygwin",_) -> "_" + _ -> "" diff --git a/src/lib/ProjectM36/Server.hs b/src/lib/ProjectM36/Server.hs --- a/src/lib/ProjectM36/Server.hs +++ b/src/lib/ProjectM36/Server.hs @@ -5,6 +5,7 @@ import ProjectM36.Server.EntryPoints import ProjectM36.Server.RemoteCallTypes import ProjectM36.Server.Config (ServerConfig(..)) +import ProjectM36.FSType import Control.Monad.IO.Class (liftIO) import Network.Transport.TCP (createTransport, defaultTCPParameters) @@ -15,6 +16,8 @@ import Control.Distributed.Process.ManagedProcess (defaultProcess, UnhandledMessagePolicy(..), ProcessDefinition(..), handleCall, serve, InitHandler, InitResult(..)) import Control.Concurrent.MVar (putMVar, MVar) import System.IO (stderr, hPutStrLn) +import System.FilePath (takeDirectory) +import System.Directory (doesDirectoryExist) -- the state should be a mapping of remote connection to the disconnected transaction- the graph should be the same, so discon must be removed from the stm tuple --trying to refactor this for less repetition is very challenging because the return type cannot be polymorphic or the distributed-process call gets confused and drops messages @@ -38,6 +41,8 @@ handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn), handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn), handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn), + handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn), + handleCall (\conn (RetrieveDatabaseContextFunctionSummary sessionId) -> handleRetrieveDatabaseContextFunctionSummary ti sessionId conn), handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn), handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr), handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn), @@ -70,36 +75,61 @@ let dbname' = remoteDBLookupName dbname register dbname' self --liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname' - + -- | A notification callback which logs the notification to stderr and does nothing else. loggingNotificationCallback :: NotificationCallback loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot +checkFSType :: Bool -> PersistenceStrategy -> IO Bool +checkFSType performCheck strat = + case strat of + NoPersistence -> pure True + MinimalPersistence _ -> pure True + CrashSafePersistence path -> + if performCheck then do + -- if the path does not (yet) exist, then walk back a step- the db directory may not yet have been created + fullpathexists <- doesDirectoryExist path + let fscheckpath = if fullpathexists then + path + else + takeDirectory path + fsTypeSupportsJournaling fscheckpath + else + pure True + +checkFSErrorMsg :: String +checkFSErrorMsg = "The filesystem does not support journaling so writes may not be crash-safe. Use --disable-fscheck to disable this fatal error." + -- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port. launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO Bool -launchServer daemonConfig mAddressMVar = do - econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig)) - case econn of - Left err -> do - hPutStrLn stderr ("Failed to create database connection: " ++ show err) - pure False - Right conn -> do - let hostname = bindHost daemonConfig - port = bindPort daemonConfig - etransport <- createTransport hostname (show port) defaultTCPParameters - case etransport of - Left err -> error ("failed to create transport: " ++ show err) - Right transport -> do - eEndpoint <- newEndPoint transport - case eEndpoint of - Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False - Right endpoint -> do - localTCPNode <- newLocalNode transport initRemoteTable - --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode)) - runProcess localTCPNode $ do - let testBool = testMode daemonConfig - reqTimeout = perRequestTimeout daemonConfig - serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout) - liftIO $ putStrLn "serve returned" - pure True +launchServer daemonConfig mAddressMVar = do + checkFSResult <- checkFSType (checkFS daemonConfig) (persistenceStrategy daemonConfig) + if not checkFSResult then do + hPutStrLn stderr checkFSErrorMsg + pure False + else do + econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig)) + case econn of + Left err -> do + hPutStrLn stderr ("Failed to create database connection: " ++ show err) + pure False + Right conn -> do + let hostname = bindHost daemonConfig + port = bindPort daemonConfig + etransport <- createTransport hostname (show port) defaultTCPParameters + case etransport of + Left err -> error ("failed to create transport: " ++ show err) + Right transport -> do + eEndpoint <- newEndPoint transport + case eEndpoint of + Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False + Right endpoint -> do + localTCPNode <- newLocalNode transport initRemoteTable + --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode)) + runProcess localTCPNode $ do + let testBool = testMode daemonConfig + reqTimeout = perRequestTimeout daemonConfig + serve (conn, databaseName daemonConfig, mAddressMVar, address endpoint) initServer (serverDefinition testBool reqTimeout) + liftIO $ putStrLn "serve returned" + pure True diff --git a/src/lib/ProjectM36/Server/Config.hs b/src/lib/ProjectM36/Server/Config.hs --- a/src/lib/ProjectM36/Server/Config.hs +++ b/src/lib/ProjectM36/Server/Config.hs @@ -1,7 +1,8 @@ module ProjectM36.Server.Config where import ProjectM36.Client -data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy, +data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy, + checkFS :: Bool, databaseName :: DatabaseName, bindHost :: Hostname, bindPort :: Port, @@ -13,6 +14,7 @@ defaultServerConfig :: ServerConfig defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence, + checkFS = True, databaseName = "base", bindHost = "127.0.0.1", bindPort = 6543, diff --git a/src/lib/ProjectM36/Server/EntryPoints.hs b/src/lib/ProjectM36/Server/EntryPoints.hs --- a/src/lib/ProjectM36/Server/EntryPoints.hs +++ b/src/lib/ProjectM36/Server/EntryPoints.hs @@ -120,6 +120,16 @@ ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn) reply ret conn +handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation) +handleRetrieveAtomFunctionSummary ti sessionId conn = do + ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn) + reply ret conn + +handleRetrieveDatabaseContextFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation) +handleRetrieveDatabaseContextFunctionSummary ti sessionId conn = do + ret <- timeoutOrDie ti (databaseContextFunctionsAsRelation sessionId conn) + reply ret conn + handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName) handleRetrieveCurrentSchemaName ti sessionId conn = do ret <- timeoutOrDie ti (currentSchemaName sessionId conn) diff --git a/src/lib/ProjectM36/Server/ParseArgs.hs b/src/lib/ProjectM36/Server/ParseArgs.hs --- a/src/lib/ProjectM36/Server/ParseArgs.hs +++ b/src/lib/ProjectM36/Server/ParseArgs.hs @@ -8,10 +8,11 @@ parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig parseArgsWithDefaults defaults = ServerConfig <$> parsePersistenceStrategy <*> + parseCheckFS <*> parseDatabaseName <*> parseHostname (bindHost defaults) <*> parsePort (bindPort defaults) <*> - many parseGhcPkgPaths <*> + many parseGhcPkgPath <*> parseTimeout (perRequestTimeout defaults) <*> pure False @@ -29,6 +30,10 @@ long "fsync" <> help "Fsync all new transactions.") +parseCheckFS :: Parser Bool +parseCheckFS = flag True False (long "disable-fscheck" <> + help "Disable filesystem check for journaling.") + parseDatabaseName :: Parser DatabaseName parseDatabaseName = strOption (short 'n' <> long "database" <> @@ -46,8 +51,8 @@ metavar "PORT_NUMBER" <> value defPort) -parseGhcPkgPaths :: Parser String -parseGhcPkgPaths = strOption (long "ghc-pkg-dir" <> +parseGhcPkgPath :: Parser String +parseGhcPkgPath = strOption (long "ghc-pkg-dir" <> metavar "GHC_PACKAGE_DIRECTORY") parseTimeout :: Int -> Parser Int diff --git a/src/lib/ProjectM36/Server/RemoteCallTypes.hs b/src/lib/ProjectM36/Server/RemoteCallTypes.hs --- a/src/lib/ProjectM36/Server/RemoteCallTypes.hs +++ b/src/lib/ProjectM36/Server/RemoteCallTypes.hs @@ -52,6 +52,10 @@ deriving (Binary, Generic) data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId deriving (Binary, Generic) +data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId + deriving (Binary, Generic) +data RetrieveDatabaseContextFunctionSummary = RetrieveDatabaseContextFunctionSummary SessionId + deriving (Binary, Generic) data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId deriving (Binary, Generic) data TestTimeout = TestTimeout SessionId 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 @@ -3,31 +3,46 @@ import ProjectM36.RelationalExpression import ProjectM36.Relation import ProjectM36.Error +import qualified ProjectM36.Attribute as A import qualified ProjectM36.AttributeNames as AS import ProjectM36.TupleSet -import Control.Monad.State hiding (join) +import Control.Monad.State import Data.Either (rights, lefts) import Control.Monad.Trans.Reader import qualified Data.Map as M +import qualified Data.Set as S -- the static optimizer performs optimizations which need not take any specific-relation statistics into account +optimizeRelationalExpr :: DatabaseContext -> RelationalExpr -> Either RelationalError RelationalExpr +optimizeRelationalExpr context expr = runReader (optimizeRelationalExprReader expr) (mkRelationalExprState context) + +optimizeRelationalExprReader :: RelationalExpr -> RelationalExprState (Either RelationalError RelationalExpr) +optimizeRelationalExprReader expr = do + eOptExpr <- applyStaticRelationalOptimization expr + case eOptExpr of + Left err -> pure (Left err) + Right optExpr -> + applyStaticJoinElimination (applyStaticRestrictionPushdown (applyStaticRestrictionCollapse optExpr)) + +optimizeDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr +optimizeDatabaseContextExpr context dbExpr = evalState (applyStaticDatabaseOptimization dbExpr) (freshDatabaseState context) -- apply optimizations which merely remove steps to become no-ops: example: projection of a relation across all of its attributes => original relation ---should optimizations offer the possibility to return errors? If they perform the up-front type-checking, maybe so +--should optimizations offer the possibility to pure errors? If they perform the up-front type-checking, maybe so applyStaticRelationalOptimization :: RelationalExpr -> RelationalExprState (Either RelationalError RelationalExpr) -applyStaticRelationalOptimization e@(MakeStaticRelation _ _) = return $ Right e - -applyStaticRelationalOptimization e@(MakeRelationFromExprs _ _) = return $ Right e +applyStaticRelationalOptimization e@(MakeStaticRelation _ _) = pure $ Right e -applyStaticRelationalOptimization e@(ExistingRelation _) = return $ Right e +applyStaticRelationalOptimization e@(MakeRelationFromExprs _ _) = pure $ Right e -applyStaticRelationalOptimization e@(RelationVariable _ _) = return $ Right e +applyStaticRelationalOptimization e@(ExistingRelation _) = pure $ Right e +applyStaticRelationalOptimization e@(RelationVariable _ _) = pure $ Right e + --remove project of attributes which removes no attributes applyStaticRelationalOptimization (Project attrNameSet expr) = do relType <- typeForRelationalExpr expr case relType of - Left err -> return $ Left err + Left err -> pure $ Left err Right relType2 | AS.all == attrNameSet -> applyStaticRelationalOptimization expr @@ -37,78 +52,87 @@ optimizedSubExpression <- applyStaticRelationalOptimization expr case optimizedSubExpression of Left err -> pure $ Left err - Right optSubExpr -> pure $ Right $ Project attrNameSet optSubExpr + Right optSubExpr -> pure (Right (Project attrNameSet optSubExpr)) applyStaticRelationalOptimization (Union exprA exprB) = do - optExprA <- applyStaticRelationalOptimization exprA - optExprB <- applyStaticRelationalOptimization exprB - case optExprA of - Left err -> return $ Left err - Right optExprAx -> case optExprB of - Left err -> return $ Left err - Right optExprBx -> if optExprAx == optExprBx then - return (Right optExprAx) - else - return $ Right $ Union optExprAx optExprBx + eOptExprA <- applyStaticRelationalOptimization exprA + eOptExprB <- applyStaticRelationalOptimization exprB + case eOptExprA of + Left err -> pure $ Left err + Right optExprA -> case eOptExprB of + Left err -> pure $ Left err + Right optExprB -> -- (x where pred1) union (x where pred2) -> (x where pred1 or pred2) + case (optExprA, optExprB) of + (Restrict predA (RelationVariable nameA ()), + Restrict predB (RelationVariable nameB ())) | nameA == nameB -> pure (Right (Restrict (AndPredicate predA predB) (RelationVariable nameA ()))) + _ -> if optExprA == optExprB then + pure (Right optExprA) + else + pure $ Right $ Union optExprA optExprB applyStaticRelationalOptimization (Join exprA exprB) = do - optExprA <- applyStaticRelationalOptimization exprA - optExprB <- applyStaticRelationalOptimization exprB - case optExprA of - Left err -> return $ Left err - Right optExprA2 -> case optExprB of - Left err -> return $ Left err - Right optExprB2 -> if optExprA == optExprB then --A join A == A - return optExprA + eOptExprA <- applyStaticRelationalOptimization exprA + eOptExprB <- applyStaticRelationalOptimization exprB + case eOptExprA of + Left err -> pure $ Left err + Right optExprA -> case eOptExprB of + Left err -> pure $ Left err + Right optExprB -> + -- if the relvars to join are the same but with predicates, then just AndPredicate the predicates + case (optExprA, optExprB) of + (Restrict predA (RelationVariable nameA ()), + Restrict predB (RelationVariable nameB ())) | nameA == nameB -> pure (Right (Restrict (AndPredicate predA predB) (RelationVariable nameA ()))) + _ -> if optExprA == optExprB then --A join A == A + pure (Right optExprA) else - return $ Right (Join optExprA2 optExprB2) + pure (Right (Join optExprA optExprB)) applyStaticRelationalOptimization (Difference exprA exprB) = do optExprA <- applyStaticRelationalOptimization exprA optExprB <- applyStaticRelationalOptimization exprB case optExprA of - Left err -> return $ Left err + Left err -> pure $ Left err Right optExprA2 -> case optExprB of - Left err -> return $ Left err + Left err -> pure $ Left err Right optExprB2 -> if optExprA == optExprB then do --A difference A == A where false eEmptyRel <- typeForRelationalExpr optExprA2 case eEmptyRel of Left err -> pure (Left err) Right emptyRel -> pure (Right (ExistingRelation emptyRel)) else - return $ Right (Difference optExprA2 optExprB2) + pure $ Right (Difference optExprA2 optExprB2) -applyStaticRelationalOptimization e@Rename{} = return $ Right e +applyStaticRelationalOptimization e@Rename{} = pure $ Right e applyStaticRelationalOptimization (Group oldAttrNames newAttrName expr) = - return $ Right $ Group oldAttrNames newAttrName expr + pure $ Right $ Group oldAttrNames newAttrName expr applyStaticRelationalOptimization (Ungroup attrName expr) = - return $ Right $ Ungroup attrName expr + pure $ Right $ Ungroup attrName expr --remove restriction of nothing applyStaticRelationalOptimization (Restrict predicate expr) = do optimizedPredicate <- applyStaticPredicateOptimization predicate case optimizedPredicate of - Left err -> return $ Left err + Left err -> pure $ Left err Right optimizedPredicate2 - | optimizedPredicate2 == TruePredicate -> applyStaticRelationalOptimization expr - | optimizedPredicate2 == NotPredicate TruePredicate -> do + | isTrueExpr optimizedPredicate2 -> applyStaticRelationalOptimization expr -- remove predicate entirely + | isFalseExpr optimizedPredicate2 -> do -- replace where false predicate with empty relation with attributes from relexpr attributesRel <- typeForRelationalExpr expr case attributesRel of - Left err -> return $ Left err - Right attributesRelA -> return $ Right $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet + Left err -> pure $ Left err + Right attributesRelA -> pure $ Right $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet | otherwise -> do optimizedSubExpression <- applyStaticRelationalOptimization expr case optimizedSubExpression of - Left err -> return $ Left err - Right optSubExpr -> return $ Right $ Restrict optimizedPredicate2 optSubExpr + Left err -> pure $ Left err + Right optSubExpr -> pure $ Right $ Restrict optimizedPredicate2 optSubExpr -applyStaticRelationalOptimization e@(Equals _ _) = return $ Right e +applyStaticRelationalOptimization e@(Equals _ _) = pure $ Right e -applyStaticRelationalOptimization e@(NotEquals _ _) = return $ Right e +applyStaticRelationalOptimization e@(NotEquals _ _) = pure $ Right e -applyStaticRelationalOptimization e@(Extend _ _) = return $ Right e +applyStaticRelationalOptimization e@(Extend _ _) = pure $ Right e applyStaticDatabaseOptimization :: DatabaseContextExpr -> DatabaseState (Either RelationalError DatabaseContextExpr) applyStaticDatabaseOptimization x@NoOperation = pure $ Right x @@ -118,39 +142,46 @@ applyStaticDatabaseOptimization (Assign name expr) = do context <- getStateContext - let optimizedExpr = runReader (applyStaticRelationalOptimization expr) (RelationalExprStateElems context) + let optimizedExpr = optimizeRelationalExpr context expr case optimizedExpr of - Left err -> return $ Left err - Right optimizedExpr2 -> return $ Right (Assign name optimizedExpr2) + Left err -> pure $ Left err + Right optimizedExpr2 -> pure $ Right (Assign name optimizedExpr2) -applyStaticDatabaseOptimization (Insert name expr) = do +applyStaticDatabaseOptimization (Insert targetName expr) = do context <- getStateContext - let optimizedExpr = runReader (applyStaticRelationalOptimization expr) (RelationalExprStateElems context) + let optimizedExpr = optimizeRelationalExpr context expr case optimizedExpr of - Left err -> return $ Left err - Right optimizedExpr2 -> return $ Right (Insert name optimizedExpr2) + Left err -> pure $ Left err + Right optimizedExpr2 -> if isEmptyRelationExpr optimizedExpr2 then -- if we are trying to insert an empty relation, do nothing + pure (Right NoOperation) + else + case optimizedExpr2 of + -- if the target relvar and the insert relvar are the same, there is nothing to do + -- insert s s -> NoOperation + RelationVariable insName () | insName == targetName -> pure (Right NoOperation) + _ -> pure $ Right (Insert targetName optimizedExpr2) applyStaticDatabaseOptimization (Delete name predicate) = do context <- getStateContext let optimizedPredicate = runReader (applyStaticPredicateOptimization predicate) (RelationalExprStateElems context) case optimizedPredicate of - Left err -> return $ Left err - Right optimizedPredicate2 -> return $ Right (Delete name optimizedPredicate2) + Left err -> pure $ Left err + Right optimizedPredicate2 -> pure $ Right (Delete name optimizedPredicate2) applyStaticDatabaseOptimization (Update name upmap predicate) = do context <- getStateContext let optimizedPredicate = runReader (applyStaticPredicateOptimization predicate) (RelationalExprStateElems context) case optimizedPredicate of - Left err -> return $ Left err - Right optimizedPredicate2 -> return $ Right (Update name upmap optimizedPredicate2) + Left err -> pure $ Left err + Right optimizedPredicate2 -> pure $ Right (Update name upmap optimizedPredicate2) -applyStaticDatabaseOptimization dep@(AddInclusionDependency _ _) = return $ Right dep +applyStaticDatabaseOptimization dep@(AddInclusionDependency _ _) = pure $ Right dep -applyStaticDatabaseOptimization (RemoveInclusionDependency name) = return $ Right (RemoveInclusionDependency name) +applyStaticDatabaseOptimization (RemoveInclusionDependency name) = pure $ Right (RemoveInclusionDependency name) applyStaticDatabaseOptimization (AddNotification name triggerExpr resultOldExpr resultNewExpr) = do context <- getStateContext - let eTriggerExprOpt = runReader (applyStaticRelationalOptimization triggerExpr) (RelationalExprStateElems context) + let eTriggerExprOpt = optimizeRelationalExpr context triggerExpr case eTriggerExprOpt of Left err -> pure $ Left err Right triggerExprOpt -> --it doesn't make sense to optimize queries when we don't have their proper contexts @@ -166,16 +197,16 @@ --optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned ---applyStaticDatabaseOptimization (MultipleExpr exprs) = return $ Right $ MultipleExpr exprs +--applyStaticDatabaseOptimization (MultipleExpr exprs) = pure $ Right $ MultipleExpr exprs --for multiple expressions, we must evaluate applyStaticDatabaseOptimization (MultipleExpr exprs) = do context <- getStateContext let optExprs = evalState substateRunner (contextWithEmptyTupleSets context, M.empty, False) let errors = lefts optExprs if not (null errors) then - return $ Left (head errors) + pure $ Left (head errors) else - return $ Right $ MultipleExpr (rights optExprs) + pure $ Right $ MultipleExpr (rights optExprs) where substateRunner = forM exprs $ \expr -> do --a previous expression could create a relvar, we don't want to miss it, so we clear the tuples and execute the expression to get an empty relation in the relvar @@ -185,4 +216,238 @@ --restore original context applyStaticPredicateOptimization :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionPredicateExpr) -applyStaticPredicateOptimization predicate = return $ Right predicate +applyStaticPredicateOptimization predi = do + eOptPred <- case predi of +-- where x and x => where x + AndPredicate pred1 pred2 -> do + eOptPred1 <- applyStaticPredicateOptimization pred1 + case eOptPred1 of + Left err -> pure (Left err) + Right optPred1 -> do + eOptPred2 <- applyStaticPredicateOptimization pred2 + case eOptPred2 of + Left err -> pure (Left err) + Right optPred2 -> + if optPred1 == optPred2 then + pure (Right optPred1) + else + pure (Right (AndPredicate optPred1 optPred2)) +-- where x or x => where x + OrPredicate pred1 pred2 -> do + eOptPred1 <- applyStaticPredicateOptimization pred1 + case eOptPred1 of + Left err -> pure (Left err) + Right optPred1 -> do + eOptPred2 <- applyStaticPredicateOptimization pred2 + case eOptPred2 of + Left err -> pure (Left err) + Right optPred2 | optPred1 == optPred2 -> pure (Right optPred1) + | isTrueExpr optPred1 -> pure (Right optPred1) -- True or x -> True + | isTrueExpr optPred2 -> pure (Right optPred2) + | otherwise -> pure (Right (OrPredicate optPred1 optPred2)) + AttributeEqualityPredicate attrNameA (AttributeAtomExpr attrNameB) -> + if attrNameA == attrNameB then + pure (Right TruePredicate) + else + pure (Right predi) + AttributeEqualityPredicate{} -> pure (Right predi) + TruePredicate -> pure $ Right predi + NotPredicate{} -> pure $ Right predi + RelationalExprPredicate{} -> pure (Right predi) + AtomExprPredicate{} -> pure (Right predi) + case eOptPred of + Left err -> pure (Left err) + Right optPred -> + let attrMap = findStaticRestrictionPredicates optPred in + pure (Right (replaceStaticAtomExprs optPred attrMap)) + +--determines if an atom expression is tautologically true +isTrueExpr :: RestrictionPredicateExpr -> Bool +isTrueExpr TruePredicate = True +isTrueExpr (AtomExprPredicate (NakedAtomExpr (BoolAtom True))) = True +isTrueExpr _ = False + +--determines if an atom expression is tautologically false +isFalseExpr :: RestrictionPredicateExpr -> Bool +isFalseExpr (NotPredicate expr) = isTrueExpr expr +isFalseExpr (AtomExprPredicate (NakedAtomExpr (BoolAtom False))) = True +isFalseExpr _ = False + +-- determine if the created relation can statically be determined to be empty +isEmptyRelationExpr :: RelationalExpr -> Bool +isEmptyRelationExpr (MakeRelationFromExprs _ []) = True +isEmptyRelationExpr (MakeStaticRelation _ tupSet) = null (asList tupSet) +isEmptyRelationExpr (ExistingRelation rel) = rel == emptyRelationWithAttrs (attributes rel) +isEmptyRelationExpr _ = False + +--transitive static variable optimization +replaceStaticAtomExprs :: RestrictionPredicateExpr -> M.Map AttributeName AtomExpr -> RestrictionPredicateExpr +replaceStaticAtomExprs predIn replaceMap = case predIn of + AttributeEqualityPredicate newAttrName (AttributeAtomExpr matchName) -> case M.lookup matchName replaceMap of + Nothing -> predIn + Just newVal -> AttributeEqualityPredicate newAttrName newVal + AttributeEqualityPredicate{} -> predIn + AndPredicate pred1 pred2 -> AndPredicate (replaceStaticAtomExprs pred1 replaceMap) (replaceStaticAtomExprs pred2 replaceMap) + OrPredicate pred1 pred2 -> OrPredicate (replaceStaticAtomExprs pred1 replaceMap) (replaceStaticAtomExprs pred2 replaceMap) + NotPredicate pred1 -> NotPredicate (replaceStaticAtomExprs pred1 replaceMap) + TruePredicate -> predIn + RelationalExprPredicate{} -> predIn + AtomExprPredicate{} -> predIn +-- used for transitive attribute optimization- only works on statically-determined atoms for now- in the future, this could work for all AtomExprs which don't reference attributes +findStaticRestrictionPredicates :: RestrictionPredicateExpr -> M.Map AttributeName AtomExpr +findStaticRestrictionPredicates (AttributeEqualityPredicate attrName atomExpr) = + case atomExpr of + val@NakedAtomExpr{} -> M.singleton attrName val + val@ConstructedAtomExpr{} -> M.singleton attrName val + _ -> M.empty + +findStaticRestrictionPredicates (AndPredicate pred1 pred2) = + M.union (findStaticRestrictionPredicates pred1) (findStaticRestrictionPredicates pred2) +findStaticRestrictionPredicates (OrPredicate pred1 pred2) = + M.union (findStaticRestrictionPredicates pred1) (findStaticRestrictionPredicates pred2) +findStaticRestrictionPredicates (NotPredicate predi) = findStaticRestrictionPredicates predi +findStaticRestrictionPredicates TruePredicate = M.empty +findStaticRestrictionPredicates RelationalExprPredicate{} = M.empty +findStaticRestrictionPredicates AtomExprPredicate{} = M.empty + +isStaticAtomExpr :: AtomExpr -> Bool +isStaticAtomExpr NakedAtomExpr{} = True +isStaticAtomExpr ConstructedAtomExpr{} = True +isStaticAtomExpr AttributeAtomExpr{} = False +isStaticAtomExpr FunctionAtomExpr{} = False +isStaticAtomExpr RelationAtomExpr{} = False + +--if the projection of a join only uses the attributes from one of the expressions and there is a foreign key relationship between the expressions, we know that the join is inconsequential and can be removed +applyStaticJoinElimination :: RelationalExpr -> RelationalExprState (Either RelationalError RelationalExpr) +applyStaticJoinElimination expr@(Project attrNameSet (Join exprA exprB)) = do + relState <- ask + eProjType <- typeForRelationalExpr expr + eTypeA <- typeForRelationalExpr exprA + eTypeB <- typeForRelationalExpr exprB + case eProjType of + Left err -> pure (Left err) + Right projType -> + case eTypeA of + Left err -> pure (Left err) + Right typeA -> + case eTypeB of + Left err -> pure (Left err) + Right typeB -> do + let matchesProjectionAttributes + | attrNames projType `S.isSubsetOf` attrNames typeA = + Just ((exprA, typeA), (exprB, typeB)) + | attrNames projType `S.isSubsetOf` attrNames typeB = + Just ((exprB, typeB), (exprA, typeA)) + | otherwise = + Nothing + attrNames = A.attributeNameSet . attributes + case matchesProjectionAttributes of + Nothing -> -- this optimization does not apply + pure (Right expr) + Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do + --scan inclusion dependencies for a foreign key relationship + incDeps <- inclusionDependencies . stateElemsContext <$> ask + let fkConstraint = foldM isFkConstraint False incDeps + --search for matching fk constraint + isFkConstraint acc (InclusionDependency (Project subattrNames subrv) (Project _ superrv)) = + case runReader (evalAttributeNames subattrNames expr) relState of + Left _ -> pure acc + Right subAttrNameSet -> + pure (acc || (joinedExpr == subrv && + unjoinedExpr == superrv && + -- the fk attribute is one of the projection attributes + A.attributeNamesContained subAttrNameSet (A.attributeNameSet (attributes joinedType)) + )) + isFkConstraint acc _ = pure acc + case fkConstraint of + Right True -> --join elimination optimization applies + applyStaticRelationalOptimization (Project attrNameSet joinedExpr) + Right False -> --join elimination optimization does not apply + pure (Right expr) + Left err -> + pure (Left err) + +applyStaticJoinElimination expr = pure (Right expr) + +--restriction collapse converts chained restrictions into (Restrict (And pred1 pred2 pred3...)) + --this optimization should be fairly uncontroversial- performing a tuple scan once is cheaper than twice- parallelization can still take place +applyStaticRestrictionCollapse :: RelationalExpr -> RelationalExpr +applyStaticRestrictionCollapse expr = + case expr of + MakeRelationFromExprs _ _ -> expr + MakeStaticRelation _ _ -> expr + ExistingRelation _ -> expr + RelationVariable _ _ -> expr + Project attrs subexpr -> + Project attrs (applyStaticRestrictionCollapse subexpr) + Union sub1 sub2 -> + Union (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2) + Join sub1 sub2 -> + Join (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2) + Rename n1 n2 sub -> + Rename n1 n2 (applyStaticRestrictionCollapse sub) + Difference sub1 sub2 -> + Difference (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2) + Group n1 n2 sub -> + Group n1 n2 (applyStaticRestrictionCollapse sub) + Ungroup n1 sub -> + Ungroup n1 (applyStaticRestrictionCollapse sub) + Equals sub1 sub2 -> + Equals (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2) + NotEquals sub1 sub2 -> + NotEquals (applyStaticRestrictionCollapse sub1) (applyStaticRestrictionCollapse sub2) + Extend n sub -> + Extend n (applyStaticRestrictionCollapse sub) + Restrict firstPred _ -> + let restrictions = sequentialRestrictions expr + finalExpr = last restrictions + optFinalExpr = case finalExpr of + Restrict _ subexpr -> applyStaticRestrictionCollapse subexpr + otherExpr -> otherExpr + andPreds = foldr (\(Restrict subpred _) acc -> AndPredicate acc subpred) firstPred (tail restrictions) in + Restrict andPreds optFinalExpr + +sequentialRestrictions :: RelationalExpr -> [RelationalExpr] +sequentialRestrictions expr@(Restrict _ subexpr) = expr:sequentialRestrictions subexpr +sequentialRestrictions _ = [] + +--restriction pushdown only really makes sense for tuple-oriented storage schemes where performing a restriction before projection can cut down on the intermediate storage needed to store the data before the projection +-- x{proj} where c1 -> (x where c1){proj} #project on fewer tuples +-- (x union y) where c -> (x where c) union (y where c) #with a selective restriction, fewer tuples will need to be joined +applyStaticRestrictionPushdown :: RelationalExpr -> RelationalExpr +applyStaticRestrictionPushdown expr = case expr of + MakeRelationFromExprs _ _ -> expr + MakeStaticRelation _ _ -> expr + ExistingRelation _ -> expr + RelationVariable _ _ -> expr + Project _ _ -> expr + --this transformation cannot be inverted because the projection attributes might not exist in the inverted version + Restrict restrictAttrs (Project projAttrs subexpr) -> + Project projAttrs (Restrict restrictAttrs (applyStaticRestrictionPushdown subexpr)) + Restrict restrictAttrs (Union subexpr1 subexpr2) -> + let optSub1 = applyStaticRestrictionPushdown subexpr1 + optSub2 = applyStaticRestrictionPushdown subexpr2 in + Union (Restrict restrictAttrs optSub1) (Restrict restrictAttrs optSub2) + Restrict attrs subexpr -> + Restrict attrs (applyStaticRestrictionPushdown subexpr) + + Union sub1 sub2 -> + Union (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) + Join sub1 sub2 -> + Join (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) + Rename n1 n2 sub -> + Rename n1 n2 (applyStaticRestrictionPushdown sub) + Difference sub1 sub2 -> + Difference (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) + Group n1 n2 sub -> + Group n1 n2 (applyStaticRestrictionPushdown sub) + Ungroup n1 sub -> + Ungroup n1 (applyStaticRestrictionPushdown sub) + Equals sub1 sub2 -> + Equals (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) + NotEquals sub1 sub2 -> + NotEquals (applyStaticRestrictionPushdown sub1) (applyStaticRestrictionPushdown sub2) + Extend n sub -> + Extend n (applyStaticRestrictionPushdown sub) + + diff --git a/src/lib/ProjectM36/TransGraphRelationalExpression.hs b/src/lib/ProjectM36/TransGraphRelationalExpression.hs --- a/src/lib/ProjectM36/TransGraphRelationalExpression.hs +++ b/src/lib/ProjectM36/TransGraphRelationalExpression.hs @@ -18,6 +18,10 @@ instance Binary TransGraphRelationalExpr +type TransGraphAttributeNames = AttributeNamesBase TransactionIdLookup + +instance Binary TransGraphAttributeNames + type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup instance Binary TransGraphExtendTupleExpr @@ -51,30 +55,32 @@ trans <- lookupTransaction graph transLookup rel <- runReader (evalRelationalExpr (RelationVariable rvname ())) (RelationalExprStateElems (concreteDatabaseContext trans)) pure (ExistingRelation rel) -evalTransGraphRelationalExpr (Project attrNames expr) graph = do +evalTransGraphRelationalExpr (Project transAttrNames expr) graph = do expr' <- evalTransGraphRelationalExpr expr graph + attrNames <- evalTransAttributeNames transAttrNames graph pure (Project attrNames expr') evalTransGraphRelationalExpr (Union exprA exprB) graph = do exprA' <- evalTransGraphRelationalExpr exprA graph exprB' <- evalTransGraphRelationalExpr exprB graph - pure (Union exprA' exprB') + pure (Union exprA' exprB') evalTransGraphRelationalExpr (Join exprA exprB) graph = do exprA' <- evalTransGraphRelationalExpr exprA graph exprB' <- evalTransGraphRelationalExpr exprB graph pure (Join exprA' exprB') evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) graph = do - expr' <- evalTransGraphRelationalExpr expr graph - pure (Rename attrName1 attrName2 expr') + let expr' = evalTransGraphRelationalExpr expr graph + Rename attrName1 attrName2 <$> expr' evalTransGraphRelationalExpr (Difference exprA exprB) graph = do exprA' <- evalTransGraphRelationalExpr exprA graph exprB' <- evalTransGraphRelationalExpr exprB graph pure (Difference exprA' exprB') -evalTransGraphRelationalExpr (Group attrNames attrName expr) graph = do +evalTransGraphRelationalExpr (Group transAttrNames attrName expr) graph = do expr' <- evalTransGraphRelationalExpr expr graph + attrNames <- evalTransAttributeNames transAttrNames graph pure (Group attrNames attrName expr') evalTransGraphRelationalExpr (Ungroup attrName expr) graph = do - expr' <- evalTransGraphRelationalExpr expr graph - pure (Ungroup attrName expr') + let expr' = evalTransGraphRelationalExpr expr graph + Ungroup attrName <$> expr' evalTransGraphRelationalExpr (Restrict predicateExpr expr) graph = do expr' <- evalTransGraphRelationalExpr expr graph predicateExpr' <- evalTransGraphRestrictionPredicateExpr predicateExpr graph @@ -94,11 +100,11 @@ evalTransGraphTupleExpr :: TransactionGraph -> TransGraphTupleExpr -> Either RelationalError TupleExpr evalTransGraphTupleExpr graph (TupleExpr attrMap) = do - attrAssoc <- mapM (\(attrName, atomExpr) -> do + let attrAssoc = mapM (\(attrName, atomExpr) -> do aExpr <- evalTransGraphAtomExpr graph atomExpr pure (attrName, aExpr) ) (M.toList attrMap) - pure (TupleExpr (M.fromList attrAssoc)) + TupleExpr . M.fromList <$> attrAssoc evalTransGraphAtomExpr :: TransactionGraph -> TransGraphAtomExpr -> Either RelationalError AtomExpr evalTransGraphAtomExpr _ (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname @@ -110,8 +116,8 @@ atom <- runReader (evalAtomExpr emptyTuple (FunctionAtomExpr funcName args' ())) (RelationalExprStateElems (concreteDatabaseContext trans)) pure (NakedAtomExpr atom) evalTransGraphAtomExpr graph (RelationAtomExpr expr) = do - expr' <- evalTransGraphRelationalExpr expr graph - pure (RelationAtomExpr expr') + let expr' = evalTransGraphRelationalExpr expr graph + RelationAtomExpr <$> expr' evalTransGraphAtomExpr graph (ConstructedAtomExpr dConsName args tLookup) = do trans <- lookupTransaction graph tLookup args' <- mapM (evalTransGraphAtomExpr graph) args @@ -129,22 +135,22 @@ exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph pure (OrPredicate exprA' exprB') evalTransGraphRestrictionPredicateExpr (NotPredicate expr) graph = do - expr' <- evalTransGraphRestrictionPredicateExpr expr graph - pure (NotPredicate expr') + let expr' = evalTransGraphRestrictionPredicateExpr expr graph + NotPredicate <$> expr' evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) graph = do - expr' <- evalTransGraphRelationalExpr expr graph - pure (RelationalExprPredicate expr') + let expr' = evalTransGraphRelationalExpr expr graph + RelationalExprPredicate <$> expr' evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) graph = do - expr' <- evalTransGraphAtomExpr graph expr - pure (AtomExprPredicate expr') + let expr' = evalTransGraphAtomExpr graph expr + AtomExprPredicate <$> expr' evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) graph = do - expr' <- evalTransGraphAtomExpr graph expr - pure (AttributeEqualityPredicate attrName expr') + let expr' = evalTransGraphAtomExpr graph expr + AttributeEqualityPredicate attrName <$> expr' evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransactionGraph -> Either RelationalError ExtendTupleExpr evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) graph = do - expr' <- evalTransGraphAtomExpr graph expr - pure (AttributeExtendTupleExpr attrName expr') + let expr' = evalTransGraphAtomExpr graph expr + AttributeExtendTupleExpr attrName <$> expr' evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do @@ -152,3 +158,18 @@ aType <- atomTypeForTypeConstructor tCons (typeConstructorMapping (concreteDatabaseContext trans)) M.empty pure (NakedAttributeExpr (Attribute attrName aType)) evalTransGraphAttributeExpr _ (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr) + +evalTransAttributeNames :: TransGraphAttributeNames -> TransactionGraph -> Either RelationalError AttributeNames +evalTransAttributeNames (AttributeNames names) _ = Right (AttributeNames names) +evalTransAttributeNames (InvertedAttributeNames names) _ = Right (InvertedAttributeNames names) +evalTransAttributeNames (UnionAttributeNames namesA namesB) graph = do + nA <- evalTransAttributeNames namesA graph + nB <- evalTransAttributeNames namesB graph + Right (UnionAttributeNames nA nB) +evalTransAttributeNames (IntersectAttributeNames namesA namesB) graph = do + nA <- evalTransAttributeNames namesA graph + nB <- evalTransAttributeNames namesB graph + Right (IntersectAttributeNames nA nB) +evalTransAttributeNames (RelationalExprAttributeNames expr) graph = do + evaldExpr <- evalTransGraphRelationalExpr expr graph + Right (RelationalExprAttributeNames evaldExpr) 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 @@ -23,10 +23,10 @@ import qualified Data.ByteString.Lazy as BSL getDirectoryNames :: FilePath -> IO [FilePath] -getDirectoryNames path = do - subpaths <- getDirectoryContents path - return $ filter (\n -> n `notElem` ["..", "."]) subpaths +getDirectoryNames path = + filter (\ n -> n `notElem` ["..", "."]) <$> getDirectoryContents path + tempTransactionDir :: FilePath -> TransactionId -> FilePath tempTransactionDir dbdir transId = dbdir "." ++ show transId @@ -109,10 +109,10 @@ readRelVars transDir = do let relvarsPath = relvarsDir transDir relvarNames <- getDirectoryNames relvarsPath - relvars <- mapM (\name -> do + let relvars = mapM (\name -> do rel <- B.decode . decompress . BSL.fromStrict <$> BS.readFile (relvarsPath name) return (T.pack name, rel)) relvarNames - return $ M.fromList relvars + M.fromList <$> relvars writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO () writeAtomFuncs sync transDir funcs = do @@ -191,8 +191,8 @@ funcNames <- getDirectoryNames (dbcFuncsDir transDir) --only Haskell script functions can be serialized --we always return the pre-compiled functions - funcs <- mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames - return $ HS.union basicDatabaseContextFunctions (HS.fromList funcs) + let funcs = mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames + HS.union basicDatabaseContextFunctions . HS.fromList <$> funcs readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction readDBCFunc transDir funcName mScriptSession precompiledFuncs = do @@ -232,8 +232,7 @@ readIncDeps transDir = do let incDepsPath = incDepsDir transDir incDepNames <- getDirectoryNames incDepsPath - incDeps <- mapM (readIncDep transDir . T.pack) incDepNames - return $ M.fromList incDeps + M.fromList <$> mapM (readIncDep transDir . T.pack) incDepNames readSubschemas :: FilePath -> IO Subschemas readSubschemas transDir = 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 @@ -98,9 +98,8 @@ matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph) transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction) -transactionsForIds idSet graph = do - transList <- forM (S.toList idSet) (`transactionForId` graph) - return (S.fromList transList) +transactionsForIds idSet graph = + S.fromList <$> forM (S.toList idSet) (`transactionForId` graph) isRootTransaction :: Transaction -> TransactionGraph -> Bool isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId @@ -108,10 +107,10 @@ -- the first transaction has no parent - all other do have parents- merges have two parents parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction) -parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph = do - trans <- transactionForId pId graph - return (S.singleton trans) +parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph = + S.singleton <$> transactionForId pId graph + parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph @@ -164,7 +163,7 @@ --uuids = map transactionId transSet --check that all heads appear in the transSet --check that all forward and backward links are in place - _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet) + mapM_ (walkParentTransactions S.empty graph) (S.toList transSet) mapM (walkChildTransactions S.empty graph) (S.toList transSet) --verify that all parent links exist and that all children exist @@ -322,8 +321,8 @@ -- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do - selectedTrans <- validateHeadName selectedBranch graph t2 - pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) (schemas selectedTrans) + let selectedTrans = validateHeadName selectedBranch graph t2 + Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) . schemas <$> selectedTrans -- merge functions, relvars, individually createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2 @@ -407,8 +406,8 @@ case createMergeTransaction stamp newId mergeStrategy subGraph' (transA, transB) of Left err -> Left (MergeTransactionError err) Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of - Just err -> Left err - Nothing -> case headNameForTransaction disconParent graph of + Left err -> Left err + Right _ -> case headNameForTransaction disconParent graph of Nothing -> Left (TransactionIsNotAHeadError parentId) Just headName -> do (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph @@ -509,7 +508,7 @@ backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp) = do trans <- transactionForId currentTid graph let parents = transactionParentIds trans - if transactionTimestamp trans < stamp then + if transactionTimestamp trans <= stamp then pure currentTid else if S.null parents then Left RootTransactionTraversalError 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 @@ -21,7 +21,8 @@ import Data.Maybe (fromMaybe) import qualified Data.List as L import Control.Exception.Base -import qualified Data.Text.IO as TIO +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE import Data.ByteString (ByteString) import Data.Monoid import qualified Crypto.Hash.SHA256 as SHA256 @@ -83,13 +84,12 @@ locker <- openLockFile (lockFilePath dbdir) gDigest <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (readGraphTransactionIdFileDigest dbdir) pure (Right (locker, gDigest)) - else if not m36exists then do - locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph - pure (Right locks) + else if not m36exists then + Right <$> bootstrapDatabaseDir sync dbdir bootstrapGraph else pure (Left (InvalidDirectoryError dbdir)) {- -initialize a database directory with the graph from which to bootstrap- return lock file handle +initialize a database directory with the graph from which to bootstrap- return lock file handle which must be closed by the caller -} bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (LockFile, LockFileHash) bootstrapDatabaseDir sync dbdir bootstrapGraph = do @@ -201,8 +201,8 @@ readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash readGraphTransactionIdFileDigest dbdir = do - graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir) - pure (SHA256.hash (encodeUtf8 graphTransactionIdData)) + let graphTransactionIdData = readUTF8FileOrError (transactionLogPath dbdir) + SHA256.hash . encodeUtf8 <$> graphTransactionIdData readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])]) readGraphTransactionIdFile dbdir = do @@ -211,7 +211,15 @@ (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))) - --warning: uses lazy IO - graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir) - return $ Right (map grapher $ T.lines graphTransactionIdData) + Right . map grapher . T.lines <$> readUTF8FileOrError (transactionLogPath dbdir) +--rationale- reading essential database files must fail hard +readUTF8FileOrError :: FilePath -> IO T.Text +readUTF8FileOrError pathIn = do + eFileBytes <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString) + case eFileBytes of + Left err -> error (show err) + Right fileBytes -> + case TE.decodeUtf8' fileBytes of + Left err -> error (show err) + Right utf8Bytes -> pure utf8Bytes diff --git a/src/lib/ProjectM36/Tuple.hs b/src/lib/ProjectM36/Tuple.hs --- a/src/lib/ProjectM36/Tuple.hs +++ b/src/lib/ProjectM36/Tuple.hs @@ -29,6 +29,14 @@ tupleAssocs :: RelationTuple -> [(AttributeName, Atom)] tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec) +orderedTupleAssocs :: RelationTuple -> [(AttributeName, Atom)] +orderedTupleAssocs tup@(RelationTuple attrVec _) = map (\attr -> (attributeName attr, atomForAttr (attributeName attr))) oAttrs + where + oAttrs = orderedAttributes attrVec + atomForAttr nam = case atomForAttributeName nam tup of + Left _ -> TextAtom "" + Right val -> val + -- return atoms in some arbitrary but consistent key order tupleAtoms :: RelationTuple -> V.Vector Atom tupleAtoms (RelationTuple _ tupVec) = tupVec @@ -48,9 +56,8 @@ -} atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> Either RelationalError (V.Vector Atom) -atomsForAttributeNames attrNames tuple = do - vindices <- vectorIndicesForAttributeNames attrNames (tupleAttributes tuple) - return $ V.map (\index -> tupleAtoms tuple V.! index) vindices +atomsForAttributeNames attrNames tuple = + V.map (\index -> tupleAtoms tuple V.! index) <$> vectorIndicesForAttributeNames attrNames (tupleAttributes tuple) vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int) vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then @@ -146,10 +153,6 @@ where newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom) -{- sort the associative list to match the header sorting -} -tupleSortedAssocs :: RelationTuple -> [(AttributeName, Atom)] -tupleSortedAssocs (RelationTuple tupAttrs tupVec) = V.toList $ V.map (\(index,attr) -> (attributeName attr, tupVec V.! index)) $ V.indexed tupAttrs - --this could be cheaper- it may not be wortwhile to update all the tuples for projection, but then the attribute management must be slightly different- perhaps the attributes should be a vector of association tuples [(name, index)] tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec @@ -206,7 +209,7 @@ RelationTuple attrs (V.map mapper attrs) where mapper attr = case atomForAttributeName (attributeName attr) tupIn of - Left _ -> error "logic failure in reorderTuple" + Left err -> error ("logic bug in reorderTuple: " ++ show err) Right atom -> atom --used in Generics derivation for ADTs without named attributes diff --git a/src/lib/ProjectM36/Tupleable.hs b/src/lib/ProjectM36/Tupleable.hs --- a/src/lib/ProjectM36/Tupleable.hs +++ b/src/lib/ProjectM36/Tupleable.hs @@ -1,19 +1,29 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances, ScopedTypeVariables, DefaultSignatures #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + module ProjectM36.Tupleable where -import ProjectM36.Base -import ProjectM36.Error -import ProjectM36.TupleSet -import ProjectM36.Tuple -import ProjectM36.Atomable -import ProjectM36.DataTypes.Primitive -import ProjectM36.Attribute hiding (null) -import GHC.Generics -import qualified Data.Vector as V -import qualified Data.Text as T -import Data.Monoid -import Data.Proxy -import Data.Foldable +import Data.Foldable +import Data.List (partition) +import qualified Data.Map as Map +import Data.Monoid +import Data.Proxy +import qualified Data.Text as T +import qualified Data.Vector as V +import GHC.Generics +import ProjectM36.Atomable +import ProjectM36.Attribute hiding (null) +import ProjectM36.Base +import ProjectM36.DataTypes.Primitive +import ProjectM36.Error +import ProjectM36.Tuple +import ProjectM36.TupleSet +import qualified Data.Set as S + {-import Data.Binary import Control.DeepSeq @@ -21,27 +31,27 @@ attrA :: Int } deriving (Generic, Show) - + data Test2T a b = Test2C { attrB :: a, attrC :: b } deriving (Generic, Show) - + instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b) instance Tupleable Test1T data TestUnnamed1 = TestUnnamed1 Int Double T.Text deriving (Show,Eq, Generic) - -instance Tupleable TestUnnamed1 +instance Tupleable TestUnnamed1 + data Test7A = Test7AC Integer deriving (Generic, Show, Eq, Atomable, NFData, Binary) - - -data Test7T = Test7C Test7A + + +data Test7T = Test7C Test7A deriving (Generic, Show, Eq) instance Tupleable Test7T @@ -52,41 +62,91 @@ toInsertExpr vals rvName = do let attrs = toAttributes (Proxy :: Proxy a) tuples <- mkTupleSet attrs $ toList (fmap toTuple vals) - let rel = MakeStaticRelation attrs tuples + let rel = MakeStaticRelation attrs tuples pure (Insert rvName rel) - + -- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'Data.Proxy'. toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs)) - where + where attrs = toAttributes (Proxy :: Proxy a) +tupleAssocsEqualityPredicate :: [(AttributeName, Atom)] -> RestrictionPredicateExpr +tupleAssocsEqualityPredicate [] = TruePredicate +tupleAssocsEqualityPredicate pairs = + foldr1 AndPredicate $ + map + (\(name, atom) -> AttributeEqualityPredicate name (NakedAtomExpr atom)) + pairs + +partitionByAttributes :: + Tupleable a + => [AttributeName] + -> a + -> ([(AttributeName, Atom)], [(AttributeName, Atom)]) +partitionByAttributes attrs = + partition ((`elem` attrs) . fst) . tupleAssocs . toTuple + +-- | Convert a list of key attributes and a 'Tupleable' value to an 'Update' +-- expression. This expression flushes the non-key attributes of the value to +-- a tuple with the matching key attributes. +toUpdateExpr :: + forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr +toUpdateExpr rvName keyAttrs a = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Update rvName updateMap keyRestriction) + where + (keyPairs, updatePairs) = partitionByAttributes keyAttrs a + updateMap = Map.fromList $ fmap NakedAtomExpr <$> updatePairs + keyRestriction = tupleAssocsEqualityPredicate keyPairs + expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a)) + +-- | Convert a list of key attributes and a 'Tupleable' value to a 'Delete' +-- expression. This expression deletes tuples matching the key attributes from +-- the value. +toDeleteExpr :: + forall a. Tupleable a => RelVarName -> [AttributeName] -> a -> Either RelationalError DatabaseContextExpr +toDeleteExpr rvName keyAttrs val = validateAttributes (S.fromList keyAttrs) expectedAttrSet (Delete rvName keyRestriction) + where + keyPairs = fst $ partitionByAttributes keyAttrs val + keyRestriction = tupleAssocsEqualityPredicate keyPairs + expectedAttrSet = attributeNameSet (toAttributes (Proxy :: Proxy a)) + +validateAttributes :: S.Set AttributeName -> S.Set AttributeName -> a -> Either RelationalError a +validateAttributes actualAttrs expectedAttrs val + | S.null actualAttrs = Left EmptyAttributesError + | not (S.null nonMatchingAttrs) = Left (NoSuchAttributeNamesError nonMatchingAttrs) + | otherwise = Right val + where + nonMatchingAttrs = attributeNamesNotContained actualAttrs expectedAttrs + + class Tupleable a where toTuple :: a -> RelationTuple - + fromTuple :: RelationTuple -> Either RelationalError a - + toAttributes :: proxy a -> Attributes default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple toTuple v = toTupleG (from v) - + default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a fromTuple tup = to <$> fromTupleG tup - + default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes toAttributes _ = toAttributesG (from (undefined :: a)) - -class TupleableG g where + +class TupleableG g where toTupleG :: g a -> RelationTuple toAttributesG :: g a -> Attributes fromTupleG :: RelationTuple -> Either RelationalError (g a) - + isRecordTypeG :: g a -> Bool + --data type metadata instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where toTupleG (M1 v) = toTupleG v toAttributesG (M1 v) = toAttributesG v fromTupleG v = M1 <$> fromTupleG v + isRecordTypeG (M1 v) = isRecordTypeG v --constructor metadata instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where @@ -94,19 +154,26 @@ where attrsToCheck = toAttributesG v counter = V.generate (V.length attrsToCheck) id - attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then - Attribute ("attr" <> T.pack (show (num + 1))) typ + attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then + Attribute ("attr" <> T.pack (show (num + 1))) typ else - attr) counter attrsToCheck + attr) counter attrsToCheck atoms = V.fromList (toAtomsG v) toAttributesG (M1 v) = toAttributesG v fromTupleG tup = M1 <$> fromTupleG tup - + isRecordTypeG (M1 v) = isRecordTypeG v + -- product types instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where toTupleG = error "toTupleG" toAttributesG ~(x :*: y) = toAttributesG x V.++ toAttributesG y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception - fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG (trimTuple 1 tup) + fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG processedTuple + where + processedTuple = if isRecordTypeG (undefined :: a x) then + tup + else + trimTuple 1 tup + isRecordTypeG ~(x :*: y) = isRecordTypeG x || isRecordTypeG y --selector/record instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where @@ -123,17 +190,18 @@ pure (M1 val) where expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x))) - atomv atom = maybe (Left (AtomTypeMismatchError + atomv atom = maybe (Left (AtomTypeMismatchError expectedAtomType (atomTypeForAtom atom) )) Right (fromAtomG atom [atom]) name = selName (undefined :: M1 S c a x) + isRecordTypeG _ = not (null (selName (undefined :: M1 S c a x))) ---constructors with no arguments +--constructors with no arguments --basically useless but orthoganal to relationTrue instance TupleableG U1 where toTupleG _= emptyTuple toAttributesG _ = emptyAttributes fromTupleG _ = pure U1 - - + isRecordTypeG _ = False + diff --git a/src/lib/ProjectM36/TypeConstructor.hs b/src/lib/ProjectM36/TypeConstructor.hs --- a/src/lib/ProjectM36/TypeConstructor.hs +++ b/src/lib/ProjectM36/TypeConstructor.hs @@ -1,19 +1,17 @@ module ProjectM36.TypeConstructor where import ProjectM36.Base -import qualified Data.Set as S name :: TypeConstructor -> TypeConstructorName name (ADTypeConstructor name' _) = name' name (PrimitiveTypeConstructor name' _) = name' -name (TypeVariable _) = error "spam" --v --not really the name, but this is used for display only +name (RelationAtomTypeConstructor _) = error "name called on RelationAtomTypeConstructor" +name (TypeVariable _) = error "name called on TypeVariable" --v --not really the name, but this is used for display only arguments :: TypeConstructor -> [TypeConstructor] arguments (ADTypeConstructor _ args) = args arguments (PrimitiveTypeConstructor _ _) = [] +arguments (RelationAtomTypeConstructor _) = [] arguments (TypeVariable _) = [] -typeVars :: TypeConstructor -> S.Set TypeVarName -typeVars (PrimitiveTypeConstructor _ _) = S.empty -typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args) -typeVars (TypeVariable v) = S.singleton v + diff --git a/src/lib/ProjectM36/WCWidth.hs b/src/lib/ProjectM36/WCWidth.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/WCWidth.hs @@ -0,0 +1,425 @@ +module ProjectM36.WCWidth where +import Data.Set.Range +import Data.Char + +wIDEEASTASIAN :: RangeSet Int +wIDEEASTASIAN = foldr insertRange empty [ + (0x1100, 0x115f), -- Hangul Choseong Kiyeok ..Hangul Choseong Filler + (0x231a, 0x231b), -- Watch ..Hourglass + (0x2329, 0x232a), -- Left-pointing Angle Brac..Right-pointing Angle Bra + (0x23e9, 0x23ec), -- Black Right-pointing Dou..Black Down-pointing Doub + (0x23f0, 0x23f0), -- Alarm Clock ..Alarm Clock + (0x23f3, 0x23f3), -- Hourglass With Flowing S..Hourglass With Flowing S + (0x25fd, 0x25fe), -- White Medium Small Squar..Black Medium Small Squar + (0x2614, 0x2615), -- Umbrella With Rain Drops..Hot Beverage + (0x2648, 0x2653), -- Aries ..Pisces + (0x267f, 0x267f), -- Wheelchair Symbol ..Wheelchair Symbol + (0x2693, 0x2693), -- Anchor ..Anchor + (0x26a1, 0x26a1), -- High Voltage Sign ..High Voltage Sign + (0x26aa, 0x26ab), -- Medium White Circle ..Medium Black Circle + (0x26bd, 0x26be), -- Soccer Ball ..Baseball + (0x26c4, 0x26c5), -- Snowman Without Snow ..Sun Behind Cloud + (0x26ce, 0x26ce), -- Ophiuchus ..Ophiuchus + (0x26d4, 0x26d4), -- No Entry ..No Entry + (0x26ea, 0x26ea), -- Church ..Church + (0x26f2, 0x26f3), -- Fountain ..Flag In Hole + (0x26f5, 0x26f5), -- Sailboat ..Sailboat + (0x26fa, 0x26fa), -- Tent ..Tent + (0x26fd, 0x26fd), -- Fuel Pump ..Fuel Pump + (0x2705, 0x2705), -- White Heavy Check Mark ..White Heavy Check Mark + (0x270a, 0x270b), -- Raised Fist ..Raised Hand + (0x2728, 0x2728), -- Sparkles ..Sparkles + (0x274c, 0x274c), -- Cross Mark ..Cross Mark + (0x274e, 0x274e), -- Negative Squared Cross M..Negative Squared Cross M + (0x2753, 0x2755), -- Black Question Mark Orna..White Exclamation Mark O + (0x2757, 0x2757), -- Heavy Exclamation Mark S..Heavy Exclamation Mark S + (0x2795, 0x2797), -- Heavy Plus Sign ..Heavy Division Sign + (0x27b0, 0x27b0), -- Curly Loop ..Curly Loop + (0x27bf, 0x27bf), -- Double Curly Loop ..Double Curly Loop + (0x2b1b, 0x2b1c), -- Black Large Square ..White Large Square + (0x2b50, 0x2b50), -- White Medium Star ..White Medium Star + (0x2b55, 0x2b55), -- Heavy Large Circle ..Heavy Large Circle + (0x2e80, 0x2e99), -- Cjk Radical Repeat ..Cjk Radical Rap + (0x2e9b, 0x2ef3), -- Cjk Radical Choke ..Cjk Radical C-simplified + (0x2f00, 0x2fd5), -- Kangxi Radical One ..Kangxi Radical Flute + (0x2ff0, 0x2ffb), -- Ideographic Description ..Ideographic Description + (0x3000, 0x303e), -- Ideographic Space ..Ideographic Variation In + (0x3041, 0x3096), -- Hiragana Letter Small A ..Hiragana Letter Small Ke + (0x3099, 0x30ff), -- Combining Katakana-hirag..Katakana Digraph Koto + (0x3105, 0x312d), -- Bopomofo Letter B ..Bopomofo Letter Ih + (0x3131, 0x318e), -- Hangul Letter Kiyeok ..Hangul Letter Araeae + (0x3190, 0x31ba), -- Ideographic Annotation L..Bopomofo Letter Zy + (0x31c0, 0x31e3), -- Cjk Stroke T ..Cjk Stroke Q + (0x31f0, 0x321e), -- Katakana Letter Small Ku..Parenthesized Korean Cha + (0x3220, 0x3247), -- Parenthesized Ideograph ..Circled Ideograph Koto + (0x3250, 0x32fe), -- Partnership Sign ..Circled Katakana Wo + (0x3300, 0x4dbf), -- Square Apaato .. + (0x4e00, 0xa48c), -- Cjk Unified Ideograph-4e..Yi Syllable Yyr + (0xa490, 0xa4c6), -- Yi Radical Qot ..Yi Radical Ke + (0xa960, 0xa97c), -- Hangul Choseong Tikeut-m..Hangul Choseong Ssangyeo + (0xac00, 0xd7a3), -- Hangul Syllable Ga ..Hangul Syllable Hih + (0xf900, 0xfaff), -- Cjk Compatibility Ideogr.. + (0xfe10, 0xfe19), -- Presentation Form For Ve..Presentation Form For Ve + (0xfe30, 0xfe52), -- Presentation Form For Ve..Small Full Stop + (0xfe54, 0xfe66), -- Small Semicolon ..Small Equals Sign + (0xfe68, 0xfe6b), -- Small Reverse Solidus ..Small Commercial At + (0xff01, 0xff60), -- Fullwidth Exclamation Ma..Fullwidth Right White Pa + (0xffe0, 0xffe6), -- Fullwidth Cent Sign ..Fullwidth Won Sign + (0x16fe0, 0x16fe0), -- (nil) .. + (0x17000, 0x187ec), -- (nil) .. + (0x18800, 0x18af2), -- (nil) .. + (0x1b000, 0x1b001), -- Katakana Letter Archaic ..Hiragana Letter Archaic + (0x1f004, 0x1f004), -- Mahjong Tile Red Dragon ..Mahjong Tile Red Dragon + (0x1f0cf, 0x1f0cf), -- Playing Card Black Joker..Playing Card Black Joker + (0x1f18e, 0x1f18e), -- Negative Squared Ab ..Negative Squared Ab + (0x1f191, 0x1f19a), -- Squared Cl ..Squared Vs + (0x1f200, 0x1f202), -- Square Hiragana Hoka ..Squared Katakana Sa + (0x1f210, 0x1f23b), -- Squared Cjk Unified Ideo.. + (0x1f240, 0x1f248), -- Tortoise Shell Bracketed..Tortoise Shell Bracketed + (0x1f250, 0x1f251), -- Circled Ideograph Advant..Circled Ideograph Accept + (0x1f300, 0x1f320), -- Cyclone ..Shooting Star + (0x1f32d, 0x1f335), -- Hot Dog ..Cactus + (0x1f337, 0x1f37c), -- Tulip ..Baby Bottle + (0x1f37e, 0x1f393), -- Bottle With Popping Cork..Graduation Cap + (0x1f3a0, 0x1f3ca), -- Carousel Horse ..Swimmer + (0x1f3cf, 0x1f3d3), -- Cricket Bat And Ball ..Table Tennis Paddle And + (0x1f3e0, 0x1f3f0), -- House Building ..European Castle + (0x1f3f4, 0x1f3f4), -- Waving Black Flag ..Waving Black Flag + (0x1f3f8, 0x1f43e), -- Badminton Racquet And Sh..Paw Prints + (0x1f440, 0x1f440), -- Eyes ..Eyes + (0x1f442, 0x1f4fc), -- Ear ..Videocassette + (0x1f4ff, 0x1f53d), -- Prayer Beads ..Down-pointing Small Red + (0x1f54b, 0x1f54e), -- Kaaba ..Menorah With Nine Branch + (0x1f550, 0x1f567), -- Clock Face One Oclock ..Clock Face Twelve-thirty + (0x1f57a, 0x1f57a), -- (nil) .. + (0x1f595, 0x1f596), -- Reversed Hand With Middl..Raised Hand With Part Be + (0x1f5a4, 0x1f5a4), -- (nil) .. + (0x1f5fb, 0x1f64f), -- Mount Fuji ..Person With Folded Hands + (0x1f680, 0x1f6c5), -- Rocket ..Left Luggage + (0x1f6cc, 0x1f6cc), -- Sleeping Accommodation ..Sleeping Accommodation + (0x1f6d0, 0x1f6d2), -- Place Of Worship .. + (0x1f6eb, 0x1f6ec), -- Airplane Departure ..Airplane Arriving + (0x1f6f4, 0x1f6f6), -- (nil) .. + (0x1f910, 0x1f91e), -- Zipper-mouth Face .. + (0x1f920, 0x1f927), -- (nil) .. + (0x1f930, 0x1f930), -- (nil) .. + (0x1f933, 0x1f93e), -- (nil) .. + (0x1f940, 0x1f94b), -- (nil) .. + (0x1f950, 0x1f95e), -- (nil) .. + (0x1f980, 0x1f991), -- Crab .. + (0x1f9c0, 0x1f9c0), -- Cheese Wedge ..Cheese Wedge + (0x20000, 0x2fffd), -- Cjk Unified Ideograph-20.. + (0x30000, 0x3fffd) -- (nil) .. + ] + +zEROWIDTH :: RangeSet Int +zEROWIDTH = foldr insertRange empty [ + (0x0300, 0x036f), -- Combining Grave Accent ..Combining Latin Small Le + (0x0483, 0x0489), -- Combining Cyrillic Titlo..Combining Cyrillic Milli + (0x0591, 0x05bd), -- Hebrew Accent Etnahta ..Hebrew Point Meteg + (0x05bf, 0x05bf), -- Hebrew Point Rafe ..Hebrew Point Rafe + (0x05c1, 0x05c2), -- Hebrew Point Shin Dot ..Hebrew Point Sin Dot + (0x05c4, 0x05c5), -- Hebrew Mark Upper Dot ..Hebrew Mark Lower Dot + (0x05c7, 0x05c7), -- Hebrew Point Qamats Qata..Hebrew Point Qamats Qata + (0x0610, 0x061a), -- Arabic Sign Sallallahou ..Arabic Small Kasra + (0x064b, 0x065f), -- Arabic Fathatan ..Arabic Wavy Hamza Below + (0x0670, 0x0670), -- Arabic Letter Superscrip..Arabic Letter Superscrip + (0x06d6, 0x06dc), -- Arabic Small High Ligatu..Arabic Small High Seen + (0x06df, 0x06e4), -- Arabic Small High Rounde..Arabic Small High Madda + (0x06e7, 0x06e8), -- Arabic Small High Yeh ..Arabic Small High Noon + (0x06ea, 0x06ed), -- Arabic Empty Centre Low ..Arabic Small Low Meem + (0x0711, 0x0711), -- Syriac Letter Superscrip..Syriac Letter Superscrip + (0x0730, 0x074a), -- Syriac Pthaha Above ..Syriac Barrekh + (0x07a6, 0x07b0), -- Thaana Abafili ..Thaana Sukun + (0x07eb, 0x07f3), -- Nko Combining Short High..Nko Combining Double Dot + (0x0816, 0x0819), -- Samaritan Mark In ..Samaritan Mark Dagesh + (0x081b, 0x0823), -- Samaritan Mark Epentheti..Samaritan Vowel Sign A + (0x0825, 0x0827), -- Samaritan Vowel Sign Sho..Samaritan Vowel Sign U + (0x0829, 0x082d), -- Samaritan Vowel Sign Lon..Samaritan Mark Nequdaa + (0x0859, 0x085b), -- Mandaic Affrication Mark..Mandaic Gemination Mark + (0x08d4, 0x08e1), -- (nil) .. + (0x08e3, 0x0902), -- Arabic Turned Damma Belo..Devanagari Sign Anusvara + (0x093a, 0x093a), -- Devanagari Vowel Sign Oe..Devanagari Vowel Sign Oe + (0x093c, 0x093c), -- Devanagari Sign Nukta ..Devanagari Sign Nukta + (0x0941, 0x0948), -- Devanagari Vowel Sign U ..Devanagari Vowel Sign Ai + (0x094d, 0x094d), -- Devanagari Sign Virama ..Devanagari Sign Virama + (0x0951, 0x0957), -- Devanagari Stress Sign U..Devanagari Vowel Sign Uu + (0x0962, 0x0963), -- Devanagari Vowel Sign Vo..Devanagari Vowel Sign Vo + (0x0981, 0x0981), -- Bengali Sign Candrabindu..Bengali Sign Candrabindu + (0x09bc, 0x09bc), -- Bengali Sign Nukta ..Bengali Sign Nukta + (0x09c1, 0x09c4), -- Bengali Vowel Sign U ..Bengali Vowel Sign Vocal + (0x09cd, 0x09cd), -- Bengali Sign Virama ..Bengali Sign Virama + (0x09e2, 0x09e3), -- Bengali Vowel Sign Vocal..Bengali Vowel Sign Vocal + (0x0a01, 0x0a02), -- Gurmukhi Sign Adak Bindi..Gurmukhi Sign Bindi + (0x0a3c, 0x0a3c), -- Gurmukhi Sign Nukta ..Gurmukhi Sign Nukta + (0x0a41, 0x0a42), -- Gurmukhi Vowel Sign U ..Gurmukhi Vowel Sign Uu + (0x0a47, 0x0a48), -- Gurmukhi Vowel Sign Ee ..Gurmukhi Vowel Sign Ai + (0x0a4b, 0x0a4d), -- Gurmukhi Vowel Sign Oo ..Gurmukhi Sign Virama + (0x0a51, 0x0a51), -- Gurmukhi Sign Udaat ..Gurmukhi Sign Udaat + (0x0a70, 0x0a71), -- Gurmukhi Tippi ..Gurmukhi Addak + (0x0a75, 0x0a75), -- Gurmukhi Sign Yakash ..Gurmukhi Sign Yakash + (0x0a81, 0x0a82), -- Gujarati Sign Candrabind..Gujarati Sign Anusvara + (0x0abc, 0x0abc), -- Gujarati Sign Nukta ..Gujarati Sign Nukta + (0x0ac1, 0x0ac5), -- Gujarati Vowel Sign U ..Gujarati Vowel Sign Cand + (0x0ac7, 0x0ac8), -- Gujarati Vowel Sign E ..Gujarati Vowel Sign Ai + (0x0acd, 0x0acd), -- Gujarati Sign Virama ..Gujarati Sign Virama + (0x0ae2, 0x0ae3), -- Gujarati Vowel Sign Voca..Gujarati Vowel Sign Voca + (0x0b01, 0x0b01), -- Oriya Sign Candrabindu ..Oriya Sign Candrabindu + (0x0b3c, 0x0b3c), -- Oriya Sign Nukta ..Oriya Sign Nukta + (0x0b3f, 0x0b3f), -- Oriya Vowel Sign I ..Oriya Vowel Sign I + (0x0b41, 0x0b44), -- Oriya Vowel Sign U ..Oriya Vowel Sign Vocalic + (0x0b4d, 0x0b4d), -- Oriya Sign Virama ..Oriya Sign Virama + (0x0b56, 0x0b56), -- Oriya Ai Length Mark ..Oriya Ai Length Mark + (0x0b62, 0x0b63), -- Oriya Vowel Sign Vocalic..Oriya Vowel Sign Vocalic + (0x0b82, 0x0b82), -- Tamil Sign Anusvara ..Tamil Sign Anusvara + (0x0bc0, 0x0bc0), -- Tamil Vowel Sign Ii ..Tamil Vowel Sign Ii + (0x0bcd, 0x0bcd), -- Tamil Sign Virama ..Tamil Sign Virama + (0x0c00, 0x0c00), -- Telugu Sign Combining Ca..Telugu Sign Combining Ca + (0x0c3e, 0x0c40), -- Telugu Vowel Sign Aa ..Telugu Vowel Sign Ii + (0x0c46, 0x0c48), -- Telugu Vowel Sign E ..Telugu Vowel Sign Ai + (0x0c4a, 0x0c4d), -- Telugu Vowel Sign O ..Telugu Sign Virama + (0x0c55, 0x0c56), -- Telugu Length Mark ..Telugu Ai Length Mark + (0x0c62, 0x0c63), -- Telugu Vowel Sign Vocali..Telugu Vowel Sign Vocali + (0x0c81, 0x0c81), -- Kannada Sign Candrabindu..Kannada Sign Candrabindu + (0x0cbc, 0x0cbc), -- Kannada Sign Nukta ..Kannada Sign Nukta + (0x0cbf, 0x0cbf), -- Kannada Vowel Sign I ..Kannada Vowel Sign I + (0x0cc6, 0x0cc6), -- Kannada Vowel Sign E ..Kannada Vowel Sign E + (0x0ccc, 0x0ccd), -- Kannada Vowel Sign Au ..Kannada Sign Virama + (0x0ce2, 0x0ce3), -- Kannada Vowel Sign Vocal..Kannada Vowel Sign Vocal + (0x0d01, 0x0d01), -- Malayalam Sign Candrabin..Malayalam Sign Candrabin + (0x0d41, 0x0d44), -- Malayalam Vowel Sign U ..Malayalam Vowel Sign Voc + (0x0d4d, 0x0d4d), -- Malayalam Sign Virama ..Malayalam Sign Virama + (0x0d62, 0x0d63), -- Malayalam Vowel Sign Voc..Malayalam Vowel Sign Voc + (0x0dca, 0x0dca), -- Sinhala Sign Al-lakuna ..Sinhala Sign Al-lakuna + (0x0dd2, 0x0dd4), -- Sinhala Vowel Sign Ketti..Sinhala Vowel Sign Ketti + (0x0dd6, 0x0dd6), -- Sinhala Vowel Sign Diga ..Sinhala Vowel Sign Diga + (0x0e31, 0x0e31), -- Thai Character Mai Han-a..Thai Character Mai Han-a + (0x0e34, 0x0e3a), -- Thai Character Sara I ..Thai Character Phinthu + (0x0e47, 0x0e4e), -- Thai Character Maitaikhu..Thai Character Yamakkan + (0x0eb1, 0x0eb1), -- Lao Vowel Sign Mai Kan ..Lao Vowel Sign Mai Kan + (0x0eb4, 0x0eb9), -- Lao Vowel Sign I ..Lao Vowel Sign Uu + (0x0ebb, 0x0ebc), -- Lao Vowel Sign Mai Kon ..Lao Semivowel Sign Lo + (0x0ec8, 0x0ecd), -- Lao Tone Mai Ek ..Lao Niggahita + (0x0f18, 0x0f19), -- Tibetan Astrological Sig..Tibetan Astrological Sig + (0x0f35, 0x0f35), -- Tibetan Mark Ngas Bzung ..Tibetan Mark Ngas Bzung + (0x0f37, 0x0f37), -- Tibetan Mark Ngas Bzung ..Tibetan Mark Ngas Bzung + (0x0f39, 0x0f39), -- Tibetan Mark Tsa -phru ..Tibetan Mark Tsa -phru + (0x0f71, 0x0f7e), -- Tibetan Vowel Sign Aa ..Tibetan Sign Rjes Su Nga + (0x0f80, 0x0f84), -- Tibetan Vowel Sign Rever..Tibetan Mark Halanta + (0x0f86, 0x0f87), -- Tibetan Sign Lci Rtags ..Tibetan Sign Yang Rtags + (0x0f8d, 0x0f97), -- Tibetan Subjoined Sign L..Tibetan Subjoined Letter + (0x0f99, 0x0fbc), -- Tibetan Subjoined Letter..Tibetan Subjoined Letter + (0x0fc6, 0x0fc6), -- Tibetan Symbol Padma Gda..Tibetan Symbol Padma Gda + (0x102d, 0x1030), -- Myanmar Vowel Sign I ..Myanmar Vowel Sign Uu + (0x1032, 0x1037), -- Myanmar Vowel Sign Ai ..Myanmar Sign Dot Below + (0x1039, 0x103a), -- Myanmar Sign Virama ..Myanmar Sign Asat + (0x103d, 0x103e), -- Myanmar Consonant Sign M..Myanmar Consonant Sign M + (0x1058, 0x1059), -- Myanmar Vowel Sign Vocal..Myanmar Vowel Sign Vocal + (0x105e, 0x1060), -- Myanmar Consonant Sign M..Myanmar Consonant Sign M + (0x1071, 0x1074), -- Myanmar Vowel Sign Geba ..Myanmar Vowel Sign Kayah + (0x1082, 0x1082), -- Myanmar Consonant Sign S..Myanmar Consonant Sign S + (0x1085, 0x1086), -- Myanmar Vowel Sign Shan ..Myanmar Vowel Sign Shan + (0x108d, 0x108d), -- Myanmar Sign Shan Counci..Myanmar Sign Shan Counci + (0x109d, 0x109d), -- Myanmar Vowel Sign Aiton..Myanmar Vowel Sign Aiton + (0x135d, 0x135f), -- Ethiopic Combining Gemin..Ethiopic Combining Gemin + (0x1712, 0x1714), -- Tagalog Vowel Sign I ..Tagalog Sign Virama + (0x1732, 0x1734), -- Hanunoo Vowel Sign I ..Hanunoo Sign Pamudpod + (0x1752, 0x1753), -- Buhid Vowel Sign I ..Buhid Vowel Sign U + (0x1772, 0x1773), -- Tagbanwa Vowel Sign I ..Tagbanwa Vowel Sign U + (0x17b4, 0x17b5), -- Khmer Vowel Inherent Aq ..Khmer Vowel Inherent Aa + (0x17b7, 0x17bd), -- Khmer Vowel Sign I ..Khmer Vowel Sign Ua + (0x17c6, 0x17c6), -- Khmer Sign Nikahit ..Khmer Sign Nikahit + (0x17c9, 0x17d3), -- Khmer Sign Muusikatoan ..Khmer Sign Bathamasat + (0x17dd, 0x17dd), -- Khmer Sign Atthacan ..Khmer Sign Atthacan + (0x180b, 0x180d), -- Mongolian Free Variation..Mongolian Free Variation + (0x1885, 0x1886), -- Mongolian Letter Ali Gal..Mongolian Letter Ali Gal + (0x18a9, 0x18a9), -- Mongolian Letter Ali Gal..Mongolian Letter Ali Gal + (0x1920, 0x1922), -- Limbu Vowel Sign A ..Limbu Vowel Sign U + (0x1927, 0x1928), -- Limbu Vowel Sign E ..Limbu Vowel Sign O + (0x1932, 0x1932), -- Limbu Small Letter Anusv..Limbu Small Letter Anusv + (0x1939, 0x193b), -- Limbu Sign Mukphreng ..Limbu Sign Sa-i + (0x1a17, 0x1a18), -- Buginese Vowel Sign I ..Buginese Vowel Sign U + (0x1a1b, 0x1a1b), -- Buginese Vowel Sign Ae ..Buginese Vowel Sign Ae + (0x1a56, 0x1a56), -- Tai Tham Consonant Sign ..Tai Tham Consonant Sign + (0x1a58, 0x1a5e), -- Tai Tham Sign Mai Kang L..Tai Tham Consonant Sign + (0x1a60, 0x1a60), -- Tai Tham Sign Sakot ..Tai Tham Sign Sakot + (0x1a62, 0x1a62), -- Tai Tham Vowel Sign Mai ..Tai Tham Vowel Sign Mai + (0x1a65, 0x1a6c), -- Tai Tham Vowel Sign I ..Tai Tham Vowel Sign Oa B + (0x1a73, 0x1a7c), -- Tai Tham Vowel Sign Oa A..Tai Tham Sign Khuen-lue + (0x1a7f, 0x1a7f), -- Tai Tham Combining Crypt..Tai Tham Combining Crypt + (0x1ab0, 0x1abe), -- Combining Doubled Circum..Combining Parentheses Ov + (0x1b00, 0x1b03), -- Balinese Sign Ulu Ricem ..Balinese Sign Surang + (0x1b34, 0x1b34), -- Balinese Sign Rerekan ..Balinese Sign Rerekan + (0x1b36, 0x1b3a), -- Balinese Vowel Sign Ulu ..Balinese Vowel Sign Ra R + (0x1b3c, 0x1b3c), -- Balinese Vowel Sign La L..Balinese Vowel Sign La L + (0x1b42, 0x1b42), -- Balinese Vowel Sign Pepe..Balinese Vowel Sign Pepe + (0x1b6b, 0x1b73), -- Balinese Musical Symbol ..Balinese Musical Symbol + (0x1b80, 0x1b81), -- Sundanese Sign Panyecek ..Sundanese Sign Panglayar + (0x1ba2, 0x1ba5), -- Sundanese Consonant Sign..Sundanese Vowel Sign Pan + (0x1ba8, 0x1ba9), -- Sundanese Vowel Sign Pam..Sundanese Vowel Sign Pan + (0x1bab, 0x1bad), -- Sundanese Sign Virama ..Sundanese Consonant Sign + (0x1be6, 0x1be6), -- Batak Sign Tompi ..Batak Sign Tompi + (0x1be8, 0x1be9), -- Batak Vowel Sign Pakpak ..Batak Vowel Sign Ee + (0x1bed, 0x1bed), -- Batak Vowel Sign Karo O ..Batak Vowel Sign Karo O + (0x1bef, 0x1bf1), -- Batak Vowel Sign U For S..Batak Consonant Sign H + (0x1c2c, 0x1c33), -- Lepcha Vowel Sign E ..Lepcha Consonant Sign T + (0x1c36, 0x1c37), -- Lepcha Sign Ran ..Lepcha Sign Nukta + (0x1cd0, 0x1cd2), -- Vedic Tone Karshana ..Vedic Tone Prenkha + (0x1cd4, 0x1ce0), -- Vedic Sign Yajurvedic Mi..Vedic Tone Rigvedic Kash + (0x1ce2, 0x1ce8), -- Vedic Sign Visarga Svari..Vedic Sign Visarga Anuda + (0x1ced, 0x1ced), -- Vedic Sign Tiryak ..Vedic Sign Tiryak + (0x1cf4, 0x1cf4), -- Vedic Tone Candra Above ..Vedic Tone Candra Above + (0x1cf8, 0x1cf9), -- Vedic Tone Ring Above ..Vedic Tone Double Ring A + (0x1dc0, 0x1df5), -- Combining Dotted Grave A..Combining Up Tack Above + (0x1dfb, 0x1dff), -- (nil) ..Combining Right Arrowhea + (0x20d0, 0x20f0), -- Combining Left Harpoon A..Combining Asterisk Above + (0x2cef, 0x2cf1), -- Coptic Combining Ni Abov..Coptic Combining Spiritu + (0x2d7f, 0x2d7f), -- Tifinagh Consonant Joine..Tifinagh Consonant Joine + (0x2de0, 0x2dff), -- Combining Cyrillic Lette..Combining Cyrillic Lette + (0x302a, 0x302d), -- Ideographic Level Tone M..Ideographic Entering Ton + (0x3099, 0x309a), -- Combining Katakana-hirag..Combining Katakana-hirag + (0xa66f, 0xa672), -- Combining Cyrillic Vzmet..Combining Cyrillic Thous + (0xa674, 0xa67d), -- Combining Cyrillic Lette..Combining Cyrillic Payer + (0xa69e, 0xa69f), -- Combining Cyrillic Lette..Combining Cyrillic Lette + (0xa6f0, 0xa6f1), -- Bamum Combining Mark Koq..Bamum Combining Mark Tuk + (0xa802, 0xa802), -- Syloti Nagri Sign Dvisva..Syloti Nagri Sign Dvisva + (0xa806, 0xa806), -- Syloti Nagri Sign Hasant..Syloti Nagri Sign Hasant + (0xa80b, 0xa80b), -- Syloti Nagri Sign Anusva..Syloti Nagri Sign Anusva + (0xa825, 0xa826), -- Syloti Nagri Vowel Sign ..Syloti Nagri Vowel Sign + (0xa8c4, 0xa8c5), -- Saurashtra Sign Virama .. + (0xa8e0, 0xa8f1), -- Combining Devanagari Dig..Combining Devanagari Sig + (0xa926, 0xa92d), -- Kayah Li Vowel Ue ..Kayah Li Tone Calya Plop + (0xa947, 0xa951), -- Rejang Vowel Sign I ..Rejang Consonant Sign R + (0xa980, 0xa982), -- Javanese Sign Panyangga ..Javanese Sign Layar + (0xa9b3, 0xa9b3), -- Javanese Sign Cecak Telu..Javanese Sign Cecak Telu + (0xa9b6, 0xa9b9), -- Javanese Vowel Sign Wulu..Javanese Vowel Sign Suku + (0xa9bc, 0xa9bc), -- Javanese Vowel Sign Pepe..Javanese Vowel Sign Pepe + (0xa9e5, 0xa9e5), -- Myanmar Sign Shan Saw ..Myanmar Sign Shan Saw + (0xaa29, 0xaa2e), -- Cham Vowel Sign Aa ..Cham Vowel Sign Oe + (0xaa31, 0xaa32), -- Cham Vowel Sign Au ..Cham Vowel Sign Ue + (0xaa35, 0xaa36), -- Cham Consonant Sign La ..Cham Consonant Sign Wa + (0xaa43, 0xaa43), -- Cham Consonant Sign Fina..Cham Consonant Sign Fina + (0xaa4c, 0xaa4c), -- Cham Consonant Sign Fina..Cham Consonant Sign Fina + (0xaa7c, 0xaa7c), -- Myanmar Sign Tai Laing T..Myanmar Sign Tai Laing T + (0xaab0, 0xaab0), -- Tai Viet Mai Kang ..Tai Viet Mai Kang + (0xaab2, 0xaab4), -- Tai Viet Vowel I ..Tai Viet Vowel U + (0xaab7, 0xaab8), -- Tai Viet Mai Khit ..Tai Viet Vowel Ia + (0xaabe, 0xaabf), -- Tai Viet Vowel Am ..Tai Viet Tone Mai Ek + (0xaac1, 0xaac1), -- Tai Viet Tone Mai Tho ..Tai Viet Tone Mai Tho + (0xaaec, 0xaaed), -- Meetei Mayek Vowel Sign ..Meetei Mayek Vowel Sign + (0xaaf6, 0xaaf6), -- Meetei Mayek Virama ..Meetei Mayek Virama + (0xabe5, 0xabe5), -- Meetei Mayek Vowel Sign ..Meetei Mayek Vowel Sign + (0xabe8, 0xabe8), -- Meetei Mayek Vowel Sign ..Meetei Mayek Vowel Sign + (0xabed, 0xabed), -- Meetei Mayek Apun Iyek ..Meetei Mayek Apun Iyek + (0xfb1e, 0xfb1e), -- Hebrew Point Judeo-spani..Hebrew Point Judeo-spani + (0xfe00, 0xfe0f), -- Variation Selector-1 ..Variation Selector-16 + (0xfe20, 0xfe2f), -- Combining Ligature Left ..Combining Cyrillic Titlo + (0x101fd, 0x101fd), -- Phaistos Disc Sign Combi..Phaistos Disc Sign Combi + (0x102e0, 0x102e0), -- Coptic Epact Thousands M..Coptic Epact Thousands M + (0x10376, 0x1037a), -- Combining Old Permic Let..Combining Old Permic Let + (0x10a01, 0x10a03), -- Kharoshthi Vowel Sign I ..Kharoshthi Vowel Sign Vo + (0x10a05, 0x10a06), -- Kharoshthi Vowel Sign E ..Kharoshthi Vowel Sign O + (0x10a0c, 0x10a0f), -- Kharoshthi Vowel Length ..Kharoshthi Sign Visarga + (0x10a38, 0x10a3a), -- Kharoshthi Sign Bar Abov..Kharoshthi Sign Dot Belo + (0x10a3f, 0x10a3f), -- Kharoshthi Virama ..Kharoshthi Virama + (0x10ae5, 0x10ae6), -- Manichaean Abbreviation ..Manichaean Abbreviation + (0x11001, 0x11001), -- Brahmi Sign Anusvara ..Brahmi Sign Anusvara + (0x11038, 0x11046), -- Brahmi Vowel Sign Aa ..Brahmi Virama + (0x1107f, 0x11081), -- Brahmi Number Joiner ..Kaithi Sign Anusvara + (0x110b3, 0x110b6), -- Kaithi Vowel Sign U ..Kaithi Vowel Sign Ai + (0x110b9, 0x110ba), -- Kaithi Sign Virama ..Kaithi Sign Nukta + (0x11100, 0x11102), -- Chakma Sign Candrabindu ..Chakma Sign Visarga + (0x11127, 0x1112b), -- Chakma Vowel Sign A ..Chakma Vowel Sign Uu + (0x1112d, 0x11134), -- Chakma Vowel Sign Ai ..Chakma Maayyaa + (0x11173, 0x11173), -- Mahajani Sign Nukta ..Mahajani Sign Nukta + (0x11180, 0x11181), -- Sharada Sign Candrabindu..Sharada Sign Anusvara + (0x111b6, 0x111be), -- Sharada Vowel Sign U ..Sharada Vowel Sign O + (0x111ca, 0x111cc), -- Sharada Sign Nukta ..Sharada Extra Short Vowe + (0x1122f, 0x11231), -- Khojki Vowel Sign U ..Khojki Vowel Sign Ai + (0x11234, 0x11234), -- Khojki Sign Anusvara ..Khojki Sign Anusvara + (0x11236, 0x11237), -- Khojki Sign Nukta ..Khojki Sign Shadda + (0x1123e, 0x1123e), -- (nil) .. + (0x112df, 0x112df), -- Khudawadi Sign Anusvara ..Khudawadi Sign Anusvara + (0x112e3, 0x112ea), -- Khudawadi Vowel Sign U ..Khudawadi Sign Virama + (0x11300, 0x11301), -- Grantha Sign Combining A..Grantha Sign Candrabindu + (0x1133c, 0x1133c), -- Grantha Sign Nukta ..Grantha Sign Nukta + (0x11340, 0x11340), -- Grantha Vowel Sign Ii ..Grantha Vowel Sign Ii + (0x11366, 0x1136c), -- Combining Grantha Digit ..Combining Grantha Digit + (0x11370, 0x11374), -- Combining Grantha Letter..Combining Grantha Letter + (0x11438, 0x1143f), -- (nil) .. + (0x11442, 0x11444), -- (nil) .. + (0x11446, 0x11446), -- (nil) .. + (0x114b3, 0x114b8), -- Tirhuta Vowel Sign U ..Tirhuta Vowel Sign Vocal + (0x114ba, 0x114ba), -- Tirhuta Vowel Sign Short..Tirhuta Vowel Sign Short + (0x114bf, 0x114c0), -- Tirhuta Sign Candrabindu..Tirhuta Sign Anusvara + (0x114c2, 0x114c3), -- Tirhuta Sign Virama ..Tirhuta Sign Nukta + (0x115b2, 0x115b5), -- Siddham Vowel Sign U ..Siddham Vowel Sign Vocal + (0x115bc, 0x115bd), -- Siddham Sign Candrabindu..Siddham Sign Anusvara + (0x115bf, 0x115c0), -- Siddham Sign Virama ..Siddham Sign Nukta + (0x115dc, 0x115dd), -- Siddham Vowel Sign Alter..Siddham Vowel Sign Alter + (0x11633, 0x1163a), -- Modi Vowel Sign U ..Modi Vowel Sign Ai + (0x1163d, 0x1163d), -- Modi Sign Anusvara ..Modi Sign Anusvara + (0x1163f, 0x11640), -- Modi Sign Virama ..Modi Sign Ardhacandra + (0x116ab, 0x116ab), -- Takri Sign Anusvara ..Takri Sign Anusvara + (0x116ad, 0x116ad), -- Takri Vowel Sign Aa ..Takri Vowel Sign Aa + (0x116b0, 0x116b5), -- Takri Vowel Sign U ..Takri Vowel Sign Au + (0x116b7, 0x116b7), -- Takri Sign Nukta ..Takri Sign Nukta + (0x1171d, 0x1171f), -- Ahom Consonant Sign Medi..Ahom Consonant Sign Medi + (0x11722, 0x11725), -- Ahom Vowel Sign I ..Ahom Vowel Sign Uu + (0x11727, 0x1172b), -- Ahom Vowel Sign Aw ..Ahom Sign Killer + (0x11c30, 0x11c36), -- (nil) .. + (0x11c38, 0x11c3d), -- (nil) .. + (0x11c3f, 0x11c3f), -- (nil) .. + (0x11c92, 0x11ca7), -- (nil) .. + (0x11caa, 0x11cb0), -- (nil) .. + (0x11cb2, 0x11cb3), -- (nil) .. + (0x11cb5, 0x11cb6), -- (nil) .. + (0x16af0, 0x16af4), -- Bassa Vah Combining High..Bassa Vah Combining High + (0x16b30, 0x16b36), -- Pahawh Hmong Mark Cim Tu..Pahawh Hmong Mark Cim Ta + (0x16f8f, 0x16f92), -- Miao Tone Right ..Miao Tone Below + (0x1bc9d, 0x1bc9e), -- Duployan Thick Letter Se..Duployan Double Mark + (0x1d167, 0x1d169), -- Musical Symbol Combining..Musical Symbol Combining + (0x1d17b, 0x1d182), -- Musical Symbol Combining..Musical Symbol Combining + (0x1d185, 0x1d18b), -- Musical Symbol Combining..Musical Symbol Combining + (0x1d1aa, 0x1d1ad), -- Musical Symbol Combining..Musical Symbol Combining + (0x1d242, 0x1d244), -- Combining Greek Musical ..Combining Greek Musical + (0x1da00, 0x1da36), -- Signwriting Head Rim ..Signwriting Air Sucking + (0x1da3b, 0x1da6c), -- Signwriting Mouth Closed..Signwriting Excitement + (0x1da75, 0x1da75), -- Signwriting Upper Body T..Signwriting Upper Body T + (0x1da84, 0x1da84), -- Signwriting Location Hea..Signwriting Location Hea + (0x1da9b, 0x1da9f), -- Signwriting Fill Modifie..Signwriting Fill Modifie + (0x1daa1, 0x1daaf), -- Signwriting Rotation Mod..Signwriting Rotation Mod + (0x1e000, 0x1e006), -- (nil) .. + (0x1e008, 0x1e018), -- (nil) .. + (0x1e01b, 0x1e021), -- (nil) .. + (0x1e023, 0x1e024), -- (nil) .. + (0x1e026, 0x1e02a), -- (nil) .. + (0x1e8d0, 0x1e8d6), -- Mende Kikakui Combining ..Mende Kikakui Combining + (0x1e944, 0x1e94a), -- (nil) .. + (0xe0100, 0xe01ef) -- Variation Selector-17 ..Variation Selector-256 + ] + + +basicZero :: RangeSet Int +basicZero = foldr insertRange empty [ + (0, 0), + (0x034f, 0x034f), + (0x200b, 0x200f), + (0x2028, 0x2029), + (0x202a, 0x202e), + (0x2060, 0x2063) + ] + +ctrlChars :: RangeSet Int +ctrlChars = foldr insertRange empty [ + (1, 32), + (0x07f, 0x09F) + ] + +wcwidth :: Char -> Int +wcwidth c | queryPoint v basicZero = 0 + | queryPoint v ctrlChars = -1 + | queryPoint v wIDEEASTASIAN = 2 + | queryPoint v zEROWIDTH = 0 + | otherwise = 1 + where v = ord c diff --git a/test/Client/Simple.hs b/test/Client/Simple.hs --- a/test/Client/Simple.hs +++ b/test/Client/Simple.hs @@ -3,11 +3,14 @@ import System.Exit import ProjectM36.Relation import qualified ProjectM36.Client as C +import ProjectM36.DateExamples +import ProjectM36.DatabaseContext import System.IO.Temp import System.FilePath import ProjectM36.TupleSet import ProjectM36.Attribute import qualified Data.Vector as V +import qualified Data.Map as M main :: IO () main = do @@ -15,7 +18,7 @@ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess testList :: Test -testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure] +testList = TestList [testSimpleCommitSuccess, testSimpleCommitFailure, testSimpleUpdate] assertEither :: (Show a) => IO (Either a b) -> IO b assertEither x = do @@ -45,6 +48,7 @@ eRes <- C.executeRelationalExpr sess conn relExpr assertEqual "x and y" (Right relationTrue) eRes + testSimpleCommitFailure :: Test testSimpleCommitFailure = TestCase $ do let failAttrs = attributesFromList [Attribute "fail" IntAtomType] @@ -55,13 +59,15 @@ execute $ Assign "x" (ExistingRelation relationTrue) --cause error execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet) - let expectedErr = Left (RelError (RelVarAssignmentTypeMismatchError V.empty failAttrs)) + let expectedErr = Left (RelError (RelationTypeMismatchError V.empty failAttrs)) assertEqual "dbc error" expectedErr err - - - - - - - +-- #176 default merge couldn't handle Update +testSimpleUpdate :: Test +testSimpleUpdate = TestCase $ do + let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] + dbconn <- assertEither (simpleConnectProjectM36 connInfo) + assertEither $ withTransaction dbconn $ + execute $ databaseContextAsDatabaseContextExpr dateExamples + assertEither $ withTransaction dbconn $ + execute $ Update "s" (M.singleton "sname" (C.NakedAtomExpr (C.TextAtom "Blakey"))) (C.AttributeEqualityPredicate "sname" (C.NakedAtomExpr (C.TextAtom "Blake"))) diff --git a/test/Relation/Basic.hs b/test/Relation/Basic.hs --- a/test/Relation/Basic.hs +++ b/test/Relation/Basic.hs @@ -3,6 +3,8 @@ import ProjectM36.Relation import ProjectM36.Error import ProjectM36.DateExamples +import ProjectM36.TupleSet +import ProjectM36.Attribute hiding (null, attributeNames) import ProjectM36.DataTypes.Primitive import ProjectM36.RelationalExpression import ProjectM36.Tuple @@ -22,7 +24,9 @@ testRelation "suppliers" suppliersRel, testRelation "products" productsRel, testRelation "supplierProducts" supplierProductsRel, - testMkRelationFromExprsBadAttrs] + testMkRelationFromExprsBadAttrs, + testDuplicateAttributes + ] main :: IO () main = do @@ -93,3 +97,10 @@ case runReader (evalRelationalExpr (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))])) (mkRelationalExprState context) of Left err -> assertEqual "tuple type mismatch" (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "badAttr2" IntAtomType])) err Right _ -> assertFailure "expected tuple type mismatch" + +--creating an empty relation with duplicate attribute names should fail +testDuplicateAttributes :: Test +testDuplicateAttributes = TestCase $ do + let eRel = mkRelation attrs emptyTupleSet + attrs = attributesFromList [Attribute "a" IntAtomType, Attribute "a" TextAtomType] + assertEqual "duplicate attribute names" (Left (DuplicateAttributeNamesError (S.singleton "a"))) eRel diff --git a/test/Relation/Export/CSV.hs b/test/Relation/Export/CSV.hs --- a/test/Relation/Export/CSV.hs +++ b/test/Relation/Export/CSV.hs @@ -57,7 +57,7 @@ Attribute "bytestringattr" ByteStringAtomType, Attribute "listintegerattr" (listAtomType IntegerAtomType), Attribute "listtextattr" (listAtomType TextAtomType), - Attribute "intervalattr" (IntervalAtomType DateTimeAtomType) + Attribute "intervalattr" (intervalAtomType DateTimeAtomType) ] sampleByteString = "\1\0\244\34\150" relOrErr = mkRelationFromList attrs [ @@ -70,7 +70,7 @@ listCons TextAtomType [TextAtom "text1", TextAtom "text2"], testInterval ], - [TextAtom "second text atom", + [TextAtom "second text atom with 漢字", IntegerAtom 314, DayAtom (fromGregorian 1001 6 28), DateTimeAtom (addUTCTime 360 now), @@ -85,7 +85,7 @@ Right rel -> case relationAsCSV rel of Left err -> assertFailure $ "export failed: " ++ show err - Right csvData -> + Right csvData -> --BS.writeFile "/tmp/csv" csvData --putStrLn (TL.unpack (TE.decodeUtf8 csvData)) case csvAsRelation attrs basicTypeConstructorMapping csvData of -- import csv data back to relation diff --git a/test/Relation/StaticOptimizer.hs b/test/Relation/StaticOptimizer.hs --- a/test/Relation/StaticOptimizer.hs +++ b/test/Relation/StaticOptimizer.hs @@ -2,19 +2,25 @@ import ProjectM36.Relation import ProjectM36.RelationalExpression import ProjectM36.DateExamples +import ProjectM36.Error import ProjectM36.TupleSet import ProjectM36.StaticOptimizer import System.Exit import Control.Monad.State import Control.Monad.Trans.Reader import Test.HUnit +import qualified Data.Set as S main :: IO () main = do tcounts <- runTestTT (TestList tests) if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess where - tests = relationOptTests ++ databaseOptTests + tests = relationOptTests ++ databaseOptTests ++ [testTransitiveOptimization, + testImpossiblePredicates, + testJoinElimination, + testRestrictionPredicateCollapse, + testPushDownRestrictionPredicate] optDBCTest = map (\(name, expr, unopt) -> TestCase $ assertEqual name expr (evalState (applyStaticDatabaseOptimization unopt) (freshDatabaseState dateExamples))) relvar nam = RelationVariable nam () startState = mkRelationalExprState dateExamples @@ -22,9 +28,7 @@ relationOptTests = optRelTest [ ("StaticProject", Right $ relvar "s", Project (AttributeNames (attributeNames suppliersRel)) (relvar "s")), ("StaticUnion", Right $ relvar "s", Union (relvar "s") (relvar "s")), - ("StaticJoin", Right $ relvar "s", Join (relvar "s") (relvar "s")), - ("StaticRestrictTrue", Right $ relvar "s", Restrict TruePredicate (relvar "s")), - ("StaticRestrictFalse", Right $ MakeStaticRelation (attributes suppliersRel) emptyTupleSet, Restrict (NotPredicate TruePredicate) (relvar "s")) + ("StaticJoin", Right $ relvar "s", Join (relvar "s") (relvar "s")) ] databaseOptTests = optDBCTest [ ("StaticAssign", @@ -37,3 +41,106 @@ MultipleExpr [Assign "z" (Restrict TruePredicate (relvar "s")), Assign "z" (Restrict TruePredicate (relvar "s"))]) ] + +testTransitiveOptimization :: Test +testTransitiveOptimization = TestCase $ do + let expr atomexpr = AndPredicate (AttributeEqualityPredicate "a" (NakedAtomExpr (IntegerAtom 300))) (AttributeEqualityPredicate "b" atomexpr) + exprIn = expr (AttributeAtomExpr "a") + exprOut = expr (NakedAtomExpr (IntegerAtom 300)) + assertEqual "transitive property" (Right exprOut) (runReader (applyStaticPredicateOptimization exprIn) (RelationalExprStateElems dateExamples)) + +optRelExpr :: RelationalExpr -> Either RelationalError RelationalExpr +optRelExpr expr = runReader (applyStaticRelationalOptimization expr) (RelationalExprStateElems dateExamples) + +testImpossiblePredicates :: Test +testImpossiblePredicates = TestCase $ do + let tautTrue = Restrict (AtomExprPredicate (NakedAtomExpr (BoolAtom True))) rel + tautTrue2 = Restrict TruePredicate rel + tautFalse = Restrict (AtomExprPredicate (NakedAtomExpr (BoolAtom False))) rel + tautFalse2 = Restrict (NotPredicate TruePredicate) rel + emptyRel = MakeStaticRelation (attributes suppliersRel) emptyTupleSet + rel = RelationVariable "s" () + assertEqual "remove tautology where true" (Right rel) (optRelExpr tautTrue) + assertEqual "remove tautology where true2" (Right rel) (optRelExpr tautTrue2) + assertEqual "remove tautology where false" (Right emptyRel) (optRelExpr tautFalse) + assertEqual "remove tautology where false2" (Right emptyRel) (optRelExpr tautFalse2) + +optJoinExpr :: RelationalExpr -> Either RelationalError RelationalExpr +optJoinExpr expr = runReader (applyStaticJoinElimination expr) (RelationalExprStateElems dateExamples) + +testJoinElimination :: Test +testJoinElimination = TestCase $ do + -- (s join sp){s#,qty,p#} == sp + let unoptExpr = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ())) + assertEqual "remove extraneous join" (Right (RelationVariable "sp" ())) (optJoinExpr unoptExpr) + +-- (sp join s){s#,qty,p#} == sp --flip relvar names + let unoptExpr2 = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (RelationVariable "s" ()) (RelationVariable "sp" ())) + assertEqual "remove extraneous join2" (Right (RelationVariable "sp" ())) (optJoinExpr unoptExpr2) + +-- (sp join s){s#,qty,sname} != sp - attribute from s included + let expr3 = Project (AttributeNames (S.fromList ["p#", "qty", "sname"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ())) + assertEqual "retain join" (Right expr3) (optJoinExpr expr3) + + -- (sp join s){qty} != sp --projection does not include foreign key attribute + let expr4 = Project (AttributeNames (S.singleton "qty")) (Join (RelationVariable "sp" ()) (RelationVariable "s" ())) + assertEqual "retain join2" (Right expr4) (optJoinExpr expr4) + + -- (sp join s){s#,qty} == sp - a subset of attributes in the projection are in the foreign key + let expr5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ())) + let expect5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (RelationVariable "sp" ()) + assertEqual "remove extraneous join (attribute subset)" (Right expect5) (optJoinExpr expr5) + + -- (s join p){s#,p#} != sp -- no foreign key + let expr6 = Project (AttributeNames (S.fromList ["s#", "p#"])) (Join (RelationVariable "s" ()) (RelationVariable "p" ())) + assertEqual "retain join- no foreign key" (Right expr6) (optJoinExpr expr6) + + -- (s join p){s#,qty,p#,sname} != sp -- all sp attributes plus one s attributes + let expr7 = Project (AttributeNames (S.fromList ["s#", "p#", "qty", "sname"])) (Join (RelationVariable "s" ()) (RelationVariable "sp" ())) + assertEqual "retain join- attributes from both relvars" (Right expr7) (optJoinExpr expr7) + +testRestrictionPredicateCollapse :: Test +testRestrictionPredicateCollapse = TestCase $ do + let expr1 = Restrict (NotPredicate TruePredicate) rv + rv = RelationVariable "a" () + assertEqual "one restriction" expr1 (applyStaticRestrictionCollapse expr1) + + let attrEqualsPred = AttributeEqualityPredicate "x" (NakedAtomExpr (IntAtom 3)) + expr2 = Restrict TruePredicate (Restrict attrEqualsPred (RelationVariable "a" ())) + assertEqual "two restrictions" (Restrict (AndPredicate TruePredicate attrEqualsPred) (RelationVariable "a" ())) (applyStaticRestrictionCollapse expr2) + + let expr3 = Restrict pred1 (Restrict pred2 (Restrict pred3 (RelationVariable "a" ()))) + pred1 = NotPredicate TruePredicate + pred2 = attrEqualsPred + pred3 = AtomExprPredicate (NakedAtomExpr (BoolAtom True)) + assertEqual "three restrictions" (Restrict (AndPredicate (AndPredicate pred1 pred3) pred2) rv) (applyStaticRestrictionCollapse expr3) + + let expr4 = Restrict pred1 (Restrict pred2 (Project projAttrs (Restrict pred3 (Restrict pred3 rv)))) + projAttrs = AttributeNames (S.singleton "spam") + expectedExpr = Restrict (AndPredicate pred1 pred2) (Project projAttrs (Restrict (AndPredicate pred3 pred3) rv)) + assertEqual "nested subexpr restrictions" expectedExpr (applyStaticRestrictionCollapse expr4) + +testPushDownRestrictionPredicate :: Test +testPushDownRestrictionPredicate = TestCase $ do + -- (s union relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}}) where status = 30 == (s where status=30) union (relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}} where status=30) + let rvs = RelationVariable "s" () + let status30 = AttributeEqualityPredicate "status" (NakedAtomExpr (IntAtom 30)) + relationsOrError = do + stevens <- mkRelationFromList (attributes suppliersRel) [[TextAtom "S6", TextAtom "Stevens", IntegerAtom 50, TextAtom "Boston"]] + let expectedExpr1 = Union (Restrict status30 rvs) (Restrict status30 (ExistingRelation stevens)) + expr1 = Restrict status30 (Union rvs (ExistingRelation stevens)) + + pure (expectedExpr1, applyStaticRestrictionPushdown expr1) + either (assertFailure . (++) "stevens relation: " . show) (uncurry $ assertEqual "union restriction pushdown") relationsOrError + + -- s{sname,city} where city="London" == (s where city="London"){sname,city} + let expr2 = Restrict whereLondon (Project projAttrs2 rvs) + projAttrs2 = AttributeNames (S.fromList ["sname", "city"]) + whereLondon = AttributeEqualityPredicate "city" (NakedAtomExpr (TextAtom "London")) + expectedExpr2 = Project projAttrs2 (Restrict whereLondon rvs) + assertEqual "projection restriction pushdown" expectedExpr2 (applyStaticRestrictionPushdown expr2) + + -- (s where city="London"){sname} != s{sname} where city="London" (no "city" attribute at projection time) + let expr3 = Project projAttrs3 (Restrict whereLondon rvs) + projAttrs3 = AttributeNames (S.singleton "sname") + assertEqual "projection restriction no-pushdown" expr3 (applyStaticRestrictionPushdown expr3) diff --git a/test/Relation/Tupleable.hs b/test/Relation/Tupleable.hs --- a/test/Relation/Tupleable.hs +++ b/test/Relation/Tupleable.hs @@ -3,6 +3,7 @@ import ProjectM36.Tupleable import ProjectM36.Atomable import ProjectM36.Attribute +import ProjectM36.Error import Data.Binary import ProjectM36.Base import Control.DeepSeq (NFData) @@ -10,6 +11,7 @@ import qualified Data.Vector as V import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Set as S import System.Exit import Data.Proxy @@ -48,6 +50,14 @@ data Test8T = Test8C deriving (Generic, Show, Eq) + +data Test9T = Test9C + { + attr9A :: Integer, + attr9B :: T.Text, + attr9C :: Double + } + deriving (Generic, Show, Eq) instance Tupleable Test1T @@ -65,20 +75,21 @@ instance Tupleable Test8T +instance Tupleable Test9T + main :: IO () main = do tcounts <- runTestTT testList if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess testList :: Test -testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8] +testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple] testADT1 :: Test testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example)) where example = Test1C {attrA = 3} - testADT2 :: Test testADT2 = TestCase $ do let example = Test2C { attrB = 4, attrC = 6 } @@ -116,4 +127,76 @@ testADT8 :: Test testADT8 = TestCase $ assertEqual "single value" (Right example) (fromTuple (toTuple example)) where - example = Test8C + example = Test8C + +testInsertExpr :: Test +testInsertExpr = TestCase $ assertEqual "insert expr" expected (toInsertExpr [Test9C { + attr9A = 4, + attr9B = "a", + attr9C = 3.4}] "rv") + where expected = Right (Insert "rv" (MakeStaticRelation attrs tuples)) + attrs = attributesFromList [Attribute "attr9A" IntegerAtomType, + Attribute "attr9B" TextAtomType, + Attribute "attr9C" DoubleAtomType] + tuples = RelationTupleSet [RelationTuple attrs (V.fromList [IntegerAtom 4, + TextAtom "a", + DoubleAtom 3.4])] + +testDefineExpr :: Test +testDefineExpr = TestCase $ assertEqual "define expr" expected actual + where + expected = Define "rv" (map NakedAttributeExpr attrs) + attrs = [Attribute "attr9A" IntegerAtomType, + Attribute "attr9B" TextAtomType, + Attribute "attr9C" DoubleAtomType] + actual = toDefineExpr (Proxy :: Proxy Test9T) "rv" + +testUpdateExpr :: Test +testUpdateExpr = TestCase $ do + let expected = Right (Update "rv" updateMap restriction) + updateMap = M.fromList [("attr9B", NakedAtomExpr (TextAtom "b")), + ("attr9C", NakedAtomExpr (DoubleAtom 5.5))] + restriction = AttributeEqualityPredicate "attr9A" (NakedAtomExpr (IntegerAtom 5)) + actual = toUpdateExpr "rv" ["attr9A"] Test9C {attr9A = 5, + attr9B = "b", + attr9C = 5.5} + + assertEqual "update expr1" expected actual + +testUpdateExprEmptyAttrs :: Test +testUpdateExprEmptyAttrs = TestCase $ do + let expected = Left EmptyAttributesError + actual = toUpdateExpr "rv" [] Test9C {attr9A = 5, + attr9B = "b", + attr9C = 5.5} + assertEqual "update with empty attrs" expected actual + +testUpdateExprWrongAttr :: Test +testUpdateExprWrongAttr = TestCase $ do + --currently, passing in the wrong attribute replaces the whole relvar with a single tuple- is this what we want? + let expected = Left (NoSuchAttributeNamesError (S.singleton "nonexistentattr")) + actual = toUpdateExpr "rv" ["nonexistentattr"] Test9C {attr9A = 5, + attr9B = "b", + attr9C = 5.5} + assertEqual "update with wrong attr" expected actual + +testDeleteExpr :: Test +testDeleteExpr = TestCase $ do + let expected = Right (Delete "rv" (AndPredicate (AttributeEqualityPredicate "attr9A" + (NakedAtomExpr (IntegerAtom 5))) + (AttributeEqualityPredicate "attr9B" + (NakedAtomExpr (TextAtom "b"))))) + actual = toDeleteExpr "rv" ["attr9A", "attr9B"] Test9C {attr9A = 5, + attr9B = "b", + attr9C = 5.5} + assertEqual "delete expr" expected actual + +--discovered in #184 by ruhatch +testReorderedTuple :: Test +testReorderedTuple = TestCase $ do + let tupleRev :: RelationTuple -> RelationTuple + tupleRev (RelationTuple v1 v2) = RelationTuple (V.reverse v1) (V.reverse v2) + expected = Test2C {attrB = 3, + attrC = 4} + actual = fromTuple . tupleRev . toTuple $ expected + assertEqual "reordered tuple" (Right expected) actual diff --git a/test/Server/Main.hs b/test/Server/Main.hs --- a/test/Server/Main.hs +++ b/test/Server/Main.hs @@ -20,7 +20,8 @@ import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress) import Data.Either (isRight) import Control.Exception ---import Control.Monad.IO.Class +import System.IO.Temp +import System.FilePath #if defined(linux_HOST_OS) import System.Directory #endif @@ -43,7 +44,7 @@ testNotification notificationTestMVar ] serverTests = [testRequestTimeout, testFileDescriptorCount] - + main :: IO () main = do (serverAddress, _) <- launchTestServer 0 @@ -80,13 +81,17 @@ -- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread launchTestServer :: Timeout -> IO (EndPointAddress, ThreadId) launchTestServer ti = do - let config = defaultServerConfig { databaseName = testDatabaseName, - perRequestTimeout = ti, - testMode = True, - bindPort = 0 - } addressMVar <- newEmptyMVar - tid <- forkIO $ launchServer config (Just addressMVar) >> pure () + tid <- forkIO $ + withSystemTempDirectory "projectm36test" $ \tempdir -> do + let config = defaultServerConfig { databaseName = testDatabaseName, + persistenceStrategy = CrashSafePersistence (tempdir "db"), + perRequestTimeout = ti, + testMode = True, + bindPort = 0 + } + + launchServer config (Just addressMVar) >> pure () endPointAddress <- takeMVar addressMVar --liftIO $ putStrLn ("launched server on " ++ show endPointAddress) pure (endPointAddress, tid) @@ -212,19 +217,24 @@ --validate that creating a server, connecting a client, and then disconnecting doesn't leak file descriptors testFileDescriptorCount = TestCase $ do (serverAddress, serverTid) <- launchTestServer 1000 - startCount <- fdCount unusedMVar <- newEmptyMVar - Right (_, testConn) <- testConnection serverAddress unusedMVar + startCount <- fdCount + Right (sess, testConn) <- testConnection serverAddress unusedMVar + --add a test commit to trigger the fsync machinery + executeDatabaseContextExpr sess testConn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail + commit sess testConn >>= eitherFail close testConn endCount <- fdCount - assertEqual "fd leak" startCount endCount + let fd_diff = endCount - startCount + assertBool ("fd leak: " ++ show fd_diff) (fd_diff <= 0) killThread serverTid + -- returns the number of open file descriptors -- linux only /proc usage fdCount :: IO Int fdCount = do fds <- getDirectoryContents "/proc/self/fd" - pure ((length fds) - 2) + pure (length fds) #else --pass on non-linux platforms testFileDescriptorCount = TestCase (pure ()) diff --git a/test/Server/WebSocket.hs b/test/Server/WebSocket.hs --- a/test/Server/WebSocket.hs +++ b/test/Server/WebSocket.hs @@ -5,6 +5,8 @@ import ProjectM36.Server.Config import ProjectM36.Server import ProjectM36.Client +import ProjectM36.Base + import Network.Socket import Control.Exception import Control.Concurrent @@ -12,7 +14,6 @@ import Data.Typeable import Data.Text hiding (map) import Data.Aeson -import ProjectM36.Base import qualified Data.Map as M import qualified Data.ByteString.Lazy as BS import ProjectM36.Relation @@ -90,14 +91,16 @@ testtutd conn = do discardPromptInfo conn - WS.sendTextData conn ("executetutd:" `append` ":showexpr true") + WS.sendTextData conn ("executetutd/json:" `append` ":showexpr true") discardPromptInfo conn discardPromptInfo conn --receive relation response response <- WS.receiveData conn :: IO BS.ByteString - let decoded = decode response :: Maybe (M.Map Text Relation) - - case decoded of - Just val -> assertEqual "round-trip true relation" (M.lookup "displayrelation" val) (Just relationTrue) >> WS.sendClose conn ("test close"::Text) - Nothing -> assertFailure ("failed to decode relation from: " ++ show response) + let decoded = decode response :: Maybe (M.Map Text (M.Map Text Relation)) + case decoded of + Nothing -> assertFailure "failed to decode" + Just decoded' -> do + assertEqual "round-trip true relation" ((decoded' M.! "displayrelation") M.! "json") relationTrue + WS.sendClose conn ("test close" :: Text) + diff --git a/test/TransactionGraph/Merge.hs b/test/TransactionGraph/Merge.hs --- a/test/TransactionGraph/Merge.hs +++ b/test/TransactionGraph/Merge.hs @@ -21,7 +21,7 @@ import Data.Time.Clock import Data.Time.Calendar -import Control.Monad.State hiding (join) +import Control.Monad.State {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} @@ -122,8 +122,8 @@ -- add another relvar to branchB branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head" (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of - (Just err, _) -> assertFailure (show err) >> undefined - (Nothing, context) -> pure context + (Left err, _) -> assertFailure (show err) >> undefined + (Right (), context) -> pure context (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head" assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans') @@ -149,8 +149,8 @@ -- add another relvar to branchB branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head" (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of - (Just err, _) -> assertFailure (show err) >> undefined - (Nothing, context) -> pure context + (Left err, _) -> assertFailure (show err) >> undefined + (Right (), context) -> pure context (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph --create the merge transaction in the graph let eGraph' = mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph' diff --git a/test/TransactionGraph/Persist.hs b/test/TransactionGraph/Persist.hs --- a/test/TransactionGraph/Persist.hs +++ b/test/TransactionGraph/Persist.hs @@ -77,22 +77,28 @@ testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do let dbdir = tempdir "dbdir" connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback [] - Right conn <- connectProjectM36 connInfo - Right sess <- createSessionAtHead conn "master" + conn <- assertIOEither $ connectProjectM36 connInfo + sess <- assertIOEither $ createSessionAtHead conn "master" let intTCons = PrimitiveTypeConstructor "Int" IntAtomType addfunc = AddAtomFunction "testdisk" [ intTCons, ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [], intTCons]] "(\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom" - Right () <- executeDatabaseContextIOExpr sess conn addfunc - Right () <- commit sess conn + _ <- assertIOEither $ executeDatabaseContextIOExpr sess conn addfunc + + _ <- assertIOEither $ commit sess conn close conn --re-open the connection to reload the graph - Right conn2 <- connectProjectM36 connInfo - Right sess2 <- createSessionAtHead conn2 "master" + conn2 <- assertIOEither $ connectProjectM36 connInfo + sess2 <- assertIOEither $ createSessionAtHead conn2 "master" res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))]) let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]] assertEqual "testdisk dbc function run" expectedRel res - +assertIOEither :: (Show a) => IO (Either a b) -> IO b +assertIOEither x = do + ret <- x + case ret of + Left err -> assertFailure (show err) >> undefined + Right val -> pure val diff --git a/test/TutorialD/Interpreter.hs b/test/TutorialD/Interpreter.hs --- a/test/TutorialD/Interpreter.hs +++ b/test/TutorialD/Interpreter.hs @@ -10,6 +10,7 @@ import ProjectM36.DatabaseContext import ProjectM36.AtomFunctions.Primitive import ProjectM36.DataTypes.Either +import ProjectM36.DataTypes.Interval import ProjectM36.DateExamples import ProjectM36.Base hiding (Finite) import ProjectM36.TransactionGraph @@ -29,20 +30,22 @@ import qualified Data.Text as T import Data.Time.Clock.POSIX hiding (getCurrentTime) import Data.Time.Clock (getCurrentTime) +import Data.Time.Calendar (fromGregorian) main :: IO () main = do tcounts <- runTestTT (TestList tests) if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess where - tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [ + tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ + map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [ transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, - testNotification, + testNotification, testTypeConstructors, testMergeTransactions, testComments, @@ -55,7 +58,16 @@ testEmptyCommits, testIntervalAtom, testListConstructedAtom, - testTypeChecker + testTypeChecker, + testRestrictionPredicateExprs, + testRelationalAttributeNames, + testSemijoin, + testAntijoin, + testRelationAttributeDefinition, + testAssignWithTypeVar, + testDefineWithTypeVar, + testIntervalType, + testArbitraryRelation ] simpleRelTests = [("x:=true", Right relationTrue), ("x:=false", Right relationFalse), @@ -76,11 +88,13 @@ ("x:=true where true or false", Right relationTrue), ("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 true", Right relationTrue), ("x:=true=true", Right relationTrue), ("x:=true=false", Right relationFalse), ("x:=true; undefine x", Left (RelVarNotDefinedError "x")), - ("x:=relation {b Integer, a Text}{}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList [TextAtom "spam", IntegerAtom 5]]), + ("x:=relation {b Integer, a Text}{}; insert x relation{tuple{b -5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList [TextAtom "spam", IntegerAtom (-5)]]), -- test nested relation constructor ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [IntegerAtom 5, RelationAtom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [IntegerAtom 6]])])]), ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntegerAtom 5])]), @@ -149,7 +163,9 @@ ("x:=relation{tuple{a Left 3}}", Left (TypeConstructorTypeVarsMismatch (S.fromList ["a","b"]) (S.fromList ["a"]))), -- Left 3, alone is not enough information to imply the type ("x:=relation{a Either Integer Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntegerAtomType TextAtomType) [IntegerAtom 3]]]), --test datetime constructor - ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]]) + ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]]), + --test Day constructor + ("x:=relation{tuple{a fromGregorian(2017,05,30)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DayAtomType]) [[DayAtom (fromGregorian 2017 05 30)]]) ] assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion @@ -487,3 +503,88 @@ let err1 = "AtomFunctionTypeError \"max\" 1 (RelationAtomType [Attribute \"_\" IntegerAtomType]) IntegerAtomType" expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 0}}:{b:=max(@a)}" +--exercise expression parser +testRestrictionPredicateExprs :: Test +testRestrictionPredicateExprs = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + -- or + executeTutorialD sessionId dbconn "x:=s where status=20 or status=10" + eRvOr <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) + let expectedRelOr = restrict (\tuple -> + pure (atomForAttributeName "status" tuple `elem` [Right (IntegerAtom 10), Right (IntegerAtom 20)])) suppliersRel + assertEqual "status 20 or 10" expectedRelOr eRvOr + -- and + executeTutorialD sessionId dbconn "x:=s where status=20 and status=10" + eRvAnd <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) + let expectedRelAnd = Right (emptyRelationWithAttrs (attributes suppliersRel)) + assertEqual "status 20 and 10" expectedRelAnd eRvAnd + +testRelationalAttributeNames :: Test +testRelationalAttributeNames = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD sessionId dbconn "x:=(s join sp){all from sp}" + eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) + case eRv of + Left err -> assertFailure (show err) + Right rel -> + assertEqual "attributes from sp" (attributes supplierProductsRel) (attributes rel) + +testSemijoin :: Test +testSemijoin = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD sessionId dbconn "x:=s semijoin sp" + executeTutorialD sessionId dbconn "y:=s where not (sname = \"Adams\")" + eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) + eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ()) + assertEqual "semijoin missing Adams" eX eY + +testAntijoin :: Test +testAntijoin = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD sessionId dbconn "x:=s antijoin sp" + executeTutorialD sessionId dbconn "y:=s where sname = \"Adams\"" + eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) + eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ()) + assertEqual "antijoin only Adams" eX eY + +testRelationAttributeDefinition :: Test +testRelationAttributeDefinition = TestCase $ do + -- test normal subrelation construction + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD sessionId dbconn "x:=relation{a relation{b Integer}}{tuple{a relation{tuple{b 4}}}}" + eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) + let expected = mkRelationFromList attrs [[RelationAtom subRel]] + attrs = attributesFromList [Attribute "a" (RelationAtomType subRelAttrs)] + subRelAttrs = attributesFromList [Attribute "b" IntegerAtomType] + Right subRel = mkRelationFromList subRelAttrs [[IntegerAtom 4]] + assertEqual "relation attribute construction" expected eX + -- test rejected subrelation construction due to floating type variables + expectTutorialDErr sessionId dbconn (T.isPrefixOf "TypeConstructorTypeVarMissing") "y:=relation{a relation{b x}}" + +testAssignWithTypeVar :: Test +testAssignWithTypeVar = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + let err1 = "TypeConstructorTypeVarMissing" + expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "y:=relation{a int, b invalidtype}" + +testDefineWithTypeVar :: Test +testDefineWithTypeVar = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + let err1 = "TypeConstructorTypeVarMissing" + expectTutorialDErr sessionId dbconn (T.isInfixOf err1) "y::{a int, b invalidtype}" + +testIntervalType :: Test +testIntervalType = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD sessionId dbconn "x:=relation{a Interval Integer}" + eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ()) + let expectedIntervalInt = mkRelationFromList expectedAttrs [] + expectedAttrs = A.attributesFromList [Attribute "a" (intervalAtomType IntegerAtomType)] + assertEqual "Interval Int attribute" expectedIntervalInt eX + +testArbitraryRelation :: Test +testArbitraryRelation = TestCase $ do + (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback + executeTutorialD sessionId dbconn "createarbitraryrelation rv1 {a Integer} 5-10" + executeTutorialD sessionId dbconn "createarbitraryrelation rv2 {a Integer, b relation{c Integer}} 10-100" + executeTutorialD sessionId dbconn "createarbitraryrelation rv3 {a Int, b relation{c Interval Int}} 3-100" diff --git a/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs b/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs --- a/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs +++ b/test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs @@ -14,9 +14,6 @@ ]) if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess -{- -adddatabasecontextfunction "addtruerv" DatabaseContext -> DatabaseContext """(\[] ctx -> execState (evalDatabaseContextExpr (Assign "true2" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext""" --} testBasicDBCFunction :: Test testBasicDBCFunction = TestCase $ do (sess, conn) <- dateExamplesConnection emptyNotificationCallback @@ -43,9 +40,6 @@ expectTutorialDErr sess conn (\err -> "UnhandledExceptionError" `T.isPrefixOf` err) "execute bomb()" -{- -adddatabasecontextfunction "multiArgFunc" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> execState (evalDatabaseContextExpr (Assign "person" (MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name), ("age", NakedAtomExpr age)])]))) ctx)""" --} testDBCFunctionWithAtomArguments :: Test testDBCFunctionWithAtomArguments = TestCase $ do --test function with creation of a relvar with some arguments @@ -60,7 +54,4 @@ assertEqual "person relation" expectedPerson result expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")" -{- -adddatabasecontextfunction "addperson" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> let newrel = MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", name),("age",age))]] in if isRight (runState (executeRelationalExpr (RelationVariable "person" ()) ctx)) then execState (executeContextExpr (Insert "person" newrel)) ctx else execState (executeContextExpr (Assign "person" newrel)) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext""" --} diff --git a/test/TutorialD/Interpreter/Import/TutorialD.hs b/test/TutorialD/Interpreter/Import/TutorialD.hs --- a/test/TutorialD/Interpreter/Import/TutorialD.hs +++ b/test/TutorialD/Interpreter/Import/TutorialD.hs @@ -5,6 +5,8 @@ import System.IO.Temp import qualified Data.Map as M import System.IO +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE main :: IO () main = do @@ -14,8 +16,14 @@ testTutdImport :: Test testTutdImport = TestCase $ withSystemTempFile "m.tutd" $ \tempPath handle -> do - hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}" + BS.hPut handle (TE.encodeUtf8 "x:=relation{tuple{a 5,b \"spam\"}}; y:=relation{tuple{b \"漢字\"}}") hClose handle - let expectedExpr = MultipleExpr [Assign "x" (MakeRelationFromExprs Nothing [TupleExpr (M.fromList [("a",NakedAtomExpr $ IntegerAtom 5),("b",NakedAtomExpr $ TextAtom "spam")])])] + let expectedExpr = MultipleExpr [ + Assign "x" (MakeRelationFromExprs Nothing + [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5), + ("b", NakedAtomExpr $ TextAtom "spam")])]), + Assign "y" (MakeRelationFromExprs Nothing + [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])] imported <- importTutorialD tempPath assertEqual "import tutd" (Right expectedExpr) imported +
" `append` atomToText (snd tup) `append` "" <> atomAsHTML (snd tup) <> "