project-m36 1.0.2 → 1.1.0

raw patch · 31 files changed

+372/−261 lines, 31 filesdep ~basedep ~curryer-rpcdep ~ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, curryer-rpc, ghc

API changes (from Hackage documentation)

Files

• Changelog.markdown +17/−12
• README.markdown +3/−1
• examples/Plantfarm.hs +28/−18
• examples/SimpleClient.hs +4/−1
• examples/blog.hs +1/−1
• project-m36.cabal +25/−16
• src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs +1/−1
• src/bin/benchmark/bigrel.hs +3/−2
• src/lib/ProjectM36/AtomFunction.hs +4/−6
• src/lib/ProjectM36/AtomType.hs +4/−5
• src/lib/ProjectM36/AttributeNames.hs +5/−1
• src/lib/ProjectM36/Client.hs +4/−1
• src/lib/ProjectM36/Client/Simple.hs +4/−1
• src/lib/ProjectM36/DataTypes/SQL/Null.hs +12/−3
• src/lib/ProjectM36/DatabaseContextFunction.hs +4/−6
• src/lib/ProjectM36/Error.hs +2/−4
• src/lib/ProjectM36/Function.hs +4/−6
• src/lib/ProjectM36/GraphRefRelationalExpr.hs +5/−6
• src/lib/ProjectM36/IsomorphicSchema.hs +44/−45
• src/lib/ProjectM36/Relation.hs +6/−4
• src/lib/ProjectM36/Relation/Show/Term.hs +5/−3
• src/lib/ProjectM36/RelationalExpression.hs +15/−9
• src/lib/ProjectM36/SQL/Convert.hs +3/−0
• src/lib/ProjectM36/ScriptSession.hs +59/−19
• src/lib/ProjectM36/StaticOptimizer.hs +10/−3
• src/lib/ProjectM36/TransactionGraph.hs +71/−68
• src/lib/ProjectM36/TransactionGraph/Merge.hs +6/−0
• src/lib/ProjectM36/TransactionGraph/Persist.hs +3/−5
• src/lib/ProjectM36/Tuple.hs +16/−9
• src/lib/ProjectM36/TupleSet.hs +3/−4
• test/Relation/StaticOptimizer.hs +1/−1

@@ -1,3 +1,8 @@+# 2024-08-25 (v1.1.0)++* add support for GHC 9.6, GHC 9.8, and GHC 9.10+* clean up compiler warnings+ # 2024-07-27 (v1.0.2)  * upgrade to streamly 0.10.1@@ -17,33 +22,33 @@  * revert to using streamly 0.9.0 due to over-the-wire corruption bug in 0.10.0 * fixed toAtom/fromAtom for NonEmpty lists (#363)-	+ # 2023-12-30 (v0.9.8)  * fix notification serialization in transaction (#362) * require minimum GHC 9.2 (dropping GHC 8.10 and GHC 9.0) * add support for GHC 9.4-	+ # 2023-07-18 (v0.9.7)  * fix critical bug resulting in empty results from cross joins-	+ # 2022-11-05 (v0.9.6)  * fix tuple context passed down to extended expressions * add ddl hash- useful for validating that the client supports the current schema * add registered queries- useful for constraining what DDL can be applied to the database so as not to break client applications * reduce memory usage during Merkle hashing by an order of magnitude by using strict serialization and hashing-	+ # 2022-08-19 (v0.9.5)-  + * removed necessity for caret "^" when using boolean atom expressions in restriction predicates * `True` and `False` are now value constructors for `Bool` atom values (previously `t` and `f); changed for better discoverability by Haskell developers * add `Scientific` data type for arbitrary-precision values (backed by Data.Scientific) * add support for GHC 9.0 and GHC 9.2 * drop support for GHC < 8.10.7 * fix relational equality when the relation includes a nested relation-	+ # 2021-12-05 (v0.9.4)  * fix bug which [caused tuple storage to be duplicated unnecessarily](https://github.com/agentm/project-m36/pull/328)@@ -54,11 +59,11 @@ * 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	-	+* 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@@ -97,7 +102,7 @@  * fix atom function type validation * add support for GHC 8.4 (now we support GHC 8.0, 8.2, and 8.4)-	+ # 2018-08-10 (v0.5)  * fix critical type bug which allowed unresolved types to be used@@ -124,8 +129,8 @@  * alter websocket server API to allow for multiple representations (JSON, text, or HTML) to be selected and returned simultaneously * add jupyter kernel for TutorialD interpreter-* fix warnings suggested by new hlint 2.0.10	-	+* fix warnings suggested by new hlint 2.0.10+ # 2017-10-08 (v0.3)  * replaced overuse of `undefined` with `Proxy` in `Tupleable` and `Atomable` typeclasses

@@ -45,6 +45,8 @@  ## Community +* [TutorialD for SQL Developers](https://www.udemy.com/course/tutoriald-for-sql-developers/)+  * ask in IRC channel for discount code to get free access * [Developer's Blog](https://agentm.github.io/project-m36/) * [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36) * IRC Channel: irc.libera.chat #project-m36 -- [Chat via Web Client](http://kiwiirc.com/nextclient/irc.libera.chat:+6697/#project-m36)@@ -105,7 +107,7 @@  ## Development -Project:M36 is developed in Haskell and compiled with GHC 8.8 or later.+Project:M36 is developed in Haskell and compiled with GHC 9.2 or later.  ## Related Projects 

@@ -1,11 +1,21 @@ {-# LANGUAGE DeriveGeneric #-}- {-# LANGUAGE OverloadedStrings #-}- {-# LANGUAGE DeriveAnyClass #-}- {-# LANGUAGE DerivingVia #-}-+-- The calls to 'S.raise' from the @scotty@ package are /deprecated/+-- TODO:+-- Replace 'raise' with 'throw'+--+-- Until then, supproess the deprecation warning+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Main+  ( main+    -- * Other example exports+  , closeConn+  , getAllPlantsWith+  , update+  , updatePlant+  ) where  import Codec.Winery (Serialise, WineryVariant(WineryVariant)) import Control.DeepSeq (NFData)@@ -90,7 +100,7 @@     | otherwise = Left t  --- Just for ToJSON for ilustration of stage+-- Just for ToJSON for illustration of stage type ASCIIStage = String  seedStr :: ASCIIStage@@ -147,7 +157,7 @@      --  retrieve a plant by name     S.get "/plant/:name" $ do-        n <- S.param "name"+        n <- S.pathParam "name"         e <- liftIO $ getPlant c n         p <- handleWebError e         S.json p@@ -170,12 +180,12 @@     --  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"+      n <- S.pathParam "name"       e <- liftIO $ waterPlant c n       p <- handleWebError e       S.json p -    --  retriving all the plants as json data+    --  retrieving all the plants as json data     S.get "/plants" $ do       e <- liftIO $ getAllPlants c       ps <- handleWebErrors e@@ -190,14 +200,14 @@      --  deleting all plants at a specific stage     S.delete "/plants?stage=:stage" $ do-      s <- S.param "stage"+      s <- S.pathParam "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"+      s <- S.pathParam "name"       e <- liftIO $ deletePlantByName c s       p <- handleWebError e       S.json p@@ -209,14 +219,14 @@       S.json ps  handleWebError :: Either Err b -> S.ActionM b-handleWebError (Left e) = S.raise (TL.pack $ "An error occurred:\n" <> show e)+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)+    l -> S.raise . TL.pack $ "Errors occurred:\n" <> concatMap ((<> "\n") . show) l   -- |    watering a plant and thereby possibly updating its stage@@ -264,7 +274,7 @@  instance ToJSON Err --- |    Just for convinience for passing around the SessionId+-- |    Just for convenience for passing around the SessionId --      and the Connection data DBConnection = DB SessionId Connection @@ -337,7 +347,7 @@   _ <- 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,+    ,   databaseContextExprForUniqueKey "plants" ["name"] -- Makes name of the plants relation a unique Key,                                                           -- Foreign Key restrictions are available too     ]   pure ()@@ -358,7 +368,7 @@   let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback [] basicDatabaseContext   --  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. \\+  --  In addition minimal persistence is available. \\ --  let connInfo = InProcessConnectionInfo (MinimalPersistence "base") emptyNotificationCallback []   conn <- handleIOErrorAndQuit $ connectProjectM36 connInfo   --create a database session at the default branch of the database@@ -371,7 +381,7 @@ 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:+--      An update in one function would take: -- --      - SessionId --      - Connection@@ -388,9 +398,9 @@ 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. \\+-- |    A convenience function to make executing DBContextExpr with committing simpler. \\ --      In particular for expr that just insert, delete and update.---      Therefor ultimately return Either _ ()+--      Therefore ultimately return Either _ () executeWithTransaction :: DBConnection -> Either RelationalError DatabaseContextExpr -> IO (Either Err ()) executeWithTransaction (DB sid conn) expr = do     iEx <- handleError expr

@@ -1,3 +1,6 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- This suppresses the incomplete pattern match on @(Right tupSet)@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} import ProjectM36.Client import ProjectM36.TupleSet import ProjectM36.Relation.Show.Term@@ -7,7 +10,7 @@ main = do   -- 1. create a ConnectionInfo   let connInfo = RemoteConnectionInfo "mytestdb" "127.0.0.1" (show defaultServerPort) emptyNotificationCallback-  -- 2. conncted to the remote database+  -- 2. connected to the remote database   eConn <- connectProjectM36 connInfo   case eConn of     Left err -> print err

