packages feed

project-m36 0.9.0 → 0.9.4

raw patch · 84 files changed

+3082/−1885 lines, 84 filesdep +barbiesdep +base16-bytestringdep +convertibledep −vector-binary-instancesdep ~aesondep ~basedep ~megaparsecnew-component:exe:Example-Plantfarm

Dependencies added: barbies, base16-bytestring, convertible, http-conduit, modern-uri, recursion-schemes, streamly, wai, wai-websockets, warp, warp-tls

Dependencies removed: vector-binary-instances

Dependency ranges changed: aeson, base, megaparsec, text-manipulate

Files

Changelog.markdown view
@@ -1,3 +1,18 @@+# 2021-12-05 (v0.9.4)++* fix bug which [caused tuple storage to be duplicated unnecessarily](https://github.com/agentm/project-m36/pull/328)+* add support for `case` and `if-then-else` expressions+* allow relation variable names and attribute names to be escaped using backticks+* add UUID primitive type+* complete implementation of [object and shared object files at runtime](https://github.com/agentm/project-m36/blob/master/docs/atomfunctions.markdown#pre-compiled-atom-functions) in order to compete with Haskell scripting alternative+* fix constraint checking after undefining a relation variable+* optionally allow TLS and client certificate authentication in Project:M36 server+* require GHC >=8.8+	+# 2021-04-01 (v0.9.3)++* add new ":importtutd <URI> <SHA256 hash>" feature to import TutorialD from a local file or a HTTP/HTTPS URI	+	 # 2020-12-27 (v0.9.0)  * replace unmaintained distributed-process-client-server RPC package with new curryer RPC package
README.markdown view
@@ -4,7 +4,6 @@ [![Public Domain](https://img.shields.io/badge/license-Public%20Domain-brightgreen.svg)](http://unlicense.org) [![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) [![Github Workflow status](https://github.com/agentm/project-m36/workflows/CI/badge.svg)](https://github.com/agentm/project-m36/actions?query=workflow%3ACI) @@ -45,7 +44,7 @@  * [Developer's Blog](https://agentm.github.io/project-m36/) * [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36)-* IRC Channel: chat.freenode.net #project-m36+* IRC Channel: irc.libera.chat #project-m36 -- [Chat via Web Client](http://kiwiirc.com/nextclient/irc.libera.chat:+6697/#project-m36) * [Hackage](https://hackage.haskell.org/package/project-m36) * [Diogo Biazus' Project:M36 Video Tutorial](https://www.youtube.com/watch?v=_GC_lxlVEnE)
+ examples/Plantfarm.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE DeriveGeneric #-}++{-# LANGUAGE OverloadedStrings #-}++{-# LANGUAGE DeriveAnyClass #-}++{-# LANGUAGE DerivingVia #-}+++import Codec.Winery (Serialise, WineryVariant(WineryVariant))+import Control.DeepSeq (NFData)+import Data.Aeson (FromJSON, ToJSON(toEncoding, toJSON))+import Data.Data (Proxy(Proxy))+import Data.Either (lefts, rights)+import Data.Functor (($>))+import Data.Text as T (Text)+import qualified Data.Text.Lazy as TL (pack)+import GHC.Generics (Generic)+import qualified ProjectM36.Base as Base+import ProjectM36.Client+       ( AtomExprBase(NakedAtomExpr)+       , Atomable(toAddTypeExpr, toAtom)+       , AttributeName+       , Connection+       , ConnectionInfo(InProcessConnectionInfo)+       , DatabaseContextExpr+       , DatabaseContextExprBase(Delete)+       , PersistenceStrategy(NoPersistence)+       , RelationalError+       , RelationalExprBase(RelationVariable, Restrict)+       , RestrictionPredicateExprBase(AttributeEqualityPredicate)+       , SessionId+       , close+       , commit+       , connectProjectM36+       , createSessionAtHead+       , databaseContextExprForUniqueKey+       , defaultHeadName+       , emptyNotificationCallback+       , executeDatabaseContextExpr+       , executeRelationalExpr+       , withTransaction+       )+import qualified ProjectM36.Relation as Relation+import ProjectM36.Tupleable+       ( Tupleable(fromTuple)+       , toDefineExpr+       , toDeleteExpr+       , toInsertExpr+       , toUpdateExpr+       )+import qualified System.Random as R+++import Control.Monad.IO.Class (MonadIO(liftIO))+import qualified Web.Scotty as S++-- |    This is an example showcasing the updating of data+--      with the help of plants. \\+--      This is a very simple example and of course not how+--      plants grow in nature. \\+--      The main goal of this example is to showcase the updating+--      of data and the different options of persistence.+--      You can just pipe the output from curl into jq:+--+--      curl -X POST -H 'Accept: application/json' http://localhost:8001/plant/water/angu | jq -r '.stage'+++data Stage = Seed | Sprout | Seedling | Adult | Dead+    deriving (Show, Eq, Ord, Generic, NFData, Atomable)+    deriving Serialise via WineryVariant Stage+++instance ToJSON Stage where --  The where can be removed and the implementation commented out+                            --  if the ascii values are not wanted+  toJSON s = toJSON $ show s <> "\nascii only provided for visualisation:\n" <> stagetoAscii s++  toEncoding s = toEncoding $ show s <> "\nascii only provided for visualisation:\n" <> stagetoAscii s++instance FromJSON Stage++instance S.Parsable Stage where+  parseParam t+    | t == "seed" || t == "Seed" = Right Seed+    | t == "sprout" || t == "Sprout" = Right Sprout+    | t == "seedling" || t == "Seedling" = Right Seedling+    | t == "adult" || t == "Adult" = Right Adult+    | t == "dead" || t == "Dead" = Right Dead+    | otherwise = Left t+++-- Just for ToJSON for ilustration of stage+type ASCIIStage = String++seedStr :: ASCIIStage+seedStr = "<>\n\+          \'''\n"+sproutStr :: ASCIIStage+sproutStr = " ..\n\+            \<|>\n\+            \''''\n"+seedlingStr :: ASCIIStage+seedlingStr = " `\\⁄o \n\+              \ v|/\n\+              \'´;'''\n"+adultStr :: ASCIIStage+adultStr = "*~(#)~\n\+           \ \\,Y,e\n\+           \  \\|/\n\+           \''+'\\''\n"+deadStr :: ASCIIStage+deadStr = "  ,__:<\n\+          \'/'''''\n"++-- Just used for ToJSON illustration of stages+stagetoAscii :: Stage -> ASCIIStage+stagetoAscii Seed = seedStr+stagetoAscii Sprout = sproutStr+stagetoAscii Seedling = seedlingStr+stagetoAscii Adult = adultStr+stagetoAscii Dead = deadStr++-- used for update stage+next :: Stage -> Stage+next Seed     = Sprout+next Sprout   = Seedling+next Seedling = Adult+next s        = s++data Plant = Plant { name :: Text, species :: Text, stage :: Stage, waterings:: Integer } deriving (Show, Generic)+instance Tupleable Plant+instance ToJSON Plant+instance FromJSON Plant+++main :: IO ()+main = do+  putStrLn "Connecting to plant farm"+  c <- dbConnection+  _ <- createSchema c+  putStrLn "Planting some plants"+  _ <- insertSampleData c+  let port = 8001+  putStrLn $ "Started Plant farm at " <> show port+  S.scotty port $ do++    --  retrieve a plant by name+    S.get "/plant/:name" $ do+        n <- S.param "name"+        e <- liftIO $ getPlant c n+        p <- handleWebError e+        S.json p+++    --  save a plant providing it as json data+    S.post "/plant" $ do+        pl <- S.jsonData :: S.ActionM Plant+        e <- liftIO $ savePlant c [pl]+        p <- handleWebError e+        S.json p++    --  updating a plant providing it as json data+    S.put "/plant" $ do+        pl <- S.jsonData :: S.ActionM Plant+        e <- liftIO $ updatePlantFst c pl+        p <- handleWebError e+        S.json p++    --  watering the plant having the provided name.+    --  This will water the plant and might let it progress to the next stage. It might also die.+    S.post "/plant/water/:name" $ do+      n <- S.param "name"+      e <- liftIO $ waterPlant c n+      p <- handleWebError e+      S.json p++    --  retriving all the plants as json data+    S.get "/plants" $ do+      e <- liftIO $ getAllPlants c+      ps <- handleWebErrors e+      S.json ps++    --  saving many plants at the same time+    S.post "/plants" $ do+        pl <- S.jsonData :: S.ActionM [Plant]+        e <- liftIO $ savePlant c pl+        p <- handleWebError e+        S.json p++    --  deleting all plants at a specific stage+    S.delete "/plants?stage=:stage" $ do+      s <- S.param "stage"+      e <- liftIO $ deletePlantsByStage c s+      p <- handleWebError e+      S.json p++    --  deleting all plants at a specific stage+    S.delete "/plants" $ do+      s <- S.param "name"+      e <- liftIO $ deletePlantByName c s+      p <- handleWebError e+      S.json p++    --  deleting all dead plants+    S.delete "/plants/clear" $ do+      e <- liftIO $ clearDeadPlants c+      ps <- handleWebErrors e+      S.json ps++handleWebError :: Either Err b -> S.ActionM b+handleWebError (Left e) = S.raise (TL.pack $ "An error occurred:\n" <> show e)+handleWebError (Right v) = pure v++handleWebErrors :: [Either Err b] -> S.ActionM [b]+handleWebErrors e = do+  case lefts e of+    [] -> pure (rights e)+    l -> S.raise (TL.pack $ "Errors occurred:\n" <> concatMap ((<>"\n") . show) l)+++-- |    watering a plant and thereby possibly updating its stage+waterPlant :: DBConnection -> Text -> IO (Either Err Plant)+waterPlant db n = do+  p <- getPlant db n+  case p of+        Left e  -> pure $ Left e+        Right v -> updateStage db $ v { waterings = waterings v + 1 }++-- |    used by 'waterPlant' updates the stage depending on random numbers+updateStage :: DBConnection -> Plant ->  IO (Either Err Plant)+updateStage db p@(Plant _ _ Dead _ ) = do+  tmp <- updatePlantFst db p+  case tmp of+    Left e  -> pure $ Left e+    Right _ -> pure $ Right p+updateStage db p = do+  res <- calculateStage p+  tmp <- updatePlantFst db res+  case tmp of+    Left e  -> pure $ Left e+    Right _ -> pure $ Right res+  where calculateStage p' = do+          r1 <- R.randomRIO (1, 10) :: IO Integer+          let np = if r1 < waterings p' then p' { stage = next $ stage p', waterings = 0 } else p'+          r2 <- R.randomRIO (1, 20)+          pure $ if r2 < waterings np then np { stage = Dead, waterings = 0 } else np++-- |    deletes all plants with Stage = Dead+clearDeadPlants :: DBConnection -> IO [Either Err Plant]+clearDeadPlants db = do+  _ <- deletePlantsByStage db Dead+  getAllPlants db+++-- ****************************+-- |    *Database functions* :+-- ****************************+++-- |    Error type for passing. It is not very specific.+--      Just minimal and non optimal for this example.+data Err = NotSpecified | NotFound deriving (Show ,Generic)++instance ToJSON Err++-- |    Just for convinience for passing around the SessionId+--      and the Connection+data DBConnection = DB SessionId Connection+++-- |    Getting plants by their name.\+--      Because plant has name as primary key \+--      we can assume will get at most one result. \+--      Alternatively we could return a list.+getPlant :: DBConnection -> Text -> IO (Either Err Plant)+getPlant db n =  defaultHead (Left NotFound)  <$> (+    get db+    ( Restrict -- Restrict can be thought of as similar to "WITH" in SQL+      (AttributeEqualityPredicate "name" (NakedAtomExpr (toAtom n))) -- This is the Predicate we are "restricting" our RelationalExprBase with+      (RelationVariable "plants" ())+    )+    :: IO [Either Err Plant] -- this is needed because our 'get' function is+  )++defaultHead :: a -> [a] -> a+defaultHead d []    = d+defaultHead _ (x:_) = x++-- |    Getting all the plants+getAllPlants :: DBConnection -> IO [Either Err Plant]+getAllPlants db = get db (RelationVariable "plants" ())++-- |    Getting all the plants that satisfy the restrictions+getAllPlantsWith :: DBConnection -> Base.RestrictionPredicateExpr -> IO [Either Err Plant]+getAllPlantsWith db ex = get db (Restrict ex (RelationVariable "plants" ()))+++-- |    Saving a plant+savePlant :: (Traversable t) => DBConnection -> t Plant -> IO (Either Err ())+savePlant db sps = insert db sps "plants"++-- |    An alternative to update alone because due to updates+--      not being cached yet \+--      they have to be calculated every update. \+--      This seems like an alternative until caching is implemented.+updatePlantFst :: DBConnection -> Plant -> IO (Either Err ())+updatePlantFst db pln = do+  _ <- delete db pln ["name"] "plants"+  savePlant db [pln]++-- |    Updating a plant. Due to the way project 36 works, \+--      updates have to be executed every time.\+--      This is slow but won't be an issue soon because they will+--      be cached.\+--      But because of this project 36 can provide O(1) commits.+updatePlant :: DBConnection -> Plant -> IO (Either Err ())+updatePlant db sps = update+  db          -- db connection+  sps         -- plant value+  ["name"]   -- the attributes to be updated by (in case of unique key)+  "plants"    -- the relation we want to update on+++-- |    deleting all plants that have given name.+deletePlantByName :: DBConnection -> Text -> IO (Either Err ())+deletePlantByName db s = executeWithTransaction db $ Right $ Delete "plants" $ AttributeEqualityPredicate "name" (NakedAtomExpr (toAtom s))++-- |    deleting all plants that have given stage.+deletePlantsByStage :: DBConnection -> Stage -> IO (Either Err ())+deletePlantsByStage db s = executeWithTransaction db $ Right $ Delete "plants" $ AttributeEqualityPredicate "stage" (NakedAtomExpr (toAtom s))+++-- |    Inserting the schema into the DB+createSchema :: DBConnection -> IO ()+createSchema (DB sessionId conn) = do+  _ <- handleIOErrorsAndQuit $ mapM (executeDatabaseContextExpr sessionId conn) [+        toAddTypeExpr (Proxy :: Proxy Stage) -- Adds the Type Stage as data to the DB+    ,   toDefineExpr (Proxy :: Proxy Plant) "plants" -- Creates the plants relation+    ,   databaseContextExprForUniqueKey "plants" ["name"] -- Makes name of the plants relation a uniqe Key,+                                                          -- Foreign Key restrictions are available too+    ]+  pure ()+++-- |    inserting some sample data+insertSampleData :: DBConnection -> IO (Either Err ())+insertSampleData (DB sid conn) = do+    insert (DB sid conn) [+        Plant "angu" "Caladenia angustata" Seed 0+      , Plant "thely" "Thelymitra alcockiae" Seed 0+      , Plant "monstera" "Araceae" Seed 0+      ] "plants"++dbConnection :: IO DBConnection+dbConnection = do+  --  connect to the database+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []+  --  The code below persists the data in a DB with the name "base". \\+--  let connInfo = InProcessConnectionInfo (CrashSafePersistence "base") emptyNotificationCallback [] \\+  --  In addition minimal persistance is available. \\+--  let connInfo = InProcessConnectionInfo (MinimalPersistence "base") emptyNotificationCallback []+  conn <- handleIOErrorAndQuit $ connectProjectM36 connInfo+  --create a database session at the default branch of the database+  sessionId <- handleIOErrorAndQuit $ createSessionAtHead conn defaultHeadName+  pure (DB sessionId conn)+++-- |    A polymorphic function to insert data (a traversable of data) into the DB+insert :: (Tupleable a, Traversable t) => DBConnection -> t a -> Base.RelVarName -> IO (Either Err ())+insert db rlv rlvName = executeWithTransaction db $ toInsertExpr rlv rlvName++-- |    A polymorphic function to update data in the DB.+--      An update in one funtion would take:+--+--      - SessionId+--      - Connection+--      - Tuplable a        -- the Tuplable you want to update+--      - [AttributeName]   -- the Attributes of the Tuplable you want to update those are of StringType+--      - RelVarName        -- the name of the relation+--+--      With that you can via 'toUpdateExpr' create a 'DatabaseContextExpr' to be executed. \\+--      For inserting its very similarly done with 'toInsertExpr'.+update :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ())+update db rlv attr rlvName = executeWithTransaction db $ toUpdateExpr rlvName attr rlv++-- |    A polymorphic function to delete data in the DB+delete :: (Tupleable a) => DBConnection -> a -> [AttributeName]-> Base.RelVarName -> IO (Either Err ())+delete db rlv attr rlvName = executeWithTransaction db $ toDeleteExpr rlvName attr rlv++-- |    A convenience function to make executing DBContextExpr with commiting simpler. \\+--      In particular for expr that just insert, delete and update.+--      Therefor ultimately return Either _ ()+executeWithTransaction :: DBConnection -> Either RelationalError DatabaseContextExpr -> IO (Either Err ())+executeWithTransaction (DB sid conn) expr = do+    iEx <- handleError expr+    case iEx of+      Left e -> pure $ Left e+      Right v -> handleIOError $ withTransaction sid conn (executeDatabaseContextExpr sid conn v) (commit sid conn)++-- |    A polymorphic function to get data (a list of data and possibly errors) from the DB+get :: Tupleable b => DBConnection -> Base.RelationalExpr -> IO [Either Err b]+get (DB sessionId conn) q = do+  eRel <-  executeRelationalExpr sessionId conn q+  e <- handleError eRel+  case e of+    Left err -> pure [Left err]+    Right pRel -> do+      ws <- Relation.toList pRel+      mapM (handleError . fromTuple) ws++-- |    for closing the DB connection.+--      Not really needed when using in-memory DB+closeConn :: DBConnection -> IO ()+closeConn (DB _ conn) = close conn+++-- |    Error handling is heavily inspired by 'blog.hs' the blog example \\+--      by (agentm)[https://github.com/agentm] (https://github.com/agentm/project-m36, commit: f8432522adaafeae7c32bc2b8b6cb09c00396fc6). \\+--      As stated there, your application should have proper error handling.+handleIOErrorAndQuit :: Show e => IO (Either e a) -> IO a+handleIOErrorAndQuit m = do+  v <- m+  handleErrorAndQuit v++handleError :: Show e => Either e a -> IO (Either Err a)+handleError eErr = case eErr of+  Left err -> print err $> Left NotSpecified+  Right v  -> pure $ Right v++handleIOError :: Show e => IO (Either e a) -> IO (Either Err a)+handleIOError m = do+  v <- m+  handleError v++handleErrorAndQuit :: Show e => Either e a -> IO a+handleErrorAndQuit eErr = case eErr of+  Left err -> print err >> error "Quit."+  Right v  -> pure v++handleIOErrorsAndQuit :: Show e => IO [Either e a] -> IO [a]+handleIOErrorsAndQuit m = do+  eErrs <- m+  case lefts eErrs of+    []    -> pure (rights eErrs)+    err:_ -> handleErrorAndQuit (Left err)+
project-m36.cabal view
@@ -1,8 +1,8 @@ Cabal-Version: 2.2 Name: project-m36-Version: 0.9.0+Version: 0.9.4 License: MIT---note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain +--note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple Homepage: https://github.com/agentm/project-m36 Bug-Reports: https://github.com/agentm/project-m36/issues@@ -35,7 +35,7 @@      Default: True  Library-    Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.3, winery, curryer-rpc, network, async, vector-instances+    Build-Depends: base>=4.8 && < 4.15, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, filepath, zlib, directory, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256, text-manipulate >= 0.2.0.1 && < 0.4, winery, curryer-rpc, network, async, vector-instances, recursion-schemes, streamly >= 0.7.2, convertible     if flag(haskell-scripting)         Build-Depends: ghc >= 8.2 && < 8.11         CPP-Options: -DPM36_HASKELL_SCRIPTING@@ -59,10 +59,12 @@                      ProjectM36.AttributeNames,                      ProjectM36.Tuple,                      ProjectM36.TupleSet,+                     ProjectM36.Function,                      ProjectM36.Atom,                      ProjectM36.AtomFunction,                      ProjectM36.AtomFunctionError,                      ProjectM36.ScriptSession,+                     ProjectM36.Shortcuts,                      ProjectM36.DatabaseContextFunction,                      ProjectM36.DatabaseContextFunctionError,                      ProjectM36.DatabaseContextFunctionUtils,@@ -135,14 +137,14 @@       Other-Modules: ProjectM36.Win32Handle     else       --219-  too many exported symbols under Windows and GHC 8.4-      GHC-Options: -rdynamic+      GHC-Options: -rdynamic -fexternal-interpreter       C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c       Build-Depends: unix     CC-Options: -fPIC     Hs-Source-Dirs: ./src/lib     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings, CPP-    if !flag(stack) +    if !flag(stack)       Build-Depends: deferred-folds  Executable tutd@@ -174,7 +176,7 @@                    directory,                    filepath,                    temporary,-                   megaparsec >= 5.2.0 && < 9,+                   megaparsec >= 5.2.0 && < 10,                    haskeline,                    random, MonadRandom,                    base64-bytestring,@@ -184,7 +186,13 @@                    list-t,                    parser-combinators,                    curryer-rpc,-                   prettyprinter+                   prettyprinter,+                   cryptohash-sha256,+                   --due to decode signature change+                   base16-bytestring >= 1.0.0.0,+                   http-conduit,+                   modern-uri,+                   http-types     Other-Modules: TutorialD.Interpreter,                    TutorialD.Interpreter.Base,                    TutorialD.Interpreter.DatabaseContextExpr,@@ -206,7 +214,10 @@                    TutorialD.Printer     main-is: TutorialD/tutd.hs     CC-Options: -fPIC-    GHC-Options: -Wall -threaded+    if os(windows)+      GHC-Options: -Wall -threaded+    else+      GHC-Options: -Wall -threaded -rdynamic     Hs-Source-Dirs: ./src/bin     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings@@ -230,7 +241,6 @@                    optparse-applicative,                    hashable-time,                    time,-                   vector-binary-instances,                    text,                    deepseq-generics,                    mtl,@@ -243,7 +253,10 @@                    list-t,                    base64-bytestring     Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs-    GHC-Options: -Wall -threaded -rtsopts+    if os(windows)+      GHC-Options: -Wall -threaded -rtsopts+    else+      GHC-Options: -Wall -threaded -rtsopts -rdynamic           if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall     Default-Language: Haskell2010@@ -252,7 +265,7 @@ Executable bigrel     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators     Other-Modules: TutorialD.Interpreter.Base,                    TutorialD.Interpreter.DatabaseContextExpr,                    TutorialD.Interpreter.RelationalExpr,@@ -264,11 +277,11 @@       GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall  Common commontest-    Default-Language: Haskell2010 -    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring+    Default-Language: Haskell2010+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, project-m36, random, MonadRandom, semigroups, parser-combinators, winery, curryer-rpc, prettyprinter, base64-bytestring, modern-uri, http-types, http-conduit, base16-bytestring,cryptohash-sha256     Default-Extensions: OverloadedStrings     GHC-Options: -Wall -threaded-    Hs-Source-Dirs: ./src/bin, ., test/+    Hs-Source-Dirs: test, src/bin  Benchmark basic-benchmark     Default-Language: Haskell2010@@ -281,67 +294,79 @@     if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall +--benchmark inserts, updates, deletes for a basic use-case to shake out any space leaks+Benchmark update-exprs+  Default-Language: Haskell2010+  Default-Extensions: OverloadedStrings+  Build-Depends: base, criterion, project-m36, text, winery+  Main-Is: benchmark/Server.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 -fexternal-interpreter+ Test-Suite test-tutoriald     import: commontest     type: exitcode-stdio-1.0-    main-is: test/TutorialD/Interpreter.hs+    main-is: TutorialD/InterpreterTest.hs     Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter  Test-Suite test-tutoriald-atomfunctionscript     import: commontest     type: exitcode-stdio-1.0     Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer-    main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs+    main-is: TutorialD/Interpreter/AtomFunctionScript.hs  Test-Suite test-tutoriald-databasecontextfunctionscript     import: commontest     type: exitcode-stdio-1.0     Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer-    main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+    main-is: TutorialD/Interpreter/DatabaseContextFunctionScript.hs  Test-Suite test-relation     import: commontest     type: exitcode-stdio-1.0-    main-is: test/Relation/Basic.hs+    main-is: Relation/Basic.hs  Test-Suite test-static-optimizer     import: commontest     type: exitcode-stdio-1.0-    main-is: test/Relation/StaticOptimizer.hs+    main-is: Relation/StaticOptimizer.hs  Test-Suite test-transactiongraph-persist     import: commontest     type: exitcode-stdio-1.0-    main-is: test/TransactionGraph/Persist.hs+    main-is: TransactionGraph/Persist.hs     Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer  Test-Suite test-relation-import-csv     import: commontest     type: exitcode-stdio-1.0-    main-is: test/Relation/Import/CSV.hs+    main-is: Relation/Import/CSV.hs  Test-Suite test-tutoriald-import-tutoriald     import: commontest     type: exitcode-stdio-1.0-    main-is: test/TutorialD/Interpreter/Import/TutorialD.hs+    main-is: TutorialD/Interpreter/Import/ImportTest.hs     Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer  Test-Suite test-relation-export-csv     import: commontest     type: exitcode-stdio-1.0-    main-is: test/Relation/Export/CSV.hs+    main-is: Relation/Export/CSV.hs  Test-Suite test-transactiongraph-merge     import: commontest     type: exitcode-stdio-1.0-    main-is: test/TransactionGraph/Merge.hs+    main-is: TransactionGraph/Merge.hs   Test-Suite test-prettyprinter     import: commontest     type: exitcode-stdio-1.0-    main-is: test/TutorialD/Printer.hs+    main-is: TutorialD/PrinterTest.hs     Other-Modules: TutorialD.Printer, TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types  benchmark bench@@ -352,41 +377,48 @@ Test-Suite test-server     import: commontest     type: exitcode-stdio-1.0-    main-is: test/Server/Main.hs+    main-is: Server/Main.hs   Executable Example-SimpleClient     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,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36, random, MonadRandom+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36, random, MonadRandom     Main-Is: examples/SimpleClient.hs     GHC-Options: -Wall -threaded  Executable Example-OutOfTheTarpit     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery     Main-Is: examples/out_of_the_tarpit.hs     GHC-Options: -Wall -threaded  Executable Example-Blog     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty, blaze-html, http-types, winery     Main-Is: examples/blog.hs     GHC-Options: -Wall -threaded  Executable Example-Hair     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery     Main-Is: examples/hair.hs     GHC-Options: -Wall -threaded +Executable Example-Plantfarm+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    Build-Depends:  aeson, barbies, base, binary, containers, deepseq, hashable, project-m36, random, scotty, text, winery+    Main-Is: examples/Plantfarm.hs+    GHC-Options: -Wall -threaded+ 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,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, winery     Main-Is: examples/CustomTupleable.hs     GHC-Options: -Wall -threaded @@ -403,12 +435,12 @@ Test-Suite test-scripts     import: commontest     type: exitcode-stdio-1.0-    main-is: test/scripts.hs+    main-is: scripts.hs     Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer  Executable project-m36-websocket-server     Default-Language: Haskell2010-    Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network+    Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, optparse-applicative, project-m36, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, semigroups, attoparsec, parser-combinators, prettyprinter, network, modern-uri, http-conduit, base16-bytestring, http-types, cryptohash-sha256, wai, wai-websockets, warp, warp-tls     Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs     Other-Modules:  ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer     GHC-Options: -Wall -threaded@@ -418,46 +450,46 @@ Test-Suite test-websocket-server     import: commontest     type: exitcode-stdio-1.0-    main-is: test/Server/WebSocket.hs+    main-is: Server/WebSocket.hs     Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator, TutorialD.Printer  Test-Suite test-isomorphic-schemas     import: commontest     type: exitcode-stdio-1.0-    main-is: test/IsomorphicSchema.hs+    main-is: IsomorphicSchema.hs  Test-Suite test-atomable     import: commontest     type: exitcode-stdio-1.0-    main-is: test/Relation/Atomable.hs+    main-is: Relation/Atomable.hs     Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer  Test-Suite test-multiprocess-access     import: commontest     type: exitcode-stdio-1.0-    main-is: test/MultiProcessDatabaseAccess.hs+    main-is: MultiProcessDatabaseAccess.hs  Test-Suite test-transactiongraph-automerge     import: commontest     type: exitcode-stdio-1.0-    main-is: test/TransactionGraph/Automerge.hs+    main-is: TransactionGraph/Automerge.hs     Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer  Test-Suite test-tupleable     import: commontest     type: exitcode-stdio-1.0-    main-is: test/Relation/Tupleable.hs+    main-is: Relation/Tupleable.hs  Test-Suite test-client-simple     import: commontest-    Main-Is: test/Client/Simple.hs+    Main-Is: Client/Simple.hs     type: exitcode-stdio-1.0  -- test for file handle leaks Executable handles     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36, random, MonadRandom, semigroups, parser-combinators, prettyprinter, modern-uri, http-types, http-conduit, base16-bytestring, cryptohash-sha256     main-is: benchmark/Handles.hs     Other-Modules: TutorialD.Interpreter,       TutorialD.Interpreter.Base,@@ -481,9 +513,9 @@     HS-Source-Dirs: ./src/bin     if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall-    + Test-Suite test-dataframe     import: commontest     type: exitcode-stdio-1.0-    Main-Is: test/DataFrame.hs+    Main-Is: DataFrame.hs     Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr,  TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Printer
src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs view
@@ -11,11 +11,13 @@ import ProjectM36.IsomorphicSchema import ProjectM36.Server.RemoteCallTypes import ProjectM36.MerkleHash+import ProjectM36.Attribute as A  import Data.Aeson import Data.ByteString.Base64 as B64 import Data.Text.Encoding import Data.Time.Calendar+import Data.UUID  instance ToJSON RelationalExpr instance FromJSON RelationalExpr@@ -44,8 +46,11 @@ instance ToJSON Relation instance FromJSON Relation -instance ToJSON Attribute-instance FromJSON Attribute+instance ToJSON Attribute where+  toJSON (Attribute attrName aType) = object [ "name" .= attrName+                                             , "type" .= toJSON aType ]+instance FromJSON Attribute where+  parseJSON = withObject "Attribute" $ \v -> Attribute <$> v .: "name" <*> v .: "type"  instance ToJSON ExtendTupleExpr instance FromJSON ExtendTupleExpr@@ -97,6 +102,8 @@                                             "val" .= decodeUtf8 (B64.encode i) ]   toJSON atom@(BoolAtom i) = object [ "type" .= atomTypeForAtom atom,                                       "val" .= i ]+  toJSON atom@(UUIDAtom u) = object [ "type" .= atomTypeForAtom atom,+                                      "val" .= u ]   toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom,                                           "val" .= i ]   toJSON atom@(RelationalExprAtom i) = object [ "type" .= atomTypeForAtom atom,@@ -128,6 +135,11 @@           Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err)           Right bs -> pure (ByteStringAtom bs)       BoolAtomType -> BoolAtom <$> o .: "val"+      UUIDAtomType -> do+        mUUID <- fromString <$> o .: "val"+        case mUUID of+          Just u -> pure $ UUIDAtom u+          Nothing -> fail "Invalid UUID String"       RelationalExprAtomType -> RelationalExprAtom <$> o .: "val"  instance ToJSON Notification@@ -145,6 +157,12 @@       Left err -> fail ("Failed to parse merkle hash: " ++ err)       Right bs -> pure (MerkleHash bs) +instance ToJSON Attributes where+  toJSON attrs = object ["attributes" .= map toJSON (A.toList attrs)]+instance FromJSON Attributes where+  parseJSON = withObject "Attributes" $ \o ->+    A.attributesFromList <$> o .: "attributes"+ instance ToJSON RelationalError instance FromJSON RelationalError @@ -154,6 +172,9 @@ instance ToJSON MergeError instance FromJSON MergeError +instance ToJSON ImportError'+instance FromJSON ImportError'+ instance ToJSON DatabaseContextFunctionError instance FromJSON DatabaseContextFunctionError @@ -168,3 +189,5 @@  instance ToJSON WithNameExpr instance FromJSON WithNameExpr++
src/bin/ProjectM36/Server/WebSocket.hs view
@@ -22,6 +22,7 @@ import Control.Applicative import Text.Megaparsec.Error import Data.Functor+import Data.Either (fromRight)  #if MIN_VERSION_megaparsec(7,0,0) import Data.List.NonEmpty as NE@@ -117,7 +118,7 @@ promptInfo sessionId conn = do   eHeadName <- headName sessionId conn   eSchemaName <- currentSchemaName sessionId conn-  pure (either (const "<unknown>") id eHeadName, either (const "<no schema>") id eSchemaName)+  pure (fromRight "<unknown>" eHeadName, fromRight "<no schema>" eSchemaName)  sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO () sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))
src/bin/ProjectM36/Server/WebSocket/websocket-server.hs view
@@ -1,23 +1,40 @@ {-# LANGUAGE CPP #-}-import ProjectM36.Server.WebSocket-import ProjectM36.Server.Config-import ProjectM36.Server.ParseArgs-import ProjectM36.Server+ import Control.Concurrent-import qualified Network.WebSockets as WS import Control.Exception+import Control.Monad (when)+import Data.Maybe (isJust)+import Data.String (fromString)+import Network.HTTP.Types (status400) import Network.Socket+import Network.Wai (Application, responseLBS)+import Network.Wai.Handler.Warp+import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)+import qualified Network.Wai.Handler.WebSockets as WS+import Network.WebSockets (defaultConnectionOptions)+import ProjectM36.Server+import ProjectM36.Server.Config+import ProjectM36.Server.ParseArgs+import ProjectM36.Server.WebSocket  main :: IO () main = do   -- launch normal project-m36-server   addressMVar <- newEmptyMVar-  serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000, bindHost = "127.0.0.1" })+  wsConfig <- parseWSConfigWithDefaults (defaultServerConfig {bindPort = 8000, bindHost = "127.0.0.1"})+   --usurp the serverConfig for our websocket server and make the proxied server run locally-  let wsHost = bindHost serverConfig+  let serverConfig = wsServerConfig wsConfig+      wsHost = bindHost serverConfig       wsPort = bindPort serverConfig       serverHost = "127.0.0.1"       serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}+      configCertificateFile = tlsCertificatePath wsConfig+      configKeyFile = tlsKeyPath wsConfig++  when (isJust configCertificateFile /= isJust configKeyFile) $+    throwIO $ ErrorCall "TLS_CERTIFICATE_PATH and TLS_KEY_PATH must be set in tandem"+   _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)   --wait for server to be listening   addr <- takeMVar addressMVar@@ -25,6 +42,22 @@         case addr of           SockAddrInet port' _ -> fromIntegral port'           _ -> error "unsupported socket address (IPv4 only currently)"-  --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces-  WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer port serverHost)+      wsApp = websocketProxyServer port serverHost+      waiApp = WS.websocketsOr defaultConnectionOptions wsApp backupApp+      settings = warpSettings wsHost (fromIntegral wsPort) +  case (configCertificateFile, configKeyFile) of+    (Just certificate, Just key) -> runTLS (tlsSettings certificate key) settings waiApp+    _ -> runSettings settings waiApp++backupApp :: Application+backupApp _ respond = respond $ responseLBS status400 [] "Not a WebSocket request"++warpSettings :: HostName -> Port -> Settings+warpSettings host port =+  setHost (fromString host)+    . setPort port+    . setServerName "project-m36"+    . setTimeout 3600+    . setGracefulShutdownTimeout (Just 5)+    $ defaultSettings
src/bin/TutorialD/Interpreter.hs view
@@ -34,6 +34,7 @@ import Data.List (isPrefixOf) import Control.Exception import System.Exit+import Data.Either (fromRight)  {- context ops are read-only operations which only operate on the database context (relvars and constraints)@@ -77,7 +78,7 @@ promptText :: Either RelationalError HeadName -> Either RelationalError SchemaName -> StringType promptText eHeadName eSchemaName = "TutorialD (" <> transInfo <> "): "   where-    transInfo = either (const "<unknown>") id eHeadName <> "/" <> either (const "<no schema>") id eSchemaName+    transInfo = fromRight "<unknown>" eHeadName <> "/" <> fromRight "<no schema>" eSchemaName  parseTutorialD :: T.Text -> Either ParserError ParsedOperation parseTutorialD = parse interpreterParserP ""@@ -215,6 +216,7 @@     unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."     barf :: RelationalError -> IO TutorialDOperatorResult     barf (ScriptError (OtherScriptCompilationError errStr)) = pure (DisplayErrorResult (T.pack errStr))+    barf (ParseError err) = pure (DisplayErrorResult err)     barf err = return $ DisplayErrorResult (T.pack (show err))     eHandler io = do       eErr <- io
src/bin/TutorialD/Interpreter/Base.hs view
@@ -12,11 +12,12 @@   where import ProjectM36.Base import ProjectM36.AtomType+import ProjectM36.Attribute as A import ProjectM36.Relation import ProjectM36.DataFrame  #if MIN_VERSION_megaparsec(6,0,0)-import Text.Megaparsec.Char+import Text.Megaparsec.Char  import qualified Text.Megaparsec.Char.Lexer as Lex import Text.Megaparsec import Data.Void@@ -30,7 +31,6 @@ import System.Random import qualified Data.Text as T import qualified Data.List as L-import qualified Data.Vector as V import qualified Data.Text.IO as TIO import System.IO import ProjectM36.Relation.Show.Term@@ -43,7 +43,7 @@ import Data.List.NonEmpty as NE import Data.Time.Clock import Data.Time.Format-import Control.Monad (void)+import Data.Char  #if !MIN_VERSION_megaparsec(7,0,0) anySingle :: Parsec Void Text (Token Text)@@ -81,8 +81,9 @@ type ParseStr = String #endif +-- consumes only horizontal spaces spaceConsumer :: Parser ()-spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")+spaceConsumer = Lex.space space1 (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")  opChar :: Parser Char opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces@@ -126,6 +127,9 @@ quote :: Parser Text quote = symbol "\"" +backtick :: Parser Text+backtick = symbol "`"+ tripleQuote :: Parser Text tripleQuote = symbol "\"\"\"" @@ -135,6 +139,9 @@ semi :: Parser Text semi = symbol ";" +nline :: Parser Text+nline = (T.singleton <$> newline) <|> crlf+ integer :: Parser Integer #if MIN_VERSION_megaparsec(6,0,0) integer = Lex.signed (pure ()) Lex.decimal <* spaceConsumer@@ -150,7 +157,7 @@ #endif  float :: Parser Double-float = Lex.float+float = Lex.float <* spaceConsumer  capitalizedIdentifier :: Parser Text capitalizedIdentifier =@@ -160,11 +167,22 @@ uncapitalizedIdentifier =   lowerChar >>= identifierRemainder +-- | When an identifier is quoted, it can contain any string.+quotedIdentifier :: Parser Text+quotedIdentifier =+  T.pack <$> backticks (many (escapedBacktick <|> notBacktickChar))+  where+    escapedBacktick = char '\\' >> char '`'+    notBacktickChar = satisfy ('`' /=)++backticks :: Parser a -> Parser a+backticks = between backtick backtick+   showRelationAttributes :: Attributes -> Text showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"   where-    showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType-    attrsL = V.toList attrs+    showAttribute (Attribute name atomType') = name <> " " <> prettyAtomType atomType'+    attrsL = A.toList attrs  type PromptLength = Int @@ -200,6 +218,9 @@ quotedString :: Parser Text quotedString = try tripleQuotedString <|> normalQuotedString +quoted :: Parser a -> Parser a+quoted = between quote quote+ uuidP :: Parser U.UUID uuidP = do   uuidStart <- count 8 hexDigitChar@@ -228,3 +249,10 @@ colonOp opStr = do   _ <- string opStr <* (void spaceChar <|> eof) <* spaceConsumer   pure ()++hex :: Parser Text+hex = takeWhileP (Just "hexadecimal")+         (\c ->+             isDigit c+             || (c >= 'a' && c <= 'f'))+
src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs view
@@ -39,7 +39,7 @@                                nothingP]              nothingP :: Parser DatabaseContextExpr            -nothingP = spaceConsumer >> pure NoOperation+nothingP = spaceConsumer <* eof >> pure NoOperation  assignP :: Parser DatabaseContextExpr assignP = do@@ -53,8 +53,9 @@ multilineSep = newline >> pure "\n"  multipleDatabaseContextExprP :: Parser DatabaseContextExpr-multipleDatabaseContextExprP = -  MultipleExpr <$> sepBy1 databaseContextExprP semi+multipleDatabaseContextExprP = do+  exprs <- filter (/= NoOperation) <$> sepBy1 databaseContextExprP semi+  pure (MultipleExpr exprs)  insertP :: Parser DatabaseContextExpr insertP = do@@ -178,15 +179,12 @@   reserved "removedatabasecontextfunction"   RemoveDatabaseContextFunction <$> quotedString -functionNameP :: Parser AtomFunctionName-functionNameP = uncapitalizedIdentifier- executeDatabaseContextFunctionP :: Parser DatabaseContextExpr executeDatabaseContextFunctionP = do   reserved "execute"-  funcName <- functionNameP+  funcName' <- functionNameP   args <- parens (sepBy atomExprP comma)-  pure (ExecuteDatabaseContextFunction funcName args)+  pure (ExecuteDatabaseContextFunction funcName' args)    databaseExprOpP :: Parser DatabaseContextExpr databaseExprOpP = multipleDatabaseContextExprP
src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs view
@@ -24,9 +24,9 @@ dbioexprP :: ParseStr -> (Text -> [TypeConstructor] -> Text -> DatabaseContextIOExpr) -> Parser DatabaseContextIOExpr dbioexprP res adt = do   reserved res-  funcName <- quotedString-  funcType <- atomTypeSignatureP-  adt funcName funcType <$> quotedString+  funcName' <- quotedString+  funcType' <- atomTypeSignatureP+  adt funcName' funcType' <$> quotedString  atomTypeSignatureP :: Parser [TypeConstructor] atomTypeSignatureP = sepBy typeConstructorP arrow
src/bin/TutorialD/Interpreter/Import/Base.hs view
@@ -2,6 +2,8 @@ module TutorialD.Interpreter.Import.Base where import ProjectM36.Base import ProjectM36.Error+import Text.URI (URI)+import Data.Text (Text) #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif@@ -12,11 +14,14 @@ instance Show RelVarDataImportOperator where   show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path +type HashVerification = Maybe Text+ -- | import data into a database context-data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator FilePath (FilePath -> IO (Either RelationalError DatabaseContextExpr))+data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator URI HashVerification (URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr))  instance Show DatabaseContextDataImportOperator where-  show (DatabaseContextDataImportOperator path _) = "DatabaseContextDataImportOperator " <> path+  show (DatabaseContextDataImportOperator uri hash _) =+    "DatabaseContextDataImportOperator " <> show uri <> " " <> show hash  -- perhaps create a structure to import a whole transaction graph section in the future @@ -24,4 +29,4 @@ evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) tConsMap attrs = importFunc relVarName tConsMap attrs path           evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr)        -evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator path importFunc) = importFunc path+evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator uri hash importFunc) = importFunc uri hash
src/bin/TutorialD/Interpreter/Import/BasicExamples.hs view
@@ -20,7 +20,7 @@ importBasicExampleOperatorP = do    reservedOp ":importexample"   example <- identifier-  if example == "date" then+  if example == "cjdate" then     pure ImportBasicDateExampleOperator     else     fail "Unknown example name"
src/bin/TutorialD/Interpreter/Import/CSV.hs view
@@ -14,10 +14,10 @@   --TODO: handle filesystem errors   csvData <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)   case csvData of -    Left err -> return $ Left (ImportError $ T.pack (show err))+    Left err -> pure $ Left (ImportError (ImportFileError (T.pack (show err))))     Right csvData' -> case csvAsRelation attrs tConsMap csvData' of-      Left err -> return $ Left (ParseError $ T.pack (show err))-      Right csvRel -> return $ Right (Insert relVarName (ExistingRelation csvRel))+      Left err -> pure $ Left (ParseError $ T.pack (show err))+      Right csvRel -> pure $ Right (Insert relVarName (ExistingRelation csvRel))  importCSVP :: Parser RelVarDataImportOperator importCSVP = do
src/bin/TutorialD/Interpreter/Import/TutorialD.hs view
@@ -9,25 +9,78 @@ import Control.Exception import qualified Data.ByteString as BS import qualified Data.Text.Encoding as TE---import a file containing TutorialD database context expressions+import qualified Text.URI as URI+import Text.URI (URI)+import Crypto.Hash.SHA256+import Data.ByteString.Base16 as B16+import Network.HTTP.Simple+import Network.HTTP.Types+--import a file containing TutorialD database context expressions via local files or HTTP/HTTPS -importTutorialD :: FilePath -> IO (Either RelationalError DatabaseContextExpr)-importTutorialD pathIn = do-  eTutdBytes <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)-  case eTutdBytes of -    Left err -> return $ Left (ImportError $ T.pack (show err))-    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)-  +importTutorialDFromFile :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)+importTutorialDFromFile fileURI mHash = do+  case URI.uriPath fileURI of+    Just (False, _) -> do+      eTutdBytes <- try (BS.readFile filePath) :: IO (Either IOError BS.ByteString)+      case eTutdBytes of +        Left err -> pure $ Left (ImportError (ImportFileError (T.pack (show err))))+        Right tutdBytes ->+          case validateBytes tutdBytes mHash of+            Left err -> pure (Left err)+            Right tutdBytes' -> importTutorialDBytes tutdBytes'+    _ -> pure (Left (ImportError (InvalidFileURIError (URI.render fileURI))))+  where+    filePath = drop (length ("file://" :: String)) (URI.renderStr fileURI)+        ++importTutorialDBytes :: BS.ByteString -> IO (Either RelationalError DatabaseContextExpr)+importTutorialDBytes tutdBytes =+  case TE.decodeUtf8' tutdBytes of+    Left err -> pure (Left (ImportError (ImportFileDecodeError (T.pack (show err)))))+    Right tutdUtf8 -> +      case parse (multipleDatabaseContextExprP <* eof) "import" tutdUtf8 of+        --parseErrorPretty is new in megaparsec 5+        Left err -> pure (Left (PM36E.ParseError (T.pack (errorBundlePretty err))))+        Right expr -> pure (Right expr)++importTutorialDViaHTTP :: URI -> HashVerification -> IO (Either RelationalError DatabaseContextExpr)+importTutorialDViaHTTP uri mHash = do+  reqURI <- parseRequest (URI.renderStr uri)+  response <- httpBS reqURI+  let scode = getResponseStatus response+  if scode == ok200 then+      let byteBody = getResponseBody response in+      case validateBytes byteBody mHash of+        Right byteBody' -> do+          importTutorialDBytes byteBody'+        Left err -> pure (Left err)+    else+      pure (Left (ImportError (ImportDownloadError (T.pack ("download failed: " <> show scode)))))++validateBytes :: BS.ByteString -> HashVerification -> Either RelationalError BS.ByteString+validateBytes tutdBytes mHash =+  case mHash of+    Nothing -> pure tutdBytes+    Just expectedHashText ->+      case B16.decode (TE.encodeUtf8 expectedHashText) of+        Left _ -> Left (ImportError (InvalidSHA256Error expectedHashText))+        Right expectedHash | hashBytes == expectedHash -> pure tutdBytes+                           | otherwise ->+                             let p = TE.decodeUtf8 . B16.encode in+                             Left (ImportError (SHA256MismatchError (p expectedHash) (p hashBytes)))+ where+    hashBytes = hash tutdBytes++     tutdImportP :: Parser DatabaseContextDataImportOperator tutdImportP = do   reserved ":importtutd" -  path <- quotedString+  uri <- quoted URI.parser   spaceConsumer-  return $ DatabaseContextDataImportOperator (T.unpack path) importTutorialD+  mhash <- optional (quoted hex)+  handler <- case URI.unRText <$> URI.uriScheme uri of+               Nothing -> fail "URI scheme missing"+               Just "file" -> pure importTutorialDFromFile+               Just scheme | scheme `elem` ["http", "https"] -> pure importTutorialDViaHTTP+                           | otherwise -> fail ( "unsupported URI scheme: " <> show scheme)+  pure $ DatabaseContextDataImportOperator uri mhash handler
src/bin/TutorialD/Interpreter/RelationalExpr.hs view
@@ -150,12 +150,8 @@ relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relExprP = try withMacroExprP <|> makeExprParser relTerm relOperators ---allow for additional characters-attributeNameP :: Parser AttributeName-attributeNameP = uncapitalizedIdentifier- relVarNameP :: Parser RelVarName-relVarNameP = uncapitalizedIdentifier+relVarNameP = try uncapitalizedIdentifier <|> quotedIdentifier  relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) relVarP = RelationVariable <$> relVarNameP <*> parseMarkerP@@ -216,6 +212,7 @@             attributeAtomExprP <|>             try nakedAtomExprP <|>             relationalAtomExprP+              attributeAtomExprP :: Parser (AtomExprBase a) attributeAtomExprP = do@@ -234,13 +231,13 @@ -- used only for primitive type parsing ? atomP :: Parser Atom atomP = stringAtomP <|>-        doubleAtomP <|>+        try doubleAtomP <|>         integerAtomP <|>         boolAtomP  functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) functionAtomExprP =-  FunctionAtomExpr <$> uncapitalizedIdentifier <*> parens (sepBy atomExprP comma) <*> parseMarkerP+  FunctionAtomExpr <$> functionNameP <*> parens (sepBy atomExprP comma) <*> parseMarkerP  relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a) relationalAtomExprP = RelationAtomExpr <$> relExprP@@ -249,7 +246,7 @@ stringAtomP = TextAtom <$> quotedString  doubleAtomP :: Parser Atom-doubleAtomP = DoubleAtom <$> try float+doubleAtomP = DoubleAtom <$> float  integerAtomP :: Parser Atom integerAtomP = IntegerAtom <$> integer
src/bin/TutorialD/Interpreter/Types.hs view
@@ -16,13 +16,19 @@ dataConstructorNameP :: Parser DataConstructorName dataConstructorNameP = capitalizedIdentifier +attributeNameP :: Parser AttributeName+attributeNameP = try uncapitalizedIdentifier <|> quotedIdentifier++functionNameP :: Parser FunctionName+functionNameP = try uncapitalizedIdentifier <|> quotedIdentifier+ -- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments. -- data *Either a b* = Left a | Right b typeConstructorDefP :: Parser TypeConstructorDef typeConstructorDefP = ADTypeConstructorDef <$> typeConstructorNameP <*> typeVarNamesP  typeVarNamesP :: Parser [TypeVarName]-typeVarNamesP = many uncapitalizedIdentifier +typeVarNamesP = many typeVariableIdentifierP    -- data Either a b = *Left a* | *Right b* dataConstructorDefP :: Parser DataConstructorDef@@ -31,7 +37,7 @@ -- data *Either a b* = Left *a* | Right *b* dataConstructorDefArgP :: Parser DataConstructorDefArg dataConstructorDefArgP = DataConstructorDefTypeConstructorArg <$> (monoTypeConstructorP <|> parens typeConstructorP) <|>-                         DataConstructorDefTypeVarNameArg <$> uncapitalizedIdentifier+                         DataConstructorDefTypeVarNameArg <$> typeConstructorNameP    -- relation{a Int} in type construction (no tuples parsed) relationTypeConstructorP :: Parser TypeConstructor@@ -44,17 +50,23 @@ makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)  attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a)-attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP+attributeAndTypeNameP = AttributeAndTypeNameExpr <$> attributeNameP <*> typeConstructorP <*> parseMarkerP++typeIdentifierP :: Parser TypeConstructorName+typeIdentifierP = capitalizedIdentifier++typeVariableIdentifierP :: Parser TypeVarName+typeVariableIdentifierP = uncapitalizedIdentifier                              -- *Either Int Text*, *Int* typeConstructorP :: Parser TypeConstructor                   typeConstructorP = relationTypeConstructorP <|>-                   ADTypeConstructor <$> capitalizedIdentifier <*> many (monoTypeConstructorP <|> parens typeConstructorP) <|>+                   ADTypeConstructor <$> typeIdentifierP <*> many (monoTypeConstructorP <|> parens typeConstructorP) <|>                    monoTypeConstructorP                     monoTypeConstructorP :: Parser TypeConstructor                    monoTypeConstructorP = ADTypeConstructor <$> typeConstructorNameP <*> pure [] <|>-                       TypeVariable <$> uncapitalizedIdentifier+                       TypeVariable <$> typeVariableIdentifierP
src/bin/TutorialD/Printer.hs view
@@ -5,8 +5,8 @@ {-# LANGUAGE TypeApplications #-} module TutorialD.Printer where import ProjectM36.Base-import ProjectM36.Attribute hiding (null)-import Data.Text.Prettyprint.Doc +import ProjectM36.Attribute as A hiding (null)+import Prettyprinter import qualified Data.Set as S hiding (fromList) import qualified Data.Vector as V import qualified Data.Map.Strict as M@@ -14,6 +14,7 @@ import Data.Time.Clock.POSIX import qualified Data.ByteString.Base64 as B64 import qualified Data.Text.Encoding as TE+import Data.UUID hiding (null)  instance Pretty Atom where   pretty (IntegerAtom x) = pretty x@@ -26,6 +27,7 @@   pretty (DateTimeAtom time) = "dateTimeFromEpochSeconds" <> parensList [pretty @Integer (round (utcTimeToPOSIXSeconds time))]   pretty (ByteStringAtom bs) = "bytestring" <> parensList [dquotes (pretty (TE.decodeUtf8 (B64.encode bs)))]   pretty (BoolAtom x) = if x then "t" else "f"+  pretty (UUIDAtom u) = pretty u   pretty (RelationAtom x) = pretty x   pretty (RelationalExprAtom re) = pretty re   pretty (ConstructedAtom n _ as) = pretty n <+> prettyList as@@ -53,6 +55,9 @@             AttributeAtomExpr attrName -> "@" <> pretty attrName             _ -> pretty atomExpr +instance Pretty UUID where+  pretty = pretty . show+ instance Pretty TupleExpr where   pretty (TupleExpr map') = "tuple" <> bracesList (Prelude.map (\(attrName,atom)-> pretty attrName <+> pretty atom) (M.toList map')) @@ -60,9 +65,9 @@   pretty (RelationTuple attrs atoms) = "tuple" <> bracesList (zipWith (\x y-> pretty x <+> pretty y) (V.toList (attributeNames attrs)) (V.toList atoms))  instance Pretty Relation where-  pretty (Relation attrs tupSet) | attrs == V.empty && null (asList tupSet) = "false"-  pretty (Relation attrs tupSet) | attrs == V.empty && asList tupSet == [RelationTuple V.empty V.empty] = "true"-  pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)+  pretty (Relation attrs tupSet) | attrs == mempty && null (asList tupSet) = "false"+  pretty (Relation attrs tupSet) | attrs == mempty && asList tupSet == [RelationTuple mempty mempty] = "true"+  pretty (Relation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet)  instance Pretty Attribute where   pretty (Attribute n aTy) = pretty n <+> pretty (show aTy)  -- workaround@@ -76,7 +81,7 @@   pretty (Extend ext r) = collectExtends r <> pretty ext <> "}"   pretty (MakeRelationFromExprs Nothing (TupleExprs () tupExprs)) = "relation" <> prettyBracesList tupExprs   pretty (MakeRelationFromExprs (Just attrExprs) (TupleExprs () tupExprs)) = "relation" <> prettyBracesList attrExprs <> prettyBracesList tupExprs-  pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (V.toList attrs) <> prettyBracesList (asList tupSet)+  pretty (MakeStaticRelation attrs tupSet) = "relation" <> prettyBracesList (A.toList attrs) <> prettyBracesList (asList tupSet)   pretty (Union a b) = parens $ pretty' a <+> "union" <+> pretty' b   pretty (Join a b) = parens $ pretty' a <+> "join" <+> pretty' b   pretty (Rename n1 n2 relExpr) = parens $ pretty relExpr <+> "rename" <+> braces (pretty n1 <+> "as" <+> pretty n2)@@ -130,7 +135,8 @@   pretty DateTimeAtomType = "DateTime"   pretty ByteStringAtomType = "ByteString"   pretty BoolAtomType = "Bool"-  pretty (RelationAtomType attrs) = "relation " <+> prettyBracesList (V.toList attrs)+  pretty UUIDAtomType = "UUID"+  pretty (RelationAtomType attrs) = "relation " <+> prettyBracesList (A.toList attrs)   pretty (ConstructedAtomType tcName tvMap) = pretty tcName <+> hsep (map pretty (M.toList tvMap)) --order matters   pretty RelationalExprAtomType = "RelationalExpr"   pretty (TypeVariableType x) = pretty x
+ src/bin/benchmark/Server.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DerivingVia, DeriveGeneric #-}+import ProjectM36.Tupleable+import ProjectM36.Client++import Criterion.Main+import Codec.Winery+import Data.Text (Text)+import Data.Proxy+import GHC.Generics+import Control.Monad+++handleIOError :: Show e => IO (Either e a) -> IO a+handleIOError m = do+  v <- m+  handleError v++handleError :: Show e => Either e a -> IO a+handleError eErr = case eErr of+    Left err -> print err >> error "Died due to errors."+    Right v -> pure v++--test local connection speeds of inserts, updates, and deletes to look for space leaks, etc.+main :: IO ()+main = do+  conn <- handleIOError $ connectProjectM36 (InProcessConnectionInfo NoPersistence emptyNotificationCallback [])+  sess <- handleIOError $ createSessionAtHead conn "master"+  _ <- handleIOError $ executeDatabaseContextExpr sess conn (toDefineExpr (Proxy :: Proxy User) "user")++  let count = 100+  insertUsers sess conn count+  defaultMain [+    bgroup "inserts" [+        bench "insert" $ nfIO $ insertUsers sess conn count]+    {-,bgroup "updates" [+        bench "update" $ nfIO $ updateUsers sess conn count+        ]-}+    ,bgroup "delete" [+        bench "delete" $ nfIO $ deleteUsers sess conn count+        ]+    ]+++insertUsers :: SessionId -> Connection -> Int -> IO ()+insertUsers sess conn count = +  forM_ [1 .. count] $ \newId -> do+    let newUser = User { userId = newId+                       , userFirstName = "Steve"+                       , userLastName = "Stevens"+                       , userEmail = "bench@bench.com"+                       }+    newUserExpr <- handleError (toInsertExpr [newUser] "user")+    handleIOError $ executeDatabaseContextExpr sess conn newUserExpr++{-+updateUsers :: SessionId -> Connection -> Int -> IO ()+updateUsers sess conn count =+  forM_ [1 .. count] $ \uid -> do+    let changeUser = User { userId = uid+                          , userFirstName = "Steve"+                          , userLastName = "Stevens III"+                          , userEmail = "bench@bench.com"+                          }+        updateExpr = toUpdateExpr "user" ["userId"] changeUser+    updateUserExpr <- handleError updateExpr+    handleIOError $ executeDatabaseContextExpr sess conn updateUserExpr+-}+deleteUsers :: SessionId -> Connection -> Int -> IO ()+deleteUsers sess conn count =+  forM_ [1 .. count] $ \uid -> do+    let delUser = User { userId = uid+                       , userFirstName = "Steve"+                       , userLastName = "Stevens III"+                       , userEmail = "bench@bench.com"+                       }+    delUserExpr <- handleError (toDeleteExpr "user" ["userId"] delUser)+    handleIOError $ executeDatabaseContextExpr sess conn delUserExpr++data User = User+          { userId :: Int+          , userFirstName :: Text+          , userLastName :: Text+          , userEmail :: Text+          }+          deriving Generic+          deriving Serialise via WineryRecord User++instance Tupleable User
src/lib/ProjectM36/Arbitrary.hs view
@@ -17,6 +17,7 @@ import qualified Data.ByteString.Char8 as B import Data.Time import Control.Monad.Reader+import Data.UUID  arbitrary' :: AtomType -> WithTCMap Gen (Either RelationalError Atom) arbitrary' IntegerAtomType = @@ -50,6 +51,9 @@ arbitrary' BoolAtomType =    Right . BoolAtom <$> lift (arbitrary :: Gen Bool) +arbitrary' UUIDAtomType = +  Right . UUIDAtom <$> lift (arbitrary :: Gen UUID)+ arbitrary' RelationalExprAtomType =   pure (Right (RelationalExprAtom (ExistingRelation relationTrue))) -- don't bother with arbitrary relational expressions @@ -84,7 +88,7 @@ arbitraryRelationTuple :: Attributes -> WithTCMap Gen (Either RelationalError RelationTuple) arbitraryRelationTuple attris = do   tcMap <- ask-  listOfMaybeAType <- lift $ mapM ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList attris)+  listOfMaybeAType <- lift $ mapM ((\aTy -> runReaderT (arbitrary' aTy) tcMap) . atomType) (V.toList (attributesVec attris))   case sequence listOfMaybeAType of     Left err -> pure $ Left err     Right listOfAttr -> do
src/lib/ProjectM36/Atom.hs view
@@ -20,6 +20,7 @@ atomToText (DateTimeAtom i) = (T.pack . show) i atomToText (ByteStringAtom i) = (T.pack . show) i atomToText (BoolAtom i) = (T.pack . show) i+atomToText (UUIDAtom u) = (T.pack . show) u atomToText (RelationalExprAtom re) = (T.pack . show) re  atomToText (RelationAtom i) = (T.pack . show) i
src/lib/ProjectM36/AtomFunction.hs view
@@ -6,7 +6,7 @@ import ProjectM36.Relation import ProjectM36.AtomType import ProjectM36.AtomFunctionError-import ProjectM36.ScriptSession+import ProjectM36.Function import qualified ProjectM36.Attribute as A import qualified Data.HashSet as HS import qualified Data.Text as T@@ -17,31 +17,30 @@ --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-atomFunctionForName funcName funcSet = if HS.null foundFunc then-                                         Left $ NoSuchFunctionError funcName+atomFunctionForName :: FunctionName -> AtomFunctions -> Either RelationalError AtomFunction+atomFunctionForName funcName' funcSet = if HS.null foundFunc then+                                         Left $ NoSuchFunctionError funcName'                                         else                                          Right $ head $ HS.toList foundFunc   where-    foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet+    foundFunc = HS.filter (\f -> funcName f == funcName') funcSet  -- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet.-emptyAtomFunction :: AtomFunctionName -> AtomFunction-emptyAtomFunction name = AtomFunction { atomFuncName = name,-                                        atomFuncType = [TypeVariableType "a", TypeVariableType "a"],-                                        atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure x) }+emptyAtomFunction :: FunctionName -> AtomFunction+emptyAtomFunction name = Function { funcName = name,+                                    funcType = [TypeVariableType "a", TypeVariableType "a"],+                                    funcBody = FunctionBuiltInBody (\(x:_) -> pure x) }                                                                                       -- | AtomFunction constructor for compiled-in functions.-compiledAtomFunction :: AtomFunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction-compiledAtomFunction name aType body = AtomFunction { atomFuncName = name,-                                                      atomFuncType = aType,-                                                      atomFuncBody = AtomFunctionBody Nothing body }+compiledAtomFunction :: FunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction+compiledAtomFunction name aType body = Function { funcName = name,+                                                  funcType = aType,+                                                  funcBody = FunctionBuiltInBody body }  --the atom function really should offer some way to return an error evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom-evalAtomFunction func args = case atomFuncBody func of-  (AtomFunctionBody _ f) -> f args+evalAtomFunction func = function (funcBody func)  --expect "Int -> Either AtomFunctionError Int" --return "Int -> Int" for funcType@@ -59,43 +58,60 @@       Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))      isScriptedAtomFunction :: AtomFunction -> Bool    -isScriptedAtomFunction func = case atomFuncBody func of-  AtomFunctionBody (Just _) _ -> True-  AtomFunctionBody Nothing _ -> False-  -atomFunctionScript :: AtomFunction -> Maybe AtomFunctionBodyScript-atomFunctionScript func = case atomFuncBody func of-  AtomFunctionBody script _ -> script+isScriptedAtomFunction func = case funcBody func of+  FunctionScriptBody{} -> True+  _ -> False    -- | Create a 'DatabaseContextIOExpr' which can be used to load a new atom function written in Haskell and loaded at runtime.-createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr-createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName (+createScriptedAtomFunction :: FunctionName -> [TypeConstructor] -> TypeConstructor -> FunctionBodyScript -> DatabaseContextIOExpr+createScriptedAtomFunction funcName' argsType retType = AddAtomFunction funcName' (   argsType ++ [ADTypeConstructor "Either" [                 ADTypeConstructor "AtomFunctionError" [],                                      retType]]) -loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])+{-+loadAtomFunctions :: ModName -> FuncName -> Maybe FilePath -> FilePath -> IO (Either LoadSymbolError [AtomFunction]) #ifdef PM36_HASKELL_SCRIPTING-loadAtomFunctions = loadFunction+Loadatomfunctions modName funcName' mModDir objPath =+  case mModDir of+    Just modDir -> do+      eNewFs <- loadFunctionFromDirectory LoadAutoObjectFile modName funcName' modDir objPath+      case eNewFs of+        Left err -> pure (Left err)+        Right newFs ->+          pure (Right (processFuncs newFs))+    Nothing -> do+      loadFunction LoadAutoObjectFile modName funcName' objPath+ where+   --functions inside object files probably won't have the right function body metadata+   processFuncs = map processor+   processor newF = newF { funcBody = processObjectLoadedFunctionBody modName funcName' objPath (funcBody newF)} #else-loadAtomFunctions _ _ _ = pure (Left LoadSymbolError)+loadAtomFunctions _ _ _ _ = pure (Left LoadSymbolError) #endif+-}  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),+        atomFuncToTuple aFunc = [TextAtom (funcName aFunc),                                  TextAtom (atomFuncTypeToText aFunc)]-        atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))+        atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (funcType aFunc))  --for calculating the merkle hash hashBytes :: AtomFunction -> BL.ByteString-hashBytes func = BL.fromChunks [serialise (atomFuncName func),-                                serialise (atomFuncType func),+hashBytes func = BL.fromChunks [serialise (funcName func),+                                serialise (funcType func),                                 bodyBin                                ]   where-    bodyBin = case atomFuncBody func of-                AtomFunctionBody mScript _ -> serialise mScript+    bodyBin = case funcBody func of+                FunctionScriptBody mScript _ -> serialise mScript+                FunctionBuiltInBody _ -> ""+                FunctionObjectLoadedBody f m n _ -> serialise (f,m,n)+  +-- | Used to mark functions which are loaded externally from the server.      +externalAtomFunction :: AtomFunctionBodyType -> AtomFunctionBody+externalAtomFunction = FunctionBuiltInBody
src/lib/ProjectM36/AtomFunctionBody.hs view
@@ -4,4 +4,4 @@ import ProjectM36.Base  compiledAtomFunctionBody :: AtomFunctionBodyType -> AtomFunctionBody  -compiledAtomFunctionBody = AtomFunctionBody Nothing+compiledAtomFunctionBody = FunctionBuiltInBody
src/lib/ProjectM36/AtomFunctionError.hs view
@@ -9,6 +9,7 @@                          InvalidIntervalOrderingError |                          InvalidIntervalBoundariesError |                          InvalidIntBoundError |+                         InvalidUUIDString Text |                          AtomFunctionEmptyRelationError |                          AtomTypeDoesNotSupportOrderingError Text |                          AtomTypeDoesNotSupportIntervalError Text |
src/lib/ProjectM36/AtomFunctions/Primitive.hs view
@@ -7,54 +7,69 @@ import qualified Data.HashSet as HS import qualified Data.Vector as V import Control.Monad+import qualified Data.UUID as U+import qualified Data.Text as T  primitiveAtomFunctions :: AtomFunctions primitiveAtomFunctions = HS.fromList [   --match on any relation type-  AtomFunction { atomFuncName = "add",-                 atomFuncType = [IntegerAtomType, IntegerAtomType, IntegerAtomType],-                 atomFuncBody = body (\(IntegerAtom i1:IntegerAtom i2:_) -> pure (IntegerAtom (i1 + i2)))},-  AtomFunction { atomFuncName = "id",-                 atomFuncType = [TypeVariableType "a", TypeVariableType "a"],-                 atomFuncBody = body (\(x:_) -> pure x)},-  AtomFunction { atomFuncName = "sum",-                 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,-                 atomFuncBody = body (\(RelationAtom rel:_) -> relationSum rel)},-  AtomFunction { atomFuncName = "count",-                 atomFuncType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType,-                 atomFuncBody = body (\(RelationAtom relIn:_) -> relationCount relIn)},-  AtomFunction { atomFuncName = "max",-                 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,-                 atomFuncBody = body (\(RelationAtom relIn:_) -> relationMax relIn)},-  AtomFunction { atomFuncName = "min",-                 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,-                 atomFuncBody = body (\(RelationAtom relIn:_) -> relationMin relIn)},-  AtomFunction { atomFuncName = "lt",-                 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],-                 atomFuncBody = body $ integerAtomFuncLessThan False},-  AtomFunction { atomFuncName = "lte",-                 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],-                 atomFuncBody = body $ integerAtomFuncLessThan True},-  AtomFunction { atomFuncName = "gte",-                 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],-                 atomFuncBody = body $ integerAtomFuncLessThan False >=> boolAtomNot},-  AtomFunction { atomFuncName = "gt",-                 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],-                 atomFuncBody = body $ integerAtomFuncLessThan True >=> boolAtomNot},-  AtomFunction { atomFuncName = "not",-                 atomFuncType = [BoolAtomType, BoolAtomType],-                 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-                                                   }-  +  Function { funcName = "add",+             funcType = [IntegerAtomType, IntegerAtomType, IntegerAtomType],+             funcBody = body (\(IntegerAtom i1:IntegerAtom i2:_) -> pure (IntegerAtom (i1 + i2)))},+    Function { funcName = "id",+               funcType = [TypeVariableType "a", TypeVariableType "a"],+               funcBody = body (\(x:_) -> pure x)},+    Function { funcName = "sum",+               funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,+               funcBody = body (\(RelationAtom rel:_) -> relationSum rel)},+    Function { funcName = "count",+               funcType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType,+               funcBody = body (\(RelationAtom relIn:_) -> relationCount relIn)},+    Function { funcName = "max",+               funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,+               funcBody = body (\(RelationAtom relIn:_) -> relationMax relIn)},+    Function { funcName = "min",+               funcType = foldAtomFuncType IntegerAtomType IntegerAtomType,+               funcBody = body (\(RelationAtom relIn:_) -> relationMin relIn)},+    Function { funcName = "lt",+               funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+               funcBody = body $ integerAtomFuncLessThan False},+    Function { funcName = "lte",+               funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+               funcBody = body $ integerAtomFuncLessThan True},+    Function { funcName = "gte",+               funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+               funcBody = body $ integerAtomFuncLessThan False >=> boolAtomNot},+    Function { funcName = "gt",+               funcType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+               funcBody = body $ integerAtomFuncLessThan True >=> boolAtomNot},+    Function { funcName = "not",+               funcType = [BoolAtomType, BoolAtomType],+               funcBody = body $ \(b:_) -> boolAtomNot b },+    Function { funcName = "int",+               funcType = [IntegerAtomType, IntAtomType],+               funcBody =+                 body $ \(IntegerAtom v:_) ->+                          if v < fromIntegral (maxBound :: Int) then+                            +                            pure (IntAtom (fromIntegral v))+                          else+                            Left InvalidIntBoundError+             },+    Function { funcName = "integer",+               funcType = [IntAtomType, IntegerAtomType],+               funcBody = body $ \(IntAtom v:_) -> Right $ IntegerAtom $ fromIntegral v},+    Function { funcName = "uuid",+               funcType = [TextAtomType, UUIDAtomType],+               funcBody = body $ \(TextAtom v:_) ->+                 let mUUID = U.fromString (T.unpack v) in+                   case mUUID of+                     Just u -> pure $ UUIDAtom u+                     Nothing -> Left $ InvalidUUIDString v+             }   ]   where-    body = AtomFunctionBody Nothing+    body = FunctionBuiltInBody                           integerAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom integerAtomFuncLessThan equality (IntegerAtom i1:IntegerAtom i2:_) = pure (BoolAtom (i1 `op` i2))
src/lib/ProjectM36/AtomType.hs view
@@ -211,7 +211,7 @@  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)+  mapM_ (uncurry resolveAtomType) (zip (A.atomTypesList attrs) evaldAtomTypes) isValidAtomTypeForTypeConstructor aType tCons _ = Left (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))  findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])@@ -295,7 +295,7 @@ -- Example: "Nothing" does not specify the the argument in "Maybe a", so allow delayed resolution in the tuple before it is added to the relation. Note that this resolution could cause a type error. Hardly a Hindley-Milner system. resolveTypesInTuple :: Attributes -> TypeConstructorMapping -> RelationTuple -> Either RelationalError RelationTuple resolveTypesInTuple resolvedAttrs tConss (RelationTuple _ tupAtoms) = do-  newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom tConss) (zip (V.toList tupAtoms) $ map A.atomType (V.toList resolvedAttrs))+  newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom tConss) (zip (V.toList tupAtoms) $ A.atomTypesList resolvedAttrs)   Right (RelationTuple resolvedAttrs (V.fromList newAtoms))                             -- | Validate that the type is provided with complete type variables for type constructors.@@ -314,7 +314,7 @@       _ -> Right () validateAtomType (RelationAtomType attrs) tConss =   mapM_ (\attr ->-         validateAtomType (A.atomType attr) tConss) (V.toList attrs)+         validateAtomType (A.atomType attr) tConss) (attributesVec attrs) validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x)   validateAtomType _ _ = pure () @@ -325,7 +325,7 @@   else     pure ()   where-    errs = lefts $ map ((`validateAtomType` tConss) . A.atomType) (V.toList attrs)+    errs = lefts $ map (`validateAtomType` tConss) (A.atomTypesList attrs)  --ensure that all type vars are fully resolved validateTypeVarMap :: TypeVarMap -> TypeConstructorMapping -> Either RelationalError ()@@ -358,7 +358,7 @@                                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)+                                 atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip (attributesVec attrs1) (attributesVec attrs2))   return x atomTypeVerify x y = if x == y then                        Right x@@ -375,7 +375,7 @@       (M.toAscList b)  prettyAtomType :: AtomType -> T.Text-prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"+prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList (attributesVec attrs))) `T.append` "}" prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))   where     showTypeVars (_, TypeVariableType x) = " " <> x@@ -409,15 +409,15 @@ resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap resolveTypeVariable _ _ = M.empty -resolveFunctionReturnValue :: AtomFunctionName -> TypeVarMap -> AtomType -> Either RelationalError AtomType-resolveFunctionReturnValue funcName tvMap (ConstructedAtomType tCons retMap) = do+resolveFunctionReturnValue :: FunctionName -> TypeVarMap -> AtomType -> Either RelationalError AtomType+resolveFunctionReturnValue funcName' tvMap (ConstructedAtomType tCons retMap) = do   let diff = M.difference retMap tvMap   if M.null diff then     pure (ConstructedAtomType tCons (M.intersection tvMap retMap))     else-    Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff))))-resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of-  Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)+    Left (AtomFunctionTypeVariableResolutionError funcName' (fst (head (M.toList diff))))+resolveFunctionReturnValue funcName' tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of+  Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName' tvName)   Just typ -> pure typ resolveFunctionReturnValue _ _ typ = pure typ @@ -442,13 +442,14 @@     DateTimeAtomType -> True     ByteStringAtomType -> True     BoolAtomType -> True+    UUIDAtomType -> True     RelationalExprAtomType -> True     RelationAtomType attrs -> isResolvedAttributes attrs     ConstructedAtomType _ tvMap -> all isResolvedType (M.elems tvMap)     TypeVariableType _ -> False  isResolvedAttributes :: Attributes -> Bool-isResolvedAttributes attrs = all isResolvedAttribute (V.toList attrs)+isResolvedAttributes attrs = all isResolvedAttribute (V.toList (attributesVec attrs))  isResolvedAttribute :: Attribute -> Bool isResolvedAttribute = isResolvedType . A.atomType
src/lib/ProjectM36/Atomable.hs view
@@ -20,6 +20,7 @@ import Data.Proxy import qualified Data.List.NonEmpty as NE import Codec.Winery+import Data.UUID  -- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values. class (Eq a, NFData a, Serialise a, Show a) => Atomable a where@@ -100,7 +101,14 @@   fromAtom _ = error "improper fromAtom"   toAtomType _ = BoolAtomType   toAddTypeExpr _ = NoOperation-  ++instance Atomable UUID where+  toAtom = UUIDAtom+  fromAtom (UUIDAtom u) = u+  fromAtom _ = error "UUID: Improper fromAtom"+  toAtomType _ = UUIDAtomType+  toAddTypeExpr _ = NoOperation+ {- instance Atomable Relation where   toAtom = RelationAtom@@ -132,6 +140,10 @@   fromAtom (ConstructedAtom "Right" _ [val]) = Right (fromAtom val)   fromAtom _ = error "improper fromAtom (Either a b)"   +  toAtomType _ = ConstructedAtomType "Either" (M.fromList [("a", toAtomType (Proxy :: Proxy a)),+                                                           ("b", toAtomType (Proxy :: Proxy b))])++   --convert to ADT list   instance Atomable a => Atomable [a] where   toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (Proxy :: Proxy a))) []@@ -235,9 +247,10 @@ typeToTypeConstructor x@DateTimeAtomType = PrimitiveTypeConstructor "DateTime" x typeToTypeConstructor x@ByteStringAtomType = PrimitiveTypeConstructor "ByteString" x typeToTypeConstructor x@BoolAtomType = PrimitiveTypeConstructor "Bool" x+typeToTypeConstructor x@UUIDAtomType = PrimitiveTypeConstructor "UUID" x typeToTypeConstructor x@RelationalExprAtomType = PrimitiveTypeConstructor "RelationalExpr" x typeToTypeConstructor (RelationAtomType attrs)-  = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList attrs+  = RelationAtomTypeConstructor $ map attrToAttrExpr $ V.toList (attributesVec attrs)   where     attrToAttrExpr (Attribute n t) = AttributeAndTypeNameExpr n (typeToTypeConstructor t) () typeToTypeConstructor (ConstructedAtomType tcName tvMap)
src/lib/ProjectM36/Attribute.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} module ProjectM36.Attribute where import ProjectM36.Base import ProjectM36.Error@@ -10,16 +11,54 @@ import Data.Either  arity :: Attributes -> Int-arity = V.length+arity a = V.length (attributesVec a) +instance Semigroup Attributes where+  attrsA <> attrsB =+    case joinAttributes attrsA attrsB of+      Left err -> error (show err)+      Right attrs' -> attrs'+    +instance Monoid Attributes where+  mempty = Attributes {+    attributesVec = mempty+    --,attributeSet = mempty+    }+ emptyAttributes :: Attributes-emptyAttributes = V.empty+emptyAttributes = mempty  null :: Attributes -> Bool-null = V.null+null a = V.null (attributesVec a) +singleton :: Attribute -> Attributes+singleton attr = Attributes {+  attributesVec = V.singleton attr+  --,attributesSet = HS.singleton attr+  }++toList :: Attributes -> [Attribute]+toList attrs = V.toList (attributesVec attrs)+ attributesFromList :: [Attribute] -> Attributes-attributesFromList = V.fromList -- . L.nub --too expensive+attributesFromList attrsL = Attributes {+  attributesVec = vec+  --,attributesSet = hset+  }+  where+    vec = if length attrsL == HS.size hset then+      --fast path- no duplicates+      V.fromList attrsL+      else+      --duplicate detected, uniqueify while maintaining original ordering+      V.fromList uniquedL+    hset = HS.fromList attrsL+    uniquedL = fst $ foldr (\attr acc@(l,s) ->+                              if HS.member attr s then+                                acc+                                else+                                (l ++ [attr], HS.insert attr s))+                              ([],mempty) attrsL  attributeName :: Attribute -> AttributeName attributeName (Attribute name _) = name@@ -28,17 +67,16 @@ atomType (Attribute _ atype) = atype  atomTypes :: Attributes -> V.Vector AtomType-atomTypes = V.map atomType+atomTypes attrs = V.map atomType (attributesVec attrs)  atomTypesList :: Attributes -> [AtomType] atomTypesList = V.toList . atomTypes  ---hm- no error-checking here addAttribute :: Attribute -> Attributes -> Attributes-addAttribute attr attrs = attrs `V.snoc` attr+addAttribute attr attrs = attrs <> singleton attr  --if some attribute names overlap but the types do not, then spit back an error-joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes+{-joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes joinAttributes attrs1 attrs2 | V.length uniqueOverlappingAttributes /= V.length overlappingAttributes = Left (TupleAttributeTypeMismatchError overlappingAttributes)                              | V.length overlappingAttrsDifferentTypes > 0 = Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)                              | otherwise = Right $ vectorUniqueify (attrs1 V.++ attrs2)@@ -47,20 +85,52 @@     attrNames2 = V.map attributeName attrs2     uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes     overlappingAttributes = V.filter (`V.elem` attrs2) attrs1+-}+joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes+joinAttributes attrs1 attrs2 +  | S.size overlappingNames == 0 = -- fast path, no overlapping names+    pure (concated id)+  | attributesForNames overlappingNames attrs1 == attributesForNames overlappingNames attrs2 = -- that atomtypes match+    pure (concated vectorUniqueify)+  | otherwise =+    --special handling to validate that overlapping names have the same atom types+    Left (TupleAttributeTypeMismatchError (attributesForNames overlappingNames attrs1))+  where+    nameSet1 = attributeNameSet attrs1+    nameSet2 = attributeNameSet attrs2+    overlappingNames = S.intersection nameSet1 nameSet2+    concated f = Attributes {+      attributesVec = f (attributesVec attrs1 <> attributesVec attrs2)+      --,attributesSet = attributesSet attrs1 <> attributesSet attrs2+      }  addAttributes :: Attributes -> Attributes -> Attributes-addAttributes = (V.++)+addAttributes = (<>) +member :: Attribute -> Attributes -> Bool+member attr attrs = HS.member attr (attributesSet attrs)+ deleteAttributeName :: AttributeName -> Attributes -> Attributes-deleteAttributeName attrName = V.filter (\attr -> attributeName attr /= attrName)+deleteAttributeName attrName = deleteAttributeNames (S.singleton attrName) +deleteAttributeNames :: S.Set AttributeName -> Attributes -> Attributes+deleteAttributeNames attrNames attrs = Attributes {+  attributesVec = vec+  }+  where+    vec = V.filter attrFilter (attributesVec attrs)+    attrFilter attr = S.notMember (attributeName attr) attrNames+ renameAttribute :: AttributeName -> Attribute -> Attribute renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo  renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes-renameAttributes oldAttrName newAttrName = V.map renamer+renameAttributes oldAttrName newAttrName attrs = Attributes {+  attributesVec = vec+  }   where-    renamer attr = if attributeName attr == oldAttrName then+  vec = V.map renamer (attributesVec attrs)+  renamer attr = if attributeName attr == oldAttrName then                      renameAttribute newAttrName attr                    else                      attr@@ -71,7 +141,7 @@   return atype  attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute-attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of+attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) (attributesVec attrs) of   Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))   Just attr -> Right attr @@ -89,15 +159,18 @@     missingNames = attributeNamesNotContained names (S.fromList (V.toList (attributeNames attrsIn)))  attributesForNames :: S.Set AttributeName -> Attributes -> Attributes-attributesForNames attrNameSet = V.filter filt+attributesForNames attrNameSet attrs = Attributes {+  attributesVec = vec+  }   where+    vec = V.filter filt (attributesVec attrs)     filt attr = S.member (attributeName attr) attrNameSet  attributeNameSet :: Attributes -> S.Set AttributeName-attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec+attributeNameSet attrs = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) (attributesVec attrs)  attributeNames :: Attributes -> V.Vector AttributeName-attributeNames = V.map attributeName+attributeNames attrs = V.map attributeName (attributesVec attrs)  --checks if set s1 is wholly contained in the set s2 attributesContained :: Attributes -> Attributes -> Bool@@ -118,42 +191,88 @@  -- useful for display orderedAttributes :: Attributes -> [Attribute]-orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList attrs)+orderedAttributes attrs = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList (attributesVec 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+--this is the function which benefits the most from the HashSet representation- this turned up in the insert performance test attributesDifference :: Attributes -> Attributes -> Attributes-attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)+{-attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)   where     diff a b = (a L.\\ b)  ++ (b L.\\ a)+-}+attributesDifference attrsA attrsB =+  if attributesSet attrsA == attributesSet attrsB then+    mempty+    else+    Attributes {+    attributesVec = vec+    --,attributesSet = hset+    }+  where+    hset = HS.difference setA setB <> HS.difference setB setA+    setA = attributesSet attrsA+    setB = attributesSet attrsB+    vec = V.filter (`HS.member` hset) (attributesVec attrsA <> attributesVec attrsB)  vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn  --check that each attribute only appears once verifyAttributes :: Attributes -> Either RelationalError Attributes-verifyAttributes attrs = if collapsedAttrs /= attrs then-                           Left (TupleAttributeTypeMismatchError (attributesDifference collapsedAttrs attrs))-                         else-                           Right attrs+verifyAttributes attrs =+  if vecSet == attributesSet attrs then+    pure attrs+  else+    Left (TupleAttributeTypeMismatchError diffAttrs)   where-    collapsedAttrs = vectorUniqueify attrs+    vecSet = V.foldr' HS.insert HS.empty (attributesVec attrs)+    diffSet = HS.difference vecSet (attributesSet attrs) <> HS.difference (attributesSet attrs) vecSet+    diffAttrs = Attributes {+      attributesVec = V.fromList (HS.toList diffSet)+      --,attributesSet = diffSet+      } +--used in Generics derivation for ADTs without named attributes- not to be used elsewhere+--drop first n attributes from vector representation+drop :: Int -> Attributes -> Attributes+drop c attrs = Attributes { attributesVec = vec+                          }+  where+    vec = V.drop c (attributesVec attrs)++    +-- use this in preference to attributesEqual when the attribute ordering matters such as during tuple unions+attributesAndOrderEqual :: Attributes -> Attributes -> Bool+attributesAndOrderEqual a b = attributesVec a == attributesVec b++-- use to determine if the same attributes are contained (but ordering is irrelevant) attributesEqual :: Attributes -> Attributes -> Bool-attributesEqual attrs1 attrs2 =  V.null (attributesDifference attrs1 attrs2)+attributesEqual attrsA attrsB =+  attributesVec attrsA == attributesVec attrsB || +  attributesSet attrsA == attributesSet attrsB  attributesAsMap :: Attributes -> M.Map AttributeName Attribute-attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs)+attributesAsMap attrs = V.foldr' (\attr acc -> M.insert (attributeName attr) attr acc) mempty (attributesVec attrs) + -- | Left-biased union of attributes. union :: Attributes -> Attributes -> Attributes-union attrsA attrsB = V.fromList (M.elems unioned)+union attrsA attrsB = Attributes {+  attributesVec = vec+  --,attributesSet = hset+  }   where-    unioned = M.union (attributesAsMap attrsA) (attributesAsMap attrsB)+    hset = HS.union (attributesSet attrsA) (attributesSet attrsB)+    vec = HS.foldr (flip V.snoc) mempty hset                        intersection :: Attributes -> Attributes -> Attributes-intersection attrsA attrsB = V.fromList (M.elems intersected)+intersection attrsA attrsB = Attributes {+  attributesVec = vec+  --,attributesSet = hset+  }   where-    intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)+    hset = HS.intersection (attributesSet attrsA) (attributesSet attrsB)+    vec = HS.foldr (flip V.snoc) mempty hset
src/lib/ProjectM36/Base.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia #-}+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable, DerivingVia, TemplateHaskell, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module ProjectM36.Base where@@ -6,6 +6,7 @@ import ProjectM36.AtomFunctionError import ProjectM36.MerkleHash +import Data.Functor.Foldable.TH import qualified Data.Map as M import qualified Data.HashSet as HS import Data.Hashable (Hashable, hashWithSalt)@@ -17,7 +18,7 @@ import GHC.Stack import qualified Data.Vector as V import qualified Data.List as L-import Data.Text (Text,unpack)+import Data.Text (Text) import Data.Time.Clock import Data.Hashable.Time () import Data.Time.Calendar (Day)@@ -29,7 +30,19 @@ type StringType = Text  type DatabaseName = String-  ++#if !(MIN_VERSION_hashable(1,3,4))+--support for hashable < 1.3, hashable 1.3+ includes instance for containers+instance Hashable (M.Map TypeVarName AtomType) where +  hashWithSalt salt tvmap = hashWithSalt salt (M.keys tvmap)++instance Hashable (M.Map AttributeName AtomExpr) where+  hashWithSalt salt m = salt `hashWithSalt` M.toList m++instance Hashable (S.Set AttributeName) where+  hashWithSalt salt s = salt `hashWithSalt` S.toList s+#endif+ -- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys. data Atom = IntegerAtom Integer |             IntAtom Int |@@ -39,6 +52,7 @@             DateTimeAtom UTCTime |             ByteStringAtom ByteString |             BoolAtom Bool |+            UUIDAtom UUID |             RelationAtom Relation |             RelationalExprAtom RelationalExpr | --used for returning inc deps             ConstructedAtom DataConstructorName AtomType [Atom]@@ -55,6 +69,7 @@   hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt   hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs   hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b+  hashWithSalt salt (UUIDAtom u) = salt `hashWithSalt` u   hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r   hashWithSalt salt (RelationalExprAtom re) = salt `hashWithSalt` re @@ -68,6 +83,7 @@                 DateTimeAtomType |                 ByteStringAtomType |                 BoolAtomType |+                UUIDAtomType |                 RelationAtomType Attributes |                 ConstructedAtomType TypeConstructorName TypeVarMap |                 RelationalExprAtomType |@@ -81,9 +97,6 @@ -- this should probably be an ordered dictionary in order to be able to round-trip these arguments   type TypeVarMap = M.Map TypeVarName AtomType -instance Hashable TypeVarMap where -  hashWithSalt salt tvmap = hashWithSalt salt (M.keys tvmap)-                        -- | Return True iff the atom type argument is relation-valued. If True, this indicates that the Atom contains a relation. isRelationAtomType :: AtomType -> Bool isRelationAtomType (RelationAtomType _) = True@@ -98,17 +111,29 @@ instance Hashable Attribute where   hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName +type AttributesHash = Int+ -- | 'Attributes' represent the head of a relation.-type Attributes = V.Vector Attribute+newtype Attributes = Attributes {+  attributesVec :: V.Vector Attribute+  --,attributesSet :: HS.HashSet Attribute --compare with this generated in heap profile and benchmarks+  }+  deriving (NFData, Read, Hashable, Generic) --- | Equality function for a set of attributes.-attributesEqual :: Attributes -> Attributes -> Bool-attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2-  where-    attrsAsSet = HS.fromList . V.toList-    +attributesSet :: Attributes -> HS.HashSet Attribute+attributesSet = HS.fromList . V.toList . attributesVec++instance Show Attributes where+  show attrs = "attributesFromList [" <> L.intercalate ", " (map (\attr -> "(" <> show attr <> ")") (V.toList (attributesVec attrs))) <> "]"++--when attribute ordering is irrelevant+instance Eq Attributes where+  attrsA == attrsB =+    attributesVec attrsA == attributesVec attrsB || +    attributesSet attrsA == attributesSet attrsB+ sortedAttributesIndices :: Attributes -> [(Int, Attribute)]    -sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed attrs)+sortedAttributesIndices attrs = L.sortBy (\(_, Attribute name1 _) (_,Attribute name2 _) -> compare name1 name2) $ V.toList (V.indexed (attributesVec attrs))  -- | The relation's tuple set is the body of the relation. newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Read)@@ -127,8 +152,8 @@ instance Hashable RelationTuple where   --sanity check the tuple for attribute and tuple counts   --this bit me when tuples were being hashed before being verified-  hashWithSalt salt (RelationTuple attrs tupVec) = if V.length attrs /= V.length tupVec then-                                                     error "invalid tuple: attributes and tuple count mismatch"+  hashWithSalt salt (RelationTuple attrs tupVec) = if V.length (attributesVec attrs) /= V.length tupVec then+                                                     error ("invalid tuple: attributes and tuple count mismatch " <> show (attributesVec attrs, tupVec))                                                    else                                                      salt `hashWithSalt`                                                       sortedAttrs `hashWithSalt`@@ -142,19 +167,20 @@ data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Read, Generic)  instance Eq RelationTuple where-  (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual+  tuple1@(RelationTuple attrs1 _) == tuple2@(RelationTuple attrs2 _) =+    attrs1 == attrs2 && atomsEqual     where-      atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of+      atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) (attributesVec attrs) of         Nothing -> Nothing         Just index -> tupVec V.!? index-      atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1+      atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) (attributesVec attrs1)  instance NFData RelationTuple where rnf = genericRnf  data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)  instance Eq Relation where-  Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2+  Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attrs1 == attrs2 && tupSet1 == tupSet2  instance NFData Relation where rnf = genericRnf                                @@ -338,26 +364,23 @@   RemoveTypeConstructor TypeConstructorName |    --adding an AtomFunction is not a pure operation (required loading GHC modules)-  RemoveAtomFunction AtomFunctionName |+  RemoveAtomFunction FunctionName |   -  RemoveDatabaseContextFunction DatabaseContextFunctionName |+  RemoveDatabaseContextFunction FunctionName |   -  ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExprBase a] |+  ExecuteDatabaseContextFunction FunctionName [AtomExprBase a] |      MultipleExpr [DatabaseContextExprBase a]   deriving (Show, Read, Eq, Generic, NFData) -instance Hashable (M.Map AttributeName AtomExpr) where-  hashWithSalt salt m = salt `hashWithSalt` M.toList m- 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 DatabaseContextIOExprBase a =-  AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |+  AddAtomFunction FunctionName [TypeConstructor] FunctionBodyScript |   LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |-  AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |+  AddDatabaseContextFunction FunctionName [TypeConstructor] FunctionBodyScript |   LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |   CreateArbitraryRelation RelVarName [AttributeExprBase a] Range                            deriving (Show, Eq, Generic)@@ -449,7 +472,7 @@ -- | An atom expression represents an action to take when extending a relation or when statically defining a relation or a new tuple. data AtomExprBase a = AttributeAtomExpr AttributeName |                       NakedAtomExpr Atom |-                      FunctionAtomExpr AtomFunctionName [AtomExprBase a] a |+                      FunctionAtomExpr FunctionName [AtomExprBase a] a |                       RelationAtomExpr (RelationalExprBase a) |                       ConstructedAtomExpr DataConstructorName [AtomExprBase a] a                     deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable)@@ -457,7 +480,7 @@ -- | Used in tuple creation when creating a relation. data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)                      deriving (Show, Read, Eq, Generic, NFData, Foldable, Functor, Traversable)-                              + type ExtendTupleExpr = ExtendTupleExprBase ()  instance Hashable ExtendTupleExpr@@ -466,42 +489,14 @@  --enumerates the list of functions available to be run as part of tuple expressions            type AtomFunctions = HS.HashSet AtomFunction--type AtomFunctionName = StringType--type AtomFunctionBodyScript = StringType- type AtomFunctionBodyType = [Atom] -> Either AtomFunctionError Atom+type ObjectFileEntryFunctionName = String -data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType-  deriving Generic+type ObjectFilePath = FilePath -instance NFData AtomFunctionBody where-  rnf (AtomFunctionBody mScript _) = rnf mScript-                        -instance Show AtomFunctionBody where-  show (AtomFunctionBody mScript _) = case mScript of-    Just script -> show (unpack script)-    Nothing -> "<compiled>"+type ObjectModuleName = String  -- | An AtomFunction has a name, a type, and a function body to execute when called.-data AtomFunction = AtomFunction {-  atomFuncName :: AtomFunctionName,-  atomFuncType :: [AtomType], -  atomFuncBody :: AtomFunctionBody-  } deriving (Generic, NFData)-                          -instance Hashable AtomFunction where-  hashWithSalt salt func = salt `hashWithSalt` atomFuncName func-                           -instance Eq AtomFunction where                           -  f1 == f2 = atomFuncName f1 == atomFuncName f2 -  -instance Show AtomFunction where  -  show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes ++ "; " ++ body-   where-     body = show (atomFuncBody aFunc)-     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 AttributeNamesBase a = AttributeNames (S.Set AttributeName) |@@ -511,13 +506,10 @@                             RelationalExprAttributeNames (RelationalExprBase a) -- use attribute names from the relational expression's type                       deriving (Eq, Show, Read, Generic, NFData, Foldable, Functor, Traversable) -instance Hashable AttributeNames--instance Hashable (S.Set AttributeName) where-  hashWithSalt salt s = salt `hashWithSalt` S.toList s-                                type AttributeNames = AttributeNamesBase () +instance Hashable AttributeNames+ type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker  -- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.@@ -525,6 +517,11 @@                            MinimalPersistence FilePath | -- ^ fsync off, not crash-safe                            CrashSafePersistence FilePath -- ^ full fsync to disk (flushes kernel and physical drive buffers to ensure that the transaction is on non-volatile storage)                            deriving (Show, Read)++persistenceDirectory :: PersistenceStrategy -> Maybe FilePath+persistenceDirectory NoPersistence = Nothing+persistenceDirectory (MinimalPersistence f) = Just f+persistenceDirectory (CrashSafePersistence f) = Just f                                      type AttributeExpr = AttributeExprBase () type GraphRefAttributeExpr = AttributeExprBase GraphRefTransactionMarker@@ -562,31 +559,50 @@   SelectedBranchMergeStrategy HeadName                      deriving (Eq, Show, Generic, NFData) -type DatabaseContextFunctionName = StringType -type DatabaseContextFunctionBodyScript = StringType  type DatabaseContextFunctionBodyType = [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext+type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction -data DatabaseContextFunctionBody = DatabaseContextFunctionBody (Maybe DatabaseContextFunctionBodyScript) DatabaseContextFunctionBodyType +type FunctionName = StringType+type FunctionBodyScript = StringType -instance NFData DatabaseContextFunctionBody where-  rnf (DatabaseContextFunctionBody mScript _) = rnf mScript+-- | Represents stored, user-created or built-in functions which can operates of types such as Atoms or DatabaseContexts.+data Function a = Function {+  funcName :: FunctionName,+  funcType :: [AtomType],+  funcBody :: FunctionBody a+  }+  deriving (Generic, NFData) -data DatabaseContextFunction = DatabaseContextFunction {-  dbcFuncName :: DatabaseContextFunctionName,-  dbcFuncType :: [AtomType],-  dbcFuncBody :: DatabaseContextFunctionBody-  } deriving (Generic, NFData)-                               -type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction+instance Eq (Function a) where                           +  f1 == f2 = funcName f1 == funcName f2 -instance Hashable DatabaseContextFunction where-  hashWithSalt salt func = salt `hashWithSalt` dbcFuncName func-                           -instance Eq DatabaseContextFunction where                           -  f1 == f2 = dbcFuncName f1 == dbcFuncName f2 +instance Hashable (Function a) where+  hashWithSalt salt func = salt `hashWithSalt` funcName func `hashWithSalt` funcType func `hashWithSalt` funcBody func +data FunctionBody a =+  FunctionScriptBody FunctionBodyScript a |+  FunctionBuiltInBody a |+  FunctionObjectLoadedBody FilePath ObjectModuleName ObjectFileEntryFunctionName a+  deriving Generic++instance Hashable (FunctionBody a) where+  salt `hashWithSalt` (FunctionScriptBody script _) = salt `hashWithSalt` script+  salt `hashWithSalt` (FunctionBuiltInBody _) = salt+  salt `hashWithSalt` (FunctionObjectLoadedBody fp modName entryFunc _) = salt `hashWithSalt` (fp, modName, entryFunc)++instance NFData a => NFData (FunctionBody a) where+  rnf (FunctionScriptBody script _) = rnf script+  rnf (FunctionBuiltInBody _) = rnf ()+  rnf (FunctionObjectLoadedBody fp mod' entryf _) = rnf (fp, mod', entryf)++type AtomFunction = Function AtomFunctionBodyType+type AtomFunctionBody = FunctionBody AtomFunctionBodyType++type DatabaseContextFunction = Function DatabaseContextFunctionBodyType+type DatabaseContextFunctionBody = FunctionBody DatabaseContextFunctionBodyType+ attrTypeVars :: Attribute -> S.Set TypeVarName attrTypeVars (Attribute _ aType) = case aType of   IntAtomType -> S.empty@@ -597,8 +613,9 @@   DateTimeAtomType -> S.empty   ByteStringAtomType -> S.empty   BoolAtomType -> S.empty+  UUIDAtomType -> S.empty   RelationalExprAtomType -> S.empty-  (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList attrs))+  (RelationAtomType attrs) -> S.unions (map attrTypeVars (V.toList (attributesVec attrs)))   (ConstructedAtomType _ tvMap) -> M.keysSet tvMap   (TypeVariableType nam) -> S.singleton nam   @@ -621,14 +638,15 @@ atomTypeVars DateTimeAtomType = S.empty atomTypeVars ByteStringAtomType = S.empty atomTypeVars BoolAtomType = S.empty+atomTypeVars UUIDAtomType = S.empty atomTypeVars RelationalExprAtomType = S.empty-atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList attrs))+atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList (attributesVec attrs))) atomTypeVars (ConstructedAtomType _ tvMap) = M.keysSet tvMap atomTypeVars (TypeVariableType nam) = S.singleton nam  unimplemented :: HasCallStack => a-unimplemented = undefined----for serializing GraphRefRelationalExpr as part of transaction serialization+unimplemented = error "unimplemented"            +makeBaseFunctor ''RelationalExprBase+
src/lib/ProjectM36/Client.hs view
@@ -141,7 +141,6 @@ import Data.UUID.V4 (nextRandom) import Data.Word import Data.Hashable-import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception) import Control.Concurrent.MVar import Codec.Winery hiding (Schema, schema) import qualified Data.Map as M@@ -248,7 +247,7 @@ createScriptSession ghcPkgPaths = do   eScriptSession <- initScriptSession ghcPkgPaths   case eScriptSession of-    Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled+    Left err -> hPutStrLn stderr ("Warning: Haskell scripting disabled: " ++ show err) >> pure Nothing --not a fatal error, but the scripting feature must be disabled     Right s -> pure (Just s)  @@ -297,16 +296,18 @@              \(NotificationMessage notifications') ->                forM_ (M.toList notifications') (uncurry notificationCallback)             ]--- TODO  missing async callback-      conn <- RPC.connect notificationHandlers (hostAddressToTuple addr) port-      eRet <- RPC.call conn (Login dbName)--- TODO handle connection errors              -      case eRet of-        Left err -> error (show err)-        Right False -> error "wtf"-        Right True ->+      let connectExcHandler (e :: IOException) = pure $ Left (IOExceptionError e)+      eConn <- (Right <$> RPC.connect notificationHandlers (hostAddressToTuple addr) port) `catch` connectExcHandler+      case eConn of+        Left err -> pure (Left err)+        Right conn -> do+          eRet <- RPC.call conn (Login dbName)+          case eRet of+            Left err -> error (show err)+            Right False -> error "wtf"+            Right True ->       --TODO handle connection errors!-          pure (Right (RemoteConnection (RemoteConnectionConf conn)))+              pure (Right (RemoteConnection (RemoteConnectionConf conn)))  --convert RPC errors into exceptions convertRPCErrors :: RPC.ConnectionError -> IO a@@ -382,7 +383,7 @@     case RE.transactionForId commitId graph of         Left err -> pure (Left err)         Right transaction -> do-            let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) False+            let freshDiscon = DisconnectedTransaction commitId (Discon.loadGraphRefRelVarsOnly commitId (Trans.schemas transaction)) False             keyDuplication <- StmMap.lookup newSessionId sessions             case keyDuplication of                 Just _ -> pure $ Left (SessionIdInUseError newSessionId)@@ -598,7 +599,8 @@     Left err -> pure (Left err)     Right session -> do       graph <- readTVarIO (ipTransactionGraph conf)-      let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession+      let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession objFilesPath+          objFilesPath = objectFilesPath <$> persistenceDirectory (ipPersistenceStrategy conf)           transId = Sess.parentId session           context = Sess.concreteDatabaseContext session       res <- RE.runDatabaseContextIOEvalMonad env context (optimizeAndEvalDatabaseContextIOExpr expr)
src/lib/ProjectM36/Client/Simple.hs view
@@ -31,7 +31,6 @@   ) where  import Control.Exception.Base-import Control.Monad ((<=<)) import Control.Monad.Reader import ProjectM36.Base import qualified ProjectM36.Client as C
src/lib/ProjectM36/DataFrame.hs view
@@ -2,7 +2,7 @@ {- A dataframe is a strongly-typed, ordered list of named tuples. A dataframe differs from a relation in that its tuples are ordered.-} module ProjectM36.DataFrame where import ProjectM36.Base-import ProjectM36.Attribute as A+import ProjectM36.Attribute as A hiding (drop) import ProjectM36.Error import qualified ProjectM36.Relation as R import ProjectM36.Relation.Show.Term@@ -81,7 +81,7 @@         Right atom2 -> compareAtoms atom1 atom2  atomForAttributeName :: AttributeName -> DataFrameTuple -> Either RelationalError Atom-atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of+atomForAttributeName attrName (DataFrameTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) (attributesVec tupAttrs) of   Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))   Just index -> case tupVec V.!? index of     Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))@@ -134,12 +134,12 @@ dataFrameAsHTML :: DataFrame -> T.Text -- web browsers don't display tables with empty cells or empty headers, so we have to insert some placeholders- it's not technically the same, but looks as expected in the browser dataFrameAsHTML df -  | length (tuples df) == 1 && L.null (attributes df) = style <>+  | length (tuples df) == 1 && A.null (attributes df) = style <>                           tablestart <>                           "<tr><th></th></tr>" <>                           "<tr><td></td></tr>" <>                            tablefooter <> "</table>"-  | L.null (tuples df) && L.null (attributes df) = style <>+  | L.null (tuples df) && A.null (attributes df) = style <>                            tablestart <>                            "<tr><th></th></tr>" <>                            tablefooter <> @@ -162,7 +162,7 @@     folder tuple acc = acc <> tupleAsHTML tuple  tupleAssocs :: DataFrameTuple -> [(AttributeName, Atom)]-tupleAssocs (DataFrameTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)+tupleAssocs (DataFrameTuple attrs tupVec) = V.toList $ V.map (first attributeName) (V.zip (attributesVec attrs) tupVec)       tupleAsHTML :: DataFrameTuple -> T.Text@@ -174,7 +174,7 @@     atomAsHTML atom = atomToText atom  attributesAsHTML :: Attributes -> [AttributeOrder] -> T.Text-attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"+attributesAsHTML attrs orders' = "<tr>" <> T.concat (map oneAttrHTML (A.toList attrs)) <> "</tr>"   where     oneAttrHTML attr = "<th>" <> prettyAttribute attr <> ordering (attributeName attr) <> "</th>"     ordering attrName = " " <> case L.find (\(AttributeOrder nam _) -> nam == attrName) orders' of
src/lib/ProjectM36/DataTypes/ByteString.hs view
@@ -8,9 +8,9 @@  bytestringAtomFunctions :: AtomFunctions bytestringAtomFunctions = HS.fromList [-  AtomFunction { atomFuncName = "bytestring",-                 atomFuncType = [TextAtomType, ByteStringAtomType],-                 atomFuncBody = compiledAtomFunctionBody $ \(TextAtom textIn:_) -> case B64.decode (TE.encodeUtf8 textIn) of+  Function { funcName = "bytestring",+             funcType = [TextAtomType, ByteStringAtomType],+             funcBody = compiledAtomFunctionBody $ \(TextAtom textIn:_) -> case B64.decode (TE.encodeUtf8 textIn) of                    Left err -> Left (AtomFunctionBytesDecodingError err)                    Right bs -> pure (ByteStringAtom bs)                 }
src/lib/ProjectM36/DataTypes/DateTime.hs view
@@ -5,10 +5,10 @@ import Data.Time.Clock.POSIX  dateTimeAtomFunctions :: AtomFunctions-dateTimeAtomFunctions = HS.fromList [ AtomFunction {-                                     atomFuncName = "dateTimeFromEpochSeconds",-                                     atomFuncType = [IntegerAtomType, DateTimeAtomType],-                                     atomFuncBody = compiledAtomFunctionBody $ \(IntegerAtom epoch:_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))+dateTimeAtomFunctions = HS.fromList [ Function {+                                     funcName = "dateTimeFromEpochSeconds",+                                     funcType = [IntegerAtomType, DateTimeAtomType],+                                     funcBody = compiledAtomFunctionBody $ \(IntegerAtom epoch:_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))                                                                                                        }]
src/lib/ProjectM36/DataTypes/Day.hs view
@@ -6,12 +6,12 @@  dayAtomFunctions :: AtomFunctions dayAtomFunctions = HS.fromList [-  AtomFunction { atomFuncName = "fromGregorian",-                 atomFuncType = [IntegerAtomType, IntegerAtomType, IntegerAtomType, DayAtomType],-                 atomFuncBody = compiledAtomFunctionBody $ \(IntegerAtom year:IntegerAtom month:IntegerAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))+  Function { funcName = "fromGregorian",+                 funcType = [IntegerAtomType, IntegerAtomType, IntegerAtomType, DayAtomType],+                 funcBody = compiledAtomFunctionBody $ \(IntegerAtom year:IntegerAtom month:IntegerAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))                  },-  AtomFunction { atomFuncName = "dayEarlierThan",-                 atomFuncType = [DayAtomType, DayAtomType, BoolAtomType],-                 atomFuncBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB))+  Function { funcName = "dayEarlierThan",+                 funcType = [DayAtomType, DayAtomType, BoolAtomType],+                 funcBody = compiledAtomFunctionBody $ \(ConstructedAtom _ _ (IntAtom dayA:_):ConstructedAtom _ _ (IntAtom dayB:_):_) -> pure (BoolAtom (dayA < dayB))                }   ]
src/lib/ProjectM36/DataTypes/Interval.hs view
@@ -34,7 +34,8 @@   DayAtomType -> True                  DateTimeAtomType -> True   ByteStringAtomType -> False-  BoolAtomType -> False                         +  BoolAtomType -> False+  UUIDAtomType -> False   RelationAtomType _ -> False   ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this   RelationalExprAtomType -> False@@ -49,7 +50,8 @@   DayAtomType -> True                  DateTimeAtomType -> True   ByteStringAtomType -> False-  BoolAtomType -> False                         +  BoolAtomType -> False+  UUIDAtomType -> False   RelationAtomType _ -> False   RelationalExprAtomType -> False   ConstructedAtomType _ _ -> False --once we support an interval-style typeclass, we might enable this@@ -92,25 +94,25 @@  intervalAtomFunctions :: AtomFunctions intervalAtomFunctions = HS.fromList [-  AtomFunction { atomFuncName = "interval",-                 atomFuncType = [TypeVariableType "a",-                                 TypeVariableType "a",-                                 BoolAtomType,-                                 BoolAtomType,-                                 intervalAtomType (TypeVariableType "a")],-                 atomFuncBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do+  Function { funcName = "interval",+             funcType = [TypeVariableType "a",+                          TypeVariableType "a",+                          BoolAtomType,+                          BoolAtomType,+                          intervalAtomType (TypeVariableType "a")],+             funcBody = compiledAtomFunctionBody $ \(atom1:atom2:BoolAtom bopen:BoolAtom eopen:_) -> do                    let aType = atomTypeForAtom atom1                     if supportsInterval aType then                      createInterval atom1 atom2 bopen eopen                      else                      Left (AtomTypeDoesNotSupportIntervalError (prettyAtomType aType))                },-  AtomFunction {-    atomFuncName = "interval_overlaps",-    atomFuncType = [intervalAtomType (TypeVariableType "a"),+  Function {+    funcName = "interval_overlaps",+    funcType = [intervalAtomType (TypeVariableType "a"),                     intervalAtomType (TypeVariableType "a"),                     BoolAtomType],-    atomFuncBody = compiledAtomFunctionBody $ \(i1@ConstructedAtom{}:i2@ConstructedAtom{}:_) -> +    funcBody = compiledAtomFunctionBody $ \(i1@ConstructedAtom{}:i2@ConstructedAtom{}:_) ->        BoolAtom <$> intervalOverlaps i1 i2     }]
src/lib/ProjectM36/DataTypes/List.hs view
@@ -34,16 +34,16 @@  listAtomFunctions :: AtomFunctions listAtomFunctions = HS.fromList [-  AtomFunction {-     atomFuncName = "length",-     atomFuncType = [listAtomType (TypeVariableType "a"), IntAtomType],-     atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) ->+  Function {+     funcName = "length",+     funcType = [listAtomType (TypeVariableType "a"), IntAtomType],+     funcBody = FunctionBuiltInBody (\(listAtom:_) ->                                                  IntAtom . fromIntegral <$> listLength listAtom)      },-  AtomFunction {-    atomFuncName = "maybeHead",-    atomFuncType = [listAtomType (TypeVariableType "a"), maybeAtomType (TypeVariableType "a")],-    atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> listMaybeHead listAtom)+  Function {+    funcName = "maybeHead",+    funcType = [listAtomType (TypeVariableType "a"), maybeAtomType (TypeVariableType "a")],+    funcBody = FunctionBuiltInBody (\(listAtom:_) -> listMaybeHead listAtom)     }   ]
src/lib/ProjectM36/DataTypes/Maybe.hs view
@@ -16,15 +16,15 @@  maybeAtomFunctions :: AtomFunctions maybeAtomFunctions = HS.fromList [-  AtomFunction {-     atomFuncName ="isJust",-     atomFuncType = [maybeAtomType (TypeVariableType "a"), BoolAtomType],-     atomFuncBody = AtomFunctionBody Nothing $ \(ConstructedAtom dConsName _ _:_) -> pure $ BoolAtom (dConsName /= "Nothing")+  Function {+     funcName ="isJust",+     funcType = [maybeAtomType (TypeVariableType "a"), BoolAtomType],+     funcBody = FunctionBuiltInBody $ \(ConstructedAtom dConsName _ _:_) -> pure $ BoolAtom (dConsName /= "Nothing")      },-  AtomFunction {-     atomFuncName = "fromMaybe",-     atomFuncType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "a"],-     atomFuncBody = AtomFunctionBody Nothing $ \(defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal+  Function {+     funcName = "fromMaybe",+     funcType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "a"],+     funcBody = FunctionBuiltInBody $ \(defaultAtom:ConstructedAtom dConsName _ (atomVal:_):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal      }   ]
src/lib/ProjectM36/DataTypes/NonEmptyList.hs view
@@ -39,15 +39,15 @@  nonEmptyListAtomFunctions :: AtomFunctions nonEmptyListAtomFunctions = HS.fromList [-  AtomFunction {-     atomFuncName = "nonEmptyListLength",-     atomFuncType = [nonEmptyListAtomType (TypeVariableType "a"), IntAtomType],-     atomFuncBody = AtomFunctionBody Nothing (\(nonEmptyListAtom:_) ->+  Function {+     funcName = "nonEmptyListLength",+     funcType = [nonEmptyListAtomType (TypeVariableType "a"), IntAtomType],+     funcBody = FunctionBuiltInBody (\(nonEmptyListAtom:_) ->                                                  IntAtom . fromIntegral <$> nonEmptyListLength nonEmptyListAtom)      },-  AtomFunction {-    atomFuncName = "nonEmptyListHead",-    atomFuncType = [nonEmptyListAtomType (TypeVariableType "a"), TypeVariableType "a"],-    atomFuncBody = AtomFunctionBody Nothing (\(nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom)+  Function {+    funcName = "nonEmptyListHead",+    funcType = [nonEmptyListAtomType (TypeVariableType "a"), TypeVariableType "a"],+    funcBody = FunctionBuiltInBody (\(nonEmptyListAtom:_) -> nonEmptyListHead nonEmptyListAtom)     }   ]
src/lib/ProjectM36/DataTypes/Primitive.hs view
@@ -10,6 +10,7 @@              ("Text", TextAtomType),              ("Double", DoubleAtomType),              ("Bool", BoolAtomType),+             ("UUID", UUIDAtomType),              ("ByteString", ByteStringAtomType),              ("DateTime", DateTimeAtomType),              ("Day", DayAtomType)@@ -30,6 +31,9 @@ dateTimeTypeConstructor :: TypeConstructor dateTimeTypeConstructor = PrimitiveTypeConstructor "DateTime" DayAtomType +uUIDTypeConstructor :: TypeConstructor+uUIDTypeConstructor = PrimitiveTypeConstructor "UUID" UUIDAtomType+ -- | Return the type of an 'Atom'. atomTypeForAtom :: Atom -> AtomType atomTypeForAtom (IntAtom _) = IntAtomType@@ -40,6 +44,7 @@ atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType atomTypeForAtom (BoolAtom _) = BoolAtomType+atomTypeForAtom (UUIDAtom _) = UUIDAtomType atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs atomTypeForAtom (ConstructedAtom _ aType _) = aType atomTypeForAtom (RelationalExprAtom _) = RelationalExprAtomType
src/lib/ProjectM36/DataTypes/Sorting.hs view
@@ -10,6 +10,7 @@ compareAtoms (DateTimeAtom d1) (DateTimeAtom d2) = compare d1 d2 compareAtoms (ByteStringAtom b1) (ByteStringAtom b2) = compare b1 b2 compareAtoms (BoolAtom b1) (BoolAtom b2) = compare b1 b2+compareAtoms (UUIDAtom u1) (UUIDAtom u2) = compare u1 u2 compareAtoms (RelationAtom _) _ = EQ compareAtoms ConstructedAtom{} _ = EQ compareAtoms _ _ = EQ@@ -24,6 +25,7 @@   DateTimeAtomType -> True   ByteStringAtomType -> False   BoolAtomType -> True+  UUIDAtomType -> False   RelationalExprAtomType -> False   RelationAtomType _ -> False   ConstructedAtomType _ _ -> False
src/lib/ProjectM36/DatabaseContext.hs view
@@ -7,9 +7,9 @@ import ProjectM36.AtomFunctions.Basic import ProjectM36.Relation import qualified Data.ByteString.Lazy as BL-import ProjectM36.AtomFunction as AF-import ProjectM36.DatabaseContextFunction as DBCF+import ProjectM36.DatabaseContextFunction import Codec.Winery+import ProjectM36.Function as F  empty :: DatabaseContext empty = DatabaseContext { inclusionDependencies = M.empty, @@ -48,7 +48,7 @@   where     incDeps = serialise (inclusionDependencies ctx)     rvs = serialise (relationVariables ctx)-    atomFs = HS.foldr (mappend . AF.hashBytes) mempty (atomFunctions ctx)-    dbcFs = HS.foldr (mappend . DBCF.hashBytes) mempty (dbcFunctions ctx)+    atomFs = HS.foldr (mappend . F.hashBytes) mempty (atomFunctions ctx)+    dbcFs = HS.foldr (mappend . F.hashBytes) mempty (dbcFunctions ctx)     nots = serialise (notifications ctx)     tConsMap = serialise (typeConstructorMapping ctx)
src/lib/ProjectM36/DatabaseContextFunction.hs view
@@ -7,40 +7,44 @@ import ProjectM36.Attribute as A import ProjectM36.Relation import ProjectM36.AtomType+import ProjectM36.Function import qualified Data.HashSet as HS import qualified Data.Map as M-import ProjectM36.ScriptSession import qualified Data.Text as T-import qualified Data.ByteString.Lazy as BL-import Codec.Winery+import Data.Maybe (isJust) -emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction-emptyDatabaseContextFunction name = DatabaseContextFunction { -  dbcFuncName = name,-  dbcFuncType = [],-  dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure ctx)+externalDatabaseContextFunction :: DatabaseContextFunctionBodyType -> DatabaseContextFunctionBody+externalDatabaseContextFunction = FunctionBuiltInBody++emptyDatabaseContextFunction :: FunctionName -> DatabaseContextFunction+emptyDatabaseContextFunction name = Function { +  funcName = name,+  funcType = [],+  funcBody = FunctionBuiltInBody (\_ ctx -> pure ctx)   } -databaseContextFunctionForName :: DatabaseContextFunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction-databaseContextFunctionForName funcName funcs = if HS.null foundFunc then-                                                   Left $ NoSuchFunctionError funcName+databaseContextFunctionForName :: FunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction+databaseContextFunctionForName funcName' funcs = if HS.null foundFunc then+                                                   Left $ NoSuchFunctionError funcName'                                                 else                                                   Right (head (HS.toList foundFunc))   where-    foundFunc = HS.filter (\(DatabaseContextFunction name _ _) -> name == funcName) funcs+    foundFunc = HS.filter (\f -> funcName f == funcName') funcs  evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext-evalDatabaseContextFunction func args ctx = case dbcFuncBody func of-  (DatabaseContextFunctionBody _ f) -> case f args ctx of+evalDatabaseContextFunction func args ctx =+  case f args ctx of     Left err -> Left (DatabaseContextFunctionUserError err)     Right c -> pure c-  +  where+   f = function (funcBody func)+    basicDatabaseContextFunctions :: DatabaseContextFunctions basicDatabaseContextFunctions = HS.fromList [-  DatabaseContextFunction { dbcFuncName = "deleteAll",-                            dbcFuncType = [],-                            dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure $ ctx { relationVariables = M.empty })-                          }+  Function { funcName = "deleteAll",+             funcType = [],+             funcBody = FunctionBuiltInBody (\_ ctx -> pure $ ctx { relationVariables = M.empty })+           }   ]                                  --the precompiled functions are special because they cannot be serialized. Their names are therefore used in perpetuity so that the functions can be "serialized" (by name).@@ -48,28 +52,15 @@ precompiledDatabaseContextFunctions = HS.filter (not . isScriptedDatabaseContextFunction) basicDatabaseContextFunctions                                  isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool-isScriptedDatabaseContextFunction func = case dbcFuncBody func of-  DatabaseContextFunctionBody (Just _) _ -> True-  DatabaseContextFunctionBody Nothing _ -> False-  -databaseContextFunctionScript :: DatabaseContextFunction -> Maybe DatabaseContextFunctionBodyScript-databaseContextFunctionScript func = case dbcFuncBody func of-  DatabaseContextFunctionBody script _ -> script+isScriptedDatabaseContextFunction func = isJust (functionScript func)    databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [   ADTypeConstructor "DatabaseContextFunctionError" [],   tCons]                                           -createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr-createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])--loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction])-#ifdef PM36_HASKELL_SCRIPTING-loadDatabaseContextFunctions = loadFunction-#else-loadDatabaseContextFunctions _ _ _ = pure (Left LoadSymbolError)-#endif+createScriptedDatabaseContextFunction :: FunctionName -> [TypeConstructor] -> TypeConstructor -> FunctionBodyScript -> DatabaseContextIOExpr+createScriptedDatabaseContextFunction funcName' argsIn retArg = AddDatabaseContextFunction funcName' (argsIn ++ [databaseContextFunctionReturnType retArg])  databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups@@ -77,15 +68,7 @@     attrs = A.attributesFromList [Attribute "name" TextAtomType,                                   Attribute "arguments" TextAtomType]     tups = map dbcFuncToTuple (HS.toList dbcFuncs)-    dbcFuncToTuple func = [TextAtom (dbcFuncName func),-                           TextAtom (dbcTextType (dbcFuncType func))]+    dbcFuncToTuple func = [TextAtom (funcName func),+                           TextAtom (dbcTextType (funcType func))]     dbcTextType typ = T.intercalate " -> " (map prettyAtomType typ ++ ["DatabaseContext", "DatabaseContext"]) --- for merkle hash                       -hashBytes :: DatabaseContextFunction -> BL.ByteString-hashBytes func = BL.fromChunks [fname, ftype, fbody]-  where-    fname = serialise (dbcFuncName func)-    ftype = serialise (dbcFuncType func)-    fbody = case dbcFuncBody func of-      DatabaseContextFunctionBody mBody _ -> serialise mBody
src/lib/ProjectM36/DisconnectedTransaction.hs view
@@ -1,11 +1,20 @@ module ProjectM36.DisconnectedTransaction where import ProjectM36.Base+import Data.Map  concreteDatabaseContext :: DisconnectedTransaction -> DatabaseContext concreteDatabaseContext (DisconnectedTransaction _ (Schemas context _) _) = context  schemas :: DisconnectedTransaction -> Schemas schemas (DisconnectedTransaction _ s _) = s++loadGraphRefRelVarsOnly :: TransactionId -> Schemas -> Schemas+loadGraphRefRelVarsOnly commitId (Schemas ctx@(DatabaseContext _ rv _ _ _ _) subschemas) = +  let f k _ = RelationVariable k (TransactionMarker commitId)+      ctx' = ctx { relationVariables = mapWithKey f rv}+  in Schemas ctx' subschemas++  parentId :: DisconnectedTransaction -> TransactionId parentId (DisconnectedTransaction pid _ _) = pid
src/lib/ProjectM36/Error.hs view
@@ -25,7 +25,7 @@                      | RelVarNotDefinedError RelVarName                      | RelVarAlreadyDefinedError RelVarName                      | RelationTypeMismatchError Attributes Attributes --expected, found-                     | InclusionDependencyCheckError IncDepName+                     | InclusionDependencyCheckError IncDepName (Maybe RelationalError)                      | InclusionDependencyNameInUseError IncDepName                      | InclusionDependencyNameNotInUseError IncDepName                      | ParseError T.Text@@ -45,7 +45,7 @@                      | NoSuchSessionError TransactionId                      | FailedToFindTransactionError TransactionId                      | TransactionIdInUseError TransactionId-                     | NoSuchFunctionError AtomFunctionName+                     | NoSuchFunctionError FunctionName                      | NoSuchTypeConstructorName TypeConstructorName                      | TypeConstructorAtomTypeMismatch TypeConstructorName AtomType                      | AtomTypeMismatchError AtomType AtomType@@ -57,14 +57,14 @@                      | TypeConstructorTypeVarMissing TypeVarName                      | TypeConstructorTypeVarsTypesMismatch TypeConstructorName TypeVarMap TypeVarMap                      | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap-                     | AtomFunctionTypeVariableResolutionError AtomFunctionName TypeVarName+                     | AtomFunctionTypeVariableResolutionError FunctionName TypeVarName                      | AtomFunctionTypeVariableMismatch TypeVarName AtomType AtomType                      | AtomTypeNameInUseError AtomTypeName                      | IncompletelyDefinedAtomTypeWithConstructorError                      | AtomTypeNameNotInUseError AtomTypeName                      | AttributeNotSortableError Attribute-                     | FunctionNameInUseError AtomFunctionName-                     | FunctionNameNotInUseError AtomFunctionName+                     | FunctionNameInUseError FunctionName+                     | FunctionNameNotInUseError FunctionName                      | EmptyCommitError                      | FunctionArgumentCountMismatchError Int Int                      | ConstructedAtomArgumentCountMismatchError Int Int@@ -75,18 +75,19 @@                      | AtomOperatorNotSupported T.Text --used by persistent driver                      | EmptyTuplesError -- used by persistent driver                      | AtomTypeCountError [AtomType] [AtomType]-                     | AtomFunctionTypeError AtomFunctionName Int AtomType AtomType --arg number+                     | AtomFunctionTypeError FunctionName Int AtomType AtomType --arg number                      | AtomFunctionUserError AtomFunctionError-                     | PrecompiledFunctionRemoveError AtomFunctionName -- pre-compiled atom functions cannot be serialized, so they cannot change over time- they are referred to in perpetuity+                     | PrecompiledFunctionRemoveError FunctionName -- pre-compiled atom functions cannot be serialized, so they cannot change over time- they are referred to in perpetuity                      | RelationValuedAttributesNotSupportedError [AttributeName]                      | NotificationNameInUseError NotificationName                      | NotificationNameNotInUseError NotificationName-                     | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra+                     | ImportError ImportError'                      | ExportError T.Text                      | UnhandledExceptionError String                      | MergeTransactionError MergeError                      | ScriptError ScriptCompilationError                      | LoadFunctionError+                     | SecurityLoadFunctionError                      | DatabaseContextFunctionUserError DatabaseContextFunctionError                      | DatabaseLoadError PersistenceError                        @@ -144,4 +145,12 @@                    RelVarInReferencedMoreThanOnce RelVarName |                    RelVarOutReferencedMoreThanOnce RelVarName                    deriving (Show, Eq, Generic, Typeable, NFData)-                           +++data ImportError' = InvalidSHA256Error T.Text+                  | SHA256MismatchError T.Text T.Text+                  | InvalidFileURIError T.Text+                  | ImportFileDecodeError T.Text+                  | ImportFileError T.Text+                  | ImportDownloadError T.Text+                  deriving (Show, Eq, Generic, Typeable, NFData)
+ src/lib/ProjectM36/Function.hs view
@@ -0,0 +1,71 @@+-- | Module for functionality common between the various Function types (AtomFunction, DatabaseContextFunction).+module ProjectM36.Function where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.Serialise.Base ()+import ProjectM36.ScriptSession+import qualified Data.ByteString.Lazy as BL+import Codec.Winery+import qualified Data.HashSet as HS++-- for merkle hash                       +hashBytes :: Function a -> BL.ByteString+hashBytes func = BL.fromChunks [fname, ftype, fbody]+  where+    fname = serialise (funcName func)+    ftype = serialise (funcType func)+    fbody = case funcBody func of+      FunctionScriptBody s _ -> serialise s+      FunctionBuiltInBody _ -> serialise ()+      FunctionObjectLoadedBody a b c _ -> serialise (a,b,c)++-- | Return the underlying function to run the Function.+function :: FunctionBody a -> a+function (FunctionScriptBody _ f) = f+function (FunctionBuiltInBody f) = f+function (FunctionObjectLoadedBody _ _ _ f) = f++-- | Return the text-based Haskell script, if applicable.+functionScript :: Function a -> Maybe FunctionBodyScript+functionScript func = case funcBody func of+  FunctionScriptBody script _ -> Just script+  _ -> Nothing++-- | Change atom function definition to reference proper object file source. Useful when moving the object file into the database directory.+processObjectLoadedFunctionBody :: ObjectModuleName -> ObjectFileEntryFunctionName -> FilePath -> FunctionBody a -> FunctionBody a+processObjectLoadedFunctionBody modName fentry objPath body =+  FunctionObjectLoadedBody objPath modName fentry f+  where+    f = function body++processObjectLoadedFunctions :: Functor f => ObjectModuleName -> ObjectFileEntryFunctionName -> FilePath -> f (Function a) -> f (Function a)+processObjectLoadedFunctions modName entryName path =+  fmap (\f -> f { funcBody = processObjectLoadedFunctionBody modName entryName path (funcBody f) } )++loadFunctions :: ModName -> FuncName -> Maybe FilePath -> FilePath -> IO (Either LoadSymbolError [Function a])+#ifdef PM36_HASKELL_SCRIPTING+loadFunctions modName funcName' mModDir objPath =+  case mModDir of+    Just modDir -> do+      eNewFs <- loadFunctionFromDirectory LoadAutoObjectFile modName funcName' modDir objPath+      case eNewFs of+        Left err -> pure (Left err)+        Right newFs ->+          pure (Right (processFuncs newFs))+    Nothing -> do+      loadFunction LoadAutoObjectFile modName funcName' objPath+ where+   --functions inside object files probably won't have the right function body metadata+   processFuncs = map processor+   processor newF = newF { funcBody = processObjectLoadedFunctionBody modName funcName' objPath (funcBody newF)}+#else+loadFunctions _ _ _ _ = pure (Left LoadSymbolError)+#endif++functionForName :: FunctionName -> HS.HashSet (Function a) -> Either RelationalError (Function a)+functionForName funcName' funcSet = if HS.null foundFunc then+                                         Left $ NoSuchFunctionError funcName'+                                        else+                                         Right $ head $ HS.toList foundFunc+  where+    foundFunc = HS.filter (\f -> funcName f == funcName') funcSet
src/lib/ProjectM36/NormalizeExpr.hs view
@@ -75,8 +75,8 @@     RemoveTypeConstructor tyName -> pure (RemoveTypeConstructor tyName)      RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)-    RemoveDatabaseContextFunction funcName -> pure (RemoveDatabaseContextFunction funcName)-    ExecuteDatabaseContextFunction funcName atomExprs -> ExecuteDatabaseContextFunction funcName <$> mapM processAtomExpr atomExprs+    RemoveDatabaseContextFunction funcName' -> pure (RemoveDatabaseContextFunction funcName')+    ExecuteDatabaseContextFunction funcName' atomExprs -> ExecuteDatabaseContextFunction funcName' <$> mapM processAtomExpr atomExprs     MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs  processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr
src/lib/ProjectM36/Relation.hs view
@@ -9,7 +9,6 @@ import qualified ProjectM36.Attribute as A 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@@ -17,7 +16,6 @@ import Data.Either (isRight) import System.Random.Shuffle import Control.Monad.Random-import Data.List (sort)  attributes :: Relation -> Attributes attributes (Relation attrs _ ) = attrs@@ -35,7 +33,7 @@ atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs  mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation-mkRelationFromList attrs atomMatrix =+mkRelationFromList attrs atomMatrix = do   Relation attrs <$> mkTupleSetFromList attrs atomMatrix    emptyRelationWithAttrs :: Attributes -> Relation  @@ -43,11 +41,6 @@  mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation 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@@ -93,13 +86,12 @@   else     Right $ Relation attrs1 newtuples   where-    newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2)-      +    newtuples = tupleSetUnion attrs1 tupSet1 tupSet2+ 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)+  newTupleList <- mapM (tupleProject newAttrs) (asList tupSet)   pure (Relation newAttrs (RelationTupleSet (HS.toList (HS.fromList newTupleList))))  rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation@@ -154,7 +146,7 @@   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))+        Right rel2 -> RelationTuple (A.singleton groupAttr) (V.singleton (RelationAtom rel2))         Left _ -> undefined       mogrifier tupIn = pure (tupleExtend tupIn (matchingRelTuple tupIn))       newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes@@ -168,7 +160,8 @@ restrictEq tuple = restrict rfilter   where     rfilter :: RelationTuple -> Either RelationalError Bool-    rfilter tupleIn = pure (tupleIntersection tuple tupleIn == tuple)+    rfilter tupleIn = do+      pure (tupleIntersection tuple tupleIn == tuple)  -- unwrap relation-valued attribute -- return error if relval attrs and nongroup attrs overlap@@ -190,13 +183,13 @@ tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation tupleUngroup relvalAttrName newAttrs tuple = do   relvalRelation <- relationForAttributeName relvalAttrName tuple+  let nonGroupAttrs = A.intersection newAttrs (tupleAttributes tuple)+  nonGroupTupleProjection <- tupleProject nonGroupAttrs tuple+  let folder tupleIn acc = case acc of+        Left err -> Left err+        Right accRel ->+          union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])   relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation-  where-    nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple-    nonGroupAttrNames = A.attributeNameSet newAttrs-    folder tupleIn acc = case acc of-      Left err -> Left err-      Right accRel -> union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])  attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes attributesForRelval relvalAttrName (Relation attrs _) = do@@ -251,7 +244,8 @@  relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation relMogrify mapper newAttributes (Relation _ tupSet) = do-  newTuples <- mapM mapper (asList tupSet)  +  newTuples <- mapM (fmap (reorderTuple newAttributes) . mapper) (asList tupSet)+                       mkRelationFromTuples newAttributes newTuples  relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a@@ -297,7 +291,8 @@     dConsType = RelationAtomType subAttrs     tuples = map mkTypeConsDescription types     -    mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])+    mkTypeConsDescription (tCons, dConsList) =+      RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])          mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " (DCD.name dCons:map (T.pack . show) (DCD.fields dCons)))) dConsList of       Left err -> error ("mkRelationFromTuples pooped " ++ show err)
src/lib/ProjectM36/Relation/Parse/CSV.hs view
@@ -22,6 +22,7 @@ import Text.Read hiding (parens) import Control.Applicative import Data.Either+import Control.Monad (void)  data CsvImportError = CsvParseError String |                       AttributeMappingError RelationalError |@@ -38,8 +39,7 @@     let strHeader = V.map decodeUtf8 headerRaw         strMapRecords = V.map convertMap vecMapsRaw         convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)-        attrNames = V.map A.attributeName attrs-        attrNameSet = S.fromList (V.toList attrNames)+        attrNameSet = A.attributeNameSet attrs         headerSet = S.fromList (V.toList strHeader)         parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType <* APT.endOfInput) textIn of           Left err -> Left (ParseError (T.pack err))@@ -47,7 +47,7 @@         makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]         makeTupleList tupMap = V.toList $ V.map (\attr ->                                                    either (Left . AttributeMappingError) Right $ -                                                  parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs+                                                  parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) (attributesVec attrs)     if attrNameSet == headerSet then do       tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)       case mkRelationFromList attrs tupleList of@@ -78,11 +78,16 @@   case readMaybe bsString of     Nothing -> fail ("invalid ByteString string: " ++ bsString)     Just bs -> pure (Right (ByteStringAtom bs))-parseCSVAtomP _ _ BoolAtomType = do    +parseCSVAtomP _ _ BoolAtomType = do   bString <- T.unpack <$> takeToEndOfData   case readMaybe bString of     Nothing -> fail ("invalid BoolAtom string: " ++ bString)     Just b -> pure (Right (BoolAtom b))+parseCSVAtomP _ _ UUIDAtomType = do+  uString <- T.unpack <$> takeToEndOfData+  case readMaybe uString of+    Nothing -> fail ("invalid UUIDAtom string: " ++ uString)+    Just u -> pure (Right (UUIDAtom u)) parseCSVAtomP _ _ RelationalExprAtomType = do   reString <- T.unpack <$> takeToEndOfData         case readMaybe reString of@@ -142,17 +147,18 @@    parens :: APT.Parser a -> APT.Parser a   parens p = do-  APT.skip (== '(')+  void $ APT.char '('   APT.skipSpace   v <- p   APT.skipSpace-  APT.skip (== ')')+  void $ APT.char ')'   pure v    quotedString :: APT.Parser T.Text quotedString = do   let escapeMap = [('"','"'), ('n', '\n'), ('r', '\r')]-  APT.skip (== '"')+      doubleQuote = void $ APT.char '"'+  doubleQuote         (_, s) <- APT.runScanner [] (\prevl nextChar -> case prevl of                              [] -> Just [nextChar]                              chars | last chars == '\\' ->@@ -161,6 +167,6 @@                                           Just escapeVal -> Just (init chars ++ [escapeVal]) -- nuke the backslash and add the escapeVal                                    | nextChar == '"' -> Nothing                                    | otherwise -> Just (chars ++ [nextChar]))-  APT.skip (== '"')+  doubleQuote   pure (T.pack s)
src/lib/ProjectM36/Relation/Show/CSV.hs view
@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module ProjectM36.Relation.Show.CSV where import ProjectM36.Base-import ProjectM36.Attribute+import ProjectM36.Attribute as A import Data.Csv import ProjectM36.Tuple import qualified Data.ByteString.Lazy as BS@@ -17,13 +17,13 @@   | relValAttrs /= [] =      Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs)  --check that there is at least one attribute    -  | V.null attrs =+  | A.null attrs =       Left $ TupleAttributeCountMismatchError 0   | otherwise =      Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet)   where-    relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs-    bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs+    relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) (attributesVec attrs)+    bsAttrNames = V.map (TE.encodeUtf8 . attributeName) (attributesVec attrs)  {- instance ToRecord RelationTuple where@@ -36,7 +36,7 @@   toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= RecordAtom v) (tupleAssocs $ unTuple rTuple)    instance DefaultOrdered RecordRelationTuple where  -  headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (tupleAttributes tuple)+  headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (attributesVec (tupleAttributes tuple))    newtype RecordAtom = RecordAtom {unAtom :: Atom}
src/lib/ProjectM36/Relation/Show/HTML.hs view
@@ -3,6 +3,7 @@ import ProjectM36.Relation import ProjectM36.Tuple import ProjectM36.Atom+import ProjectM36.Attribute as A import ProjectM36.AtomType import qualified Data.List as L import Data.Text (Text, pack)@@ -11,10 +12,9 @@ #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif-import qualified Data.Vector as V  attributesAsHTML :: Attributes -> Text-attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (V.toList attrs)) <> "</tr>"+attributesAsHTML attrs = "<tr>" <> T.concat (map oneAttrHTML (A.toList attrs)) <> "</tr>"   where     oneAttrHTML attr = "<th>" <> prettyAttribute attr <> "</th>"
src/lib/ProjectM36/Relation/Show/Term.hs view
@@ -83,11 +83,11 @@     oAttrNames = orderedAttributeNames (attributes rel)     header = map prettyAttribute oAttrs     body :: [[Cell]]-    body = L.foldl' tupleFolder [] (asList tupleSet)-    tupleFolder acc tuple = acc ++ [map (\attrName -> case atomForAttributeName attrName tuple of+    body = L.foldr tupleFolder [] (asList tupleSet)+    tupleFolder tuple acc = map (\attrName -> case atomForAttributeName attrName tuple of                                             Left _ -> "?"                                             Right atom -> showAtom 0 atom-                                            ) oAttrNames]+                                            ) oAttrNames : acc  showParens :: Bool -> StringType -> StringType showParens predicate f = if predicate then
src/lib/ProjectM36/RelationalExpression.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings  #-} module ProjectM36.RelationalExpression where import ProjectM36.Relation import ProjectM36.Tuple@@ -39,7 +40,10 @@ import Control.Monad.Reader as R hiding (join) import ProjectM36.NormalizeExpr import ProjectM36.WithNameExpr+import ProjectM36.Function import Test.QuickCheck+import qualified Data.Functor.Foldable as Fold+import Control.Applicative #ifdef PM36_HASKELL_SCRIPTING import GHC hiding (getContext) import Control.Exception@@ -107,11 +111,11 @@ askEnv = R.ask  mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv-mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =-  e{ gre_extra = new_elems }+mergeTuplesIntoGraphRefRelationalExprEnv tupIn env =+  env { gre_extra = new_elems }   where     new_elems = Just (Left newTuple)-    mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))+    mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple env))     newTuple = mkRelationTupleFromMap mergedTupMap  mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv@@ -209,160 +213,6 @@ setEnvContext :: RelationalExprEnv -> DatabaseContext -> RelationalExprEnv setEnvContext e ctx = e { re_context = ctx } -{----full evaluation down the graph-eval :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)-eval expr = do-  env <- askEnv-  eGfExpr <- processRelationalExpr expr-  case eGfExpr of-    Left err -> pure (Left err)-    Right gfExpr -> pure $ evalGraphRefRelationalExpr gfExpr (re_graph env)--}-{-  ---relvar state is needed in evaluation of relational expression but only as read-only in order to extract current relvar values-evalRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError GraphRefRelationalExpr)-evalRelationalExpr (RelationVariable name _) = do-  relvarTable <- fmap (relationVariables . envContext) askEnv-  return $ case M.lookup name relvarTable of-    Just res -> Right res-    Nothing -> Left $ RelVarNotDefinedError name--evalRelationalExpr (Project attrNames expr) = do-    eAttrNameSet <- evalAttributeNames attrNames expr-    case eAttrNameSet of-      Left err -> pure (Left err)-      Right attrNameSet -> do-        rel <- evalRelationalExpr expr-        case rel of-          Right rel2 -> pure $ Right (Project (AttributeNames attrNameSet) rel2)-          Left err -> pure $ Left err--evalRelationalExpr (Union exprA exprB) = do-  relA <- evalRelationalExpr exprA-  relB <- evalRelationalExpr exprB-  case relA of-    Left err -> return $ Left err-    Right relA2 -> case relB of-      Left err -> return $ Left err-      Right relB2 -> return $ Right (Union relA2 relB2)--evalRelationalExpr (Join exprA exprB) = do-  relA <- evalRelationalExpr exprA-  relB <- evalRelationalExpr exprB-  case relA of-    Left err -> return $ Left err-    Right relA2 -> case relB of-      Left err -> return $ Left err-      Right relB2 -> return $ Right (Join relA2 relB2)-      -evalRelationalExpr (Difference exprA exprB) = do-  relA <- evalRelationalExpr exprA-  relB <- evalRelationalExpr exprB-  case relA of-    Left err -> return $ Left err-    Right relA2 -> case relB of-      Left err -> return $ Left err-      Right relB2 -> return $ Right (Difference relA2 relB2)-      -evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = -  case mkRelation attributeSet tupleSet of-    Right rel -> return $ Right (ExistingRelation rel)-    Left err -> return $ Left err-    -evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do-  currentContext <- fmap envContext askEnv-  let tConss = typeConstructorMapping currentContext-  -- 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 _ ->-        Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)-      Nothing -> pure Nothing-    tuples <- mapM (liftE . evalTupleExpr mAttrs) tupleExprs-    let attrs = fromMaybe firstTupleAttrs mAttrs-        firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)-    expr <- either throwE pure (mkRelation attrs (RelationTupleSet tuples))-    pure (ExistingRelation expr)-  -evalRelationalExpr (ExistingRelation rel) = pure (Right (ExistingRelation rel))--evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do-  evald <- evalRelationalExpr relExpr-  case evald of-    Right expr -> return $ Right (Rename oldAttrName newAttrName expr)-    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 expr -> return $ Right (Group (AttributeNames oldAttrNameSet) newAttrName expr)-        Left err -> return $ Left err--evalRelationalExpr (Ungroup attrName relExpr) = do-  evald <- evalRelationalExpr relExpr-  case evald of-    Right expr -> return $ Right (Ungroup attrName expr)-    Left err -> return $ Left err--evalRelationalExpr (Restrict predicateExpr relExpr) = do-  evald <- evalRelationalExpr relExpr-  pred <- processRestrictionPredicateExpr predicateExpr-  case evald of-    Left err -> return $ Left err-    Right expr -> -      pure $ Right (Restrict pred expr)--evalRelationalExpr (Equals relExprA relExprB) = do-  evaldA <- evalRelationalExpr relExprA-  evaldB <- evalRelationalExpr relExprB-  case evaldA of-    Left err -> return $ Left err-    Right exprA -> case evaldB of-      Left err -> return $ Left err-      Right exprB -> return $ Right (Equals exprA exprB)-{--evalRelationalExpr (With views mainExpr) = do-  rstate <- ask-  -  let addScopedView ctx (vname,vexpr) = if vname `M.member` relationVariables ctx then-                                          Left (RelVarAlreadyDefinedError vname)-                                        else-                                          case runState (evalDatabaseContextExpr (Assign vname vexpr)) (freshDatabaseState ctx) of-                                            (Left err,_) -> Left err-                                            (Right (), (ctx',_,_)) -> Right ctx'--  case foldM addScopedView (stateElemsContext rstate) views of-       Left err -> return $ Left err-       Right ctx'' -> do -         let evalMainExpr expr = runReader (evalRelationalExpr expr) (RelationalExprEnv ctx'')-         case evalMainExpr mainExpr of-              Left err -> return $ Left err-              Right rel -> return $ Right rel --}---warning: copy-pasta from above- refactor-evalRelationalExpr (NotEquals relExprA relExprB) = do-  evaldA <- evalRelationalExpr relExprA-  evaldB <- evalRelationalExpr relExprB-  case evaldA of-    Left err -> return $ Left err-    Right exprA -> case evaldB of-      Left err -> return $ Left err-      Right exprB -> return $ Right (NotEquals exprA exprB)---- extending a relation adds a single attribute with the results of the per-tuple expression evaluated-evalRelationalExpr (Extend tupleExpression relExpr) = do-  eExpr <- evalRelationalExpr relExpr-  case eExpr of-    Left err -> pure (Left err)-    Right expr -> do-      tupProc <- processExtendTupleExpr tupleExpression-      pure (Right (Extend tupProc expr))--} --helper function to process relation variable creation/assignment setRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad () setRelVar relVarName relExpr = do@@ -382,6 +232,9 @@       Left err -> dbErr err       Right _ -> putStateContext potentialContext +--fast-path insertion- we already know that the previous relvar validated correctly, so we can validate just the relation that is being inserted for attribute matches- without this, even a single tuple relation inserted causes the entire relation to be re-validated unnecessarily+--insertIntoRelVar :: RelVarName -> GraphRefRelationalExpr -> DatabaseContextEvalMonad ()+ -- 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 -> DatabaseContextEvalMonad () deleteRelVar relVarName = do@@ -392,8 +245,12 @@     else do     let newRelVars = M.delete relVarName relVars         newContext = currContext { relationVariables = newRelVars }-    putStateContext newContext-    pure ()+    graph <- dbcGraph+    tid <- dbcTransId+    case checkConstraints newContext tid graph of+      Left err -> dbErr err+      Right _ ->+        putStateContext newContext  evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad () evalGraphRefDatabaseContextExpr NoOperation = pure ()@@ -447,20 +304,36 @@  evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do   gfExpr <- relVarByName relVarName-  evalGraphRefDatabaseContextExpr (Assign relVarName-                                   (Union-                                    gfExpr-                                    relExpr))+  let optExpr = applyUnionCollapse (Union+                                    relExpr+                                     gfExpr)+  evalGraphRefDatabaseContextExpr (Assign relVarName optExpr)  evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do   gfExpr <- relVarByName relVarName-  setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)+  let optExpr = applyRestrictionCollapse (Restrict (NotPredicate predicate) gfExpr)+  setRelVar relVarName optExpr    --union of restricted+updated portion and the unrestricted+unupdated portion evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do   rvExpr <- relVarByName relVarName+  graph <- re_graph <$> dbcRelationalExprEnv  +  context <- getStateContext+  let reEnv = freshGraphRefRelationalExprEnv (Just context) graph+  --get the current attributes name in the relvar to ensure that we don't conflict when renaming+      eExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr rvExpr)+  exprType' <- case eExprType of+    Left err -> throwError err+    Right t -> pure t   let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr-      tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict+      tmpAttr = tmpAttrC 1+      tmpAttrC :: Int -> AttributeName -> AttributeName+      tmpAttrC c attr =+        let tmpAttrName = "_tmp_" <> T.pack (show c) <> attr in+          if tmpAttrName `S.member` A.attributeNameSet (attributes exprType') then+            tmpAttrC (c+1) attr+          else +            tmpAttrName       updateAttr nam atomExpr = Extend (AttributeExtendTupleExpr (tmpAttr nam) atomExpr)       projectAndRename attr expr = Rename (tmpAttr attr) attr (Project (InvertedAttributeNames (S.singleton attr)) expr)       restrictedPortion = Restrict pred' rvExpr@@ -550,41 +423,41 @@   --the multiple expressions must pass the same context around- not the old unmodified context   mapM_ evalGraphRefDatabaseContextExpr exprs -evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do+evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName') = do   currentContext <- getStateContext   let atomFuncs = atomFunctions currentContext-  case atomFunctionForName funcName atomFuncs of+  case atomFunctionForName funcName' atomFuncs of     Left err -> dbErr err     Right realFunc ->       if isScriptedAtomFunction realFunc then do         let updatedFuncs = HS.delete realFunc atomFuncs         putStateContext (currentContext {atomFunctions = updatedFuncs })       else-        dbErr (PrecompiledFunctionRemoveError funcName)+        dbErr (PrecompiledFunctionRemoveError funcName')       -evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do      +evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName') = do         context <- getStateContext   let dbcFuncs = dbcFunctions context-  case databaseContextFunctionForName funcName dbcFuncs of+  case databaseContextFunctionForName funcName' dbcFuncs of     Left err -> dbErr err     Right realFunc ->       if isScriptedDatabaseContextFunction realFunc then do         let updatedFuncs = HS.delete realFunc dbcFuncs         putStateContext (context { dbcFunctions = updatedFuncs })       else-        dbErr (PrecompiledFunctionRemoveError funcName)+        dbErr (PrecompiledFunctionRemoveError funcName')       -evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do+evalGraphRefDatabaseContextExpr (ExecuteDatabaseContextFunction funcName' atomArgExprs) = do   context <- getStateContext   graph <- dbcGraph   --resolve atom arguments   let eAtomTypes = mapM (runGraphRefRelationalExprM gfEnv . typeForGraphRefAtomExpr emptyAttributes) atomArgExprs-      eFunc = databaseContextFunctionForName funcName (dbcFunctions context)+      eFunc = databaseContextFunctionForName funcName' (dbcFunctions context)       gfEnv = freshGraphRefRelationalExprEnv (Just context) graph   case eFunc of       Left err -> dbErr err       Right func -> do-        let expectedArgCount = length (dbcFuncType func)+        let expectedArgCount = length (funcType func)             actualArgCount = length atomArgExprs         if expectedArgCount /= actualArgCount then           dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)@@ -597,7 +470,7 @@                                            -> case atomTypeVerify expType actType of                                                 Left err -> Just err                                                 Right _ -> Nothing)-                                (dbcFuncType func) atomTypes+                                (funcType func) atomTypes                   typeErrors = catMaybes mValidTypes                   eAtomArgs = map (runGraphRefRelationalExprM gfEnv . evalGraphRefAtomExpr emptyTuple) atomArgExprs               if length (lefts eAtomArgs) > 1 then@@ -611,7 +484,8 @@ data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv   { dbcio_transId :: TransactionId,     dbcio_graph :: TransactionGraph,-    dbcio_mScriptSession :: Maybe ScriptSession+    dbcio_mScriptSession :: Maybe ScriptSession,+    dbcio_mModulesDirectory :: Maybe FilePath -- ^ when running in persistent mode, this must be a Just value to a directory containing .o/.so/.dynlib files which the user has placed there for access to compiled functions   }  type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a@@ -652,7 +526,7 @@ evalGraphRefDatabaseContextIOExpr LoadAtomFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError)) evalGraphRefDatabaseContextIOExpr LoadDatabaseContextFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError)) #else-evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do+evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName' funcType' script) = do   eScriptSession <- requireScriptSession   currentContext <- getDBCIOContext   case eScriptSession of@@ -661,7 +535,7 @@       res <- liftIO $ try $ runGhc (Just libdir) $ do         setSession (hscEnv scriptSession)         let atomFuncs = atomFunctions currentContext-        case extractAtomFunctionType funcType of+        case extractAtomFunctionType funcType' of           Left err -> pure (Left err)           Right adjustedAtomTypeCons -> do             --compile the function@@ -672,12 +546,12 @@                 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,-                                                 atomFuncType = funcAtomType,-                                                 atomFuncBody = AtomFunctionBody (Just script) compiledFunc }+                    newAtomFunc = Function { funcName = funcName',+                                             funcType = funcAtomType,+                                             funcBody = FunctionScriptBody script compiledFunc }                -- check if the name is already in use-                if HS.member funcName (HS.map atomFuncName atomFuncs) then-                  Left (FunctionNameInUseError funcName)+                if HS.member funcName' (HS.map funcName atomFuncs) then+                  Left (FunctionNameInUseError funcName')                   else                    Right newContext       case res of@@ -685,18 +559,18 @@         Right eContext -> case eContext of           Left err -> pure (Left err)           Right context' -> putDBCIOContext context'-evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName funcType script) = do+evalGraphRefDatabaseContextIOExpr (AddDatabaseContextFunction funcName' funcType' script) = do   eScriptSession <- requireScriptSession   currentContext <- getDBCIOContext   case eScriptSession of     Left err -> pure (Left err)     Right scriptSession -> do       --validate that the function signature is of the form x -> y -> ... -> DatabaseContext -> DatabaseContext-      let last2Args = reverse (take 2 (reverse funcType))-          atomArgs = take (length funcType - 2) funcType+      let last2Args = reverse (take 2 (reverse funcType'))+          atomArgs = take (length funcType' - 2) funcType'           dbContextTypeCons = ADTypeConstructor "Either" [ADTypeConstructor "DatabaseContextFunctionError" [], ADTypeConstructor "DatabaseContext" []]           expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"-          actualType = show funcType+          actualType = show funcType'       if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then          pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))         else do@@ -711,14 +585,14 @@               let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)                   newContext = currentContext { dbcFunctions = updatedDBCFuncs }                   dbcFuncs = dbcFunctions currentContext-                  newDBCFunc = DatabaseContextFunction {-                    dbcFuncName = funcName,-                    dbcFuncType = funcAtomType,-                    dbcFuncBody = DatabaseContextFunctionBody (Just script) compiledFunc+                  newDBCFunc = Function {+                    funcName = funcName',+                    funcType = funcAtomType,+                    funcBody = FunctionScriptBody script compiledFunc                     }-                -- check if the name is already in use                                              -              if HS.member funcName (HS.map dbcFuncName dbcFuncs) then-                Left (FunctionNameInUseError funcName)+                -- check if the name is already in use+              if HS.member funcName' (HS.map funcName dbcFuncs) then+                Left (FunctionNameInUseError funcName')                 else                  Right newContext         case res of@@ -726,21 +600,34 @@           Right eContext -> case eContext of             Left err -> pure (Left err)             Right context' -> putDBCIOContext context'-evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do+evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName entrypointName modPath) = do++  -- when running an in-memory database, we are willing to load object files from any path- when running in persistent mode, we load modules only from the modules directory so that we can be reasonbly sure that these same modules will exist when the database is restarted from the same directory+  mModDir <- dbcio_mModulesDirectory <$> ask   currentContext <- getDBCIOContext-  eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath+  let sModName = T.unpack modName+      sEntrypointName = T.unpack entrypointName+  eLoadFunc <- liftIO $ loadFunctions sModName sEntrypointName mModDir 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 putDBCIOContext newContext-evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName modPath) = do+    Left SecurityLoadSymbolError -> pure (Left SecurityLoadFunctionError)+    Right atomFunctionListFunc -> do+      let newContext = currentContext { atomFunctions = mergedFuncs }+          processedAtomFunctions = processObjectLoadedFunctions sModName sEntrypointName modPath atomFunctionListFunc+          mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList processedAtomFunctions)+      putDBCIOContext newContext+evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName entrypointName modPath) = do   currentContext <- getDBCIOContext-  eLoadFunc <- liftIO $ loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath+  let sModName = T.unpack modName+      sEntrypointName = T.unpack entrypointName+  mModDir <- dbcio_mModulesDirectory <$> ask      +  eLoadFunc <- liftIO $ loadFunctions sModName sEntrypointName mModDir modPath   case eLoadFunc of     Left LoadSymbolError -> pure (Left LoadFunctionError)+    Left SecurityLoadSymbolError -> pure (Left SecurityLoadFunctionError)     Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }-                             mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)+                             mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList processedDBCFuncs)+                             processedDBCFuncs = processObjectLoadedFunctions sModName sEntrypointName modPath dbcListFunc                                   in putDBCIOContext newContext #endif evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do@@ -774,21 +661,9 @@                             Left err -> pure (Left err)                             Right dbstate' -> putDBCIOContext (dbc_context dbstate') -{--updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> TransactionGraph -> RelationTuple -> Either RelationalError RelationTuple-updateTupleWithAtomExprs exprMap context graph tupIn = do-  --resolve all atom exprs-  let -  atomsAssoc <- mapM (\(attrName, atomExpr) -> do-                         let atom = unimplemented-                         --atom <- runReader (evalAtomExpr tupIn atomExpr) (mkRelationalExprState context graph)-                         pure (attrName, atom)-                     ) (M.toList exprMap)-  pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)--} --run verification on all constraints checkConstraints :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError ()-checkConstraints context transId graph@(TransactionGraph graphHeads transSet) =+checkConstraints context transId graph@(TransactionGraph graphHeads transSet) = do   mapM_ (uncurry checkIncDep) (M.toList deps)    where     potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)@@ -809,7 +684,9 @@           gfSupersetExpr = process (processRelationalExpr supersetExpr)       --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.       let gfEnv = freshGraphRefRelationalExprEnv (Just context) graph-          runGfRel = runGraphRefRelationalExprM gfEnv+          runGfRel e = case runGraphRefRelationalExprM gfEnv e of+            Left err -> Left (InclusionDependencyCheckError depName (Just err))+            Right v -> Right v       typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)       typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)       when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))@@ -821,7 +698,7 @@         Right resultRel -> if resultRel == relationTrue then                                    pure ()                                 else -                                  Left (InclusionDependencyCheckError depName)+                                  Left (InclusionDependencyCheckError depName Nothing)  -- 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@@ -837,15 +714,6 @@       runGf = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)   lift $ except runGf ---returns a database context with all tuples removed---this is useful for type checking and optimization-{--contextWithEmptyTupleSets :: DatabaseContext -> DatabaseContext-contextWithEmptyTupleSets contextIn = contextIn { relationVariables = relVars }-  where-    relVars = M.map (\rel -> ExistingRelation (Relation (attributes rel) emptyTupleSet)) (relationVariables contextIn)--}- liftE :: (Monad m) => m (Either a b) -> ExceptT a m b liftE v = do   y <- lift v@@ -966,19 +834,19 @@         Just (Right _) -> throwError err     Left err -> throwError err evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom-evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName arguments tid) = do+evalGraphRefAtomExpr tupIn (FunctionAtomExpr funcName' arguments tid) = do   argTypes <- mapM (typeForGraphRefAtomExpr (tupleAttributes tupIn)) arguments   context <- gfDatabaseContextForMarker tid   let functions = atomFunctions context-  func <- lift $ except (atomFunctionForName funcName functions)-  let expectedArgCount = length (atomFuncType func) - 1+  func <- lift $ except (atomFunctionForName funcName' functions)+  let expectedArgCount = length (funcType func) - 1       actualArgCount = length argTypes       safeInit [] = [] -- different behavior from normal init       safeInit xs = init xs   if expectedArgCount /= actualArgCount then       throwError (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)     else do-      let zippedArgs = zip (safeInit (atomFuncType func)) argTypes+      let zippedArgs = zip (safeInit (funcType func)) argTypes       mapM_ (\(expType, actType) ->                  lift $ except (atomTypeVerify expType actType)) zippedArgs       evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments@@ -986,7 +854,7 @@         Left err -> throwError (AtomFunctionUserError err)         Right result -> do           --validate that the result matches the expected type-          _ <- lift $ except (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))+          _ <- lift $ except (atomTypeVerify (last (funcType func)) (atomTypeForAtom result))           pure result evalGraphRefAtomExpr tupIn (RelationAtomExpr relExpr) = do   --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes@@ -1001,58 +869,6 @@     mapM (evalGraphRefAtomExpr tupIn) dConsArgs   pure (ConstructedAtom dConsName aType argAtoms) -{--evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprM Atom-evalAtomExpr tupIn expr =-  -}-{---evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of-  Right atom -> pure (Right atom)-  err@(Left (NoSuchAttributeNamesError _)) -> do-    rstate <- ask-    let stateTup = stateTuple rstate-    pure (atomForAttributeName attrName stateTup)-  Left err -> pure (Left err)-evalAtomExpr _ (NakedAtomExpr atom) = pure (Right atom)-evalAtomExpr tupIn (FunctionAtomExpr funcName arguments ()) = do-  argTypes <- mapM (typeFromAtomExpr (tupleAttributes tupIn)) arguments-  context <- fmap stateElemsContext ask-  runExceptT $ do-    let functions = atomFunctions context-    func <- either throwE pure (atomFunctionForName funcName functions)-    let expectedArgCount = length (atomFuncType func) - 1-        actualArgCount = length argTypes-        safeInit [] = [] -- different behavior from normal init-        safeInit xs = init xs-    if expectedArgCount /= actualArgCount then-      throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)-      else do-      let zippedArgs = zip (safeInit (atomFuncType func)) argTypes-      mapM_ (\(expType, eActType) -> do-                actType <- either throwE pure eActType-                either throwE pure (atomTypeVerify expType actType)) zippedArgs-      evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments-      case evalAtomFunction func evaldArgs of-        Left err -> throwE (AtomFunctionUserError err)-        Right result -> do-          --validate that the result matches the expected type-          _ <- either throwE pure (atomTypeVerify (last (atomFuncType func)) (atomTypeForAtom result))-          pure result-evalAtomExpr tupIn (RelationAtomExpr relExpr) = do-  --merge existing state tuple context into new state tuple context to support an arbitrary number of levels, but new attributes trounce old attributes-  rstate <- ask-  runExceptT $ do-    let newState = mergeTuplesIntoRelationalExprState tupIn rstate-    relAtom <- either throwE pure (runReader (evalRelationalExpr relExpr) newState)-    pure (RelationAtom relAtom)-evalAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs ()) = runExceptT $ do-  rstate <- lift ask-  let newState = mergeTuplesIntoRelationalExprState tupIn rstate-  aType <- either throwE pure (runReader (typeFromAtomExpr (tupleAttributes tupIn) cons) newState)-  argAtoms <- mapM (\arg -> either throwE pure (runReader (evalAtomExpr tupIn arg) newState)) dConsArgs-  pure (ConstructedAtom dConsName aType argAtoms)--} typeForGraphRefAtomExpr :: Attributes -> GraphRefAtomExpr -> GraphRefRelationalExprM AtomType typeForGraphRefAtomExpr attrs (AttributeAtomExpr attrName) = do   renv <- askEnv@@ -1070,18 +886,18 @@     Left err -> throwError err  typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)-typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do+typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName' atomArgs transId) = do   funcs <- atomFunctions <$> gfDatabaseContextForMarker transId-  case atomFunctionForName funcName funcs of+  case atomFunctionForName funcName' funcs of     Left err -> throwError err     Right func -> do-      let funcRetType = last (atomFuncType func)-          funcArgTypes = init (atomFuncType func)+      let funcRetType = last (funcType func)+          funcArgTypes = init (funcType func)       argTypes <- mapM (typeForGraphRefAtomExpr attrs) atomArgs       let eTvMap = resolveTypeVariables funcArgTypes argTypes       case eTvMap of             Left err -> throwError err-            Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName tvMap funcRetType+            Right tvMap -> lift $ except $ resolveFunctionReturnValue funcName' tvMap funcRetType typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do   relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)   pure (RelationAtomType (attributes relType))@@ -1110,16 +926,16 @@  verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =   lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)-verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs tid) expectedType = do+verifyGraphRefAtomExprTypes relIn (FunctionAtomExpr funcName' funcArgExprs tid) expectedType = do   context <- gfDatabaseContextForMarker tid   let functions = atomFunctions context-  func <- lift $ except $ atomFunctionForName funcName functions-  let expectedArgTypes = atomFuncType func+  func <- lift $ except $ atomFunctionForName funcName' functions+  let expectedArgTypes = funcType func       funcArgVerifier (atomExpr, expectedType2, argCount) = do         let handler :: RelationalError -> GraphRefRelationalExprM AtomType-            handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)+            handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName' argCount expSubType actSubType)             handler err = throwError err-        verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler            +        verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler      funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]   if length funcArgTypes /= length expectedArgTypes - 1 then       throwError (AtomTypeCountError funcArgTypes expectedArgTypes)@@ -1127,7 +943,7 @@       lift $ except $ atomTypeVerify expectedType (last expectedArgTypes) verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType =   do-    let mergedAttrsEnv e = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) e+    let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn)     relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)     lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType)) verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do@@ -1165,7 +981,7 @@                   lift $ except $ resolveAttributes accAttr tupAttr            mostResolvedTypes <-                 foldM (\acc tup -> do-                         let zipped = zip (V.toList $ tupleAttributes tup) acc+                         let zipped = zip (V.toList . attributesVec $ tupleAttributes tup) acc                              accNames = S.fromList $ map A.attributeName acc                              tupNames = A.attributeNameSet (tupleAttributes tup)                              attrNamesDiff = S.union (S.difference accNames tupNames) (S.difference tupNames accNames)@@ -1176,7 +992,7 @@                            pure nextTupleAttrs                            else                            throwError (TupleAttributeTypeMismatchError diff)-                      ) (V.toList $ tupleAttributes headTuple) tailTuples+                      ) (V.toList . attributesVec $ tupleAttributes headTuple) tailTuples           pure (A.attributesFromList mostResolvedTypes)   --strategy: if all the tuple expr transaction markers refer to one location, then we can pass the type constructor mapping from that location, otherwise, we cannot assume that the types are the same   tConsMap <- case singularTransactions tupleExprL of@@ -1222,56 +1038,6 @@ --  _ <- lift $ except (validateTuple tup' tConss)   pure tup' -{--evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprM (Either RelationalError (S.Set AttributeName))-evalAttributeNames attrNames expr = do-  eExprType <- typeForRelationalExpr expr-  case eExprType of-    Left err -> throwError 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)))--}- --temporary implementation until we have a proper planner+executor evalGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation evalGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do@@ -1500,7 +1266,7 @@         let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph         gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)         pure (rvName, gfType)-      relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]+      relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributesVec (attributes rel))]       attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]       attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of         Left err -> error ("relationVariablesAsRelation pooped " ++ show err)@@ -1520,15 +1286,6 @@     Left err -> throwError err     Right rel -> pure rel -{--relVarByName :: RelVarName -> GraphRefRelationalExprM GraphRefRelationalExpr-relVarByName = do-  relvars <- relationVariables <$> getStateContext  -  case M.lookup relVarName relvars of-        Nothing -> dbErr (RelVarNotDefinedError relVarName)-        Just gfexpr -> pure gfExpr--}- class (MonadError RelationalError m, Monad m) => DatabaseContextM m where   getContext :: m DatabaseContext   @@ -1613,3 +1370,44 @@   resolve (RelationAtomExpr expr) = RelationAtomExpr <$> resolve expr   resolve (ConstructedAtomExpr dConsName atomExprs marker) =     ConstructedAtomExpr dConsName <$> mapM resolve atomExprs <*> pure marker++--convert series of simple Union queries into MakeStaticRelation+-- this is especially useful for long, nested applications of Union with simple tuples+-- Union (MakeRelation x y) (MakeRelation x y') -> MakeRelation x (y + y')++--MakeRelationFromExprs Nothing (TupleExprs UncommittedContextMarker [TupleExpr (fromList [("name", NakedAtomExpr (TextAtom "steve"))])])++applyUnionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr+applyUnionCollapse = Fold.cata opt+  where+    opt :: RelationalExprBaseF GraphRefTransactionMarker GraphRefRelationalExpr -> GraphRefRelationalExpr+    opt (UnionF exprA exprB) | exprA == exprB = exprA+    opt (UnionF+         exprA@(MakeRelationFromExprs mAttrs1 tupExprs1)+         exprB@(MakeRelationFromExprs mAttrs2 tupExprs2)) | tupExprs1 == tupExprs2 = MakeRelationFromExprs (mAttrs1 <|> mAttrs2) tupExprs1+                                                    | tupExprsNull tupExprs1 = exprB+                                                    | tupExprsNull tupExprs2 = exprA+    opt x = Fold.embed x+    tupExprsNull (TupleExprs _ []) = True+    tupExprsNull _ = False+++--UPDATE optimization- find matching where clause in "lower" levels of renaming+--update x where y=1 set (x:=5,z:=10); update x where y=1 set(x:=6,z:=11)+-- =>+-- update x where y=1 set (x:=6,z:=11)+-- future opt: match individual attributes update x where y=1 set (x:=5); update x where y=1 set (z:=11) => update x where y=1 set (x:=5,z:=11)++--strategy: try to collapse the top-level update (union (restrict pred MakeRelationFromExpr) expr) if it contains the same predicate and resultant relation++--DELETE optimization+-- if a restriction matches a previous restriction, combine them+-- O(1) since it only scans at the top level, critical in benchmarks generating redundant deletions+applyRestrictionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr+applyRestrictionCollapse orig@(Restrict npred@(NotPredicate _) expr) =+  case expr of+    orig'@(Restrict npred'@(NotPredicate _) _) | npred == npred' -> orig'+    _ -> orig+applyRestrictionCollapse expr = expr++
src/lib/ProjectM36/ScriptSession.hs view
@@ -44,7 +44,6 @@ import Encoding #endif - data ScriptSession = ScriptSession { #ifdef PM36_HASKELL_SCRIPTING   hscEnv :: HscEnv,@@ -62,7 +61,7 @@   deriving (Show) #endif -data LoadSymbolError = LoadSymbolError+data LoadSymbolError = LoadSymbolError | SecurityLoadSymbolError type ModName = String type FuncName = String @@ -126,10 +125,9 @@                              "unordered-containers",                              "hashable",                              "uuid",+                             "mtl",                              "vector",                              "text",-                             "binary",-                             "vector-binary-instances",                              "time",                              "project-m36",                              "bytestring"]@@ -250,20 +248,55 @@       maybe "" (\p -> zEncodeString p ++ "_") pkg ++       zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure" -loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)-loadFunction modName funcName objPath = do+data ObjectLoadMode = LoadObjectFile | -- ^ load .o files only+                      LoadDLLFile | -- ^ load .so .dynlib .dll files only+                      LoadAutoObjectFile -- ^ determine which object mode to use based on the file name's extension++-- | Load either a .o or dynamic library based on the file name's extension.+++-- | Load a function from an relocatable object file (.o or .so)+--   If a modulesDir is specified, only load a path relative to the modulesDir (no ..)++type ModuleDirectory = FilePath++loadFunctionFromDirectory :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> FilePath -> IO (Either LoadSymbolError a)+loadFunctionFromDirectory mode modName funcName modDir objPath =+  if takeFileName objPath /= objPath then+    pure (Left SecurityLoadSymbolError)+  else+    let fullObjPath = modDir </> objPath in+      loadFunction mode modName funcName fullObjPath+++loadFunction :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)+loadFunction loadMode modName funcName objPath = do #if __GLASGOW_HASKELL__ >= 802   initObjLinker RetainCAFs #else   initObjLinker #endif-  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)+  let loadFuncForSymbol = do    +        _ <- 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)+  case loadMode of+    LoadAutoObjectFile ->+      if takeExtension objPath == ".o" then+          loadFunction LoadObjectFile modName funcName objPath+        else+          loadFunction LoadDLLFile modName funcName objPath+    LoadObjectFile -> do+      loadObj objPath+      loadFuncForSymbol+    LoadDLLFile -> do+      mErr <- loadDLL objPath+      case mErr of+        Just _ -> pure (Left LoadSymbolError)+        Nothing -> loadFuncForSymbol  prefixUnderscore :: String prefixUnderscore =
src/lib/ProjectM36/Serialise/Base.hs view
@@ -10,6 +10,7 @@ import Data.UUID import Data.Proxy import Data.Word+import ProjectM36.Attribute as A import qualified Data.List.NonEmpty as NE import qualified Data.Vector as V import Data.Time.Calendar (Day,toGregorian,fromGregorian)@@ -72,5 +73,13 @@   extractor = fromGregorianTup <$> extractor   decodeCurrent = fromGregorianTup <$> decodeCurrent -+instance Serialise Attributes where+  schemaGen _ = SVector <$> getSchema (Proxy @Attribute)+  toBuilder attrs = varInt (V.length (attributesVec attrs)) <> foldMap toBuilder (V.toList (attributesVec attrs))+  extractor =+    attributesFromList . V.toList <$> extractListBy extractor +  decodeCurrent = do+    n <- decodeVarInt+    l <- replicateM n decodeCurrent+    pure (A.attributesFromList l)
src/lib/ProjectM36/Serialise/Error.hs view
@@ -12,3 +12,4 @@ deriving via WineryVariant ScriptCompilationError instance Serialise ScriptCompilationError deriving via WineryVariant PersistenceError instance Serialise PersistenceError deriving via WineryVariant SchemaError instance Serialise SchemaError+deriving via WineryVariant ImportError' instance Serialise ImportError'
src/lib/ProjectM36/Server/Config.hs view
@@ -12,6 +12,12 @@                                    }                     deriving (Show) +data WebsocketServerConfig = WebsocketServerConfig { wsServerConfig :: ServerConfig,+                                                     tlsCertificatePath :: Maybe String,+                                                     tlsKeyPath :: Maybe String+                                                     }+                              deriving (Show)+ defaultServerConfig :: ServerConfig defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,                                      checkFS = True,
src/lib/ProjectM36/Server/EntryPoints.hs view
@@ -5,8 +5,8 @@ import ProjectM36.Client as C import Data.Map import Control.Concurrent (threadDelay)-import Network.RPC.Curryer.Server-import System.Timeout+import Network.RPC.Curryer.Server +import System.Timeout hiding (Timeout) import Network.Socket import Control.Exception
src/lib/ProjectM36/Server/ParseArgs.hs view
@@ -17,14 +17,14 @@                                  many parseGhcPkgPath <*>                                  parseTimeout (perRequestTimeout defaults) <*>                                  parseTestMode-                     + parsePersistenceStrategy :: Parser PersistenceStrategy parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>                            MinimalPersistence <$> dbdirOpt <|>                            pure NoPersistence-  where -    dbdirOpt = strOption (short 'd' <> -                          long "database-directory" <> +  where+    dbdirOpt = strOption (short 'd' <>+                          long "database-directory" <>                           metavar "DIRECTORY" <>                           showDefaultWith show                          )@@ -34,44 +34,61 @@  parseTestMode :: Parser Bool parseTestMode = flag True False (long "test-mode" <> hidden)-               -parseCheckFS :: Parser Bool               ++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" <>                                metavar "DATABASE_NAME") -parseHostname :: Hostname -> Parser Hostname                    +parseHostname :: Hostname -> Parser Hostname parseHostname defHostname = strOption (short 'h' <>                            long "hostname" <>                            metavar "HOST_NAME" <>                            value defHostname)-                + parsePort :: Port -> Parser Port parsePort defPort = option auto (short 'p' <>                          long "port" <>                          metavar "PORT_NUMBER" <>                          value defPort)-            + parseGhcPkgPath :: Parser String parseGhcPkgPath = strOption (long "ghc-pkg-dir" <>                               metavar "GHC_PACKAGE_DIRECTORY")-                   -parseTimeout :: Int -> Parser Int              ++parseTimeout :: Int -> Parser Int parseTimeout defTimeout = option auto (long "timeout" <>                             metavar "MICROSECONDS" <>                             value defTimeout)  parseConfig :: IO ServerConfig parseConfig = parseConfigWithDefaults defaultServerConfig-  + parseConfigWithDefaults :: ServerConfig -> IO ServerConfig parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults <**> helpOption) idm) +parseWSConfigWithDefaults :: ServerConfig -> IO WebsocketServerConfig+parseWSConfigWithDefaults defaults = execParser (info (parseWSArgsWithDefaults defaults <**> helpOption) idm) +parseWSArgsWithDefaults :: ServerConfig -> Parser WebsocketServerConfig+parseWSArgsWithDefaults defaults = WebsocketServerConfig <$>+                                 parseArgsWithDefaults defaults <*>+                                 parseTlsCertificatePath <*>+                                 parseTlsKeyPath+++parseTlsCertificatePath :: Parser (Maybe String)+parseTlsCertificatePath = optional $ strOption (long "tls-certificate-path" <>+                              metavar "TLS_CERTIFICATE_PATH")++parseTlsKeyPath :: Parser (Maybe String)+parseTlsKeyPath = optional $ strOption (long "tls-key-path" <>+                              metavar "TLS_KEY_PATH")+ helpOption :: Parser (a -> a) helpOption = abortOption helpText $ mconcat   [ long "help"@@ -80,6 +97,6 @@   where #if MIN_VERSION_optparse_applicative(0,16,0)     helpText = ShowHelpText Nothing-#else               +#else     helpText = ShowHelpText #endif
+ src/lib/ProjectM36/Shortcuts.hs view
@@ -0,0 +1,247 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+module ProjectM36.Shortcuts where+-- users need OverloadedLabels, OverloadedLists, and default(Int,Text) to use these shortcuts.+import Data.Text hiding (foldl, map)+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.Atomable+import Prelude hiding ((!!))+import Data.Proxy+import GHC.OverloadedLabels+import GHC.TypeLits hiding (Text)+import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.Set as S+import GHC.Exts (IsList(..))+import Data.Convertible++default (Text)++instance IsList (AttributeNamesBase ()) where+  type Item (AttributeNamesBase ()) = AttributeName+  fromList = AttributeNames . S.fromList +  toList (AttributeNames ns) = S.toList ns+  toList _ = error "needs AttributeNames"++instance IsList (TupleExprsBase ()) where+  type Item TupleExprs = TupleExpr+  fromList = TupleExprs ()+  toList (TupleExprs _ ts) = ts++instance IsList TupleExpr where+  type Item TupleExpr = (AttributeName, AtomExpr) +  fromList attributeValues = TupleExpr (M.fromList attributeValues)+  toList (TupleExpr attributeValues) = M.toList attributeValues+++-- #xxx :: Text+instance KnownSymbol x => IsLabel x Text where+  fromLabel = T.pack $ symbolVal @x Proxy++-- #relvarName :: RelationalExpr+instance KnownSymbol x => IsLabel x RelationalExpr where+  fromLabel = RelationVariable (T.pack $ symbolVal @x Proxy) ()++-- *Main> #a Int :: AttributeExpr+-- NakedAttributeExpr (Attribute "a" IntAtomType)+-- *Main> #a (Attr @[Int]) :: AttributeExpr+-- NakedAttributeExpr (Attribute "a" (ConstructedAtomType "List" (fromList [("a",IntAtomType)])))+-- can't offer a Relation atomtype -- don't know how to express a Relation type in haskell type. Maybe something a HList of (Text, a) ?+--+-- ps. I don't understand the usage of "AttributeAndTypeNameExpr AttributeName TypeConstructor a"+instance (KnownSymbol x, Atomable a)=> IsLabel x (HaskAtomType a -> AttributeExpr) where+  fromLabel = (NakedAttributeExpr . Attribute name) . toAtomType''+    where name = T.pack $ symbolVal @x Proxy++-- (#a 1) :: ExtendTupleExpr+-- no need for :=+instance (Convertible a AtomExpr, KnownSymbol x) => IsLabel x (a -> ExtendTupleExpr) where+  fromLabel x = AttributeExtendTupleExpr name (convert x) +    where name = T.pack $ symbolVal @x Proxy++-- #name AtomExpr +-- ex. tuple [ #name 3 ]+-- default(Text) is needed in client code to avoid `no Atomable Char`+instance (Convertible a AtomExpr, KnownSymbol x) => IsLabel x (a -> (AttributeName, AtomExpr)) where+  fromLabel = \x -> (name, convert x)+    where name = T.pack $ symbolVal @x Proxy++-- *Main> #a [1] :: AtomExpr+-- FunctionAtomExpr "a" [NakedAtomExpr (IntegerAtom 1)] ()+--+-- This usage is not working in RestrictionPredicateExpr and AttributeExtendTupleExpr. Use f "a" [1] instead.+instance (KnownSymbol x, Convertible a AtomExpr) => IsLabel x ([a] -> AtomExpr) where+  fromLabel = \as' -> FunctionAtomExpr name (map convert as') ()+    where name = T.pack $ symbolVal @x Proxy++instance (KnownSymbol x) => IsLabel x AtomExpr where+  fromLabel = AttributeAtomExpr name+    where name = T.pack $ symbolVal @x Proxy+++data HaskAtomType a where+  Int :: HaskAtomType Int+  Integer :: HaskAtomType Integer+  Double :: HaskAtomType Double+  Text :: HaskAtomType Text+--  Day :: HaskAtomType Day+--  DateTime :: HaskAtomType DateTime+--  ByteString :: HaskAtomType ByteString+  Bool :: HaskAtomType Bool+  Attr :: Atomable a => HaskAtomType a  -- a Proxy-like value for type application.++toAtomType'' :: Atomable a => HaskAtomType a -> AtomType+toAtomType'' (_ :: HaskAtomType a) = toAtomType (Proxy @a)++-- usage: relation [tuple [#a 1, #b "b"], tuple [#a 2, #b "b"]]+relation :: [TupleExpr] -> RelationalExpr+relation ts = MakeRelationFromExprs Nothing (TupleExprs () ts)++relation' :: [AttributeExprBase ()] -> [TupleExpr] -> RelationalExpr+relation' as' ts = MakeRelationFromExprs (Just as') (TupleExprs () ts)++-- usage: tuple [#name "Mike",#age 6]+tuple :: [(AttributeName, AtomExpr)] -> TupleExprBase ()+tuple as' = TupleExpr (M.fromList as')++-- #a rename  [#b `as` #c]+rename :: RelationalExpr -> [(AttributeName,AttributeName)] -> RelationalExpr +rename relExpr renameList = case renameList of +  [] -> Restrict TruePredicate relExpr+  renames -> +    foldl (\acc (old,new) -> Rename old new  acc) relExpr renames ++--project !!+-- #a !! [#b,#c]+infix 9 !!+(!!) :: RelationalExpr -> AttributeNames -> RelationalExpr  +relExpr !! xs = Project xs relExpr++--join ><+-- #a >< #b+(><) :: RelationalExpr -> RelationalExpr -> RelationalExpr+a >< b = Join a b++allBut :: AttributeNames -> AttributeNames+allBut (AttributeNames ns) = InvertedAttributeNames ns+allBut _ = error "give allBut something other than attribute names."++allFrom :: RelationalExpr -> AttributeNames+allFrom = RelationalExprAttributeNames ++as :: AttributeNames -> AttributeName -> (AttributeNames, AttributeName)+as = (,)++-- #a `group` ([#b,#c] `as` #d)+group :: RelationalExpr -> (AttributeNames, AttributeName) -> RelationalExpr+group relExpr (aNames, aName) = Group aNames aName relExpr++-- #a `ungroup` #b+ungroup :: RelationalExpr -> AttributeName -> RelationalExpr+ungroup relExpr aName = Ungroup aName relExpr++-- *Main> #a #:= true #: ( #b (f "count" [1,2]))+-- Assign "a" (Extend (AttributeExtendTupleExpr "b" (FunctionAtomExpr "count" [NakedAtomExpr (IntegerAtom 1),NakedAtomExpr (IntegerAtom 2)] ())) (ExistingRelation (Relation attributesFromList [] (RelationTupleSet {asList = [RelationTuple attributesFromList [] []]}))))+(#:) :: RelationalExpr -> ExtendTupleExpr -> RelationalExpr+a #: b = Extend b a+infix 8 #:++instance Convertible AtomExpr AtomExpr where+  safeConvert = Right++instance Convertible RelVarName AtomExpr where+  safeConvert n = Right $ RelationAtomExpr (RelationVariable n ()) ++instance Convertible RelationalExpr AtomExpr where+  safeConvert relExpr = Right $ RelationAtomExpr relExpr++instance Convertible RelVarName RelationalExpr where+  safeConvert n = Right $ RelationVariable n ()++-- @ in tutd+-- (@@) "aaa"+(@@) :: AttributeName -> AtomExpr+(@@) = AttributeAtomExpr ++-- works in RestrictedPredicateExpr and AttributeExtendTupleExpr +-- usage: f "gte" [1]+f :: Convertible a AtomExpr => FunctionName -> [a] -> AtomExpr+f n as' = FunctionAtomExpr n (map convert as') ()++-- DatabaseContextExpr+-- define+(#::) :: RelVarName -> [AttributeExpr] -> DatabaseContextExpr+s #:: xs =  Define s xs+infix 5 #::++-- assign+(#:=) :: RelVarName -> RelationalExpr -> DatabaseContextExpr +s #:= r = Assign s r+infix 5 #:=++class Boolean a b where+  (&&&) :: a -> b -> RestrictionPredicateExpr+  infixl 6 &&&+  (|||) :: a -> b -> RestrictionPredicateExpr+  infixl 5 |||++-- where: @~ mimics the restriction symbol in algebra  +-- usage: true #: (#a 1) @~ #a ?= 1 &&& not' false ||| (f "gte" [1])+(@~) :: Convertible a RestrictionPredicateExpr => RelationalExpr -> a -> RelationalExpr+(@~) relExpr resPreExpr = Restrict (convert resPreExpr) relExpr+infix 4 @~++true :: RelationalExpr+true = ExistingRelation relationTrue++false :: RelationalExpr+false = ExistingRelation relationFalse++trueP :: RestrictionPredicateExprBase a+trueP = TruePredicate++falseP :: RestrictionPredicateExprBase a+falseP = NotPredicate TruePredicate++(?=) :: Convertible a AtomExpr => AttributeName -> a -> RestrictionPredicateExpr+(?=) name a = AttributeEqualityPredicate name (convert a)+infix 9 ?=++not' :: Convertible a RestrictionPredicateExpr => a -> RestrictionPredicateExpr+not' = NotPredicate . convert++instance (Convertible a RestrictionPredicateExpr, Convertible b RestrictionPredicateExpr) => Boolean a b where+  a &&& b = AndPredicate (convert a) (convert b) +  a ||| b = OrPredicate (convert a) (convert b)++instance {-# Incoherent #-} Atomable a => Convertible a RestrictionPredicateExpr where+  safeConvert n = Right $ AtomExprPredicate $ toAtomExpr . toAtom $ n ++instance {-# Incoherent #-} Convertible RelationalExpr RestrictionPredicateExpr where+  safeConvert a = Right $ RelationalExprPredicate a+ +instance {-# Incoherent #-} Convertible AtomExpr RestrictionPredicateExpr where+  safeConvert a = Right $ AtomExprPredicate a++instance {-# Incoherent #-} Convertible RestrictionPredicateExpr RestrictionPredicateExpr where+  safeConvert = Right++instance {-# Incoherent #-} Atomable a => Convertible a AtomExpr where+  safeConvert n = Right $ toAtomExpr . toAtom $ n ++toAtomExpr :: Atom -> AtomExpr+toAtomExpr (ConstructedAtom n _ xs) = ConstructedAtomExpr n (toAtomExpr <$> xs) () +toAtomExpr a = NakedAtomExpr a+++
src/lib/ProjectM36/StaticOptimizer.hs view
@@ -22,8 +22,6 @@  -- the static optimizer performs optimizations which need not take any specific-relation statistics into account ---import Debug.Trace- data GraphRefSOptRelationalExprEnv =   GraphRefSOptRelationalExprEnv   {@@ -179,7 +177,7 @@ optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e -optimizeGraphRefRelationalExpr e@(MakeRelationFromExprs _ _) = pure e+optimizeGraphRefRelationalExpr e@MakeRelationFromExprs{} = pure e  optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e @@ -209,6 +207,8 @@   case (optExprA, optExprB) of            (Restrict predA (RelationVariable nameA sA),            Restrict predB (RelationVariable nameB sB)) | nameA == nameB && sA == sB -> pure (Restrict (AndPredicate predA predB) (RelationVariable nameA sA))+          (exprA', exprB') | isEmptyRelationExpr exprA' -> pure exprB'+                           | isEmptyRelationExpr exprB' -> pure exprA'           _ -> if optExprA == optExprB then                        pure optExprA             else@@ -575,3 +575,4 @@ -- no optimizations available   optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr optimizeDatabaseContextIOExpr = pure+
src/lib/ProjectM36/TransGraphRelationalExpression.hs view
@@ -122,8 +122,8 @@ processTransGraphAtomExpr :: TransGraphAtomExpr -> TransGraphEvalMonad GraphRefAtomExpr processTransGraphAtomExpr (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname processTransGraphAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom-processTransGraphAtomExpr (FunctionAtomExpr funcName args tLookup) =-  FunctionAtomExpr funcName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup+processTransGraphAtomExpr (FunctionAtomExpr funcName' args tLookup) =+  FunctionAtomExpr funcName' <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup processTransGraphAtomExpr (RelationAtomExpr expr) =   RelationAtomExpr <$> processTransGraphRelationalExpr expr processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =
src/lib/ProjectM36/Transaction/Persist.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+#ifdef PM36_HASKELL_SCRIPTING {-# LANGUAGE TypeApplications #-}+#endif module ProjectM36.Transaction.Persist where import ProjectM36.Base import ProjectM36.Error@@ -6,11 +11,13 @@ import ProjectM36.DatabaseContextFunction import ProjectM36.AtomFunction import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)+import ProjectM36.Function import qualified Data.Map as M import qualified Data.HashSet as HS import System.FilePath import System.Directory import qualified Data.Text as T+import Data.Foldable (toList) import Control.Monad import ProjectM36.ScriptSession import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)@@ -45,8 +52,8 @@ atomFuncsPath :: FilePath -> FilePath atomFuncsPath transdir = transdir </> "atomfuncs" -dbcFuncsDir :: FilePath -> FilePath-dbcFuncsDir transdir = transdir </> "dbcfuncs"+dbcFuncsPath :: FilePath -> FilePath+dbcFuncsPath transdir = transdir </> "dbcfuncs"  typeConsPath :: FilePath -> FilePath typeConsPath transdir = transdir </> "typecons"@@ -54,6 +61,10 @@ subschemasPath :: FilePath -> FilePath subschemasPath transdir = transdir </> "schemas" +-- | where compiled modules are stored within the database directory+objectFilesPath :: FilePath -> FilePath+objectFilesPath transdir = transdir </> ".." </> "compiled_modules"+ readTransaction :: FilePath -> TransactionId -> Maybe ScriptSession -> IO (Either PersistenceError Transaction) readTransaction dbdir transId mScriptSession = do   let transDir = transactionDir dbdir transId@@ -66,8 +77,8 @@     incDeps <- readIncDeps transDir     typeCons <- readTypeConstructorMapping transDir     sschemas <- readSubschemas transDir-    dbcFuncs <- readDBCFuncs transDir mScriptSession-    atomFuncs <- readAtomFuncs transDir mScriptSession+    dbcFuncs <- readFuncs transDir (dbcFuncsPath transDir) basicDatabaseContextFunctions mScriptSession+    atomFuncs <- readFuncs transDir (atomFuncsPath transDir) precompiledAtomFunctions mScriptSession     let newContext = DatabaseContext { inclusionDependencies = incDeps,                                        relationVariables = relvars,                                        typeConstructorMapping = typeCons,@@ -85,15 +96,14 @@   transDirExists <- doesDirectoryExist finalTransDir   unless transDirExists $ do     --create sub directories-    mapM_ createDirectory [tempTransDir, incDepsDir tempTransDir, dbcFuncsDir tempTransDir]+    mapM_ createDirectory [tempTransDir, incDepsDir tempTransDir]     writeRelVars sync tempTransDir (relationVariables context)     writeIncDeps sync tempTransDir (inclusionDependencies context)-    writeAtomFuncs sync tempTransDir (atomFunctions context)-    writeDBCFuncs sync tempTransDir (dbcFunctions context)+    writeFuncs sync (atomFuncsPath tempTransDir) (HS.toList (atomFunctions context))+    writeFuncs sync (dbcFuncsPath tempTransDir) (HS.toList (dbcFunctions context))     writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)     writeSubschemas sync tempTransDir (subschemas trans)-    writeFileSerialise (transactionInfoPath tempTransDir) (transactionInfo trans)-    --move the temp directory to final location+    writeFileSerialise (transactionInfoPath tempTransDir) (transactionInfo trans)    --move the temp directory to final location     renameSync sync tempTransDir finalTransDir  writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()@@ -105,60 +115,95 @@ readRelVars transDir =    readFileDeserialise (relvarsPath transDir) -writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()-writeAtomFuncs sync transDir funcs = do-  let atomFuncPath = atomFuncsPath transDir -  writeBSFileSync sync atomFuncPath (serialise $ map (\f -> (atomFuncType f, atomFuncName f, atomFunctionScript f)) (HS.toList funcs))+writeFuncs :: Traversable t => DiskSync -> FilePath -> t (Function a) -> IO ()+writeFuncs sync funcWritePath funcs = do+  funcs' <- forM funcs $ \fun -> do+    case funcBody fun of+      FunctionScriptBody{} -> pure fun+      FunctionBuiltInBody{} -> pure fun+      FunctionObjectLoadedBody objPath a b c -> do+         let newFuncBody = FunctionObjectLoadedBody objPath a b c+         pure (fun { funcBody = newFuncBody })+  --write additional data for object-loaded functions (which are not built-in or scripted)+  let functionData f =+          (funcType f, funcName f, functionScript f, objInfo f)+      objInfo :: Function a -> Maybe ObjectFileInfo+      objInfo f =+        case funcBody f of+          FunctionObjectLoadedBody objPath modName entryFunc _ ->+            Just (ObjectFileInfo (objPath, modName, entryFunc))+          FunctionScriptBody{} -> Nothing+          FunctionBuiltInBody{} -> Nothing+  writeBSFileSync sync funcWritePath (serialise $ fmap functionData (toList funcs')) ---all the atom functions are in one file-readAtomFuncs :: FilePath -> Maybe ScriptSession -> IO AtomFunctions-readAtomFuncs transDir mScriptSession = do-  atomFuncsList <- readFileDeserialise (atomFuncsPath transDir)-  --only Haskell script functions can be serialized+readFuncs :: FilePath -> FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> IO (HS.HashSet (Function a))+readFuncs transDir funcPath precompiledFunctions mScriptSession = do+  funcsList <- readFileDeserialise funcPath   --we always return the pre-compiled functions-  funcs <- mapM (\(funcType, funcName, mFuncScript) -> loadAtomFunc precompiledAtomFunctions mScriptSession funcName funcType mFuncScript) atomFuncsList-  pure (HS.union precompiledAtomFunctions (HS.fromList funcs))-  -loadAtomFunc :: AtomFunctions -> Maybe ScriptSession -> AtomFunctionName -> [AtomType] -> Maybe AtomFunctionBodyScript -> IO AtomFunction-loadAtomFunc precompiledFuncs _mScriptSession funcName _funcType mFuncScript = case mFuncScript of-    --handle pre-compiled case- pull it from the precompiled list-    Nothing -> case atomFunctionForName funcName precompiledFuncs of-      --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored-      Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)-      Right realFunc -> pure realFunc-    --handle a real Haskell scripted function- compile and load-    Just _funcScript ->+  --load object files and functions in objects (shared libraries or flat object files)+  let objFilesDir = objectFilesPath transDir+  funcs <- mapM (\(funcType', funcName', mFuncScript, mObjInfo) -> +                    loadFunc objFilesDir precompiledFunctions mScriptSession funcName' funcType' mFuncScript mObjInfo) funcsList+  pure (HS.union precompiledFunctions (HS.fromList funcs))++newtype ObjectFileInfo = ObjectFileInfo { _unFileInfo :: (FilePath, String, String) }+ deriving (Show, Serialise)+-- deriving Serialise via WineryVariant ObjectFileInfo++loadFunc :: FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> FunctionName -> [AtomType] -> Maybe FunctionBodyScript -> Maybe ObjectFileInfo -> IO (Function a)+loadFunc objFilesDir precompiledFuncs _mScriptSession funcName' _funcType mFuncScript mObjInfo = do+  case mObjInfo of+    --load from shared or static object library+    Just (ObjectFileInfo (path, modName, entryFunc)) -> do+      eFuncs <- loadFunctions modName entryFunc (Just objFilesDir) path+      case eFuncs of+        Left _ -> error $ "Failed to load " <> path+        Right funcs -> +          case filter (\f -> funcName f == funcName'+                      ) funcs of+            [f] -> pure f+            [] -> error $ "Failed to find function \"" <> T.unpack funcName' <> "\" in " <> path+            _ -> error $ "impossible error in loading \"" <> T.unpack funcName' <> "\""+    Nothing -> +      case mFuncScript of+        --handle pre-compiled case- pull it from the precompiled list+        Nothing -> case functionForName funcName' precompiledFuncs of+          --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored+          Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName')+          Right realFunc -> pure realFunc+        --handle a real Haskell scripted function- compile and load+        Just _funcScript -> #ifdef PM36_HASKELL_SCRIPTING-      case _mScriptSession of-        Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"-        Just scriptSession -> do-          --risk of GHC exception during compilation here-          eCompiledScript <- runGhc (Just libdir) $ do-            setSession (hscEnv scriptSession)-            compileScript (atomFunctionBodyType scriptSession) _funcScript-          case eCompiledScript of-            Left err -> throwIO err-            Right compiledScript -> pure AtomFunction { atomFuncName = funcName,-                                                        atomFuncType = _funcType,-                                                        atomFuncBody = AtomFunctionBody (Just _funcScript) compiledScript }+          case _mScriptSession of+            Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"+            Just scriptSession -> do+              --risk of GHC exception during compilation here+              eCompiledScript <- runGhc (Just libdir) $ do+                setSession (hscEnv scriptSession)+                compileScript (atomFunctionBodyType scriptSession) _funcScript+              case eCompiledScript of+                Left err -> throwIO err+                Right compiledScript -> pure Function { funcName = funcName',+                                                        funcType = _funcType,+                                                        funcBody = FunctionScriptBody _funcScript compiledScript } #else-      error "Haskell scripting is disabled"+         error "Haskell scripting is disabled" #endif                                      --if the script session is enabled, compile the script, otherwise, hard error!     -readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction+readAtomFunc :: FilePath -> FunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction #if !defined(PM36_HASKELL_SCRIPTING) readAtomFunc _ _ _ _ = error "Haskell scripting is disabled" #else-readAtomFunc transDir funcName mScriptSession precompiledFuncs = do+readAtomFunc transDir funcName' mScriptSession precompiledFuncs = do   let atomFuncPath = atomFuncsPath transDir-  (funcType, mFuncScript) <- readFileDeserialise @([AtomType],Maybe T.Text) atomFuncPath+  (funcType', mFuncScript) <- readFileDeserialise @([AtomType],Maybe T.Text) atomFuncPath   case mFuncScript of     --handle pre-compiled case- pull it from the precompiled list-    Nothing -> case atomFunctionForName funcName precompiledFuncs of+    Nothing -> case atomFunctionForName funcName' precompiledFuncs of       --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored-      Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)+      Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName')       Right realFunc -> pure realFunc     --handle a real Haskell scripted function- compile and load     Just funcScript ->@@ -172,55 +217,9 @@             compileScript (atomFunctionBodyType scriptSession) funcScript           case eCompiledScript of             Left err -> throwIO err-            Right compiledScript -> pure AtomFunction { atomFuncName = funcName,-                                                         atomFuncType = funcType,-                                                         atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }-#endif---writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()-writeDBCFuncs sync transDir funcs = mapM_ (writeDBCFunc sync transDir) (HS.toList funcs)-  -writeDBCFunc :: DiskSync -> FilePath -> DatabaseContextFunction -> IO ()-writeDBCFunc sync transDir func = do-  let dbcFuncPath = dbcFuncsDir transDir </> T.unpack (dbcFuncName func)  -  writeBSFileSync sync dbcFuncPath (serialise (dbcFuncType func, databaseContextFunctionScript func))--readDBCFuncs :: FilePath -> Maybe ScriptSession -> IO DatabaseContextFunctions-readDBCFuncs transDir mScriptSession = do-  funcNames <- getDirectoryNames (dbcFuncsDir transDir)-  --only Haskell script functions can be serialized-  --we always return the pre-compiled functions-  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-#if !defined(PM36_HASKELL_SCRIPTING)-readDBCFunc transDir funcName _ precompiledFuncs = do-#else-readDBCFunc transDir funcName mScriptSession precompiledFuncs = do-#endif-  let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName-  (_funcType, mFuncScript) <- readFileDeserialise @([AtomType], Maybe T.Text) dbcFuncPath-  case mFuncScript of-    Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of-      Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)-      Right realFunc -> pure realFunc --return precompiled function-    Just _funcScript ->-#ifdef PM36_HASKELL_SCRIPTING-      case mScriptSession of-        Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"-        Just scriptSession -> do-          eCompiledScript <- runGhc (Just libdir) $ do-            setSession (hscEnv scriptSession)-            compileScript (dbcFunctionBodyType scriptSession) _funcScript-          case eCompiledScript of-            Left err -> throwIO err-            Right compiledScript -> pure DatabaseContextFunction { dbcFuncName = funcName,-                                                                    dbcFuncType = _funcType,-                                                                    dbcFuncBody = DatabaseContextFunctionBody (Just _funcScript) compiledScript}-#else-      error "Haskell scripting is disabled"+            Right compiledScript -> pure Function { funcName = funcName',+                                                    funcType = funcType',+                                                    funcBody = FunctionScriptBody funcScript compiledScript } #endif  writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()
src/lib/ProjectM36/TransactionGraph.hs view
@@ -133,13 +133,11 @@  --adds a disconnected transaction to a transaction graph at some head addDisconnectedTransaction :: UTCTime -> TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)-addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) graph = addTransactionToGraph headName newTrans' graph+addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans   where     newTrans = Transaction newId newTInfo schemas'     newTInfo = TI.singleParent parentId stamp'-    newTrans' = Transaction newId (newTInfo { merkleHash = newHash }) schemas'-    newHash = calculateMerkleHash newTrans graph--lookup parents in graph to calculate---LOOP+ addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph) addTransactionToGraph headName newTrans graph = do   let parentIds' = parentIds newTrans@@ -159,9 +157,13 @@   when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))   --replace all references to UncommittedTransactionMarker to new transaction id   let newTrans' = newTransUncommittedReplace newTrans-      updatedTransSet = S.insert newTrans' (transactionsForGraph graph)-      updatedHeads = M.insert headName newTrans' (transactionHeadsForGraph graph)-  pure (newTrans', TransactionGraph updatedHeads updatedTransSet)+      --add merkle hash to all new transactions+      hashedTransactionInfo = (transactionInfo newTrans')+                              { merkleHash = calculateMerkleHash newTrans' graph }+      hashedTrans = Transaction (transactionId newTrans') hashedTransactionInfo (schemas newTrans')+      updatedTransSet = S.insert hashedTrans (transactionsForGraph graph)+      updatedHeads = M.insert headName hashedTrans (transactionHeadsForGraph graph)+  pure (hashedTrans, TransactionGraph updatedHeads updatedTransSet)  --replace all occurrences of the uncommitted context marker newTransUncommittedReplace :: Transaction -> Transaction@@ -384,7 +386,7 @@     else do     currentTransChildren <- childTransactions currentTrans' origGraph     let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren-        searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)+        searchChild start' = pathToTransaction origGraph start' goalTrans (S.insert currentTrans' traverseSet)         childSearches = map searchChild (S.toList searchChildren)         errors = lefts childSearches         pathsFound = rights childSearches@@ -596,10 +598,15 @@    -- the new hash includes the parents' ids, the current id, and the hash of the context, and the merkle hashes of the parent transactions calculateMerkleHash :: Transaction -> TransactionGraph -> MerkleHash-calculateMerkleHash trans graph = MerkleHash $ hashlazy (BL.fromChunks [transIds,-                                                                        schemasBytes-                                                                       ] <>                                                      dbcBytes <> parentMerkleHashes)+calculateMerkleHash trans graph = +  MerkleHash newHash   where+    newHash = hashlazy (BL.fromChunks [transIdsBytes,+                                         schemasBytes,+                                         tstampBytes+                                       ] <> dbcBytes <> parentMerkleHashes)+    tstamp = stamp (transactionInfo trans)+    tstampBytes = serialise tstamp     parentMerkleHashes = BL.fromChunks $ map (_unMerkleHash . getMerkleHash) parentTranses     parentTranses =       case transactionsForIds (parentIds trans) graph of@@ -607,7 +614,8 @@         Left e -> error ("failed to find transaction in Merkle hash construction: " ++ show e)         Right t -> S.toList t     getMerkleHash t = merkleHash (transactionInfo t)-    transIds = serialise (transactionId trans : S.toList (parentIds trans))+    transIds = transactionId trans : S.toAscList (parentIds trans)+    transIdsBytes = serialise transIds     dbcBytes = DBC.hashBytes (concreteDatabaseContext trans)     schemasBytes = serialise (subschemas trans) @@ -622,7 +630,7 @@     actualHash = calculateMerkleHash trans graph  data MerkleValidationError = MerkleValidationError TransactionId MerkleHash MerkleHash-  deriving (Show, Eq, Generic)+  deriving (Show,Eq, Generic)  validateMerkleHashes :: TransactionGraph -> Either [MerkleValidationError] () validateMerkleHashes graph =
src/lib/ProjectM36/TransactionGraph/Merge.hs view
@@ -7,7 +7,6 @@ import qualified Data.Set as S import qualified Data.Map as M import qualified ProjectM36.TypeConstructorDef as TCD-import Control.Monad (foldM) import qualified Data.HashSet as HS  data MergePreference = PreferFirst | PreferSecond | PreferNeither
src/lib/ProjectM36/TransactionGraph/Persist.hs view
@@ -43,7 +43,7 @@ -}  expectedVersion :: Int-expectedVersion = 5+expectedVersion = 6  transactionLogFileName :: FilePath  transactionLogFileName = "m36v" ++ show expectedVersion@@ -98,9 +98,12 @@   createDirectory dbdir   locker <- openLockFile (lockFilePath dbdir)   let allTransIds = map transactionId (S.toList (transactionsForGraph bootstrapGraph))+  createDirectoryIfMissing False (ProjectM36.TransactionGraph.Persist.objectFilesPath dbdir)   digest  <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (transactionGraphPersist sync dbdir allTransIds bootstrapGraph)   pure (locker, digest)-  ++objectFilesPath :: FilePath -> FilePath+objectFilesPath dbdir = dbdir </> "compiled_modules" {-  incrementally updates an existing database directory --algorithm:
src/lib/ProjectM36/Tuple.hs view
@@ -1,7 +1,7 @@ module ProjectM36.Tuple where import ProjectM36.Base import ProjectM36.Error-import ProjectM36.Attribute+import ProjectM36.Attribute as A import ProjectM36.Atom import ProjectM36.AtomType import ProjectM36.DataTypes.Primitive@@ -15,19 +15,19 @@ import Data.Maybe  emptyTuple :: RelationTuple-emptyTuple = RelationTuple V.empty V.empty+emptyTuple = RelationTuple mempty mempty  tupleSize :: RelationTuple -> Int-tupleSize (RelationTuple tupAttrs _) = V.length tupAttrs+tupleSize (RelationTuple tupAttrs _) = arity tupAttrs  tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName-tupleAttributeNameSet (RelationTuple tupAttrs _) = S.fromList $ V.toList $ V.map attributeName tupAttrs+tupleAttributeNameSet (RelationTuple tupAttrs _) = attributeNameSet tupAttrs  tupleAttributes :: RelationTuple -> Attributes tupleAttributes (RelationTuple tupAttrs _) = tupAttrs  tupleAssocs :: RelationTuple -> [(AttributeName, Atom)]-tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (first attributeName) (V.zip attrVec tupVec)+tupleAssocs (RelationTuple attrs tupVec) = V.toList $ V.map (first attributeName) (V.zip (attributesVec attrs) tupVec)  orderedTupleAssocs :: RelationTuple -> [(AttributeName, Atom)] orderedTupleAssocs tup@(RelationTuple attrVec _) = map (\attr -> (attributeName attr, atomForAttr (attributeName attr))) oAttrs@@ -42,7 +42,7 @@ tupleAtoms (RelationTuple _ tupVec) = tupVec  atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom-atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of+atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) (attributesVec tupAttrs) of   Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))   Just index -> case tupVec V.!? index of     Nothing -> Left (NoSuchAttributeNamesError (S.singleton attrName))@@ -59,7 +59,7 @@                                                      Right $ V.map mapper attrNameVec   where     unknownAttrNames = V.filter (`V.notElem` attributeNames attrs) attrNameVec-    mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (V.map attributeName attrs))+    mapper attrName = fromMaybe (error "logic failure in vectorIndicesForAttributeNames") (V.elemIndex attrName (attributeNames attrs))   relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation@@ -86,10 +86,10 @@     mapper = mkRelationTuple attrs      mkRelationTupleFromMap :: M.Map AttributeName Atom -> RelationTuple-mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (attrMap M.!) attrNames)+mkRelationTupleFromMap attrMap = RelationTuple (attributesFromList attrs) (V.map (attrMap M.!) (V.fromList attrNames))   where-    attrNames = V.fromList (M.keys attrMap)-    attrs = V.map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames+    attrNames = M.keys attrMap+    attrs = map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames  --return error if attribute names match but their types do not singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]@@ -120,8 +120,8 @@     return $ Just $ RelationTuple joinedAttrs newVec   where     keysIntersection = V.map attributeName attrsIntersection-    attrsIntersection = V.filter (`V.elem` tupAttrs1) tupAttrs2-    newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs+    attrsIntersection = V.filter (`V.elem` attributesVec tupAttrs1) (attributesVec tupAttrs2)+    newVec = V.map (findAtomForAttributeName . attributeName) (attributesVec joinedAttrs)     --search both tuples for the attribute     findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2] @@ -138,23 +138,31 @@ tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec   where-    newAttrs = tupAttrs1 V.++ tupAttrs2-    newVec = tupVec1 V.++ tupVec2+    newAttrs = tupAttrs1 <> tupAttrs2+    newVec = tupVec1 <> tupVec2  tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup   where-    newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)+    newTup = RelationTuple (A.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom) ---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 :: S.Set AttributeName -> RelationTuple -> RelationTuple tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec   where-    deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) attrs+    deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) (attributesVec attrs)     indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)-    newAttrs = indexDeleter attrs+    newAttrs = case A.projectionAttributesForNames projectAttrs attrs of+                 Left err -> error (show (err, projectAttrs, attrs))+                 Right attrs' ->  attrs'     newTupVec = indexDeleter tupVec-+-}+-- remember that the attributes order matters+tupleProject :: Attributes -> RelationTuple -> Either RelationalError RelationTuple+tupleProject projectAttrs tup = do+  newTupVec <- foldM (\acc attr ->+                        V.snoc acc <$> atomForAttributeName (attributeName attr) tup+                        ) V.empty (attributesVec projectAttrs)+  pure $ reorderTuple projectAttrs (RelationTuple projectAttrs newTupVec) --return the attributes and atoms which are equal in both vectors --semi-join tupleIntersection :: RelationTuple -> RelationTuple -> RelationTuple@@ -162,12 +170,14 @@   where     attrs1 = tupleAttributes tuple1     attrs2 = tupleAttributes tuple2-    matchingIndices = V.findIndices (\attr -> V.elem attr attrs2 &&-                                              atomForAttributeName (attributeName attr) tuple1 ==-                                              atomForAttributeName (attributeName attr) tuple2-                                    ) attrs1+    intersectAttrs = A.intersection attrs1 attrs2+    matchingIndices = V.findIndices (\attr -> A.member attr intersectAttrs &&+                                    atomForAttributeName (attributeName attr) tuple1 ==+                                    atomForAttributeName (attributeName attr) tuple2) (attributesVec attrs1)     indexFilter = V.ifilter (\index _ -> V.elem index matchingIndices)-    newAttrs = indexFilter attrs1+    newAttrs = case A.projectionAttributesForNames (A.attributeNameSet intersectAttrs) attrs1 of+      Left _ -> mempty+      Right attrs' -> attrs'     newTupVec = indexFilter (tupleAtoms tuple1)  -- | An optimized form of tuple update which updates vectors efficiently.@@ -175,19 +185,20 @@ updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec   where     updateKeysSet = M.keysSet updateMap-    updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)+    updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed (attributesVec attrs))     newVec = V.update tupVec updateVec     updateVec = V.map (\(index, attr) -> (index, updateMap M.! attributeName attr)) updateKeysIVec  tupleToMap :: RelationTuple -> M.Map AttributeName Atom tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList   where-    assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)+    assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed (attributesVec attrs)) +-- | Validate that the tuple has the correct attributes in the correct order verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple-verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs+verifyTuple attrs tuple = let attrsTypes = A.atomTypes attrs                               tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in-  if V.length attrs /= V.length tupleTypes then+  if A.arity attrs /= V.length tupleTypes then     Left $ TupleAttributeCountMismatchError 0   else do     mapM_ (uncurry atomTypeVerify) (V.zip attrsTypes tupleTypes)@@ -196,15 +207,18 @@ --two tuples can be equal but the vectors of attributes could be out-of-order --reorder if necessary- this is useful during relMogrify so that all the relation's tuples have identical atom/attribute ordering reorderTuple :: Attributes -> RelationTuple -> RelationTuple-reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then+reorderTuple attrs tupIn = if attributesAndOrderEqual (tupleAttributes tupIn) attrs then                              tupIn                            else-                             RelationTuple attrs (V.map mapper attrs)+                             RelationTuple attrs (V.map mapper (attributesVec attrs))   where     mapper attr = case atomForAttributeName (attributeName attr) tupIn of-      Left err -> error ("logic bug in reorderTuple: " ++ show err)+      Left err -> error ("logic bug in reorderTuple: " ++ show err <> show tupIn)       Right atom -> atom  --used in Generics derivation for ADTs without named attributes trimTuple :: Int -> RelationTuple -> RelationTuple-trimTuple index (RelationTuple attrs vals) = RelationTuple (V.drop index attrs) (V.drop index vals)+trimTuple index (RelationTuple attrs vals) =+  RelationTuple newAttrs (V.drop index vals)+  where+    newAttrs = A.drop index attrs
src/lib/ProjectM36/TupleSet.hs view
@@ -31,3 +31,10 @@  mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (mkRelationTuple attrs . V.fromList) atomMatrix+++-- | Union two tuplesets while reordering their attribute/atom mapping properly.+tupleSetUnion :: Attributes -> RelationTupleSet -> RelationTupleSet -> RelationTupleSet+tupleSetUnion targetAttrs tupSet1 tupSet2 = RelationTupleSet $ HS.toList . HS.fromList $ reorder (asList tupSet1) ++ reorder (asList tupSet2)+  where+    reorder = map (reorderTuple targetAttrs)
src/lib/ProjectM36/Tupleable.hs view
@@ -38,7 +38,7 @@ import qualified Data.Vector                    as V import           GHC.Generics import           ProjectM36.Atomable-import           ProjectM36.Attribute           hiding (null)+import           ProjectM36.Attribute           as A hiding (null, toList) import           ProjectM36.Base import           ProjectM36.DataTypes.Primitive import           ProjectM36.Error@@ -89,7 +89,7 @@  -- | 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))+toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList (attributesVec attrs)))   where     attrs = toAttributes (Proxy :: Proxy a) @@ -228,11 +228,12 @@   toTupleG opts (M1 v) = RelationTuple attrs atoms     where       attrsToCheck = toAttributesG opts v-      counter = V.generate (V.length attrsToCheck) id-      attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then+      counter = V.generate (arity attrsToCheck) id+      attrs = attributesFromList (V.toList attrsV)+      attrsV = 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 (attributesVec attrsToCheck)       atoms = V.fromList (toAtomsG v)   toAttributesG opts (M1 v) = toAttributesG opts v   fromTupleG opts tup = M1 <$> fromTupleG opts tup@@ -241,7 +242,7 @@ -- product types instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where   toTupleG = error "toTupleG"-  toAttributesG opts ~(x :*: y) = toAttributesG opts x V.++ toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception+  toAttributesG opts ~(x :*: y) = toAttributesG opts x <> toAttributesG opts y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception   fromTupleG opts tup = (:*:) <$> fromTupleG opts tup <*> fromTupleG opts processedTuple     where       processedTuple = if isRecordTypeG (undefined :: a x) then@@ -253,7 +254,7 @@ --selector/record instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where   toTupleG = error "toTupleG"-  toAttributesG opts m@(M1 v) = V.singleton (Attribute modifiedName aType)+  toAttributesG opts m@(M1 v) = A.singleton (Attribute modifiedName aType)    where      name = T.pack (selName m)      modifiedName = if T.null name then@@ -268,7 +269,7 @@                      val <- atomv atom                      pure (M1 val)    where-     expectedAtomType = atomType (V.head (toAttributesG opts (undefined :: M1 S c a x)))+     expectedAtomType = atomType (V.head (attributesVec (toAttributesG opts (undefined :: M1 S c a x))))      atomv atom = maybe (Left (AtomTypeMismatchError                                expectedAtomType                                (atomTypeForAtom atom)
src/lib/ProjectM36/WithNameExpr.hs view
@@ -42,9 +42,11 @@ substituteWithNameMacros macros (Extend extendTup expr) =   Extend (substituteWitNameMacrosExtendTupleExpr macros extendTup) (substituteWithNameMacros macros expr) substituteWithNameMacros macros (With moreMacros expr) =-  --collect and override existing macros and recurse+  --collect and update nested with exprs   let newMacros = foldr macroFolder macros moreMacros-      macroFolder (wnexpr, mexpr) acc = filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, mexpr)] in+      macroFolder (wnexpr, mexpr) acc =+        let subExpr = substituteWithNameMacros macros mexpr in+        filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, subExpr)] in         --scan for a match- if it exists, replace it (representing a with clause at a lower level   substituteWithNameMacros newMacros expr
test/Client/Simple.hs view
@@ -9,7 +9,6 @@ import System.FilePath import ProjectM36.TupleSet import ProjectM36.Attribute-import qualified Data.Vector as V import qualified Data.Map as M  main :: IO ()           @@ -59,7 +58,7 @@       execute $ Assign "x" (ExistingRelation relationTrue)       --cause error       execute $ Assign "x" (MakeStaticRelation failAttrs emptyTupleSet)-  let expectedErr = Left (RelError (RelationTypeMismatchError V.empty failAttrs))+  let expectedErr = Left (RelError (RelationTypeMismatchError mempty failAttrs))   assertEqual "dbc error" expectedErr err  -- #176 default merge couldn't handle Update
test/Relation/Basic.hs view
@@ -3,8 +3,6 @@ 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.TransactionGraph@@ -25,8 +23,8 @@                      testRelation "products" productsRel,                      testRelation "supplierProducts" supplierProductsRel,                      testMkRelationFromExprsBadAttrs,-                     testDuplicateAttributes,-                     testExistingRelationType+                     testExistingRelationType,+                     testReorderTuple                     ]  main :: IO ()           @@ -65,7 +63,7 @@     attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of                                  Left _ -> False                                  Right atom -> Right (atomTypeForAtom atom) ==-                                  A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)+                                  A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributesVec (attributes rel))      simpleRel :: Relation     simpleRel = case mkRelation attrs tupleSet of@@ -103,16 +101,19 @@     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-   testExistingRelationType :: Test testExistingRelationType = TestCase $ do   (graph, _) <- freshTransactionGraph dateExamples   let typeResult = runRelationalExprM reenv (typeForRelationalExpr (ExistingRelation relationTrue))       reenv = mkRelationalExprEnv dateExamples graph   assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult++-- | Ensure that tuple reordering honors the +testReorderTuple :: Test+testReorderTuple = TestCase $ do+  let tup1 = mkRelationTuple attrs1 (V.fromList [IntAtom 4, TextAtom "test"])+      attrs1 = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" TextAtomType]+      attrs2 = A.attributesFromList [Attribute "b" TextAtomType, Attribute "a" IntAtomType]+      actual = reorderTuple attrs2 tup1+      expected = mkRelationTuple attrs2 (V.fromList [TextAtom "test", IntAtom 4])+  assertEqual "reorderTuple" expected actual
test/Relation/StaticOptimizer.hs view
@@ -81,7 +81,7 @@       tautFalse2 = Restrict (NotPredicate TruePredicate) rel       emptyRel = MakeStaticRelation (attributes suppliersRel) emptyTupleSet       rel = RelationVariable "s" UncommittedContextMarker-      optRelExpr expr = optimizeGraphRefRelationalExpr' (Just dateExamples) graph expr      +      optRelExpr = optimizeGraphRefRelationalExpr' (Just dateExamples) graph   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)
test/Relation/Tupleable.hs view
@@ -13,7 +13,7 @@ import Test.HUnit import ProjectM36.Tupleable.Deriving import ProjectM36.Atomable-import ProjectM36.Attribute+import ProjectM36.Attribute as A import ProjectM36.Error import ProjectM36.Base import Control.DeepSeq (NFData)@@ -110,7 +110,7 @@   if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess  testList :: Test-testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8, testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple, testAddPrefixField, testDropPrefixField, testAddSuffixField, testDropSuffixField, testUpperCaseField, testLowerCaseField, testTitleCaseField, testCamelCaseField, testPascalCaseField, testSnakeCaseField, testSpinalCaseField, testTrainCaseField, testAsIsCodec, testAsIsField, testComposeRLCodec, testComposeRLField, testComposeLRCodec, testComposeLRField]+testList = TestList [testADT1, testADT2, testADT3, testADT4, testADT6, testADT7, testADT8  ,testInsertExpr, testDefineExpr, testUpdateExpr, testUpdateExprEmptyAttrs, testDeleteExpr, testUpdateExprWrongAttr, testReorderedTuple, testAddPrefixField, testDropPrefixField, testAddSuffixField, testDropSuffixField, testUpperCaseField, testLowerCaseField, testTitleCaseField, testCamelCaseField, testPascalCaseField, testSnakeCaseField, testSpinalCaseField, testTrainCaseField, testAsIsCodec, testAsIsField, testComposeRLCodec, testComposeRLField, testComposeLRCodec, testComposeLRField]  testADT1 :: Test testADT1 = TestCase $ assertEqual "one record constructor" (Right example) (fromTuple (toTuple example))@@ -148,7 +148,7 @@ testADT7 = TestCase $ do   let example = Test7C (Test7AC 3)   assertEqual "atom type" (Right example) (fromTuple (toTuple example))-  let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))+  let expectedAttrs = A.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))   assertEqual "adt atomtype" expectedAttrs (toAttributes (Proxy :: Proxy Test7T))      testADT8 :: Test    @@ -222,7 +222,8 @@ testReorderedTuple :: Test testReorderedTuple = TestCase $ do   let tupleRev :: RelationTuple -> RelationTuple-      tupleRev (RelationTuple v1 v2) = RelationTuple (V.reverse v1) (V.reverse v2)+      tupleRev (RelationTuple v1 v2) = RelationTuple (revAttrs v1) (V.reverse v2)+      revAttrs attrs = A.attributesFromList (reverse (A.toList attrs))       expected = Test2C {attrB = 3,                           attrC = 4}       actual = fromTuple . tupleRev . toTuple $ expected
test/Server/Main.hs view
@@ -23,8 +23,6 @@ import System.Directory #endif -import Debug.Trace- type Timeout = Int  testList :: SessionId -> Connection -> MVar () -> Test@@ -44,7 +42,7 @@       testRelationVariableSummary,       testNotification notificationTestMVar       ] -    serverTests = [testRequestTimeout, testFileDescriptorCount]+    serverTests = [testRequestTimeout, testFileDescriptorCount, testClientConnectFail]  main :: IO () main = do@@ -209,7 +207,7 @@   case eTestConn of     Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure     Right (session, testConn) -> do-      res <- catchJust (\exc -> if traceShowId exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))+      res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))       assertBool "timeout exception was not thrown" (not res)       killThread serverTid       @@ -240,3 +238,11 @@ --pass on non-linux platforms testFileDescriptorCount = TestCase (pure ()) #endif++testClientConnectFail :: Test+testClientConnectFail = TestCase $ do+  let connInfo = RemoteConnectionInfo "nonexistentdb" "127.0.0.1" "7777" emptyNotificationCallback+  eConn <- connectProjectM36 connInfo+  case eConn of+    Left (IOExceptionError _) -> pure ()+    _ -> assertFailure "connection failure failed"
test/TransactionGraph/Automerge.hs view
@@ -72,7 +72,7 @@      _ <- checkEither $ executeRelationalExpr sessionPastId conn (RelationVariable "s" ())   -  assertEqual "merge failure" (Left (InclusionDependencyCheckError "s_pkey")) mergeRes+  assertEqual "merge failure" (Left (InclusionDependencyCheckError "s_pkey" Nothing)) mergeRes    --reported as #128 testAutomergeReconnect :: Test
test/TransactionGraph/Merge.hs view
@@ -15,17 +15,6 @@  import qualified Data.ByteString.Lazy as BS import System.Exit----------- import Data.Word import qualified Data.UUID as U import qualified Data.Set as S@@ -290,7 +279,7 @@   let eMerge = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")       env = freshGraphRefRelationalExprEnv Nothing graph''   case eMerge of-    Left (InclusionDependencyCheckError incDepName') -> assertEqual "incdep violation name" incDepName incDepName'+    Left (InclusionDependencyCheckError incDepName' Nothing) -> assertEqual "incdep violation name" incDepName incDepName'     Left err -> assertFailure ("other error: " ++ show err)     Right _ -> assertFailure "constraint violation missing"
− test/TutorialD/Interpreter.hs 
@@ -1,726 +0,0 @@-import TutorialD.Interpreter.DatabaseContextExpr-import TutorialD.Interpreter.TestBase-import TutorialD.Interpreter-import TutorialD.Interpreter.Base-import Test.HUnit-import ProjectM36.Relation as R-import ProjectM36.Tuple-import ProjectM36.TupleSet-import ProjectM36.Error-import ProjectM36.DatabaseContext-import ProjectM36.AtomFunctions.Primitive-import ProjectM36.RelationalExpression-import ProjectM36.DataTypes.Either-import ProjectM36.DataTypes.Interval-import ProjectM36.DataTypes.NonEmptyList-import ProjectM36.DataTypes.List-import ProjectM36.DateExamples-import ProjectM36.Base hiding (Finite)-import ProjectM36.TransactionGraph-import ProjectM36.Client-import qualified ProjectM36.DisconnectedTransaction as Discon-import qualified ProjectM36.AttributeNames as AN-import qualified ProjectM36.Session as Sess-import qualified ProjectM36.Attribute as A-import qualified Data.Map as M-import System.Exit-import Data.Maybe (isJust)-import qualified Data.Vector as V-import Data.Text.Encoding as TE-import Control.Concurrent-import qualified Data.Set as S-import Data.Text hiding (map)-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 = [-      simpleRelTests,-      dateExampleRelTests,-      transactionGraphBasicTest, -      transactionGraphAddCommitTest, -      transactionRollbackTest, -      transactionJumpTest, -      transactionBranchTest, -      simpleJoinTest, -      testNotification,-      testTypeConstructors, -      testMergeTransactions, -      testComments, -      testTransGraphRelationalExpr, -      failJoinTest, -      testMultiAttributeRename, -      testSchemaExpr, -      testRelationalExprStateTupleElems, -      testFunctionalDependencies, -      testEmptyCommits,-      testIntervalAtom,-      testListConstructedAtom,-      testTypeChecker,-      testRestrictionPredicateExprs,-      testRelationalAttributeNames,-      testSemijoin,-      testAntijoin,-      testRelationAttributeDefinition,-      testAssignWithTypeVar,-      testDefineWithTypeVar,-      testIntervalType,-      testArbitraryRelation,-      testNonEmptyListType,-      testUnresolvedAtomTypes,-      testWithClause,-      testAtomFunctionArgumentMismatch,-      testInvalidDataConstructor,-      testBasicList,-      testRelationDeclarationMismatch,-      testInvalidTuples,-      testSelfReferencingUncommittedContext,-      testUnionAndIntersectionAttributeExprs-      ]--simpleRelTests :: Test-simpleRelTests = TestCase $ do-  (graph, transId) <- freshTransactionGraph dateExamples  -  mapM_ (\(tutd, expected) -> assertTutdEqual basicDatabaseContext transId graph expected tutd) testTups-  where-    testTups = [("x:=true", Right relationTrue),-                      ("x:=false", Right relationFalse),-                      ("x:=true union false", Right relationTrue),-                      ("x:=true minus false", Right relationTrue),-                      ("x:=false minus true", Right relationFalse),                      -                      ("x:=true; x:=false", Right relationFalse),-                      ("x:=relation{a Integer}{}", mkRelation simpleAAttributes emptyTupleSet),-                      ("x:=relation{c Integer}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),-                      ("y:=relation{b Integer, c Integer}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),-                      ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntegerAtom 5])]),-                      ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),-                      ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),-                      ("x:=relation{}{}", Right relationFalse),-                      ("x:=relation{tuple{}}", Right relationTrue),-                      ("x:=true where true", Right relationTrue),-                      ("x:=true where false", Right relationFalse),-                      ("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)]]),-                      -- 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])]),-                      ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 5])]),-                      ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 6])]),-                      ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 10])]),-                      ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntegerAtomType TextAtomType)),-                      ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])]),-                      ("x:=false:{a:=1,b:=2}", mkRelationFromTuples simpleDAttributes [])-                     ]-    simpleAAttributes = A.attributesFromList [Attribute "a" IntegerAtomType]-    simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]-    simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntegerAtomType]-    simpleDAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]-    simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]-    nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]-  -dateExampleRelTests :: Test-dateExampleRelTests = TestCase $ do-  (graph, transId) <- freshTransactionGraph dateExamples-  mapM_ (\(tutd, expected) -> assertTutdEqual dateExamples transId graph expected tutd) testTups-  where-    simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]-    maybeIntegerAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType)-    maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)-    simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]-    simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntegerAtomType]-    byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]    -    minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType]-    groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]-    updateParisPlus10 = relMap (\tuple -> do-                                   statusAtom <- atomForAttributeName "status" tuple-                                   cityAtom <- atomForAttributeName "city" tuple-                                   if cityAtom == TextAtom "Paris" then-                                     Right $ updateTupleWithAtoms (M.singleton "status" (IntegerAtom (castInteger statusAtom + 10))) tuple-                                     else Right tuple) suppliersRel-    extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]-    testTups = [("x:=s where true", Right suppliersRel),-                           ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == Right (TextAtom "London")) suppliersRel),-                           ("x:=s where false", Right $ Relation (R.attributes suppliersRel) emptyTupleSet),-                           ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (R.attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),-                           ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntegerAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntegerAtomType]) (V.fromList [IntegerAtom 50])])),-                           ("x:=s minus (s where status=20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),-                           --atom function tests-                           ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),-                           ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])),-                           ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == Right (TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),-                           ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),-                           --relatom function tests-                           ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntegerAtom 1)])),-                           ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel),-                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),-                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),-                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),-                           --boolean function restriction-                           ("x:=s where ^lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),-                           ("x:=s where ^gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],-                                                                                                       [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),-                           ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntegerAtomType BoolAtomType),-                           ("x:=s where ^not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),-                           --test "all but" attribute inversion syntax-                           ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),-                           --test key syntax-                           ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint")),-                           ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right relationTrue),-                           --test binary bytestring data type-                           ("x:=relation{tuple{y bytestring(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),-                           --test Maybe Text-                           ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]),-                           --test Maybe Integer-                           ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntegerAtomType [IntegerAtom 3]]]),-                           --test Either Integer Text-                           ("x:=relation{tuple{a Left 3}}",  Left (TypeConstructorTypeVarMissing "b")), -- 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)))]]),-                           --test Day constructor-                           ("x:=relation{tuple{a fromGregorian(2017,05,30)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DayAtomType]) [[DayAtom (fromGregorian 2017 05 30)]])-                          ]--assertTutdEqual :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError Relation -> Text -> Assertion-assertTutdEqual databaseContext transId graph expected tutd = assertEqual (unpack tutd) expected interpreted-  where-    interpreted = case interpretDatabaseContextExpr databaseContext transId graph tutd of-      Left err -> Left err-      Right context -> case M.lookup "x" (relationVariables context) of-        Nothing -> Left $ RelVarNotDefinedError "x"-        Just relExpr -> do-          let env = freshGraphRefRelationalExprEnv (Just context) graph-          runGraphRefRelationalExprM env (evalGraphRefRelationalExpr relExpr)---transactionGraphBasicTest :: Test-transactionGraphBasicTest = TestCase $ do-  (_, dbconn) <- dateExamplesConnection emptyNotificationCallback-  graph <- transactionGraph_ dbconn-  assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing----add a new transaction to the graph, validate it is in the graph-transactionGraphAddCommitTest :: Test-transactionGraphAddCommitTest = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  case parseTutorialD "x:=s" of-    Left err -> assertFailure (show err)-    Right parsed -> do -      result <- evalTutorialD sessionId dbconn UnsafeEvaluation parsed-      case result of-        QuitResult -> assertFailure "quit?"-        DisplayResult _ -> assertFailure "display?"-        DisplayIOResult _ -> assertFailure "displayIO?"-        DisplayRelationResult _ -> assertFailure "displayrelation?"-        DisplayDataFrameResult _ -> assertFailure "displaydataframe?"-        DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"-        DisplayErrorResult err -> assertFailure (show err)   -        QuietSuccessResult -> do-          commit sessionId dbconn >>= eitherFail-          discon <- disconnectedTransaction_ sessionId dbconn-          let context = Discon.concreteDatabaseContext discon-          assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just (ExistingRelation suppliersRel))--transactionRollbackTest :: Test-transactionRollbackTest = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  graph <- transactionGraph_ dbconn-  executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail-  rollback sessionId dbconn >>= eitherFail-  discon <- disconnectedTransaction_ sessionId dbconn-  graph' <- transactionGraph_ dbconn-  assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))-  let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)-  assertEqual "validate graph" (graphEq graph) (graphEq graph')----commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present-transactionJumpTest :: Test-transactionJumpTest = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  (DisconnectedTransaction firstUUID _ _) <- disconnectedTransaction_ sessionId dbconn-  executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail-  commit sessionId dbconn >>= eitherFail-  --perform the jump-  executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID) >>= eitherFail-  --check that the disconnected transaction does not include "x"-  discon <- disconnectedTransaction_ sessionId dbconn-  assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))          ---branch from the first transaction and verify that there are two heads-transactionBranchTest :: Test-transactionBranchTest = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  mapM_ (>>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"),-                                  executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),-                                  commit sessionId dbconn,-                                  executeGraphExpr sessionId dbconn (JumpToHead "master"),-                                  executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))-                  ]-  graph <- transactionGraph_ dbconn-  assertBool "master branch exists" $ isJust (transactionForHead "master" graph)-  assertBool "test branch exists" $ isJust (transactionForHead "test" graph)---- test that overlapping attribute names with different types fail with an error-failJoinTest :: Test-failJoinTest = TestCase $ do-  (graph, transId) <- freshTransactionGraph dateExamples  -  assertTutdEqual basicDatabaseContext transId graph err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"-  where-    err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntegerAtomType]))--simpleJoinTest :: Test-simpleJoinTest = TestCase $ do-  (graph, transId) <- freshTransactionGraph dateExamples    -  assertTutdEqual dateExamples transId graph joinedRel "x:=s join sp"-    where-        attrs = A.attributesFromList [Attribute "city" TextAtomType,-                                      Attribute "qty" IntegerAtomType,-                                      Attribute "p#" TextAtomType,-                                      Attribute "s#" TextAtomType,-                                      Attribute "sname" TextAtomType,-                                      Attribute "status" IntegerAtomType]-        joinedRel = mkRelationFromList attrs [[TextAtom "London", IntegerAtom 100, TextAtom "P6", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],-                                              [TextAtom "London", IntegerAtom 400, TextAtom "P3", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],-                                              [TextAtom "London", IntegerAtom 400, TextAtom "P5", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],-                                              [TextAtom "London", IntegerAtom 300, TextAtom "P1", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],-                                              [TextAtom "Paris", IntegerAtom 200, TextAtom "P2", TextAtom "S3", TextAtom "Blake", IntegerAtom 30],-                                              [TextAtom "Paris", IntegerAtom 300, TextAtom "P1", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],-                                              [TextAtom "London", IntegerAtom 100, TextAtom "P5", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],-                                              [TextAtom "London", IntegerAtom 300, TextAtom "P4", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],-                                              [TextAtom "Paris", IntegerAtom 400, TextAtom "P2", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],-                                              [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],-                                              [TextAtom "London", IntegerAtom 200, TextAtom "P4", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],-                                              [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S4", TextAtom "Clark", IntegerAtom 20]-                                              ]-                    -                    -{--inclusionDependencies :: Connection -> M.Map IncDepName InclusionDependency-inclusionDependencies (InProcessConnection (DisconnectedTransaction _ context)) = inclusionDependencies context-inclusionDependencies _ = error "remote connection used"                       --}-                           --- test notifications over the InProcessConnection-testNotification :: Test-testNotification = TestCase $ do-  notifmvar <- newEmptyMVar-  let notifCallback mvar _ _ = putMVar mvar ()-      relvarx = RelationVariable "x" ()-  (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)-  executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail-  executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx relvarx) >>= eitherFail-  commit sess conn >>= eitherFail-  executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail-  commit sess conn >>= eitherFail-  takeMVar notifmvar-    -testTypeConstructors :: Test-testTypeConstructors = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  executeTutorialD sessionId dbconn "data Hair = Color Text | Bald | UserRefusesToSpecify"-  executeTutorialD sessionId dbconn "x:=relation{a Hair}{tuple{a Color \"Blonde\"},tuple{a Bald},tuple{a UserRefusesToSpecify}}"-  executeTutorialD sessionId dbconn "data Tree a = Node a (Tree a) (Tree a) | EmptyNode"-  executeTutorialD sessionId dbconn "y:=relation{a Tree Integer}{tuple{a Node 3 (Node 4 EmptyNode EmptyNode) EmptyNode},tuple{a Node 4 EmptyNode EmptyNode}}"-  -testMergeTransactions :: Test-testMergeTransactions = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  mapM_ (executeTutorialD sessionId dbconn) [-   ":branch branchA",-   "conflictrv := relation{conflict Integer}{tuple{conflict 1}}",-   ":commit",-   ":jumphead master",-   ":branch branchB",-   "conflictrv := relation{conflict Integer}{tuple{conflict 2}}",-   ":commit",-   ":mergetrans union branchA branchB"-   ]-  case mkRelationFromList (attributesFromList [Attribute "conflict" IntegerAtomType]) [[IntegerAtom 1],[IntegerAtom 2]] of-    Left err -> assertFailure (show err)-    Right conflictCheck -> do-      eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "conflictrv" ())-      case eRv of-        Left err -> assertFailure (show err)-        Right conflictrv -> assertEqual "conflict union merge relvar" conflictCheck conflictrv--testComments :: Test-testComments = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  -  mapM_ (executeTutorialD sessionId dbconn) [-    ":branch testbranch --test comment\n",-    ":jumphead {- test comment -} master"]-  --- create a graph and query from two disparate contexts  -testTransGraphRelationalExpr :: Test    -testTransGraphRelationalExpr = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  -  mapM_ (executeTutorialD sessionId dbconn) [-    "x:=s", --dud relvar so that the commit isn't empty-    ":commit",-    ":branch testbranch",-    "insert s relation{tuple{city \"Boston\", s# \"S9\", sname \"Smithers\", status 50}}",-    ":commit"-    ]-  let masterMarker = TransactionIdHeadNameLookup "master" []-      testBranchMarker = TransactionIdHeadNameLookup "testbranch" []-      sattrs = attributesFromList [Attribute "city" TextAtomType,-                                   Attribute "sname" TextAtomType,-                                   Attribute "s#" TextAtomType,-                                   Attribute "status" IntegerAtomType]-      expectedRel = mkRelationFromList sattrs [[TextAtom "Boston",-                                                TextAtom "Smithers",-                                                TextAtom "S9",-                                                IntegerAtom 50]]-  diff <- executeTransGraphRelationalExpr sessionId dbconn (Difference (RelationVariable "s" testBranchMarker) (RelationVariable "s" masterMarker))-  assertEqual "difference in s" expectedRel diff -  -  --test graph traversal (head backtracking)-  let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]-  backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))-  assertEqual "backtrack to master" (Right relationTrue) backtrackRel-  -  --test walkback to time (stay in current location)-  now <- getCurrentTime-  headId <- headTransactionId sessionId dbconn-  _ <- executeGraphExpr sessionId dbconn (WalkBackToTime now)-  headId' <- headTransactionId sessionId dbconn-  assertEqual "transaction walk back stays in place" headId headId'--  --test branch deletion-  mapM_ (executeTutorialD sessionId dbconn) [-        ":jumphead master",-        ":deletebranch testbranch"]-  eEvald <- case parseTutorialD ":jumphead testbranch" of-    Left _ -> assertFailure "jumphead parse error" >> error "x"-    Right parsed -> evalTutorialD sessionId dbconn UnsafeEvaluation parsed-  case eEvald of-    DisplayErrorResult err -> assertEqual "testbranch deletion"  (show (NoSuchHeadNameError "testbranch")) (unpack err)-    _ -> assertFailure "failed to delete branch"-    -testMultiAttributeRename :: Test-testMultiAttributeRename = TestCase $ do-  (graph, transId) <- freshTransactionGraph dateExamples    -  assertTutdEqual dateExamples transId graph renamedRel "x:=s rename {city as town, status as price} where false"-  where-    sattrs = attributesFromList [Attribute "town" TextAtomType,-                                 Attribute "sname" TextAtomType,-                                 Attribute "s#" TextAtomType,-                                 Attribute "price" IntegerAtomType]-    renamedRel = mkRelationFromList sattrs []--testSchemaExpr :: Test-testSchemaExpr = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  -  mapM_ (executeTutorialD sessionId dbconn) [-    ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" ^gte(17,@weight))",-    ":setschema test",-    ""-    ]-  eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ())-  lightProduct <- assertEither eLightProduct-  let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntegerAtom 17), AttributeAtomExpr "weight"] ()))-  setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName >>= eitherFail-  eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))-  restrictedProduct <- assertEither eRestrictedProduct-  assertEqual "light product" restrictedProduct lightProduct-  -assertEither :: (Show a) => Either a b -> IO b-assertEither x = case x of-  Left err -> assertFailure (show err) >> undefined-  Right val -> pure val-  --- | Validate that a tuple passed through the context correctly typechecks and propagates to the AttributeAtomExpr.-testRelationalExprStateTupleElems :: Test-testRelationalExprStateTupleElems = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  executeTutorialD sessionId dbconn "x := (s : { parts := p rename {city as pcity} where pcity=@city}) : {z:=count(@parts)}"--  executeTutorialD sessionId dbconn "y:=x{city,z}"-  eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())-  let expectedRel = mkRelationFromList (attributesFromList [Attribute "city" TextAtomType,-                                                            Attribute "z" IntegerAtomType])-                    [[TextAtom "Paris", IntegerAtom 2],-                     [TextAtom "London", IntegerAtom 3],-                     [TextAtom "Athens", IntegerAtom 0]]-  assertEqual "validate parts count" expectedRel eRv-  -  executeTutorialD sessionId dbconn "rv1:=relation{tuple{test 1}}"-  executeTutorialD sessionId dbconn "rv2:=relation{tuple{val 1},tuple{val 2}}"-  --check subexpression evaluation in restriction predicate-  -- "rv1 where ((rv2 where val=@test) {})"-  let correctSubexpr = Restrict (AttributeEqualityPredicate "val" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())-      mainExpr subexpr = Restrict -                         (RelationalExprPredicate-                          (Project AN.empty subexpr)) (RelationVariable "rv1" ())-  eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr)-  let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntegerAtomType]) [[IntegerAtom 1]]-  assertEqual "validate sub-expression attribute" expectedRel2 eRv2-  -  --check error in subexpression-  let wrongSubexpr = Restrict (AttributeEqualityPredicate "nosuchattr" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())-  eRv3 <- executeRelationalExpr sessionId dbconn (mainExpr wrongSubexpr)-  assertEqual "validate missing attribute in subexpression" (Left (NoSuchAttributeNamesError (S.singleton "nosuchattr"))) eRv3-  --- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid.-testFunctionalDependencies :: Test    -testFunctionalDependencies = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  -  executeTutorialD sessionId dbconn "funcdep sname_status (sname) -> (status) s"-  --insert a new, valid tuple-  executeTutorialD sessionId dbconn "insert s relation{tuple{city \"Boston\", s# \"S6\", sname \"Stevens\", status 30}}"-  --insert an constraint-violating tuple-  let expectedError = "InclusionDependencyCheckError \"sname_status_A\""-  expectTutorialDErr sessionId dbconn (T.isPrefixOf expectedError) "insert s relation{tuple{city \"Boston\", s# \"S7\", sname \"Jones\", status 20}}"--testEmptyCommits :: Test-testEmptyCommits = TestCase $ do -  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  dirty <- disconnectedTransactionIsDirty sessionId dbconn-  assertEqual "no change not dirty" (Right False) dirty-  Right () <- commit sessionId dbconn--  --insert no tuples-  Right () <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ()))-  dirty' <- disconnectedTransactionIsDirty sessionId dbconn-  assertEqual "empty insert empty commit" (Right False) dirty'-  Right () <- commit sessionId dbconn-  -  --update no tuples- since we defer the restriction, we can only assume the context is dirty, perhaps the constraint checker could offer an optimization here-  Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))-  dirty'' <- disconnectedTransactionIsDirty sessionId dbconn-  assertEqual "empty update empty commit" (Right True) dirty''-  Right () <- commit sessionId dbconn--  --assign the same rel expr-  Right () <- executeDatabaseContextExpr sessionId dbconn (Assign "true" (ExistingRelation relationTrue))-  sameREdirty <- disconnectedTransactionIsDirty sessionId dbconn-  assertEqual "same relexpr assigned" (Right False) sameREdirty-  Right () <- commit sessionId dbconn-  -  --delete no tuples-  Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))-  dirty''' <- disconnectedTransactionIsDirty sessionId dbconn-  assertEqual "empty delete empty commit" (Right True) dirty'''- -testIntervalAtom :: Test  -testIntervalAtom = TestCase $ do  -  --test interval creation-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  -  executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,f,f), b interval(4,5,f,f)}, tuple{n 2,a interval(3,4,t,t), b interval(4,5,t,t)}}"-  --test failed interval creation-  let err1 = "AtomFunctionUserError InvalidIntervalOrderingError"-      err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError \"Text\")"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}"  --  --test interval_overlaps-  executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}"-  eRv <- executeRelationalExpr sessionId dbconn (Project (AttributeNames (S.fromList ["n","c"])) (RelationVariable "y" ()))-  assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntegerAtomType]) [[BoolAtom True, IntegerAtom 1], [BoolAtom False, IntegerAtom 2]]) eRv--testListConstructedAtom :: Test-testListConstructedAtom = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  executeTutorialD sessionId dbconn "x:=relation{tuple{l Cons 4 (Cons 5 Empty)}}"-  let err1 = "ConstructedAtomArgumentCountMismatchError 2 1"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{l Cons 4}}"-  let err2 = "TypeConstructorAtomTypeMismatch \"List\" IntegerAtomType"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{l Cons 4 5}}"-  -testTypeChecker :: Test  -testTypeChecker = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  -  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 (R.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" (R.attributes supplierProductsRel) (R.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"-  -testNonEmptyListType :: Test-testNonEmptyListType = TestCase $ do-  --create a NonEmptyList-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  -  executeTutorialD sessionId dbconn "x:=relation{tuple{a NECons 3 (Cons 4 Empty)}} : {x:=nonEmptyListHead(@a)}"-  eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())-  let expected = mkRelationFromList attrs [[nelist, nehead]]-      attrs = attributesFromList [Attribute "a" neListType,-                                  Attribute "x" IntegerAtomType]-      neListType = nonEmptyListAtomType IntegerAtomType-      listType = listAtomType IntegerAtomType-      nelist = ConstructedAtom "NECons" (nonEmptyListAtomType IntegerAtomType) [-        IntegerAtom 3,-        ConstructedAtom "Cons" listType [IntegerAtom 4, ConstructedAtom "Empty" listType []]]-      nehead = IntegerAtom 3-  assertEqual "non-empty list type construction" expected eX-  -testUnresolvedAtomTypes :: Test-testUnresolvedAtomTypes = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  let err1 = "TypeConstructorTypeVarMissing"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a Empty}}"-  executeTutorialD sessionId dbconn "x:=relation{a List Int}{tuple{a Empty}}"---- with (x as s) s    -testWithClause :: Test-testWithClause = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  executeTutorialD sessionId dbconn "x:=with (x as s) x"-  eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())-  assertEqual "with x as s" (Right suppliersRel) eX-  -  let err1 = "RelVarAlreadyDefinedError"  -  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"  -  -  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as sp) s"  --testAtomFunctionArgumentMismatch :: Test-testAtomFunctionArgumentMismatch = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  let err1 = "AtomTypeMismatchError"-  --atom function type mismatch-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where ^gt(@a,1.5)"-  --wrong argument count-  let err2 = "FunctionArgumentCountMismatchError"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"--testInvalidDataConstructor :: Test-testInvalidDataConstructor = TestCase $ do-  --test that a referenced TypeConstructor in a DataConstructor definition matches the expected count of arguments-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  let err1 = "ConstructedAtomArgumentCountMismatchError"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "data TestT = TestT Maybe Int"--testBasicList :: Test-testBasicList = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  executeTutorialD sessionId dbconn "x := relation{tuple{ a (Cons 1 (Cons 2 Empty)) }}"--testRelationDeclarationMismatch :: Test-testRelationDeclarationMismatch = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  expectTutorialDErr sessionId dbconn (T.isPrefixOf "AtomTypeMismatchError") "data A a = A a | B | C; a := relation{a A Integer}{tuple{a A \"1\"}}"----generate errors when the tuples in a new relation don't match-testInvalidTuples :: Test-testInvalidTuples = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{b 2}}"-  expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{a 2, b 3}}"---  expectTutorialDErr sessionId dbconn (T.isPrefixOf "ParseErrorBundle") ":showexpr relation{tuple{a 2, a 3}}" --parse failure can't be validated with this function--testSelfReferencingUncommittedContext :: Test-testSelfReferencingUncommittedContext = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  executeTutorialD sessionId dbconn "s:=s union s"-  eS <- executeRelationalExpr sessionId dbconn (RelationVariable "s" ())-  _ <- rollback sessionId dbconn-  eSorig <- executeRelationalExpr sessionId dbconn (RelationVariable "s" ())  -  assertEqual "s=s'" eSorig eS--testUnionAndIntersectionAttributeExprs :: Test-testUnionAndIntersectionAttributeExprs = TestCase $ do-  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  executeTutorialD sessionId dbconn "x:=s{intersection of {all but sname} {sname}}"-  xRel <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())-  assertEqual "intersection attrs" (Right relationTrue) xRel--  executeTutorialD sessionId dbconn "y:=s{union of {all but sname} {sname}}"-  yRel <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())-  assertEqual "union attrs" (Right suppliersRel) yRel-
+ test/TutorialD/Interpreter/Import/ImportTest.hs view
@@ -0,0 +1,46 @@+import Test.HUnit+import ProjectM36.Base+import TutorialD.Interpreter.Import.TutorialD+import System.Exit+import qualified Data.Text as T+import System.IO.Temp+import System.FilePath+import qualified Data.Map as M+import System.IO+import qualified Data.ByteString as BS+import qualified Data.Text.Encoding as TE+import Text.URI hiding (makeAbsolute)++main :: IO ()+main = do +  tcounts <- runTestTT $ TestList [testTutdFileImport+                                  ,testTutdHTTPSImport+                                  ]+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testTutdFileImport :: Test+testTutdFileImport = TestCase $+  withSystemTempFile "m.tutd" $ \tempPath handle -> do+    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 +                      $ TupleExprs () [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),+                                              ("b", NakedAtomExpr $ TextAtom "spam")])]),+          Assign "y" (MakeRelationFromExprs Nothing +                      $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]+    --on Windows, the file URI should not include the drive letter "/c/Users..." -> "/Users"+    let uri = "file://" <> map (\c -> if c == '\\' then '/' else c) ( joinDrive "/" (dropDrive tempPath))+    fileURI <- mkURI (T.pack uri)+    imported <- importTutorialDFromFile fileURI Nothing+    assertEqual "import tutd" (Right expectedExpr) imported++testTutdHTTPSImport :: Test+testTutdHTTPSImport = TestCase $ do+  uri <- mkURI "https://raw.githubusercontent.com/agentm/project-m36/master/test/TutorialD/Interpreter/Import/httpimporttest.tutd"+  let hash = "effe32b247586dc3ac0079fc241b9618d41d189afcaeb7907edbe5a8b45992a4"+      expected = Right (MultipleExpr [Assign "x" (RelationVariable "true" ()),Assign "y" (RelationVariable "false" ())])+  actual <- importTutorialDViaHTTP uri (Just hash)+  assertEqual "github https" expected actual+  +
− test/TutorialD/Interpreter/Import/TutorialD.hs 
@@ -1,29 +0,0 @@-import Test.HUnit-import ProjectM36.Base-import TutorialD.Interpreter.Import.TutorialD-import System.Exit-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 -  tcounts <- runTestTT $ TestList [testTutdImport]-  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess--testTutdImport :: Test-testTutdImport = TestCase $ -  withSystemTempFile "m.tutd" $ \tempPath handle -> do-    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 -                      $ TupleExprs () [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),-                                              ("b", NakedAtomExpr $ TextAtom "spam")])]),-          Assign "y" (MakeRelationFromExprs Nothing -                      $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]-    imported <- importTutorialD tempPath-    assertEqual "import tutd" (Right expectedExpr) imported-
+ test/TutorialD/InterpreterTest.hs view
@@ -0,0 +1,753 @@+import TutorialD.Interpreter.DatabaseContextExpr+import TutorialD.Interpreter.TestBase+import TutorialD.Interpreter+import TutorialD.Interpreter.Base+import Test.HUnit+import ProjectM36.Relation as R+import ProjectM36.Tuple+import ProjectM36.TupleSet+import ProjectM36.Error+import ProjectM36.DatabaseContext+import ProjectM36.AtomFunctions.Primitive+import ProjectM36.RelationalExpression+import ProjectM36.DataTypes.Either+import ProjectM36.DataTypes.Interval+import ProjectM36.DataTypes.NonEmptyList+import ProjectM36.DataTypes.List+import ProjectM36.DateExamples+import ProjectM36.Base hiding (Finite)+import ProjectM36.TransactionGraph+import ProjectM36.Client+import qualified ProjectM36.DisconnectedTransaction as Discon+import qualified ProjectM36.AttributeNames as AN+import qualified ProjectM36.Session as Sess+import qualified ProjectM36.Attribute as A+import qualified Data.Map as M+import System.Exit+import Data.Maybe (isJust)+import qualified Data.Vector as V+import Data.Text.Encoding as TE+import Control.Concurrent+import qualified Data.Set as S+import Data.Text hiding (map)+import qualified Data.Text as T+import Data.Time.Clock.POSIX hiding (getCurrentTime)+import Data.Time.Clock (getCurrentTime)+import Data.Time.Calendar (fromGregorian)+import Data.Either++main :: IO ()+main = do+  tcounts <- runTestTT (TestList tests)+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess+  where+    tests = [+      simpleRelTests,+      dateExampleRelTests,+      transactionGraphBasicTest, +      transactionGraphAddCommitTest, +      transactionRollbackTest, +      transactionJumpTest, +      transactionBranchTest, +      simpleJoinTest, +      testNotification,+      testTypeConstructors, +      testMergeTransactions, +      testComments, +      testTransGraphRelationalExpr, +      failJoinTest, +      testMultiAttributeRename, +      testSchemaExpr, +      testRelationalExprStateTupleElems, +      testFunctionalDependencies, +      testEmptyCommits,+      testIntervalAtom,+      testListConstructedAtom,+      testTypeChecker,+      testRestrictionPredicateExprs,+      testRelationalAttributeNames,+      testSemijoin,+      testAntijoin,+      testRelationAttributeDefinition,+      testAssignWithTypeVar,+      testDefineWithTypeVar,+      testIntervalType,+      testArbitraryRelation,+      testNonEmptyListType,+      testUnresolvedAtomTypes,+      testWithClause,+      testAtomFunctionArgumentMismatch,+      testInvalidDataConstructor,+      testBasicList,+      testRelationDeclarationMismatch,+      testInvalidTuples,+      testSelfReferencingUncommittedContext,+      testUnionAndIntersectionAttributeExprs,+      testUndefineConstraints,+      testQuotedRelVarNames      +      ]++simpleRelTests :: Test+simpleRelTests = TestCase $ do+  (graph, transId) <- freshTransactionGraph dateExamples  +  mapM_ (\(tutd, expected) ->+            assertTutdEqual basicDatabaseContext transId graph expected tutd) testTups+  where+    testTups = [("x:=true", Right relationTrue),+                      ("x:=false", Right relationFalse),+                      ("x:=true union false", Right relationTrue),+                      ("x:=true minus false", Right relationTrue),+                      ("x:=false minus true", Right relationFalse),                      +                      ("x:=true; x:=false", Right relationFalse),+                      ("x:=relation{a Integer}{}", mkRelation simpleAAttributes emptyTupleSet),+                      ("x:=relation{c Integer}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),+                      ("y:=relation{b Integer, c Integer}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),+                      ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntegerAtom 5])]),+                      ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc" Nothing),+                      ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),+                      ("x:=relation{}{}", Right relationFalse),+                      ("x:=relation{tuple{}}", Right relationTrue),+                      ("x:=true where true", Right relationTrue),+                      ("x:=true where false", Right relationFalse),+                      ("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)]]),+                      -- 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])]),+                      ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 5])]),+                      ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 6])]),+                      ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 10])]),+                      ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntegerAtomType TextAtomType)),+                      ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])]),+                      ("x:=false:{a:=1,b:=2}", mkRelationFromTuples simpleDAttributes [])+                     ]+    simpleAAttributes = A.attributesFromList [Attribute "a" IntegerAtomType]+    simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]+    simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntegerAtomType]+    simpleDAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]+    simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]+    nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]+  +dateExampleRelTests :: Test+dateExampleRelTests = TestCase $ do+  (graph, transId) <- freshTransactionGraph dateExamples+  mapM_ (\(tutd, expected) ->+            assertTutdEqual dateExamples transId graph expected tutd) testTups+  where+    simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]+    maybeIntegerAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType)+    maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)+    simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]+    simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntegerAtomType]+    byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]    +    minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType]+    groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]+    updateParisPlus10 = relMap (\tuple -> do+                                   statusAtom <- atomForAttributeName "status" tuple+                                   cityAtom <- atomForAttributeName "city" tuple+                                   if cityAtom == TextAtom "Paris" then+                                     Right $ updateTupleWithAtoms (M.singleton "status" (IntegerAtom (castInteger statusAtom + 10))) tuple+                                     else Right tuple) suppliersRel+    extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]+    testTups = [("x:=s where true", Right suppliersRel),+                           ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == Right (TextAtom "London")) suppliersRel),+                           ("x:=s where false", Right $ Relation (R.attributes suppliersRel) emptyTupleSet),+                           ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (R.attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),+                           ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntegerAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntegerAtomType]) (V.fromList [IntegerAtom 50])])),+                           ("x:=s minus (s where status=20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),+                           --atom function tests+                           ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),+                           ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])),+                           ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == Right (TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),+                           ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),+                           --relatom function tests+                           ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntegerAtom 1)])),+                           ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),+                           --boolean function restriction+                           ("x:=s where ^lt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),+                           ("x:=s where ^gt(@status,20)", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],+                                                                                                       [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),+                           ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntegerAtomType BoolAtomType),+                           ("x:=s where ^not(gte(@status,20))", mkRelationFromList (R.attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),+                           --test "all but" attribute inversion syntax+                           ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),+                           --test key syntax+                           ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint" Nothing)),+                           ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right relationTrue),+                           --test binary bytestring data type+                           ("x:=relation{tuple{y bytestring(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),+                           --test Maybe Text+                           ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]),+                           --test Maybe Integer+                           ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntegerAtomType [IntegerAtom 3]]]),+                           --test Either Integer Text+                           ("x:=relation{tuple{a Left 3}}",  Left (TypeConstructorTypeVarMissing "b")), -- 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)))]]),+                           --test Day constructor+                           ("x:=relation{tuple{a fromGregorian(2017,05,30)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DayAtomType]) [[DayAtom (fromGregorian 2017 05 30)]])+                          ]++assertTutdEqual :: DatabaseContext -> TransactionId -> TransactionGraph -> Either RelationalError Relation -> Text -> Assertion+assertTutdEqual databaseContext transId graph expected tutd = assertEqual (unpack tutd) expected interpreted+  where+    interpreted = case interpretDatabaseContextExpr databaseContext transId graph tutd of+      Left err -> Left err+      Right context -> case M.lookup "x" (relationVariables context) of+        Nothing -> Left $ RelVarNotDefinedError "x"+        Just relExpr -> do+          let env = freshGraphRefRelationalExprEnv (Just context) graph+          runGraphRefRelationalExprM env (evalGraphRefRelationalExpr relExpr)+++transactionGraphBasicTest :: Test+transactionGraphBasicTest = TestCase $ do+  (_, dbconn) <- dateExamplesConnection emptyNotificationCallback+  graph <- transactionGraph_ dbconn+  assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing++--add a new transaction to the graph, validate it is in the graph+transactionGraphAddCommitTest :: Test+transactionGraphAddCommitTest = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  case parseTutorialD "x:=s" of+    Left err -> assertFailure (show err)+    Right parsed -> do +      result <- evalTutorialD sessionId dbconn UnsafeEvaluation parsed+      case result of+        QuitResult -> assertFailure "quit?"+        DisplayResult _ -> assertFailure "display?"+        DisplayIOResult _ -> assertFailure "displayIO?"+        DisplayRelationResult _ -> assertFailure "displayrelation?"+        DisplayDataFrameResult _ -> assertFailure "displaydataframe?"+        DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"+        DisplayErrorResult err -> assertFailure (show err)   +        QuietSuccessResult -> do+          commit sessionId dbconn >>= eitherFail+          discon <- disconnectedTransaction_ sessionId dbconn+          let context = Discon.concreteDatabaseContext discon+          assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just (ExistingRelation suppliersRel))++transactionRollbackTest :: Test+transactionRollbackTest = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  graph <- transactionGraph_ dbconn+  executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail+  rollback sessionId dbconn >>= eitherFail+  discon <- disconnectedTransaction_ sessionId dbconn+  graph' <- transactionGraph_ dbconn+  assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))+  let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)+  assertEqual "validate graph" (graphEq graph) (graphEq graph')++--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present+transactionJumpTest :: Test+transactionJumpTest = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  (DisconnectedTransaction firstUUID _ _) <- disconnectedTransaction_ sessionId dbconn+  executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())) >>= eitherFail+  commit sessionId dbconn >>= eitherFail+  --perform the jump+  executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID) >>= eitherFail+  --check that the disconnected transaction does not include "x"+  discon <- disconnectedTransaction_ sessionId dbconn+  assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))          +--branch from the first transaction and verify that there are two heads+transactionBranchTest :: Test+transactionBranchTest = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  mapM_ (>>= eitherFail) [executeGraphExpr sessionId dbconn (Branch "test"),+                                  executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),+                                  commit sessionId dbconn,+                                  executeGraphExpr sessionId dbconn (JumpToHead "master"),+                                  executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))+                  ]+  graph <- transactionGraph_ dbconn+  assertBool "master branch exists" $ isJust (transactionForHead "master" graph)+  assertBool "test branch exists" $ isJust (transactionForHead "test" graph)++-- test that overlapping attribute names with different types fail with an error+failJoinTest :: Test+failJoinTest = TestCase $ do+  (graph, transId) <- freshTransactionGraph dateExamples  +  assertTutdEqual basicDatabaseContext transId graph err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"+  where+    err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntegerAtomType]))++simpleJoinTest :: Test+simpleJoinTest = TestCase $ do+  (graph, transId) <- freshTransactionGraph dateExamples    +  assertTutdEqual dateExamples transId graph joinedRel "x:=s join sp"+    where+        attrs = A.attributesFromList [Attribute "city" TextAtomType,+                                      Attribute "qty" IntegerAtomType,+                                      Attribute "p#" TextAtomType,+                                      Attribute "s#" TextAtomType,+                                      Attribute "sname" TextAtomType,+                                      Attribute "status" IntegerAtomType]+        joinedRel = mkRelationFromList attrs [[TextAtom "London", IntegerAtom 100, TextAtom "P6", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 400, TextAtom "P3", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 400, TextAtom "P5", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 300, TextAtom "P1", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "Paris", IntegerAtom 200, TextAtom "P2", TextAtom "S3", TextAtom "Blake", IntegerAtom 30],+                                              [TextAtom "Paris", IntegerAtom 300, TextAtom "P1", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],+                                              [TextAtom "London", IntegerAtom 100, TextAtom "P5", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 300, TextAtom "P4", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],+                                              [TextAtom "Paris", IntegerAtom 400, TextAtom "P2", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],+                                              [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 200, TextAtom "P4", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S4", TextAtom "Clark", IntegerAtom 20]+                                              ]+                    +                    +{-+inclusionDependencies :: Connection -> M.Map IncDepName InclusionDependency+inclusionDependencies (InProcessConnection (DisconnectedTransaction _ context)) = inclusionDependencies context+inclusionDependencies _ = error "remote connection used"                       +-}+                           +-- test notifications over the InProcessConnection+testNotification :: Test+testNotification = TestCase $ do+  notifmvar <- newEmptyMVar+  let notifCallback mvar _ _ = putMVar mvar ()+      relvarx = RelationVariable "x" ()+  (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)+  executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail+  executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx relvarx) >>= eitherFail+  commit sess conn >>= eitherFail+  executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail+  commit sess conn >>= eitherFail+  takeMVar notifmvar+    +testTypeConstructors :: Test+testTypeConstructors = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "data Hair = Color Text | Bald | UserRefusesToSpecify"+  executeTutorialD sessionId dbconn "x:=relation{a Hair}{tuple{a Color \"Blonde\"},tuple{a Bald},tuple{a UserRefusesToSpecify}}"+  executeTutorialD sessionId dbconn "data Tree a = Node a (Tree a) (Tree a) | EmptyNode"+  executeTutorialD sessionId dbconn "y:=relation{a Tree Integer}{tuple{a Node 3 (Node 4 EmptyNode EmptyNode) EmptyNode},tuple{a Node 4 EmptyNode EmptyNode}}"+  +testMergeTransactions :: Test+testMergeTransactions = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  mapM_ (executeTutorialD sessionId dbconn) [+   ":branch branchA",+   "conflictrv := relation{conflict Integer}{tuple{conflict 1}}",+   ":commit",+   ":jumphead master",+   ":branch branchB",+   "conflictrv := relation{conflict Integer}{tuple{conflict 2}}",+   ":commit",+   ":mergetrans union branchA branchB"+   ]+  case mkRelationFromList (attributesFromList [Attribute "conflict" IntegerAtomType]) [[IntegerAtom 1],[IntegerAtom 2]] of+    Left err -> assertFailure (show err)+    Right conflictCheck -> do+      eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "conflictrv" ())+      case eRv of+        Left err -> assertFailure (show err)+        Right conflictrv -> assertEqual "conflict union merge relvar" conflictCheck conflictrv++testComments :: Test+testComments = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  mapM_ (executeTutorialD sessionId dbconn) [+    ":branch testbranch --test comment",+    ":jumphead {- test comment -} master"]+  +-- create a graph and query from two disparate contexts  +testTransGraphRelationalExpr :: Test    +testTransGraphRelationalExpr = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  mapM_ (executeTutorialD sessionId dbconn) [+    "x:=s", --dud relvar so that the commit isn't empty+    ":commit",+    ":branch testbranch",+    "insert s relation{tuple{city \"Boston\", s# \"S9\", sname \"Smithers\", status 50}}",+    ":commit"+    ]+  let masterMarker = TransactionIdHeadNameLookup "master" []+      testBranchMarker = TransactionIdHeadNameLookup "testbranch" []+      sattrs = attributesFromList [Attribute "city" TextAtomType,+                                   Attribute "sname" TextAtomType,+                                   Attribute "s#" TextAtomType,+                                   Attribute "status" IntegerAtomType]+      expectedRel = mkRelationFromList sattrs [[TextAtom "Boston",+                                                TextAtom "Smithers",+                                                TextAtom "S9",+                                                IntegerAtom 50]]+  diff <- executeTransGraphRelationalExpr sessionId dbconn (Difference (RelationVariable "s" testBranchMarker) (RelationVariable "s" masterMarker))+  assertEqual "difference in s" expectedRel diff +  +  --test graph traversal (head backtracking)+  let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]+  backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))+  assertEqual "backtrack to master" (Right relationTrue) backtrackRel+  +  --test walkback to time (stay in current location)+  now <- getCurrentTime+  headId <- headTransactionId sessionId dbconn+  _ <- executeGraphExpr sessionId dbconn (WalkBackToTime now)+  headId' <- headTransactionId sessionId dbconn+  assertEqual "transaction walk back stays in place" headId headId'++  --test branch deletion+  mapM_ (executeTutorialD sessionId dbconn) [+        ":jumphead master",+        ":deletebranch testbranch"]+  eEvald <- case parseTutorialD ":jumphead testbranch" of+    Left _ -> assertFailure "jumphead parse error" >> error "x"+    Right parsed -> evalTutorialD sessionId dbconn UnsafeEvaluation parsed+  case eEvald of+    DisplayErrorResult err -> assertEqual "testbranch deletion"  (show (NoSuchHeadNameError "testbranch")) (unpack err)+    _ -> assertFailure "failed to delete branch"+    +testMultiAttributeRename :: Test+testMultiAttributeRename = TestCase $ do+  (graph, transId) <- freshTransactionGraph dateExamples    +  assertTutdEqual dateExamples transId graph renamedRel "x:=s rename {city as town, status as price} where false"+  where+    sattrs = attributesFromList [Attribute "town" TextAtomType,+                                 Attribute "sname" TextAtomType,+                                 Attribute "s#" TextAtomType,+                                 Attribute "price" IntegerAtomType]+    renamedRel = mkRelationFromList sattrs []++testSchemaExpr :: Test+testSchemaExpr = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  mapM_ (executeTutorialD sessionId dbconn) [+    ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" ^gte(17,@weight))",+    ":setschema test",+    ""+    ]+  eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ())+  lightProduct <- assertEither eLightProduct+  let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntegerAtom 17), AttributeAtomExpr "weight"] ()))+  setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName >>= eitherFail+  eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))+  restrictedProduct <- assertEither eRestrictedProduct+  assertEqual "light product" restrictedProduct lightProduct+  +assertEither :: (Show a) => Either a b -> IO b+assertEither x = case x of+  Left err -> assertFailure (show err) >> undefined+  Right val -> pure val+  +-- | Validate that a tuple passed through the context correctly typechecks and propagates to the AttributeAtomExpr.+testRelationalExprStateTupleElems :: Test+testRelationalExprStateTupleElems = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "x := (s : { parts := p rename {city as pcity} where pcity=@city}) : {z:=count(@parts)}"++  executeTutorialD sessionId dbconn "y:=x{city,z}"+  eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())+  let expectedRel = mkRelationFromList (attributesFromList [Attribute "city" TextAtomType,+                                                            Attribute "z" IntegerAtomType])+                    [[TextAtom "Paris", IntegerAtom 2],+                     [TextAtom "London", IntegerAtom 3],+                     [TextAtom "Athens", IntegerAtom 0]]+  assertEqual "validate parts count" expectedRel eRv+  +  executeTutorialD sessionId dbconn "rv1:=relation{tuple{test 1}}"+  executeTutorialD sessionId dbconn "rv2:=relation{tuple{val 1},tuple{val 2}}"+  --check subexpression evaluation in restriction predicate+  -- "rv1 where ((rv2 where val=@test) {})"+  let correctSubexpr = Restrict (AttributeEqualityPredicate "val" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())+      mainExpr subexpr = Restrict +                         (RelationalExprPredicate+                          (Project AN.empty subexpr)) (RelationVariable "rv1" ())+  eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr)+  let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntegerAtomType]) [[IntegerAtom 1]]+  assertEqual "validate sub-expression attribute" expectedRel2 eRv2+  +  --check error in subexpression+  let wrongSubexpr = Restrict (AttributeEqualityPredicate "nosuchattr" (AttributeAtomExpr "test")) (RelationVariable "rv2" ())+  eRv3 <- executeRelationalExpr sessionId dbconn (mainExpr wrongSubexpr)+  assertEqual "validate missing attribute in subexpression" (Left (NoSuchAttributeNamesError (S.singleton "nosuchattr"))) eRv3+  +-- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid.+testFunctionalDependencies :: Test    +testFunctionalDependencies = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  executeTutorialD sessionId dbconn "funcdep sname_status (sname) -> (status) s"+  --insert a new, valid tuple+  executeTutorialD sessionId dbconn "insert s relation{tuple{city \"Boston\", s# \"S6\", sname \"Stevens\", status 30}}"+  --insert an constraint-violating tuple+  let expectedError = "InclusionDependencyCheckError \"sname_status_A\""+  expectTutorialDErr sessionId dbconn (T.isPrefixOf expectedError) "insert s relation{tuple{city \"Boston\", s# \"S7\", sname \"Jones\", status 20}}"++testEmptyCommits :: Test+testEmptyCommits = TestCase $ do +  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  dirty <- disconnectedTransactionIsDirty sessionId dbconn+  assertEqual "no change not dirty" (Right False) dirty+  Right () <- commit sessionId dbconn++  --insert no tuples+  Right () <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ()))+  dirty' <- disconnectedTransactionIsDirty sessionId dbconn+  assertEqual "empty insert empty commit" (Right False) dirty'+  Right () <- commit sessionId dbconn+  +  --update no tuples- since we defer the restriction, we can only assume the context is dirty, perhaps the constraint checker could offer an optimization here+  Right () <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))+  dirty'' <- disconnectedTransactionIsDirty sessionId dbconn+  assertEqual "empty update empty commit" (Right True) dirty''+  Right () <- commit sessionId dbconn++  --assign the same rel expr+  Right () <- executeDatabaseContextExpr sessionId dbconn (Assign "true" (ExistingRelation relationTrue))+  sameREdirty <- disconnectedTransactionIsDirty sessionId dbconn+  assertEqual "same relexpr assigned" (Right False) sameREdirty+  Right () <- commit sessionId dbconn+  +  --delete no tuples+  Right () <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))+  dirty''' <- disconnectedTransactionIsDirty sessionId dbconn+  assertEqual "empty delete empty commit" (Right True) dirty'''+ +testIntervalAtom :: Test  +testIntervalAtom = TestCase $ do  +  --test interval creation+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,f,f), b interval(4,5,f,f)}, tuple{n 2,a interval(3,4,t,t), b interval(4,5,t,t)}}"+  --test failed interval creation+  let err1 = "AtomFunctionUserError InvalidIntervalOrderingError"+      err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError \"Text\")"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}"  ++  --test interval_overlaps+  executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}"+  eRv <- executeRelationalExpr sessionId dbconn (Project (AttributeNames (S.fromList ["n","c"])) (RelationVariable "y" ()))+  assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntegerAtomType]) [[BoolAtom True, IntegerAtom 1], [BoolAtom False, IntegerAtom 2]]) eRv++testListConstructedAtom :: Test+testListConstructedAtom = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "x:=relation{tuple{l Cons 4 (Cons 5 Empty)}}"+  let err1 = "ConstructedAtomArgumentCountMismatchError 2 1"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{l Cons 4}}"+  let err2 = "TypeConstructorAtomTypeMismatch \"List\" IntegerAtomType"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{l Cons 4 5}}"+  +testTypeChecker :: Test  +testTypeChecker = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  let err1 = "AtomFunctionTypeError \"max\" 1"+  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 (R.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" (R.attributes supplierProductsRel) (R.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"+  +testNonEmptyListType :: Test+testNonEmptyListType = TestCase $ do+  --create a NonEmptyList+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  executeTutorialD sessionId dbconn "x:=relation{tuple{a NECons 3 (Cons 4 Empty)}} : {x:=nonEmptyListHead(@a)}"+  eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())+  let expected = mkRelationFromList attrs [[nelist, nehead]]+      attrs = attributesFromList [Attribute "a" neListType,+                                  Attribute "x" IntegerAtomType]+      neListType = nonEmptyListAtomType IntegerAtomType+      listType = listAtomType IntegerAtomType+      nelist = ConstructedAtom "NECons" (nonEmptyListAtomType IntegerAtomType) [+        IntegerAtom 3,+        ConstructedAtom "Cons" listType [IntegerAtom 4, ConstructedAtom "Empty" listType []]]+      nehead = IntegerAtom 3+  assertEqual "non-empty list type construction" expected eX+  +testUnresolvedAtomTypes :: Test+testUnresolvedAtomTypes = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  let err1 = "TypeConstructorTypeVarMissing"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a Empty}}"+  executeTutorialD sessionId dbconn "x:=relation{a List Int}{tuple{a Empty}}"++-- with (x as s) s    +testWithClause :: Test+testWithClause = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "x:=with (x as s) x"+  eX <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())+  assertEqual "with x as s" (Right suppliersRel) eX++  executeTutorialD sessionId dbconn "y:=with(a as true) (with (b as a) b)"+  eY <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())+  assertEqual "nested with" (Right relationTrue) eY+  +  let err1 = "RelVarAlreadyDefinedError"  +  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as s) s"  +  +  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=with (s as sp) s"  ++testAtomFunctionArgumentMismatch :: Test+testAtomFunctionArgumentMismatch = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  let err1 = "AtomTypeMismatchError"+  --atom function type mismatch+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 5}} where ^gt(@a,1.5)"+  --wrong argument count+  let err2 = "FunctionArgumentCountMismatchError"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "x:=relation{tuple{a 5}} where ^gt(@a,1,3)"++testInvalidDataConstructor :: Test+testInvalidDataConstructor = TestCase $ do+  --test that a referenced TypeConstructor in a DataConstructor definition matches the expected count of arguments+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  let err1 = "ConstructedAtomArgumentCountMismatchError"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "data TestT = TestT Maybe Int"++testBasicList :: Test+testBasicList = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "x := relation{tuple{ a (Cons 1 (Cons 2 Empty)) }}"++testRelationDeclarationMismatch :: Test+testRelationDeclarationMismatch = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  expectTutorialDErr sessionId dbconn (T.isPrefixOf "AtomTypeMismatchError") "data A a = A a | B | C; a := relation{a A Integer}{tuple{a A \"1\"}}"++--generate errors when the tuples in a new relation don't match+testInvalidTuples :: Test+testInvalidTuples = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{b 2}}"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf "AttributeNamesMismatchError") ":showexpr relation{tuple{a 1},tuple{a 2, b 3}}"+--  expectTutorialDErr sessionId dbconn (T.isPrefixOf "ParseErrorBundle") ":showexpr relation{tuple{a 2, a 3}}" --parse failure can't be validated with this function++testSelfReferencingUncommittedContext :: Test+testSelfReferencingUncommittedContext = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "s:=s union s"+  eS <- executeRelationalExpr sessionId dbconn (RelationVariable "s" ())+  _ <- rollback sessionId dbconn+  eSorig <- executeRelationalExpr sessionId dbconn (RelationVariable "s" ())  +  assertEqual "s=s'" eSorig eS++testUnionAndIntersectionAttributeExprs :: Test+testUnionAndIntersectionAttributeExprs = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "x:=s{intersection of {all but sname} {sname}}"+  xRel <- executeRelationalExpr sessionId dbconn (RelationVariable "x" ())+  assertEqual "intersection attrs" (Right relationTrue) xRel++  executeTutorialD sessionId dbconn "y:=s{union of {all but sname} {sname}}"+  yRel <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())+  assertEqual "union attrs" (Right suppliersRel) yRel++-- ensure that an undefined table triggers constraint validation #306+testUndefineConstraints :: Test+testUndefineConstraints = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  let expectedErr = InclusionDependencyCheckError "bad" (Just (RelVarNotDefinedError "x"))+  expectTutorialDErr sessionId dbconn (== T.pack (show expectedErr)) "x:=true;constraint bad x equals true;undefine x"++testQuotedRelVarNames :: Test+testQuotedRelVarNames = TestCase $ do+  let parseDBExpr = parse databaseContextExprP ""+      true = RelationVariable "true" ()+      assign rv = Right (Assign rv true)+  assertEqual "quoted rv" (assign "TEST") (parseDBExpr "`TEST` := true")+  assertEqual "quoted backtick rv" (assign "TEST`TEST") (parseDBExpr "`TEST\\`TEST`:=true")+  assertEqual "multibyte rv" (assign "漢字") (parseDBExpr "`漢字`:=true")+  let qAttrExpected = Right (Assign "test" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "\28450\23383" (NakedAtomExpr (TextAtom "test")))])))+  assertEqual "quoted attribute" qAttrExpected (parseDBExpr "test:=relation{tuple{`漢字` \"test\"}}")+  assertBool "invalid quoted rv" (isLeft (parseDBExpr "`TEST:=true"))
− test/TutorialD/Printer.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-import Test.HUnit-import ProjectM36.Base-import System.Exit-import Data.Text.Prettyprint.Doc-import Data.Map (fromList)-import TutorialD.Printer ()-import TutorialD.Interpreter.RelationalExpr-import Text.Megaparsec-import Data.Text (pack)--testList :: Test-testList = TestList [-  testPretty "true" (RelationVariable "true" ()),-  testPretty "relation{tuple{a 3, b \"x\"}, tuple{a 4, b \"y\"}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (IntegerAtom 3)),("b",NakedAtomExpr (TextAtom "x"))]),TupleExpr (fromList [("a",NakedAtomExpr (IntegerAtom 4)),("b",NakedAtomExpr (TextAtom "y"))])])),-  testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntegerAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntegerAtom 1))) (RelationVariable "true" ()))),-  testPretty "relation{tuple{a fromGregorian(2014, 2, 4)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "fromGregorian" [NakedAtomExpr (IntegerAtom 2014),NakedAtomExpr (IntegerAtom 2),NakedAtomExpr (IntegerAtom 4)] ())])])),-  testPretty "relation{tuple{a bytestring(\"dGVzdGRhdGE=\")}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "bytestring" [NakedAtomExpr (TextAtom "dGVzdGRhdGE=")] ())])])),-  testPretty "relation{tuple{a t}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (BoolAtom True))])])),-  testPretty "relation{tuple{a Cons 4 (Cons 5 Empty)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 4),ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 5),ConstructedAtomExpr "Empty" [] ()] ()] ())])])),-  testPretty "relation{a Int, b Text, c Bool}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (ADTypeConstructor "Int" []) (),AttributeAndTypeNameExpr "b" (ADTypeConstructor "Text" []) (),AttributeAndTypeNameExpr "c" (ADTypeConstructor "Bool" []) ()]) (TupleExprs () [])),-  testPretty "relation{a relation{b Int}}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (RelationAtomTypeConstructor [AttributeAndTypeNameExpr "b" (ADTypeConstructor "Int" []) ()]) ()]) (TupleExprs () []))-  ]--main :: IO ()           -main = do -  tcounts <- runTestTT testList-  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess--testPretty :: String -> RelationalExpr -> Test-testPretty tutdStr relExprADT =-  TestCase $ do-    let relExprStr = show (pretty relExprADT)-    print relExprStr-    roundTrip <- parseRelExpr relExprStr-    {-tutdIn <- parseRelExpr tutdStr-     print ("tutd parsed", tutdIn)-}-    assertEqual ("pretty ADT " <> tutdStr) tutdStr relExprStr-    assertEqual ("round-trip " <> tutdStr) relExprADT roundTrip----round trip tutoriald-parseRelExpr :: String -> IO RelationalExpr-parseRelExpr tutdStr =-  case parse relExprP "test" (pack tutdStr) of-    Left err ->-      assertFailure (show err)-    Right parsed -> pure parsed
+ test/TutorialD/PrinterTest.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.HUnit+import ProjectM36.Base+import System.Exit+import Prettyprinter+import Data.Map (fromList)+import TutorialD.Printer ()+import TutorialD.Interpreter.RelationalExpr+import Text.Megaparsec+import Data.Text (pack)++testList :: Test+testList = TestList [+  testPretty "true" (RelationVariable "true" ()),+  testPretty "relation{tuple{a 3, b \"x\"}, tuple{a 4, b \"y\"}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (IntegerAtom 3)),("b",NakedAtomExpr (TextAtom "x"))]),TupleExpr (fromList [("a",NakedAtomExpr (IntegerAtom 4)),("b",NakedAtomExpr (TextAtom "y"))])])),+  testPretty "true:{a:=1, b:=1}" (Extend (AttributeExtendTupleExpr "b" (NakedAtomExpr (IntegerAtom 1))) (Extend (AttributeExtendTupleExpr "a" (NakedAtomExpr (IntegerAtom 1))) (RelationVariable "true" ()))),+  testPretty "relation{tuple{a fromGregorian(2014, 2, 4)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "fromGregorian" [NakedAtomExpr (IntegerAtom 2014),NakedAtomExpr (IntegerAtom 2),NakedAtomExpr (IntegerAtom 4)] ())])])),+  testPretty "relation{tuple{a bytestring(\"dGVzdGRhdGE=\")}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",FunctionAtomExpr "bytestring" [NakedAtomExpr (TextAtom "dGVzdGRhdGE=")] ())])])),+  testPretty "relation{tuple{a t}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",NakedAtomExpr (BoolAtom True))])])),+  testPretty "relation{tuple{a Cons 4 (Cons 5 Empty)}}" (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (fromList [("a",ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 4),ConstructedAtomExpr "Cons" [NakedAtomExpr (IntegerAtom 5),ConstructedAtomExpr "Empty" [] ()] ()] ())])])),+  testPretty "relation{a Int, b Text, c Bool}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (ADTypeConstructor "Int" []) (),AttributeAndTypeNameExpr "b" (ADTypeConstructor "Text" []) (),AttributeAndTypeNameExpr "c" (ADTypeConstructor "Bool" []) ()]) (TupleExprs () [])),+  testPretty "relation{a relation{b Int}}{}" (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "a" (RelationAtomTypeConstructor [AttributeAndTypeNameExpr "b" (ADTypeConstructor "Int" []) ()]) ()]) (TupleExprs () []))+  ]++main :: IO ()           +main = do +  tcounts <- runTestTT testList+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testPretty :: String -> RelationalExpr -> Test+testPretty tutdStr relExprADT =+  TestCase $ do+    let relExprStr = show (pretty relExprADT)+    print relExprStr+    roundTrip <- parseRelExpr relExprStr+    {-tutdIn <- parseRelExpr tutdStr+     print ("tutd parsed", tutdIn)-}+    assertEqual ("pretty ADT " <> tutdStr) tutdStr relExprStr+    assertEqual ("round-trip " <> tutdStr) relExprADT roundTrip++--round trip tutoriald+parseRelExpr :: String -> IO RelationalExpr+parseRelExpr tutdStr =+  case parse relExprP "test" (pack tutdStr) of+    Left err ->+      assertFailure (show err)+    Right parsed -> pure parsed
test/scripts.hs view
@@ -4,6 +4,8 @@ import System.Directory import Data.List (isSuffixOf) import System.Exit+import qualified Data.Text as T+import Text.URI  testList :: IO Test testList = do@@ -20,7 +22,8 @@    testScript :: FilePath -> Test testScript tutdFile = TestCase $ do-  eImport <- importTutorialD tutdFile +  fileURI <- mkURI (T.pack ("file://" <> tutdFile))+  eImport <- importTutorialDFromFile fileURI Nothing   case eImport of     Left err -> assertFailure ("tutd import failure in " ++ tutdFile ++ ": " ++ show err)     Right _ -> pure ()