project-m36 0.7 → 0.8

raw patch · 58 files changed

+3383/−2035 lines, 58 filesdep ~basedep ~ghcdep ~megaparsec

Dependency ranges changed: base, ghc, megaparsec

Files

Changelog.markdown +4/−0
README.markdown +2/−0
examples/blog.hs +5/−5
examples/hair.hs +4/−2
project-m36.cabal +24/−10
src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +6/−0
src/bin/TutorialD/Interpreter/Base.hs +1/−2
src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +9/−7
src/bin/TutorialD/Interpreter/RelationalExpr.hs +10/−7
src/bin/TutorialD/Interpreter/SchemaOperator.hs +2/−2
src/bin/benchmark/bigrel.hs +16/−7
src/lib/ProjectM36/AtomFunction.hs +5/−0
src/lib/ProjectM36/AtomType.hs +53/−5
src/lib/ProjectM36/AttributeNames.hs +3/−2
src/lib/ProjectM36/Base.hs +129/−47
src/lib/ProjectM36/Client.hs +105/−68
src/lib/ProjectM36/Client/Simple.hs +2/−1
src/lib/ProjectM36/DatabaseContext.hs +9/−4
src/lib/ProjectM36/DatabaseContextFunction.hs +5/−0
src/lib/ProjectM36/DatabaseContextFunctionUtils.hs +15/−8
src/lib/ProjectM36/DateExamples.hs +3/−3
src/lib/ProjectM36/DisconnectedTransaction.hs +6/−0
src/lib/ProjectM36/Error.hs +5/−0
src/lib/ProjectM36/GraphRefRelationalExpr.hs +45/−0
src/lib/ProjectM36/IsomorphicSchema.hs +22/−23
src/lib/ProjectM36/NormalizeExpr.hs +132/−0
src/lib/ProjectM36/Notifications.hs +12/−7
src/lib/ProjectM36/Relation.hs +1/−17
src/lib/ProjectM36/RelationalExpression.hs +1528/−1001
src/lib/ProjectM36/ScriptSession.hs +29/−15
src/lib/ProjectM36/Server.hs +7/−1
src/lib/ProjectM36/Server/EntryPoints.hs +4/−3
src/lib/ProjectM36/Session.hs +2/−1
src/lib/ProjectM36/Sessions.hs +1/−1
src/lib/ProjectM36/StaticOptimizer.hs +368/−248
src/lib/ProjectM36/TransGraphRelationalExpression.hs +135/−120
src/lib/ProjectM36/Transaction.hs +19/−16
src/lib/ProjectM36/Transaction/Persist.hs +47/−38
src/lib/ProjectM36/TransactionGraph.hs +168/−141
src/lib/ProjectM36/TransactionGraph/Merge.hs +16/−12
src/lib/ProjectM36/TransactionGraph/Persist.hs +6/−5
src/lib/ProjectM36/TransactionGraph/Show.hs +3/−4
src/lib/ProjectM36/TransactionInfo.hs +10/−0
src/lib/ProjectM36/WithNameExpr.hs +84/−0
test/IsomorphicSchema.hs +36/−26
test/Relation/Atomable.hs +1/−2
test/Relation/Basic.hs +11/−5
test/Relation/StaticOptimizer.hs +76/−51
test/Relation/Tupleable.hs +1/−1
test/Server/Main.hs +4/−2
test/Server/WebSocket.hs +5/−3
test/TransactionGraph/Merge.hs +60/−39
test/TransactionGraph/Persist.hs +19/−12
test/TutorialD/Interpreter.hs +59/−24
test/TutorialD/Interpreter/AtomFunctionScript.hs +24/−16
test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs +13/−6
test/TutorialD/Interpreter/Import/TutorialD.hs +2/−2
test/TutorialD/Interpreter/TestBase.hs +10/−13

Changelog.markdown view

@@ -1,3 +1,7 @@+# 2020-05-25 (v0.8)++* refactor backend to maximize laziness: [An Architecture for Data Independence](docs/data_independence.markdown)+ # 2019-09-07 (v0.7)  * fix case sensitivity issue with relation variables in tutd

README.markdown view

@@ -48,6 +48,7 @@  1. [Installation and Introduction to Project:M36](docs/introduction_to_projectm36.markdown) 1. [Introduction to the Relational Algebra](docs/introduction_to_the_relational_algebra.markdown)+1. [TutorialD Cheatsheet](docs/tutd_cheatsheet.markdown) 1. [TutorialD via Jupyter Notebook Walkthrough](jupyter/TutorialD%20Notebook%20Walkthrough.ipynb) 1. [TutorialD Tutorial](docs/tutd_tutorial.markdown) 1. [15 Minute Tutorial](docs/15_minute_tutorial.markdown)@@ -60,6 +61,7 @@ 1. [ACID Database Properties](docs/acid_assessment.markdown) 1. [On NULL (in SQL)](docs/on_null.markdown) 1. [Reaching "Out of the Tarpit" with Project:M36](docs/reaching_out_of_the_tarpit.markdown)+1. [An Architecture for Data Independence](docs/data_independence.markdown)  ### Advanced Features

examples/blog.hs view

@@ -35,7 +35,7 @@ data Blog = Blog {   title :: T.Text,   entry :: T.Text,-  stamp :: UTCTime,+  tstamp :: UTCTime,   category :: Category --note that this type is an algebraic data type   }           deriving (Generic, Show) --derive Generic so that Tupleable can use default instances@@ -105,11 +105,11 @@ insertSampleData sessionId conn = do   let blogs = [Blog { title = "Haskell Lenses",                       entry = "I wear Haskell rose-colored lenses.",-                      stamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),+                      tstamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),                       category = Food },                Blog { title = "Haskell Monad Analogy",                       entry = "Monads are like burritos going through intestines.",-                      stamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),+                      tstamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),                       category = Cats }                ]       comments = [Comment { blogTitle = "Haskell Lenses",@@ -138,7 +138,7 @@     Left err -> render500 (toHtml (show err))     Right blogRel -> do       blogs <- liftIO (toList blogRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Blog]-      let sortedBlogs = sortBy (\b1 b2 -> stamp b1 `compare` stamp b2) blogs+      let sortedBlogs = sortBy (\b1 b2 -> tstamp b1 `compare` tstamp b2) blogs       html . renderHtml $ do         h1 "Blog Posts"         forM_ sortedBlogs $ \blog -> a ! href (toValue $ "/blog/" <> title blog) $ h2 (toHtml (title blog))@@ -184,7 +184,7 @@           render $ do             --show blog details             h1 (toHtml (title blog))-            p (toHtml ("Posted at " <> formatStamp (stamp blog) <> " under " <> show (category blog)))+            p (toHtml ("Posted at " <> formatStamp (tstamp blog) <> " under " <> show (category blog)))             p (toHtml (entry blog))             hr             h3 "Comments"

examples/hair.hs view

@@ -31,8 +31,10 @@    --create a relation with the new Hair AtomType   let blond = NakedAtomExpr (toAtom Blond)-  eCheck $ executeDatabaseContextExpr sessionId conn (Assign "people" (MakeRelationFromExprs Nothing [-            TupleExpr (M.fromList [("hair", blond), ("name", NakedAtomExpr (TextAtom "Colin"))])]))+  eCheck $ executeDatabaseContextExpr sessionId conn+    (Assign "people"+     (MakeRelationFromExprs Nothing $ TupleExprs () [+         TupleExpr (M.fromList [("hair", blond), ("name", NakedAtomExpr (TextAtom "Colin"))])]))    let restrictionPredicate = AttributeEqualityPredicate "hair" blond   peopleRel <- eCheck $ executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "people" ()))

project-m36.cabal view

@@ -1,5 +1,5 @@ Name: project-m36-Version: 0.7+Version: 0.8 License: PublicDomain Build-Type: Simple Homepage: https://github.com/agentm/project-m36@@ -28,8 +28,19 @@     Manual: True     Default: False +Flag haskell-scripting+     Description: enables Haskell scripting which links against GHC as a library+     Manual: True+     Default: True+ Library-    Build-Depends: base>=4.8 && < 4.13, ghc >= 8.2 && < 8.7, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256+    Build-Depends: base>=4.8 && < 4.14, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256+    if flag(haskell-scripting)+        Build-Depends: ghc >= 8.2 && < 8.9+        CPP-Options: -DPM36_HASKELL_SCRIPTING+    if impl(ghc>= 8) && flag(haskell-scripting)+      build-depends:+        ghc-boot, ghci     if impl(ghc>= 8.6)         Build-Depends: deferred-folds     Exposed-Modules: ProjectM36.Error,@@ -104,7 +115,11 @@                      ProjectM36.TypeConstructorDef,                      ProjectM36.FileLock,                      ProjectM36.FSType,-                     ProjectM36.Arbitrary+                     ProjectM36.Arbitrary,+                     ProjectM36.GraphRefRelationalExpr,+                     ProjectM36.NormalizeExpr,+                     ProjectM36.TransactionInfo,+                     ProjectM36.WithNameExpr     GHC-Options: -Wall -rdynamic     if os(windows)       Build-Depends: Win32 >= 2.5.4.1@@ -118,15 +133,13 @@     Hs-Source-Dirs: ./src/lib     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings, CPP-    if impl(ghc>= 8)-      build-depends:-        ghc-boot, ghci-    if !flag(stack)+    if !flag(stack)        Build-Depends: deferred-folds  Executable tutd+    if flag(haskell-scripting)+        Build-Depends: ghc >= 8.2 && < 8.9     Build-Depends: base >=4.8 && <5.0,-                   ghc >= 7.8 && < 8.7,                    ghc-paths,                    project-m36,                    containers,@@ -154,7 +167,7 @@                    directory,                    filepath,                    temporary,-                   megaparsec >= 5.2.0 && < 8,+                   megaparsec >= 5.2.0 && < 9,                    haskeline,                    random, MonadRandom,                    base64-bytestring,@@ -189,8 +202,9 @@     Default-Extensions: OverloadedStrings  Executable project-m36-server+    if flag(haskell-scripting)+        Build-Depends: ghc >= 8.2 && < 8.9     Build-Depends: base,-                   ghc >= 7.8 && < 8.7,                    ghc-paths,                    project-m36,                    binary,

src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs view

@@ -22,6 +22,9 @@ instance ToJSON TupleExpr instance FromJSON TupleExpr +instance ToJSON TupleExprs+instance FromJSON TupleExprs+ instance ToJSON RestrictionPredicateExpr instance FromJSON RestrictionPredicateExpr @@ -149,3 +152,6 @@  instance ToJSON AtomFunctionError instance FromJSON AtomFunctionError++instance ToJSON WithNameExpr+instance FromJSON WithNameExpr

src/bin/TutorialD/Interpreter/Base.hs view

@@ -50,7 +50,6 @@ anySingle = anyChar #endif - displayOpResult :: TutorialDOperatorResult -> IO () displayOpResult QuitResult = return () displayOpResult (DisplayResult out) = TIO.putStrLn out@@ -222,4 +221,4 @@   timeStr <- quotedString   case parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (T.unpack timeStr) of     Nothing -> fail "invalid datetime input, use \"YYYY-MM-DD HH:MM:SS\""-    Just stamp -> pure stamp+    Just stamp' -> pure stamp'

src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs view

@@ -6,7 +6,6 @@ import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.Types import qualified Data.Map as M-import Control.Monad.State import ProjectM36.StaticOptimizer import qualified ProjectM36.Error as PM36E import ProjectM36.Error@@ -192,19 +191,22 @@ databaseExprOpP :: Parser DatabaseContextExpr databaseExprOpP = multipleDatabaseContextExprP +{- evalDatabaseContextExpr :: Bool -> DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContext evalDatabaseContextExpr useOptimizer context expr = do     optimizedExpr <- evalState (applyStaticDatabaseOptimization expr) (RE.freshDatabaseState context)     case runState (RE.evalDatabaseContextExpr (if useOptimizer then optimizedExpr else expr)) (RE.freshDatabaseState context) of         (Right (), (context',_, _)) -> Right context'         (Left err, _) -> Left err-+-} -interpretDatabaseContextExpr :: DatabaseContext -> T.Text -> Either RelationalError DatabaseContext-interpretDatabaseContextExpr context tutdstring = case parse databaseExprOpP "" tutdstring of-                                    Left err -> Left $ PM36E.ParseError (T.pack (show err))-                                    Right parsed -> -                                      evalDatabaseContextExpr True context parsed+interpretDatabaseContextExpr :: DatabaseContext -> TransactionId -> TransactionGraph -> T.Text -> Either RelationalError DatabaseContext+interpretDatabaseContextExpr context transId graph tutdstring =+  case parse databaseExprOpP "" tutdstring of+    Left err -> Left $ PM36E.ParseError (T.pack (show err))+    Right parsed -> do+      let env = RE.mkDatabaseContextEvalEnv transId graph+      RE.dbc_context <$> RE.runDatabaseContextEvalMonad context env (optimizeAndEvalDatabaseContextExpr True parsed)  {- --no optimization

src/bin/TutorialD/Interpreter/RelationalExpr.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}- module TutorialD.Interpreter.RelationalExpr where import Text.Megaparsec #if MIN_VERSION_megaparsec(7,0,0)@@ -30,7 +29,8 @@   reserved "relation"   attrExprs <- try (fmap Just makeAttributeExprsP) <|> pure Nothing   tupleExprs <- braces (sepBy tupleExprP comma) <|> pure []-  pure $ MakeRelationFromExprs attrExprs tupleExprs+  marker <- parseMarkerP+  pure $ MakeRelationFromExprs attrExprs (TupleExprs marker tupleExprs)   --abstract data type parser- in this context, the type constructor must not include any type arguments@@ -251,12 +251,15 @@ withMacroExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a) withMacroExprP = do   reservedOp "with"-  views <- parens (sepBy1 createViewP comma)+  views <- parens (sepBy1 createMacroP comma)   With views <$> relExprP -createViewP :: RelationalMarkerExpr a => Parser (RelVarName, RelationalExprBase a)-createViewP = do-  name <- relVarNameP+createMacroP :: RelationalMarkerExpr a => Parser (WithNameExprBase a, RelationalExprBase a)+createMacroP = do +  name <- identifier   reservedOp "as"   expr <- relExprP-  pure (name, expr)+  marker <- parseMarkerP+  pure (WithNameExpr name marker, expr)++

src/bin/TutorialD/Interpreter/SchemaOperator.hs view

@@ -42,7 +42,7 @@   reserved "isorestrict"   relVarIn <- qrelVarP   relvarsOut <- isoRestrictOutRelVarsP-  IsoRestrict <$> pure relVarIn <*> restrictionPredicateP <*> pure relvarsOut+  IsoRestrict relVarIn <$> restrictionPredicateP <*> pure relvarsOut    isoRestrictOutRelVarsP :: Parser (RelVarName, RelVarName)   isoRestrictOutRelVarsP = (,) <$> qrelVarP <*> qrelVarP@@ -55,7 +55,7 @@   reserved "isounion"   relVarsIn <- isoUnionInRelVarsP   relVarsOut <- qrelVarP-  IsoUnion <$> pure relVarsIn <*> restrictionPredicateP <*> pure relVarsOut+  IsoUnion relVarsIn <$> restrictionPredicateP <*> pure relVarsOut    isoRenameP :: Parser SchemaIsomorph isoRenameP = do

src/bin/benchmark/bigrel.hs view

@@ -4,28 +4,30 @@ import ProjectM36.Relation import ProjectM36.DateExamples import ProjectM36.Error+import ProjectM36.StaticOptimizer import qualified ProjectM36.Attribute as A import qualified Data.Text as T --import ProjectM36.Relation.Show.CSV import ProjectM36.Relation.Show.HTML-import TutorialD.Interpreter.DatabaseContextExpr (interpretDatabaseContextExpr) import ProjectM36.RelationalExpression+import ProjectM36.TransactionGraph --import qualified Data.HashSet as HS --import qualified Data.ByteString.Lazy.Char8 as BS --import qualified Data.IntMap as IM --import qualified Data.Hashable as Hash import qualified Data.Vector as V import Options.Applicative-import qualified Data.Map as M import qualified Data.Text.IO as TIO import System.IO-import Control.Monad.State import Control.DeepSeq import Data.Text hiding (map)+import Data.Time.Clock+import Data.UUID.V4 #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif + {- dumpcsv :: Relation -> IO () dumpcsv rel = case relationAsCSV rel of@@ -62,13 +64,20 @@     Right rel -> if tutd == "" then                    putStrLn "Done."                  else do+                   now <- getCurrentTime+                   tid <- nextRandom                    let setx = Assign "x" (ExistingRelation (force rel))-                       (context,_,_) = execState (evalDatabaseContextExpr setx) (freshDatabaseState dateExamples)-                       interpreted = interpretDatabaseContextExpr context tutd+                       graph = bootstrapTransactionGraph now tid dateExamples+                       env = mkDatabaseContextEvalEnv tid graph+                       eNewState = runDatabaseContextEvalMonad dateExamples env (optimizeAndEvalDatabaseContextExpr True setx)                        --plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd                    --displayOpResult plan-                   case interpreted of-                     Right context' -> TIO.putStrLn $ relationAsHTML (relationVariables context' M.! "x")+                   case eNewState of+                     Right newState -> do+                       let ctx = dbc_context newState+                           Right x = optimizeAndEvalRelationalExpr env' (RelationVariable "x" ())+                           env' = RelationalExprEnv ctx graph Nothing+                       TIO.putStrLn $ relationAsHTML x                      Left err -> hPrint stderr err  {-

src/lib/ProjectM36/AtomFunction.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module ProjectM36.AtomFunction where import ProjectM36.Base import ProjectM36.Error@@ -72,7 +73,11 @@                 retType]])  loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])+#ifdef PM36_HASKELL_SCRIPTING loadAtomFunctions = loadFunction+#else+loadAtomFunctions _ _ _ = pure (Left LoadSymbolError)+#endif  atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

src/lib/ProjectM36/AtomType.hs view

@@ -221,10 +221,18 @@                                      Just (tCons, dConsList)                                    else                                      accum-                                    ++resolveAttributes :: Attribute -> Attribute -> Either RelationalError Attribute+resolveAttributes attrA attrB =+  if A.attributeName attrA /= A.attributeName attrB then+    Left $ AttributeNamesMismatchError (S.fromList (map A.attributeName [attrA, attrB]))+  else+    Attribute (A.attributeName attrA) <$> resolveAtomType (A.atomType attrA) (A.atomType attrB)+    +--given two atom types, try to resolve type variables                                      resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType   resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) =-  ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap+  ConstructedAtomType tConsName <$> resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap  resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then                                                     Right typeFromRelation                                                   else@@ -252,12 +260,16 @@   let resolveTypePair resKey resType =         -- if the key is missing in the unresolved type map, then fill it in with the value from the resolved map         case M.lookup resKey unresolvedTypeMap of-          Just unresType -> case unresType of +          Just unresType -> case unresType of             --do we need to recurse for RelationAtomType?             subType@(ConstructedAtomType _ _) -> do               resSubType <- resolveAtomType resType subType               pure (resKey, resSubType)-            _ -> pure (resKey, resType)+            TypeVariableType _ -> pure (resKey, resType)+            typ -> if typ == resType then+                     pure (resKey, resType)+                   else+                     Left $ AtomTypeMismatchError typ resType           Nothing ->             pure (resKey, resType) --swipe the missing type var from the expected map   tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap)@@ -306,6 +318,15 @@ validateAtomType (TypeVariableType x) _ = Left (TypeConstructorTypeVarMissing x)   validateAtomType _ _ = pure () +validateAttributes :: TypeConstructorMapping -> Attributes -> Either RelationalError ()+validateAttributes tConss attrs =+  if not (null errs) then+    Left (someErrors errs)+  else+    pure ()+  where+    errs = lefts $ map ((`validateAtomType` tConss) . A.atomType) (V.toList attrs)+ --ensure that all type vars are fully resolved validateTypeVarMap :: TypeVarMap -> TypeConstructorMapping -> Either RelationalError () validateTypeVarMap tvMap tConss = mapM_ (`validateAtomType` tConss) $ M.elems tvMap@@ -346,7 +367,12 @@  -- | Determine if two typeVars are logically compatible. typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool-typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) (map (\((_,v1),(_,v2)) -> atomTypeVerify v1 v2) (zip (M.toAscList a) (M.toAscList b))) == M.size a+typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) zipped == M.size a+  where+    zipped = zipWith+      (curry (\ ((_, v1), (_, v2)) -> atomTypeVerify v1 v2))+      (M.toAscList a)+      (M.toAscList b)  prettyAtomType :: AtomType -> T.Text prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"@@ -405,3 +431,25 @@   Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)   Just typ -> Right typ +isResolvedType :: AtomType -> Bool+isResolvedType typ =+  case typ of+    IntAtomType -> True+    IntegerAtomType -> True+    DoubleAtomType -> True+    TextAtomType -> True+    DayAtomType -> True+    DateTimeAtomType -> True+    ByteStringAtomType -> True+    BoolAtomType -> True+    RelationAtomType attrs -> isResolvedAttributes attrs+    ConstructedAtomType _ tvMap -> all isResolvedType (M.elems tvMap)+    TypeVariableType _ -> False++isResolvedAttributes :: Attributes -> Bool+isResolvedAttributes attrs = all isResolvedAttribute (V.toList attrs)++isResolvedAttribute :: Attribute -> Bool+isResolvedAttribute = isResolvedType . A.atomType++--given two AtomTypes x,y

src/lib/ProjectM36/AttributeNames.hs view

@@ -3,8 +3,9 @@ import qualified Data.Set as S --AttributeNames is a data structure which can represent inverted projection attributes and attribute names derived from relational expressions -empty :: AttributeNames+empty :: AttributeNamesBase a empty = AttributeNames S.empty -all :: AttributeNames+all :: AttributeNamesBase a all = InvertedAttributeNames S.empty+

src/lib/ProjectM36/Base.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings #-}+{-# LANGUAGE ExistentialQuantification,DeriveGeneric,DeriveAnyClass,FlexibleInstances,OverloadedStrings, DeriveTraversable #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module ProjectM36.Base where@@ -13,6 +13,7 @@ import Control.DeepSeq (NFData, rnf) import Control.DeepSeq.Generics (genericRnf) import GHC.Generics (Generic)+import GHC.Stack import qualified Data.Vector as V import qualified Data.List as L import Data.Text (Text,unpack)@@ -24,6 +25,7 @@ import Data.Hashable.Time () import Data.Typeable import Data.ByteString (ByteString)+import qualified Data.List.NonEmpty as NE type StringType = Text    -- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.@@ -79,7 +81,8 @@               deriving (Eq, NFData, Generic, Binary, Show)  instance Ord AtomType where-  compare = undefined                      +  compare = undefined+   type TypeVarMap = M.Map TypeVarName AtomType  instance Hashable TypeVarMap where @@ -182,7 +185,7 @@ -- | A relational expression represents query (read) operations on a database. data RelationalExprBase a =   --- | Create a relation from tuple expressions.-  MakeRelationFromExprs (Maybe [AttributeExprBase a]) [TupleExprBase a] |+  MakeRelationFromExprs (Maybe [AttributeExprBase a]) (TupleExprsBase a) |   --- | Create and reference a relation from attributes and a tuple set.   MakeStaticRelation Attributes RelationTupleSet |   --- | Reference an existing relation in Haskell-space.@@ -191,7 +194,7 @@   --in Tutorial D, relational variables pick up the type of the first relation assigned to them   --relational variables should also be able to be explicitly-typed like in Haskell   --- | Reference a relation variable by its name.-  RelationVariable RelVarName a |+  RelationVariable RelVarName a |      --- | Create a projection over attribute names. (Note that the 'AttributeNames' structure allows for the names to be inverted.)   Project (AttributeNamesBase a) (RelationalExprBase a) |   --- | Create a union of two relational expressions. The expressions should have identical attributes.@@ -214,11 +217,20 @@   Extend (ExtendTupleExprBase a) (RelationalExprBase a) |   --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend   --Evaluate relationalExpr with scoped views-  With [(RelVarName,RelationalExprBase a)] (RelationalExprBase a)-  deriving (Show, Eq, Generic, NFData)+  With [(WithNameExprBase a, RelationalExprBase a)] (RelationalExprBase a)+  deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)             instance Binary RelationalExpr-           ++data WithNameExprBase a = WithNameExpr RelVarName a+  deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)++type WithNameExpr = WithNameExprBase ()++instance Binary WithNameExpr++type GraphRefWithNameExpr = WithNameExprBase GraphRefTransactionMarker+ type NotificationName = StringType type Notifications = M.Map NotificationName Notification @@ -262,8 +274,15 @@                            deriving (Show, Generic, Binary, Eq, NFData)                                      type InclusionDependencies = M.Map IncDepName InclusionDependency-type RelationVariables = M.Map RelVarName Relation+type RelationVariables = M.Map RelVarName GraphRefRelationalExpr +data GraphRefTransactionMarker = TransactionMarker TransactionId |+                                 UncommittedContextMarker+                                 deriving (Eq, Show, Binary, Generic, NFData, Ord)+  +-- a fundamental relational expr to which other relational expressions compile+type GraphRefRelationalExpr = RelationalExprBase GraphRefTransactionMarker+ type SchemaName = StringType                           type Subschemas = M.Map SchemaName Schema@@ -305,15 +324,21 @@ --used for returning information about individual expressions type DatabaseContextExprName = StringType +type DatabaseContextExpr = DatabaseContextExprBase ()++type GraphRefDatabaseContextExpr = DatabaseContextExprBase GraphRefTransactionMarker++instance Binary GraphRefDatabaseContextExpr+ -- | Database context expressions modify the database context.-data DatabaseContextExpr = +data DatabaseContextExprBase a =    NoOperation |-  Define RelVarName [AttributeExpr] |+  Define RelVarName [AttributeExprBase a] |   Undefine RelVarName | --forget existence of relvar X-  Assign RelVarName RelationalExpr |-  Insert RelVarName RelationalExpr |-  Delete RelVarName RestrictionPredicateExpr  |-  Update RelVarName AttributeNameAtomExprMap RestrictionPredicateExpr |+  Assign RelVarName (RelationalExprBase a) |+  Insert RelVarName (RelationalExprBase a) |+  Delete RelVarName (RestrictionPredicateExprBase a)  |+  Update RelVarName AttributeNameAtomExprMap (RestrictionPredicateExprBase a) |      AddInclusionDependency IncDepName InclusionDependency |   RemoveInclusionDependency IncDepName |@@ -329,24 +354,33 @@      RemoveDatabaseContextFunction DatabaseContextFunctionName |   -  ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExpr] |+  ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExprBase a] |   -  MultipleExpr [DatabaseContextExpr]-  deriving (Show, Eq, Binary, Generic)+  MultipleExpr [DatabaseContextExprBase a]+  deriving (Show, Eq, Generic) +instance Binary DatabaseContextExpr+ type ObjModuleName = StringType type ObjFunctionName = StringType type Range = (Int,Int)   -- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.-data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |-                             LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |-                             AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |-                             LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |-                             CreateArbitraryRelation RelVarName [AttributeExpr] Range+data DatabaseContextIOExprBase a =+  AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |+  LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |+  AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript |+  LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |+  CreateArbitraryRelation RelVarName [AttributeExprBase a] Range                            deriving (Show, Eq, Generic, Binary) +type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker++type DatabaseContextIOExpr = DatabaseContextIOExprBase ()+ type RestrictionPredicateExpr = RestrictionPredicateExprBase () +type GraphRefRestrictionPredicateExpr = RestrictionPredicateExprBase GraphRefTransactionMarker+ -- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation. data RestrictionPredicateExprBase a =   TruePredicate |@@ -356,7 +390,7 @@   RelationalExprPredicate (RelationalExprBase a) | --type must be same as true and false relations (no attributes)   AtomExprPredicate (AtomExprBase a) | --atom must evaluate to boolean   AttributeEqualityPredicate AttributeName (AtomExprBase a) -- relationalexpr must result in relation with single tuple-  deriving (Show, Eq, Generic, NFData)+  deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)  instance Binary RestrictionPredicateExpr @@ -369,17 +403,26 @@ -- | The transaction graph is the global database's state which references every committed transaction. data TransactionGraph = TransactionGraph TransactionHeads (S.Set Transaction) -transactionsForGraph :: TransactionGraph -> S.Set Transaction-transactionsForGraph (TransactionGraph _ t) = t- transactionHeadsForGraph :: TransactionGraph -> TransactionHeads-transactionHeadsForGraph (TransactionGraph heads _) = heads+transactionHeadsForGraph (TransactionGraph hs _) = hs +transactionsForGraph :: TransactionGraph -> S.Set Transaction+transactionsForGraph (TransactionGraph _ ts) = ts+ -- | Every transaction has context-specific information attached to it.-data TransactionInfo = TransactionInfo TransactionId (S.Set TransactionId) UTCTime | -- 1 parent + n children-                       MergeTransactionInfo TransactionId TransactionId (S.Set TransactionId) UTCTime -- 2 parents, n children-                     deriving(Show, Generic)-                             +-- The `TransactionDiff`s represent child/edge relationships to previous transactions (branches or continuations of the same branch).+data TransactionInfo = TransactionInfo {+  parents :: TransactionParents,+  stamp :: UTCTime+  } deriving (Show, Generic)++type TransactionParents = NE.NonEmpty TransactionId+{-+data TransactionInfo = TransactionInfo TransactionId TransactionDiffs UTCTime | -- 1 parent + n children+                       MergeTransactionInfo TransactionId TransactionId TransactionDiffs UTCTime -- 2 parents, n children+                     deriving (Show, Generic)+-}+ instance Binary TransactionInfo                               -- | Every set of modifications made to the database are atomically committed to the transaction graph as a transaction.@@ -387,13 +430,13 @@  data Transaction = Transaction TransactionId TransactionInfo Schemas                             ---instance Binary Transaction-                            +-- | The disconnected transaction represents an in-progress workspace used by sessions before changes are committed. This is similar to git's "index". After a transaction is committed, it is "connected" in the transaction graph and can no longer be modified.+data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag+--the database context expression represents a difference between the disconnected transaction and its immutable parent transaction- is this diff expr used at all?+ type DirtyFlag = Bool --- | The disconnected transaction represents an in-progress workspace used by sessions before changes are committed. This is similar to git's "index". After a transaction is committed, it is "connected" in the transaction graph and can no longer be modified.-data DisconnectedTransaction = DisconnectedTransaction TransactionId Schemas DirtyFlag --parentID, context- the context here represents the singular concrete context from the schema---the dirty flag indicates that the database context has diverged from its parent's context+type TransactionDiffExpr = DatabaseContextExpr                              transactionId :: Transaction -> TransactionId transactionId (Transaction tid _ _) = tid@@ -409,24 +452,27 @@  type AtomExpr = AtomExprBase () +type GraphRefAtomExpr = AtomExprBase GraphRefTransactionMarker+ -- | 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 |                       RelationAtomExpr (RelationalExprBase a) |                       ConstructedAtomExpr DataConstructorName [AtomExprBase a] a-                    deriving (Eq,Show,Generic, NFData)+                    deriving (Eq,Show,Generic, NFData, Foldable, Functor, Traversable)                         instance Binary AtomExpr                         -- | Used in tuple creation when creating a relation. data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)-                     deriving (Show, Eq, Generic, NFData)+                     deriving (Show, Eq, Generic, NFData, Foldable, Functor, Traversable)                               -type ExtendTupleExpr = ExtendTupleExprBase ()                              +type ExtendTupleExpr = ExtendTupleExprBase ()+type GraphRefExtendTupleExpr = ExtendTupleExprBase GraphRefTransactionMarker  instance Binary ExtendTupleExpr-           + --enumerates the list of functions available to be run as part of tuple expressions            type AtomFunctions = HS.HashSet AtomFunction @@ -471,9 +517,12 @@                             UnionAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |                             IntersectAttributeNames (AttributeNamesBase a) (AttributeNamesBase a) |                             RelationalExprAttributeNames (RelationalExprBase a) -- use attribute names from the relational expression's type-                      deriving (Eq, Show, Generic, NFData)+                      deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)                                -type AttributeNames = AttributeNamesBase ()                               +type AttributeNames = AttributeNamesBase ()++type GraphRefAttributeNames = AttributeNamesBase GraphRefTransactionMarker+ instance Binary AttributeNames                                  -- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.@@ -483,20 +532,32 @@                            deriving (Show, Read)                                      type AttributeExpr = AttributeExprBase ()+type GraphRefAttributeExpr = AttributeExprBase GraphRefTransactionMarker  -- | Create attributes dynamically. data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |                            NakedAttributeExpr Attribute-                         deriving (Eq, Show, Generic, Binary, NFData)+                         deriving (Eq, Show, Generic, Binary, NFData, Foldable, Functor, Traversable)                                -- | Dynamically create a tuple from attribute names and 'AtomExpr's. newtype TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))-                 deriving (Eq, Show, Generic, NFData)-                          -instance Binary TupleExpr                          +                 deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)                           -type TupleExpr = TupleExprBase ()                           +instance Binary TupleExpr +type TupleExpr = TupleExprBase ()++type GraphRefTupleExpr = TupleExprBase GraphRefTransactionMarker++data TupleExprsBase a = TupleExprs a [TupleExprBase a]+  deriving (Eq, Show, Generic, NFData, Foldable, Functor, Traversable)++type GraphRefTupleExprs = TupleExprsBase GraphRefTransactionMarker++type TupleExprs = TupleExprsBase ()++instance Binary TupleExprs+ data MergeStrategy =    -- | After a union merge, the merge transaction is a result of union'ing relvars of the same name, introducing all uniquely-named relvars, union of constraints, union of atom functions, notifications, and types (unless the names and definitions collide, e.g. two types of the same name with different definitions)   UnionMergeStrategy |@@ -567,4 +628,25 @@ atomTypeVars (RelationAtomType attrs) = S.unions (map attrTypeVars (V.toList 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+instance Binary (TupleExprsBase GraphRefTransactionMarker)++instance Binary (TupleExprBase GraphRefTransactionMarker)++instance Binary GraphRefRelationalExpr ++instance Binary (AtomExprBase GraphRefTransactionMarker)++instance Binary (AttributeNamesBase GraphRefTransactionMarker)++instance Binary (RestrictionPredicateExprBase GraphRefTransactionMarker)++instance Binary (ExtendTupleExprBase GraphRefTransactionMarker)++instance Binary GraphRefWithNameExpr+

src/lib/ProjectM36/Client.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, BangPatterns, MonoLocalBinds #-}+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, MonoLocalBinds #-} {-| Module: ProjectM36.Client @@ -46,8 +46,10 @@        PersistenceStrategy(..),        RelationalExpr,        RelationalExprBase(..),-       DatabaseContextExpr(..),-       DatabaseContextIOExpr(..),+       DatabaseContextExprBase(..),+       DatabaseContextExpr,+       DatabaseContextIOExprBase(..),+       DatabaseContextIOExpr,        Attribute(..),        MergeStrategy(..),        attributesFromList,@@ -97,6 +99,7 @@        AtomType(..),        Atomable(..),        TupleExprBase(..),+       TupleExprsBase(..),        AtomExprBase(..),        RestrictionPredicateExprBase(..),        withTransaction@@ -112,7 +115,6 @@ import ProjectM36.DatabaseContextFunction as DCF import qualified ProjectM36.IsomorphicSchema as Schema import Control.Monad.State-import Control.Monad.Trans.Reader import qualified ProjectM36.RelationalExpression as RE import ProjectM36.DatabaseContext (basicDatabaseContext) import qualified ProjectM36.TransactionGraph as Graph@@ -120,22 +122,24 @@ import qualified ProjectM36.Transaction as Trans import ProjectM36.TransactionGraph.Persist import ProjectM36.Attribute-import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)+import ProjectM36.TransGraphRelationalExpression as TGRE (TransGraphRelationalExpr) import ProjectM36.Persist (DiskSync(..)) import ProjectM36.FileLock+import ProjectM36.NormalizeExpr import ProjectM36.Notifications import ProjectM36.Server.RemoteCallTypes import qualified ProjectM36.DisconnectedTransaction as Discon import ProjectM36.Relation (typesAsRelation) import ProjectM36.ScriptSession (initScriptSession, ScriptSession) import qualified ProjectM36.Relation as R-import qualified ProjectM36.DatabaseContext as DBC import Control.Exception.Base import GHC.Conc.Sync  import Network.Transport (Transport(closeTransport))--#if MIN_VERSION_network_transport_tcp(0,6,0)+#if MIN_VERSION_network_transport_tcp(0,7,0)+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)+import Network.Transport.TCP.Internal (encodeEndPointAddress)+#elif MIN_VERSION_network_transport_tcp(0,6,0) import Network.Transport.TCP (createTransport, defaultTCPParameters) import Network.Transport.TCP.Internal (encodeEndPointAddress) #else@@ -152,7 +156,6 @@ import Control.Exception (IOException, handle, AsyncException, throwIO, fromException, Exception) import Control.Concurrent.MVar import qualified Data.Map as M-import Control.Distributed.Process.Serializable (Serializable) #if MIN_VERSION_stm_containers(1,0,0) import qualified StmContainers.Map as StmMap import qualified StmContainers.Set as StmSet@@ -168,6 +171,7 @@ import Control.DeepSeq (force) import System.IO import Data.Time.Clock+import Data.Typeable  type Hostname = String @@ -269,7 +273,9 @@  createLocalNode :: IO (LocalNode, Transport) createLocalNode = do-#if MIN_VERSION_network_transport_tcp(0,6,0)  +#if MIN_VERSION_network_transport_tcp(0,7,0)+  eLocalTransport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters+#elif MIN_VERSION_network_transport_tcp(0,6,0)     eLocalTransport <- createTransport "127.0.0.1" "0" (\sn -> ("127.0.0.1", sn)) defaultTCPParameters #else   eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters@@ -310,9 +316,9 @@ --create a new in-memory database/transaction graph connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do   freshId <- nextRandom-  stamp <- getCurrentTime+  tstamp <- getCurrentTime   let bootstrapContext = basicDatabaseContext -      freshGraph = bootstrapTransactionGraph stamp freshId bootstrapContext+      freshGraph = bootstrapTransactionGraph tstamp freshId bootstrapContext   case strat of     --create date examples graph for now- probably should be empty context in the future     NoPersistence -> do@@ -405,7 +411,7 @@     let sessions = ipSessions conf         graphTvar = ipTransactionGraph conf     graph <- readTVar graphTvar-    case transactionForId commitId graph of+    case RE.transactionForId commitId graph of         Left err -> pure (Left err)         Right transaction -> do             let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) False@@ -493,7 +499,7 @@     Left (_ :: ServerError) -> pure False     Right val -> pure val -remoteCall :: (Serializable a, Serializable b) => Connection -> a -> IO b+remoteCall :: (Binary a, Binary b, Typeable a, Typeable b) => Connection -> a -> IO b remoteCall (InProcessConnection _ ) _ = error "remoteCall called on local connection" remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do   ret <- safeCall serverProcessId arg@@ -568,13 +574,14 @@                     Right expr       case expr' of         Left err -> pure (Left err)-        Right expr'' -> case optimizeRelationalExpr (Sess.concreteDatabaseContext session) expr'' of-          Left err -> pure (Left err)-          Right optExpr -> do-            let evald = runReader (RE.evalRelationalExpr optExpr) (RE.mkRelationalExprState (Sess.concreteDatabaseContext session))-            case evald of-              Left err -> pure (Left err)-              Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here +        Right expr'' -> do+          let graphTvar = ipTransactionGraph conf+          graph <- readTVar graphTvar+          let reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) graph+          case optimizeAndEvalRelationalExpr reEnv expr'' of+            Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here +            Left err -> pure (Left err)+ executeRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)  -- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.@@ -591,21 +598,24 @@                     Schema.processDatabaseContextExprInSchema schema expr       case expr' of          Left err -> pure (Left err)-        Right expr'' -> case runState (do-                                          eOptExpr <- applyStaticDatabaseOptimization expr''-                                          case eOptExpr of-                                            Left err -> pure (Left err)-                                            Right optExpr ->-                                              RE.evalDatabaseContextExpr optExpr) (RE.freshDatabaseState (Sess.concreteDatabaseContext session)) of-          (Left err,_) -> pure (Left err)-          (Right (), (_,_,False)) -> pure (Right ()) --optimization- if nothing was dirtied, nothing to do-          (Right (), (!context',_,True)) -> do-            let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True-                newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr-                newSchemas = Schemas context' newSubschemas-                newSession = Session newDiscon (Sess.schemaName session)-            StmMap.insert newSession sessionId sessions-            pure (Right ())+        Right expr'' -> do+          graph <- readTVar (ipTransactionGraph conf)+          let ctx = Sess.concreteDatabaseContext session+              env = RE.mkDatabaseContextEvalEnv transId graph+              transId = Sess.parentId session+          case RE.runDatabaseContextEvalMonad ctx env (optimizeAndEvalDatabaseContextExpr True expr'') of+            Left err -> pure (Left err)+            Right newState ->+              if not (RE.dbc_dirty newState) then --nothing dirtied, nothing to do+                pure (Right ())+              else do+                let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True+                    context' = RE.dbc_context newState+                    newSubschemas = Schema.processDatabaseContextExprSchemasUpdate (Sess.subschemas session) expr+                    newSchemas = Schemas context' newSubschemas+                    newSession = Session newDiscon (Sess.schemaName session)+                StmMap.insert newSession sessionId sessions+                pure (Right ()) executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)  -- | Similar to a git rebase, 'autoMergeToHead' atomically creates a temporary branch and merges it to the latest commit of the branch referred to by the 'HeadName' and commits the merge. This is useful to reduce incidents of 'TransactionIsNotAHeadError's but at the risk of merge errors (thus making it similar to rebasing). Alternatively, as an optimization, if a simple commit is possible (meaning that the head has not changed), then a fast-forward commit takes place instead.@@ -615,7 +625,7 @@   id1 <- nextRandom   id2 <- nextRandom   id3 <- nextRandom-  stamp <- getCurrentTime+  tstamp <- getCurrentTime   commitLock_ sessionId conf $ \graph -> do     eSession <- sessionForSessionId sessionId sessions       case eSession of@@ -626,10 +636,10 @@           Just headTrans -> do             --attempt fast-forward commit, if possible             let graphInfo = if Sess.parentId session == transactionId headTrans then do-                              ret <- Graph.evalGraphOp stamp id1 (Sess.disconnectedTransaction session) graph Commit+                              ret <- Graph.evalGraphOp tstamp id1 (Sess.disconnectedTransaction session) graph Commit                               pure (ret, [id1])                             else do-                              ret <- Graph.autoMergeToHead stamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph +                              ret <- Graph.autoMergeToHead tstamp (id1, id2, id3) (Sess.disconnectedTransaction session) headName' strat graph                                pure (ret, [id1,id2,id3])             case graphInfo of               Left err -> pure (Left err)@@ -647,13 +657,18 @@   case eSession of     Left err -> pure (Left err)     Right session -> do-      res <- RE.evalDatabaseContextIOExpr scriptSession (Sess.concreteDatabaseContext session) expr+      graph <- readTVarIO (ipTransactionGraph conf)+      let env = RE.DatabaseContextIOEvalEnv transId graph scriptSession+          transId = Sess.parentId session+          context = Sess.concreteDatabaseContext session+      res <- RE.runDatabaseContextIOEvalMonad env context (optimizeAndEvalDatabaseContextIOExpr expr)       case res of         Left err -> pure (Left err)-        Right context' -> do-          let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True+        Right newState -> do+          let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas False               newSchemas = Schemas context' (Sess.subschemas session)               newSession = Session newDiscon (Sess.schemaName session)+              context' = RE.dbc_context newState           atomically $ StmMap.insert newSession sessionId sessions           pure (Right ()) executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)@@ -673,12 +688,18 @@ -}    -- process notifications for commits-executeCommitExprSTM_ :: DatabaseContext -> DatabaseContext -> ClientNodes -> STM (EvaluatedNotifications, ClientNodes)-executeCommitExprSTM_ oldContext newContext nodes = do+executeCommitExprSTM_+  :: TransactionGraph+  -> DatabaseContext+  -> DatabaseContext+  -> ClientNodes+  -> STM (EvaluatedNotifications, ClientNodes)+executeCommitExprSTM_ graph oldContext newContext nodes = do   let nots = notifications oldContext-      fireNots = notificationChanges nots oldContext newContext +      fireNots = notificationChanges nots graph oldContext newContext        evaldNots = M.map mkEvaldNot fireNots-      evalInContext expr ctx = runReader (RE.evalRelationalExpr expr) (RE.mkRelationalExprState ctx)+      evalInContext expr ctx = optimizeAndEvalRelationalExpr (RE.mkRelationalExprEnv ctx graph) expr+        mkEvaldNot notif = EvaluatedNotification { notification = notif,                                                   reportOldRelation = evalInContext (reportOldExpr notif) oldContext,                                                  reportNewRelation = evalInContext (reportNewExpr notif) newContext}@@ -693,18 +714,18 @@ executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do   let sessions = ipSessions conf   freshId <- nextRandom-  stamp <- getCurrentTime+  tstamp <- getCurrentTime   commitLock_ sessionId conf $ \updatedGraph -> do     eSession <- sessionForSessionId sessionId sessions     case eSession of       Left err -> pure (Left err)       Right session -> do         let discon = Sess.disconnectedTransaction session-        case evalGraphOp stamp freshId discon updatedGraph graphExpr of+        case evalGraphOp tstamp freshId discon updatedGraph graphExpr of           Left err -> pure (Left err)           Right (discon', graph') -> do             --if freshId appears in the graph, then we need to pass it on-            let transIds = [freshId | isRight (transactionForId freshId graph')]+            let transIds = [freshId | isRight (RE.transactionForId freshId graph')]             pure (Right (discon', graph', transIds)) {- executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excEither $ do@@ -784,11 +805,10 @@ executeTransGraphRelationalExpr _ (InProcessConnection conf) tgraphExpr = excEither . atomically $ do   let graphTvar = ipTransactionGraph conf   graph <- readTVar graphTvar-  case evalTransGraphRelationalExpr tgraphExpr graph of-    Left err -> pure (Left err)-    Right relExpr -> case runReader (RE.evalRelationalExpr relExpr) (RE.mkRelationalExprState DBC.empty) of+  pure $ force $ optimizeAndEvalTransGraphRelationalExpr graph tgraphExpr+{-  case runReader (RE.evalRelationalExpr relExpr) (RE.mkRelationalExprState DBC.empty) of       Left err -> pure (Left err)-      Right rel -> pure (force (Right rel))+      Right rel -> pure (force (Right rel))-} executeTransGraphRelationalExpr sessionId conn@(RemoteProcessConnection _) tgraphExpr = remoteCall conn (ExecuteTransGraphRelationalExpr sessionId tgraphExpr)    -- | Schema expressions manipulate the isomorphic schemas for the current 'DatabaseContext'.@@ -800,13 +820,16 @@     Left err -> pure (Left err)     Right (session, _) -> do       let subschemas' = subschemas session-      case Schema.evalSchemaExpr schemaExpr (Sess.concreteDatabaseContext session) subschemas' of+          transId = Sess.parentId session+          context = Sess.concreteDatabaseContext session+      graph <- readTVar (ipTransactionGraph conf)+      case Schema.evalSchemaExpr schemaExpr context transId graph subschemas' of         Left err -> pure (Left err)         Right (newSubschemas, newContext) -> do           --hm- maybe we should start using lenses           let discon = Sess.disconnectedTransaction session                newSchemas = Schemas newContext newSubschemas-              newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas True) (Sess.schemaName session)+              newSession = Session (DisconnectedTransaction (Discon.parentId discon) newSchemas False) (Sess.schemaName session)           StmMap.insert newSession sessionId sessions           pure (Right ()) executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)          @@ -856,7 +879,10 @@                        Schema.processRelationalExprInSchema schema relExpr       case processed of         Left err -> pure (Left err)-        Right relExpr' -> pure $ runReader (RE.typeForRelationalExpr relExpr') (RE.mkRelationalExprState (Sess.concreteDatabaseContext session))+        Right relExpr' -> do+          graph <- readTVar (ipTransactionGraph conf)          +          let reEnv = RE.mkRelationalExprEnv (Sess.concreteDatabaseContext session) graph+          pure $ RE.runRelationalExprM reEnv (RE.typeForRelationalExpr relExpr')       typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection" @@ -889,17 +915,22 @@ typeConstructorMapping sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId)    -- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated.-planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError DatabaseContextExpr)  +planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError GraphRefDatabaseContextExpr)   planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do   let sessions = ipSessions conf   atomically $ do+    graph <- readTVar (ipTransactionGraph conf)         eSession <- sessionAndSchema sessionId sessions     case eSession of       Left err -> pure $ Left err -      Right (session, _) -> if schemaName session == defaultSchemaName then-                                   pure $ evalState (applyStaticDatabaseOptimization dbExpr) (RE.freshDatabaseState (Sess.concreteDatabaseContext session))-                                 else -- don't show any optimization because the current optimization infrastructure relies on access to the base context- this probably underscores the need for each schema to have its own DatabaseContext, even if it is generated on-the-fly-                                   pure (Right dbExpr)+      Right (session, _) ->+        if schemaName session == defaultSchemaName then do+          let ctx = Sess.concreteDatabaseContext session+              transId = Sess.parentId session+              gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr dbExpr)+          pure $ runGraphRefSOptDatabaseContextExprM transId ctx graph (optimizeGraphRefDatabaseContextExpr gfExpr)+        else -- don't show any optimization because the current optimization infrastructure relies on access to the base context- this probably underscores the need for each schema to have its own DatabaseContext, even if it is generated on-the-fly-}+          pure (Left NonConcreteSchemaPlanError)  planForDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)              @@ -926,17 +957,20 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do   let sessions = ipSessions conf   atomically $ do+    graph <- readTVar (ipTransactionGraph conf)     eSession <- sessionAndSchema sessionId sessions     case eSession of       Left err -> pure (Left err)       Right (session, schema) -> do         let context = Sess.concreteDatabaseContext session         if Sess.schemaName session == defaultSchemaName then-          pure $ R.relationVariablesAsRelation (relationVariables context)+          pure $ RE.relationVariablesAsRelation context graph           else-          case Schema.relationVariablesInSchema schema context of+          case Schema.relationVariablesInSchema schema of             Left err -> pure (Left err)-            Right relvars -> pure $ R.relationVariablesAsRelation relvars+            Right relvars -> do+              let schemaContext = context {relationVariables = relvars }+              pure $ RE.relationVariablesAsRelation schemaContext graph         relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId) @@ -982,7 +1016,7 @@     eSession <- sessionForSessionId sessionId sessions     case eSession of       Left err -> pure (Left err)-      Right session -> case transactionForId (Sess.parentId session) graph of+      Right session -> case RE.transactionForId (Sess.parentId session) graph of         Left err -> pure (Left err)         Right parentTrans -> case headNameForTransaction parentTrans graph of           Nothing -> pure (Left UnknownHeadError)@@ -1094,11 +1128,11 @@                 writeTVar graphTvar graph'                 let newSession = Session discon' (Sess.schemaName session)                 StmMap.insert newSession sessionId sessions-                case transactionForId (Sess.parentId session) oldGraph of+                case RE.transactionForId (Sess.parentId session) oldGraph of                   Left err -> pure $ Left err                   Right previousTrans ->                     if not (Prelude.null transactionIdsToPersist) then do-                      (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes+                      (evaldNots, nodes) <- executeCommitExprSTM_ graph' (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes                       nodesToNotify <- stmSetToList nodes                       pure $ Right (evaldNots, nodesToNotify, graph', transactionIdsToPersist)                     else pure (Right (M.empty, [], graph', []))@@ -1159,7 +1193,10 @@       case verified of         Left err -> pure (Left err)         Right attrs -> do-          let attrOrders = map (\(attr',order') -> DF.AttributeOrder (attributeName attr') order') (zip attrs orders)+          let attrOrders = zipWith+                            (DF.AttributeOrder . attributeName)+                           attrs+                           orders           case DF.sortDataFrameBy attrOrders . DF.toDataFrame $ rel of             Left err -> pure (Left err)             Right dFrame -> do

src/lib/ProjectM36/Client/Simple.hs view

@@ -25,7 +25,8 @@   C.PersistenceStrategy(..),   C.NotificationCallback,   C.emptyNotificationCallback,-  C.DatabaseContextExpr(..),+  C.DatabaseContextExprBase(..),+  C.DatabaseContextExpr,     C.RelationalExprBase(..)   ) where

src/lib/ProjectM36/DatabaseContext.hs view

@@ -1,5 +1,6 @@ module ProjectM36.DatabaseContext where import ProjectM36.Base+import Control.Monad (void) import qualified Data.Map as M import qualified Data.HashSet as HS import ProjectM36.DataTypes.Basic@@ -14,20 +15,24 @@                           atomFunctions = HS.empty,                           dbcFunctions = HS.empty,                           typeConstructorMapping = [] }++-- | Remove TransactionId markers on GraphRefRelationalExpr+stripGraphRefRelationalExpr :: GraphRefRelationalExpr -> RelationalExpr+stripGraphRefRelationalExpr = void          -- | convert an existing database context into its constituent expression.    databaseContextAsDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr databaseContextAsDatabaseContextExpr context = MultipleExpr $ relVarsExprs ++ incDepsExprs ++ funcsExprs   where-    relVarsExprs = map (\(name, rel) -> Assign name (ExistingRelation rel)) (M.toList (relationVariables context))+    relVarsExprs = map (\(name, rel) -> Assign name (stripGraphRefRelationalExpr rel)) (M.toList (relationVariables context))     incDepsExprs :: [DatabaseContextExpr]     incDepsExprs = map (uncurry AddInclusionDependency) (M.toList (inclusionDependencies context))-    funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet+    funcsExprs = [] -- map (\func -> ) (HS.toList funcs) -- there are no databaseExprs to add atom functions yet-}  basicDatabaseContext :: DatabaseContext basicDatabaseContext = DatabaseContext { inclusionDependencies = M.empty,-                                         relationVariables = M.fromList [("true", relationTrue),-                                                                         ("false", relationFalse)],+                                         relationVariables = M.fromList [("true", ExistingRelation relationTrue),+                                                                         ("false", ExistingRelation relationFalse)],                                          atomFunctions = basicAtomFunctions,                                          dbcFunctions = basicDatabaseContextFunctions,                                          notifications = M.empty,

src/lib/ProjectM36/DatabaseContextFunction.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module ProjectM36.DatabaseContextFunction where --implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr import ProjectM36.Base@@ -61,7 +62,11 @@ 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  databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups

src/lib/ProjectM36/DatabaseContextFunctionUtils.hs view

@@ -3,13 +3,20 @@ import ProjectM36.Base import ProjectM36.DatabaseContextFunctionError import ProjectM36.Error-import Control.Monad.State-import Control.Monad.Trans.Reader+import ProjectM36.StaticOptimizer -executeDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext-executeDatabaseContextExpr expr context = case runState (evalDatabaseContextExpr expr) (freshDatabaseState context) of-  (Right (), (context', _, _)) -> pure context'-  (Left err, _) -> error (show err)+executeDatabaseContextExpr :: DatabaseContextExpr -> TransactionId -> TransactionGraph -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext+executeDatabaseContextExpr expr transId graph context' =+  case run of+    Right st -> pure (dbc_context st)+    Left err -> error (show err)+  where+    env = mkDatabaseContextEvalEnv transId graph+    run = runDatabaseContextEvalMonad context' env (optimizeAndEvalDatabaseContextExpr True expr)   -executeRelationalExpr :: RelationalExpr -> DatabaseContext -> Either RelationalError Relation-executeRelationalExpr expr context = runReader (evalRelationalExpr expr) (mkRelationalExprState context)+executeRelationalExpr :: RelationalExpr -> DatabaseContext -> TransactionGraph -> Either RelationalError Relation+executeRelationalExpr expr context graph =+  run+  where+    env = mkRelationalExprEnv context graph+    run = optimizeAndEvalRelationalExpr env expr

src/lib/ProjectM36/DateExamples.hs view

@@ -16,9 +16,9 @@                                  atomFunctions = basicAtomFunctions,                                  typeConstructorMapping = basicTypeConstructorMapping }   where -- these must be lower case now that data constructors are in play-    dateRelVars = M.fromList [("s", suppliers),-                              ("p", products),-                              ("sp", supplierProducts)]+    dateRelVars = M.fromList [("s", ExistingRelation suppliers),+                              ("p", ExistingRelation products),+                              ("sp", ExistingRelation supplierProducts)]     suppliers = suppliersRel     products = productsRel     supplierProducts = supplierProductsRel

src/lib/ProjectM36/DisconnectedTransaction.hs view

@@ -9,3 +9,9 @@  parentId :: DisconnectedTransaction -> TransactionId parentId (DisconnectedTransaction pid _ _) = pid++isDirty :: DisconnectedTransaction -> Bool+isDirty (DisconnectedTransaction _ _ flag) = flag++freshTransaction :: TransactionId -> Schemas -> DisconnectedTransaction+freshTransaction tid schemas' = DisconnectedTransaction tid schemas' False

src/lib/ProjectM36/Error.hs view

@@ -96,6 +96,11 @@                      | SchemaCreationError SchemaError                                               | ImproperDatabaseStateError++                     | NonConcreteSchemaPlanError++                     | NoUncommittedContextInEvalError+                     | TupleExprsReferenceMultipleMarkersError                                              | MultipleErrors [RelationalError]                        deriving (Show,Eq,Generic,Binary,Typeable, NFData)

+ src/lib/ProjectM36/GraphRefRelationalExpr.hs view

@@ -0,0 +1,45 @@+module ProjectM36.GraphRefRelationalExpr where+--evaluate relational expressions across the entire transaction graph to support cross-transaction referencing+import ProjectM36.Base+import qualified Data.Set as S++--import Debug.Trace++data SingularTransactionRef = SingularTransactionRef GraphRefTransactionMarker |+                              MultipleTransactionsRef |+                              NoTransactionsRef+                              deriving (Eq, Show)++instance Semigroup SingularTransactionRef where+  NoTransactionsRef <> x = x+  MultipleTransactionsRef <> _ = MultipleTransactionsRef+  SingularTransactionRef tidA <> s@(SingularTransactionRef tidB) =+    if tidA == tidB then+      s+    else+      MultipleTransactionsRef+  s@SingularTransactionRef{} <> NoTransactionsRef = s+  _ <> MultipleTransactionsRef = MultipleTransactionsRef++instance Monoid SingularTransactionRef where+  mempty = NoTransactionsRef+  +-- | 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++-- | Return True if two 'GraphRefRelationalExpr's both refer exclusively to the same transaction (or none at all).+inSameTransaction :: GraphRefRelationalExpr -> GraphRefRelationalExpr -> Maybe GraphRefTransactionMarker+inSameTransaction exprA exprB = case (stA, stB) of+  (SingularTransactionRef tA, SingularTransactionRef tB) | tA == tB -> Just tA+  _ -> Nothing+  where stA = singularTransaction exprA+        stB = singularTransaction exprB++singularTransactions :: (Foldable f, Foldable t) => f (t GraphRefTransactionMarker) -> SingularTransactionRef+singularTransactions = foldMap singularTransaction

src/lib/ProjectM36/IsomorphicSchema.hs view

@@ -3,12 +3,11 @@ import ProjectM36.Base import ProjectM36.Error import ProjectM36.MiscUtils-import ProjectM36.RelationalExpression import ProjectM36.Relation+import ProjectM36.NormalizeExpr+import ProjectM36.RelationalExpression import qualified ProjectM36.AttributeNames as AN import Control.Monad-import Control.Monad.State-import Control.Monad.Trans.Reader import GHC.Generics import Data.Binary import qualified Data.Map as M@@ -256,15 +255,15 @@ 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 -> DatabaseContext -> Either RelationalError RelationVariables-relationVariablesInSchema schema@(Schema morphs) context = foldM transform M.empty morphs+relationVariablesInSchema :: Schema -> Either RelationalError RelationVariables+relationVariablesInSchema schema@(Schema morphs) = foldM transform M.empty morphs   where     transform newRvMap morph = do       let rvNames = isomorphInRelVarNames morph       rvAssocs <- mapM (\rv -> do                            expr' <- processRelationalExprInSchema schema (RelationVariable rv ())-                           rel <- runReader (evalRelationalExpr expr') (RelationalExprStateElems context)-                           pure (rv, rel)) rvNames+                           let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr')+                           pure (rv, gfExpr)) rvNames       pure (M.union newRvMap (M.fromList rvAssocs))  @@ -312,24 +311,24 @@ createIncDepsForIsomorph _ _ = M.empty  -- in the case of IsoRestrict, the database context should be updated with the restriction so that if the restriction does not hold, then the schema cannot be created-evalSchemaExpr :: SchemaExpr -> DatabaseContext -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext)-evalSchemaExpr (AddSubschema sname morphs) context sschemas =+evalSchemaExpr :: SchemaExpr -> DatabaseContext -> TransactionId -> TransactionGraph -> Subschemas -> Either RelationalError (Subschemas, DatabaseContext)+evalSchemaExpr (AddSubschema sname morphs) context transId graph sschemas =   if M.member sname sschemas then     Left (SubschemaNameInUseError sname)-    else case valid of-    Just err -> Left (SchemaCreationError err)-    Nothing -> -      let newSchemas = M.insert sname newSchema sschemas-          moreIncDeps = foldr (\morph acc -> M.union acc (createIncDepsForIsomorph sname morph)) M.empty morphs-          incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps))-      in-      case runState (evalDatabaseContextExpr incDepExprs) (context, M.empty, False) of-        (Left err, _) -> Left err-        (Right (), (newContext,_,_)) -> pure (newSchemas, newContext) --need to propagate dirty flag here-  where-    newSchema = Schema morphs-    valid = validateSchema newSchema context-evalSchemaExpr (RemoveSubschema sname) context sschemas = if M.member sname sschemas then+    else+    case validateSchema (Schema morphs) context of+      Just err -> Left (SchemaCreationError err)+      Nothing -> do+        let newSchemas = M.insert sname newSchema sschemas+            newSchema = Schema morphs+            moreIncDeps = foldr (\morph acc -> M.union acc (createIncDepsForIsomorph sname morph)) M.empty morphs+            incDepExprs = MultipleExpr (map (uncurry AddInclusionDependency) (M.toList moreIncDeps))+            dbenv = mkDatabaseContextEvalEnv transId graph+        dbstate <- runDatabaseContextEvalMonad context dbenv (evalGraphRefDatabaseContextExpr incDepExprs)+        pure (newSchemas, dbc_context dbstate)+--need to propagate dirty flag here      ++evalSchemaExpr (RemoveSubschema sname) context _ _ sschemas = if M.member sname sschemas then                                            pure (M.delete sname sschemas, context)                                          else                                            Left (SubschemaNameNotInUseError sname)

+ src/lib/ProjectM36/NormalizeExpr.hs view

@@ -0,0 +1,132 @@+-- | Functions to convert all types of expresions into their GraphRef- equivalents.+module ProjectM36.NormalizeExpr where+import ProjectM36.Base+import Control.Monad.Trans.Reader as R+import qualified Data.Map as M++--used to process/normalize exprs to their respective graph ref forms+type ProcessExprM a = Reader GraphRefTransactionMarker a++type CurrentTransactionId = TransactionId++runProcessExprM :: GraphRefTransactionMarker -> ProcessExprM a -> a+runProcessExprM mtid m = runReader m mtid++askMarker :: ProcessExprM GraphRefTransactionMarker+askMarker = R.ask++-- convert a RelationalExpr into a GraphRefRelationalExpr using the current trans Id+processRelationalExpr :: RelationalExpr -> ProcessExprM GraphRefRelationalExpr+processRelationalExpr (MakeRelationFromExprs mAttrs tupleExprs) = do+  mAttrs' <- case mAttrs of+                  Nothing -> pure Nothing+                  Just mAttrs'' -> Just <$> mapM processAttributeExpr mAttrs''+  MakeRelationFromExprs mAttrs' <$> processTupleExprs tupleExprs+processRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)+processRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)+--requires current trans id and graph+processRelationalExpr (RelationVariable rv ()) = RelationVariable rv <$> askMarker+processRelationalExpr (Project attrNames expr) = Project <$> processAttributeNames attrNames <*> processRelationalExpr expr+processRelationalExpr (Union exprA exprB) = Union <$> processRelationalExpr exprA <*> processRelationalExpr exprB+processRelationalExpr (Join exprA exprB) = Join <$> processRelationalExpr exprA <*> processRelationalExpr exprB+processRelationalExpr (Rename attrA attrB expr) =+  Rename attrA attrB <$> processRelationalExpr expr+processRelationalExpr (Difference exprA exprB) = Difference <$> processRelationalExpr exprA <*> processRelationalExpr exprB+processRelationalExpr (Group attrNames attrName expr) = Group <$> processAttributeNames attrNames <*> pure attrName <*> processRelationalExpr expr+processRelationalExpr (Ungroup attrName expr) = Ungroup attrName <$> processRelationalExpr expr+processRelationalExpr (Restrict pred' expr) = Restrict <$> processRestrictionPredicateExpr pred' <*> processRelationalExpr expr+processRelationalExpr (Equals exprA exprB) =+  Equals <$> processRelationalExpr exprA <*> processRelationalExpr exprB+processRelationalExpr (NotEquals exprA exprB) =   +  NotEquals <$> processRelationalExpr exprA <*> processRelationalExpr exprB+processRelationalExpr (Extend extendExpr expr) =+  Extend <$> processExtendTupleExpr extendExpr <*> processRelationalExpr expr+processRelationalExpr (With macros expr) =+  With <$> mapM (\(wnexpr, macroExpr) -> (,) <$> processWithNameExpr wnexpr <*> processRelationalExpr macroExpr) macros <*> processRelationalExpr expr++processWithNameExpr :: WithNameExpr -> ProcessExprM GraphRefWithNameExpr+processWithNameExpr (WithNameExpr rvname ()) =+  WithNameExpr rvname <$> askMarker++processAttributeNames :: AttributeNames -> ProcessExprM GraphRefAttributeNames+processAttributeNames (AttributeNames nameSet) = pure $ AttributeNames nameSet+processAttributeNames (InvertedAttributeNames attrNameSet) =+  pure $ InvertedAttributeNames attrNameSet+processAttributeNames (UnionAttributeNames attrNamesA attrNamesB) = UnionAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB+processAttributeNames (IntersectAttributeNames attrNamesA attrNamesB) = IntersectAttributeNames <$> processAttributeNames attrNamesA <*> processAttributeNames attrNamesB+processAttributeNames (RelationalExprAttributeNames expr) = RelationalExprAttributeNames <$> processRelationalExpr expr++processDatabaseContextExpr :: DatabaseContextExpr -> ProcessExprM GraphRefDatabaseContextExpr+processDatabaseContextExpr expr =+  case expr of+    NoOperation -> pure NoOperation+    Define nam attrExprs -> Define nam <$> mapM processAttributeExpr attrExprs+    Undefine nam -> pure (Undefine nam)+    Assign nam rexpr -> Assign nam <$> processRelationalExpr rexpr+    Insert nam rexpr -> Insert nam <$> processRelationalExpr rexpr+    Delete nam pred' -> Delete nam <$> processRestrictionPredicateExpr pred'+    Update nam attrMap pred' -> Update nam attrMap <$> processRestrictionPredicateExpr pred'++    AddInclusionDependency nam dep -> pure (AddInclusionDependency nam dep)+    RemoveInclusionDependency nam -> pure (RemoveInclusionDependency nam)+    AddNotification nam exprA exprB exprC -> pure (AddNotification nam exprA exprB exprC)+    RemoveNotification nam -> pure (RemoveNotification nam)+    AddTypeConstructor tyDef consDefs -> pure (AddTypeConstructor tyDef consDefs)+    RemoveTypeConstructor tyName -> pure (RemoveTypeConstructor tyName)++    RemoveAtomFunction aFuncName -> pure (RemoveAtomFunction aFuncName)+    RemoveDatabaseContextFunction funcName -> pure (RemoveDatabaseContextFunction funcName)+    ExecuteDatabaseContextFunction funcName atomExprs -> ExecuteDatabaseContextFunction funcName <$> mapM processAtomExpr atomExprs+    MultipleExpr exprs -> MultipleExpr <$> mapM processDatabaseContextExpr exprs++processDatabaseContextIOExpr :: DatabaseContextIOExpr -> ProcessExprM GraphRefDatabaseContextIOExpr+processDatabaseContextIOExpr (AddAtomFunction f tcs sc) =+  pure (AddAtomFunction f tcs sc)+processDatabaseContextIOExpr (LoadAtomFunctions mod' fun file) =+  pure (LoadAtomFunctions mod' fun file)+processDatabaseContextIOExpr (AddDatabaseContextFunction mod' fun path) =+  pure (AddDatabaseContextFunction mod' fun path)+processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod' fun path) =+  pure (LoadDatabaseContextFunctions mod' fun path)+processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =+  CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range+  +processRestrictionPredicateExpr :: RestrictionPredicateExpr -> ProcessExprM GraphRefRestrictionPredicateExpr+processRestrictionPredicateExpr TruePredicate = pure TruePredicate+processRestrictionPredicateExpr (AndPredicate a b) = AndPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b+processRestrictionPredicateExpr (OrPredicate a b) = OrPredicate <$> processRestrictionPredicateExpr a <*> processRestrictionPredicateExpr b+processRestrictionPredicateExpr (NotPredicate a) = NotPredicate <$> processRestrictionPredicateExpr a+processRestrictionPredicateExpr (RelationalExprPredicate expr) =+  RelationalExprPredicate <$> processRelationalExpr expr+processRestrictionPredicateExpr (AtomExprPredicate expr) =+  AtomExprPredicate <$> processAtomExpr expr+processRestrictionPredicateExpr (AttributeEqualityPredicate nam expr) =+  AttributeEqualityPredicate nam <$> processAtomExpr expr++processExtendTupleExpr :: ExtendTupleExpr -> ProcessExprM GraphRefExtendTupleExpr+processExtendTupleExpr (AttributeExtendTupleExpr nam atomExpr) =+  AttributeExtendTupleExpr nam <$> processAtomExpr atomExpr++processAtomExpr :: AtomExpr -> ProcessExprM GraphRefAtomExpr+processAtomExpr (AttributeAtomExpr nam) = pure $ AttributeAtomExpr nam+processAtomExpr (NakedAtomExpr atom) = pure $ NakedAtomExpr atom+processAtomExpr (FunctionAtomExpr fName atomExprs ()) =+  FunctionAtomExpr fName <$> mapM processAtomExpr atomExprs  <*> askMarker+processAtomExpr (RelationAtomExpr expr) = RelationAtomExpr <$> processRelationalExpr expr+processAtomExpr (ConstructedAtomExpr dConsName atomExprs ()) = ConstructedAtomExpr dConsName <$> mapM processAtomExpr atomExprs <*> askMarker++processTupleExprs :: TupleExprs -> ProcessExprM GraphRefTupleExprs+processTupleExprs (TupleExprs () tupleExprs) = do+  marker <- askMarker+  TupleExprs marker <$> mapM processTupleExpr tupleExprs+  +processTupleExpr :: TupleExpr -> ProcessExprM GraphRefTupleExpr+processTupleExpr (TupleExpr tMap) =+  TupleExpr . M.fromList <$> mapM (\(k,v) -> (,) k <$> processAtomExpr v) (M.toList tMap)++--convert AttributeExpr to GraphRefAttributeExpr+processAttributeExpr :: AttributeExpr -> ProcessExprM GraphRefAttributeExpr+processAttributeExpr (AttributeAndTypeNameExpr nam tCons ()) =+  AttributeAndTypeNameExpr nam tCons <$> askMarker+processAttributeExpr (NakedAttributeExpr attr) = pure $ NakedAttributeExpr attr+

src/lib/ProjectM36/Notifications.hs view

@@ -1,17 +1,22 @@ module ProjectM36.Notifications where import ProjectM36.Base+import ProjectM36.Error import ProjectM36.RelationalExpression-import Control.Monad.Trans.Reader+import ProjectM36.StaticOptimizer import qualified Data.Map as M import Data.Either (isRight)  -- | Returns the notifications which should be triggered based on the transition from the first 'DatabaseContext' to the second 'DatabaseContext'.-notificationChanges :: Notifications -> DatabaseContext -> DatabaseContext -> Notifications-notificationChanges nots context1 context2 = M.filter notificationFilter nots+notificationChanges :: Notifications -> TransactionGraph -> DatabaseContext -> DatabaseContext -> Notifications+notificationChanges nots graph context1 context2 = M.filter notificationFilter nots   where-    notificationFilter (Notification chExpr _ _) = let oldChangeEval = evalChangeExpr chExpr (RelationalExprStateElems context1)-                                                       newChangeEval = evalChangeExpr chExpr (RelationalExprStateElems context2) in-                                                 oldChangeEval /= newChangeEval && isRight oldChangeEval-    evalChangeExpr chExpr = runReader (evalRelationalExpr chExpr)+    notificationFilter (Notification chExpr _ _) = oldChangeEval /= newChangeEval && isRight oldChangeEval+      where+        oldChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context1 graph)+        newChangeEval = evalChangeExpr chExpr (mkRelationalExprEnv context2 graph)++    evalChangeExpr :: RelationalExpr -> RelationalExprEnv -> Either RelationalError Relation                                     +    evalChangeExpr chExpr env =+      optimizeAndEvalRelationalExpr env chExpr

src/lib/ProjectM36/Relation.hs view

@@ -4,8 +4,6 @@ import qualified Data.HashSet as HS import Control.Monad import qualified Data.Vector as V-import qualified Data.Map as M-import ProjectM36.AtomType import ProjectM36.Base import ProjectM36.Tuple import qualified ProjectM36.Attribute as A@@ -97,7 +95,7 @@   where     newtuples = RelationTupleSet $ HS.toList . HS.fromList $ asList tupSet1 ++ map (reorderTuple attrs1) (asList tupSet2)       -project :: S.Set AttributeName -> Relation -> Either RelationalError Relation      +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@@ -304,20 +302,6 @@     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)       Right rel -> RelationAtom rel---- | Return a Relation describing the relation variables.-relationVariablesAsRelation :: M.Map RelVarName Relation -> Either RelationalError Relation-relationVariablesAsRelation relVarMap = mkRelationFromList attrs tups-  where-    subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]-    attrs = A.attributesFromList [Attribute "name" TextAtomType,-                                  Attribute "attributes" (RelationAtomType subrelAttrs)]-    tups = map relVarToAtomList (M.toList relVarMap)-    relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]-    attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of-      Left err -> error ("relationVariablesAsRelation pooped " ++ show err)-      Right rel -> RelationAtom rel-    attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]        -- | Randomly resort the tuples. This is useful for emphasizing that two relations are equal even when they are printed to the console in different orders. randomizeTupleOrder :: MonadRandom m => Relation -> m Relation

src/lib/ProjectM36/RelationalExpression.hs view

@@ -1,1002 +1,1529 @@ {-# LANGUAGE ScopedTypeVariables #-}-module ProjectM36.RelationalExpression where-import ProjectM36.Relation-import ProjectM36.Tuple-import ProjectM36.TupleSet-import ProjectM36.Base-import ProjectM36.Error-import ProjectM36.AtomType-import ProjectM36.Attribute (emptyAttributes)-import ProjectM36.ScriptSession-import ProjectM36.DataTypes.Primitive-import ProjectM36.AtomFunction-import ProjectM36.DatabaseContextFunction-import ProjectM36.Arbitrary-import qualified ProjectM36.Attribute as A-import qualified Data.Map as M-import qualified Data.HashSet as HS-import qualified Data.Set as S-import Control.Monad.State hiding (join)-import Control.Exception-import Data.Maybe-import Data.Either-import Data.Char (isUpper)-import qualified Data.Text as T-import qualified Data.Vector as V-import qualified ProjectM36.TypeConstructorDef as TCD-import Control.Monad.Trans.Except-import Control.Monad.Trans.Reader-import Test.QuickCheck-import GHC-import GHC.Paths--data DatabaseContextExprDetails = CountUpdatedTuples--databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc-databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups-  where-    attrs = A.attributesFromList [Attribute "count" IntAtomType]-    existingTuple = fromMaybe (error "impossible counting error in singletonTuple") (singletonTuple relIn)-    existingCount = case V.head (tupleAtoms existingTuple) of-      IntAtom v -> v-      _ -> error "impossible counting error in tupleAtoms"-    newTups = case mkTupleSetFromList attrs [[IntAtom (existingCount + 1)]] of-      Left err -> error ("impossible counting error in " ++ show err)-      Right ts -> ts-      --- | Used to start a fresh database state for a new database context expression.-freshDatabaseState :: DatabaseContext -> DatabaseStateElems-freshDatabaseState ctx = (ctx, M.empty, False) --future work: propagate return accumulator---- we need to pass around a higher level RelationTuple and Attributes in order to solve #52-data RelationalExprStateElems = RelationalExprStateTupleElems DatabaseContext RelationTuple | -- used when fully evaluating a relexpr-                                RelationalExprStateAttrsElems DatabaseContext Attributes | --used when evaluating the type of a relexpr-                                RelationalExprStateElems DatabaseContext --used by default at the top level of evaluation-                                -instance Show RelationalExprStateElems where                                -  show (RelationalExprStateTupleElems _ tup) = "RelationalExprStateTupleElems " ++ show tup-  show (RelationalExprStateAttrsElems _ attrs) = "RelationalExprStateAttrsElems" ++ show attrs-  show (RelationalExprStateElems _) = "RelationalExprStateElems"-                                -mkRelationalExprState :: DatabaseContext -> RelationalExprStateElems-mkRelationalExprState = RelationalExprStateElems--mergeTuplesIntoRelationalExprState :: RelationTuple -> RelationalExprStateElems -> RelationalExprStateElems-mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateElems ctx) = RelationalExprStateTupleElems ctx tupIn-mergeTuplesIntoRelationalExprState _ st@(RelationalExprStateAttrsElems _ _) = st-mergeTuplesIntoRelationalExprState tupIn (RelationalExprStateTupleElems ctx existingTuple) = let mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap existingTuple) in-  RelationalExprStateTupleElems ctx (mkRelationTupleFromMap mergedTupMap)-  -mergeAttributesIntoRelationalExprState :: Attributes -> RelationalExprStateElems -> RelationalExprStateElems-mergeAttributesIntoRelationalExprState attrs (RelationalExprStateElems ctx) = RelationalExprStateAttrsElems ctx attrs-mergeAttributesIntoRelationalExprState _ st@(RelationalExprStateTupleElems _ _) = st-mergeAttributesIntoRelationalExprState attrsIn (RelationalExprStateAttrsElems ctx attrs) = RelationalExprStateAttrsElems ctx (A.union attrsIn attrs)--type ResultAccumName = StringType--type ResultAccumFunc = (RelationTuple -> Relation -> Relation) -> Relation -> Relation--data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,-                                 resultAccumResult :: Relation-                                 }--type DatabaseStateElems = (DatabaseContext, M.Map ResultAccumName ResultAccum, DirtyFlag)--type DatabaseState a = State DatabaseStateElems a--getStateContext :: DatabaseState DatabaseContext-getStateContext = do-  (ctx,_, _) <- get-  pure ctx-  -putStateContext :: DatabaseContext -> DatabaseState () -putStateContext ctx = do-  (_, accum, _) <- get-  put (ctx, accum, True)-  -type RelationalExprState a = Reader RelationalExprStateElems a--stateElemsContext :: RelationalExprStateElems -> DatabaseContext-stateElemsContext (RelationalExprStateTupleElems ctx _) = ctx-stateElemsContext (RelationalExprStateElems ctx) = ctx-stateElemsContext (RelationalExprStateAttrsElems ctx _) = ctx--setStateElemsContext :: RelationalExprStateElems -> DatabaseContext -> RelationalExprStateElems-setStateElemsContext (RelationalExprStateTupleElems _ tup) ctx = RelationalExprStateTupleElems ctx tup-setStateElemsContext (RelationalExprStateElems _) ctx = RelationalExprStateElems ctx-setStateElemsContext (RelationalExprStateAttrsElems _ attrs) ctx = RelationalExprStateAttrsElems ctx attrs----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 Relation)-evalRelationalExpr (RelationVariable name _) = do-  relvarTable <- fmap (relationVariables . stateElemsContext) ask-  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 $ project 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 $ 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 $ 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 $ difference relA2 relB2-      -evalRelationalExpr (MakeStaticRelation attributeSet tupleSet) = -  case mkRelation attributeSet tupleSet of-    Right rel -> return $ Right rel-    Left err -> return $ Left err-    -evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do-  currentContext <- fmap stateElemsContext ask-  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 (either throwE pure . evalAttrExpr tConss) (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)-    either throwE pure (mkRelation attrs (RelationTupleSet tuples))-  -evalRelationalExpr (ExistingRelation rel) = pure (Right rel)--evalRelationalExpr (Rename oldAttrName newAttrName relExpr) = do-  evald <- evalRelationalExpr relExpr-  case evald of-    Right rel -> return $ rename oldAttrName newAttrName rel-    Left err -> return $ Left err--evalRelationalExpr (Group oldAttrNames newAttrName relExpr) = do-  eOldAttrNameSet <- evalAttributeNames oldAttrNames relExpr-  case eOldAttrNameSet of-    Left err -> pure (Left err)-    Right oldAttrNameSet -> do-      evald <- evalRelationalExpr relExpr-      case evald of-        Right rel -> return $ group oldAttrNameSet newAttrName rel-        Left err -> return $ Left err--evalRelationalExpr (Ungroup attrName relExpr) = do-  evald <- evalRelationalExpr relExpr-  case evald of-    Right rel -> return $ ungroup attrName rel-    Left err -> return $ Left err--evalRelationalExpr (Restrict predicateExpr relExpr) = do-  evald <- evalRelationalExpr relExpr-  case evald of-    Left err -> return $ Left err-    Right rel -> do-      eFilterFunc <- predicateRestrictionFilter (attributes rel) predicateExpr-      case eFilterFunc of-        Left err -> return $ Left err-        Right filterfunc -> -          pure (restrict filterfunc rel)--evalRelationalExpr (Equals relExprA relExprB) = do-  evaldA <- evalRelationalExpr relExprA-  evaldB <- evalRelationalExpr relExprB-  case evaldA of-    Left err -> return $ Left err-    Right relA -> case evaldB of-      Left err -> return $ Left err-      Right relB -> return $ Right $ if relA == relB then relationTrue else relationFalse--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) (RelationalExprStateElems 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 relA -> case evaldB of-      Left err -> return $ Left err-      Right relB -> return $ Right $ if relA /= relB then relationTrue else relationFalse---- extending a relation adds a single attribute with the results of the per-tuple expression evaluated-evalRelationalExpr (Extend tupleExpression relExpr) = do-  rstate <- ask-  let evald = runReader (evalRelationalExpr relExpr) rstate-  case evald of-    Left err -> pure (Left err)-    Right rel -> do-      tupProc <- extendTupleExpressionProcessor rel tupleExpression-      case tupProc of-        Left err -> pure (Left err)-        Right (newAttrs, tupProc') -> pure $ relMogrify tupProc' newAttrs rel----helper function to process relation variable creation/assignment-setRelVar :: RelVarName -> Relation -> DatabaseState (Either RelationalError ())-setRelVar relVarName rel = do-  currentContext <- getStateContext-  let newRelVars = M.insert relVarName rel $ relationVariables currentContext-      potentialContext = currentContext { relationVariables = newRelVars }-                        -  case checkConstraints potentialContext of-    Left err -> pure (Left err)-    Right _ -> do-      putStateContext potentialContext-      return (Right ())---- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation-deleteRelVar :: RelVarName -> DatabaseState (Either RelationalError ())-deleteRelVar relVarName = do-  currContext <- getStateContext-  let relVars = relationVariables currContext-  if M.notMember relVarName relVars then-    pure (Right ())-    else do-    let newRelVars = M.delete relVarName relVars-        newContext = currContext { relationVariables = newRelVars }-    putStateContext newContext-    pure (Right ())--evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Either RelationalError ())-evalDatabaseContextExpr NoOperation = pure (Right ())-  -evalDatabaseContextExpr (Define relVarName attrExprs) = do-  relvars <- fmap relationVariables getStateContext-  tConss <- fmap typeConstructorMapping getStateContext-  let eAttrs = map (evalAttrExpr tConss) attrExprs-      attrErrs = lefts eAttrs-      attrsList = rights eAttrs-  if not (null  attrErrs) then-    pure (Left (someErrors attrErrs))-    else do-      let atomTypeErrs = lefts $ map ((`validateAtomType` tConss) . A.atomType) attrsList-      if not (null atomTypeErrs) then-        pure (Left (someErrors atomTypeErrs))-        else -        case M.member relVarName relvars of-          True -> pure (Left (RelVarAlreadyDefinedError relVarName))-          False -> setRelVar relVarName emptyRelation >> pure (Right ())-            where-              attrs = A.attributesFromList attrsList-              emptyRelation = Relation attrs emptyTupleSet--evalDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName--evalDatabaseContextExpr (Assign relVarName expr) = do-  -- in the future, it would be nice to get types from the RelationalExpr instead of needing to evaluate it-  context <- getStateContext-  let existingRelVar = M.lookup relVarName relVarTable-      relVarTable = relationVariables context-      value = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)-  case value of-    Left err -> pure (Left err)-    Right rel -> case existingRelVar of-      Nothing -> setRelVar relVarName rel-      Just existingRel -> let expectedAttributes = attributes existingRel-                              foundAttributes = attributes rel in-                          if A.attributesEqual expectedAttributes foundAttributes then-                            setRelVar relVarName rel-                          else-                            pure (Left (RelationTypeMismatchError expectedAttributes foundAttributes))--evalDatabaseContextExpr (Insert relVarName relExpr) = do-  context <- getStateContext-  let unionexp = Union relExpr rv-      rv = RelationVariable relVarName ()-      unioned = runReader (evalRelationalExpr unionexp) (RelationalExprStateElems context)-      origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)-  case unioned of-    Left err -> pure (Left err)-    Right unioned' -> case origRel of-      Left err -> pure (Left err)-      Right origRel' -> if cardinality unioned' == cardinality origRel' then --no tuples actually inserted-                          pure (Right ())-                        else-                          evalDatabaseContextExpr $ Assign relVarName (ExistingRelation unioned')--evalDatabaseContextExpr (Delete relVarName predicate) = do-  context <- getStateContext-  let rv = RelationVariable relVarName ()-  let updatedRel = runReader (evalRelationalExpr (Restrict (NotPredicate predicate) rv)) (RelationalExprStateElems context)-      origRel = runReader (evalRelationalExpr rv) (RelationalExprStateElems context)-  case updatedRel of-    Left err -> pure (Left err)-    Right updatedRel' -> case origRel of-                      Left err -> pure (Left err)-                      Right origRel' -> if cardinality origRel' == cardinality updatedRel' then-                                          pure (Right ())-                                        else-                                          setRelVar relVarName updatedRel'----union of restricted+updated portion and the unrestricted+unupdated portion-evalDatabaseContextExpr (Update relVarName atomExprMap restrictionPredicateExpr) = do-  context <- getStateContext-  let relVarTable = relationVariables context-  case M.lookup relVarName relVarTable of-    Nothing -> pure (Left (RelVarNotDefinedError relVarName))-    Just rel -> -      case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of-        Left err -> pure (Left err)-        Right predicateFunc -> do-          let ret = do-                restrictedPortion <- restrict predicateFunc rel-                if cardinality restrictedPortion == Finite 0 then -                  pure Nothing-                  else do-                  unrestrictedPortion <- restrict (predicateFunc >=> (pure . not)) rel-                  updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion-                  updatedRel <- updatedPortion `union` unrestrictedPortion-                  pure (Just updatedRel)-          case ret of -            Left err -> pure (Left err)-            Right Nothing -> pure (Right ())-            Right (Just updatedRel) -> setRelVar relVarName updatedRel--evalDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do-  currContext <- getStateContext-  let currDeps = inclusionDependencies currContext-      newDeps = M.insert newDepName newDep currDeps-  if M.member newDepName currDeps then-    pure (Left (InclusionDependencyNameInUseError newDepName))-    else do-      let potentialContext = currContext { inclusionDependencies = newDeps }-      case checkConstraints potentialContext of-        Left err -> pure (Left err)-        Right _ -> do-          putStateContext potentialContext-          return (Right ())--evalDatabaseContextExpr (RemoveInclusionDependency depName) = do-  currContext <- getStateContext-  let currDeps = inclusionDependencies currContext-      newDeps = M.delete depName currDeps-  if M.notMember depName currDeps then-    pure (Left (InclusionDependencyNameNotInUseError depName))-    else do-    putStateContext $ currContext {inclusionDependencies = newDeps }-    return (Right ())-    --- | Add a notification which will send the resultExpr when triggerExpr changes between commits.-evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do-  currentContext <- getStateContext-  let nots = notifications currentContext-  if M.member notName nots then-    pure (Left (NotificationNameInUseError notName))-    else do-      let newNotifications = M.insert notName newNotification nots-          newNotification = Notification { changeExpr = triggerExpr,-                                           reportOldExpr = resultOldExpr, -                                           reportNewExpr = resultNewExpr}-      putStateContext $ currentContext { notifications = newNotifications }-      return (Right ())-  -evalDatabaseContextExpr (RemoveNotification notName) = do-  currentContext <- getStateContext-  let nots = notifications currentContext-  if M.notMember notName nots then-    pure (Left (NotificationNameNotInUseError notName))-    else do-    let newNotifications = M.delete notName nots-    putStateContext $ currentContext { notifications = newNotifications }-    pure (Right ())---- | Adds type and data constructors to the database context.--- validate that the type *and* constructor names are unique! not yet implemented!-evalDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do-  currentContext <- getStateContext-  let oldTypes = typeConstructorMapping currentContext-      tConsName = TCD.name tConsDef-  -- validate that the constructor's types exist-  case validateTypeConstructorDef tConsDef dConsDefList oldTypes of-    Left err -> pure (Left err)-    Right _ | T.null tConsName || not (isUpper (T.head tConsName)) -> pure (Left (InvalidAtomTypeName tConsName))-            | isJust (findTypeConstructor tConsName oldTypes) -> pure (Left (AtomTypeNameInUseError tConsName))-            | otherwise -> do-                let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]-                putStateContext $ currentContext { typeConstructorMapping = newTypes }-                pure (Right ())---- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.-evalDatabaseContextExpr (RemoveTypeConstructor tConsName) = do-  currentContext <- getStateContext-  let oldTypes = typeConstructorMapping currentContext-  if isNothing (findTypeConstructor tConsName oldTypes) then-    pure (Left (AtomTypeNameNotInUseError tConsName))-    else do-      let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes-      putStateContext $ currentContext { typeConstructorMapping = newTypes }-      pure (Right ())--evalDatabaseContextExpr (MultipleExpr exprs) = do-  --the multiple expressions must pass the same context around- not the old unmodified context-  evald <- forM exprs evalDatabaseContextExpr-  --some lifting magic needed here-  case lefts evald of-    [] -> pure (Right ())-    errs -> pure (Left (someErrors errs))-             -evalDatabaseContextExpr (RemoveAtomFunction funcName) = do-  currentContext <- getStateContext-  let atomFuncs = atomFunctions currentContext-  case atomFunctionForName funcName atomFuncs of-    Left err -> pure (Left err)-    Right realFunc -> if isScriptedAtomFunction realFunc then do-      let updatedFuncs = HS.delete realFunc atomFuncs-      putStateContext (currentContext {atomFunctions = updatedFuncs })-      pure (Right ())-                      else-                        pure (Left (PrecompiledFunctionRemoveError funcName))-      -evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do      -  context <- getStateContext-  let dbcFuncs = dbcFunctions context-  case databaseContextFunctionForName funcName dbcFuncs of-    Left err -> pure (Left err)-    Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do-      let updatedFuncs = HS.delete realFunc dbcFuncs-      putStateContext (context { dbcFunctions = updatedFuncs })-      pure (Right ())-                      else-                        pure (Left (PrecompiledFunctionRemoveError funcName))-      -evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) = do-  context <- getStateContext-  --resolve atom arguments-  let relExprState = mkRelationalExprState context-      eAtomTypes = map (\atomExpr -> runReader (typeFromAtomExpr emptyAttributes atomExpr) relExprState) atomArgExprs-      eFunc = databaseContextFunctionForName funcName (dbcFunctions context)-  case eFunc of-      Left err -> pure (Left err)-      Right func -> do-        let expectedArgCount = length (dbcFuncType func)-            actualArgCount = length atomArgExprs-        if expectedArgCount /= actualArgCount then-          pure (Left (FunctionArgumentCountMismatchError expectedArgCount actualArgCount))-          else -          --check that the atom types are valid-          case lefts eAtomTypes of-            _:_ -> pure (Left (someErrors (lefts eAtomTypes)))-            [] -> do-              let atomTypes = rights eAtomTypes-              let mValidTypes = map (\(expType, actType) -> case atomTypeVerify expType actType of -                                        Left err -> Just err-                                        Right _ -> Nothing) (zip (dbcFuncType func) atomTypes)-                  typeErrors = catMaybes mValidTypes -                  eAtomArgs = map (\arg -> runReader (evalAtomExpr emptyTuple arg) relExprState) atomArgExprs-              if length (lefts eAtomArgs) > 1 then-                pure (Left (someErrors (lefts eAtomArgs)))-                else if not (null typeErrors) then-                     pure (Left (someErrors typeErrors))                   -                   else-                     case evalDatabaseContextFunction func (rights eAtomArgs) context of-                       Left err -> pure (Left err)-                       Right newContext -> putStateContext newContext >> pure (Right ())-      -evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)-evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = -  case mScriptSession of-    Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))-    Just scriptSession -> do-      res <- try $ runGhc (Just libdir) $ do-        setSession (hscEnv scriptSession)-        let atomFuncs = atomFunctions currentContext-        case extractAtomFunctionType funcType of-          Left err -> pure (Left err)-          Right adjustedAtomTypeCons -> do-            --compile the function-            eCompiledFunc  <- compileScript (atomFunctionBodyType scriptSession) script-            pure $ case eCompiledFunc of-              Left err -> Left (ScriptError err)-              Right compiledFunc -> do-                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 }-               -- check if the name is already in use-                if HS.member funcName (HS.map atomFuncName atomFuncs) then-                  Left (FunctionNameInUseError funcName)-                  else -                  Right newContext-      case res of-        Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))-        Right eContext -> case eContext of-          Left err -> pure (Left err)-          Right context' -> pure (Right context')-          -evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunction funcName funcType script) = -  case mScriptSession of-    Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))-    Just 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-          dbContextTypeCons = ADTypeConstructor "Either" [ADTypeConstructor "DatabaseContextFunctionError" [], ADTypeConstructor "DatabaseContext" []]-          expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"-          actualType = show funcType-      if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then -        pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))-        else do-        res <- try $ runGhc (Just libdir) $ do-          setSession (hscEnv scriptSession)-          eCompiledFunc  <- compileScript (dbcFunctionBodyType scriptSession) script-          pure $ case eCompiledFunc of        -            Left err -> Left (ScriptError err)-            Right compiledFunc -> do-              --if we are here, we have validated that the written function type is X -> DatabaseContext -> DatabaseContext, so we need to munge the first elements into an array-              funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) atomArgs-              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-                    }-                -- check if the name is already in use                                              -              if HS.member funcName (HS.map dbcFuncName dbcFuncs) then-                Left (FunctionNameInUseError funcName)-                else -                Right newContext-        case res of-          Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))-          Right eContext -> case eContext of-            Left err -> pure (Left err)-            Right context' -> pure (Right context')-evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do-  eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath-  case eLoadFunc of-    Left LoadSymbolError -> pure (Left LoadFunctionError)-    Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }-                                      mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)-                                  in pure (Right newContext)-evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName funcName modPath) = do-  eLoadFunc <- loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath-  case eLoadFunc of-    Left LoadSymbolError -> pure (Left LoadFunctionError)-    Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }-                             mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)-                                  in pure (Right newContext)--evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =-  --Define-  case runState ( evalDatabaseContextExpr (Define relVarName attrExprs)) (freshDatabaseState currentContext) of-    (Left err,_) -> pure (Left err)-    (Right (), elems@(ctx,_,_)) -> do-         --Assign-           let existingRelVar = M.lookup relVarName relVarTable-               relVarTable = relationVariables ctx -           case existingRelVar of-                Nothing -> pure $ Left (RelVarNotDefinedError relVarName)-                Just existingRel -> do-                                      let expectedAttributes = attributes existingRel-                                      let tcMap = typeConstructorMapping ctx-                                      eitherRel <- generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap-                                      case eitherRel of-                                           Left err -> pure $ Left err-                                           Right rel ->-                                             case runState (setRelVar relVarName rel) elems of-                                                  (Left err,_) -> pure (Left err)-                                                  (Right (), (ctx',_,_)) -> pure $ Right ctx'--updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple-updateTupleWithAtomExprs exprMap context tupIn = do-  --resolve all atom exprs-  atomsAssoc <- mapM (\(attrName, atomExpr) -> do-                         atom <- runReader (evalAtomExpr tupIn atomExpr) (RelationalExprStateElems context)-                         pure (attrName, atom)-                     ) (M.toList exprMap)-  pure (updateTupleWithAtoms (M.fromList atomsAssoc) tupIn)----run verification on all constraints-checkConstraints :: DatabaseContext -> Either RelationalError ()-checkConstraints context =-  mapM_ (uncurry checkIncDep) (M.toList deps) -  where-    deps = inclusionDependencies context-    eval expr = evalReader (evalRelationalExpr expr)-    evalReader f = runReader f (RelationalExprStateElems context)-    checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do-      --if both expressions are of a single-attribute (such as with a simple foreign key), the names of the attributes are irrelevant (they need not match) because the expression is unambiguous, but special-casing this to rename the attribute automatically would not be orthogonal behavior and probably cause confusion. Instead, special case the error to make it clear.-      typeSub <- evalReader (typeForRelationalExpr subsetExpr)-      typeSuper <- evalReader (typeForRelationalExpr supersetExpr)-      when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))-      let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)-      case eval checkExpr of-        Left err -> Left err-        Right resultRel -> if resultRel == relationTrue then-                                   pure ()-                                else -                                  Left (InclusionDependencyCheckError depName)---- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing--- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation--typeForRelationalExpr :: RelationalExpr -> RelationalExprState (Either RelationalError Relation)-typeForRelationalExpr expr = do-  rstate <- ask-  let context = stateElemsContext rstate-  --replace the relationVariables context element with a cloned set of relation devoid of tuples-  let context' = contextWithEmptyTupleSets context-      rstate' = setStateElemsContext rstate context'-  --evalRelationalExpr could still return an existing relation with tuples, so strip them-  pure $ case runReader (evalRelationalExpr expr) rstate' of-    Left err -> Left err-    Right typeRel -> Right (relationWithEmptyTupleSet typeRel)----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 -> Relation (attributes rel) emptyTupleSet) (relationVariables contextIn)--liftE :: (Monad m) => m (Either a b) -> ExceptT a m b-liftE v = do-  y <- lift v-  case y of-    Left err -> throwE err-    Right val -> pure val--{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}-predicateRestrictionFilter :: Attributes -> RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionFilter)-predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = -  runExceptT $ do-    expr1v <- liftE (predicateRestrictionFilter attrs expr1)-    expr2v <- liftE (predicateRestrictionFilter attrs expr2)-    pure (\x -> do-                ev1 <- expr1v x -                ev2 <- expr2v x-                pure (ev1 && ev2))--predicateRestrictionFilter attrs (OrPredicate expr1 expr2) =-  runExceptT $ do-    expr1v <- liftE (predicateRestrictionFilter attrs expr1)-    expr2v <- liftE (predicateRestrictionFilter attrs expr2)-    pure (\x -> do-                ev1 <- expr1v x -                ev2 <- expr2v x-                pure (ev1 || ev2))--predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> pure True))--predicateRestrictionFilter attrs (NotPredicate expr) = -  runExceptT $ do-    exprv <- liftE (predicateRestrictionFilter attrs expr)-    pure (fmap not . exprv)----optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here-predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do-  rstate <- ask-  pure (Right (\tup -> case runReader (evalRelationalExpr relExpr) (mergeTuplesIntoRelationalExprState tup rstate) of-    Left err -> Left err-    Right rel -> if arity rel /= 0 then-                   Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")-                   else-                   pure (rel == relationTrue)))--predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do-  rstate <- ask-  let (attrs', ctxtup') = case rstate of-                    RelationalExprStateElems _ -> (attrs, emptyTuple)-                    RelationalExprStateAttrsElems _ _ -> (attrs, emptyTuple)-                    RelationalExprStateTupleElems _ ctxtup -> (A.union attrs (tupleAttributes ctxtup), ctxtup)-  runExceptT $ do-    atomExprType <- liftE (typeFromAtomExpr attrs' atomExpr)-    attr <- either throwE pure $ case A.attributeForName attrName attrs of-      Right attr -> Right attr-      Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of-        Right ctxattr -> Right ctxattr-        Left err2@(NoSuchAttributeNamesError _) -> Left err2-        Left err -> Left err-      Left err -> Left err-    if atomExprType /= A.atomType attr then-      throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))-      else-      pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of-                               Right atomCmp -> atomCmp == atomIn-                               Left _ -> False-                             atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate-                         in-                          pure $ case atomForAttributeName attrName tupleIn of-                            Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of-                              Left _ -> False-                              Right ctxatom -> evalAndCmp ctxatom-                            Left _ -> False-                            Right atomIn -> evalAndCmp atomIn--- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance-predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do-  --merge attrs into the state attributes-  rstate <- ask-  runExceptT $ do-    aType <- liftE (typeFromAtomExpr attrs  atomExpr)-    if aType /= BoolAtomType then-      throwE (AtomTypeMismatchError aType BoolAtomType)-      else-      pure (\tupleIn ->-             case runReader (evalAtomExpr tupleIn atomExpr) rstate of-                  Left err -> Left err-                  Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))--tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation-tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then-                                           Left (AttributeNameInUseError attrName)-                                         else-                                           Right rel--extendTupleExpressionProcessor :: Relation -> ExtendTupleExpr -> RelationalExprState (Either RelationalError (Attributes, RelationTuple -> Either RelationalError RelationTuple))-extendTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = do-  rstate <- ask-  -- check that the attribute name is not in use-  case tupleExprCheckNewAttrName newAttrName relIn of-    Left err -> pure (Left err)-    Right _ -> runExceptT $ do-      atomExprType <- liftE (typeFromAtomExpr (attributes relIn) atomExpr)-      atomExprType' <- liftE (verifyAtomExprTypes relIn atomExpr atomExprType)-      let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']-          newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs-      pure (newAndOldAttrs, \tup -> let substate = mergeTuplesIntoRelationalExprState tup rstate in case runReader (evalAtomExpr tup atomExpr) substate of-                 Left err -> Left err-                 Right atom -> Right (tupleAtomExtend newAttrName atom tup)-               )--evalAtomExpr :: RelationTuple -> AtomExpr -> RelationalExprState (Either RelationalError Atom)-evalAtomExpr tupIn (AttributeAtomExpr attrName) = case atomForAttributeName attrName tupIn of-  Right atom -> pure (Right atom)-  err@(Left (NoSuchAttributeNamesError _)) -> do-    rstate <- ask-    case rstate of-      RelationalExprStateElems _ -> pure err-      RelationalExprStateAttrsElems _ _ -> pure err-      RelationalExprStateTupleElems _ ctxtup -> pure (atomForAttributeName attrName ctxtup)-  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)--typeFromAtomExpr :: Attributes -> AtomExpr -> RelationalExprState (Either RelationalError AtomType)-typeFromAtomExpr attrs (AttributeAtomExpr attrName) = do-  rstate <- ask-  case A.atomTypeForAttributeName attrName attrs of-    Right aType -> pure (Right aType)-    Left err@(NoSuchAttributeNamesError _) -> case rstate of-        RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of-          Left err' -> pure (Left err')-          Right attr -> pure (Right (A.atomType attr))-        RelationalExprStateElems _ -> pure (Left err)-        RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of-          Left err' -> pure (Left err')-          Right atom -> pure (Right (atomTypeForAtom atom))-    Left err -> pure (Left err)-typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom))-typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do-  context <- fmap stateElemsContext ask-  let funcs = atomFunctions context-  case atomFunctionForName funcName funcs of-    Left err -> pure (Left err)-    Right func -> do-      let funcRetType = last (atomFuncType func)-          funcArgTypes = init (atomFuncType func)-      eArgTypes <- mapM (typeFromAtomExpr attrs) atomArgs-      case lefts eArgTypes of                   -        errs@(_:_) -> pure (Left (someErrors errs))-        [] -> do-          let eTvMap = resolveTypeVariables funcArgTypes argTypes-              argTypes = rights eArgTypes-          case eTvMap of-            Left err -> pure (Left err)-            Right tvMap -> pure (resolveFunctionReturnValue funcName tvMap funcRetType)-typeFromAtomExpr attrs (RelationAtomExpr relExpr) = runExceptT $ do-  rstate <- lift ask-  relType <- either throwE pure (runReader (typeForRelationalExpr relExpr) (mergeAttributesIntoRelationalExprState attrs rstate))-  pure (RelationAtomType (attributes relType))--- grab the type of the data constructor, then validate that the args match the expected types-typeFromAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs _) = -  runExceptT $ do-    argsTypes <- mapM (liftE . typeFromAtomExpr attrs) dConsArgs -    context <- fmap stateElemsContext (lift ask)-    either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)---- | Validate that the type of the AtomExpr matches the expected type.-verifyAtomExprTypes :: Relation -> AtomExpr -> AtomType -> RelationalExprState (Either RelationalError AtomType)-verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do-  rstate <- lift ask-  case A.atomTypeForAttributeName attrName (attributes relIn) of-    Right aType -> either throwE pure (atomTypeVerify expectedType aType)-    (Left err@(NoSuchAttributeNamesError _)) -> case rstate of-      RelationalExprStateTupleElems _ _ -> throwE err-      RelationalExprStateElems _ -> throwE err-      RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of-        Left err' -> throwE err'-        Right attrType -> either throwE pure (atomTypeVerify expectedType (A.atomType attrType))-    Left err -> throwE err-verifyAtomExprTypes _ (NakedAtomExpr atom) expectedType = pure (atomTypeVerify expectedType (atomTypeForAtom atom))-verifyAtomExprTypes relIn (FunctionAtomExpr funcName funcArgExprs _) expectedType = do-  rstate <- ask-  let functions = atomFunctions context-      context = stateElemsContext rstate-  runExceptT $ do-    func <- either throwE pure (atomFunctionForName funcName functions)-    let expectedArgTypes = atomFuncType func-    funcArgTypes <- mapM (\(atomExpr,expectedType2,argCount) -> case runReader (verifyAtomExprTypes relIn atomExpr expectedType2) rstate of-                           Left (AtomTypeMismatchError expSubType actSubType) -> throwE (AtomFunctionTypeError funcName argCount expSubType actSubType)-                           Left err -> throwE err-                           Right x -> pure x-                           ) $ zip3 funcArgExprs expectedArgTypes [1..]-    if length funcArgTypes /= length expectedArgTypes - 1 then-      throwE (AtomTypeCountError funcArgTypes expectedArgTypes)-      else -      either throwE pure (atomTypeVerify expectedType (last expectedArgTypes))-verifyAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType = runExceptT $ do-  rstate <- lift ask-  relType <- either throwE pure (runReader (typeForRelationalExpr relationExpr) (mergeAttributesIntoRelationalExprState (attributes relIn) rstate))-  either throwE pure (atomTypeVerify expectedType (RelationAtomType (attributes relType)))-verifyAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = runExceptT $ do-  cType <- liftE (typeFromAtomExpr (attributes rel) cons)-  either throwE pure (atomTypeVerify expectedType cType)---- | Look up the type's name and create a new attribute.-evalAttrExpr :: TypeConstructorMapping -> AttributeExpr -> Either RelationalError Attribute-evalAttrExpr aTypes (AttributeAndTypeNameExpr attrName tCons ()) = do-  aType <- atomTypeForTypeConstructorValidate True tCons aTypes M.empty-  validateAtomType aType aTypes-  Right (Attribute attrName aType)-  -evalAttrExpr _ (NakedAttributeExpr attr) = Right attr-  -evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)-evalTupleExpr mAttrs (TupleExpr tupMap) = do-  context <- fmap stateElemsContext ask-  runExceptT $ do-  -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority-  -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed-    let attrs = fromMaybe A.emptyAttributes mAttrs-    attrAtoms <- mapM (\(attrName, aExpr) -> do-                          --provided when the relation header is available-                          let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs-                          unresolvedType <- liftE (typeFromAtomExpr attrs aExpr)-                          resolvedType <- case eExpectedAtomType of-                            Left _ -> pure unresolvedType-                            Right typeHint -> either throwE pure (resolveAtomType typeHint unresolvedType)-                          --resolve atom typevars based on resolvedType?-                          newAtom <- liftE (evalAtomExpr emptyTuple aExpr)-                          pure (attrName, newAtom, resolvedType)-                      ) (M.toList tupMap)-    let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms-        atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms-        tup = mkRelationTuple tupAttrs atoms-        tConss = typeConstructorMapping context-        finalAttrs = fromMaybe tupAttrs mAttrs-    --verify that the attributes match-    when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)-    tup' <- either throwE pure (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))-    _ <- either throwE pure (validateTuple tup' tConss)-    pure tup'--evalAttributeNames :: AttributeNames -> RelationalExpr -> RelationalExprState (Either RelationalError (S.Set AttributeName))-evalAttributeNames attrNames expr = do-  eExprType <- typeForRelationalExpr expr-  case eExprType of-    Left err -> pure (Left err)-    Right exprTyp -> do-      let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprTyp)))-      case attrNames of-        AttributeNames names ->-          case A.projectionAttributesForNames names (attributes exprTyp) of-            Left err -> pure (Left err)-            Right attrs -> pure (Right (S.fromList (V.toList (A.attributeNames attrs))))-          -        InvertedAttributeNames names -> do-          let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet-          if not (S.null nonExistentAttributeNames) then-            pure (Left (AttributeNamesMismatchError nonExistentAttributeNames))-            else-            pure (Right (A.nonMatchingAttributeNameSet names typeNameSet))-        -        UnionAttributeNames namesA namesB -> do-          eNameSetA <- evalAttributeNames namesA expr-          case eNameSetA of-            Left err -> pure (Left err)-            Right nameSetA -> do-              eNameSetB <- evalAttributeNames namesB expr-              case eNameSetB of-                Left err -> pure (Left err)-                Right nameSetB ->           -                  pure (Right (S.union nameSetA nameSetB))-        -        IntersectAttributeNames namesA namesB -> do-          eNameSetA <- evalAttributeNames namesA expr-          case eNameSetA of-            Left err -> pure (Left err)-            Right nameSetA -> do-              eNameSetB <- evalAttributeNames namesB expr-              case eNameSetB of-                Left err -> pure (Left err)-                Right nameSetB ->           -                  pure (Right (S.intersection nameSetA nameSetB))-        -        RelationalExprAttributeNames attrExpr -> do-          eAttrExprType <- typeForRelationalExpr attrExpr-          case eAttrExprType of-            Left err -> pure (Left err)-            Right attrExprType -> pure (Right (A.attributeNameSet (attributes attrExprType)))-              +{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE FlexibleContexts  #-}+module ProjectM36.RelationalExpression where+import ProjectM36.Relation+import ProjectM36.Tuple+import ProjectM36.TupleSet+import ProjectM36.Base+import qualified Data.UUID as U+import ProjectM36.Error+import ProjectM36.AtomType+import ProjectM36.Attribute (emptyAttributes, attributesFromList)+import ProjectM36.ScriptSession+import ProjectM36.DataTypes.Primitive+import ProjectM36.AtomFunction+import ProjectM36.DatabaseContextFunction+import ProjectM36.Arbitrary+import ProjectM36.GraphRefRelationalExpr+import ProjectM36.Transaction+import qualified ProjectM36.Attribute as A+import qualified Data.Map as M+import qualified Data.HashSet as HS+import qualified Data.Set as S+import Control.Monad.State hiding (join)+import Data.Bifunctor (second)+import Data.Maybe+import Data.Either+import Data.Char (isUpper)+import Data.Time+import qualified Data.List.NonEmpty as NE+import Data.Functor.Identity+import qualified Data.Text as T+import qualified Data.Vector as V+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 Test.QuickCheck+#ifdef PM36_HASKELL_SCRIPTING+import GHC hiding (getContext)+import Control.Exception+import GHC.Paths+#endif++data DatabaseContextExprDetails = CountUpdatedTuples++databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc+databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups+  where+    attrs = A.attributesFromList [Attribute "count" IntAtomType]+    existingTuple = fromMaybe (error "impossible counting error in singletonTuple") (singletonTuple relIn)+    existingCount = case V.head (tupleAtoms existingTuple) of+      IntAtom v -> v+      _ -> error "impossible counting error in tupleAtoms"+    newTups = case mkTupleSetFromList attrs [[IntAtom (existingCount + 1)]] of+      Left err -> error ("impossible counting error in " ++ show err)+      Right ts -> ts+      +-- | Used to start a fresh database state for a new database context expression.+mkDatabaseContextEvalState :: DatabaseContext -> DatabaseContextEvalState+mkDatabaseContextEvalState context = DatabaseContextEvalState {+  dbc_context = context,+  dbc_accum = M.empty,+  dbc_dirty = False+  } --future work: propagate return accumulator++-- we need to pass around a higher level RelationTuple and Attributes in order to solve #52+data RelationalExprEnv = RelationalExprEnv {+  re_context :: DatabaseContext, +  re_graph :: TransactionGraph,+  re_extra :: Maybe (Either RelationTuple Attributes)+  }++envTuple :: GraphRefRelationalExprEnv -> RelationTuple+envTuple e = fromLeft emptyTuple (fromMaybe (Left emptyTuple) (gre_extra e))++envAttributes :: GraphRefRelationalExprEnv -> Attributes+envAttributes e = fromRight emptyAttributes (fromMaybe (Right emptyAttributes) (gre_extra e))+  +instance Show RelationalExprEnv where+  show e@RelationalExprEnv{} = "RelationalExprEnv " ++ show (re_extra e)++--used to eval relationalexpr+type RelationalExprM a = ReaderT RelationalExprEnv (ExceptT RelationalError Identity) a++runRelationalExprM :: RelationalExprEnv -> RelationalExprM a -> Either RelationalError a+runRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))++reGraph :: RelationalExprM TransactionGraph+reGraph = asks re_graph++reContext :: RelationalExprM DatabaseContext+reContext = asks re_context++mkRelationalExprEnv :: DatabaseContext -> TransactionGraph -> RelationalExprEnv+mkRelationalExprEnv ctx graph =+  RelationalExprEnv+  { re_context = ctx,+    re_graph = graph,+    re_extra = Nothing }++askEnv :: GraphRefRelationalExprM GraphRefRelationalExprEnv+askEnv = R.ask++mergeTuplesIntoGraphRefRelationalExprEnv :: RelationTuple -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv+mergeTuplesIntoGraphRefRelationalExprEnv tupIn e =+  e{ gre_extra = new_elems }+  where+    new_elems = Just (Left newTuple)+    mergedTupMap = M.union (tupleToMap tupIn) (tupleToMap (envTuple e))+    newTuple = mkRelationTupleFromMap mergedTupMap++mergeAttributesIntoGraphRefRelationalExprEnv :: Attributes -> GraphRefRelationalExprEnv -> GraphRefRelationalExprEnv+mergeAttributesIntoGraphRefRelationalExprEnv attrsIn e = e { gre_extra = newattrs }+  where+    newattrs = Just (Right (A.union attrsIn (envAttributes e)))++type ResultAccumName = StringType++type ResultAccumFunc = (RelationTuple -> Relation -> Relation) -> Relation -> Relation++data ResultAccum = ResultAccum { resultAccumFunc :: ResultAccumFunc,+                                 resultAccumResult :: Relation+                                 }++data DatabaseContextEvalState = DatabaseContextEvalState {+  dbc_context :: DatabaseContext, --new, alterable context for a new transaction+  dbc_accum :: M.Map ResultAccumName ResultAccum,+  dbc_dirty :: DirtyFlag+  }++data DatabaseContextEvalEnv = DatabaseContextEvalEnv+  { dce_transId :: TransactionId,+    dce_graph :: TransactionGraph+  }++mkDatabaseContextEvalEnv :: TransactionId -> TransactionGraph -> DatabaseContextEvalEnv+mkDatabaseContextEvalEnv = DatabaseContextEvalEnv++type DatabaseContextEvalMonad a = RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity) a++runDatabaseContextEvalMonad :: DatabaseContext -> DatabaseContextEvalEnv -> DatabaseContextEvalMonad () -> Either RelationalError DatabaseContextEvalState+runDatabaseContextEvalMonad ctx env m = runIdentity (runExceptT (fst <$> execRWST m env freshEnv))+  where+    freshEnv = mkDatabaseContextEvalState ctx+    ++dbcTransId :: DatabaseContextEvalMonad TransactionId+dbcTransId = dce_transId <$> RWS.ask++dbcGraph :: DatabaseContextEvalMonad TransactionGraph+dbcGraph = dce_graph <$> RWS.ask++dbcRelationalExprEnv :: DatabaseContextEvalMonad RelationalExprEnv+dbcRelationalExprEnv = +  mkRelationalExprEnv <$> getStateContext <*> dbcGraph++getStateContext :: DatabaseContextEvalMonad DatabaseContext+getStateContext = gets dbc_context++putStateContext :: DatabaseContext -> DatabaseContextEvalMonad () +putStateContext ctx' = do+  s <- get+  put (s {dbc_context = ctx', dbc_dirty = True}) ++-- | The context is optionally passed down along in cases where the current context is uncommitted.+data GraphRefRelationalExprEnv =+  GraphRefRelationalExprEnv {+  gre_context :: Maybe DatabaseContext,+  gre_graph :: TransactionGraph,+  gre_extra :: Maybe (Either RelationTuple Attributes)+  }+  +type GraphRefRelationalExprM a = ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity) a++gfTransForId :: TransactionId -> GraphRefRelationalExprM Transaction+gfTransForId tid = do+  graph <- gfGraph+  lift $ except $ transactionForId tid graph++gfDatabaseContextForMarker :: GraphRefTransactionMarker -> GraphRefRelationalExprM DatabaseContext+gfDatabaseContextForMarker (TransactionMarker transId) = concreteDatabaseContext <$> gfTransForId transId+gfDatabaseContextForMarker UncommittedContextMarker = do+  mctx <- gre_context <$> askEnv+  case mctx of+    Nothing -> throwError NoUncommittedContextInEvalError+    Just ctx -> pure ctx++runGraphRefRelationalExprM :: GraphRefRelationalExprEnv -> GraphRefRelationalExprM a -> Either RelationalError a+runGraphRefRelationalExprM env m = runIdentity (runExceptT (runReaderT m env))++freshGraphRefRelationalExprEnv :: Maybe DatabaseContext -> TransactionGraph -> GraphRefRelationalExprEnv+freshGraphRefRelationalExprEnv mctx graph = GraphRefRelationalExprEnv {+  gre_context = mctx,+  gre_graph = graph,+  gre_extra = Nothing+  }++gfGraph :: GraphRefRelationalExprM TransactionGraph+gfGraph = asks gre_graph++envContext :: RelationalExprEnv -> DatabaseContext+envContext = re_context++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+  currentContext <- getStateContext+  --prevent recursive relvar definition+  let newRelVars = M.insert relVarName relExpr $ relationVariables currentContext+      potentialContext = currentContext { relationVariables = newRelVars }+  --optimization: if the relexpr is unchanged, skip the update      +  if M.lookup relVarName (relationVariables currentContext) == Just relExpr then+    pure ()+    else do+    --determine when to check constraints+    graph <- dbcGraph+    tid <- dbcTransId+    case checkConstraints potentialContext tid graph of+      Left err -> dbErr err+      Right _ -> putStateContext potentialContext++-- 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+  currContext <- getStateContext+  let relVars = relationVariables currContext+  if M.notMember relVarName relVars then+    pure ()+    else do+    let newRelVars = M.delete relVarName relVars+        newContext = currContext { relationVariables = newRelVars }+    putStateContext newContext+    pure ()++evalGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> DatabaseContextEvalMonad ()+evalGraphRefDatabaseContextExpr NoOperation = pure ()+  +evalGraphRefDatabaseContextExpr (Define relVarName attrExprs) = do+  context <- getStateContext+  relvars <- fmap relationVariables getStateContext+  tConss <- fmap typeConstructorMapping getStateContext+  graph <- dbcGraph+  let eAttrs = runGraphRefRelationalExprM gfEnv (mapM evalGraphRefAttrExpr attrExprs)+      gfEnv = freshGraphRefRelationalExprEnv (Just context) graph+  case eAttrs of+    Left err -> dbErr err+    Right attrsList -> do+      lift $ except $ validateAttributes tConss (A.attributesFromList attrsList)+      case M.member relVarName relvars of+          True -> dbErr (RelVarAlreadyDefinedError relVarName)+          False -> setRelVar relVarName (ExistingRelation emptyRelation)+            where+              attrs = A.attributesFromList attrsList+              emptyRelation = Relation attrs emptyTupleSet++evalGraphRefDatabaseContextExpr (Undefine relVarName) = deleteRelVar relVarName++evalGraphRefDatabaseContextExpr (Assign relVarName expr) = do+  graph <- re_graph <$> dbcRelationalExprEnv+  context <- getStateContext+  let existingRelVar = M.lookup relVarName (relationVariables context)+      reEnv = freshGraphRefRelationalExprEnv (Just context) graph+      eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr)      +  case existingRelVar of+    Nothing -> do+      case runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr expr) of+        Left err -> dbErr err+        Right reltype -> do+          lift $ except $ validateAttributes (typeConstructorMapping context) (attributes reltype)+          setRelVar relVarName expr+    Just existingRel -> do+      let eExpectedType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr existingRel)+      case eExpectedType of+        Left err -> dbErr err+        Right expectedType ->+          case eNewExprType of+            Left err -> dbErr err+            Right newExprType -> do+              if newExprType == expectedType then do+                lift $ except $ validateAttributes (typeConstructorMapping context) (attributes newExprType)+                setRelVar relVarName expr +              else+                dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType))++evalGraphRefDatabaseContextExpr (Insert relVarName relExpr) = do+  gfExpr <- relVarByName relVarName+  evalGraphRefDatabaseContextExpr (Assign relVarName+                                   (Union+                                    gfExpr+                                    relExpr))++evalGraphRefDatabaseContextExpr (Delete relVarName predicate) = do+  gfExpr <- relVarByName relVarName+  setRelVar relVarName (Restrict (NotPredicate predicate) gfExpr)+  +--union of restricted+updated portion and the unrestricted+unupdated portion+evalGraphRefDatabaseContextExpr (Update relVarName atomExprMap pred') = do+  rvExpr <- relVarByName relVarName+  let unrestrictedPortion = Restrict (NotPredicate pred') rvExpr+      tmpAttr attr = "_tmp_" <> attr --this could certainly be improved to verify that there is no attribute name conflict+      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+      updated = foldr (\(oldname, atomExpr) accum ->+                                 let procAtomExpr = runProcessExprM UncommittedContextMarker (processAtomExpr atomExpr) in+                                  updateAttr oldname procAtomExpr accum+                              ) restrictedPortion (M.toList atomExprMap)+              -- the atomExprMap could reference other attributes, so we must perform multi-pass folds+      updatedPortion = foldr projectAndRename updated (M.keys atomExprMap)+  setRelVar relVarName (Union unrestrictedPortion updatedPortion)++evalGraphRefDatabaseContextExpr (AddInclusionDependency newDepName newDep) = do+  currContext <- getStateContext+  transId <- dbcTransId+  graph <- dbcGraph+  let currDeps = inclusionDependencies currContext+      newDeps = M.insert newDepName newDep currDeps+  if M.member newDepName currDeps then+    dbErr (InclusionDependencyNameInUseError newDepName)+    else do+      let potentialContext = currContext { inclusionDependencies = newDeps }+      -- if the potential context passes all constraints, then save it+      -- potential optimization: validate only the new constraint- all old constraints must already hold+      case checkConstraints potentialContext transId graph of+        Left err -> dbErr err+        Right _ -> +          putStateContext potentialContext++evalGraphRefDatabaseContextExpr (RemoveInclusionDependency depName) = do+  currContext <- getStateContext+  let currDeps = inclusionDependencies currContext+      newDeps = M.delete depName currDeps+  if M.notMember depName currDeps then+    dbErr (InclusionDependencyNameNotInUseError depName)+    else +    putStateContext $ currContext {inclusionDependencies = newDeps }+    +-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.+evalGraphRefDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do+  currentContext <- getStateContext+  let nots = notifications currentContext+  if M.member notName nots then+    dbErr (NotificationNameInUseError notName)+    else do+      let newNotifications = M.insert notName newNotification nots+          newNotification = Notification { changeExpr = triggerExpr,+                                           reportOldExpr = resultOldExpr, +                                           reportNewExpr = resultNewExpr}+      putStateContext $ currentContext { notifications = newNotifications }+  +evalGraphRefDatabaseContextExpr (RemoveNotification notName) = do+  currentContext <- getStateContext+  let nots = notifications currentContext+  if M.notMember notName nots then+    dbErr (NotificationNameNotInUseError notName)+    else do+    let newNotifications = M.delete notName nots+    putStateContext $ currentContext { notifications = newNotifications }+++-- | Adds type and data constructors to the database context.+-- validate that the type *and* constructor names are unique! not yet implemented!+evalGraphRefDatabaseContextExpr (AddTypeConstructor tConsDef dConsDefList) = do+  currentContext <- getStateContext+  let oldTypes = typeConstructorMapping currentContext+      tConsName = TCD.name tConsDef+  -- validate that the constructor's types exist+  case validateTypeConstructorDef tConsDef dConsDefList oldTypes of+    Left err -> throwError err+    Right () | T.null tConsName || not (isUpper (T.head tConsName)) -> dbErr (InvalidAtomTypeName tConsName)+       | isJust (findTypeConstructor tConsName oldTypes) -> dbErr (AtomTypeNameInUseError tConsName)+       | otherwise -> do+      let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]+      putStateContext $ currentContext { typeConstructorMapping = newTypes }++-- | Removing the atom constructor prevents new atoms of the type from being created. Existing atoms of the type remain. Thus, the atomTypes list in the DatabaseContext need not be all-inclusive.+evalGraphRefDatabaseContextExpr (RemoveTypeConstructor tConsName) = do+  currentContext <- getStateContext+  let oldTypes = typeConstructorMapping currentContext+  if isNothing (findTypeConstructor tConsName oldTypes) then+    dbErr (AtomTypeNameNotInUseError tConsName)+    else do+      let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes+      putStateContext $ currentContext { typeConstructorMapping = newTypes }++evalGraphRefDatabaseContextExpr (MultipleExpr exprs) =+  --the multiple expressions must pass the same context around- not the old unmodified context+  mapM_ evalGraphRefDatabaseContextExpr exprs++evalGraphRefDatabaseContextExpr (RemoveAtomFunction funcName) = do+  currentContext <- getStateContext+  let atomFuncs = atomFunctions currentContext+  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)+      +evalGraphRefDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do      +  context <- getStateContext+  let dbcFuncs = dbcFunctions context+  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)+      +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)+      gfEnv = freshGraphRefRelationalExprEnv (Just context) graph+  case eFunc of+      Left err -> dbErr err+      Right func -> do+        let expectedArgCount = length (dbcFuncType func)+            actualArgCount = length atomArgExprs+        if expectedArgCount /= actualArgCount then+          dbErr (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)+          else +          --check that the atom types are valid+          case eAtomTypes of+            Left err -> dbErr err+            Right atomTypes -> do+              let mValidTypes = zipWith (\ expType actType+                                           -> case atomTypeVerify expType actType of+                                                Left err -> Just err+                                                Right _ -> Nothing)+                                (dbcFuncType func) atomTypes+                  typeErrors = catMaybes mValidTypes+                  eAtomArgs = map (runGraphRefRelationalExprM gfEnv . evalGraphRefAtomExpr emptyTuple) atomArgExprs+              if length (lefts eAtomArgs) > 1 then+                dbErr (someErrors (lefts eAtomArgs))+                else if not (null typeErrors) then+                     dbErr (someErrors typeErrors)+                   else+                     case evalDatabaseContextFunction func (rights eAtomArgs) context of+                       Left err -> dbErr err+                       Right newContext -> putStateContext newContext+data DatabaseContextIOEvalEnv = DatabaseContextIOEvalEnv+  { dbcio_transId :: TransactionId,+    dbcio_graph :: TransactionGraph,+    dbcio_mScriptSession :: Maybe ScriptSession+  }++type DatabaseContextIOEvalMonad a = RWST DatabaseContextIOEvalEnv () DatabaseContextEvalState IO a++runDatabaseContextIOEvalMonad :: DatabaseContextIOEvalEnv -> DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ()) -> IO (Either RelationalError DatabaseContextEvalState)+runDatabaseContextIOEvalMonad env ctx m = do+  res <- runRWST m env freshState+  case res of+    (Left err,_,_) -> pure (Left err)+    (Right (),s,_) -> pure (Right s)+  where+    freshState = mkDatabaseContextEvalState ctx++requireScriptSession :: DatabaseContextIOEvalMonad (Either RelationalError ScriptSession)+requireScriptSession = do+  env <- RWS.ask+  case dbcio_mScriptSession env of+    Nothing -> pure $ Left $ ScriptError ScriptCompilationDisabledError+    Just ss -> pure (Right ss)++putDBCIOContext :: DatabaseContext -> DatabaseContextIOEvalMonad (Either RelationalError ())+putDBCIOContext ctx = do+  RWS.modify (\dbstate -> dbstate { dbc_context = ctx})+  pure (Right ())++getDBCIOContext :: DatabaseContextIOEvalMonad DatabaseContext+getDBCIOContext = dbc_context <$> RWS.get++getDBCIORelationalExprEnv :: DatabaseContextIOEvalMonad RelationalExprEnv+getDBCIORelationalExprEnv = do+  context <- getDBCIOContext+  mkRelationalExprEnv context . dbcio_graph <$> RWS.ask++evalGraphRefDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())+#if !defined(PM36_HASKELL_SCRIPTING)+evalGraphRefDatabaseContextIOExpr AddAtomFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))+evalGraphRefDatabaseContextIOExpr AddDatabaseContextFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))+evalGraphRefDatabaseContextIOExpr LoadAtomFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))+evalGraphRefDatabaseContextIOExpr LoadDatabaseContextFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))+#else+evalGraphRefDatabaseContextIOExpr (AddAtomFunction funcName funcType script) = do+  eScriptSession <- requireScriptSession+  currentContext <- getDBCIOContext+  case eScriptSession of+    Left err -> pure (Left err)+    Right scriptSession -> do+      res <- liftIO $ try $ runGhc (Just libdir) $ do+        setSession (hscEnv scriptSession)+        let atomFuncs = atomFunctions currentContext+        case extractAtomFunctionType funcType of+          Left err -> pure (Left err)+          Right adjustedAtomTypeCons -> do+            --compile the function+            eCompiledFunc  <- compileScript (atomFunctionBodyType scriptSession) script+            pure $ case eCompiledFunc of+              Left err -> Left (ScriptError err)+              Right compiledFunc -> do+                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 }+               -- check if the name is already in use+                if HS.member funcName (HS.map atomFuncName atomFuncs) then+                  Left (FunctionNameInUseError funcName)+                  else +                  Right newContext+      case res of+        Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))+        Right eContext -> case eContext of+          Left err -> pure (Left err)+          Right context' -> putDBCIOContext context'+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+          dbContextTypeCons = ADTypeConstructor "Either" [ADTypeConstructor "DatabaseContextFunctionError" [], ADTypeConstructor "DatabaseContext" []]+          expectedType = "DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext"+          actualType = show funcType+      if last2Args /= [ADTypeConstructor "DatabaseContext" [], dbContextTypeCons] then +        pure (Left (ScriptError (TypeCheckCompilationError expectedType actualType)))+        else do+        res <- liftIO $ try $ runGhc (Just libdir) $ do+          setSession (hscEnv scriptSession)+          eCompiledFunc  <- compileScript (dbcFunctionBodyType scriptSession) script+          pure $ case eCompiledFunc of        +            Left err -> Left (ScriptError err)+            Right compiledFunc -> do+              --if we are here, we have validated that the written function type is X -> DatabaseContext -> DatabaseContext, so we need to munge the first elements into an array+              funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) atomArgs+              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+                    }+                -- check if the name is already in use                                              +              if HS.member funcName (HS.map dbcFuncName dbcFuncs) then+                Left (FunctionNameInUseError funcName)+                else +                Right newContext+        case res of+          Left (exc :: SomeException) -> pure $ Left (ScriptError (OtherScriptCompilationError (show exc)))+          Right eContext -> case eContext of+            Left err -> pure (Left err)+            Right context' -> putDBCIOContext context'+evalGraphRefDatabaseContextIOExpr (LoadAtomFunctions modName funcName modPath) = do+  currentContext <- getDBCIOContext+  eLoadFunc <- liftIO $ loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath+  case eLoadFunc of+    Left LoadSymbolError -> pure (Left LoadFunctionError)+    Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }+                                      mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)+                                  in putDBCIOContext newContext+evalGraphRefDatabaseContextIOExpr (LoadDatabaseContextFunctions modName funcName modPath) = do+  currentContext <- getDBCIOContext+  eLoadFunc <- liftIO $ loadDatabaseContextFunctions (T.unpack modName) (T.unpack funcName) modPath+  case eLoadFunc of+    Left LoadSymbolError -> pure (Left LoadFunctionError)+    Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }+                             mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)+                                  in putDBCIOContext newContext+evalGraphRefDatabaseContextIOExpr (CreateArbitraryRelation relVarName attrExprs range) = do+  --Define+  currentContext <- getDBCIOContext+  env <- RWS.ask+  --create graph ref expr+  let gfExpr = Define relVarName attrExprs+      evalEnv = mkDatabaseContextEvalEnv (dbcio_transId env) (dbcio_graph env)+      graph = dbcio_graph env+  case runDatabaseContextEvalMonad currentContext evalEnv (evalGraphRefDatabaseContextExpr gfExpr) of+    Left err -> pure (Left err)+    Right dbstate -> do+         --Assign+           let existingRelVar = M.lookup relVarName relVarTable+               relVarTable = relationVariables (dbc_context dbstate)+           case existingRelVar of+                Nothing -> pure $ Left (RelVarNotDefinedError relVarName)+                Just existingRel -> do+                  let gfEnv = freshGraphRefRelationalExprEnv (Just currentContext) graph+                  case runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr existingRel) of+                    Left err -> pure (Left err)+                    Right relType -> do+                      let expectedAttributes = attributes relType+                          tcMap = typeConstructorMapping (dbc_context dbstate)+                      eitherRel <- liftIO $ generate $ runReaderT (arbitraryRelation expectedAttributes range) tcMap+                      case eitherRel of+                        Left err -> pure $ Left err+                        Right rel ->+                          case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of+                            Left err -> pure (Left err)+                            Right dbstate' -> putDBCIOContext (dbc_context dbstate')+#endif+{-+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) =+  mapM_ (uncurry checkIncDep) (M.toList deps) +  where+    potentialGraph = TransactionGraph graphHeads (S.insert tempTrans transSet)+    tempStamp = UTCTime { utctDay = fromGregorian 2000 1 1,+                          utctDayTime = secondsToDiffTime 0 }+    tempSchemas = Schemas context M.empty+    tempTrans = Transaction U.nil (TransactionInfo (transId NE.:| []) tempStamp) tempSchemas+    +    deps = inclusionDependencies context+      -- no optimization available here, really? perhaps the optimizer should be passed down to here or the eval function should be passed through the environment+    checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do+      let process = runProcessExprM UncommittedContextMarker+          gfSubsetExpr = process (processRelationalExpr subsetExpr)+          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+      typeSub <- runGfRel (typeForGraphRefRelationalExpr gfSubsetExpr)+      typeSuper <- runGfRel (typeForGraphRefRelationalExpr gfSupersetExpr)+      when (typeSub /= typeSuper) (Left (RelationTypeMismatchError (attributes typeSub) (attributes typeSuper)))+      let checkExpr = Equals gfSupersetExpr (Union gfSubsetExpr gfSupersetExpr)+          gfEvald = runGraphRefRelationalExprM gfEnv' (evalGraphRefRelationalExpr checkExpr)+          gfEnv' = freshGraphRefRelationalExprEnv (Just context) potentialGraph+      case gfEvald of+        Left err -> Left err+        Right resultRel -> if resultRel == relationTrue then+                                   pure ()+                                else +                                  Left (InclusionDependencyCheckError depName)++-- the type of a relational expression is equal to the relation attribute set returned from executing the relational expression; therefore, the type can be cheaply derived by evaluating a relational expression and ignoring and tuple processing+-- furthermore, the type of a relational expression is the resultant header of the evaluated empty-tupled relation++typeForRelationalExpr :: RelationalExpr -> RelationalExprM Relation+typeForRelationalExpr expr = do+  --replace the relationVariables context element with a cloned set of relation devoid of tuples+  --evalRelationalExpr could still return an existing relation with tuples, so strip them+  graph <- reGraph+  context <- reContext+  let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)+      gfEnv = freshGraphRefRelationalExprEnv (Just context) graph+      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+  case y of+    Left err -> throwError err+    Right val -> pure val++{- used for restrictions- take the restrictionpredicate and return the corresponding filter function -}+predicateRestrictionFilter :: Attributes -> GraphRefRestrictionPredicateExpr -> GraphRefRelationalExprM RestrictionFilter+predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do+  expr1v <- predicateRestrictionFilter attrs expr1+  expr2v <- predicateRestrictionFilter attrs expr2+  pure (\x -> do+           ev1 <- expr1v x +           ev2 <- expr2v x+           pure (ev1 && ev2))++predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do+    expr1v <- predicateRestrictionFilter attrs expr1+    expr2v <- predicateRestrictionFilter attrs expr2+    pure (\x -> do+                ev1 <- expr1v x +                ev2 <- expr2v x+                pure (ev1 || ev2))++predicateRestrictionFilter _ TruePredicate = pure (\_ -> pure True)++predicateRestrictionFilter attrs (NotPredicate expr) = do+  exprv <- predicateRestrictionFilter attrs expr+  pure (fmap not . exprv)++--optimization opportunity: if the subexpression does not reference attributes in the top-level expression, then it need only be evaluated once, statically, outside the tuple filter- see historical implementation here+predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = do+  renv <- askEnv+  let eval :: RelationTuple -> Either RelationalError Relation+      eval tup = +        let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup renv in+        runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)+  pure (\tup -> case eval tup of+    Left err -> Left err+    Right rel -> if arity rel /= 0 then+                   Left (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")+                   else+                   pure (rel == relationTrue))++predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do+  env <- askEnv+  let attrs' = A.union attrs (envAttributes env)+      ctxtup' = envTuple env+  atomExprType <- typeForGraphRefAtomExpr attrs' atomExpr+  attr <- lift $ except $ case A.attributeForName attrName attrs of+      Right attr -> Right attr+      Left (NoSuchAttributeNamesError _) -> case A.attributeForName attrName (tupleAttributes ctxtup') of+        Right ctxattr -> Right ctxattr+        Left err2@(NoSuchAttributeNamesError _) -> Left err2+        Left err -> Left err+      Left err -> Left err+  if atomExprType /= A.atomType attr then+      throwError (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))+    else+      pure $ \tupleIn -> let evalAndCmp atomIn = case atomEvald of+                               Right atomCmp -> atomCmp == atomIn+                               Left _ -> False+                             atomEvald = runGraphRefRelationalExprM env (evalGraphRefAtomExpr tupleIn atomExpr)+                         in+                          pure $ case atomForAttributeName attrName tupleIn of+                            Left (NoSuchAttributeNamesError _) -> case atomForAttributeName attrName ctxtup' of+                              Left _ -> False+                              Right ctxatom -> evalAndCmp ctxatom+                            Left _ -> False+                            Right atomIn -> evalAndCmp atomIn+-- in the future, it would be useful to do typechecking on the attribute and atom expr filters in advance+predicateRestrictionFilter attrs (AtomExprPredicate atomExpr) = do+  --merge attrs into the state attributes+  renv <- askEnv+  aType <- typeForGraphRefAtomExpr attrs atomExpr+  if aType /= BoolAtomType then+      throwError (AtomTypeMismatchError aType BoolAtomType)+    else+      pure (\tupleIn ->+             case runGraphRefRelationalExprM renv (evalGraphRefAtomExpr tupleIn atomExpr) of+               Left err -> Left err+               Right boolAtomValue -> pure (boolAtomValue == BoolAtom True))++tupleExprCheckNewAttrName :: AttributeName -> Relation -> Either RelationalError Relation+tupleExprCheckNewAttrName attrName rel = if isRight (attributeForName attrName rel) then+                                           Left (AttributeNameInUseError attrName)+                                         else+                                           Right rel++extendGraphRefTupleExpressionProcessor :: Relation -> GraphRefExtendTupleExpr -> GraphRefRelationalExprM (Attributes, RelationTuple -> Either RelationalError RelationTuple)+extendGraphRefTupleExpressionProcessor relIn (AttributeExtendTupleExpr newAttrName atomExpr) = +--  renv <- askEnv+  -- check that the attribute name is not in use+  case tupleExprCheckNewAttrName newAttrName relIn of+    Left err -> throwError err+    Right _ -> do+      atomExprType <- typeForGraphRefAtomExpr (attributes relIn) atomExpr+      atomExprType' <- verifyGraphRefAtomExprTypes relIn atomExpr atomExprType+      let newAttrs = A.attributesFromList [Attribute newAttrName atomExprType']+          newAndOldAttrs = A.addAttributes (attributes relIn) newAttrs+      env <- ask+      pure (newAndOldAttrs, \tup -> do+               let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tup env+               atom <- runGraphRefRelationalExprM gfEnv (evalGraphRefAtomExpr tup atomExpr)+               Right (tupleAtomExtend newAttrName atom tup)+               )++evalGraphRefAtomExpr :: RelationTuple -> GraphRefAtomExpr -> GraphRefRelationalExprM Atom+evalGraphRefAtomExpr tupIn (AttributeAtomExpr attrName) =+  case atomForAttributeName attrName tupIn of+    Right atom -> pure atom+    Left err@(NoSuchAttributeNamesError _) -> do+      env <- askEnv+      case gre_extra env of+        Nothing -> throwError err+        Just (Left ctxtup) -> lift $ except $ atomForAttributeName attrName ctxtup+        Just (Right _) -> throwError err+    Left err -> throwError err+evalGraphRefAtomExpr _ (NakedAtomExpr atom) = pure atom+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+      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+      mapM_ (\(expType, actType) -> +                lift $ except (atomTypeVerify expType actType)) zippedArgs+      evaldArgs <- mapM (evalGraphRefAtomExpr tupIn) arguments+      case evalAtomFunction func evaldArgs of+        Left err -> throwError (AtomFunctionUserError err)+        Right result -> do+          --validate that the result matches the expected type+          _ <- lift $ except (atomTypeVerify (last (atomFuncType 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+  env <- ask+  let gfEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn env+  relAtom <- lift $ except $ runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr relExpr)+  pure (RelationAtom relAtom)+evalGraphRefAtomExpr tupIn cons@(ConstructedAtomExpr dConsName dConsArgs _) = do --why is the tid unused here? suspicious+  let mergeEnv = mergeTuplesIntoGraphRefRelationalExprEnv tupIn+  aType <- local mergeEnv (typeForGraphRefAtomExpr (tupleAttributes tupIn) cons)+  argAtoms <- local mergeEnv $+    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+  case A.atomTypeForAttributeName attrName attrs of+    Right aType -> pure aType+    Left err@(NoSuchAttributeNamesError _) ->+      let envTup = envTuple renv+          envAttrs = envAttributes renv in+      case A.attributeForName attrName envAttrs of+        Right attr -> pure (A.atomType attr)+        Left _ -> case atomForAttributeName attrName envTup of+          Right atom -> pure (atomTypeForAtom atom)+          Left _ -> --throwError (traceStack (show ("typeForGRAtomExpr", attrs, envTup)) err)+            throwError err+    Left err -> throwError err++typeForGraphRefAtomExpr _ (NakedAtomExpr atom) = pure (atomTypeForAtom atom)+typeForGraphRefAtomExpr attrs (FunctionAtomExpr funcName atomArgs transId) = do+  funcs <- atomFunctions <$> gfDatabaseContextForMarker transId+  case atomFunctionForName funcName funcs of+    Left err -> throwError err+    Right func -> do+      let funcRetType = last (atomFuncType func)+          funcArgTypes = init (atomFuncType 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+typeForGraphRefAtomExpr attrs (RelationAtomExpr relExpr) = do+  relType <- R.local (mergeAttributesIntoGraphRefRelationalExprEnv attrs) (typeForGraphRefRelationalExpr relExpr)+  pure (RelationAtomType (attributes relType))+-- grab the type of the data constructor, then validate that the args match the expected types+typeForGraphRefAtomExpr attrs (ConstructedAtomExpr dConsName dConsArgs tid) =+  do+    argsTypes <- mapM (typeForGraphRefAtomExpr attrs) dConsArgs+    tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid+    lift $ except $ atomTypeForDataConstructor tConsMap dConsName argsTypes++-- | Validate that the type of the AtomExpr matches the expected type.+verifyGraphRefAtomExprTypes :: Relation -> GraphRefAtomExpr -> AtomType -> GraphRefRelationalExprM AtomType+verifyGraphRefAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = do+  env <- askEnv+  case A.atomTypeForAttributeName attrName (attributes relIn) of+    Right aType -> lift $ except $ atomTypeVerify expectedType aType+    (Left err@(NoSuchAttributeNamesError _)) ->+      let attrs' = envAttributes env in+        if attrs' == emptyAttributes then+          throwError err+        else+          case A.attributeForName attrName attrs' of+            Left err' -> throwError err'+            Right attrType -> lift $ except $ atomTypeVerify expectedType (A.atomType attrType)+    Left err -> throwError err++verifyGraphRefAtomExprTypes _ (NakedAtomExpr atom) expectedType =+  lift $ except $ atomTypeVerify expectedType (atomTypeForAtom atom)+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+      funcArgVerifier (atomExpr, expectedType2, argCount) = do+        let handler :: RelationalError -> GraphRefRelationalExprM AtomType+            handler (AtomTypeMismatchError expSubType actSubType) = throwError (AtomFunctionTypeError funcName argCount expSubType actSubType)+            handler err = throwError err+        verifyGraphRefAtomExprTypes relIn atomExpr expectedType2 `catchError` handler            +  funcArgTypes <- mapM funcArgVerifier $ zip3 funcArgExprs expectedArgTypes [1..]+  if length funcArgTypes /= length expectedArgTypes - 1 then+      throwError (AtomTypeCountError funcArgTypes expectedArgTypes)+      else +      lift $ except $ atomTypeVerify expectedType (last expectedArgTypes)+verifyGraphRefAtomExprTypes relIn (RelationAtomExpr relationExpr) expectedType =+  do+    let mergedAttrsEnv e = mergeAttributesIntoGraphRefRelationalExprEnv (attributes relIn) e+    relType <- R.local mergedAttrsEnv (typeForGraphRefRelationalExpr relationExpr)+    lift $ except $ atomTypeVerify expectedType (RelationAtomType (attributes relType))+verifyGraphRefAtomExprTypes rel cons@ConstructedAtomExpr{} expectedType = do+  cType <- typeForGraphRefAtomExpr (attributes rel) cons+  lift $ except $ atomTypeVerify expectedType cType++-- | Look up the type's name and create a new attribute.+evalGraphRefAttrExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute+evalGraphRefAttrExpr (AttributeAndTypeNameExpr attrName tCons transId) = do+  tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker transId+  aType <- lift $ except $ atomTypeForTypeConstructorValidate True tCons tConsMap M.empty+  lift $ except $ validateAtomType aType tConsMap+  pure $ Attribute attrName aType+  +evalGraphRefAttrExpr (NakedAttributeExpr attr) = pure attr++-- for tuple type concrete resolution (Nothing ==> Maybe Int) when the attributes hint is Nothing, we need to first process all the tuples, then extract the concrete types on a per-attribute basis, then reprocess the tuples to include the concrete types+evalGraphRefTupleExprs :: Maybe Attributes -> GraphRefTupleExprs -> GraphRefRelationalExprM [RelationTuple]+evalGraphRefTupleExprs _ (TupleExprs _ []) = pure []+evalGraphRefTupleExprs mAttrs (TupleExprs fixedMarker tupleExprL) = do+  tuples <- mapM (evalGraphRefTupleExpr mAttrs) tupleExprL+  finalAttrs <- case mAttrs of+    Just attrs -> pure attrs+    Nothing ->+      case tuples of+        [] -> pure emptyAttributes+        (headTuple:tailTuples) -> do+      --gather up resolved atom types or throw an error if an attribute cannot be made concrete from the inferred types- this could still fail if the type cannot be inferred (e.g. from [Nothing, Nothing])+          let mostResolvedTypes =+                foldr (\tup acc ->+                         fmap (\(tupAttr,accAttr) -> --if the attribute is a constructedatomtype, we can recurse into it to potentially resolve type variables+                                 if isResolvedAttribute accAttr then+                                   accAttr+                                 else+                                   case resolveAttributes accAttr tupAttr of+                                     Left _ -> accAttr+                                     Right val -> val) (zip (V.toList $ tupleAttributes tup) acc)) (V.toList $ 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+                   SingularTransactionRef commonTransId -> +                     typeConstructorMapping <$> gfDatabaseContextForMarker commonTransId+                   NoTransactionsRef -> +                     typeConstructorMapping <$> gfDatabaseContextForMarker fixedMarker+  -- if there are multiple transaction markers in the TupleExprs, then we can't assume a single type constructor mapping- this could be improved in the future, but if all the tuples are fully resolved, then we don't need further resolution                     +                   _ -> throwError TupleExprsReferenceMultipleMarkersError+  lift $ except $ validateAttributes tConsMap finalAttrs+  mapM (lift . except . resolveTypesInTuple finalAttrs tConsMap) tuples+++--resolveAttributes (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",IntegerAtomType),("b",TypeVariableType "b")]))) (Attribute "gonk" (ConstructedAtomType "Either" (fromList [("a",TypeVariableType "a"),("b",TextAtomType)])))+                                                                                                                                                 +evalGraphRefTupleExpr :: Maybe Attributes -> GraphRefTupleExpr -> GraphRefRelationalExprM RelationTuple+evalGraphRefTupleExpr mAttrs (TupleExpr tupMap) = do+  -- it's not possible for AtomExprs in tuple constructors to reference other Attributes' atoms due to the necessary order-of-operations (need a tuple to pass to evalAtomExpr)- it may be possible with some refactoring of type usage or delayed evaluation- needs more thought, but not a priority+  -- I could adjust this logic so that when the attributes are not specified (Nothing), then I can attempt to extract the attributes from the tuple- the type resolution will blow up if an ambiguous data constructor is used (Left 4) and this should allow simple cases to "relation{tuple{a 4}}" to be processed+  let attrs = fromMaybe A.emptyAttributes mAttrs+      resolveOneAtom (attrName, aExpr) =+        do+          --provided when the relation header is available+          let eExpectedAtomType = A.atomTypeForAttributeName attrName attrs+          unresolvedType <- typeForGraphRefAtomExpr attrs aExpr+          resolvedType <- case eExpectedAtomType of+                            Left _ -> pure unresolvedType+                            Right typeHint -> lift $ except $ resolveAtomType typeHint unresolvedType+                          --resolve atom typevars based on resolvedType?+          newAtom <- evalGraphRefAtomExpr emptyTuple aExpr+          pure (attrName, newAtom, resolvedType)+  attrAtoms <- mapM resolveOneAtom (M.toList tupMap)+  let tupAttrs = A.attributesFromList $ map (\(attrName, _, aType) -> Attribute attrName aType) attrAtoms+      atoms = V.fromList $ map (\(_, atom, _) -> atom) attrAtoms+      tup = mkRelationTuple tupAttrs atoms+      finalAttrs = fromMaybe tupAttrs mAttrs+    --verify that the attributes match+  when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwError (TupleAttributeTypeMismatchError tupAttrs)+  --we can't resolve types here- they have to be resolved at the atom level where the graph ref is held+  --tup' <- lift $ except (resolveTypesInTuple finalAttrs tConss (reorderTuple finalAttrs tup))+  let tup' = reorderTuple finalAttrs tup+  --TODO: restore type resolution+--  _ <- 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+  mAttrs <- case mAttrExprs of+    Just _ ->+        Just . A.attributesFromList <$> mapM evalGraphRefAttrExpr (fromMaybe [] mAttrExprs)+    Nothing -> pure Nothing+  tuples <- evalGraphRefTupleExprs mAttrs tupleExprs+  let attrs = fromMaybe firstTupleAttrs mAttrs+      firstTupleAttrs = if null tuples then A.emptyAttributes else tupleAttributes (head tuples)+  lift $ except $ mkRelation attrs (RelationTupleSet tuples)+evalGraphRefRelationalExpr (MakeStaticRelation attributeSet tupleSet) = +  lift $ except $ mkRelation attributeSet tupleSet+evalGraphRefRelationalExpr (ExistingRelation rel) = pure rel+evalGraphRefRelationalExpr (RelationVariable name tid) = do+  ctx <- gfDatabaseContextForMarker tid+  case M.lookup name (relationVariables ctx) of+    Nothing -> throwError (RelVarNotDefinedError name)+    Just rv -> evalGraphRefRelationalExpr rv+evalGraphRefRelationalExpr (Project attrNames expr) = do+  attrNameSet <- evalGraphRefAttributeNames attrNames expr+  rel <- evalGraphRefRelationalExpr expr+  lift $ except $ project attrNameSet rel+evalGraphRefRelationalExpr (Union exprA exprB) = do+  relA <- evalGraphRefRelationalExpr exprA+  relB <- evalGraphRefRelationalExpr exprB+  lift $ except $ union relA relB+evalGraphRefRelationalExpr (Join exprA exprB) = do  +  relA <- evalGraphRefRelationalExpr exprA+  relB <- evalGraphRefRelationalExpr exprB+  lift $ except $ join relA relB+evalGraphRefRelationalExpr (Rename oldName newName expr) = do+  rel <- evalGraphRefRelationalExpr expr+  lift $ except $ rename oldName newName rel+evalGraphRefRelationalExpr (Difference exprA exprB) = do+  relA <- evalGraphRefRelationalExpr exprA+  relB <- evalGraphRefRelationalExpr exprB+  lift $ except $ difference relA relB+evalGraphRefRelationalExpr (Group groupAttrNames newAttrName expr) = do+  groupNames <- evalGraphRefAttributeNames groupAttrNames expr+  rel <- evalGraphRefRelationalExpr expr+  lift $ except $ group groupNames newAttrName rel+evalGraphRefRelationalExpr (Ungroup groupAttrName expr) = do+  rel <- evalGraphRefRelationalExpr expr+  lift $ except $ ungroup groupAttrName rel+evalGraphRefRelationalExpr (Restrict predExpr expr) = do+  rel <- evalGraphRefRelationalExpr expr+  filt <- predicateRestrictionFilter (attributes rel) predExpr+  lift $ except $ restrict filt rel+evalGraphRefRelationalExpr (Equals exprA exprB) = do+  relA <- evalGraphRefRelationalExpr exprA+  relB <- evalGraphRefRelationalExpr exprB+  pure $ if relA == relB then relationTrue else relationFalse+evalGraphRefRelationalExpr (NotEquals exprA exprB) = do+  relA <- evalGraphRefRelationalExpr exprA+  relB <- evalGraphRefRelationalExpr exprB+  pure $ if relA == relB then relationFalse else relationTrue+evalGraphRefRelationalExpr (Extend extendTupleExpr expr) = do+  rel <- evalGraphRefRelationalExpr expr+  (newAttrs, tupProc) <- extendGraphRefTupleExpressionProcessor rel extendTupleExpr+  lift $ except $ relMogrify tupProc newAttrs rel+evalGraphRefRelationalExpr expr@With{} =+  --strategy A: add relation variables to the contexts in the graph+  --strategy B: drop in macros in place (easier programmatically)+  --strategy B implementation+  evalGraphRefRelationalExpr (substituteWithNameMacros [] expr)++dbContextForTransId :: TransactionId -> TransactionGraph -> Either RelationalError DatabaseContext+dbContextForTransId tid graph = do+  trans <- transactionForId tid graph+  pure (concreteDatabaseContext trans)++transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction+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)++typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation+typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs emptyTupleSet+typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))+typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do+  mAttrs <- case mAttrExprs of+              Just attrExprs -> do+                attrs <- mapM evalGraphRefAttributeExpr attrExprs+                pure (Just (attributesFromList attrs))+              Nothing -> pure Nothing+  tuples <- evalGraphRefTupleExprs mAttrs tupleExprs+  let retAttrs = case tuples of+                (tup:_) -> tupleAttributes tup+                [] -> fromMaybe A.emptyAttributes mAttrs+  pure $ emptyRelationWithAttrs retAttrs+  +typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do+  relVars <- relationVariables <$> gfDatabaseContextForMarker tid+  case M.lookup rvName relVars of+    Nothing -> throwError (RelVarNotDefinedError rvName)+    Just rvExpr -> +      typeForGraphRefRelationalExpr rvExpr+typeForGraphRefRelationalExpr (Project attrNames expr) = do+  exprType' <- typeForGraphRefRelationalExpr expr+  projectionAttrs <- evalGraphRefAttributeNames attrNames expr+  lift $ except $ project projectionAttrs exprType'+typeForGraphRefRelationalExpr (Union exprA exprB) = do+  exprA' <- typeForGraphRefRelationalExpr exprA+  exprB' <- typeForGraphRefRelationalExpr exprB+  lift $ except $ union exprA' exprB'+typeForGraphRefRelationalExpr (Join exprA exprB) = do+  exprA' <- typeForGraphRefRelationalExpr exprA+  exprB' <- typeForGraphRefRelationalExpr exprB+  lift $ except $ join exprA' exprB'+typeForGraphRefRelationalExpr (Rename oldAttr newAttr expr) = do+  expr' <- typeForGraphRefRelationalExpr expr+  lift $ except $ rename oldAttr newAttr expr'+typeForGraphRefRelationalExpr (Difference exprA exprB) = do  +  exprA' <- typeForGraphRefRelationalExpr exprA+  exprB' <- typeForGraphRefRelationalExpr exprB+  lift $ except $ difference exprA' exprB'+typeForGraphRefRelationalExpr (Group groupNames attrName expr) = do+  expr' <- typeForGraphRefRelationalExpr expr+  groupNames' <- evalGraphRefAttributeNames groupNames expr+  lift $ except $ group groupNames' attrName expr'+typeForGraphRefRelationalExpr (Ungroup groupAttrName expr) = do+  expr' <- typeForGraphRefRelationalExpr expr+  lift $ except $ ungroup groupAttrName expr'+typeForGraphRefRelationalExpr (Restrict pred' expr) = do+  expr' <- typeForGraphRefRelationalExpr expr+  filt <- predicateRestrictionFilter (attributes expr') pred'+  lift $ except $ restrict filt expr'+typeForGraphRefRelationalExpr Equals{} = +  pure relationFalse+typeForGraphRefRelationalExpr NotEquals{} = +  pure relationFalse+typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do+  rel <- typeForGraphRefRelationalExpr expr+  evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))+typeForGraphRefRelationalExpr expr@(With withs _) = do+  let expr' = substituteWithNameMacros [] expr+      checkMacroName (WithNameExpr macroName tid) = do+        rvs <- relationVariables <$> gfDatabaseContextForMarker tid+        case M.lookup macroName rvs of+          Just _ -> lift $ except $ Left (RelVarAlreadyDefinedError macroName) --this error does not include the transaction marker, but should be good enough to identify the cause+          Nothing -> pure ()+  mapM_ (checkMacroName . fst) withs+  typeForGraphRefRelationalExpr expr'+  +evalGraphRefAttributeNames :: GraphRefAttributeNames -> GraphRefRelationalExpr -> GraphRefRelationalExprM (S.Set AttributeName)+evalGraphRefAttributeNames attrNames expr = do+  exprType' <- typeForGraphRefRelationalExpr expr+  let typeNameSet = S.fromList (V.toList (A.attributeNames (attributes exprType')))+  case attrNames of+    AttributeNames names ->+      case A.projectionAttributesForNames names (attributes exprType') of+        Left err -> throwError err+        Right attrs -> pure (S.fromList (V.toList (A.attributeNames attrs)))+          +    InvertedAttributeNames names -> do+          let nonExistentAttributeNames = A.attributeNamesNotContained names typeNameSet+          if not (S.null nonExistentAttributeNames) then+            throwError $ AttributeNamesMismatchError nonExistentAttributeNames+            else+            pure (A.nonMatchingAttributeNameSet names typeNameSet)+        +    UnionAttributeNames namesA namesB -> do+      nameSetA <- evalGraphRefAttributeNames namesA expr+      nameSetB <- evalGraphRefAttributeNames namesB expr+      pure (S.union nameSetA nameSetB)+        +    IntersectAttributeNames namesA namesB -> do+      nameSetA <- evalGraphRefAttributeNames namesA expr+      nameSetB <- evalGraphRefAttributeNames namesB expr+      pure (S.intersection nameSetA nameSetB)+        +    RelationalExprAttributeNames attrExpr -> do+      attrExprType <- typeForGraphRefRelationalExpr attrExpr+      pure (A.attributeNameSet (attributes attrExprType))++evalGraphRefAttributeExpr :: GraphRefAttributeExpr -> GraphRefRelationalExprM Attribute+evalGraphRefAttributeExpr (AttributeAndTypeNameExpr attrName tCons tid) = do+  tConsMap <- typeConstructorMapping <$> gfDatabaseContextForMarker tid+  case atomTypeForTypeConstructorValidate True tCons tConsMap M.empty of+    Left err -> throwError err+    Right aType -> do+      case validateAtomType aType tConsMap of+        Left err -> throwError err+        Right _ -> pure (Attribute attrName aType)+evalGraphRefAttributeExpr (NakedAttributeExpr attr) = pure attr        ++mkEmptyRelVars :: RelationVariables -> RelationVariables+mkEmptyRelVars = M.map mkEmptyRelVar+  where+    mkEmptyRelVar expr@MakeRelationFromExprs{} = expr --do not truncate here because we might lose essential type information in emptying the tuples+    mkEmptyRelVar (MakeStaticRelation attrs _) = MakeStaticRelation attrs emptyTupleSet+    mkEmptyRelVar (ExistingRelation rel) = ExistingRelation (emptyRelationWithAttrs (attributes rel))+    mkEmptyRelVar rv@RelationVariable{} = Restrict (NotPredicate TruePredicate) rv+    mkEmptyRelVar (Project attrNames expr) = Project attrNames (mkEmptyRelVar expr)+    mkEmptyRelVar (Union exprA exprB) = Union (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)+    mkEmptyRelVar (Join exprA exprB) = Join (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)+    mkEmptyRelVar (Rename nameA nameB expr) = Rename nameA nameB (mkEmptyRelVar expr)+    mkEmptyRelVar (Difference exprA exprB) = Difference (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)+    mkEmptyRelVar (Group attrNames attrName expr) = Group attrNames attrName (mkEmptyRelVar expr)+    mkEmptyRelVar (Ungroup attrName expr) = Ungroup attrName (mkEmptyRelVar expr)+    mkEmptyRelVar (Restrict pred' expr) = Restrict pred' (mkEmptyRelVar expr)+    mkEmptyRelVar (Equals exprA exprB) = Equals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)+    mkEmptyRelVar (NotEquals exprA exprB) = NotEquals (mkEmptyRelVar exprA) (mkEmptyRelVar exprB)+    mkEmptyRelVar (Extend extTuple expr) = Extend extTuple (mkEmptyRelVar expr)+    mkEmptyRelVar (With macros expr) = With (map (second mkEmptyRelVar) macros) (mkEmptyRelVar expr)+++dbErr :: RelationalError -> DatabaseContextEvalMonad ()+dbErr err = lift (except (Left err))+      +-- | Return a Relation describing the relation variables.+relationVariablesAsRelation :: DatabaseContext -> TransactionGraph -> Either RelationalError Relation+relationVariablesAsRelation ctx graph = do+  let subrelAttrs = A.attributesFromList [Attribute "attribute" TextAtomType, Attribute "type" TextAtomType]+      attrs = A.attributesFromList [Attribute "name" TextAtomType,+                                  Attribute "attributes" (RelationAtomType subrelAttrs)]+      relVars = relationVariables ctx+      mkRvDesc (rvName, gfExpr) = do+        let gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph+        gfType <- runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr gfExpr)+        pure (rvName, gfType)+      relVarToAtomList (rvName, rel) = [TextAtom rvName, attributesToRel (attributes rel)]+      attrAtoms a = [TextAtom (A.attributeName a), TextAtom (prettyAtomType (A.atomType a))]+      attributesToRel attrl = case mkRelationFromList subrelAttrs (map attrAtoms (V.toList attrl)) of+        Left err -> error ("relationVariablesAsRelation pooped " ++ show err)+        Right rel -> RelationAtom rel+  rvs <- mapM mkRvDesc (M.toList relVars)+  let tups = map relVarToAtomList rvs+  mkRelationFromList attrs tups++-- | An unoptimized variant of evalGraphRefRelationalExpr for testing.+evalRelationalExpr :: RelationalExpr -> RelationalExprM Relation+evalRelationalExpr expr = do+  graph <- reGraph+  context <- reContext+  let expr' = runProcessExprM UncommittedContextMarker (processRelationalExpr expr)+      gfEnv = freshGraphRefRelationalExprEnv (Just context) graph+  case runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr expr') of+    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+  +instance DatabaseContextM (ReaderT GraphRefRelationalExprEnv (ExceptT RelationalError Identity)) where+  getContext = gfDatabaseContextForMarker UncommittedContextMarker++instance DatabaseContextM (RWST DatabaseContextEvalEnv () DatabaseContextEvalState (ExceptT RelationalError Identity)) where+  getContext = getStateContext+    +relVarByName :: DatabaseContextM m => RelVarName -> m GraphRefRelationalExpr+relVarByName rvName = do+  relvars <- relationVariables <$> getContext  +  case M.lookup rvName relvars of+    Nothing -> throwError (RelVarNotDefinedError rvName)+    Just gfexpr -> pure gfexpr+

src/lib/ProjectM36/ScriptSession.hs view

@@ -1,8 +1,12 @@-{-# LANGUAGE MagicHash, UnboxedTuples, KindSignatures, DataKinds #-}+{-# LANGUAGE UnboxedTuples, KindSignatures, DataKinds #-}+#ifdef PM36_HASKELL_SCRIPTING+{-# LANGUAGE MagicHash #-}+#endif module ProjectM36.ScriptSession where +#ifdef PM36_HASKELL_SCRIPTING import ProjectM36.Error-+import GHC import Control.Exception import Control.Monad import System.IO.Error@@ -13,8 +17,6 @@ import System.Info (os, arch) import Data.Text (Text, unpack) import Data.Maybe--import GHC import GHC.Paths (libdir) #if __GLASGOW_HASKELL__ >= 800 import GHC.LanguageExtensions@@ -36,22 +38,38 @@ import Type hiding (pprTyThing) #else #endif- import GHC.Exts (addrToAny#) import GHC.Ptr (Ptr(..)) import Encoding+#endif + data ScriptSession = ScriptSession {+#ifdef PM36_HASKELL_SCRIPTING   hscEnv :: HscEnv,   atomFunctionBodyType :: Type,   dbcFunctionBodyType :: Type+#endif   } -newtype ScriptSessionError = ScriptSessionLoadError GhcException+#ifdef PM36_HASKELL_SCRIPTING+data ScriptSessionError = ScriptSessionLoadError GhcException+                        | ScriptingDisabled                           deriving (Show)+#else+data ScriptSessionError = ScriptingDisabled+  deriving (Show)+#endif +data LoadSymbolError = LoadSymbolError+type ModName = String+type FuncName = String+ -- | Configure a GHC environment/session which we will use for all script compilation. initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)+#if !defined(PM36_HASKELL_SCRIPTING)+initScriptSession _ = pure (Left ScriptingDisabled)+#else initScriptSession ghcPkgPaths = do     --for the sake of convenience, for developers' builds, include the local cabal sandbox package database and the cabal new-build package database   eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory@@ -62,13 +80,13 @@     let ghcVersion = projectVersion dflags      sandboxPkgPaths <- liftIO $ concat <$> mapM glob [-      "./dist-newstyle/packagedb/ghc-" ++ ghcVersion,+      --"./dist-newstyle/packagedb/ghc-" ++ ghcVersion, --rely on cabal 3's ghc.environment install: "cabal install --lib project-m36"       ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d",       ".stack-work/install/*/*/" ++ ghcVersion ++ "/pkgdb",       ".stack-work/install/*/pkgdb/", --windows stack build       "C:/sr/snapshots/b201cfe6/pkgdb", --windows stack build- ideally, we could run `stack path --snapshot-pkg-db, but this is sufficient to pass CI-      homeDir </> ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb",-      homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"+      homeDir </> ".stack/snapshots/*/*/" ++ ghcVersion ++ "/pkgdb"+      --homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"       ]      let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)@@ -170,7 +188,7 @@ addImport :: String -> Ghc () addImport moduleNam = do   ctx <- getContext-  setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )+  setContext (IIDecl (simpleImportDecl (mkModuleName moduleNam)) : ctx)  showType :: DynFlags -> Type -> String showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)@@ -223,11 +241,6 @@       maybe "" (\p -> zEncodeString p ++ "_") pkg ++       zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure" -type ModName = String-type FuncName = String--data LoadSymbolError = LoadSymbolError- loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a) loadFunction modName funcName objPath = do #if __GLASGOW_HASKELL__ >= 802@@ -252,3 +265,4 @@       ("darwin",_) -> "_"       ("cygwin",_) -> "_"       _ -> ""+#endif

src/lib/ProjectM36/Server.hs view

@@ -8,7 +8,11 @@ import ProjectM36.FSType  import Control.Monad.IO.Class (liftIO)+#if MIN_VERSION_network_transport_tcp(0,7,0)+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)  +#else import Network.Transport.TCP (createTransport, defaultTCPParameters)+#endif import Network.Transport (EndPointAddress(..), newEndPoint, address) import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable) import Control.Distributed.Process.Extras.Time (Delay(..))@@ -113,7 +117,9 @@         Right conn -> do           let hostname = bindHost daemonConfig               port = bindPort daemonConfig-#if MIN_VERSION_network_transport_tcp(0,6,0)                +#if MIN_VERSION_network_transport_tcp(0,7,0)+          etransport <- createTransport (defaultTCPAddr hostname (show port)) defaultTCPParameters+#elif MIN_VERSION_network_transport_tcp(0,6,0)                           etransport <- createTransport hostname (show port) (\nam -> (hostname, nam)) defaultTCPParameters               #else                                   etransport <- createTransport hostname (show port) defaultTCPParameters

src/lib/ProjectM36/Server/EntryPoints.hs view

@@ -8,12 +8,13 @@ import Control.Distributed.Process.ManagedProcess (ProcessReply) import Control.Distributed.Process.ManagedProcess.Server (reply) import Control.Distributed.Process.Async (async, task, waitCancelTimeout, AsyncResult(..))-import Control.Distributed.Process.Serializable (Serializable) import Control.Monad.IO.Class (liftIO) import Data.Map import Control.Concurrent (threadDelay)+import Data.Typeable+import Data.Binary -timeoutOrDie :: Serializable a => Timeout -> IO a -> Process (Either ServerError a)+timeoutOrDie :: (Binary a, Typeable a) => Timeout -> IO a -> Process (Either ServerError a) timeoutOrDie micros act =    if micros == 0 then     liftIO act >>= \x -> pure (Right x)@@ -83,7 +84,7 @@   ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)   reply ret conn   -handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError DatabaseContextExpr)+handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError GraphRefDatabaseContextExpr) handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do   ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)   reply ret conn

src/lib/ProjectM36/Session.hs view

@@ -3,6 +3,7 @@ import Data.UUID import qualified Data.Map as M import ProjectM36.Error+import qualified ProjectM36.DisconnectedTransaction as Discon  type SessionId = UUID @@ -18,7 +19,7 @@ disconnectedTransaction (Session discon _) = discon  isDirty :: Session -> DirtyFlag-isDirty (Session (DisconnectedTransaction _ _ dirtyFlag) _) = dirtyFlag+isDirty (Session discon _) = Discon.isDirty discon  concreteDatabaseContext :: Session -> DatabaseContext concreteDatabaseContext (Session (DisconnectedTransaction _ (Schemas context _) _) _) = context

src/lib/ProjectM36/Sessions.hs view

@@ -7,7 +7,7 @@ #else import qualified STMContainers.Map as StmMap import qualified STMContainers.Set as StmSet-#endif+#endif  import ProjectM36.Attribute import ProjectM36.Base import ProjectM36.Session

src/lib/ProjectM36/StaticOptimizer.hs view

@@ -1,289 +1,402 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} module ProjectM36.StaticOptimizer where import ProjectM36.Base-import ProjectM36.RelationalExpression+import ProjectM36.GraphRefRelationalExpr import ProjectM36.Relation+import ProjectM36.RelationalExpression+import ProjectM36.TransGraphRelationalExpression as TGRE hiding (askGraph) import ProjectM36.Error+import ProjectM36.Transaction+import ProjectM36.NormalizeExpr import qualified ProjectM36.Attribute as A import qualified ProjectM36.AttributeNames as AS import ProjectM36.TupleSet import Control.Monad.State-import Data.Either (rights, lefts)-import Control.Monad.Trans.Reader+import Control.Monad.Reader+import Control.Monad.Except+import Control.Monad.Trans.Except+import Data.Functor.Identity import qualified Data.Map as M import qualified Data.Set as S  -- the static optimizer performs optimizations which need not take any specific-relation statistics into account-optimizeRelationalExpr :: DatabaseContext -> RelationalExpr -> Either RelationalError RelationalExpr-optimizeRelationalExpr context expr = runReader (optimizeRelationalExprReader expr) (mkRelationalExprState context)-              -optimizeRelationalExprReader :: RelationalExpr -> RelationalExprState (Either RelationalError RelationalExpr)              -optimizeRelationalExprReader expr = do-  eOptExpr <- applyStaticRelationalOptimization expr++--import Debug.Trace++data GraphRefSOptRelationalExprEnv =+  GraphRefSOptRelationalExprEnv+  {+    ore_graph :: TransactionGraph,+    ore_mcontext :: Maybe DatabaseContext+  }+  +type GraphRefSOptRelationalExprM a = ReaderT GraphRefSOptRelationalExprEnv (ExceptT RelationalError Identity) a++data GraphRefSOptDatabaseContextExprEnv =+  GraphRefSOptDatabaseContextExprEnv+  {+    odce_graph :: TransactionGraph,+    odce_context :: DatabaseContext, --not optional for DatabaseContextExpr evaluation+    odce_transId :: TransactionId -- parent if context is committed- needed because MultipleExpr optimization requires running the DatabaseContextExprs (with empty relvars)+    }++type GraphRefSOptDatabaseContextExprM a = ReaderT GraphRefSOptDatabaseContextExprEnv (ExceptT RelationalError Identity) a++-- | A temporary function to be replaced by IO-based implementation.+optimizeAndEvalRelationalExpr :: RelationalExprEnv -> RelationalExpr -> Either RelationalError Relation+optimizeAndEvalRelationalExpr env expr = do+  let gfExpr = runProcessExprM UncommittedContextMarker (processRelationalExpr expr) -- references parent tid instead of context! options- I could add the context to the graph with a new transid or implement an evalRelationalExpr in RE.hs to use the context (which is what I had previously)+      graph = re_graph env+      ctx = re_context env+      gfEnv = freshGraphRefRelationalExprEnv (Just ctx) graph+  optExpr <- runGraphRefSOptRelationalExprM (Just ctx) (re_graph env) (fullOptimizeGraphRefRelationalExpr gfExpr)+  runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)++class Monad m => AskGraphContext m where+  askGraph :: m TransactionGraph+  askContext :: m DatabaseContext++instance AskGraphContext (ReaderT GraphRefSOptDatabaseContextExprEnv (ExceptT RelationalError Identity)) where+  askGraph = asks odce_graph+  askContext = asks odce_context ++instance AskGraphContext (ReaderT GraphRefSOptRelationalExprEnv (ExceptT RelationalError Identity)) where+  askGraph = asks ore_graph+  askContext = do+    mctx <- asks ore_mcontext+    case mctx of+      Nothing -> throwError NoUncommittedContextInEvalError+      Just ctx -> pure ctx++askTransId :: GraphRefSOptDatabaseContextExprM TransactionId+askTransId = asks odce_transId++askMaybeContext :: GraphRefSOptRelationalExprM (Maybe DatabaseContext)+askMaybeContext = asks ore_mcontext++optimizeDatabaseContextExpr :: DatabaseContextExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextExpr+optimizeDatabaseContextExpr expr = do+  let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)+  optimizeGraphRefDatabaseContextExpr gfExpr+  +optimizeAndEvalDatabaseContextExpr :: Bool -> DatabaseContextExpr -> DatabaseContextEvalMonad ()+optimizeAndEvalDatabaseContextExpr optimize expr = do+  graph <- asks dce_graph+  transId <- asks dce_transId+  context <- getStateContext+  let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextExpr expr)+      eOptExpr = if optimize then+                   runGraphRefSOptDatabaseContextExprM transId context graph (optimizeGraphRefDatabaseContextExpr gfExpr)+                   else+                   pure gfExpr   case eOptExpr of+    Left err -> throwError err+    Right optExpr -> evalGraphRefDatabaseContextExpr optExpr+++optimizeAndEvalTransGraphRelationalExpr :: TransactionGraph -> TransGraphRelationalExpr -> Either RelationalError Relation+optimizeAndEvalTransGraphRelationalExpr graph tgExpr = do+  gfExpr <- TGRE.process (TransGraphEvalEnv graph) tgExpr+  optExpr <- runGraphRefSOptRelationalExprM Nothing graph (fullOptimizeGraphRefRelationalExpr gfExpr)+  let gfEnv = freshGraphRefRelationalExprEnv Nothing graph+  runGraphRefRelationalExprM gfEnv (evalGraphRefRelationalExpr optExpr)++optimizeAndEvalDatabaseContextIOExpr :: DatabaseContextIOExpr -> DatabaseContextIOEvalMonad (Either RelationalError ())+optimizeAndEvalDatabaseContextIOExpr expr = do+  transId <- asks dbcio_transId+  ctx <- getDBCIOContext+  graph <- asks dbcio_graph+  let gfExpr = runProcessExprM UncommittedContextMarker (processDatabaseContextIOExpr expr)+      eOptExpr = runGraphRefSOptDatabaseContextExprM transId ctx graph (optimizeDatabaseContextIOExpr gfExpr)+  case eOptExpr of     Left err -> pure (Left err)     Right optExpr ->-      applyStaticJoinElimination (applyStaticRestrictionPushdown (applyStaticRestrictionCollapse optExpr))+      evalGraphRefDatabaseContextIOExpr optExpr -optimizeDatabaseContextExpr :: DatabaseContext -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr-optimizeDatabaseContextExpr context dbExpr = evalState (applyStaticDatabaseOptimization dbExpr) (freshDatabaseState context)+{-  +runStaticOptimizerMonad :: RelationalExprEnv -> StaticOptimizerMonad a -> Either RelationalError a+runStaticOptimizerMonad env m = runIdentity (runExceptT (runReaderT m env))+-}++runGraphRefSOptRelationalExprM ::+  Maybe DatabaseContext ->  +  TransactionGraph ->+  GraphRefSOptRelationalExprM a ->+  Either RelationalError a+runGraphRefSOptRelationalExprM mctx graph m = runIdentity (runExceptT (runReaderT m env))+  where+    env = GraphRefSOptRelationalExprEnv {+      ore_graph = graph,+      ore_mcontext = mctx+      }+  ++runGraphRefSOptDatabaseContextExprM ::+  TransactionId ->+  DatabaseContext ->+  TransactionGraph ->+  GraphRefSOptDatabaseContextExprM a ->+  Either RelationalError a+runGraphRefSOptDatabaseContextExprM tid ctx graph m =+  runIdentity (runExceptT (runReaderT m env))+  where+    env = GraphRefSOptDatabaseContextExprEnv {+      odce_graph = graph,+      odce_context = ctx,+      odce_transId = tid+      }++optimizeGraphRefRelationalExpr' ::+  Maybe DatabaseContext ->+  TransactionGraph ->+  GraphRefRelationalExpr ->+  Either RelationalError GraphRefRelationalExpr+optimizeGraphRefRelationalExpr' mctx graph expr =+  runIdentity (runExceptT (runReaderT (optimizeGraphRefRelationalExpr expr) env))+  where+    env = GraphRefSOptRelationalExprEnv {+      ore_graph = graph,+      ore_mcontext = mctx+      }++-- | optimize relational expression within database context expr monad+liftGraphRefRelExpr :: GraphRefSOptRelationalExprM a -> GraphRefSOptDatabaseContextExprM a+liftGraphRefRelExpr m = do+  context <- asks odce_context+  graph <- asks odce_graph+  lift $ except $ runGraphRefSOptRelationalExprM (Just context) graph m+  +fullOptimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr+fullOptimizeGraphRefRelationalExpr expr = do+  optExpr <- optimizeGraphRefRelationalExpr expr+  let optExpr' = applyStaticRestrictionPushdown (applyStaticRestrictionCollapse optExpr)+  applyStaticJoinElimination optExpr'+ -- apply optimizations which merely remove steps to become no-ops: example: projection of a relation across all of its attributes => original relation  --should optimizations offer the possibility to pure errors? If they perform the up-front type-checking, maybe so-applyStaticRelationalOptimization :: RelationalExpr -> RelationalExprState (Either RelationalError RelationalExpr)-applyStaticRelationalOptimization e@(MakeStaticRelation _ _) = pure $ Right e+optimizeGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr+optimizeGraphRefRelationalExpr e@(MakeStaticRelation _ _) = pure e -applyStaticRelationalOptimization e@(MakeRelationFromExprs _ _) = pure $ Right e+optimizeGraphRefRelationalExpr e@(MakeRelationFromExprs _ _) = pure e -applyStaticRelationalOptimization e@(ExistingRelation _) = pure $ Right e+optimizeGraphRefRelationalExpr e@(ExistingRelation _) = pure e -applyStaticRelationalOptimization e@(RelationVariable _ _) = pure $ Right e+optimizeGraphRefRelationalExpr e@(RelationVariable _ _) = pure e    --remove project of attributes which removes no attributes-applyStaticRelationalOptimization (Project attrNameSet expr) = do-  relType <- typeForRelationalExpr expr+optimizeGraphRefRelationalExpr (Project attrNameSet expr) = do+  graph <- askGraph+  mctx <- askMaybeContext+  let relType = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)+      gfEnv = freshGraphRefRelationalExprEnv mctx graph   case relType of-    Left err -> pure $ Left err+    Left err -> throwError err     Right relType2 -      | AS.all == attrNameSet ->                -        applyStaticRelationalOptimization expr+      | AS.all == attrNameSet ->        +        optimizeGraphRefRelationalExpr expr       | AttributeNames (attributeNames relType2) == attrNameSet ->-        applyStaticRelationalOptimization expr+        optimizeGraphRefRelationalExpr expr       | otherwise -> do-        optimizedSubExpression <- applyStaticRelationalOptimization expr -        case optimizedSubExpression of-          Left err -> pure $ Left err-          Right optSubExpr -> pure (Right (Project attrNameSet optSubExpr))+        optSubExpr <- optimizeGraphRefRelationalExpr expr +        pure (Project attrNameSet optSubExpr)                            -applyStaticRelationalOptimization (Union exprA exprB) = do-  eOptExprA <- applyStaticRelationalOptimization exprA-  eOptExprB <- applyStaticRelationalOptimization exprB-  case eOptExprA of -    Left err -> pure $ Left err-    Right optExprA -> case eOptExprB of-      Left err -> pure $ Left err-      Right optExprB -> -- (x where pred1) union (x where pred2) -> (x where pred1 or pred2)-        case (optExprA, optExprB) of -          (Restrict predA (RelationVariable nameA ()),-           Restrict predB (RelationVariable nameB ())) | nameA == nameB -> pure (Right (Restrict (AndPredicate predA predB) (RelationVariable nameA ())))+optimizeGraphRefRelationalExpr (Union exprA exprB) = do+  optExprA <- optimizeGraphRefRelationalExpr exprA+  optExprB <- optimizeGraphRefRelationalExpr exprB+  -- (x where pred1) union (x where pred2) -> (x where pred1 or pred2)+  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))           _ -> if optExprA == optExprB then           -            pure (Right optExprA)+            pure optExprA             else-            pure $ Right $ Union optExprA optExprB+            pure $ Union optExprA optExprB                             -applyStaticRelationalOptimization (Join exprA exprB) = do-  eOptExprA <- applyStaticRelationalOptimization exprA-  eOptExprB <- applyStaticRelationalOptimization exprB-  case eOptExprA of-    Left err -> pure $ Left err-    Right optExprA -> case eOptExprB of-      Left err -> pure $ Left err-      Right optExprB -> -        -- if the relvars to join are the same but with predicates, then just AndPredicate the predicates-        case (optExprA, optExprB) of-          (Restrict predA (RelationVariable nameA ()),-           Restrict predB (RelationVariable nameB ())) | nameA == nameB -> pure (Right (Restrict  (AndPredicate predA predB) (RelationVariable nameA ())))+optimizeGraphRefRelationalExpr (Join exprA exprB) = do+  optExprA <- optimizeGraphRefRelationalExpr exprA+  optExprB <- optimizeGraphRefRelationalExpr exprB+  -- if the relvars to join are the same but with predicates, then just AndPredicate the predicates+  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))           _ -> if optExprA == optExprB then --A join A == A-                           pure (Right optExprA)+                           pure optExprA                          else-                           pure (Right (Join optExprA optExprB))+                           pure (Join optExprA optExprB)                            -applyStaticRelationalOptimization (Difference exprA exprB) = do-  optExprA <- applyStaticRelationalOptimization exprA-  optExprB <- applyStaticRelationalOptimization exprB-  case optExprA of-    Left err -> pure $ Left err-    Right optExprA2 -> case optExprB of-      Left err -> pure $ Left err-      Right optExprB2 -> if optExprA == optExprB then do --A difference A == A where false-                           eEmptyRel <- typeForRelationalExpr optExprA2-                           case eEmptyRel of-                             Left err -> pure (Left err)-                             Right emptyRel -> pure (Right (ExistingRelation emptyRel))-                         else-                           pure $ Right (Difference optExprA2 optExprB2)+optimizeGraphRefRelationalExpr (Difference exprA exprB) = do+  graph <- askGraph+  context <- askMaybeContext+  optExprA <- optimizeGraphRefRelationalExpr exprA+  optExprB <- optimizeGraphRefRelationalExpr exprB+  if optExprA == optExprB then do --A difference A == A where false+    let eEmptyRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr optExprA)+        gfEnv = freshGraphRefRelationalExprEnv context graph+    case eEmptyRel of+      Left err -> throwError err+      Right emptyRel -> pure (ExistingRelation emptyRel)+    else+    pure (Difference optExprA optExprB)                            -applyStaticRelationalOptimization e@Rename{} = pure $ Right e+optimizeGraphRefRelationalExpr e@Rename{} = pure e -applyStaticRelationalOptimization (Group oldAttrNames newAttrName expr) =-  pure $ Right $ Group oldAttrNames newAttrName expr+optimizeGraphRefRelationalExpr (Group oldAttrNames newAttrName expr) =+  pure $ Group oldAttrNames newAttrName expr   -applyStaticRelationalOptimization (Ungroup attrName expr) =-  pure $ Right $ Ungroup attrName expr+optimizeGraphRefRelationalExpr (Ungroup attrName expr) =+  pure $ Ungroup attrName expr    --remove restriction of nothing-applyStaticRelationalOptimization (Restrict predicate expr) = do+optimizeGraphRefRelationalExpr (Restrict predicate expr) = do+  graph <- askGraph+  mctx <- askMaybeContext   optimizedPredicate <- applyStaticPredicateOptimization predicate   case optimizedPredicate of-    Left err -> pure $ Left err-    Right optimizedPredicate2 -      | isTrueExpr optimizedPredicate2 -> applyStaticRelationalOptimization expr -- remove predicate entirely-      | isFalseExpr optimizedPredicate2 -> do -- replace where false predicate with empty relation with attributes from relexpr-        attributesRel <- typeForRelationalExpr expr+    optimizedPredicate' | isTrueExpr optimizedPredicate' -> optimizeGraphRefRelationalExpr expr -- remove predicate entirely+    optimizedPredicate' | isFalseExpr optimizedPredicate' -> do -- replace where false predicate with empty relation with attributes from relexpr+        let attributesRel = runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr expr)+            gfEnv = freshGraphRefRelationalExprEnv mctx graph         case attributesRel of -          Left err -> pure $ Left err-          Right attributesRelA -> pure $ Right $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet+          Left err -> throwError err+          Right attributesRelA -> pure $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet       | otherwise -> do-        optimizedSubExpression <- applyStaticRelationalOptimization expr-        case optimizedSubExpression of-          Left err -> pure $ Left err-          Right optSubExpr -> pure $ Right $ Restrict optimizedPredicate2 optSubExpr+        optSubExpr <- optimizeGraphRefRelationalExpr expr+        pure $ Restrict optimizedPredicate' optSubExpr   -applyStaticRelationalOptimization e@(Equals _ _) = pure $ Right e +optimizeGraphRefRelationalExpr e@(Equals _ _) = pure e  -applyStaticRelationalOptimization e@(NotEquals _ _) = pure $ Right e +optimizeGraphRefRelationalExpr e@(NotEquals _ _) = pure e    -applyStaticRelationalOptimization e@(Extend _ _) = pure $ Right e  +optimizeGraphRefRelationalExpr e@(Extend _ _) = pure e   -applyStaticRelationalOptimization e@(With _ _) = pure $ Right e  +optimizeGraphRefRelationalExpr e@(With _ _) = pure e   -applyStaticDatabaseOptimization :: DatabaseContextExpr -> DatabaseState (Either RelationalError DatabaseContextExpr)-applyStaticDatabaseOptimization x@NoOperation = pure $ Right x-applyStaticDatabaseOptimization x@(Define _ _) = pure $ Right x+-- database context expr+optimizeGraphRefDatabaseContextExpr :: GraphRefDatabaseContextExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextExpr+optimizeGraphRefDatabaseContextExpr x@NoOperation = pure x+optimizeGraphRefDatabaseContextExpr x@(Define _ _) = pure x -applyStaticDatabaseOptimization x@(Undefine _) = pure $ Right x+optimizeGraphRefDatabaseContextExpr x@(Undefine _) = pure x -applyStaticDatabaseOptimization (Assign name expr) = do-  context <- getStateContext-  let optimizedExpr = optimizeRelationalExpr context expr-  case optimizedExpr of-    Left err -> pure $ Left err-    Right optimizedExpr2 -> pure $ Right (Assign name optimizedExpr2)+optimizeGraphRefDatabaseContextExpr (Assign name expr) = do+  optExpr <- liftGraphRefRelExpr (fullOptimizeGraphRefRelationalExpr expr)+  pure $ Assign name optExpr     -applyStaticDatabaseOptimization (Insert targetName expr) = do-  context <- getStateContext-  let optimizedExpr = optimizeRelationalExpr context expr-  case optimizedExpr of-    Left err -> pure $ Left err-    Right optimizedExpr2 -> if isEmptyRelationExpr optimizedExpr2 then -- if we are trying to insert an empty relation, do nothing-                              pure (Right NoOperation)-                              else -                              case optimizedExpr2 of -                                -- if the target relvar and the insert relvar are the same, there is nothing to do-                                -- insert s s -> NoOperation-                                RelationVariable insName () | insName == targetName -> pure (Right NoOperation)-                                _ -> pure $ Right (Insert targetName optimizedExpr2)+optimizeGraphRefDatabaseContextExpr (Insert targetName expr) = do+  optimizedExpr <- liftGraphRefRelExpr (fullOptimizeGraphRefRelationalExpr expr)+  if isEmptyRelationExpr optimizedExpr then -- if we are trying to insert an empty relation, do nothing+    pure NoOperation+    else +    case optimizedExpr of +      -- if the target relvar and the insert relvar are the same, there is nothing to do+      -- insert s s -> NoOperation+      RelationVariable insName _ | insName == targetName -> pure NoOperation+      _ -> pure (Insert targetName optimizedExpr)   -applyStaticDatabaseOptimization (Delete name predicate) = do  -  context <- getStateContext-  let optimizedPredicate = runReader (applyStaticPredicateOptimization predicate) (RelationalExprStateElems context)-  case optimizedPredicate of-      Left err -> pure $ Left err-      Right optimizedPredicate2 -> pure $ Right (Delete name optimizedPredicate2)+optimizeGraphRefDatabaseContextExpr (Delete name predicate) =+  Delete name <$> liftGraphRefRelExpr (applyStaticPredicateOptimization predicate) -applyStaticDatabaseOptimization (Update name upmap predicate) = do -  context <- getStateContext-  let optimizedPredicate = runReader (applyStaticPredicateOptimization predicate) (RelationalExprStateElems context)-  case optimizedPredicate of-      Left err -> pure $ Left err-      Right optimizedPredicate2 -> pure $ Right (Update name upmap optimizedPredicate2)+optimizeGraphRefDatabaseContextExpr (Update name upmap predicate) =+  Update name upmap <$> liftGraphRefRelExpr (applyStaticPredicateOptimization predicate)       -applyStaticDatabaseOptimization dep@(AddInclusionDependency _ _) = pure $ Right dep+optimizeGraphRefDatabaseContextExpr dep@(AddInclusionDependency _ _) = pure dep -applyStaticDatabaseOptimization (RemoveInclusionDependency name) = pure $ Right (RemoveInclusionDependency name)+optimizeGraphRefDatabaseContextExpr (RemoveInclusionDependency name) = pure (RemoveInclusionDependency name) -applyStaticDatabaseOptimization (AddNotification name triggerExpr resultOldExpr resultNewExpr) = do-  context <- getStateContext-  let eTriggerExprOpt = optimizeRelationalExpr context triggerExpr-  case eTriggerExprOpt of-         Left err -> pure $ Left err-         Right triggerExprOpt -> --it doesn't make sense to optimize queries when we don't have their proper contexts-           pure (Right (AddNotification name triggerExprOpt resultOldExpr resultNewExpr))+optimizeGraphRefDatabaseContextExpr (AddNotification name triggerExpr resultOldExpr resultNewExpr) = +  --we can't optimize these expressions until they run+  pure (AddNotification name triggerExpr resultOldExpr resultNewExpr) -applyStaticDatabaseOptimization notif@(RemoveNotification _) = pure (Right notif)+optimizeGraphRefDatabaseContextExpr notif@(RemoveNotification _) = pure notif -applyStaticDatabaseOptimization c@(AddTypeConstructor _ _) = pure (Right c)-applyStaticDatabaseOptimization c@(RemoveTypeConstructor _) = pure (Right c)-applyStaticDatabaseOptimization c@(RemoveAtomFunction _) = pure (Right c)-applyStaticDatabaseOptimization c@(RemoveDatabaseContextFunction _) = pure (Right c)-applyStaticDatabaseOptimization c@(ExecuteDatabaseContextFunction _ _) = pure (Right c)+optimizeGraphRefDatabaseContextExpr c@(AddTypeConstructor _ _) = pure c+optimizeGraphRefDatabaseContextExpr c@(RemoveTypeConstructor _) = pure c+optimizeGraphRefDatabaseContextExpr c@(RemoveAtomFunction _) = pure c+optimizeGraphRefDatabaseContextExpr c@(RemoveDatabaseContextFunction _) = pure c+optimizeGraphRefDatabaseContextExpr c@(ExecuteDatabaseContextFunction _ _) = pure c  --optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned  --applyStaticDatabaseOptimization (MultipleExpr exprs) = pure $ Right $ MultipleExpr exprs --for multiple expressions, we must evaluate-applyStaticDatabaseOptimization (MultipleExpr exprs) = do-  context <- getStateContext-  let optExprs = evalState substateRunner (contextWithEmptyTupleSets context, M.empty, False)-  let errors = lefts optExprs-  if not (null errors) then-    pure $ Left (head errors)-    else-      pure $ Right $ MultipleExpr (rights optExprs)-   where-     substateRunner = forM exprs $ \expr -> do-                                    --a previous expression could create a relvar, we don't want to miss it, so we clear the tuples and execute the expression to get an empty relation in the relvar                                -       _ <- evalDatabaseContextExpr expr    -       applyStaticDatabaseOptimization expr-  --this error handling could be improved with some lifting presumably-  --restore original context+optimizeGraphRefDatabaseContextExpr (MultipleExpr exprs) = do+  --a previous expression in the exprs list could create a relvar; we don't want to miss it, so we clear the tuples and execute the expression to get an empty relation in the relvar+  context <- askContext+  graph <- askGraph+  parentId <- askTransId+  +  let emptyRvs ctx = ctx { relationVariables = mkEmptyRelVars (relationVariables ctx) }+      dbcEnv = mkDatabaseContextEvalEnv parentId graph+      folder (ctx, expracc) expr = do+        --optimize the expr and run it against empty relvars to add it to the context+        case runGraphRefSOptDatabaseContextExprM parentId ctx graph (optimizeGraphRefDatabaseContextExpr expr) of+          Left err -> throwError err+          Right optExpr ->+            case runDatabaseContextEvalMonad ctx dbcEnv (evalGraphRefDatabaseContextExpr optExpr) of+              Left err -> throwError err+              Right dbcState ->+                pure (emptyRvs $ dbc_context dbcState, expracc ++ [optExpr]) -applyStaticPredicateOptimization :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionPredicateExpr)+  (_, exprs') <- foldM folder (context,[]) exprs+  pure (MultipleExpr exprs')++applyStaticPredicateOptimization :: GraphRefRestrictionPredicateExpr -> GraphRefSOptRelationalExprM GraphRefRestrictionPredicateExpr applyStaticPredicateOptimization predi = do-  eOptPred <- case predi of +  optPred <- case predi of  -- where x and x => where x     AndPredicate pred1 pred2 -> do-      eOptPred1 <- applyStaticPredicateOptimization pred1-      case eOptPred1 of-        Left err -> pure (Left err)-        Right optPred1 -> do-          eOptPred2 <- applyStaticPredicateOptimization pred2-          case eOptPred2 of-            Left err -> pure (Left err)-            Right optPred2 ->-              if optPred1 == optPred2 then-                pure (Right optPred1)-                else-                pure (Right (AndPredicate optPred1 optPred2))+      optPredA <- applyStaticPredicateOptimization pred1+      optPredB <- applyStaticPredicateOptimization pred2+      if optPredA == optPredB then+        pure optPredA+        else+        pure (AndPredicate optPredA optPredB) -- where x or x => where x         OrPredicate pred1 pred2 -> do-      eOptPred1 <- applyStaticPredicateOptimization pred1-      case eOptPred1 of-        Left err -> pure (Left err)-        Right optPred1 -> do-          eOptPred2 <- applyStaticPredicateOptimization pred2-          case eOptPred2 of-            Left err -> pure (Left err)-            Right optPred2 | optPred1 == optPred2 -> pure (Right optPred1)-                           | isTrueExpr optPred1 -> pure (Right optPred1)  -- True or x -> True-                           | isTrueExpr optPred2 -> pure (Right optPred2)-                           | otherwise -> pure (Right (OrPredicate optPred1 optPred2))+      optPredA <- applyStaticPredicateOptimization pred1+      optPredB <- applyStaticPredicateOptimization pred2+      if (optPredA == optPredB) || isTrueExpr optPredA then+        pure optPredA+        else if isTrueExpr optPredB then+               pure optPredB+             else+               pure (OrPredicate optPredA optPredB)     AttributeEqualityPredicate attrNameA (AttributeAtomExpr attrNameB) ->       if attrNameA == attrNameB then-        pure (Right TruePredicate)+        pure TruePredicate       else-        pure (Right predi)-    AttributeEqualityPredicate{} -> pure (Right predi)-    TruePredicate -> pure $ Right predi-    NotPredicate{} -> pure $ Right predi-    RelationalExprPredicate{} -> pure (Right predi)-    AtomExprPredicate{} -> pure (Right predi)-  case eOptPred of-    Left err -> pure (Left err)-    Right optPred -> -      let attrMap = findStaticRestrictionPredicates optPred in-      pure (Right (replaceStaticAtomExprs optPred attrMap))+        pure predi+    AttributeEqualityPredicate{} -> pure predi+    TruePredicate -> pure predi+    NotPredicate{} -> pure predi+    RelationalExprPredicate{} -> pure predi+    AtomExprPredicate{} -> pure predi+  let attrMap = findStaticRestrictionPredicates optPred+  pure (replaceStaticAtomExprs optPred attrMap)  --determines if an atom expression is tautologically true-isTrueExpr :: RestrictionPredicateExpr -> Bool+isTrueExpr :: RestrictionPredicateExprBase a -> Bool isTrueExpr TruePredicate = True isTrueExpr (AtomExprPredicate (NakedAtomExpr (BoolAtom True))) = True isTrueExpr _ = False  --determines if an atom expression is tautologically false-isFalseExpr :: RestrictionPredicateExpr -> Bool+isFalseExpr :: RestrictionPredicateExprBase a -> Bool isFalseExpr (NotPredicate expr) = isTrueExpr expr isFalseExpr (AtomExprPredicate (NakedAtomExpr (BoolAtom False))) = True isFalseExpr _ = False  -- determine if the created relation can statically be determined to be empty-isEmptyRelationExpr :: RelationalExpr -> Bool    -isEmptyRelationExpr (MakeRelationFromExprs _ []) = True+isEmptyRelationExpr :: RelationalExprBase a -> Bool    +isEmptyRelationExpr (MakeRelationFromExprs _ (TupleExprs _ [])) = True isEmptyRelationExpr (MakeStaticRelation _ tupSet) = null (asList tupSet) isEmptyRelationExpr (ExistingRelation rel) = rel == emptyRelationWithAttrs (attributes rel) isEmptyRelationExpr _ = False      --transitive static variable optimization                        -replaceStaticAtomExprs :: RestrictionPredicateExpr -> M.Map AttributeName AtomExpr -> RestrictionPredicateExpr+replaceStaticAtomExprs :: GraphRefRestrictionPredicateExpr -> M.Map AttributeName GraphRefAtomExpr -> GraphRefRestrictionPredicateExpr replaceStaticAtomExprs predIn replaceMap = case predIn of   AttributeEqualityPredicate newAttrName (AttributeAtomExpr matchName) -> case M.lookup matchName replaceMap of     Nothing -> predIn@@ -296,7 +409,7 @@   RelationalExprPredicate{} -> predIn   AtomExprPredicate{} -> predIn -- used for transitive attribute optimization- only works on statically-determined atoms for now- in the future, this could work for all AtomExprs which don't reference attributes-findStaticRestrictionPredicates :: RestrictionPredicateExpr -> M.Map AttributeName AtomExpr+findStaticRestrictionPredicates :: GraphRefRestrictionPredicateExpr -> M.Map AttributeName GraphRefAtomExpr findStaticRestrictionPredicates (AttributeEqualityPredicate attrName atomExpr) =    case atomExpr of     val@NakedAtomExpr{} -> M.singleton attrName val@@ -320,60 +433,65 @@ isStaticAtomExpr RelationAtomExpr{} = False  --if the projection of a join only uses the attributes from one of the expressions and there is a foreign key relationship between the expressions, we know that the join is inconsequential and can be removed-applyStaticJoinElimination :: RelationalExpr -> RelationalExprState (Either RelationalError RelationalExpr)+applyStaticJoinElimination :: GraphRefRelationalExpr -> GraphRefSOptRelationalExprM GraphRefRelationalExpr applyStaticJoinElimination expr@(Project attrNameSet (Join exprA exprB)) = do-  relState <- ask-  eProjType <- typeForRelationalExpr expr-  eTypeA <- typeForRelationalExpr exprA-  eTypeB <- typeForRelationalExpr exprB-  case eProjType of-    Left err -> pure (Left err)-    Right projType -> -      case eTypeA of -        Left err -> pure (Left err)-        Right typeA -> -          case eTypeB of-            Left err -> pure (Left err)-            Right typeB -> do-              let matchesProjectionAttributes -                    | attrNames projType `S.isSubsetOf` attrNames typeA =-                      Just ((exprA, typeA), (exprB, typeB))-                    | attrNames projType `S.isSubsetOf` attrNames typeB =-                        Just ((exprB, typeB), (exprA, typeA))-                    | otherwise =-                      Nothing-                  attrNames = A.attributeNameSet . attributes-              case matchesProjectionAttributes of-                Nothing ->  -- this optimization does not apply-                  pure (Right expr)-                Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do-                  --scan inclusion dependencies for a foreign key relationship-                  incDeps <- inclusionDependencies . stateElemsContext <$> ask-                  let fkConstraint = foldM isFkConstraint False incDeps-                      --search for matching fk constraint-                      isFkConstraint acc (InclusionDependency (Project subattrNames subrv) (Project _ superrv)) = -                        case runReader (evalAttributeNames subattrNames expr) relState of-                          Left _ -> pure acc-                          Right subAttrNameSet -> -                            pure (acc || (joinedExpr == subrv &&-                                          unjoinedExpr == superrv && -                                          -- the fk attribute is one of the projection attributes-                                          A.attributeNamesContained subAttrNameSet (A.attributeNameSet (attributes joinedType))+  graph <- askGraph+  case inSameTransaction exprA exprB of+    -- the sub exprs are in different transactions or none at all, so we cannot extract inclusion dependencies across transaction boundaries+    Nothing -> pure expr+    Just marker -> do+      commonContext <- case marker of+                         UncommittedContextMarker -> askContext+                         TransactionMarker tid -> concreteDatabaseContext <$> lift (except (transactionForId tid graph))+      let typeForExpr e = lift $ except $ runGraphRefRelationalExprM gfEnv (typeForGraphRefRelationalExpr e)+          gfEnv = freshGraphRefRelationalExprEnv (Just commonContext) graph+        +      projType <- typeForExpr expr+      typeA <- typeForExpr exprA+      typeB <- typeForExpr exprB+      let matchesProjectionAttributes +            | attrNames projType `S.isSubsetOf` attrNames typeA =+                Just ((exprA, typeA), (exprB, typeB))+            | attrNames projType `S.isSubsetOf` attrNames typeB =+                Just ((exprB, typeB), (exprA, typeA))+            | otherwise =+                Nothing+          attrNames = A.attributeNameSet . attributes+      case matchesProjectionAttributes of+        Nothing ->  -- this optimization does not apply+          pure expr+        Just ((joinedExpr, joinedType), (unjoinedExpr, _)) -> do+        --lookup transaction+        --scan inclusion dependencies for a foreign key relationship+         let incDeps = inclusionDependencies commonContext+             fkConstraint = foldM isFkConstraint False incDeps+            --search for matching fk constraint+             isFkConstraint acc (InclusionDependency (Project subAttrNames subrv) (Project _ superrv)) = do+               let gfSubAttrNames = processM (processAttributeNames subAttrNames)+                   gfSubRv = processM (processRelationalExpr subrv)+                   gfSuperRv = processM (processRelationalExpr superrv)+                   processM = runProcessExprM marker+               case runGraphRefRelationalExprM gfEnv (evalGraphRefAttributeNames gfSubAttrNames expr) of+                 Left _ -> pure acc+                 Right subAttrNameSet -> +                   pure (acc || (joinedExpr == gfSubRv &&+                                 unjoinedExpr == gfSuperRv && +                                 -- the fk attribute is one of the projection attributes+                                 A.attributeNamesContained subAttrNameSet (A.attributeNameSet (attributes joinedType))                                 ))-                      isFkConstraint acc _ = pure acc-                  case fkConstraint of-                    Right True -> --join elimination optimization applies-                      applyStaticRelationalOptimization (Project attrNameSet joinedExpr)-                    Right False -> --join elimination optimization does not apply-                      pure (Right expr)-                    Left err -> -                      pure (Left err)+             isFkConstraint acc _ = pure acc+         case fkConstraint of+           Right True -> --join elimination optimization applies+             optimizeGraphRefRelationalExpr (Project attrNameSet joinedExpr)+           Right False -> --join elimination optimization does not apply+             pure expr+           Left err -> throwError err           -applyStaticJoinElimination expr = pure (Right expr)      +applyStaticJoinElimination expr = pure expr                                                                                --restriction collapse converts chained restrictions into (Restrict (And pred1 pred2 pred3...))   --this optimization should be fairly uncontroversial- performing a tuple scan once is cheaper than twice- parallelization can still take place-applyStaticRestrictionCollapse :: RelationalExpr -> RelationalExpr+applyStaticRestrictionCollapse :: GraphRefRelationalExpr -> GraphRefRelationalExpr applyStaticRestrictionCollapse expr =    case expr of     MakeRelationFromExprs _ _ -> expr@@ -410,14 +528,14 @@           andPreds = foldr (\(Restrict subpred _) acc -> AndPredicate acc subpred) firstPred (tail restrictions) in       Restrict andPreds optFinalExpr       -sequentialRestrictions :: RelationalExpr -> [RelationalExpr]+sequentialRestrictions :: RelationalExprBase a -> [RelationalExprBase a] sequentialRestrictions expr@(Restrict _ subexpr) = expr:sequentialRestrictions subexpr sequentialRestrictions _ = []  --restriction pushdown only really makes sense for tuple-oriented storage schemes where performing a restriction before projection can cut down on the intermediate storage needed to store the data before the projection -- x{proj} where c1 -> (x where c1){proj} #project on fewer tuples -- (x union y) where c -> (x where c) union (y where c) #with a selective restriction, fewer tuples will need to be joined-applyStaticRestrictionPushdown :: RelationalExpr -> RelationalExpr+applyStaticRestrictionPushdown :: GraphRefRelationalExpr -> GraphRefRelationalExpr applyStaticRestrictionPushdown expr = case expr of   MakeRelationFromExprs _ _ -> expr   MakeStaticRelation _ _ -> expr@@ -454,4 +572,6 @@   Extend n sub ->     Extend n (applyStaticRestrictionPushdown sub)     -  +-- no optimizations available  +optimizeDatabaseContextIOExpr :: GraphRefDatabaseContextIOExpr -> GraphRefSOptDatabaseContextExprM GraphRefDatabaseContextIOExpr+optimizeDatabaseContextIOExpr = pure

src/lib/ProjectM36/TransGraphRelationalExpression.hs view

@@ -4,13 +4,12 @@ module ProjectM36.TransGraphRelationalExpression where import ProjectM36.Base import ProjectM36.TransactionGraph-import ProjectM36.Transaction-import ProjectM36.RelationalExpression import ProjectM36.Error-import ProjectM36.Tuple-import ProjectM36.AtomType import qualified Data.Map as M import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Data.Functor.Identity import Data.Binary  -- | The TransGraphRelationalExpression is equivalent to a relational expression except that relation variables can reference points in the transaction graph (at previous points in time).@@ -30,6 +29,10 @@  instance Binary TransGraphTupleExpr +type TransGraphTupleExprs = TupleExprsBase TransactionIdLookup++instance Binary TransGraphTupleExprs+ type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup  instance Binary TransGraphRestrictionPredicateExpr@@ -40,143 +43,155 @@  type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup +type TransGraphWithNameExpr = WithNameExprBase TransactionIdLookup++instance Binary TransGraphWithNameExpr++newtype TransGraphEvalEnv = TransGraphEvalEnv {+  tge_graph :: TransactionGraph+  }++type TransGraphEvalMonad a = ReaderT TransGraphEvalEnv (ExceptT RelationalError Identity) a++process :: TransGraphEvalEnv -> TransGraphRelationalExpr -> Either RelationalError GraphRefRelationalExpr+process env texpr = runIdentity (runExceptT (runReaderT (processTransGraphRelationalExpr texpr) env))++liftE :: Either RelationalError a -> TransGraphEvalMonad a+liftE = lift . except++askGraph :: TransGraphEvalMonad TransactionGraph+askGraph = tge_graph <$> ask++findTransId :: TransactionIdLookup -> TransGraphEvalMonad GraphRefTransactionMarker+findTransId tlook = TransactionMarker . transactionId <$> findTrans tlook++findTrans :: TransactionIdLookup -> TransGraphEvalMonad Transaction+findTrans tlook = do+  graph <- askGraph+  liftE $ lookupTransaction graph tlook+ -- OUTDATED a previous attempt at this function attempted to convert TransGraphRelationalExpr to RelationalExpr by resolving the transaction lookups. However, there is no way to resolve a FunctionAtomExpr to an Atom without fully evaluating the higher levels (TupleExpr, etc.). An anonymous function expression cannot be serialized, so that workaround is out. Still, I suspect we can reuse the existing static optimizer logic to work on both structures. The current conversion reduces the chance of whole-query optimization due to full-evaluation on top of full-evaluation, so this function would benefit from some re-design.-evalTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransactionGraph -> Either RelationalError RelationalExpr-evalTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) graph = do-  tupleExprs' <- mapM (evalTransGraphTupleExpr graph) tupleExprs+processTransGraphRelationalExpr :: TransGraphRelationalExpr -> TransGraphEvalMonad GraphRefRelationalExpr+processTransGraphRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do+  tupleExprs' <- processTransGraphTupleExprs tupleExprs   case mAttrExprs of     Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')     Just attrExprs -> do-      attrExprs' <- mapM (evalTransGraphAttributeExpr graph) attrExprs+      attrExprs' <- mapM processTransGraphAttributeExpr attrExprs       pure (MakeRelationFromExprs (Just attrExprs') tupleExprs')-evalTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) _ = pure (MakeStaticRelation attrs tupSet)-evalTransGraphRelationalExpr (ExistingRelation rel) _ = pure (ExistingRelation rel)-evalTransGraphRelationalExpr (RelationVariable rvname transLookup) graph = do-  trans <- lookupTransaction graph transLookup-  rel <- runReader (evalRelationalExpr (RelationVariable rvname ())) (RelationalExprStateElems (concreteDatabaseContext trans))-  pure (ExistingRelation rel)-evalTransGraphRelationalExpr (Project transAttrNames expr) graph = do-  expr' <- evalTransGraphRelationalExpr expr graph-  attrNames <- evalTransAttributeNames transAttrNames graph-  pure (Project attrNames expr')-evalTransGraphRelationalExpr (Union exprA exprB) graph = do-  exprA' <- evalTransGraphRelationalExpr exprA graph-  exprB' <- evalTransGraphRelationalExpr exprB graph-  pure (Union exprA' exprB')-evalTransGraphRelationalExpr (Join exprA exprB) graph = do-  exprA' <- evalTransGraphRelationalExpr exprA graph-  exprB' <- evalTransGraphRelationalExpr exprB graph-  pure (Join exprA' exprB')-evalTransGraphRelationalExpr (Rename attrName1 attrName2 expr) graph = do-  let expr' = evalTransGraphRelationalExpr expr graph  -  Rename attrName1 attrName2 <$> expr'-evalTransGraphRelationalExpr (Difference exprA exprB) graph = do  -  exprA' <- evalTransGraphRelationalExpr exprA graph-  exprB' <- evalTransGraphRelationalExpr exprB graph-  pure (Difference exprA' exprB')-evalTransGraphRelationalExpr (Group transAttrNames attrName expr) graph = do  -  expr' <- evalTransGraphRelationalExpr expr graph-  attrNames <- evalTransAttributeNames transAttrNames graph-  pure (Group attrNames attrName expr')-evalTransGraphRelationalExpr (Ungroup attrName expr) graph = do  -  let expr' = evalTransGraphRelationalExpr expr graph    -  Ungroup attrName <$> expr'-evalTransGraphRelationalExpr (Restrict predicateExpr expr) graph = do-  expr' <- evalTransGraphRelationalExpr expr graph  -  predicateExpr' <- evalTransGraphRestrictionPredicateExpr predicateExpr graph-  pure (Restrict predicateExpr' expr')-evalTransGraphRelationalExpr (Equals exprA exprB) graph = do  -  exprA' <- evalTransGraphRelationalExpr exprA graph-  exprB' <- evalTransGraphRelationalExpr exprB graph+processTransGraphRelationalExpr (MakeStaticRelation attrs tupSet) = pure (MakeStaticRelation attrs tupSet)+processTransGraphRelationalExpr (ExistingRelation rel) = pure (ExistingRelation rel)+processTransGraphRelationalExpr (RelationVariable rvname transLookup) = +  RelationVariable rvname <$> findTransId transLookup+processTransGraphRelationalExpr (Project transAttrNames expr) = +  Project <$> processTransGraphAttributeNames transAttrNames <*> processTransGraphRelationalExpr expr+processTransGraphRelationalExpr (Union exprA exprB) =+  Union <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB+processTransGraphRelationalExpr (Join exprA exprB) =+  Join <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB+processTransGraphRelationalExpr (Rename attrName1 attrName2 expr) =+  Rename attrName1 attrName2 <$> processTransGraphRelationalExpr expr+processTransGraphRelationalExpr (Difference exprA exprB) =+  Difference <$> processTransGraphRelationalExpr exprA <*> processTransGraphRelationalExpr exprB+processTransGraphRelationalExpr (Group transAttrNames attrName expr) = +  Group <$>+    processTransGraphAttributeNames transAttrNames <*>+    pure attrName <*>+    processTransGraphRelationalExpr expr+processTransGraphRelationalExpr (Ungroup attrName expr) = +  Ungroup attrName <$> processTransGraphRelationalExpr expr+processTransGraphRelationalExpr (Restrict predicateExpr expr) =+  Restrict <$> evalTransGraphRestrictionPredicateExpr predicateExpr <*>+    processTransGraphRelationalExpr expr+processTransGraphRelationalExpr (Equals exprA exprB) = do  +  exprA' <- processTransGraphRelationalExpr exprA+  exprB' <- processTransGraphRelationalExpr exprB    pure (Equals exprA' exprB')-evalTransGraphRelationalExpr (NotEquals exprA exprB) graph = do  -  exprA' <- evalTransGraphRelationalExpr exprA graph-  exprB' <- evalTransGraphRelationalExpr exprB graph+processTransGraphRelationalExpr (NotEquals exprA exprB) = do  +  exprA' <- processTransGraphRelationalExpr exprA +  exprB' <- processTransGraphRelationalExpr exprB    pure (NotEquals exprA' exprB')-evalTransGraphRelationalExpr (Extend extendExpr expr) graph = do-  extendExpr' <- evalTransGraphExtendTupleExpr extendExpr graph-  expr' <- evalTransGraphRelationalExpr expr graph+processTransGraphRelationalExpr (Extend extendExpr expr) = do+  extendExpr' <- processTransGraphExtendTupleExpr extendExpr +  expr' <- processTransGraphRelationalExpr expr    pure (Extend extendExpr' expr')-evalTransGraphRelationalExpr (With views expr) graph = do-  evaldViews <- mapM (\(vname, vexpr) -> do-                         vexpr' <- evalTransGraphRelationalExpr vexpr graph-                         pure (vname, vexpr')+processTransGraphRelationalExpr (With views expr) = do+  evaldViews <- mapM (\(wnexpr, vexpr) -> do+                         wnexpr' <- processTransGraphWithNameExpr wnexpr+                         vexpr' <- processTransGraphRelationalExpr vexpr +                         pure (wnexpr', vexpr')                      ) views-  expr' <- evalTransGraphRelationalExpr expr graph+  expr' <- processTransGraphRelationalExpr expr    pure (With evaldViews expr')-  -evalTransGraphTupleExpr :: TransactionGraph -> TransGraphTupleExpr -> Either RelationalError TupleExpr-evalTransGraphTupleExpr graph (TupleExpr attrMap) = do++processTransGraphTupleExprs :: TransGraphTupleExprs -> TransGraphEvalMonad GraphRefTupleExprs+processTransGraphTupleExprs (TupleExprs marker texprs) =+  TupleExprs <$> findTransId marker <*> mapM processTransGraphTupleExpr texprs++processTransGraphTupleExpr :: TransGraphTupleExpr -> TransGraphEvalMonad GraphRefTupleExpr+processTransGraphTupleExpr (TupleExpr attrMap) = do   let attrAssoc = mapM (\(attrName, atomExpr) -> do -                        aExpr <- evalTransGraphAtomExpr graph atomExpr+                        aExpr <- processTransGraphAtomExpr atomExpr                         pure (attrName, aExpr)                     ) (M.toList attrMap)   TupleExpr . M.fromList <$> attrAssoc   -evalTransGraphAtomExpr :: TransactionGraph -> TransGraphAtomExpr -> Either RelationalError AtomExpr-evalTransGraphAtomExpr _ (AttributeAtomExpr aname) = pure $ AttributeAtomExpr aname-evalTransGraphAtomExpr _ (NakedAtomExpr atom) = pure $ NakedAtomExpr atom-evalTransGraphAtomExpr graph (FunctionAtomExpr funcName args tLookup) = do-  trans <- lookupTransaction graph tLookup-  --I can't return a FunctionAtomExpr because the function needs to be resolved at a specific context-  args' <- mapM (evalTransGraphAtomExpr graph) args-  atom <- runReader (evalAtomExpr emptyTuple (FunctionAtomExpr funcName args' ())) (RelationalExprStateElems (concreteDatabaseContext trans))-  pure (NakedAtomExpr atom)-evalTransGraphAtomExpr graph (RelationAtomExpr expr) = do-  let expr' = evalTransGraphRelationalExpr expr graph -  RelationAtomExpr <$> expr'-evalTransGraphAtomExpr graph (ConstructedAtomExpr dConsName args tLookup) = do-  trans <- lookupTransaction graph tLookup  -  args' <- mapM (evalTransGraphAtomExpr graph) args-  atom <- runReader (evalAtomExpr emptyTuple (ConstructedAtomExpr dConsName args' ())) (RelationalExprStateElems (concreteDatabaseContext trans))-  pure (NakedAtomExpr atom)--evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransactionGraph -> Either RelationalError RestrictionPredicateExpr-evalTransGraphRestrictionPredicateExpr TruePredicate _ = pure TruePredicate-evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) graph = do-  exprA' <- evalTransGraphRestrictionPredicateExpr exprA graph-  exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph+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 (RelationAtomExpr expr) =+  RelationAtomExpr <$> processTransGraphRelationalExpr expr+processTransGraphAtomExpr (ConstructedAtomExpr dConsName args tLookup) =+  ConstructedAtomExpr dConsName <$> mapM processTransGraphAtomExpr args <*> findTransId tLookup+evalTransGraphRestrictionPredicateExpr :: TransGraphRestrictionPredicateExpr -> TransGraphEvalMonad GraphRefRestrictionPredicateExpr+evalTransGraphRestrictionPredicateExpr TruePredicate = pure TruePredicate+evalTransGraphRestrictionPredicateExpr (AndPredicate exprA exprB) = do+  exprA' <- evalTransGraphRestrictionPredicateExpr exprA+  exprB' <- evalTransGraphRestrictionPredicateExpr exprB   pure (AndPredicate exprA' exprB')-evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) graph = do  -  exprA' <- evalTransGraphRestrictionPredicateExpr exprA graph-  exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph+evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) = do  +  exprA' <- evalTransGraphRestrictionPredicateExpr exprA +  exprB' <- evalTransGraphRestrictionPredicateExpr exprB   pure (OrPredicate exprA' exprB')-evalTransGraphRestrictionPredicateExpr (NotPredicate expr) graph = do-  let expr' = evalTransGraphRestrictionPredicateExpr expr graph+evalTransGraphRestrictionPredicateExpr (NotPredicate expr) = do+  let expr' = evalTransGraphRestrictionPredicateExpr expr   NotPredicate <$> expr'-evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) graph = do  -  let expr' = evalTransGraphRelationalExpr expr graph+evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) = do  +  let expr' = processTransGraphRelationalExpr expr   RelationalExprPredicate <$> expr'-evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) graph = do-  let expr' = evalTransGraphAtomExpr graph expr+evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) = do+  let expr' = processTransGraphAtomExpr expr   AtomExprPredicate <$> expr'-evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) graph = do  -  let expr' = evalTransGraphAtomExpr graph expr+evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) = do  +  let expr' = processTransGraphAtomExpr expr   AttributeEqualityPredicate attrName <$> expr'   -evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransactionGraph -> Either RelationalError ExtendTupleExpr-evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) graph = do-  let expr' = evalTransGraphAtomExpr graph expr-  AttributeExtendTupleExpr attrName <$> expr'+processTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransGraphEvalMonad GraphRefExtendTupleExpr+processTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) =+  AttributeExtendTupleExpr attrName <$> processTransGraphAtomExpr expr -evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr-evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do-  trans <- lookupTransaction graph tLookup-  aType <- atomTypeForTypeConstructor tCons (typeConstructorMapping (concreteDatabaseContext trans)) M.empty-  pure (NakedAttributeExpr (Attribute attrName aType))-evalTransGraphAttributeExpr _ (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)  +processTransGraphAttributeExpr :: TransGraphAttributeExpr -> TransGraphEvalMonad GraphRefAttributeExpr+processTransGraphAttributeExpr (AttributeAndTypeNameExpr attrName tCons tLookup) =+  AttributeAndTypeNameExpr attrName tCons <$> findTransId tLookup+processTransGraphAttributeExpr (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)   -evalTransAttributeNames :: TransGraphAttributeNames -> TransactionGraph -> Either RelationalError AttributeNames-evalTransAttributeNames (AttributeNames names) _ = Right (AttributeNames names)-evalTransAttributeNames (InvertedAttributeNames names) _ = Right (InvertedAttributeNames names)-evalTransAttributeNames (UnionAttributeNames namesA namesB) graph = do-  nA <- evalTransAttributeNames namesA graph-  nB <- evalTransAttributeNames namesB graph-  Right (UnionAttributeNames nA nB)-evalTransAttributeNames (IntersectAttributeNames namesA namesB) graph = do-  nA <- evalTransAttributeNames namesA graph-  nB <- evalTransAttributeNames namesB graph-  Right (IntersectAttributeNames nA nB)-evalTransAttributeNames (RelationalExprAttributeNames expr) graph = do-  evaldExpr <- evalTransGraphRelationalExpr expr graph-  Right (RelationalExprAttributeNames evaldExpr)+processTransGraphAttributeNames :: TransGraphAttributeNames -> TransGraphEvalMonad GraphRefAttributeNames+processTransGraphAttributeNames (AttributeNames names) = pure (AttributeNames names)+processTransGraphAttributeNames (InvertedAttributeNames names) = pure (InvertedAttributeNames names)+processTransGraphAttributeNames (UnionAttributeNames namesA namesB) = do+  nA <- processTransGraphAttributeNames namesA +  nB <- processTransGraphAttributeNames namesB+  pure (UnionAttributeNames nA nB)+processTransGraphAttributeNames (IntersectAttributeNames namesA namesB) = do+  nA <- processTransGraphAttributeNames namesA +  nB <- processTransGraphAttributeNames namesB +  pure (IntersectAttributeNames nA nB)+processTransGraphAttributeNames (RelationalExprAttributeNames expr) = do+  evaldExpr <- processTransGraphRelationalExpr expr +  pure (RelationalExprAttributeNames evaldExpr)++processTransGraphWithNameExpr :: TransGraphWithNameExpr -> TransGraphEvalMonad GraphRefWithNameExpr+processTransGraphWithNameExpr (WithNameExpr rvname tlookup) =+  WithNameExpr rvname <$> findTransId tlookup

src/lib/ProjectM36/Transaction.hs view

@@ -3,28 +3,25 @@ import qualified Data.Set as S import qualified Data.UUID as U import Data.Time.Clock--transactionTimestamp :: Transaction -> UTCTime-transactionTimestamp (Transaction _ (TransactionInfo _ _ stamp) _) = stamp-transactionTimestamp (Transaction _ (MergeTransactionInfo _ _ _ stamp) _) = stamp+import qualified Data.List.NonEmpty as NE -transactionParentIds :: Transaction -> S.Set TransactionId-transactionParentIds (Transaction _ (TransactionInfo pId _ _) _) = S.singleton pId-transactionParentIds (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _) = S.fromList [pId1, pId2]+parentIds :: Transaction -> S.Set TransactionId+parentIds (Transaction _ tinfo _) = S.fromList (NE.toList (parents tinfo)) -transactionChildIds :: Transaction -> S.Set TransactionId-transactionChildIds (Transaction _ (TransactionInfo _ children _) _) = children-transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children _) _) = children+rootParent :: TransactionParents+rootParent = singleParent U.nil --- | Create a new transaction which is identical to the original except that a new set of child transaction ids is added.-transactionSetChildren :: Transaction -> S.Set TransactionId -> Transaction-transactionSetChildren t@(Transaction _ (TransactionInfo pId _ stamp) schemas') childIds = Transaction (transactionId t) (TransactionInfo pId childIds stamp) schemas'-transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _ stamp) schemas') childIds = Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds stamp) schemas'+singleParent :: TransactionId -> TransactionParents+singleParent tid = tid NE.:| []  -- | Return the same transaction but referencing only the specific child transactions. This is useful when traversing a graph and returning a subgraph. This doesn't filter parent transactions because it assumes a head-to-root traversal. filterTransactionInfoTransactions :: S.Set TransactionId -> TransactionInfo -> TransactionInfo-filterTransactionInfoTransactions filterIds (TransactionInfo parentId childIds stamp) = TransactionInfo (filterParent parentId filterIds) (S.intersection childIds filterIds) stamp-filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds stamp) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (S.intersection childIds filterIds) stamp+filterTransactionInfoTransactions filterIds tinfo =+  TransactionInfo { parents = case+                      NE.filter (`S.member`  filterIds) (parents tinfo) of+                      [] -> rootParent+                      xs -> NE.fromList xs,+                    stamp = stamp tinfo }  filterParent :: TransactionId -> S.Set TransactionId -> TransactionId filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil@@ -44,3 +41,9 @@ -- | Returns all subschemas which are isomorphic or sub-isomorphic to the concrete schema. subschemas :: Transaction -> Subschemas subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas++fresh :: TransactionId -> UTCTime -> Schemas -> Transaction+fresh freshId stamp' = Transaction freshId (TransactionInfo rootParent stamp')++timestamp :: Transaction -> UTCTime+timestamp (Transaction _ tinfo _) = stamp tinfo

src/lib/ProjectM36/Transaction/Persist.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE TypeApplications #-} module ProjectM36.Transaction.Persist where import ProjectM36.Base import ProjectM36.Error@@ -8,19 +9,18 @@ import qualified Data.Map as M import qualified Data.HashSet as HS import qualified Data.Binary as B---import qualified Data.ByteString as BS import System.FilePath import System.Directory import qualified Data.Text as T import Control.Monad import ProjectM36.ScriptSession import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)-import Control.Exception++#ifdef PM36_HASKELL_SCRIPTING import GHC+import Control.Exception import GHC.Paths-import Codec.Compression.GZip-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL+#endif  getDirectoryNames :: FilePath -> IO [FilePath] getDirectoryNames path =@@ -36,8 +36,8 @@ transactionInfoPath :: FilePath -> FilePath transactionInfoPath transdir = transdir </> "info" -relvarsDir :: FilePath -> FilePath        -relvarsDir transdir = transdir </> "relvars"+relvarsPath :: FilePath -> FilePath        +relvarsPath transdir = transdir </> "relvars"  incDepsDir :: FilePath -> FilePath incDepsDir transdir = transdir </> "incdeps"@@ -85,7 +85,7 @@   transDirExists <- doesDirectoryExist finalTransDir   unless transDirExists $ do     --create sub directories-    mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, dbcFuncsDir tempTransDir]+    mapM_ createDirectory [tempTransDir, incDepsDir tempTransDir, dbcFuncsDir tempTransDir]     writeRelVars sync tempTransDir (relationVariables context)     writeIncDeps sync tempTransDir (inclusionDependencies context)     writeAtomFuncs sync tempTransDir (atomFunctions context)@@ -95,24 +95,16 @@     B.encodeFile (transactionInfoPath tempTransDir) (transactionInfo trans)     --move the temp directory to final location     renameSync sync tempTransDir finalTransDir-  -writeRelVar :: DiskSync -> FilePath -> (RelVarName, Relation) -> IO ()-writeRelVar sync transDir (relvarName, rel) = do-  let relvarPath = relvarsDir transDir </> T.unpack relvarName-  writeBSFileSync sync relvarPath (compress (B.encode rel))-  -writeRelVars :: DiskSync -> FilePath -> M.Map RelVarName Relation -> IO ()-writeRelVars sync transDir relvars = mapM_ (writeRelVar sync transDir) $ M.toList relvars -readRelVars :: FilePath -> IO (M.Map RelVarName Relation)-readRelVars transDir = do-  let relvarsPath = relvarsDir transDir-  relvarNames <- getDirectoryNames relvarsPath-  let relvars = mapM (\name -> do-                      rel <- B.decode . decompress . BSL.fromStrict <$> BS.readFile (relvarsPath </> name)-                      return (T.pack name, rel)) relvarNames-  M.fromList <$> relvars+writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()+writeRelVars sync transDir relvars = do+  let path = relvarsPath transDir+  writeBSFileSync sync path (B.encode relvars) +readRelVars :: FilePath -> IO RelationVariables+readRelVars transDir = +  B.decodeFile (relvarsPath transDir)+ writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO () writeAtomFuncs sync transDir funcs = do   let atomFuncPath = atomFuncsPath transDir @@ -128,33 +120,40 @@   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+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 -> -      case mScriptSession of+    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+            compileScript (atomFunctionBodyType scriptSession) _funcScript           case eCompiledScript of             Left err -> throwIO err             Right compiledScript -> pure AtomFunction { atomFuncName = funcName,-                                                        atomFuncType = funcType,-                                                        atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }+                                                        atomFuncType = _funcType,+                                                        atomFuncBody = AtomFunctionBody (Just _funcScript) compiledScript }+#else+      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+#if !defined(PM36_HASKELL_SCRIPTING)+readAtomFunc _ _ _ _ = error "Haskell scripting is disabled"+#else readAtomFunc transDir funcName mScriptSession precompiledFuncs = do   let atomFuncPath = atomFuncsPath transDir-  (funcType, mFuncScript) <- B.decodeFile atomFuncPath+  (funcType, mFuncScript) <- B.decodeFile @([AtomType],Maybe T.Text) atomFuncPath   case mFuncScript of     --handle pre-compiled case- pull it from the precompiled list     Nothing -> case atomFunctionForName funcName precompiledFuncs of@@ -162,7 +161,8 @@       Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)       Right realFunc -> pure realFunc     --handle a real Haskell scripted function- compile and load-    Just funcScript -> +    Just funcScript ->+       case mScriptSession of         Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"         Just scriptSession -> do@@ -175,6 +175,7 @@             Right compiledScript -> pure AtomFunction { atomFuncName = funcName,                                                          atomFuncType = funcType,                                                          atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }+#endif   writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()@@ -193,26 +194,34 @@   let funcs = mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames   HS.union basicDatabaseContextFunctions . HS.fromList <$> funcs   -readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction  +readDBCFunc :: 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) <- B.decodeFile dbcFuncPath+  (_funcType, mFuncScript) <- B.decodeFile @([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 -> +    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+            compileScript (dbcFunctionBodyType scriptSession) _funcScript           case eCompiledScript of             Left err -> throwIO err             Right compiledScript -> pure DatabaseContextFunction { dbcFuncName = funcName,-                                                                    dbcFuncType = funcType,-                                                                    dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript}+                                                                    dbcFuncType = _funcType,+                                                                    dbcFuncBody = DatabaseContextFunctionBody (Just _funcScript) compiledScript}+#else+      error "Haskell scripting is disabled"+#endif  writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()   writeIncDep sync transDir (incDepName, incDep) =

src/lib/ProjectM36/TransactionGraph.hs view

@@ -1,21 +1,24 @@-{-# LANGUAGE DeriveAnyClass, DeriveGeneric, CPP #-}+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, CPP, FlexibleContexts #-} module ProjectM36.TransactionGraph where import ProjectM36.Base import ProjectM36.Error import ProjectM36.Transaction+import ProjectM36.TransactionInfo as TI import ProjectM36.Relation import ProjectM36.TupleSet import ProjectM36.Tuple import ProjectM36.RelationalExpression import ProjectM36.TransactionGraph.Merge import qualified ProjectM36.DisconnectedTransaction as Discon+import qualified ProjectM36.Attribute as A +import Control.Monad.Except hiding (join)+import Control.Monad.Reader hiding (join) import qualified Data.Vector as V-import qualified ProjectM36.Attribute as A import qualified Data.UUID as U import qualified Data.Set as S import qualified Data.Map as M-import Control.Monad+import qualified Data.List.NonEmpty as NE import Data.Time.Clock import qualified Data.Text as T import GHC.Generics@@ -26,12 +29,7 @@ #endif import Control.Arrow import Data.Maybe--{----import Debug.Trace-import Control.Monad.Reader-import qualified ProjectM36.DisconnectedTransaction as D--}+import Data.UUID.V4  -- | Record a lookup for a specific transaction in the graph. data TransactionIdLookup = TransactionIdLookup TransactionId |@@ -64,13 +62,21 @@                                   deriving Show  bootstrapTransactionGraph :: UTCTime -> TransactionId -> DatabaseContext -> TransactionGraph-bootstrapTransactionGraph stamp freshId context = TransactionGraph bootstrapHeads bootstrapTransactions+bootstrapTransactionGraph stamp' freshId context = TransactionGraph bootstrapHeads bootstrapTransactions   where     bootstrapHeads = M.singleton "master" freshTransaction     newSchemas = Schemas context M.empty-    freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty stamp) newSchemas+    freshTransaction = fresh freshId stamp' newSchemas     bootstrapTransactions = S.singleton freshTransaction +-- | Create a transaction graph from a context.+freshTransactionGraph :: DatabaseContext -> IO (TransactionGraph, TransactionId)+freshTransactionGraph ctx = do+  now <- getCurrentTime+  freshId <- nextRandom+  pure (bootstrapTransactionGraph now freshId ctx, freshId)++ emptyTransactionGraph :: TransactionGraph emptyTransactionGraph = TransactionGraph M.empty S.empty @@ -88,76 +94,77 @@   where     matchingTrans = M.filter (transaction ==) heads -transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction-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)- transactionsForIds :: S.Set TransactionId -> TransactionGraph -> Either RelationalError (S.Set Transaction) transactionsForIds idSet graph =   S.fromList <$> forM (S.toList idSet) (`transactionForId` graph) -isRootTransaction :: Transaction -> TransactionGraph -> Bool-isRootTransaction (Transaction _ (TransactionInfo pId _ _) _) _ = U.null pId-isRootTransaction (Transaction _ MergeTransactionInfo{} _) _  = False+-- | A root transaction terminates a graph and has no parents.+isRootTransaction :: Transaction -> Bool+isRootTransaction trans = parentIds trans == S.singleton U.nil +rootTransactions :: TransactionGraph -> S.Set Transaction+rootTransactions graph = S.filter isRootTransaction (transactionsForGraph graph)+ -- the first transaction has no parent - all other do have parents- merges have two parents parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)-parentTransactions (Transaction _ (TransactionInfo pId _ _) _) graph = -  S.singleton <$> transactionForId pId graph---parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _ _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph-+parentTransactions trans = transactionsForIds (parentIds trans)  childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)-childTransactions (Transaction _ (TransactionInfo _ children _) _) = transactionsForIds children-childTransactions (Transaction _ (MergeTransactionInfo _ _ children _) _) = transactionsForIds children+childTransactions trans graph = transactionsForIds childIds graph+  where+    childIds = S.map transactionId (S.filter filt (transactionsForGraph graph))+    filt trans' = S.member (transactionId trans) (parentIds trans')  -- create a new commit and add it to the heads -- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent) addBranch :: UTCTime -> TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)-addBranch stamp newId newBranchName branchPointId graph = do+addBranch stamp' newId newBranchName branchPointId graph = do   parentTrans <- transactionForId branchPointId graph-  let newTrans = Transaction newId (TransactionInfo branchPointId S.empty stamp) (schemas parentTrans)+  let newTrans = Transaction newId (TI.singleParent branchPointId stamp') (schemas parentTrans)   addTransactionToGraph newBranchName newTrans graph  --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' _) = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty stamp) schemas')-+addDisconnectedTransaction stamp' newId headName (DisconnectedTransaction parentId schemas' _) = addTransactionToGraph headName newTrans+  where+    newTrans = Transaction newId (TI.singleParent parentId stamp') schemas'  addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph) addTransactionToGraph headName newTrans graph = do-  let parentIds = transactionParentIds newTrans-      childIds = transactionChildIds newTrans+  let parentIds' = parentIds newTrans       newId = transactionId newTrans       validateIds ids = mapM (`transactionForId` graph) (S.toList ids)-      addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))+  childTs <- childTransactions newTrans graph   --validate that the parent transactions are in the graph-  _ <- validateIds parentIds-  when (S.size parentIds < 1) (Left $ NewTransactionMissingParentError newId)+  _ <- validateIds parentIds'+  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 -    Just trans -> when (S.notMember (transactionId trans) parentIds) (Left (HeadNameSwitchingHeadProhibitedError headName))+    Just trans -> when (S.notMember (transactionId trans) parentIds') (Left (HeadNameSwitchingHeadProhibitedError headName))   --validate that the transaction has no children-  unless (S.null childIds) (Left $ NewTransactionMayNotHaveChildrenError newId)+  unless (S.null childTs) (Left $ NewTransactionMayNotHaveChildrenError newId)   --validate that the trasaction's id is unique   when (isRight (transactionForId newId graph)) (Left (TransactionIdInUseError newId))-  --update the parent transactions to point to the new transaction-  parents <- mapM (`transactionForId` graph) (S.toList parentIds)-  let updatedParents = S.map addChildTransaction (S.fromList parents)-      updatedTransSet = S.insert newTrans (S.union updatedParents (transactionsForGraph graph))-      updatedHeads = M.insert headName newTrans (transactionHeadsForGraph graph)-  pure (newTrans, TransactionGraph updatedHeads updatedTransSet)+  --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) +--replace all occurrences of the uncommitted context marker+newTransUncommittedReplace :: Transaction -> Transaction+newTransUncommittedReplace trans@(Transaction tid tinfo (Schemas ctx sschemas)) =+  Transaction tid tinfo (Schemas fixedContext sschemas)+  where+  uncommittedReplace UncommittedContextMarker = TransactionMarker tid+  uncommittedReplace marker = marker+  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@@ -228,7 +235,7 @@   case transactionForId jumpDest graph of     Left err -> Left err     Right trans -> do-      let disconnectedTrans = DisconnectedTransaction (transactionId trans) (schemas trans) False+      let disconnectedTrans = Discon.freshTransaction (transactionId trans) (schemas trans)       Right (disconnectedTrans, graph)                -- add new head pointing to branchPoint@@ -246,15 +253,15 @@  -- create a new commit and add it to the heads -- technically, the new head could be added to an existing commit, but by adding a new commit, the new head is unambiguously linked to a new commit (with a context indentical to its parent)-evalGraphOp stamp newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do-  let newDiscon = DisconnectedTransaction newId schemas' False-  case addBranch stamp newId newBranchName parentId graph of+evalGraphOp stamp' newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do+  let newDiscon = Discon.freshTransaction newId schemas'+  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+evalGraphOp stamp' newTransId discon@(DisconnectedTransaction parentId schemas' _) graph Commit = case transactionForId parentId graph of   Left err -> Left err   Right parentTransaction -> case headNameForTransaction parentTransaction graph of     Nothing -> Left $ TransactionIsNotAHeadError parentId@@ -262,17 +269,20 @@       Left err-> Left err       Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)       where-        newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False-        maybeUpdatedGraph = addDisconnectedTransaction stamp newTransId headName discon graph+        newDisconnectedTrans = Discon.freshTransaction newTransId schemas'+        maybeUpdatedGraph = addDisconnectedTransaction stamp' newTransId headName discon graph  -- refresh the disconnected transaction, return the same graph evalGraphOp _ _ (DisconnectedTransaction parentId _ _) graph Rollback = case transactionForId parentId graph of   Left err -> Left err   Right parentTransaction -> Right (newDiscon, graph)     where-      newDiscon = DisconnectedTransaction parentId (schemas parentTransaction) False+      newDiscon = Discon.freshTransaction parentId (schemas parentTransaction)       -evalGraphOp stamp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph+evalGraphOp stamp' newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = +  runGraphRefRelationalExprM env $ mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB)+  where+    env = freshGraphRefRelationalExprEnv Nothing graph  evalGraphOp _ _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of   Nothing -> Left (NoSuchHeadNameError branchName)@@ -294,7 +304,7 @@     tupleGenerator transaction = case transactionParentsRelation transaction graph of       Left err -> Left err       Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),-                                     DateTimeAtom (transactionTimestamp transaction),+                                     DateTimeAtom (timestamp transaction),                                      RelationAtom parentTransRel,                                      BoolAtom $ parentId == transactionId transaction,                                      TextAtom $ fromMaybe "" (headNameForTransaction transaction graph)@@ -302,7 +312,7 @@  transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation transactionParentsRelation trans graph = -  if isRootTransaction trans graph then    +  if isRootTransaction trans then         mkRelation attrs emptyTupleSet     else do       parentTransSet <- parentTransactions trans graph@@ -321,39 +331,45 @@ -}  -- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph-createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction-createMergeTransaction stamp newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do-  let selectedTrans = validateHeadName selectedBranch graph t2-  Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty stamp) . schemas <$> selectedTrans+createMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction+createMergeTransaction stamp' newId (SelectedBranchMergeStrategy selectedBranch) t2@(trans1, trans2) = do+  graph <- gfGraph+  selectedTrans <- validateHeadName selectedBranch graph t2+  pure $ Transaction newId (TransactionInfo {+                        parents = NE.fromList [transactionId trans1,+                                               transactionId trans2],+                        stamp = stamp' }) (schemas selectedTrans)                         -- merge functions, relvars, individually-createMergeTransaction stamp newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction stamp newId strat graph t2+createMergeTransaction stamp' newId strat@UnionMergeStrategy t2 =+  createUnionMergeTransaction stamp' newId strat t2  -- merge function, relvars, but, on error, just take the component from the preferred branch-createMergeTransaction stamp newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction stamp newId strat graph t2+createMergeTransaction stamp' newId strat@(UnionPreferMergeStrategy _) t2 =+  createUnionMergeTransaction stamp' newId strat t2  -- | Returns the correct Transaction for the branch name in the graph and ensures that it is one of the two transaction arguments in the tuple.-validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction+validateHeadName :: HeadName -> TransactionGraph -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction validateHeadName headName graph (t1, t2) =   case transactionForHead headName graph of-    Nothing -> Left SelectedHeadMismatchMergeError+    Nothing -> throwError (MergeTransactionError SelectedHeadMismatchMergeError)     Just trans -> if trans /= t1 && trans /= t2 then -                    Left SelectedHeadMismatchMergeError +                    throwError (MergeTransactionError SelectedHeadMismatchMergeError)                   else-                    Right trans+                    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. subGraphOfFirstCommonAncestor :: TransactionGraph -> TransactionHeads -> Transaction -> Transaction -> S.Set Transaction -> Either RelationalError TransactionGraph-subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans goalTrans traverseSet = do-  let currentid = transactionId currentTrans+subGraphOfFirstCommonAncestor origGraph resultHeads currentTrans' goalTrans traverseSet = do+  let currentid = transactionId currentTrans'       goalid = transactionId goalTrans-  if currentTrans == goalTrans then+  if currentTrans' == goalTrans then     Right (TransactionGraph resultHeads traverseSet) -- add filter     --catch root transaction to improve error?     else do-    currentTransChildren <- S.fromList <$> mapM (`transactionForId` origGraph) (S.toList (transactionChildIds currentTrans))            -    let searchChildren = S.difference (S.insert currentTrans traverseSet) currentTransChildren-        searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans traverseSet)+    currentTransChildren <- childTransactions currentTrans' origGraph+    let searchChildren = S.difference (S.insert currentTrans' traverseSet) currentTransChildren+        searchChild start = pathToTransaction origGraph start goalTrans (S.insert currentTrans' traverseSet)         childSearches = map searchChild (S.toList searchChildren)         errors = lefts childSearches         pathsFound = rights childSearches@@ -362,17 +378,16 @@     unless (null realErrors) (Left (head realErrors))     -- if no paths found, search the parent     if null pathsFound then-      case oneParent currentTrans of+      case oneParent currentTrans' of         Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)         Left err -> Left err         Right currentTransParent ->-          subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans traverseSet)+          subGraphOfFirstCommonAncestor origGraph resultHeads currentTransParent goalTrans (S.insert currentTrans' traverseSet)       else -- we found a path       Right (TransactionGraph resultHeads (S.unions (traverseSet : pathsFound)))   where-    oneParent (Transaction _ (TransactionInfo parentId _ _) _) = transactionForId parentId origGraph-    oneParent (Transaction _ (MergeTransactionInfo parentId _ _ _) _) = transactionForId parentId origGraph-+    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@@ -380,11 +395,11 @@   if transactionId targetTransaction == transactionId currentTransaction then     Right accumTransSet     else do-    currentTransChildren <- mapM (`transactionForId` graph) (S.toList (transactionChildIds currentTransaction))        +    currentTransChildren <- childTransactions currentTransaction graph     if null currentTransChildren then       Left (FailedToFindTransactionError targetId)       else do-      let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren+      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@@ -394,35 +409,39 @@            else --we have some paths!              Right (S.unions paths) -mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)-mergeTransactions stamp newId parentId mergeStrategy (headNameA, headNameB) graph = do+mergeTransactions :: UTCTime -> TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> GraphRefRelationalExprM (DisconnectedTransaction, TransactionGraph)+mergeTransactions stamp' newId parentId mergeStrategy (headNameA, headNameB) = do+  graph <- gfGraph   let transactionForHeadErr name = case transactionForHead name graph of-        Nothing -> Left (NoSuchHeadNameError name)-        Just t -> Right t-  transA <- transactionForHeadErr headNameA -  transB <- transactionForHeadErr headNameB -  disconParent <- transactionForId parentId graph+        Nothing -> throwError (NoSuchHeadNameError name)+        Just t -> pure t+      runE e = case e of+        Left e' -> throwError e'+        Right v -> pure v+  transA <- transactionForHeadErr headNameA+  transB <- transactionForHeadErr headNameB+  disconParent <- gfTransForId parentId   let subHeads = M.filterWithKey (\k _ -> k `elem` [headNameA, headNameB]) (transactionHeadsForGraph graph)-  subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty-  subGraph' <- filterSubGraph subGraph subHeads-  case createMergeTransaction stamp newId mergeStrategy subGraph' (transA, transB) of-    Left err -> Left (MergeTransactionError err)-    Right mergedTrans -> case checkConstraints (concreteDatabaseContext mergedTrans) of-      Left err -> Left err-      Right _ -> case headNameForTransaction disconParent graph of-        Nothing -> Left (TransactionIsNotAHeadError parentId)+  subGraph <- runE $ subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty+  subGraph' <- runE $ filterSubGraph subGraph subHeads+  mergedTrans <- local (const (freshGraphRefRelationalExprEnv Nothing subGraph')) $ createMergeTransaction stamp' newId mergeStrategy (transA, transB)+  case headNameForTransaction disconParent graph of+        Nothing -> throwError (TransactionIsNotAHeadError parentId)         Just headName -> do-          (newTrans, newGraph) <- addTransactionToGraph headName mergedTrans graph-          let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)-              newDiscon = DisconnectedTransaction newId (schemas newTrans) False-          pure (newDiscon, newGraph')+          (newTrans, newGraph) <- runE $ addTransactionToGraph headName mergedTrans graph+          case checkConstraints (concreteDatabaseContext mergedTrans) newId graph of+            Left err -> throwError err+            Right _ -> do+              let newGraph' = TransactionGraph (transactionHeadsForGraph newGraph) (transactionsForGraph newGraph)+                  newDiscon = Discon.freshTransaction newId (schemas newTrans)+              pure (newDiscon, newGraph')    --TEMPORARY COPY/PASTE   showTransactionStructureX :: Transaction -> TransactionGraph -> String showTransactionStructureX trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " " ++ parentTransactionsInfo   where     headInfo = maybe "" show (headNameForTransaction trans graph)-    parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of+    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   @@ -441,25 +460,29 @@     newHeads = M.map (filterTransaction validIds) heads      --helper function for commonalities in union merge-createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction-createUnionMergeTransaction stamp newId strategy graph (t1,t2) = do+createUnionMergeTransaction :: UTCTime -> TransactionId -> MergeStrategy -> (Transaction, Transaction) -> GraphRefRelationalExprM Transaction+createUnionMergeTransaction stamp' newId strategy (t1,t2) = do   let contextA = concreteDatabaseContext t1       contextB = concreteDatabaseContext t2-  +      liftMergeE x = case x of+        Left e -> throwError (MergeTransactionError e)+        Right t -> pure t+        +  graph <- gfGraph   preference <- case strategy of      UnionMergeStrategy -> pure PreferNeither     UnionPreferMergeStrategy preferBranch ->       case transactionForHead preferBranch graph of-        Nothing -> Left (PreferredHeadMissingMergeError preferBranch)+        Nothing -> throwError (MergeTransactionError (PreferredHeadMissingMergeError preferBranch))         Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond-    badStrat -> Left (InvalidMergeStrategyError badStrat)+    badStrat -> throwError (MergeTransactionError (InvalidMergeStrategyError badStrat))           -  incDeps <- unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)+  incDeps <- liftMergeE $ unionMergeMaps preference (inclusionDependencies contextA) (inclusionDependencies contextB)   relVars <- unionMergeRelVars preference (relationVariables contextA) (relationVariables contextB)-  atomFuncs <- unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)-  notifs <- unionMergeMaps preference (notifications contextA) (notifications contextB)-  types <- unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)-  dbcFuncs <- unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)+  atomFuncs <- liftMergeE $ unionMergeAtomFunctions preference (atomFunctions contextA) (atomFunctions contextB)+  notifs <- liftMergeE $ unionMergeMaps preference (notifications contextA) (notifications contextB)+  types <- liftMergeE $ unionMergeTypeConstructorMapping preference (typeConstructorMapping contextA) (typeConstructorMapping contextB)+  dbcFuncs <- liftMergeE $ unionMergeDatabaseContextFunctions preference (dbcFunctions contextA) (dbcFunctions contextB)   -- TODO: add merge of subschemas   let newContext = DatabaseContext {         inclusionDependencies = incDeps, @@ -470,7 +493,10 @@         typeConstructorMapping = types         }       newSchemas = Schemas newContext (subschemas t1)-  pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty stamp) newSchemas)+  pure (Transaction newId (TransactionInfo {+                              parents = NE.fromList [transactionId t1,+                                                     transactionId t2],+                              stamp = stamp'}) newSchemas)  lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph@@ -487,56 +513,57 @@ -- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do   trans <- transactionForId currentTid graph-  let parents = S.toAscList (transactionParentIds trans)-  if null parents then-    Left RootTransactionTraversalError-    else do-    parentTrans <- transactionForId (head parents) graph-    if steps == 1 then-      pure (transactionId parentTrans)-      else-      backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))++  let parentIds' = S.toAscList (parentIds trans)+  case parentIds' of+    [] -> Left RootTransactionTraversalError+    firstParentId:_ -> do+      parentTrans <- transactionForId firstParentId graph+      if steps == 1 then+        pure (transactionId parentTrans)+        else+        backtrackGraph graph (transactionId parentTrans) (TransactionIdHeadParentBacktrack (steps - 1))    backtrackGraph graph currentTid (TransactionIdHeadBranchBacktrack steps) = do   trans <- transactionForId currentTid graph-  let parents = transactionParentIds trans-  if S.size parents < 1 then+  let parentIds' = parentIds trans+  if S.size parentIds' < 1 then     Left RootTransactionTraversalError    -    else if S.size parents < steps then-           Left (ParentCountTraversalError (S.size parents) steps)+    else if S.size parentIds' < steps then+           Left (ParentCountTraversalError (S.size parentIds') steps)          else-           pure (S.elemAt (steps - 1) parents)+           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 parents = transactionParentIds trans-  if transactionTimestamp trans <= stamp then+  let parentIds' = parentIds trans  +  if timestamp trans <= stamp' then     pure currentTid-    else if S.null parents then+    else if S.null parentIds' then            Left RootTransactionTraversalError          else-           let arbitraryParent = head (S.toList parents) in+           let arbitraryParent = head (S.toList parentIds') in            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)-autoMergeToHead stamp (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do+autoMergeToHead stamp' (tempBranchTransId, tempCommitTransId, mergeTransId) discon mergeToHeadName strat graph = do   let tempBranchName = "mergebranch_" <> U.toText tempBranchTransId   --create the temp branch-  (discon', graph') <- evalGraphOp stamp tempBranchTransId discon graph (Branch tempBranchName)+  (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+  (discon'', graph'') <- evalGraphOp stamp' tempCommitTransId discon' graph' Commit     --jump to merge head-  (discon''', graph''') <- evalGraphOp stamp tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)+  (discon''', graph''') <- evalGraphOp stamp' tempBranchTransId discon'' graph'' (JumpToHead mergeToHeadName)      --create the merge-  (discon'''', graph'''') <- evalGraphOp stamp mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)+  (discon'''', graph'''') <- evalGraphOp stamp' mergeTransId discon''' graph''' (MergeTransactions strat tempBranchName mergeToHeadName)      --delete the temp branch-  (discon''''', graph''''') <- evalGraphOp stamp tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)+  (discon''''', graph''''') <- evalGraphOp stamp' tempBranchTransId discon'''' graph'''' (DeleteBranch tempBranchName)   {-   let rel = runReader (evalRelationalExpr (RelationVariable "s" ())) (mkRelationalExprState $ D.concreteDatabaseContext discon'''')   traceShowM rel@@ -544,4 +571,4 @@      pure (discon''''', graph''''') -  +

src/lib/ProjectM36/TransactionGraph/Merge.hs view

@@ -2,10 +2,11 @@ module ProjectM36.TransactionGraph.Merge where import ProjectM36.Base import ProjectM36.Error+import ProjectM36.RelationalExpression+import Control.Monad.Except hiding (join) import qualified Data.Set as S import qualified Data.Map as M import qualified ProjectM36.TypeConstructorDef as TCD-import ProjectM36.Relation import Control.Monad (foldM) import qualified Data.HashSet as HS @@ -22,19 +23,22 @@                      Left StrategyViolatesComponentMergeError                       -- perform the merge even if the attributes are different- is this what we want? Obviously, we need finer-grained merge options.-unionMergeRelation :: MergePreference -> Relation -> Relation -> Either MergeError Relation-unionMergeRelation prefer relA relB = case relA `union` relB of-    Right unionRel -> pure unionRel-    Left (AttributeNamesMismatchError _) -> preferredRelVar-    Left _ -> Left StrategyViolatesRelationVariableMergeError-    where-      preferredRelVar = case prefer of-        PreferFirst -> Right relA-        PreferSecond -> Right relB-        PreferNeither -> Left StrategyViolatesRelationVariableMergeError+unionMergeRelation :: MergePreference -> GraphRefRelationalExpr -> GraphRefRelationalExpr -> GraphRefRelationalExprM GraphRefRelationalExpr+unionMergeRelation prefer relA relB = do+  let unioned = Union relA relB+      mergeErr = MergeTransactionError StrategyViolatesRelationVariableMergeError+      preferredRelVar =+        case prefer of+          PreferFirst -> pure relA+          PreferSecond -> pure relB+          PreferNeither -> throwError mergeErr+      handler AttributeNamesMismatchError{} = preferredRelVar+      handler _err' = throwError mergeErr+  --typecheck first?+  (evalGraphRefRelationalExpr unioned >> pure (Union relA relB)) `catchError` handler  --try to execute unions against the relvars contents -- if a relvar only appears in one context, include it-unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> Either MergeError RelationVariables+unionMergeRelVars :: MergePreference -> RelationVariables -> RelationVariables -> GraphRefRelationalExprM RelationVariables unionMergeRelVars prefer relvarsA relvarsB = do   let allNames = S.toList (S.union (M.keysSet relvarsA) (M.keysSet relvarsB))   foldM (\acc name -> do

src/lib/ProjectM36/TransactionGraph/Persist.hs view

@@ -1,8 +1,8 @@ module ProjectM36.TransactionGraph.Persist where import ProjectM36.Error-import ProjectM36.TransactionGraph import ProjectM36.Transaction import ProjectM36.Transaction.Persist+import ProjectM36.RelationalExpression import ProjectM36.Base import ProjectM36.ScriptSession import ProjectM36.Persist (writeFileSync, renameSync, DiskSync)@@ -194,12 +194,12 @@     uuidInfo = T.intercalate "\n" graphLines     digest = SHA256.hash (encodeUtf8 uuidInfo)     graphLines = S.toList $ S.map graphLine transSet -    epochTime = realToFrac . utcTimeToPOSIXSeconds . transactionTimestamp :: Transaction -> Double+    epochTime = realToFrac . utcTimeToPOSIXSeconds . timestamp :: Transaction -> Double     graphLine trans = U.toText (transactionId trans)                        <> " "                        <> T.pack (show (epochTime trans))                       <> " "-                      <> T.intercalate " " (S.toList (S.map U.toText $ transactionParentIds trans))+                      <> T.intercalate " " (S.toList (S.map U.toText $ parentIds trans))      readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash readGraphTransactionIdFileDigest dbdir = do@@ -209,8 +209,8 @@ readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])]) readGraphTransactionIdFile dbdir = do   --read in all transactions' uuids-  let grapher line = let tid:epochText:parentIds = T.words line in-        (readUUID tid, readEpoch epochText, map readUUID parentIds)+  let grapher line = let tid:epochText:parentIds' = T.words line in+        (readUUID tid, readEpoch epochText, map readUUID parentIds')       readUUID uuidText = fromMaybe (error "failed to read uuid") (U.fromText uuidText)       readEpoch t = posixSecondsToUTCTime (realToFrac (either (error "failed to read epoch") fst (double t)))   Right . map grapher . T.lines <$> readUTF8FileOrError (transactionLogPath dbdir)@@ -225,3 +225,4 @@       case TE.decodeUtf8' fileBytes of         Left err -> error (show err)         Right utf8Bytes -> pure utf8Bytes+

src/lib/ProjectM36/TransactionGraph/Show.hs view

@@ -1,17 +1,16 @@ module ProjectM36.TransactionGraph.Show where import ProjectM36.Base import ProjectM36.TransactionGraph-import ProjectM36.Transaction import qualified Data.Set as S  showTransactionStructure :: Transaction -> TransactionGraph -> String-showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " p" ++ parentTransactionsInfo ++ " c" ++ childTransactionsInfo+showTransactionStructure trans graph = headInfo ++ " " ++ show (transactionId trans) ++ " p" ++ parentTransactionsInfo   where     headInfo = maybe "" show (headNameForTransaction trans graph)-    parentTransactionsInfo = if isRootTransaction trans graph then "root" else case parentTransactions trans graph of+    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-    childTransactionsInfo = show (S.toList (transactionChildIds trans))+    showGraphStructure :: TransactionGraph -> String showGraphStructure graph@(TransactionGraph _ transSet) = S.foldr folder "" transSet

+ src/lib/ProjectM36/TransactionInfo.hs view

@@ -0,0 +1,10 @@+module ProjectM36.TransactionInfo where+import ProjectM36.Base+import Data.Time.Clock+import Data.List.NonEmpty++-- | Create a TransactionInfo with just one parent transaction ID.+singleParent :: TransactionId -> UTCTime -> TransactionInfo+singleParent tid stamp' = TransactionInfo {+  parents = tid :| [],+  stamp = stamp' }

+ src/lib/ProjectM36/WithNameExpr.hs view

@@ -0,0 +1,84 @@+module ProjectM36.WithNameExpr where+import ProjectM36.Base++-- substitute all instances of With-based macros to remove macro context+-- ideally, we would use a different relational expr type to "prove" that the with macros can no longer exist+type WithNameAssocs = [(GraphRefWithNameExpr, GraphRefRelationalExpr)]+-- | Drop macros into the relational expression wherever they are referenced.+substituteWithNameMacros ::+  WithNameAssocs ->+  GraphRefRelationalExpr ->+  GraphRefRelationalExpr+substituteWithNameMacros _ e@MakeRelationFromExprs{} = e+substituteWithNameMacros _ e@MakeStaticRelation{} = e+substituteWithNameMacros _ e@ExistingRelation{} = e+substituteWithNameMacros macros e@(RelationVariable rvname tid) =+  let+    macroFilt (WithNameExpr macroName macroTid, _) = rvname == macroName && tid== macroTid in+  case filter macroFilt macros of+    [] -> e+    [(_,replacement)] -> replacement+    _ -> error "more than one macro matched!"+substituteWithNameMacros macros (Project attrs expr) =+  Project attrs (substituteWithNameMacros macros expr)+substituteWithNameMacros macros (Union exprA exprB) =+  Union (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)+substituteWithNameMacros macros (Join exprA exprB) =+  Join (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)+substituteWithNameMacros macros (Rename attrA attrB expr) =+  Rename attrA attrB (substituteWithNameMacros macros expr)+substituteWithNameMacros macros (Difference exprA exprB) =+  Difference (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)+substituteWithNameMacros macros (Group attrs attr expr) =+  Group attrs attr (substituteWithNameMacros macros expr)  +substituteWithNameMacros macros (Ungroup attr expr) =+  Ungroup attr (substituteWithNameMacros macros expr)  +substituteWithNameMacros macros (Restrict pred' expr) =+  Restrict (substituteWithNameMacrosRestrictionPredicate macros pred') (substituteWithNameMacros macros expr)  +substituteWithNameMacros macros (Equals exprA exprB) =+  Equals (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)+substituteWithNameMacros macros (NotEquals exprA exprB) =+  NotEquals (substituteWithNameMacros macros exprA) (substituteWithNameMacros macros exprB)+substituteWithNameMacros macros (Extend extendTup expr) =+  Extend (substituteWitNameMacrosExtendTupleExpr macros extendTup) (substituteWithNameMacros macros expr)+substituteWithNameMacros macros (With moreMacros expr) =+  --collect and override existing macros and recurse+  let newMacros = foldr macroFolder macros moreMacros+      macroFolder (wnexpr, mexpr) acc = filter (\(w,_) -> w /= wnexpr) acc ++ [(wnexpr, mexpr)] in+        --scan for a match- if it exists, replace it (representing a with clause at a lower level+  substituteWithNameMacros newMacros expr+++substituteWithNameMacrosRestrictionPredicate :: WithNameAssocs -> GraphRefRestrictionPredicateExpr -> GraphRefRestrictionPredicateExpr+substituteWithNameMacrosRestrictionPredicate macros pred' =+  let sub = substituteWithNameMacrosRestrictionPredicate macros in+  case pred' of+    TruePredicate -> pred'+    AndPredicate exprA exprB ->+      AndPredicate (sub exprA) (sub exprB)+    OrPredicate exprA exprB ->+      OrPredicate (sub exprA) (sub exprB)+    NotPredicate expr ->+      NotPredicate (sub expr)+    RelationalExprPredicate reexpr ->+      RelationalExprPredicate (substituteWithNameMacros macros reexpr)+    AtomExprPredicate atomExpr ->+      AtomExprPredicate (substituteWithNameMacrosAtomExpr macros atomExpr)+    AttributeEqualityPredicate attrName atomExpr ->+      AttributeEqualityPredicate attrName (substituteWithNameMacrosAtomExpr macros atomExpr)++substituteWitNameMacrosExtendTupleExpr :: WithNameAssocs -> GraphRefExtendTupleExpr -> GraphRefExtendTupleExpr+substituteWitNameMacrosExtendTupleExpr macros (AttributeExtendTupleExpr attrName atomExpr) =+  AttributeExtendTupleExpr attrName (substituteWithNameMacrosAtomExpr macros atomExpr)++substituteWithNameMacrosAtomExpr :: WithNameAssocs -> GraphRefAtomExpr -> GraphRefAtomExpr+substituteWithNameMacrosAtomExpr macros atomExpr =+  case atomExpr of+    e@AttributeAtomExpr{} -> e+    e@NakedAtomExpr{} -> e+    FunctionAtomExpr fname atomExprs tid ->+      FunctionAtomExpr fname (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid+    RelationAtomExpr reExpr ->+      RelationAtomExpr (substituteWithNameMacros macros reExpr)+    ConstructedAtomExpr dconsName atomExprs tid ->+      ConstructedAtomExpr dconsName (map (substituteWithNameMacrosAtomExpr macros) atomExprs) tid

test/IsomorphicSchema.hs view

@@ -4,13 +4,13 @@ import ProjectM36.IsomorphicSchema import ProjectM36.Relation import ProjectM36.RelationalExpression+import ProjectM36.TransactionGraph+import ProjectM36.StaticOptimizer import qualified ProjectM36.DatabaseContext as DBC import qualified ProjectM36.Attribute as A import System.Exit import qualified Data.Map as M import qualified Data.Set as S-import Control.Monad.State-import Control.Monad.Trans.Reader  testList :: Test testList = TestList [testIsoRename, testIsoRestrict, testIsoUnion, testSchemaValidation]@@ -36,7 +36,7 @@ testSchemaValidation :: Test testSchemaValidation = TestCase $ do     let potentialSchema = DBC.basicDatabaseContext {-        relationVariables = M.singleton "anotherRel" relationTrue+        relationVariables = M.singleton "anotherRel" (ExistingRelation relationTrue)         }   -- missing relvars failure       morphs = [IsoRename "true" "true", IsoRename "false" "false"]@@ -50,15 +50,17 @@ testIsoRename :: Test testIsoRename = TestCase $ do   -- create a schema with two relvars and rename one while the other remains the same in the isomorphic schema-  let schemaA = mkRelationalExprState DBC.empty { -        relationVariables = M.fromList [("employee", relationTrue), -                                        ("department", relationFalse)]+  let ctx = DBC.empty { +        relationVariables = M.fromList [("employee", ExistingRelation relationTrue), +                                        ("department", ExistingRelation relationFalse)]         }-      isomorphsAtoB = [IsoRename "emp" "employee", +  (graph, _) <- freshTransactionGraph ctx+  let isomorphsAtoB = [IsoRename "emp" "employee",                         IsoRename "department" "department"]-      unionExpr = Union (RelationVariable "emp" ()) (RelationVariable "department" ())      +      unionExpr = Union (RelationVariable "emp" ()) (RelationVariable "department" ())+      env = mkRelationalExprEnv ctx graph   relExpr <- assertEither (applyRelationalExprSchemaIsomorphs isomorphsAtoB unionExpr)-  let relResult = runReader (evalRelationalExpr relExpr) schemaA                             +  let relResult = optimizeAndEvalRelationalExpr env relExpr   assertEqual "employee relation morph" (Right relationTrue) relResult    testIsoRestrict :: Test@@ -67,59 +69,67 @@   -- the virtual schema has an employee   let empattrs = A.attributesFromList [Attribute "name" TextAtomType,                                         Attribute "boss" TextAtomType]+  (graph, transId) <- freshTransactionGraph DBC.empty                    emprel <- assertEither $ mkRelationFromList empattrs             [[TextAtom "Steve", TextAtom ""],              [TextAtom "Cindy", TextAtom "Steve"],              [TextAtom "Sam", TextAtom "Steve"]]   let predicate = AttributeEqualityPredicate "boss" (NakedAtomExpr (TextAtom ""))-  bossRel <- assertEither $ runReader (evalRelationalExpr (Restrict predicate (ExistingRelation emprel))) (mkRelationalExprState DBC.empty)-  nonBossRel <- assertEither $ runReader (evalRelationalExpr (Restrict (NotPredicate predicate) (ExistingRelation emprel))) (mkRelationalExprState DBC.empty)+      reenv = mkRelationalExprEnv DBC.empty graph+  bossRel <- assertEither $ runRelationalExprM reenv (evalRelationalExpr (Restrict predicate (ExistingRelation emprel)))+  nonBossRel <- assertEither $ runRelationalExprM reenv (evalRelationalExpr (Restrict (NotPredicate predicate) (ExistingRelation emprel)))             -  let schemaA = mkRelationalExprState DBC.empty {-        relationVariables = M.fromList [("nonboss", nonBossRel),-                                        ("boss", bossRel)]+  let schemaA = mkRelationalExprEnv baseContext graph+      baseContext = DBC.empty {+        relationVariables = M.fromList [("nonboss", ExistingRelation nonBossRel),+                                        ("boss", ExistingRelation bossRel)]         }-       isomorphsAtoB = [IsoRestrict "employee" predicate ("boss", "nonboss")]       bossq = RelationVariable "boss" ()       nonbossq = RelationVariable "nonboss" ()       employeeq = RelationVariable "employee" ()       unionq = Union bossq nonbossq   empExpr <- assertEither (applyRelationalExprSchemaIsomorphs isomorphsAtoB employeeq)-  let empResult = runReader (evalRelationalExpr empExpr) schemaA-      unionResult = runReader (evalRelationalExpr unionq) schemaA+  let empResult = evalRelExpr (evalRelationalExpr empExpr)+      unionResult = evalRelExpr (evalRelationalExpr unionq)+      evalRelExpr = runRelationalExprM schemaA   assertEqual "boss/nonboss isorestrict" unionResult empResult   --execute database context expr   bobRel <- assertEither (mkRelationFromList empattrs [[TextAtom "Bob", TextAtom ""]])   let schemaBInsertExpr = Insert "employee" (ExistingRelation bobRel)   schemaBInsertExpr' <- assertEither (processDatabaseContextExprInSchema (Schema isomorphsAtoB) schemaBInsertExpr)-  let (postInsertContext,_,_) = execState (evalDatabaseContextExpr schemaBInsertExpr') (freshDatabaseState (stateElemsContext schemaA))-      expectedRel = runReader (evalRelationalExpr (Union (RelationVariable "boss" ()) (RelationVariable "nonboss" ()))) (mkRelationalExprState postInsertContext)+  let Right dbcState = evalDBCExpr schemaBInsertExpr'+      postInsertContext = dbc_context dbcState+      evalDBCExpr expr' = runDatabaseContextEvalMonad baseContext dbcenv (optimizeAndEvalDatabaseContextExpr False expr')+      dbcenv = mkDatabaseContextEvalEnv transId graph+      expectedRel = runRelationalExprM postInsertEnv (evalRelationalExpr (Union (RelationVariable "boss" ()) (RelationVariable "nonboss" ())))+      postInsertEnv = mkRelationalExprEnv postInsertContext graph   --execute the expression against the schema and compare against the base context   processedExpr <- assertEither (processRelationalExprInSchema (Schema isomorphsAtoB) (RelationVariable "employee" ()))-  let processedRel = runReader (evalRelationalExpr processedExpr) (mkRelationalExprState postInsertContext)+  let processedRel = runRelationalExprM postInsertEnv (evalRelationalExpr processedExpr)   assertEqual "insert bob boss" expectedRel processedRel    testIsoUnion :: Test   testIsoUnion = TestCase $ do   --create motors relation which is split into low-power (<50 horsepower) and high-power (>=50 horsepower) motors   --the schema is contains the split relvars+  (graph, _) <- freshTransactionGraph DBC.empty   motorsRel <- assertEither $ mkRelationFromList (A.attributesFromList [Attribute "name" TextAtomType,                                                                         Attribute "power" IntegerAtomType])                 [[TextAtom "Puny", IntegerAtom 10],                 [TextAtom "Scooter", IntegerAtom 49],                 [TextAtom "Auto", IntegerAtom 200],                 [TextAtom "Tractor", IntegerAtom 500]]-  let baseSchema = mkRelationalExprState DBC.basicDatabaseContext {-        relationVariables = M.singleton "motor" motorsRel-        }+  let env = mkRelationalExprEnv DBC.basicDatabaseContext {+        relationVariables = M.singleton "motor" (ExistingRelation motorsRel)+        } graph       splitPredicate = AtomExprPredicate (FunctionAtomExpr "lt" [AttributeAtomExpr "power", NakedAtomExpr (IntegerAtom 50)] ())       splitIsomorphs = [IsoUnion ("lowpower", "highpower") splitPredicate "motor",                         IsoRename "true" "true",                         IsoRename "false" "false"]-      lowmotors = runReader (evalRelationalExpr (Restrict splitPredicate (RelationVariable "motor" ()))) baseSchema-      highmotors = runReader (evalRelationalExpr (Restrict (NotPredicate splitPredicate) (RelationVariable "motor" ()))) baseSchema-      relResult expr = runReader (evalRelationalExpr expr) baseSchema+      lowmotors = runRelationalExprM env (evalRelationalExpr (Restrict splitPredicate (RelationVariable "motor" ())))+      highmotors = runRelationalExprM env (evalRelationalExpr (Restrict (NotPredicate splitPredicate) (RelationVariable "motor" ())))+      relResult expr = runRelationalExprM env (evalRelationalExpr expr)   lowpowerExpr <- assertEither (processRelationalExprInSchema (Schema splitIsomorphs) (RelationVariable "lowpower" ()))   lowpowerRel <- assertEither (relResult lowpowerExpr)   highpowerExpr <- assertEither (processRelationalExprInSchema (Schema splitIsomorphs) (RelationVariable "highpower" ()))

test/Relation/Atomable.hs view

@@ -104,7 +104,7 @@   let createRelExpr = Assign "x" rel                    rel = MakeRelationFromExprs Nothing-            [TupleExpr (M.singleton "a1" (NakedAtomExpr atomVal))]+            (TupleExprs () [TupleExpr (M.singleton "a1" (NakedAtomExpr atomVal))])       atomVal = toAtom exampleVal       exampleVal = Test1C 10   checkExecuteDatabaseContextExpr sessionId dbconn createRelExpr@@ -194,4 +194,3 @@    let example5 = Test9_5C 1 2 3 4 5   assertEqual "five fields product type" example5 (fromAtom (toAtom example5))-

test/Relation/Basic.hs view

@@ -7,9 +7,9 @@ import ProjectM36.Attribute hiding (null, attributeNames) import ProjectM36.DataTypes.Primitive import ProjectM36.RelationalExpression+import ProjectM36.TransactionGraph import ProjectM36.Tuple import qualified ProjectM36.DatabaseContext as DBC-import Control.Monad.Trans.Reader import qualified ProjectM36.Attribute as A import qualified Data.Map as M import qualified Data.Vector as V@@ -64,7 +64,7 @@     tupleAtomCheck tuple = V.all (== True) (attrChecks tuple)     attrChecks tuple = V.map (\attr -> case atomForAttributeName (A.attributeName attr) tuple of                                  Left _ -> False-                                 Right atom -> (Right $ atomTypeForAtom atom) ==+                                 Right atom -> Right (atomTypeForAtom atom) ==                                   A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)      simpleRel :: Relation    @@ -94,8 +94,12 @@  testMkRelationFromExprsBadAttrs :: Test testMkRelationFromExprsBadAttrs = TestCase $ do-  let context = DBC.empty-  case runReader (evalRelationalExpr (MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))])) (mkRelationalExprState context) of+  let context = DBC.empty +  (graph,_) <- freshTransactionGraph context  +  let reenv = mkRelationalExprEnv context graph+      reExpr = MakeRelationFromExprs (Just [AttributeAndTypeNameExpr "badAttr1" (PrimitiveTypeConstructor "Int" IntAtomType) ()]) (TupleExprs () [TupleExpr (M.singleton "badAttr2" (NakedAtomExpr (IntAtom 1)))])+      evald = runRelationalExprM reenv (evalRelationalExpr reExpr)+  case evald of     Left err -> assertEqual "tuple type mismatch" (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "badAttr2" IntAtomType])) err     Right _ -> assertFailure "expected tuple type mismatch" @@ -108,5 +112,7 @@    testExistingRelationType :: Test testExistingRelationType = TestCase $ do-  let typeResult = runReader (typeForRelationalExpr (ExistingRelation relationTrue)) (RelationalExprStateElems DBC.empty)+  (graph, _) <- freshTransactionGraph dateExamples+  let typeResult = runRelationalExprM reenv (typeForRelationalExpr (ExistingRelation relationTrue))+      reenv = mkRelationalExprEnv dateExamples graph   assertEqual "ExistingRelation with tuples type" (Right relationFalse) typeResult

test/Relation/StaticOptimizer.hs view

@@ -1,13 +1,12 @@ import ProjectM36.Base import ProjectM36.Relation-import ProjectM36.RelationalExpression+import ProjectM36.TransactionGraph import ProjectM36.DateExamples-import ProjectM36.Error import ProjectM36.TupleSet import ProjectM36.StaticOptimizer+import ProjectM36.DatabaseContext as DBC import System.Exit import Control.Monad.State-import Control.Monad.Trans.Reader import Test.HUnit import qualified Data.Set as S @@ -16,100 +15,126 @@   tcounts <- runTestTT (TestList tests)   if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess   where-    tests = relationOptTests ++ databaseOptTests ++ [testTransitiveOptimization,-                                                     testImpossiblePredicates,-                                                     testJoinElimination,-                                                     testRestrictionPredicateCollapse,-                                                     testPushDownRestrictionPredicate]-    optDBCTest = map (\(name, expr, unopt) -> TestCase $ assertEqual name expr (evalState (applyStaticDatabaseOptimization unopt) (freshDatabaseState dateExamples)))-    relvar nam = RelationVariable nam ()-    startState = mkRelationalExprState dateExamples-    optRelTest = map (\(name, expr, unopt) -> TestCase $ assertEqual name expr (runReader (applyStaticRelationalOptimization unopt) startState))-    relationOptTests = optRelTest [-      ("StaticProject", Right $ relvar "s", Project (AttributeNames (attributeNames suppliersRel)) (relvar "s")),-      ("StaticUnion", Right $ relvar "s", Union (relvar "s") (relvar "s")),-      ("StaticJoin", Right $ relvar "s", Join (relvar "s") (relvar "s"))-      ]-    databaseOptTests = optDBCTest [-      ("StaticAssign", -       Right $ Assign "z" (relvar "s"),-       Assign "z" (Restrict TruePredicate (relvar "s"))-       ),-      ("StaticMultipleExpr", -       Right $ MultipleExpr [Assign "z" (relvar "s"), -                             Assign "z" (relvar "s")],-       MultipleExpr [Assign "z" (Restrict TruePredicate (relvar "s")),-                     Assign "z" (Restrict TruePredicate (relvar "s"))])-      ]+    tests = [testTransitiveOptimization,+              testImpossiblePredicates,+              testJoinElimination,+              testRestrictionPredicateCollapse,+              testPushDownRestrictionPredicate,+              testOptimizeRelationalExpr,+              testOptimizeDatabaseContextExpr] +testOptimizeDatabaseContextExpr :: Test+testOptimizeDatabaseContextExpr = TestCase $ do+  (graph, transId) <- freshTransactionGraph DBC.empty+  let relvar nam = RelationVariable nam ()+      relvarId nam = RelationVariable nam UncommittedContextMarker+      testInfos = [+        ("StaticAssign", +         Right $ Assign "z" (relvarId "s"),+         Assign "z" (Restrict TruePredicate (relvar "s"))+        ),+        ("StaticMultipleExpr", +         Right $ MultipleExpr [Assign "z" (relvarId "s"), +                               Assign "z" (relvarId "s")],+         MultipleExpr [Assign "z" (Restrict TruePredicate (relvar "s")),+                       Assign "z" (Restrict TruePredicate (relvar "s"))])+        ]+  forM_ testInfos $ \(name, expectedExpr, unoptExpr) -> do+    let optExpr = runGraphRefSOptDatabaseContextExprM transId dateExamples graph (optimizeDatabaseContextExpr unoptExpr)+    assertEqual name expectedExpr optExpr+ testTransitiveOptimization :: Test testTransitiveOptimization = TestCase $ do+  (graph, _) <- freshTransactionGraph dateExamples   let expr atomexpr = AndPredicate (AttributeEqualityPredicate "a" (NakedAtomExpr (IntegerAtom 300))) (AttributeEqualityPredicate "b" atomexpr)       exprIn = expr (AttributeAtomExpr "a")       exprOut = expr (NakedAtomExpr (IntegerAtom 300))-  assertEqual "transitive property" (Right exprOut) (runReader (applyStaticPredicateOptimization exprIn) (RelationalExprStateElems dateExamples))-  -optRelExpr :: RelationalExpr -> Either RelationalError RelationalExpr-optRelExpr expr = runReader (applyStaticRelationalOptimization expr) (RelationalExprStateElems dateExamples)+      optExpr = runGraphRefSOptRelationalExprM Nothing graph (applyStaticPredicateOptimization exprIn)+  assertEqual "transitive property" (Right exprOut) optExpr ++testOptimizeRelationalExpr :: Test+testOptimizeRelationalExpr = TestCase $ do+  (graph, _) <- freshTransactionGraph dateExamples+  let relvarId nam = RelationVariable nam UncommittedContextMarker+      relationOptTests = [+        ("StaticProject",+         Right $ relvarId "s",+         Project (AttributeNames (attributeNames suppliersRel)) (relvarId "s")),+        ("StaticUnion",+         Right $ relvarId "s",+         Union (relvarId "s") (relvarId "s")),+        ("StaticJoin",+         Right $ relvarId "s",+         Join (relvarId "s") (relvarId "s"))+        ]+  forM_ relationOptTests $ \(name, expr, unoptExpr) -> do+    let optExpr = runGraphRefSOptRelationalExprM (Just dateExamples) graph (optimizeGraphRefRelationalExpr unoptExpr)+    assertEqual name expr optExpr+ testImpossiblePredicates :: Test   testImpossiblePredicates = TestCase $ do+  (graph, _) <- freshTransactionGraph dateExamples     let tautTrue = Restrict (AtomExprPredicate (NakedAtomExpr (BoolAtom True))) rel       tautTrue2 = Restrict TruePredicate rel       tautFalse = Restrict (AtomExprPredicate (NakedAtomExpr (BoolAtom False))) rel       tautFalse2 = Restrict (NotPredicate TruePredicate) rel       emptyRel = MakeStaticRelation (attributes suppliersRel) emptyTupleSet-      rel = RelationVariable "s" ()+      rel = RelationVariable "s" UncommittedContextMarker+      optRelExpr expr = optimizeGraphRefRelationalExpr' (Just dateExamples) graph expr         assertEqual "remove tautology where true" (Right rel) (optRelExpr tautTrue)   assertEqual "remove tautology where true2" (Right rel) (optRelExpr tautTrue2)   assertEqual "remove tautology where false" (Right emptyRel) (optRelExpr tautFalse)   assertEqual "remove tautology where false2" (Right emptyRel) (optRelExpr tautFalse2)-  -optJoinExpr :: RelationalExpr -> Either RelationalError RelationalExpr-optJoinExpr expr = runReader (applyStaticJoinElimination expr) (RelationalExprStateElems dateExamples)  testJoinElimination :: Test   testJoinElimination = TestCase $ do+  (graph, _) <- freshTransactionGraph dateExamples  +  let marker = UncommittedContextMarker+      optJoinExpr expr = runGraphRefSOptRelationalExprM (Just dateExamples) graph (applyStaticJoinElimination expr)+      relvar rv = RelationVariable rv marker+   -- (s join sp){s#,qty,p#} == sp-  let unoptExpr = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ()))-  assertEqual "remove extraneous join" (Right (RelationVariable "sp" ())) (optJoinExpr unoptExpr)+  let unoptExpr = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (relvar "sp") (relvar "s"))+  assertEqual "remove extraneous join" (Right (relvar "sp")) (optJoinExpr unoptExpr)    -- (sp join s){s#,qty,p#} == sp --flip relvar names-  let unoptExpr2 = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (RelationVariable "s" ()) (RelationVariable "sp" ()))  -  assertEqual "remove extraneous join2" (Right (RelationVariable "sp" ())) (optJoinExpr unoptExpr2)+  let unoptExpr2 = Project (AttributeNames (S.fromList ["p#", "qty", "s#"])) (Join (relvar "s") (relvar "sp"))  +  assertEqual "remove extraneous join2" (Right (relvar "sp")) (optJoinExpr unoptExpr2)    -- (sp join s){s#,qty,sname} != sp - attribute from s included-  let expr3 = Project (AttributeNames (S.fromList ["p#", "qty", "sname"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ()))+  let expr3 = Project (AttributeNames (S.fromList ["p#", "qty", "sname"])) (Join (relvar "sp") (relvar "s"))   assertEqual "retain join" (Right expr3) (optJoinExpr expr3)    -- (sp join s){qty} != sp --projection does not include foreign key attribute-  let expr4 = Project (AttributeNames (S.singleton "qty")) (Join (RelationVariable "sp" ()) (RelationVariable "s" ()))+  let expr4 = Project (AttributeNames (S.singleton "qty")) (Join (relvar "sp") (relvar "s"))   assertEqual "retain join2" (Right expr4) (optJoinExpr expr4)      -- (sp join s){s#,qty} == sp - a subset of attributes in the projection are in the foreign key-  let expr5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (Join (RelationVariable "sp" ()) (RelationVariable "s" ()))-  let expect5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (RelationVariable "sp" ())+  let expr5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (Join (relvar "sp") (relvar "s"))+  let expect5 = Project (AttributeNames (S.fromList ["s#", "qty"])) (relvar "sp")   assertEqual "remove extraneous join (attribute subset)" (Right expect5) (optJoinExpr expr5)      -- (s join p){s#,p#} != sp -- no foreign key-  let expr6 = Project (AttributeNames (S.fromList ["s#", "p#"])) (Join (RelationVariable "s" ()) (RelationVariable "p" ()))+  let expr6 = Project (AttributeNames (S.fromList ["s#", "p#"])) (Join (relvar "s") (relvar "p"))   assertEqual "retain join- no foreign key" (Right expr6) (optJoinExpr expr6)    -- (s join p){s#,qty,p#,sname} != sp -- all sp attributes plus one s attributes-  let expr7 = Project (AttributeNames (S.fromList ["s#", "p#", "qty", "sname"])) (Join (RelationVariable "s" ()) (RelationVariable "sp" ()))+  let expr7 = Project (AttributeNames (S.fromList ["s#", "p#", "qty", "sname"])) (Join (relvar "s") (relvar "sp"))   assertEqual "retain join- attributes from both relvars" (Right expr7) (optJoinExpr expr7)        testRestrictionPredicateCollapse :: Test testRestrictionPredicateCollapse = TestCase $ do   let expr1 = Restrict (NotPredicate TruePredicate) rv-      rv = RelationVariable "a" ()+      rv = RelationVariable "a" UncommittedContextMarker+      relvar name = RelationVariable name UncommittedContextMarker   assertEqual "one restriction" expr1 (applyStaticRestrictionCollapse expr1)      let attrEqualsPred = AttributeEqualityPredicate "x" (NakedAtomExpr (IntAtom 3))-      expr2 = Restrict TruePredicate (Restrict attrEqualsPred (RelationVariable "a" ()))-  assertEqual "two restrictions" (Restrict (AndPredicate TruePredicate attrEqualsPred) (RelationVariable "a" ())) (applyStaticRestrictionCollapse expr2)+      expr2 = Restrict TruePredicate (Restrict attrEqualsPred (relvar "a"))+  assertEqual "two restrictions" (Restrict (AndPredicate TruePredicate attrEqualsPred) (relvar "a")) (applyStaticRestrictionCollapse expr2)   -  let expr3 = Restrict pred1 (Restrict pred2 (Restrict pred3 (RelationVariable "a" ())))+  let expr3 = Restrict pred1 (Restrict pred2 (Restrict pred3 (relvar "a")))       pred1 = NotPredicate TruePredicate       pred2 = attrEqualsPred       pred3 = AtomExprPredicate (NakedAtomExpr (BoolAtom True))@@ -123,7 +148,7 @@ testPushDownRestrictionPredicate :: Test testPushDownRestrictionPredicate = TestCase $ do   -- (s union relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}}) where status = 30 == (s where status=30) union (relation{tuple{city "Boston", s# "S6", sname "Stevens", status 50}} where status=30)-  let rvs = RelationVariable "s" ()+  let rvs = RelationVariable "s" UncommittedContextMarker   let status30 = AttributeEqualityPredicate "status" (NakedAtomExpr (IntAtom 30))       relationsOrError = do             stevens <- mkRelationFromList (attributes suppliersRel) [[TextAtom "S6", TextAtom "Stevens", IntegerAtom 50, TextAtom "Boston"]]

test/Relation/Tupleable.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, TypeOperators, DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts, DeriveAnyClass #-} import Test.HUnit import ProjectM36.Tupleable import ProjectM36.Atomable

test/Server/Main.hs view

@@ -94,7 +94,8 @@                                          persistenceStrategy = CrashSafePersistence (tempdir </> "db"),                                          perRequestTimeout = ti,                                          testMode = True,-                                         bindPort = 0+                                         bindPort = 0,+                                         checkFS = False --not stricly needed for these tests                                        }            launchServer config (Just addressMVar) >> pure ()@@ -146,10 +147,11 @@   let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Int" IntAtomType) ()]       testrv = "testrv"       dbExpr = Define testrv attrExprs+      expected = Define testrv [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Int" IntAtomType) UncommittedContextMarker]   planResult <- planForDatabaseContextExpr sessionId conn dbExpr   case planResult of     Left err -> assertFailure (show err)-    Right plan -> assertEqual "planForDatabaseContextExpr failure" dbExpr plan+    Right plan -> assertEqual "planForDatabaseContextExpr failure" expected plan          testTransactionGraphAsRelation :: SessionId -> Connection -> Test     testTransactionGraphAsRelation sessionId conn = TestCase $ do

test/Server/WebSocket.hs view

@@ -32,7 +32,8 @@ launchTestServer = do   addressMVar <- newEmptyMVar   let config = defaultServerConfig { databaseName = testDatabaseName, -                                     bindPort = 0 }+                                     bindPort = 0,+                                     checkFS = False}       testDatabaseName = "test"   -- start normal server   _ <- forkIO (launchServer config (Just addressMVar) >> pure ())@@ -56,13 +57,14 @@   if secondsToTry <= 0 then     throw WaitForSocketListenException     else do-    hostaddr <- inet_addr "127.0.0.1"+    --hostaddr <- inet_addr "127.0.0.1"+    hostaddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just (show port))     sock <- socket AF_INET Stream defaultProtocol     let handler :: IOException -> IO ()         handler _ = do           threadDelay 1000000           waitForListenSocket (secondsToTry - 1) port-    catch (connect sock (SockAddrInet port hostaddr)) handler+    catch (connect sock (addrAddress hostaddr)) handler    main :: IO () main = do

test/TransactionGraph/Merge.hs view

@@ -10,6 +10,7 @@ import qualified ProjectM36.DisconnectedTransaction as Discon import qualified ProjectM36.DatabaseContext as DBC import ProjectM36.RelationalExpression+import ProjectM36.StaticOptimizer  import qualified Data.ByteString.Lazy as BS import System.Exit@@ -20,8 +21,7 @@ import Data.Maybe import Data.Time.Clock import Data.Time.Calendar--import Control.Monad.State+import qualified Data.List.NonEmpty as NE  {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} @@ -61,9 +61,10 @@       uuidA = fakeUUID 10       uuidB = fakeUUID 11       uuidRoot = fakeUUID 1+      parents' = uuidRoot NE.:| []       rootContext = concreteDatabaseContext rootTrans-  (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph-  (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty testTime) rootContext) bsGraph'+  (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo parents' testTime) rootContext) bsGraph+  (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo parents' testTime) rootContext) bsGraph'   pure bsGraph''    addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)@@ -107,7 +108,7 @@   baseGraph <- basicTransactionGraph     transA <- assertMaybe (transactionForHead "branchA" baseGraph) "failed to get branchA"   transB <- assertMaybe (transactionForHead "branchB" baseGraph) "failed to get branchB"-  (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1) S.empty testTime) (concreteDatabaseContext transA)) baseGraph+  (_, graph) <- addTransaction "branchC" (createTrans (fakeUUID 12) (TransactionInfo (fakeUUID 1 NE.:| []) testTime) (concreteDatabaseContext transA)) baseGraph   subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty   assertGraph subgraph   let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)  @@ -121,16 +122,18 @@    -- add another relvar to branchB   branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"-  (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of-    (Left err, _) -> assertFailure (show err) >> undefined-    (Right (), context) -> pure context-  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph+  let env = mkDatabaseContextEvalEnv (transactionId branchBTrans) graph+      branchBContext = concreteDatabaseContext branchBTrans+  updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of+    Left err -> assertFailure (show err) >> undefined+    Right st -> pure $ dbc_context st+  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph   branchBTrans' <- assertMaybe (transactionForHead "branchB" graph') "failed to get branchB head"     assertEqual "branchB id 3" (fakeUUID 3) (transactionId branchBTrans')        -- add another transaction to branchA   branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"  -  (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) (concreteDatabaseContext branchATrans)) graph'+  (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) (concreteDatabaseContext branchATrans)) graph'   branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"   assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')                                               @@ -148,12 +151,15 @@      -- add another relvar to branchB   branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"-  (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of-    (Left err, _) -> assertFailure (show err) >> undefined-    (Right (), context) -> pure context-  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph+  let env = mkDatabaseContextEvalEnv (transactionId branchBTrans) graph+      branchBContext = concreteDatabaseContext branchBTrans  +  updatedBranchBContext <- case runDatabaseContextEvalMonad branchBContext env (optimizeAndEvalDatabaseContextExpr True (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) of+    Left err -> assertFailure (show err) >> undefined+    Right st -> pure (dbc_context st)+  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph   --create the merge transaction in the graph-  let eGraph' = mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'+  let eGraph' = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB")+      gfEnv = freshGraphRefRelationalExprEnv Nothing graph'          (_, graph'') <- assertEither eGraph' @@ -175,18 +181,22 @@   branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "branchBTrans"   branchBRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []     let branchAContext = (concreteDatabaseContext branchATrans) {relationVariables = M.insert conflictRelVarName branchARelVar (relationVariables (concreteDatabaseContext branchATrans))}-      branchARelVar = relationTrue-      branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName branchBRelVar (relationVariables (concreteDatabaseContext branchBTrans))}-      conflictRelVarName = "conflictRelVar"+      branchARelVar = ExistingRelation relationTrue +      branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert conflictRelVarName (ExistingRelation branchBRelVar) (relationVariables (concreteDatabaseContext branchBTrans))}+      conflictRelVarName = "conflictRelVar"  -  (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph-  (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph'+  (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) branchAContext) graph+  (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) branchBContext) graph'   -- validate that the conflict is hidden because we preferred a branch-  let merged = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''+  let merged = runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB")+      env = freshGraphRefRelationalExprEnv Nothing graph''   case merged of     Left err -> assertFailure ("expected merge success: " ++ show err)-    Right (discon, _) ->-      assertEqual "branchB relvar preferred in conflict" (Just branchBRelVar) (M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon)))+    Right (discon, _) -> do+      let Just rvExpr = M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon))+          reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph+      let eRvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr)+      assertEqual "branchB relvar preferred in conflict" (Right branchBRelVar) eRvRel    -- try various individual component conflicts and check for merge failure testUnionMergeStrategy :: Test@@ -201,31 +211,41 @@    let updatedBranchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.insert branchBOnlyRelVarName branchBOnlyRelVar (relationVariables (concreteDatabaseContext branchBTrans)) }       updatedBranchAContext = (concreteDatabaseContext branchATrans) {inclusionDependencies = M.insert branchAOnlyIncDepName branchAOnlyIncDep (inclusionDependencies (concreteDatabaseContext branchATrans)) }-      branchBOnlyRelVar = relationTrue+      branchBOnlyRelVar = ExistingRelation relationTrue       branchAOnlyIncDepName = "branchAOnlyIncDep"       branchBOnlyRelVarName = "branchBOnlyRelVar"       branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)-  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) updatedBranchBContext) graph-  (discon, _) <- assertEither $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB") graph'-  assertEqual "branchBOnlyRelVar should appear in the merge" (M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))) (Just relationTrue)-  (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) updatedBranchAContext) graph'-  let eMergeGraph = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''+  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) updatedBranchBContext) graph+  let env = freshGraphRefRelationalExprEnv Nothing graph'+  (discon, _) <- assertEither $ runGraphRefRelationalExprM env $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 10) UnionMergeStrategy ("branchA", "branchB")+  let Just rvExpr = M.lookup branchBOnlyRelVarName (relationVariables (Discon.concreteDatabaseContext discon))+      Right rvRel = runGraphRefRelationalExprM reEnv (evalGraphRefRelationalExpr rvExpr)+      reEnv = freshGraphRefRelationalExprEnv (Just (Discon.concreteDatabaseContext discon)) graph+      +  assertEqual "branchBOnlyRelVar should appear in the merge" relationTrue rvRel+  (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) updatedBranchAContext) graph'+  let eMergeGraph = runGraphRefRelationalExprM gfEnv $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")+      gfEnv = freshGraphRefRelationalExprEnv Nothing graph''   case eMergeGraph of     Left err -> assertFailure ("expected merge success: " ++ show err)     Right (_, mergeGraph) -> do       -- check that the new merge transaction has the correct parents       mergeTrans <- assertEither $ transactionForId (fakeUUID 5) mergeGraph       let mergeContext = concreteDatabaseContext mergeTrans-      assertEqual "merge transaction parents" (transactionParentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])+      assertEqual "merge transaction parents" (parentIds mergeTrans) (S.fromList [fakeUUID 3, fakeUUID 4])       -- check that the new merge tranasction has elements from both A and B branches-      assertEqual "merge transaction relvars" (Just relationTrue) (M.lookup branchBOnlyRelVarName (relationVariables mergeContext))+      let Just rvExpr' = M.lookup branchBOnlyRelVarName (relationVariables mergeContext)+          Right rvRel' = runGraphRefRelationalExprM reEnv' (evalGraphRefRelationalExpr rvExpr')+          reEnv' = freshGraphRefRelationalExprEnv (Just mergeContext) graph+      assertEqual "merge transaction relvars" relationTrue rvRel'       assertEqual "merge transaction incdeps" (Just branchAOnlyIncDep) (M.lookup branchAOnlyIncDepName (inclusionDependencies mergeContext))        -- test an expected conflict- add branchBOnlyRelVar with same name but different attributes       conflictRelVar <- assertEither $ mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) []-      let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName conflictRelVar (relationVariables updatedBranchAContext) }+      let conflictContextA = updatedBranchAContext {relationVariables = M.insert branchBOnlyRelVarName (ExistingRelation conflictRelVar) (relationVariables updatedBranchAContext) }       conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"-      (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty testTime) conflictContextA) graph''-      let failingMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'''+      (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans NE.:| []) testTime) conflictContextA) graph''+      let failingMerge = runGraphRefRelationalExprM gfEnv' $ mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB")+          gfEnv' = freshGraphRefRelationalExprEnv Nothing graph'''       case failingMerge of         Right _ -> assertFailure "expected merge failure"         Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)@@ -244,20 +264,21 @@       rvName = "x"       Right branchArv = eRel 2       Right branchBrv = eRel 3-      branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchArv}-      branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName branchBrv, +      branchAContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchArv)}+      branchBContext = (concreteDatabaseContext branchBTrans) {relationVariables = M.singleton rvName (ExistingRelation branchBrv),                                                                 inclusionDependencies = M.singleton incDepName incDep}             incDepName = "x_key"       incDep = inclusionDependencyForKey (AttributeNames (S.singleton "x")) (RelationVariable "x" ())      --add the rv in new commits to both branches-  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty testTime) branchBContext) graph+  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans NE.:| []) testTime) branchBContext) graph                   -  (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans) S.empty testTime) branchAContext) graph'+  (_, graph'') <- addTransaction "branchA" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchATrans NE.:| []) testTime) branchAContext) graph'      --check that the union merge fails due to a violated constraint-  let eMerge = mergeTransactions testTime (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph''+  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 err -> assertFailure ("other error: " ++ show err)

test/TransactionGraph/Persist.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} import Test.HUnit import ProjectM36.Base import ProjectM36.Persist (DiskSync(NoDiskSync))@@ -5,8 +6,6 @@ import ProjectM36.TransactionGraph import ProjectM36.Transaction import ProjectM36.DateExamples-import ProjectM36.Client-import ProjectM36.Relation import System.IO.Temp import System.Exit import Data.Either@@ -17,6 +16,10 @@ import qualified Data.Set as S import Data.Time.Clock import Data.Time.Calendar+#ifdef PM36_HASKELL_SCRIPTING+import ProjectM36.Client+import ProjectM36.Relation+#endif  main :: IO ()            main = do @@ -29,8 +32,8 @@                      testFunctionPersistence]                      -stamp :: UTCTime-stamp = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000)+stamp' :: UTCTime+stamp' = UTCTime (fromGregorian 1980 01 01) (secondsToDiffTime 1000)  {- bootstrap a database, ensure that it can be read -} testBootstrapDB :: Test@@ -38,7 +41,7 @@   let dbdir = tempdir </> "dbdir"   freshId <- nextRandom -  _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph stamp freshId dateExamples)+  _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph stamp' freshId dateExamples)   loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing   assertBool "transactionGraphLoad" $ isRight loadedGraph @@ -48,17 +51,17 @@   let dbdir = tempdir </> "dbdir"   freshId <- nextRandom -  let graph = bootstrapTransactionGraph stamp freshId dateExamples+  let graph = bootstrapTransactionGraph stamp' freshId dateExamples   _ <- bootstrapDatabaseDir NoDiskSync dbdir graph   case transactionForHead "master" graph of     Nothing -> assertFailure "Failed to retrieve head transaction for master branch."     Just headTrans -> -          case interpretDatabaseContextExpr (concreteDatabaseContext headTrans) "x:=s" of+          case interpretDatabaseContextExpr (concreteDatabaseContext headTrans) (transactionId headTrans) graph "x:=s" of             Left err -> assertFailure (show err)             Right context' -> do               freshId' <- nextRandom-              let newdiscon = DisconnectedTransaction (transactionId headTrans) (Schemas context' M.empty) True-                  addTrans = addDisconnectedTransaction stamp freshId' "master" newdiscon graph+              let newdiscon = DisconnectedTransaction (transactionId headTrans) (Schemas context' M.empty) False+                  addTrans = addDisconnectedTransaction stamp' freshId' "master" newdiscon graph               --add a transaction to the graph               case addTrans of                 Left err -> assertFailure (show err)@@ -75,7 +78,10 @@  --only Haskell-scripted dbc and atom functions can be serialized                    testFunctionPersistence :: Test-testFunctionPersistence = TestCase $ +#if !defined(PM36_HASKELL_SCRIPTING)+testFunctionPersistence = TestCase $ pure ()+#else+testFunctionPersistence = TestCase $  withSystemTempDirectory "m36testdb" $ \tempdir -> do   let dbdir = tempdir </> "dbdir"       connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []@@ -93,13 +99,14 @@   conn2 <- assertIOEither $ connectProjectM36 connInfo   sess2 <- assertIOEither $ createSessionAtHead conn2 "master"   -  res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))])+  res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))]))   let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]   assertEqual "testdisk dbc function run" expectedRel res-    + assertIOEither :: (Show a) => IO (Either a b) -> IO b assertIOEither x = do   ret <- x   case ret of     Left err -> assertFailure (show err) >> undefined     Right val -> pure val+#endif

test/TutorialD/Interpreter.hs view

@@ -9,6 +9,7 @@ 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@@ -39,8 +40,9 @@   tcounts <- runTestTT (TestList tests)   if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess   where-    tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ -            map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests  ++ [+    tests = [+      simpleRelTests,+      dateExampleRelTests,       transactionGraphBasicTest,        transactionGraphAddCommitTest,        transactionRollbackTest, @@ -75,9 +77,16 @@       testWithClause,       testAtomFunctionArgumentMismatch,       testInvalidDataConstructor,-      testBasicList+      testBasicList,+      testRelationDeclarationMismatch       ]-    simpleRelTests = [("x:=true", Right relationTrue),++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),@@ -116,25 +125,31 @@     simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]     simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntegerAtomType]     simpleDAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]-    maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)+    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]-    simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]-    simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]-    nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]-    extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (R.attributes suppliersRel)]     byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]    -    groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]     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-    dateExampleRelTests = [("x:=s where true", Right suppliersRel),-                           ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) 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])])),@@ -142,7 +157,7 @@                            --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 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)])),@@ -176,15 +191,18 @@                            ("x:=relation{tuple{a fromGregorian(2017,05,30)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DayAtomType]) [[DayAtom (fromGregorian 2017 05 30)]])                           ] -assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion-assertTutdEqual databaseContext expected tutd = assertEqual (unpack tutd) expected interpreted+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 tutd of+    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 rel -> Right rel+        Just relExpr -> do+          let env = freshGraphRefRelationalExprEnv (Just context) graph+          runGraphRefRelationalExprM env (evalGraphRefRelationalExpr relExpr) + transactionGraphBasicTest :: Test transactionGraphBasicTest = TestCase $ do   (_, dbconn) <- dateExamplesConnection emptyNotificationCallback@@ -211,7 +229,7 @@           commit sessionId dbconn >>= eitherFail           discon <- disconnectedTransaction_ sessionId dbconn           let context = Discon.concreteDatabaseContext discon-          assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)+          assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just (RelationVariable "s" UncommittedContextMarker))  transactionRollbackTest :: Test transactionRollbackTest = TestCase $ do@@ -253,12 +271,16 @@  -- test that overlapping attribute names with different types fail with an error failJoinTest :: Test-failJoinTest = TestCase $ assertTutdEqual basicDatabaseContext err "x:=relation{tuple{test 4}} join relation{tuple{test \"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 $ assertTutdEqual dateExamples joinedRel "x:=s join sp"+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,@@ -385,7 +407,9 @@     _ -> assertFailure "failed to delete branch"      testMultiAttributeRename :: Test-testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"+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,@@ -470,16 +494,22 @@   assertEqual "empty insert empty commit" (Right False) dirty'   Right () <- commit sessionId dbconn   -  --update no tuples+  --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 False) dirty''+  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 False) dirty'''+  assertEqual "empty delete empty commit" (Right True) dirty'''   testIntervalAtom :: Test   testIntervalAtom = TestCase $ do  @@ -656,3 +686,8 @@ 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\"}}"

test/TutorialD/Interpreter/AtomFunctionScript.hs view

@@ -1,25 +1,32 @@-import TutorialD.Interpreter.TestBase+{-# LANGUAGE CPP #-} import System.Exit import Test.HUnit+#ifdef PM36_HASKELL_SCRIPTING+import TutorialD.Interpreter.TestBase import ProjectM36.Client import ProjectM36.Relation import ProjectM36.DataTypes.Maybe import qualified Data.Vector as V import qualified Data.Map as M+#endif  {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} main :: IO () main = do-  tcounts <- runTestTT (TestList [testBasicAtomFunction,-                                  testExceptionAtomFunction,-                                  testErrorAtomFunction,-                                  testNoArgumentAtomFunction,-                                  testArgumentTypeMismatch,-                                  testPolymorphicReturnType,-                                  testScriptedTypeVariable-                                  ])+  tcounts <- runTestTT (TestList [+#ifdef PM36_HASKELL_SCRIPTING+    testBasicAtomFunction,+    testExceptionAtomFunction,+    testErrorAtomFunction,+    testNoArgumentAtomFunction,+    testArgumentTypeMismatch,+    testPolymorphicReturnType,+    testScriptedTypeVariable+#endif    +    ])   if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess +#ifdef PM36_HASKELL_SCRIPTING --add an atom function and run it testBasicAtomFunction :: Test testBasicAtomFunction = TestCase $ do@@ -29,7 +36,7 @@       funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()       tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]       expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 3]]-  result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)+  result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) (TupleExprs () tupleExprs))    assertEqual "simple atom function equality" expectedResult result   @@ -40,7 +47,7 @@   executeTutorialD sess conn "addatomfunction \"mkTest\" Integer -> Either AtomFunctionError Integer \"\"\"(\\(IntegerAtom x:xs) -> (error (show 1))) :: [Atom] -> Either AtomFunctionError Atom\"\"\""   let attrs = [Attribute "x" IntegerAtomType]       funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()-      tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]+      tupleExprs = TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)]   result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)   assertBool "catch error exception from script" (case result of                                                      Left (UnhandledExceptionError _) -> True@@ -57,7 +64,7 @@   executeTutorialD sess conn "addatomfunction \"mkTest\" Either AtomFunctionError Integer \"\"\"(\\x -> pure (IntegerAtom 5)) :: [Atom] -> Either AtomFunctionError Atom\"\"\""   let attrs = [Attribute "x" IntegerAtomType]       funcAtomExpr = FunctionAtomExpr  "mkTest" [] ()-      tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]+      tupleExprs = TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)]       expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 5]]   result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)   assertEqual "no argument scripted function" expectedResult result@@ -66,7 +73,7 @@ testArgumentTypeMismatch = TestCase $ do   (sess, conn) <- dateExamplesConnection emptyNotificationCallback   executeTutorialD sess conn "addatomfunction \"mkTest\" Integer -> Either AtomFunctionError Integer \"\"\"(\\(IntegerAtom x:_) -> pure $ TextAtom \"wrong type\") :: [Atom] -> Either AtomFunctionError Atom\"\"\""-  let tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]+  let tupleExprs = TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)]       funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()       attrs = [Attribute "x" IntegerAtomType]       expectedResult = Left (AtomTypeMismatchError IntegerAtomType TextAtomType)@@ -80,7 +87,7 @@   let funcAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntegerAtom 5),                                                    NakedAtomExpr maybeAtom] ()       maybeAtom = ConstructedAtom "Just" (maybeAtomType IntegerAtomType) [IntegerAtom 3]-      relExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" funcAtomExpr)]+      relExpr = MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)])   mRelType <- typeForRelationalExpr sess conn relExpr   case mRelType of     Left err -> assertFailure (show err)@@ -94,7 +101,7 @@   let failFuncAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntegerAtom 5),                                                        NakedAtomExpr mismatchAtom] ()       mismatchAtom = ConstructedAtom "Just" (maybeAtomType TextAtomType) [TextAtom "fail"]-      failRelExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" failFuncAtomExpr)]+      failRelExpr = MakeRelationFromExprs Nothing (TupleExprs () [TupleExpr (M.singleton "x" failFuncAtomExpr)])   mFailRes <- executeRelationalExpr sess conn failRelExpr   let expectedErr = Left (AtomFunctionTypeVariableMismatch "a" IntegerAtomType TextAtomType)   assertEqual "expected type variable mismatch" expectedErr mFailRes@@ -106,9 +113,10 @@   executeTutorialD sess conn "addatomfunction \"idTest\" a -> Either AtomFunctionError a \"(\\\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom\""   let attrs = [Attribute "x" IntegerAtomType]       funcAtomExpr = FunctionAtomExpr  "idTest" [NakedAtomExpr (IntegerAtom 3)] ()-      tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]+      tupleExprs = TupleExprs () [TupleExpr (M.singleton "x" funcAtomExpr)]       expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 3]]   result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)    assertEqual "id function equality" expectedResult result   +#endif

test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs view

@@ -1,19 +1,26 @@-import TutorialD.Interpreter.TestBase+{-# LANGUAGE CPP #-} import System.Exit import Test.HUnit+#ifdef PM36_HASKELL_SCRIPTING+import TutorialD.Interpreter.TestBase import ProjectM36.Client import ProjectM36.Relation import qualified Data.Text as T+#endif  main :: IO () main = do-  tcounts <- runTestTT (TestList [testBasicDBCFunction,-                                  testErrorDBCFunction,-                                  testExceptionDBCFunction,-                                  testDBCFunctionWithAtomArguments+  tcounts <- runTestTT (TestList [+#ifdef PM36_HASKELL_SCRIPTING+    testBasicDBCFunction,+    testErrorDBCFunction,+    testExceptionDBCFunction,+    testDBCFunctionWithAtomArguments+#endif                                                                     ])   if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess +#ifdef PM36_HASKELL_SCRIPTING testBasicDBCFunction :: Test testBasicDBCFunction = TestCase $ do     (sess, conn) <- dateExamplesConnection emptyNotificationCallback@@ -55,4 +62,4 @@   assertEqual "person relation" expectedPerson result   expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")" -+#endif

test/TutorialD/Interpreter/Import/TutorialD.hs view

@@ -20,10 +20,10 @@     hClose handle     let expectedExpr = MultipleExpr [           Assign "x" (MakeRelationFromExprs Nothing -                      [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),+                      $ TupleExprs () [TupleExpr (M.fromList [("a", NakedAtomExpr $ IntegerAtom 5),                                               ("b", NakedAtomExpr $ TextAtom "spam")])]),           Assign "y" (MakeRelationFromExprs Nothing -                      [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]+                      $ TupleExprs () [TupleExpr (M.fromList [("b", NakedAtomExpr (TextAtom "漢字"))])])]     imported <- importTutorialD tempPath     assertEqual "import tutd" (Right expectedExpr) imported

test/TutorialD/Interpreter/TestBase.hs view

@@ -2,16 +2,14 @@ import ProjectM36.Client import TutorialD.Interpreter import TutorialD.Interpreter.Base-import qualified ProjectM36.Base as Base import ProjectM36.DateExamples+import ProjectM36.DatabaseContext import Test.HUnit-import qualified Data.Map as M import Data.Text  dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection) dateExamplesConnection callback = do   dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback [])-  let incDeps = Base.inclusionDependencies dateExamples   case dbconn of      Left err -> error (show err)     Right conn -> do@@ -19,8 +17,7 @@       case eSessionId of         Left err -> error (show err)         Right sessionId -> do-          mapM_ (\(rvName,rvRel) -> executeDatabaseContextExpr sessionId conn (Assign rvName (Base.ExistingRelation rvRel))) (M.toList (Base.relationVariables dateExamples))-          mapM_ (\(idName,incDep) -> executeDatabaseContextExpr sessionId conn (AddInclusionDependency idName incDep)) (M.toList incDeps)+          executeDatabaseContextExpr sessionId conn (databaseContextAsDatabaseContextExpr dateExamples) >>= eitherFail       --skipping atom functions for now- there are no atom function manipulation operators yet           commit sessionId conn >>= eitherFail           pure (sessionId, conn)@@ -31,13 +28,13 @@     Right parsed -> do        result <- evalTutorialD sessionId conn UnsafeEvaluation parsed       case result of-        QuitResult -> putStrLn "yyy" >> assertFailure "quit?"-        DisplayResult _ -> putStrLn "xxx" >> assertFailure "display?"-        DisplayIOResult _ -> putStrLn "z" >> assertFailure "displayIO?"-        DisplayRelationResult _ -> putStrLn "Y" >> assertFailure "displayrelation?"-        DisplayDataFrameResult _ -> putStrLn "DF" >> assertFailure "displaydataframe?"-        DisplayParseErrorResult _ _ -> putStrLn "X" >> assertFailure "displayparseerrorresult?"-        DisplayErrorResult err -> putStrLn "asd" >> assertFailure (show tutd ++ ": " ++ show err)        +        QuitResult -> assertFailure "quit?"+        DisplayResult _ -> assertFailure "display?"+        DisplayIOResult _ -> assertFailure "displayIO?"+        DisplayRelationResult _ -> assertFailure "displayrelation?"+        DisplayDataFrameResult _ -> assertFailure "displaydataframe?"+        DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"+        DisplayErrorResult err -> assertFailure (show tutd ++ ": " ++ show err)                 QuietSuccessResult -> pure ()          expectTutorialDErr :: SessionId -> Connection -> (Text -> Bool) -> Text -> IO ()        @@ -52,7 +49,7 @@         DisplayRelationResult _ -> assertFailure "displayrelation?"         DisplayDataFrameResult _ -> assertFailure "displaydataframe?"         DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"-        DisplayErrorResult err -> assertBool ("match error on: " ++ unpack err) (matchFunc err)+        DisplayErrorResult err -> assertBool (unpack tutd ++ " match error on: " ++ unpack err) (matchFunc err)         QuietSuccessResult -> pure ()          eitherFail :: Either RelationalError a -> IO ()