@@ -27,7 +27,7 @@ import Text.Blaze.Html5 (h1, h2, h3, p, form, input, (!), toHtml, Html, a, toValue, hr, textarea) import Text.Blaze.Html5.Attributes (name, href, type_, method, action, value) import Text.Blaze.Html.Renderer.Text-import Control.Monad.IO.Class (liftIO)+--import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status import Data.Time.Format.ISO8601 

@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36-Version: 1.0.2+Version: 1.1.0 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple@@ -12,8 +12,9 @@ Maintainer: agentm@themactionfaction.com Synopsis: Relational Algebra Engine Description: A relational algebra engine which can be used to persist and query Haskell data types.-Extra-Source-Files: Changelog.markdown README.markdown scripts/DateExamples.tutd scripts/multiline.tutd-tested-with: GHC ==9.2.8 || ==9.4.8+Extra-Source-Files: scripts/DateExamples.tutd scripts/multiline.tutd+Extra-Doc-Files: Changelog.markdown README.markdown+tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.2 || ==9.10.1  Source-Repository head     Type: git@@ -37,7 +38,7 @@  Library     Build-Depends:-                  base>=4.16 && < 4.19,+                  base >=4.14 && < 5,                   ghc-paths,                   mtl,                   containers,@@ -88,7 +89,7 @@                   cryptohash-sha256,                   text-manipulate >= 0.2.0.1 && < 0.4,                   winery >= 1.4,-                  curryer-rpc>=0.3.6,+                  curryer-rpc>=0.3.7,                   network,                   async,                   vector-instances,@@ -98,7 +99,7 @@                   fast-builder,                   scientific     if flag(haskell-scripting)-        Build-Depends: ghc >= 9.0 && < 9.5+        Build-Depends: ghc >= 9.0         CPP-Options: -DPM36_HASKELL_SCRIPTING     if impl(ghc>= 8) && flag(haskell-scripting)       build-depends:@@ -213,7 +214,9 @@       Other-Modules: ProjectM36.Win32Handle     else       --219-  too many exported symbols under Windows and GHC 8.4-      GHC-Options: -rdynamic -fexternal-interpreter -eventlog+      GHC-Options: -rdynamic -fexternal-interpreter+      if impl(ghc <9.4)+        GHC-Options: -eventlog       C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c       Build-Depends: unix     CC-Options: -fPIC@@ -225,7 +228,7 @@  Executable tutd     if flag(haskell-scripting)-        Build-Depends: ghc >= 9.0 && < 9.5+        Build-Depends: ghc >= 9.0     Build-Depends: base >=4.8,                    ghc-paths,                    project-m36,@@ -291,10 +294,11 @@                    ProjectM36.Interpreter     main-is: TutorialD/tutd.hs     CC-Options: -fPIC-    if os(windows)-      GHC-Options: -Wall -threaded -eventlog -rtsopts-    else-      GHC-Options: -Wall -threaded -rdynamic -eventlog -rtsopts+    GHC-Options: -Wall -threaded -rtsopts+    if !os(windows)+      GHC-Options: -rdynamic+    if impl(ghc <9.4)+      GHC-Options: -eventlog     if flag(profiler)       GHC-Prof-Options: -fprof-auto -rtsopts -threaded     Hs-Source-Dirs: ./src/bin@@ -303,7 +307,7 @@  Executable sqlegacy     if flag(haskell-scripting)-        Build-Depends: ghc >= 9.0 && < 9.5+        Build-Depends: ghc >= 9.0     Build-Depends: base,                    ghc-paths,                    project-m36,@@ -377,7 +381,7 @@  Executable project-m36-server     if flag(haskell-scripting)-        Build-Depends: ghc >= 9.0 && < 9.5+        Build-Depends: ghc >= 9.0     Build-Depends: base,                    ghc-paths,                    transformers,@@ -428,7 +432,9 @@     GHC-Options: -Wall -threaded -rtsopts     HS-Source-Dirs: ./src/bin     if flag(profiler)-      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall -eventlog+      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall+      if impl(ghc <9.4)+        GHC-Prof-Options: -eventlog  Common commontest     Default-Language: Haskell2010@@ -548,7 +554,10 @@     import: commontest     type: exitcode-stdio-1.0     main-is: benchmark/OnDiskClient.hs-    GHC-Options: -rtsopts -Wall -threaded -eventlog -finfo-table-map -fdistinct-constructor-tables+    GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall+    GHC-Options: -rtsopts -Wall -threaded -finfo-table-map -fdistinct-constructor-tables+    if impl(ghc <9.4)+      GHC-Options: -eventlog  Test-Suite test-server     import: commontest

@@ -12,7 +12,7 @@ import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.DatabaseContextExpr import TutorialD.Printer-import Control.Monad.State+import Control.Monad (when) import qualified Data.Text as T import ProjectM36.Relation.Show.Gnuplot import ProjectM36.HashSecurely

@@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+-- This suppresses the incomplete pattern match on @Right x@ in 'matrixRun'+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} import ProjectM36.Base import ProjectM36.Relation import ProjectM36.DateExamples@@ -111,7 +113,7 @@  -- 20 s 90 MBs- a clear win- ideal size is 10 * 100000 * 8 bytes = 80 MB! without IntAtom wrapper --with IntAtom wrapper: 1m12s 90 MB-{-                    +{-  vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom) vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]@@ -129,4 +131,3 @@       tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom (fromIntegral tupleX)))       tuples = map tuple [0 .. tupleCount]   mkRelationDeferVerify attrs (RelationTupleSet tuples)-

@@ -18,12 +18,10 @@    returnType]  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 (\f -> funcName f == funcName') funcSet+atomFunctionForName funcName' funcSet =+  case HS.toList  $ HS.filter (\f -> funcName f == funcName') funcSet of+    [] -> Left $ NoSuchFunctionError funcName'+    x : _ -> Right x  -- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet. emptyAtomFunction :: FunctionName -> AtomFunction

@@ -13,7 +13,7 @@ import qualified Data.List as L import Data.Maybe (isJust) import Data.Either (rights, lefts)-import Control.Monad.Writer+import Control.Monad (foldM, unless, when) import qualified Data.Map as M import qualified Data.Text as T @@ -416,10 +416,9 @@     pure ctype     else do     let diff = M.difference retMap tvMap-    if M.null diff then-      pure (ConstructedAtomType tCons (M.intersection tvMap retMap))-      else-      Left (AtomFunctionTypeVariableResolutionError funcName' (fst (head (M.toList diff))))+    case M.toList diff of+      [] -> pure (ConstructedAtomType tCons (M.intersection tvMap retMap))+      x : _ -> Left (AtomFunctionTypeVariableResolutionError funcName' (fst x)) resolveFunctionReturnValue funcName' tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of   Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName' tvName)   Just typ -> pure typ

@@ -1,7 +1,11 @@+{-# LANGUAGE CPP #-} module ProjectM36.AttributeNames where import ProjectM36.Base import qualified Data.Set as S-import Data.List (foldl')+#if MIN_VERSION_base(4,20,0)+#else+import Data.Foldable (foldl')+#endif --AttributeNames is a data structure which can represent inverted projection attributes and attribute names derived from relational expressions  empty :: AttributeNamesBase a

@@ -122,7 +122,10 @@ import qualified ProjectM36.DataFrame as DF import ProjectM36.DatabaseContextFunction as DCF import qualified ProjectM36.IsomorphicSchema as Schema-import Control.Monad.State+#if MIN_VERSION_base(4,16,0)+import Control.Monad (forever, forM, forM_, unless, void)+#endif+--import Control.Monad.State import qualified ProjectM36.RelationalExpression as RE import qualified ProjectM36.TransactionGraph as Graph import ProjectM36.TransactionGraph as TG

@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} -- | A simplified client interface for Project:M36 database access. module ProjectM36.Client.Simple (   simpleConnectProjectM36,@@ -31,6 +31,9 @@   ) where  import Control.Exception.Base+#if MIN_VERSION_base(4,18,0)+import Control.Monad ((<=<))+#endif import Control.Monad.Reader import ProjectM36.Base import qualified ProjectM36.Client as C

@@ -298,9 +298,18 @@ sqlEqualsTypes :: Atom -> Atom -> Bool sqlEqualsTypes a b = underlyingType a == underlyingType b   where-    underlyingType (ConstructedAtom "SQLNull" (ConstructedAtomType "SQLNullable" typmap) []) | M.size typmap == 1 = snd (head (M.assocs typmap))-    underlyingType (ConstructedAtom "SQLJust" (ConstructedAtomType "SQLNullable" typmap) _args) | M.size typmap == 1 = snd (head (M.assocs typmap))-    underlyingType atom = atomTypeForAtom atom+    underlyingType atom =+      let def = atomTypeForAtom atom +      in  case atom of+            ConstructedAtom x (ConstructedAtomType "SQLNullable" typmap) y ->+              let getSingle = case M.elems typmap of+                    [z] -> z+                    _ -> def +              in  case (x, y) of+                    ("SQLNull", []) -> getSingle +                    ("SQLJust", _) -> getSingle+                    _ -> def+            _ -> def  sqlEquals :: AtomFunctionBodyType sqlEquals [a,b] | sqlEqualsTypes a b =

@@ -24,12 +24,10 @@   }  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 (\f -> funcName f == funcName') funcs+databaseContextFunctionForName funcName' funcs =+  case HS.toList $ HS.filter (\f -> funcName f == funcName') funcs of+    [] -> Left $ NoSuchFunctionError funcName'+    x : _ -> Right x  evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext evalDatabaseContextFunction func args ctx =

@@ -125,10 +125,8 @@ --collapse list of errors into normal error- if there is just one, just return one someErrors :: [RelationalError] -> RelationalError                                       someErrors [] = error "no errors in error list: function misuse" -someErrors errList  = if length errList == 1 then-                        head errList-                      else-                        MultipleErrors errList+someErrors [err] = err+someErrors errList = MultipleErrors errList                          data MergeError = SelectedHeadMismatchMergeError |                   PreferredHeadMissingMergeError HeadName |

@@ -52,9 +52,7 @@ #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+functionForName funcName' funcSet =+  case HS.toList $ HS.filter (\f -> funcName f == funcName') funcSet of+    [] -> Left $ NoSuchFunctionError funcName'+    x : _ -> Right x

@@ -24,12 +24,11 @@    -- | return `Just transid` if this GraphRefRelationalExpr refers to just one transaction in the graph. This is useful for determining if certain optimizations can apply. singularTransaction :: Foldable t => t GraphRefTransactionMarker -> SingularTransactionRef-singularTransaction expr-  | S.null transSet = NoTransactionsRef-  | S.size transSet == 1 = SingularTransactionRef (head (S.toList transSet))-  | otherwise = MultipleTransactionsRef-  where-    transSet = foldr S.insert S.empty expr+singularTransaction expr = case S.toList $ foldr S.insert S.empty expr of+  [] -> NoTransactionsRef+  x : xs -> case xs of+    [] -> SingularTransactionRef x+    _ -> MultipleTransactionsRef  -- | Return True if two 'GraphRefRelationalExpr's both refer exclusively to the same transaction (or none at all). inSameTransaction :: GraphRefRelationalExpr -> GraphRefRelationalExpr -> Maybe GraphRefTransactionMarker

@@ -32,7 +32,7 @@ data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |                   RemoveSubschema SchemaName                   deriving (Generic, Show)-  + isomorphs :: Schema -> SchemaIsomorphs isomorphs (Schema i) = i @@ -40,10 +40,13 @@ -- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once. --TODO: add relvar must appear exactly once constraint validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError-validateSchema potentialSchema baseContext | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff)-                                           | not (null outDupes) = Just (RelVarOutReferencedMoreThanOnce (head outDupes))-                                           | not (null inDupes) = Just (RelVarInReferencedMoreThanOnce (head inDupes))                -                                           | otherwise = Nothing+validateSchema potentialSchema baseContext+  | not (S.null rvDiff) = Just (RelVarReferencesMissing rvDiff)+  | otherwise = case outDupes of+      x : _ -> Just $ RelVarOutReferencedMoreThanOnce x+      _ -> case inDupes of+             [] -> Nothing+             x : _ -> Just $ RelVarInReferencedMoreThanOnce x   where     --check that the predicate for IsoUnion and IsoRestrict holds right now     outDupes = duplicateNames (namesList isomorphOutRelVarNames)@@ -70,8 +73,8 @@ isomorphsInRelVarNames morphs = S.fromList (foldr rvnames [] morphs)   where     rvnames morph acc = acc ++ isomorphInRelVarNames morph-    -isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]    ++isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName] isomorphOutRelVarNames (IsoRestrict _ _ (rvA, rvB)) = [rvA, rvB] isomorphOutRelVarNames (IsoUnion _ _ rv) = [rv] isomorphOutRelVarNames (IsoRename _ rv) = [rv]@@ -89,23 +92,23 @@                             ex -> Right ex) relExprIn   where     validRelVarNames = isomorphsInRelVarNames (isomorphs schema)-  + processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr processRelationalExprInSchema (Schema []) expr = pure expr processRelationalExprInSchema schema relExprIn = do   --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation)   let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr-  validateRelationalExprInSchema schema relExprIn                    +  validateRelationalExprInSchema schema relExprIn   foldM processRelExpr relExprIn (isomorphs schema) -validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()  +validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError () validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema)-  -processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr  ++processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do   let relExprMogrifier = processRelationalExprInSchema schema   --validate that all mentioned relvars are in the valid set-  _ <- validateDatabaseContextExprInSchema schema dbExpr      +  _ <- validateDatabaseContextExprInSchema schema dbExpr   --perform the morph   foldM (\ex morph -> databaseContextExprMorph morph relExprMogrifier ex) dbExpr morphs @@ -120,18 +123,18 @@   where     validSchemaName = isomorphsInRelVarNames morphs     passthru rvname = Schema (morphs ++ [IsoRename rvname rvname])-    -processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas    ++processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas processDatabaseContextExprSchemasUpdate subschemas expr = M.map (`processDatabaseContextExprSchemaUpdate` expr) subschemas-  --- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema! ++-- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema! -- weird compromise: allow inclusion dependencies failures not in the subschema to be propagated- in the worst case, only the inclusion dependency's name is leaked.   {- -- | Convert inclusion dependencies for display in a specific schema. applySchemaToInclusionDependencies :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies-applySchemaToInclusionDependencies (Schema morphs) incDeps = +applySchemaToInclusionDependencies (Schema morphs) incDeps =   let incDepMorph incDep = --check that the mentioned relvars are in fact in the current schema-  M.update incDepMorph incDeps        +  M.update incDepMorph incDeps   -}  -- | Morph a relational expression in one schema to another isomorphic schema.@@ -144,7 +147,7 @@   RelationVariable rv m | rv == relIn -> Right (Union (RelationVariable relOutTrue m) (RelationVariable relOutFalse m))   orig -> Right orig relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \case-  --only the true predicate portion appears in the virtual schema  +  --only the true predicate portion appears in the virtual schema   RelationVariable rv m | rv == relInT -> Right (Restrict predi (RelationVariable relTarget m))    RelationVariable rv m | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget m))@@ -152,7 +155,7 @@ relExprMorph (IsoRename relIn relOut) = \case   RelationVariable rv m | rv == relIn -> Right (RelationVariable relOut m)   orig -> Right orig-  + relExprMogrify :: (RelationalExprBase a -> Either RelationalError (RelationalExprBase a)) -> RelationalExprBase a -> Either RelationalError (RelationalExprBase a) relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex) relExprMogrify func (Union exprA exprB) = do@@ -187,7 +190,7 @@ spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate (Just "nonboss", Just "boss"))) (RelationVariable "emp" ())  spam2 :: Either RelationalError RelationalExpr-spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ()) +spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ()) -}  databaseContextExprMorph :: SchemaIsomorph  -> (RelationalExpr -> Either RelationalError RelationalExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr@@ -208,14 +211,14 @@         falseExpr n = Update n attrMap (AndPredicate predi (NotPredicate filt))     pure (MultipleExpr [trueExpr rvTrue, falseExpr rvFalse])   MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs-  orig -> pure orig                                    -databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc expr = case expr of   +  orig -> pure orig+databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc expr = case expr of   --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr   --problem: between the delete->insert, constraints could be violated which would not otherwise be violated in the "in" schema. This implies that there should be a combo operator which can insert/update/delete in a single pass based on relexpr queries, or perhaps MultipleExpr should be the infamous "comma" operator from TutorialD?   -- if any tuples are filtered out of the insert/assign, we need to simulate a constraint violation   Assign rv relExpr | rv == rvTrue -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt,                                                                                       Insert rvOut (Restrict filt ex)]-  Assign rv relExpr | rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),            +  Assign rv relExpr | rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),                                                                                            Insert rvOut (Restrict (NotPredicate filt) ex)]   Insert rv relExpr | rv == rvTrue || rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ Insert rvOut ex   Delete rv delPred | rv == rvTrue -> pure $ Delete rvOut (AndPredicate delPred filt)@@ -229,9 +232,9 @@   Insert rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure $ Insert relOut ex   Delete rv delPred | rv == relIn -> pure $ Delete relOut delPred   Update rv attrMap predi | rv == relIn -> pure $ Update relOut attrMap predi-  MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs  +  MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs   orig -> pure orig-  + -- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema. applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs@@ -243,7 +246,7 @@ inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do   --collect all relvars which appear in the schema   let schemaRelVars = isomorphsInRelVarNames (isomorphs schema)-  rvAssoc <- mapM (\rvIn -> do +  rvAssoc <- mapM (\rvIn -> do                       rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ())                       pure (rvOut, RelationVariable rvIn ())                   )@@ -262,7 +265,7 @@ -- for IsoRestrict, consider hiding the two, generated constraints since they can never be thrown in the isomorphic schema inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies inclusionDependenciesInSchema schema incDeps = M.fromList <$> mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps)-  + relationVariablesInSchema :: Schema -> Either RelationalError RelationVariables relationVariablesInSchema schema@(Schema morphs) = foldM transform M.empty morphs   where@@ -289,7 +292,7 @@       attrs = A.attributesFromList [Attribute "name" TextAtomType,                                   Attribute "attributes" (RelationAtomType subrelAttrs)]       relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributesVec (attributes rel))]-      attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]  +      attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]       attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of         Left err -> error ("relationVariablesAsRelation pooped " ++ show err)         Right rel -> RelationAtom rel@@ -297,12 +300,12 @@  {- proposal-data DatabaseContext = +data DatabaseContext = Concrete ...| Virtual Isomorphs -}-{-  -applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables                                                                 +{-+applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables applyRelationVariablesSchemaIsomorphs {-morphs rvs -}= undefined -} {-  M.fromList <$> mapM (\(rvname, rvexpr) -> do@@ -321,10 +324,10 @@                   --notifications = notifs,                   --typeConstructorMapping = tconsmapping                 })-  -}  -{-    +  -}+{- validate :: SchemaIsomorph -> S.Set RelVarName -> Either RelationalError SchemaIsomorph-validate morph underlyingRvNames = if S.size invalidRvNames > 0 then +validate morph underlyingRvNames = if S.size invalidRvNames > 0 then                           Left (MultipleErrors (map RelVarNotDefinedError (S.toList invalidRvNames)))                          else                            Right morph@@ -335,7 +338,7 @@  -- | Create inclusion dependencies mainly for IsoRestrict because the predicate should hold in the base schema. createIncDepsForIsomorph :: SchemaName -> SchemaIsomorph -> InclusionDependencies-createIncDepsForIsomorph sname (IsoRestrict origRv predi (rvTrue, rvFalse)) = let +createIncDepsForIsomorph sname (IsoRestrict origRv predi (rvTrue, rvFalse)) = let   newIncDep predicate rv = InclusionDependency (Project AN.empty (Restrict predicate (RelationVariable rv ()))) (ExistingRelation relationTrue)   incDepName b = "schema" <> "_" <> sname <> "_" <> b in   M.fromList [(incDepName (origRv <> "_true"), newIncDep predi rvTrue),@@ -358,7 +361,7 @@             dbenv = mkDatabaseContextEvalEnv transId graph         dbstate <- runDatabaseContextEvalMonad context dbenv (evalGraphRefDatabaseContextExpr incDepExprs)         pure (newSchemas, dbc_context dbstate)---need to propagate dirty flag here      +--need to propagate dirty flag here  evalSchemaExpr (RemoveSubschema sname) context _ _ sschemas = if M.member sname sschemas then                                            pure (M.delete sname sschemas, context)@@ -373,14 +376,14 @@ instance Morph RelationalExpr where   morphToSchema schema _ relExprIn = do       let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr-      validateRelationalExprInSchema schema relExprIn                    +      validateRelationalExprInSchema schema relExprIn       foldM processRelExpr relExprIn (isomorphs schema)  -- | The names of inclusion dependencies might leak context about a different schema, but that's arbitrary and cannot be altered without having the user provide a renaming function or a new set of incDep names- seems extraneous. instance Morph InclusionDependency where   morphToSchema schema _ (InclusionDependency rexprA rexprB) = do     let schemaRelVars = isomorphsInRelVarNames (isomorphs schema)-    rvAssoc <- mapM (\rvIn -> do +    rvAssoc <- mapM (\rvIn -> do                       rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ())                       pure (rvOut, RelationVariable rvIn ())                   )@@ -400,7 +403,7 @@ -- cannot be implemented because relvars map to transaction-graph-traversing expressions and we do not track schema changes over time instance Morph RelationVariables where   morphToSchema schema tg relVars = do-    let folder acc (IsoRename rvBase rvSchema) = +    let folder acc (IsoRename rvBase rvSchema) =           case M.lookup rvBase relVars of             Nothing -> Left (RelVarNotDefinedError rvBase)             Just gfExpr -> do@@ -412,7 +415,3 @@ instance Morph GraphRefRelationalExpr where -- cannot be supported because we don't track how the schema changes over the lifetime of a transaction graph -}-                                                                                                                 -  -  -

@@ -73,10 +73,12 @@  --if the relation contains one tuple, return it, otherwise Nothing singletonTuple :: Relation -> Maybe RelationTuple-singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Finite 1 then-                                         Just $ head $ asList tupleSet-                                       else-                                         Nothing+singletonTuple rel@(Relation _ tupleSet) =+  case cardinality rel of+    Countable -> Nothing+    _ -> case asList tupleSet of+      [] -> Nothing+      x : _ -> Just x  -- this is still unncessarily expensive for (bigx union bigx) because each tuple is hashed and compared for equality (when the hashes match), but the major expense is attributesEqual, but we already know that all tuple attributes are equal (it's a precondition) union :: Relation -> Relation -> Either RelationalError Relation

@@ -136,9 +136,11 @@ renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar   where     columnLocations = fst cellLocs-    rowLocations = snd cellLocs-    renderRows = T.concat (map (\(row, rowHeight)-> renderRow row columnLocations rowHeight boxV) rowHeightMatrix)-    rowHeightMatrix = zip cellMatrix (tail rowLocations)+    rowLocations = case snd cellLocs of+      [] -> []+      _ : xs -> xs+    renderRows = T.concat (map (\(row, rowHeight) -> renderRow row columnLocations rowHeight boxV) rowHeightMatrix)+    rowHeightMatrix = zip cellMatrix rowLocations     renderBottomBar = renderHBar boxBL boxBB boxBR columnLocations  repeatString :: Int -> StringType -> StringType

@@ -22,7 +22,13 @@ import qualified Data.Map as M import qualified Data.HashSet as HS import qualified Data.Set as S-import Control.Monad.State hiding (join)+import Control.Monad (foldM, unless, when)+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError, catchError)+import Control.Monad.Reader (ReaderT, runReaderT, asks, ask, local)+import qualified Control.Monad.Reader as R+import Control.Monad.State (gets, get, put)+import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (liftIO) import Data.Bifunctor (second) import Data.Maybe import Data.Tuple (swap)@@ -36,9 +42,7 @@ import qualified ProjectM36.TypeConstructorDef as TCD import qualified Control.Monad.RWS.Strict as RWS import Control.Monad.RWS.Strict (RWST, execRWST, runRWST)-import Control.Monad.Except hiding (join) import Control.Monad.Trans.Except (except)-import Control.Monad.Reader as R hiding (join) import ProjectM36.NormalizeExpr import ProjectM36.WithNameExpr import ProjectM36.Function@@ -1138,7 +1142,9 @@     Nothing -> pure Nothing   tuples <- evalGraphRefTupleExprs mAttrs tupleExprs   let attrs = fromMaybe firstTupleAttrs mAttrs-      firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)+      firstTupleAttrs = case tuples of+        [] -> A.emptyAttributes+        x : _ -> tupleAttributes x   lift $ except $ mkRelation attrs (RelationTupleSet tuples) evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) =    lift $ except $ mkRelation attributeSet tupleSet@@ -1215,12 +1221,12 @@ transactionForId tid graph    | tid == U.nil =     Left RootTransactionTraversalError-  | S.null matchingTrans =-    Left $ NoSuchTransactionError tid   | otherwise =-    Right $ head (S.toList matchingTrans)-  where-    matchingTrans = S.filter (\(Transaction idMatch _ _) -> idMatch == tid) (transactionsForGraph graph)+      let sameTID (Transaction idMatch _ _) = idMatch == tid+          matchingTrans = S.filter sameTID $ transactionsForGraph graph+      in  case S.toList matchingTrans of+        [] -> Left $ NoSuchTransactionError tid+        x : _ -> Right x  typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet

@@ -32,7 +32,10 @@ import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT) import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Trans.Class (lift)+#if MIN_VERSION_base(4,20,0)+#else import Data.Foldable (foldl')+#endif import Data.Bifunctor (bimap) --import qualified Data.HashSet as HS 

@@ -22,14 +22,30 @@  import Unsafe.Coerce import GHC.LanguageExtensions (Extension(OverloadedStrings,ExtendedDefaultRules,ImplicitPrelude,ScopedTypeVariables))-+#if MIN_VERSION_ghc(9,6,0)+import Data.List.NonEmpty(NonEmpty(..))+#else+#endif+#if MIN_VERSION_ghc(9,6,0)+#else+#endif+#if MIN_VERSION_ghc(9,6,0)+import GHC.Core.TyCo.Compare (eqType)+#elif MIN_VERSION_ghc(9,0,0)+import GHC.Core.Type (eqType)+#else+import Type (eqType)+#endif+#if MIN_VERSION_ghc(9,6,0)+#elif MIN_VERSION_ghc(9,0,0)+import GHC.Unit.Types (IsBootInterface(NotBoot))+#else+#endif #if MIN_VERSION_ghc(9,4,0) import GHC.Utils.Panic (handleGhcException) import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) import GHC.Types.SourceText (SourceText(NoSourceText))-import GHC.Unit.Types (IsBootInterface(NotBoot)) import GHC.Driver.Ppr (showSDocForUser)-import GHC.Core.Type (eqType) import GHC.Core.TyCo.Ppr (pprType) import GHC.Utils.Encoding (zEncodeString) import GHC.Unit.State (emptyUnitState)@@ -39,9 +55,7 @@ import GHC.Utils.Panic (handleGhcException) import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) import GHC.Types.SourceText (SourceText(NoSourceText))-import GHC.Unit.Types (IsBootInterface(NotBoot)) import GHC.Driver.Ppr (showSDocForUser)-import GHC.Core.Type (eqType) import GHC.Types.TyThing.Ppr (pprTypeForUser) import GHC.Utils.Encoding (zEncodeString) import GHC.Unit.State (emptyUnitState)@@ -50,8 +64,6 @@ import GHC.Utils.Panic (handleGhcException) import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) import GHC.Types.Basic (SourceText(NoSourceText))-import GHC.Unit.Types (IsBootInterface(NotBoot))-import GHC.Core.Type (eqType) import GHC.Utils.Outputable (showSDocForUser) import GHC.Utils.Encoding (zEncodeString) import GHC.Core.Ppr.TyThing (pprTypeForUser)@@ -60,7 +72,6 @@ import BasicTypes (SourceText(NoSourceText)) import Outputable (showSDocForUser) import PprTyThing (pprTypeForUser)-import Type (eqType) import Encoding (zEncodeString) import Panic (handleGhcException) import DynFlags (projectVersion, PkgConfRef(PkgConfFile), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming), PackageDBFlag(PackageDB))@@ -126,7 +137,9 @@     let localPkgPaths = map pkgConf (ghcPkgPaths ++ sandboxPkgPaths ++ maybeToList mNixLibDir)      let dflags' = applyGopts . applyXopts $ dflags {-#if MIN_VERSION_ghc(9,2,0)+#if MIN_VERSION_ghc(9,6,0)+                           backend = interpreterBackend,+#elif MIN_VERSION_ghc(9,2,0)                            backend = Interpreter, #else                              hscTarget = HscInterpreted ,@@ -165,13 +178,32 @@   --liftIO $ traceShowM (showSDoc dflags' (ppr packages))     _ <- setSessionDynFlags dflags'     let safeImportDecl :: String -> Maybe String -> ImportDecl (GhcPass 'Parsed)-        safeImportDecl fullModuleName mQualifiedName = ImportDecl {+        safeImportDecl fullModuleName _mQualifiedName = ImportDecl {+#if MIN_VERSION_ghc(9,6,0)+#else           ideclSourceSrc = NoSourceText,--#if MIN_VERSION_ghc(9,2,0)+#endif+#if MIN_VERSION_ghc(9,6,0)+          ideclImportList = Nothing,+#endif+#if MIN_VERSION_ghc(9,10,0)+          ideclExt = XImportDeclPass+            { ideclAnn = noAnn+            , ideclSourceText = NoSourceText+            , ideclImplicit = False+            },+#elif MIN_VERSION_ghc(9,6,0)+          ideclExt = XImportDeclPass+            { ideclAnn = EpAnnNotUsed+            , ideclSourceText = NoSourceText+            , ideclImplicit = False+            },+#elif MIN_VERSION_ghc(9,2,0)           ideclExt = noAnn,+          ideclImplicit  = False, #else           ideclExt = noExtField,+          ideclImplicit  = False, #endif #if MIN_VERSION_ghc(9,2,0)           --GenLocated SrcSpanAnnA ModuleName@@ -189,16 +221,19 @@ #else           ideclSource    = False, #endif--          ideclSafe      = True,-          ideclImplicit  = False,-          ideclQualified = if isJust mQualifiedName then QualifiedPre else NotQualified,-#if MIN_VERSION_ghc(9,2,0)+          ideclQualified = if isJust _mQualifiedName then QualifiedPre else NotQualified,+#if MIN_VERSION_ghc(9,6,0)+          ideclAs        = Nothing,+#elif MIN_VERSION_ghc(9,2,0)           ideclAs        = Just (noLocA (mkModuleName fullModuleName)), #else-          ideclAs        = noLoc . mkModuleName <$> mQualifiedName,+          ideclAs        = noLoc . mkModuleName <$> _mQualifiedName, #endif-          ideclHiding    = Nothing+#if MIN_VERSION_ghc(9,6,0)+#else+          ideclHiding    = Nothing,+#endif+          ideclSafe      = True           }         unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl modn Nothing) [           "Prelude",@@ -239,9 +274,14 @@ mkTypeForName name = do   lBodyName <- parseName name   case lBodyName of+#if MIN_VERSION_ghc(9,6,0)+    _ :| (_:_) -> error "too many name matches"+    bodyName :| _ -> do+#else     [] -> error ("failed to parse " ++ name)     _:_:_ -> error "too many name matches"     [bodyName] -> do+#endif       mThing <- lookupName bodyName       case mThing of         Nothing -> error ("failed to find " ++ name)

@@ -12,11 +12,16 @@ import qualified ProjectM36.Attribute as A import qualified ProjectM36.AttributeNames as AS import ProjectM36.TupleSet+#if MIN_VERSION_base(4,18,0)+import Control.Monad (foldM)+#endif import Control.Monad.State import Control.Monad.Reader import Control.Monad.Except import Control.Monad.Trans.Except import Data.Functor.Identity+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import qualified Data.Set as S import Data.Functor.Foldable as Fold@@ -533,12 +538,14 @@     Extend n sub ->       Extend n (applyStaticRestrictionCollapse sub)     Restrict firstPred _ ->-      let restrictions = sequentialRestrictions expr-          finalExpr = last restrictions+      let (finalExpr, restrictions) = case sequentialRestrictions expr of+            [] -> (undefined, [])+            x : xs -> (NE.last $ x :| xs, xs)+           optFinalExpr = case finalExpr of                               Restrict _ subexpr -> applyStaticRestrictionCollapse subexpr                               otherExpr -> otherExpr-          andPreds = foldr folder firstPred (tail restrictions)+          andPreds = foldr folder firstPred restrictions           folder (Restrict subpred _) acc = AndPredicate acc subpred           folder _ _ = error "unexpected restriction expression in optimization phase"       in

@@ -16,8 +16,11 @@ import ProjectM36.ReferencedTransactionIds  import Codec.Winery-import Control.Monad.Except hiding (join)-import Control.Monad.Reader hiding (join)+#if MIN_VERSION_base(4,18,0)+import Control.Monad (foldM, forM, unless, when)+#endif+import Control.Monad.Except+import Control.Monad.Reader import qualified Data.Vector as V import qualified Data.UUID as U import qualified Data.Set as S@@ -39,15 +42,15 @@                            TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]                            deriving (Show, Eq, Generic)                            deriving Serialise via WineryVariant TransactionIdLookup-                           + -- | Used for git-style head backtracking such as topic~3^2. data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~v: walk back n parents, arbitrarily choosing a parent when a choice must be made-                                  TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent +                                  TransactionIdHeadBranchBacktrack Int | -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent                                   TransactionStampHeadBacktrack UTCTime -- ^ git equivalent of 'git-rev-list -n 1 --before X' find the first transaction which was created before the timestamp                                   deriving (Show, Eq, Generic)                                   deriving Serialise via WineryVariant TransactionIdHeadBacktrack -  + -- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon. data TransactionGraphOperator = JumpToHead HeadName  |                                 JumpToTransaction TransactionId |@@ -59,11 +62,11 @@                                 Rollback                               deriving (Eq, Show, Generic)                               deriving Serialise via WineryVariant TransactionGraphOperator-                                       -isCommit :: TransactionGraphOperator -> Bool                                       ++isCommit :: TransactionGraphOperator -> Bool isCommit Commit = True isCommit _ = False-                                       + data ROTransactionGraphOperator = ShowGraph | ValidateMerkleHashes                                   deriving Show @@ -94,12 +97,10 @@ headList graph = map (second transactionId) (M.assocs (transactionHeadsForGraph graph))  headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName-headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then-                                                                  Nothing-                                                                else-                                                                  Just $ (head . M.keys) matchingTrans-  where-    matchingTrans = M.filter (transaction ==) heads+headNameForTransaction transaction (TransactionGraph heads _) =+  case M.keys $ M.filter (transaction ==) heads of+    [] -> Nothing+    name : _ -> Just name  transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction) transactionsForIds idSet graph =@@ -148,7 +149,7 @@   when (S.size parentIds' < 1) (Left $ NewTransactionMissingParentError newId)   --if the headName already exists, ensure that it refers to a parent   case transactionForHead headName graph of-    Nothing -> pure () -- any headName is OK +    Nothing -> pure () -- any headName is OK     Just trans -> when (S.notMember (transactionId trans) parentIds') (Left (HeadNameSwitchingHeadProhibitedError headName))   --validate that the transaction has no children   unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)@@ -171,12 +172,12 @@   where   uncommittedReplace UncommittedContextMarker = TransactionMarker tid   uncommittedReplace marker = marker-  relvars = relationVariables (concreteDatabaseContext trans)  +  relvars = relationVariables (concreteDatabaseContext trans)   fixedRelvars = M.map (fmap uncommittedReplace) relvars   fixedContext = ctx { relationVariables = fixedRelvars }-    + validateGraph :: TransactionGraph -> Maybe [RelationalError] validateGraph graph@(TransactionGraph _ transSet) = do   --check that all transaction ids are unique in the graph@@ -240,16 +241,16 @@     Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in       Right (disconnectedTrans, graph)     Nothing -> Left $ NoSuchHeadNameError headName-    + evalGraphOp _ _ discon graph (WalkBackToTime backTime) = do   let startTransId = Discon.parentId discon-  jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime) +  jumpDest <- backtrackGraph graph startTransId (TransactionStampHeadBacktrack backTime)   case transactionForId jumpDest graph of     Left err -> Left err     Right trans -> do       let disconnectedTrans = Discon.freshTransaction (transactionId trans) (schemas trans)       Right (disconnectedTrans, graph)-              + -- add new head pointing to branchPoint -- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context) -- affects transactiongraph and the disconnectedtransaction is recreated based off the branch@@ -270,7 +271,7 @@   case addBranch stamp' newId newBranchName parentId graph of     Left err -> Left err     Right (_, newGraph) -> Right (newDiscon, newGraph)-  + -- add the disconnected transaction to the graph -- affects graph and disconnectedtransaction- the new disconnectedtransaction's parent is the freshly committed transaction evalGraphOp stamp' newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of@@ -290,8 +291,8 @@   Right parentTransaction -> Right (newDiscon, graph)     where       newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)-      -evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = ++evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) =   runGraphRefRelationalExprM env $ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB)   where     env = freshGraphRefRelationalExprEnv Nothing graph@@ -325,8 +326,8 @@                                       ]  transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation-transactionParentsRelation trans graph = -  if isRootTransaction trans then    +transactionParentsRelation trans graph =+  if isRootTransaction trans then     mkRelation attrs emptyTupleSet     else do       parentTransSet <- parentTransactions trans graph@@ -355,7 +356,7 @@                                                  transactionId trans2],                           stamp = stamp',                           merkleHash = mempty }) (schemas selectedTrans)-                       + -- merge functions, relvars, individually createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =   createUnionMergeTransaction stamp' newId strat t2@@ -369,11 +370,11 @@ validateHeadName headName graph (t1, t2) =   case transactionForHead headName graph of     Nothing -> throwError (MergeTransactionError SelectedHeadMismatchMergeError)-    Just trans -> if trans /= t1 && trans /= t2 then +    Just trans -> if trans /= t1 && trans /= t2 then                     throwError (MergeTransactionError SelectedHeadMismatchMergeError)                   else                     pure trans-  + -- Algorithm: start at one transaction and work backwards up the parents. If there is a node we have not yet visited as a child, then walk that up to its head. If that branch contains the goal transaction, then we have completed a valid subgraph traversal. The subgraph must also include any transactions which are referenced by other transactions. subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do@@ -390,8 +391,10 @@         errors = lefts childSearches         pathsFound = rights childSearches         realErrors = filter (/= FailedToFindTransactionError goalid) errors-    -- report any non-search-related errors        -    unless (null realErrors) (Left (head realErrors))+    -- report any non-search-related errors+    case realErrors of+      [] -> pure ()+      err : _ -> Left err     -- if no paths found, search the parent     if null pathsFound then       case oneParent currentTrans' of@@ -409,7 +412,7 @@         Right (TransactionGraph resultHeads closedTransactionSet)   where     oneParent (Transaction _ tinfo _) = transactionForId (NE.head (parents tinfo)) origGraph-    + -- | Search from a past graph point to all following heads for a specific transaction. If found, return the transaction path, otherwise a RelationalError. pathToTransaction :: TransactionGraph -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError (S.Set Transaction) pathToTransaction graph currentTransaction targetTransaction accumTransSet = do@@ -424,12 +427,14 @@       let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) (S.toList currentTransChildren)       let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)           paths = rights searches-      if not (null realErrors) then -- found some real errors-        Left (head realErrors)-      else if null paths then -- failed to find transaction in all children-             Left (FailedToFindTransactionError targetId)-           else --we have some paths!-             Right (S.unions paths)+      case realErrors of+        -- found some real errors+        err : _ -> Left err+        [] -> case paths of+          -- failed to find transaction in all children+          [] -> Left $ FailedToFindTransactionError targetId+          -- we have some paths!+          _ -> Right $ S.unions paths  mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> GraphRefRelationalExprM (DisconnectedTransaction, TransactionGraph) mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = do@@ -462,8 +467,8 @@               let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)                   newDiscon = Discon.freshTransaction newId (schemas newTrans)               pure (newDiscon, newGraph')-  ---TEMPORARY COPY/PASTE  ++--TEMPORARY COPY/PASTE showTransactionStructureX :: Bool -> Transaction -> TransactionGraph -> String showTransactionStructureX showRelVars trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo ++ relVarsInfo   where@@ -473,13 +478,13 @@     parentTransactionsInfo = if isRootTransaction trans then "root" else case parentTransactions trans graph of       Left err -> show err       Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet-  + showGraphStructureX :: Bool -> TransactionGraph -> String showGraphStructureX showRelVars graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet   where     folder trans acc = acc ++ showTransactionStructureX showRelVars trans graph ++ "\n"     headsInfo = show $ M.map transactionId heads-    + -- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph. filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet@@ -487,7 +492,7 @@     validIds = S.map transactionId (transactionsForGraph graph)     newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)     newHeads = M.map (filterTransaction validIds) heads-    + --helper function for commonalities in union merge createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction createUnionMergeTransaction stamp' newId strategy (t1,t2) = do@@ -496,16 +501,16 @@       liftMergeE x = case x of         Left e -> throwError (MergeTransactionError e)         Right t -> pure t-        +   graph <- gfGraph-  preference <- case strategy of +  preference <- case strategy of     UnionMergeStrategy -> pure PreferNeither     UnionPreferMergeStrategy preferBranch ->       case transactionForHead preferBranch graph of         Nothing -> throwError (MergeTransactionError (PreferredHeadMissingMergeError preferBranch))         Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond     badStrat -> throwError (MergeTransactionError (InvalidMergeStrategyError badStrat))-          +   incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)   relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)   atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)@@ -515,8 +520,8 @@   registeredQs <- liftMergeE $ unionMergeRegisteredQueries preference (registeredQueries contextA) (registeredQueries contextB)   -- TODO: add merge of subschemas   let newContext = DatabaseContext {-        inclusionDependencies = incDeps, -        relationVariables = relVars, +        inclusionDependencies = incDeps,+        relationVariables = relVars,         atomFunctions = atomFuncs,         dbcFunctions = dbcFuncs,         notifications = notifs,@@ -533,15 +538,15 @@  lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph-lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of +lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of   Nothing -> Left (NoSuchHeadNameError headName)   Just headTrans -> do     traversedId <- traverseGraph graph (transactionId headTrans) backtracks     transactionForId traversedId graph-    + traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId traverseGraph graph = foldM (backtrackGraph graph)-             + backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId -- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do@@ -556,28 +561,26 @@         pure (transactionId parentTrans)         else         backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))-  + backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do   trans <- transactionForId currentTid graph   let parentIds' = parentIds trans   if S.size parentIds' < 1 then-    Left RootTransactionTraversalError    +    Left RootTransactionTraversalError     else if S.size parentIds' < steps then            Left (ParentCountTraversalError (S.size parentIds') steps)          else            pure (S.elemAt (steps - 1) parentIds')-           -backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do           ++backtrackGraph graph currentTid btrack@(TransactionStampHeadBacktrack stamp') = do   trans <- transactionForId currentTid graph-  let parentIds' = parentIds trans  +  let parentIds' = parentIds trans   if timestamp trans <= stamp' then     pure currentTid-    else if S.null parentIds' then-           Left RootTransactionTraversalError-         else-           let arbitraryParent = head (S.toList parentIds') in-           backtrackGraph graph arbitraryParent btrack-    +    else case S.toList parentIds' of+      [] -> Left RootTransactionTraversalError+      arbitraryParent : _ -> backtrackGraph graph arbitraryParent btrack+ -- | Create a temporary branch for commit, merge the result to head, delete the temporary branch. This is useful to atomically commit a transaction, avoiding a TransactionIsNotHeadError but trading it for a potential MergeError. --this is not a GraphOp because it combines multiple graph operations autoMergeToHead :: UTCTime -> (TransactionId, TransactionId, TransactionId) -> DisconnectedTransaction -> HeadName -> MergeStrategy -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)@@ -585,23 +588,23 @@   let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId   --create the temp branch   (discon', graph') <- evalGraphOp stamp' tempBranchTransId discon graph (Branch tempBranchName)-  +   --commit to the new branch- possible future optimization: don't require fsync for this- create a temp commit type   (discon'', graph'') <- evalGraphOp stamp' tempCommitTransId discon' graph' Commit- +   --jump to merge head   (discon''', graph''') <- evalGraphOp stamp' tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)-  +   --create the merge   (discon'''', graph'''') <- evalGraphOp stamp' mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)-  +   --delete the temp branch   (discon''''', graph''''') <- evalGraphOp stamp' tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)   {-   let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')   traceShowM rel -}-  +   pure (discon''''', graph''''')  @@ -620,7 +623,7 @@         Right t -> t  validateMerkleHash :: Transaction -> TransactionGraph -> Either MerkleValidationError ()-validateMerkleHash trans graph = +validateMerkleHash trans graph =   when (expectedHash /= actualHash) $     Left (MerkleValidationError (transactionId trans) expectedHash actualHash)   where@@ -634,7 +637,7 @@ validateMerkleHashes graph =   if null errs then pure () else Left errs   where-    errs = S.foldr validateTrans [] (transactionsForGraph graph)    +    errs = S.foldr validateTrans [] (transactionsForGraph graph)     validateTrans trans acc =       case validateMerkleHash trans graph of         Left err -> err : acc

@@ -1,9 +1,15 @@+{-# LANGUAGE CPP #-} --Transaction Merge Engines module ProjectM36.TransactionGraph.Merge where import ProjectM36.Base import ProjectM36.Error import ProjectM36.RelationalExpression+#if MIN_VERSION_base(4,18,0)+import Control.Monad (foldM)+import Control.Monad.Except+#else import Control.Monad.Except hiding (join)+#endif import qualified Data.Set as S import qualified Data.Map as M import qualified ProjectM36.TypeConstructorDef as TCD

@@ -68,11 +68,9 @@ checkForOtherVersions dbdir = do   versionMatches <- globDir1 (compile "m36v*") dbdir   let otherVersions = L.delete transactionLogFileName (map takeFileName versionMatches)-  if not (null otherVersions) then-     pure (Left (WrongDatabaseFormatVersionError transactionLogFileName (head otherVersions)))-     else-     pure (Right ())- +  pure $ case otherVersions of+    [] -> Right ()+    x : _ -> Left $ WrongDatabaseFormatVersionError transactionLogFileName x  setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (LockFile, LockFileHash)) setupDatabaseDir sync dbdir bootstrapGraph = do

@@ -107,22 +107,29 @@   where     mapper tup2 = singleTupleJoin tup1 tup2 -}-            + -- if the keys share some keys and values, then merge the tuples -- if there are shared attributes, if they match, create a new tuple from the atoms of both tuples based on the attribute ordering argument singleTupleJoin :: Attributes -> RelationTuple -> RelationTuple -> Either RelationalError (Maybe RelationTuple)-singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if-  atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2-  then-    return Nothing-  else-    return $ Just $ RelationTuple joinedAttrs newVec+singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = do+    k1 <- atomsForAttributeNames keysIntersection tup1+    k2 <- atomsForAttributeNames keysIntersection tup2+    pure $ if k1 == k2+      then Just $ RelationTuple joinedAttrs newVec+      else Nothing   where+    keysIntersection :: V.Vector AttributeName     keysIntersection = V.map attributeName attrsIntersection+    attrsIntersection :: V.Vector Attribute     attrsIntersection = V.filter (`V.elem` attributesVec tupAttrs1) (attributesVec tupAttrs2)-    newVec = V.map (findAtomForAttributeName . attributeName) (attributesVec joinedAttrs)+    newVec :: V.Vector Atom+    newVec = V.mapMaybe (findAtomForAttributeName . attributeName) (attributesVec joinedAttrs)     --search both tuples for the attribute-    findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]+    findAtomForAttributeName :: AttributeName -> Maybe Atom+    findAtomForAttributeName attrName =+      case rights $ atomForAttributeName attrName <$> [tup1, tup2] of+        [] -> Nothing+        x : _ -> Just x  --same consideration as Data.List.union- duplicates in v1 are not de-duped vectorUnion :: (Eq a) => V.Vector a -> V.Vector a -> V.Vector a

@@ -21,10 +21,9 @@   let tupleList = map (verifyTuple attrs) (asList tupleSet) `P.using` P.parListChunk chunkSize P.r0       chunkSize = (length . asList) tupleSet `div` 24   --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet)-  if not (null (lefts tupleList)) then-    Left $ head (lefts tupleList)-   else-     return $ RelationTupleSet $ (HS.toList . HS.fromList) (rights tupleList)+  case lefts tupleList of+    x : _ -> Left x+    _ -> pure $ RelationTupleSet $ (HS.toList . HS.fromList) (rights tupleList)  mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet mkTupleSet attrs tuples = verifyTupleSet attrs (RelationTupleSet tuples)

@@ -6,9 +6,9 @@ import ProjectM36.StaticOptimizer import ProjectM36.DatabaseContext as DBC import System.Exit-import Control.Monad.State import Test.HUnit import qualified Data.Set as S+import Control.Monad (forM_)  main :: IO () main = do