packages feed

project-m36 (empty) → 0.1

raw patch · 114 files changed

+12256/−0 lines, 114 filesdep +Cabaldep +Globdep +HUnitsetup-changed

Dependencies added: Cabal, Glob, HUnit, MonadRandom, Win32, aeson, attoparsec, base, base64-bytestring, binary, bytestring, cassava, conduit, containers, criterion, cryptohash-sha256, data-interval, deepseq, deepseq-generics, directory, distributed-process, distributed-process-async, distributed-process-client-server, distributed-process-extras, either, extended-reals, filepath, ghc, ghc-boot, ghc-paths, gnuplot, hashable, hashable-time, haskeline, http-api-data, list-t, megaparsec, monad-parallel, mtl, network, network-transport, network-transport-tcp, old-locale, optparse-applicative, parallel, path-pieces, project-m36, random, random-shuffle, resourcet, semigroups, stm, stm-containers, template-haskell, temporary, text, time, transformers, unix, unordered-containers, uuid, uuid-aeson, vector, vector-binary-instances, websockets

Files

+ Changelog.markdown view
@@ -0,0 +1,28 @@+# 2017-06-12++## add file locking++This [feature](#102) allows Project:M36 database directories to be shared amongst multiple Project:M36 processes. This is similar to how SQLite operates except that the remote server mode supports the feature as well. This could allow, for example, multi-master, file-based replication across Windows shares or NFS.++[Documentation](/docs/replication.markdown)++# 2016-11-30++## add functional dependency macro++Date demonstrates two ways to implement functional dependencies as constraints on page 21 in "Database Design and Relational Theory". A similar macros is now implemented in the tutd interpreter.++```funcdep sname_status (sname) -> (status) s```++[Documentation](/docs/tutd_tutorial.markdown#functional-dependencies)++# 2016-09-07++## add TransGraphRelationalExpr++The TransGraphRelationalExpr allows queries against all past states of the database.++The following example executes a query against two different committed transactions using syntax similar to that of git for graph traversal:+```:showtransgraphexpr s@master~ join sp@master```++[Documentation](/docs/transgraphrelationalexpr.markdown)
+ README.markdown view
@@ -0,0 +1,85 @@+# Ξ Project:M36 Relational Algebra Engine++*Software can always be made faster, but rarely can it be made more correct.*++## Introduction++Project:M36 implements a relational algebra engine as inspired by the writings of Chris Date.++## Description++Unlike most database management systems (DBMS), Project:M36 is opinionated software which adheres strictly to the mathematics of the relational algebra. The purpose of this adherence is to prove that software which implements mathematically-sound design principles reaps benefits in the form of code clarity, consistency, performance, and future-proofing.++Project:M36 can be used as an in-process or remote DBMS.++Project:M36 is written entirely in the [Haskell programming language](https://www.haskell.org/).++## Sample Session++[![asciicast](https://asciinema.org/a/3syu35c8cydm403292a74l1n5.png)](https://asciinema.org/a/3syu35c8cydm403292a74l1n5)++## Try It!++You can experiment instantly with Project:M36 straight from your browser at [try.project-m36.io](https://try.project-m36.io)!++## Use-Cases++Project:M36 supports multiple frontends which target different audiences.++* learn about the relational algebra via TutorialD+* store and manipulate databases+* use Project:M36 as a native Haskell database backend++## Community++* [Developer's Blog](https://agentm.github.io/project-m36/)+* [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36)+* IRC Channel: chat.freenode.net #project-m36++## Documentation++### Introductory Materials++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 Tutorial](docs/tutd_tutorial.markdown)+1. [15 Minute Tutorial](docs/15_minute_tutorial.markdown)+1. [Developer's Change Log](Changelog.markdown)++### Database Comparisons++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)++### Advanced Features++1. [Transaction Graph Operators](docs/transaction_graph_operators.markdown)+1. [ProjectM36.Client Library](docs/projectm36_client_library.markdown)+1. [Adding New Data Types](docs/new_datatypes.markdown)+1. [Database-Manipulating Functions](docs/database_context_functions.markdown)+1. [Serving Remote ProjectM36 Databases](docs/server_mode.markdown)+1. [Using Notifications](docs/using_notifications.markdown)+1. [Merge Transactions](docs/merge_transactions.markdown)+1. [WebSocket Server](docs/websocket_server.markdown)+1. [Atom (Value) Functions](docs/atomfunctions.markdown)+1. [Trans-Graph Relational Expressions](docs/transgraphrelationalexpr.markdown)+1. [Isomorphic Schemas](docs/isomorphic_schemas.markdown)+1. [Replication](docs/replication.markdown)++## Development++Project:M36 is developed in Haskell and compiled with GHC 7.10 or GHC 8.0.2 or later.++## Related Projects++* [The Third Manifesto](http://thethirdmanifesto.com/): the philosophical basis for relational algebra engines+* [Rel](http://reldb.org/): a TutorialD implementation against a BerkeleyDB backend+* [Andl](http://andl.org/): a new database language with SQLite and PostgreSQL backends+* [Coddie](https://github.com/scvalencia/Coddie): a python-based relational algebra interpreter++## Suggested Reading++* [Out of the Tarpit](http://shaffner.us/cs/papers/tarpit.pdf): a proposed software architecture which minimizes state and complexity. Project:M36 implements the requirements of this paper.+* [Database Design & Relational Theory: Normal Forms and All That Jazz](http://shop.oreilly.com/product/0636920025276.do): mathematical foundations for the principles of the relational algebra+* [Database Explorations: Essays on the Third Manifesto and Related Topics](http://bookstore.trafford.com/Products/SKU-000177853/Database-Explorations.aspx): additional essays and debates on practical approaches to relational algebra engine design
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/DirectoryFsync.c view
@@ -0,0 +1,48 @@+#include <sys/types.h>+#include <sys/stat.h>+#include <unistd.h>+#include <strings.h>+#include <errno.h>+#include <fcntl.h>++#ifndef _DIRECTORY_FSYNC_+#define _DIRECTORY_FSYNC_+/* open a directory for reading and fsync the resultant fd */+int cDirectoryFsync(char *path)+{+  int fd = 0;+  int ret = 0;+  struct stat fdstat = {0};++  fd = open(path, O_RDONLY);+  if(fd < 0)+    {+      return errno;+    }++  /* ensure that opened fd is a directory fd. Otherwise, fsync will fail (on a read-only file descriptor */+  ret = fstat(fd,&fdstat);+  if(ret < 0)+    {+      return errno;+    }++  if(!S_ISDIR(fdstat.st_mode))+    {+      return ENOTDIR;+    }+  +  /* execute the fsync */+    +#if defined(__APPLE__) && defined(__MACH__) && defined(F_FULLFSYNC)+  ret = fcntl(fd, F_FULLFSYNC);+#else+  ret = fsync(fd);+#endif+  if(ret < 0)+    {+      return errno;+    }+  return 0;+}+#endif
+ examples/SimpleClient.hs view
@@ -0,0 +1,38 @@+import ProjectM36.Client+import ProjectM36.TupleSet+import ProjectM36.Relation.Show.Term++main :: IO ()+main = do+  -- 1. create a ConnectionInfo+  let connInfo = RemoteProcessConnectionInfo "mytestdb" (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback+  -- 2. conncted to the remote database+  eConn <- connectProjectM36 connInfo+  case eConn of+    Left err -> putStrLn (show err)+    Right conn -> do+      --3. create a session on the "master" branch+      eSessionId <- createSessionAtHead "master" conn+      case eSessionId of+        Left err -> putStrLn (show err)+        Right sessionId -> do+          --4. define a new relation variable with a DatabaseContext expression+          let attrList = [Attribute "name" TextAtomType,+                          Attribute "age" IntAtomType]+              attrs = attributesFromList attrList+          mErr1 <- executeDatabaseContextExpr sessionId conn (Define "person" (map NakedAttributeExpr attrList))+          putStrLn (show mErr1)+          --5. add a tuple to the relation referenced by the relation variable+          let (Right tupSet) = mkTupleSetFromList attrs [[TextAtom "Bob", IntAtom 45]]+          mErr2 <- executeDatabaseContextExpr sessionId conn (Insert "person" (MakeStaticRelation attrs tupSet))+          putStrLn (show mErr2)+      +          --6. execute a relational algebra query+          let restrictionPredicate = AttributeEqualityPredicate "name" (NakedAtomExpr (TextAtom "Steve"))+          eRel <- executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "person" ()))+          case eRel of+            Left err -> putStrLn (show err)+            Right rel -> putStrLn (show $ showRelation rel)+      +          --7. close the connection+          close conn
+ examples/hair.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings #-}+import ProjectM36.Client+import ProjectM36.Relation.Show.Term+import GHC.Generics+import Data.Text+import Data.Binary+import Control.DeepSeq+import qualified Data.Map as M+import qualified Data.Text.IO as TIO++data Hair = Bald | Brown | Blond | OtherColor Text+   deriving (Generic, Show, Eq, Binary, NFData, Atomable)++main :: IO ()+main = do+ --connect to the database+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []+      eCheck v = do+        x <- v+        case x of +          Left err -> error (show err)+          Right x' -> pure x'+  conn <- eCheck $ connectProjectM36 connInfo++  --create a database session at the default branch of the fresh database+  sessionId <- eCheck $ createSessionAtHead "master" conn  +  +  let mCheck v = v >>= \x -> case x of +                                  Just err -> error (show err)+                                  Nothing -> pure ()+  --create the data type in the database context+  mCheck $ executeDatabaseContextExpr sessionId conn (toDatabaseContextExpr (undefined :: Hair))++  --create a relation with the new Hair AtomType+  let blond = NakedAtomExpr (toAtom Blond)+  mCheck $ executeDatabaseContextExpr sessionId conn (Assign "people" (MakeRelationFromExprs Nothing [+            TupleExpr (M.fromList [("hair", blond), ("name", NakedAtomExpr (TextAtom "Colin"))])]))++  let restrictionPredicate = AttributeEqualityPredicate "hair" blond+  peopleRel <- eCheck $ executeRelationalExpr sessionId conn (Restrict restrictionPredicate (RelationVariable "people" ()))++  TIO.putStrLn (showRelation peopleRel)+
+ examples/out_of_the_tarpit.hs view
@@ -0,0 +1,150 @@+-- the Out-of-the-Tarpit example in Haskell and Project:M36+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}+import ProjectM36.Client+import ProjectM36.DataTypes.Primitive+import qualified Data.Map as M+import Data.Maybe+import Control.Monad+import GHC.Generics+import Data.Binary+import Control.DeepSeq++--create various database value (atom) types+addressAtomType :: AtomType+addressAtomType = TextAtomType++nameAtomType :: AtomType+nameAtomType = TextAtomType++priceAtomType :: AtomType+priceAtomType = DoubleAtomType++fileNameAtomType :: AtomType+fileNameAtomType = TextAtomType++data Room = Kitchen | Bathroom | LivingRoom+          deriving (Generic, Atomable, Eq, Show, Binary, NFData)+                   +roomAtomType :: AtomType                   +roomAtomType = toAtomType (undefined :: Room)+                   +data PriceBand = Low | Medium | High | Premium+               deriving (Generic, Atomable, Eq, Show, Binary, NFData)+                        +priceBandAtomType :: AtomType+priceBandAtomType = toAtomType (undefined :: PriceBand)++data AreaCode = City | Suburban | Rural+              deriving (Generic, Atomable, Eq, Show, Binary, NFData)++areaCodeAtomType :: AtomType+areaCodeAtomType = ConstructedAtomType "AreaCode" M.empty++data SpeedBand = VeryFastBand | FastBand | MediumBand | SlowBand +               deriving (Generic, Atomable, Eq, Show, Binary, NFData)++speedBandAtomType :: AtomType+speedBandAtomType = ConstructedAtomType "SpeedBand" M.empty+  +main :: IO ()+main = do+  --connect to the database+  let connInfo = InProcessConnectionInfo NoPersistence emptyNotificationCallback []+      check x = case x of +        Left err -> error (show err)+        Right x' -> x'+  eConn <- connectProjectM36 connInfo+  let conn = check eConn+  +  --create a database session at the default branch of the fresh database+  eSessionId <- createSessionAtHead "master" conn  +  let sessionId = check eSessionId++  createSchema sessionId conn+  +createSchema :: SessionId -> Connection -> IO ()  +createSchema sessionId conn = do+  --create attributes for relvars+  let propertyAttrs = [Attribute "address" addressAtomType,+                       Attribute "price" priceAtomType,+                       Attribute "photo" fileNameAtomType,+                       Attribute "dateRegistered" DayAtomType]+      offerAttrs = [Attribute "address" addressAtomType,+                    Attribute "offerPrice" priceAtomType,+                    Attribute "offerDate" DayAtomType,+                    Attribute "bidderName" nameAtomType,+                    Attribute "bidderAddress" addressAtomType,+                    Attribute "decisionDate" DayAtomType,+                    Attribute "accepted" BoolAtomType]+      decisionAttrs = [Attribute "address" addressAtomType,             +                       Attribute "offerDate" DayAtomType,+                       Attribute "bidderName" nameAtomType,+                       Attribute "bidderAddress" addressAtomType,+                       Attribute "decisionDate" DayAtomType,+                       Attribute "accepted" BoolAtomType]+      roomAttrs = [Attribute "address" addressAtomType, +                   Attribute "roomName" TextAtomType,+                   Attribute "width" DoubleAtomType,+                   Attribute "breadth" DoubleAtomType,+                   Attribute "type" roomAtomType]+      floorAttrs = [Attribute "address" addressAtomType,+                    Attribute "roomName" TextAtomType,+                    Attribute "floor" IntAtomType]+      commissionAttrs = [Attribute "priceBand" priceBandAtomType,+                    Attribute "areaCode" areaCodeAtomType,+                    Attribute "saleSpeed" speedBandAtomType,+                    Attribute "commission" DoubleAtomType]+      --create uniqueness constraints                     +      incDepKeys = map (uncurry databaseContextExprForUniqueKey)+                [("property", ["address"]),+                 ("offer", ["address", "offerDate", "bidderName", "bidderAddress"]),+                 ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),+                 ("room", ["address", "roomName"]),+                 ("floor", ["address", "roomName"]),+                 --"commision" misspelled in OotT+                 ("commission", ["priceBand", "areaCode", "saleSpeed"])+                 ]+      --create foreign key constraints+      foreignKeys = [("offer_property_fk", +                      ("offer", ["address"]), +                      ("property", ["address"])),+                     ("decision_offer_fk",+                      ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),+                      ("offer", ["address", "offerDate", "bidderName", "bidderAddress"])),+                     ("room_property_fk",+                      ("room", ["address"]),+                      ("property", ["address"])),+                     ("floor_property_fk",+                      ("floor", ["address"]),+                      ("property", ["address"]))+                    ]+      incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys+      --define the relvars+      relvarMap = [("property", propertyAttrs),+                   ("offer", offerAttrs),+                   ("decision", decisionAttrs),+                   ("room", roomAttrs),+                   ("floor", floorAttrs),+                   ("commission", commissionAttrs)]+      rvDefs = map (\(name, attrs) -> Define name (map NakedAttributeExpr attrs)) relvarMap     +      --create the new algebraic data types+      new_adts = [toDatabaseContextExpr (undefined :: Room),+                  toDatabaseContextExpr (undefined :: PriceBand),+                  toDatabaseContextExpr (undefined :: AreaCode),+                  toDatabaseContextExpr (undefined :: SpeedBand)]+      --create the stored atom functions+      priceBandScript = "(\\(DoubleAtom price:_) -> do\n let band = if price < 10000.0 then \"Low\" else if price < 20000.0 then \"Medium\" else if price < 30000.0 then \"High\" else \"Premium\"\n let aType = ConstructedAtomType \"PriceBand\" empty\n pure (ConstructedAtom band aType [])) :: [Atom] -> Either AtomFunctionError Atom"+      areaCodeScript = "(\\(TextAtom address:_) -> let aType = ConstructedAtomType \"AreaCode\" empty in if address == \"90210\" then pure (ConstructedAtom \"City\" aType []) else pure (ConstructedAtom \"Rural\" aType [])) :: [Atom] -> Either AtomFunctionError Atom"+      speedBandScript = "(\\(DayAtom d1:DayAtom d2:_) -> do\n let aType = ConstructedAtomType \"SpeedBand\" empty\n     (_, month1, _) = toGregorian d1\n     (_, month2, _) = toGregorian d2\n if month1 == 11 && month2 == 11 then pure (ConstructedAtom \"VeryFast\" aType []) else pure (ConstructedAtom \"MediumBand\" aType [])) :: [Atom] -> Either AtomFunctionError Atom"+      atomFuncs = [createScriptedAtomFunction "priceBandForPrice" [doubleTypeConstructor] (ADTypeConstructor "PriceBand" []) priceBandScript,+                   createScriptedAtomFunction "areaCodeForAddress" [textTypeConstructor] (ADTypeConstructor "AreaCode" []) areaCodeScript,+                   createScriptedAtomFunction "datesToSpeedBand" [dayTypeConstructor, dayTypeConstructor] (ADTypeConstructor "SpeedBand" []) speedBandScript+                  ]+  --gather up and execute all database updates+  mErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)+  let errs = catMaybes mErrs+  when (length errs > 0) (error (show errs))    +  +  mErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs+  let errs' = catMaybes mErrs'+  when (length errs' > 0) (error (show errs'))
+ project-m36.cabal view
@@ -0,0 +1,482 @@+Name: project-m36+Version: 0.1+License: PublicDomain+Build-Type: Simple+Homepage: https://github.com/agentm/project-m36+Bug-Reports: https://github.com/agentm/project-m36/issues+Author: AgentM+Stability: experimental+Category: Relational Algebra+Maintainer: agentm@themactionfaction.com+Cabal-Version: >= 1.10+Synopsis: Relational Algebra Engine+Description: A relational algebra engine which can be used to persist and query Haskell data types.+Extra-Source-Files: Changelog.markdown README.markdown++Source-Repository head+    Type: git+    location: https://github.com/agentm/project-m36++Flag profiler+  Description: Enable Haskell-specific profiling support+  Default: False+  Manual: True  ++Library+    Build-Depends: base>=4.8 && < 5.0+                   ,ghc >= 7.8 && <= 8.1+                   ,ghc-paths+                   ,mtl+                   ,containers+                   ,unordered-containers+                   ,hashable+                   ,haskeline+                   ,directory+                   ,MonadRandom+                   ,random-shuffle+		   --critical uuid bug in lesser versions https://www.reddit.com/r/haskell/comments/4myot5/psa_make_sure_to_use_uuid_1312/+                   ,uuid >= 1.3.12+                   ,cassava ==0.4.*+                   ,text+                   ,bytestring+                   ,deepseq+                   ,deepseq-generics+                   ,vector+                   ,parallel+                   ,monad-parallel+                   ,transformers+                   ,gnuplot+                   ,binary+                   ,filepath+                   ,directory+                   ,vector-binary-instances+                   ,temporary+                   ,stm+                   ,time+                   ,hashable-time+                   ,old-locale+                   ,attoparsec+                   ,either+                   ,base64-bytestring+                   ,data-interval+                   ,extended-reals+                   ,network-transport+                   ,aeson+                   ,path-pieces+                   ,conduit+                   ,resourcet+                   ,http-api-data+--needed for remote access                   +                   ,distributed-process-client-server >= 0.2.3+                   ,distributed-process >= 0.6.6+                   ,distributed-process-extras >= 0.3.2+                   ,distributed-process-async >= 0.2.4+                   ,network-transport-tcp+                   ,network-transport+                   ,stm-containers+                   ,list-t+                   ,optparse-applicative+                   ,Glob+--used for hashing the transaction graph file to check for differences+                   ,cryptohash-sha256+    Exposed-Modules: ProjectM36.Error,+                     ProjectM36.Transaction,+                     ProjectM36.TransactionGraph,+                     ProjectM36.TransactionGraph.Show,+                     ProjectM36.TransactionGraph.Persist,+                     ProjectM36.TransactionGraph.Merge,+                     ProjectM36.TransGraphRelationalExpression,+                     ProjectM36.Base,+                     ProjectM36.Attribute,+                     ProjectM36.AttributeNames,+                     ProjectM36.Tuple,+                     ProjectM36.TupleSet,+                     ProjectM36.Atom,+                     ProjectM36.AtomFunction,+                     ProjectM36.AtomFunctionError,+                     ProjectM36.ScriptSession,+                     ProjectM36.DatabaseContextFunction,+                     ProjectM36.DatabaseContextFunctionError,+                     ProjectM36.Key,+                     ProjectM36.FunctionalDependency,+                     ProjectM36.DatabaseContext,+                     ProjectM36.DateExamples,+                     ProjectM36.DisconnectedTransaction,+                     ProjectM36.AtomFunctionBody,		  +                     ProjectM36.RelationalExpression,+                     ProjectM36.Relation.Show.HTML,+                     ProjectM36.StaticOptimizer,+                     ProjectM36.Relation.Show.Term,+                     ProjectM36.Relation.Show.CSV,+                     ProjectM36.Relation.Show.Gnuplot,+                     ProjectM36.Relation.Parse.CSV,+                     ProjectM36.IsomorphicSchema,+                     ProjectM36.InclusionDependency,+                     ProjectM36.Client,+                     ProjectM36.Persist,+                     ProjectM36.AtomType,+                     ProjectM36.AtomFunctions.Basic,+                     ProjectM36.AtomFunctions.Primitive,+                     ProjectM36.Atomable,+                     ProjectM36.DataConstructorDef,+                     ProjectM36.DataTypes.Basic,+                     ProjectM36.DataTypes.Day,+                     ProjectM36.DataTypes.DateTime,+                     ProjectM36.DataTypes.Either,+                     ProjectM36.DataTypes.Maybe,+                     ProjectM36.DataTypes.List,+                     ProjectM36.DataTypes.Primitive,+                     ProjectM36.MiscUtils,+                     ProjectM36.Notifications,+                     ProjectM36.Relation,+                     ProjectM36.Server,+                     ProjectM36.Server.Config,+                     ProjectM36.Server.EntryPoints,+                     ProjectM36.Server.ParseArgs,+                     ProjectM36.Server.RemoteCallTypes,+                     ProjectM36.Session,+                     ProjectM36.Sessions,+                     ProjectM36.Transaction.Persist,+                     ProjectM36.TypeConstructor,+                     ProjectM36.TypeConstructorDef,+                     ProjectM36.FileLock+    GHC-Options: -Wall+    if os(windows)+      Build-Depends: Win32 >= 2.3+      Other-Modules: ProjectM36.Win32Handle+    else+      C-sources: cbits/DirectoryFsync.c+      Build-Depends: unix+    CC-Options: -fPIC+    Hs-Source-Dirs: ./src/lib+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings, CPP+    if impl(ghc>= 8)+      build-depends:+        ghc-boot++Executable tutd+    Build-Depends: base >=4.8 && <5.0, +                   ghc >= 7.8 && <= 8.1,+                   ghc-paths,+                   project-m36 == 0.1,+                   containers,+                   unordered-containers,+                   hashable,+                   transformers,+                   semigroups,+                   mtl,+                   uuid,+                   deepseq-generics,+                   MonadRandom, MonadRandom,+                   vector,+                   text,+                   vector-binary-instances,+                   time,+                   hashable-time,+                   bytestring,+                   stm,+                   deepseq,+                   binary,+                   data-interval,+                   parallel,+                   cassava,+                   gnuplot,+                   directory,+                   filepath,+                   temporary,+                   megaparsec >= 5.2.0 && < 5.3,+                   haskeline,+                   random, MonadRandom,+                   base64-bytestring,+                   optparse-applicative,+                   attoparsec,+                   stm-containers,+                   list-t+    Other-Modules: TutorialD.Interpreter,+                   TutorialD.Interpreter.Base,+                   TutorialD.Interpreter.DatabaseContextExpr,+                   TutorialD.Interpreter.RODatabaseContextOperator,+                   TutorialD.Interpreter.TransactionGraphOperator,+                   TutorialD.Interpreter.DataTypes.Interval,+                   TutorialD.Interpreter.DataTypes.DateTime,+                   TutorialD.Interpreter.Import.BasicExamples,+                   TutorialD.Interpreter.InformationOperator,+                   TutorialD.Interpreter.Export.Base,+                   TutorialD.Interpreter.Export.CSV,+                   TutorialD.Interpreter.DatabaseContextIOOperator,+                   TutorialD.Interpreter.Import.Base,+                   TutorialD.Interpreter.Import.CSV,+                   TutorialD.Interpreter.Import.TutorialD,+                   TutorialD.Interpreter.RelationalExpr,+                   TutorialD.Interpreter.Types,+                   TutorialD.Interpreter.SchemaOperator,+                   TutorialD.Interpreter.TransGraphRelationalOperator,+                   TutorialD.Interpreter.SchemaOperator+    main-is: TutorialD/tutd.hs+    CPP-Options: -DPROJECTM36_VERSION="v0.1"+    CC-Options: -fPIC+    GHC-Options: -Wall +    Hs-Source-Dirs: ./src/bin+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+--    if os(windows)+--      Build-Depends: Win32 >= 2.3 && < 2.4+--      Other-Modules: ProjectM36.Win32Handle+--    else+--      C-sources: ProjectM36/DirectoryFsync.c+--      Build-Depends: unix+    ++Executable project-m36-server+    Build-Depends: base,+                   ghc >= 7.8 && <= 8.1,+                   ghc-paths,+                   project-m36 == 0.1,+                   binary,+                   transformers,+                   temporary,+                   data-interval,+                   deepseq,+                   uuid,+                   stm,+                   filepath,+                   directory,+                   parallel,+                   bytestring,+                   optparse-applicative,+                   hashable-time,+                   time,+                   vector-binary-instances,+                   text,+                   deepseq-generics,+                   mtl,+                   containers,+                   hashable,+                   unordered-containers,+                   vector,+                   http-api-data,+                   stm-containers,+                   list-t,+                   base64-bytestring+    Main-Is: ./src/bin/ProjectM36/Server/project-m36-server.hs+    CPP-Options: -DPROJECTM36_VERSION="v0.1"+    GHC-Options: -Wall -threaded -rtsopts+    if flag(profiler)+      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings++Executable bigrel+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, optparse-applicative, stm-containers, list-t, ghc, ghc-paths, transformers, project-m36 == 0.1, random, MonadRandom, semigroups+    Other-Modules: TutorialD.Interpreter.Base,+                   TutorialD.Interpreter.DatabaseContextExpr,+                   TutorialD.Interpreter.RelationalExpr,+                   TutorialD.Interpreter.Types+    main-is: benchmark/bigrel.hs+    GHC-Options: -Wall -threaded -rtsopts+    CPP-Options: -DPROJECTM36_VERSION="v0.1"+    HS-Source-Dirs: ./src/bin+    if flag(profiler)+      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall++Test-Suite test-tutoriald+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/TutorialD/Interpreter.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, list-t, project-m36 == 0.1, random, MonadRandom, semigroups+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator+    GHC-Options: -Wall+    Hs-Source-Dirs: ./src/bin, ., test+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Test-Suite test-tutoriald-atomfunctionscript+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator+    main-is: test/TutorialD/Interpreter/AtomFunctionScript.hs+    Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups+    GHC-Options: -Wall+    Hs-Source-Dirs: ./src/bin, ./test, .+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Test-Suite test-tutoriald-databasecontextfunctionscript+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.SchemaOperator+    main-is: test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+    Build-Depends: base, HUnit, project-m36 == 0.1, uuid, containers, megaparsec, text, vector, directory, bytestring, mtl, haskeline, random, MonadRandom, semigroups+    GHC-Options: -Wall+    Hs-Source-Dirs: ./src/bin, ./test, .+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Test-Suite test-relation+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/Relation/Basic.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring,  uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1, transformers+    GHC-Options: -Wall++Test-Suite test-static-optimizer+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/Relation/StaticOptimizer.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1, transformers+    GHC-Options: -Wall+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Test-Suite test-transactiongraph-persist+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/TransactionGraph/Persist.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1, random, MonadRandom, semigroups+    Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples+    Hs-Source-Dirs: ., ./src/bin+    GHC-Options: -Wall++Test-Suite test-relation-import-csv+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/Relation/Import/CSV.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1+    GHC-Options: -Wall+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Test-Suite test-tutoriald-import-tutoriald+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/TutorialD/Interpreter/Import/TutorialD.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1, random, MonadRandom, semigroups+    Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples+    GHC-Options: -Wall+    Hs-Source-Dirs: ., ./src/bin++Test-Suite test-relation-export-csv+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/Relation/Export/CSV.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, stm-containers, project-m36 == 0.1+    GHC-Options: -Wall ++Test-Suite test-transactiongraph-merge+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/TransactionGraph/Merge.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, template-haskell, transformers, aeson, conduit, either, path-pieces, http-api-data, stm-containers, list-t, project-m36 == 0.1+    GHC-Options: -Wall++benchmark bench+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: benchmark/Relation.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, criterion, stm-containers, project-m36 == 0.1+    GHC-Options: -Wall -rtsopts+    Hs-Source-Dirs: ./src/bin++Test-Suite test-server+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/Server/Main.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36 == 0.1, network-transport, semigroups+    HS-Source-Dirs: ., ./src/bin+    GHC-Options: -Wall+    +Executable Example-SimpleClient+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, ghc, ghc-paths, project-m36 == 0.1, random, MonadRandom+    Main-Is: examples/SimpleClient.hs+    GHC-Options: -Wall++Executable Example-OutOfTheTarpit+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36 == 0.1+    Main-Is: examples/out_of_the_tarpit.hs+    GHC-Options: -Wall+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Executable Example-Hair+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36 == 0.1+    Main-Is: examples/hair.hs+    GHC-Options: -Wall+    CPP-Options: -DPROJECTM36_VERSION="v0.1"+    +Test-Suite test-scripts+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    type: exitcode-stdio-1.0+    main-is: test/scripts.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, network-transport-tcp, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, project-m36 == 0.1, random, MonadRandom, semigroups+    Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.Import.BasicExamples+    GHC-Options: -Wall+    Hs-Source-Dirs: ., ./src/bin++Executable project-m36-websocket-server+    Default-Language: Haskell2010+    Build-Depends: base, aeson, path-pieces, either, conduit, http-api-data, template-haskell, websockets, aeson, uuid-aeson, optparse-applicative, project-m36 == 0.1, containers, bytestring, text, vector, uuid, megaparsec, haskeline, mtl, directory, base64-bytestring, random, MonadRandom, time, network-transport-tcp, semigroups+    Main-Is: ProjectM36/Server/WebSocket/websocket-server.hs+    Other-Modules:  ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator+    GHC-Options: -Wall   +    CPP-Options: -DPROJECTM36_VERSION="v0.1"+    Hs-Source-Dirs: ./src/bin+    Default-Extensions: OverloadedStrings++Test-Suite test-websocket-server+    Default-Language: Haskell2010+    type: exitcode-stdio-1.0+    main-is: test/Server/WebSocket.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom, network-transport-tcp, semigroups+    Other-Modules: TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.TransactionGraphOperator, ProjectM36.Client.Json, ProjectM36.Server.RemoteCallTypes.Json, ProjectM36.Server.WebSocket, TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.SchemaOperator+    Default-Extensions: OverloadedStrings+    GHC-Options: -Wall+    Hs-Source-Dirs: ./src/bin, .+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Test-Suite test-isomorphic-schemas+    Default-Language: Haskell2010+    type: exitcode-stdio-1.0+    main-is: test/IsomorphicSchema.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1+    Default-Extensions: OverloadedStrings+    GHC-Options: -Wall+    Hs-Source-Dirs: ./src/bin, .+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Test-Suite test-atomable+    Default-Language: Haskell2010+    type: exitcode-stdio-1.0+    main-is: test/Relation/Atomable.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom, semigroups+    Other-Modules: TutorialD.Interpreter, TutorialD.Interpreter.Base, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.DatabaseContextIOOperator, TutorialD.Interpreter.Export.Base, TutorialD.Interpreter.Export.CSV, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Interpreter.Import.CSV, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.InformationOperator, TutorialD.Interpreter.RODatabaseContextOperator, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.SchemaOperator, TutorialD.Interpreter.TestBase, TutorialD.Interpreter.TransGraphRelationalOperator, TutorialD.Interpreter.TransactionGraphOperator, TutorialD.Interpreter.Types+    Default-Extensions: OverloadedStrings+    GHC-Options: -Wall+    Hs-Source-Dirs: ./src/bin, ., test/+    CPP-Options: -DPROJECTM36_VERSION="v0.1"++Test-Suite test-multiprocess-access+    Default-Language: Haskell2010+    type: exitcode-stdio-1.0+    main-is: test/MultiProcessDatabaseAccess.hs+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, binary, parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, websockets, optparse-applicative, network, aeson, uuid-aeson, project-m36 == 0.1, random, MonadRandom+    Default-Extensions: OverloadedStrings+    GHC-Options: -Wall+    Hs-Source-Dirs: ./src/bin, ., test/+    CPP-Options: -DPROJECTM36_VERSION="v0.1"+
+ src/bin/ProjectM36/Client/Json.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Client.Json where+import Data.Aeson+import ProjectM36.Server.RemoteCallTypes.Json ()+import ProjectM36.Client+import Control.Exception (IOException)++instance ToJSON EvaluatedNotification+instance FromJSON EvaluatedNotification++instance ToJSON ConnectionError++instance ToJSON IOException where+  toJSON err = object ["IOException" .= show err]
+ src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs view
@@ -0,0 +1,140 @@+--create a bunch of orphan instances for use with the websocket server+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Server.RemoteCallTypes.Json where+import ProjectM36.Server.RemoteCallTypes+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.DataTypes.Primitive+import ProjectM36.IsomorphicSchema+import ProjectM36.DatabaseContextFunctionError+import ProjectM36.AtomFunctionError++import Control.Monad+import Data.Aeson+import Data.UUID.Aeson ()+import Data.ByteString.Base64 as B64+import Data.Text.Encoding+import Data.Time.Calendar++instance ToJSON RelationalExpr+instance FromJSON RelationalExpr++instance ToJSON TupleExpr+instance FromJSON TupleExpr++instance ToJSON RestrictionPredicateExpr+instance FromJSON RestrictionPredicateExpr++instance ToJSON AtomExpr+instance FromJSON AtomExpr++instance ToJSON RelationTupleSet+instance FromJSON RelationTupleSet++instance ToJSON RelationTuple+instance FromJSON RelationTuple++instance ToJSON ExecuteRelationalExpr+instance FromJSON ExecuteRelationalExpr++instance ToJSON Relation+instance FromJSON Relation++instance ToJSON Attribute+instance FromJSON Attribute++instance ToJSON ExtendTupleExpr+instance FromJSON ExtendTupleExpr++instance ToJSON AttributeNames+instance FromJSON AttributeNames++instance ToJSON AttributeExpr+instance FromJSON AttributeExpr++instance ToJSON AtomType+instance FromJSON AtomType++instance ToJSON TypeConstructor+instance FromJSON TypeConstructor++instance ToJSON SchemaExpr+instance FromJSON SchemaExpr++instance ToJSON SchemaIsomorph+instance FromJSON SchemaIsomorph++instance ToJSON Atom where                   +  toJSON atom@(IntAtom i) = object [ "type" .= atomTypeForAtom atom,+                                     "val" .= i ]+  toJSON atom@(DoubleAtom i) = object [ "type" .= atomTypeForAtom atom,+                                        "val" .= i ]+  toJSON atom@(TextAtom i) = object [ "type" .= atomTypeForAtom atom,+                                      "val" .= i ]+  toJSON atom@(DayAtom i) = do+    object [ "type" .= atomTypeForAtom atom,+             "val" .= toGregorian i ]+  toJSON atom@(DateTimeAtom i) = object [ "type" .= atomTypeForAtom atom,+                                          "val" .= i ]+  toJSON atom@(ByteStringAtom i) = object [ "type" .= atomTypeForAtom atom,+                                            "val" .= decodeUtf8 (B64.encode i) ]+  toJSON atom@(BoolAtom i) = object [ "type" .= atomTypeForAtom atom,+                                      "val" .= i ]+  toJSON atom@(RelationAtom i) = object [ "type" .= atomTypeForAtom atom,+                                          "val" .= i ]+  toJSON (ConstructedAtom dConsName atomtype atomlist) = object [+    "dataconstructorname" .= dConsName,+    "type" .= toJSON atomtype,+    "atomlist" .= toJSON atomlist+    ]+    +instance FromJSON Atom where+  parseJSON = withObject "atom" $ \o -> do+    atype <- o .: "type" +    case atype of+      TypeVariableType _ -> fail "cannot pass AnyAtomType over the wire"+      caType@(ConstructedAtomType _ _) -> ConstructedAtom <$> o .: "dataconstructorname" <*> pure caType <*> o .: "atom"+      RelationAtomType _ -> do+        rel <- o .: "val"+        pure $ RelationAtom rel      +      IntAtomType -> IntAtom <$> o .: "val"+      DoubleAtomType -> DoubleAtom <$> o .: "val"+      TextAtomType -> TextAtom <$> o .: "val"+      DayAtomType -> do+        (y, m, d) <- o .: "val"+        pure (DayAtom (fromGregorian y m d))+      DateTimeAtomType -> DateTimeAtom <$> o .: "val"+      ByteStringAtomType -> do+        b64bs <- liftM encodeUtf8 (o .: "val")+        case B64.decode b64bs of+          Left err -> fail ("Failed to parse base64-encoded ByteString: " ++ err)+          Right bs -> pure (ByteStringAtom bs)+      BoolAtomType -> BoolAtom <$> o .: "val"++instance ToJSON Notification+instance FromJSON Notification++instance ToJSON ScriptCompilationError+instance FromJSON ScriptCompilationError++instance ToJSON RelationalError+instance FromJSON RelationalError++instance ToJSON SchemaError+instance FromJSON SchemaError++instance ToJSON MergeError+instance FromJSON MergeError++instance ToJSON DatabaseContextFunctionError+instance FromJSON DatabaseContextFunctionError++instance ToJSON MergeStrategy+instance FromJSON MergeStrategy++instance ToJSON PersistenceError+instance FromJSON PersistenceError++instance ToJSON AtomFunctionError+instance FromJSON AtomFunctionError
+ src/bin/ProjectM36/Server/WebSocket.hs view
@@ -0,0 +1,95 @@+module ProjectM36.Server.WebSocket where+-- while the tutd client performs TutorialD parsing on the client, the websocket server will pass tutd to be parsed and executed on the server- otherwise I have to pull in ghcjs as a dependency to allow client-side parsing- that's not appealing because then the frontend is not language-agnostic, but this could change in the future, perhaps by sending different messages over the websocket+-- ideally, the wire protocol should not be exposed to a straight string-based API ala SQL, so we could make perhaps a javascript DSL which compiles to the necessary JSON- anaylyze tradeoffs++-- launch the project-m36-server+-- proxy all connections to it through ProjectM36.Client+import Control.Monad (forever)+import qualified Data.Text as T+import qualified Network.WebSockets as WS+import ProjectM36.Server.RemoteCallTypes.Json ()+import ProjectM36.Client.Json ()+import Data.Aeson+import TutorialD.Interpreter+import TutorialD.Interpreter.Base+import ProjectM36.Client+import Control.Exception+import Data.Maybe (fromMaybe)++websocketProxyServer :: Port -> Hostname -> WS.ServerApp+websocketProxyServer port host pending = do    +  conn <- WS.acceptRequest pending+  let unexpectedMsg = WS.sendTextData conn ("messagenotexpected" :: T.Text)+  --phase 1- accept database name for connection+  dbmsg <- (WS.receiveData conn) :: IO T.Text+  let connectdbmsg = "connectdb:"+  if not (connectdbmsg `T.isPrefixOf` dbmsg) then unexpectedMsg >> WS.sendClose conn ("" :: T.Text)+    else do+        let dbname = T.unpack $ T.drop (T.length connectdbmsg) dbmsg+        bracket (createConnection conn dbname port host) +          (\eDBconn -> case eDBconn of+                            Right dbconn -> close dbconn+                            Left _ -> pure ()) $ \eDBconn -> do+          case eDBconn of+            Left err -> sendError conn err+            Right dbconn -> do+                eSessionId <- createSessionAtHead "master" dbconn+                case eSessionId of+                  Left err -> sendError conn err+                  Right sessionId -> do+                    --phase 2- accept tutoriald commands+                    _ <- forever $ do+                      pInfo <- promptInfo sessionId dbconn+                      --figure out why sending three times during startup is necessary+                      sendPromptInfo pInfo conn                +                      sendPromptInfo pInfo conn+                      msg <- (WS.receiveData conn) :: IO T.Text+                      let tutdprefix = "executetutd:"+                      case msg of+                        _ | tutdprefix `T.isPrefixOf` msg -> do+                          let tutdString = T.drop (T.length tutdprefix) msg+                          case parseTutorialD tutdString of+                            Left err -> handleOpResult conn dbconn (DisplayErrorResult ("parse error: " `T.append` T.pack (show err)))+                            Right parsed -> do+                              let timeoutFilter = \exc -> if exc == RequestTimeoutException +                                                          then Just exc +                                                          else Nothing+                                  responseHandler = do+                                    result <- evalTutorialD sessionId dbconn SafeEvaluation parsed+                                    pInfo' <- promptInfo sessionId dbconn+                                    sendPromptInfo pInfo' conn                       +                                    handleOpResult conn dbconn result+                              catchJust timeoutFilter responseHandler (\_ -> handleOpResult conn dbconn (DisplayErrorResult "Request Timed Out."))+                        _ -> unexpectedMsg+                    pure ()+    +notificationCallback :: WS.Connection -> NotificationCallback    +notificationCallback conn notifName evaldNotif = WS.sendTextData conn (encode (object ["notificationname" .= notifName,+                                                                                       "evaldnotification" .= evaldNotif+                                        ]))+    +--this creates a new database for each connection- perhaps not what we want (?)+createConnection :: WS.Connection -> DatabaseName -> Port -> Hostname -> IO (Either ConnectionError Connection)+createConnection wsconn dbname port host = connectProjectM36 (RemoteProcessConnectionInfo dbname (createNodeId host port) (notificationCallback wsconn))++sendError :: (ToJSON a) => WS.Connection -> a -> IO ()+sendError conn err = WS.sendTextData conn (encode (object ["displayerror" .= err]))++handleOpResult :: WS.Connection -> Connection -> TutorialDOperatorResult -> IO ()+handleOpResult conn db QuitResult = WS.sendClose conn ("close" :: T.Text) >> close db+handleOpResult conn  _ (DisplayResult out) = WS.sendTextData conn (encode (object ["display" .= out]))+handleOpResult _ _ (DisplayIOResult ioout) = ioout+handleOpResult conn _ (DisplayErrorResult err) = WS.sendTextData conn (encode (object ["displayerror" .= err]))+handleOpResult conn _ (DisplayParseErrorResult _ err) = WS.sendTextData conn (encode (object ["displayparseerrorresult" .= show err]))+handleOpResult conn _ QuietSuccessResult = WS.sendTextData conn (encode (object ["acknowledged" .= True]))+handleOpResult conn _ (DisplayRelationResult rel) = WS.sendTextData conn (encode (object ["displayrelation" .= rel]))++-- get current schema and head name for client+promptInfo :: SessionId -> Connection -> IO (HeadName, SchemaName)+promptInfo sessionId conn = do+  mHeadName <- headName sessionId conn  +  mSchemaName <- currentSchemaName sessionId conn+  pure (fromMaybe "<unknown>" mHeadName, fromMaybe "<no schema>" mSchemaName)+  +sendPromptInfo :: (HeadName, SchemaName) -> WS.Connection -> IO ()+sendPromptInfo (hName, sName) conn = WS.sendTextData conn (encode (object ["promptInfo" .= object ["headname" .= hName, "schemaname" .= sName]]))
+ src/bin/ProjectM36/Server/WebSocket/websocket-server.hs view
@@ -0,0 +1,26 @@+import ProjectM36.Server.WebSocket+import ProjectM36.Server.Config+import ProjectM36.Server.ParseArgs+import ProjectM36.Server+import Control.Concurrent+import qualified Network.WebSockets as WS+import Network.Transport.TCP (decodeEndPointAddress)+import Control.Exception++main :: IO ()+main = do+  -- launch normal project-m36-server+  addressMVar <- newEmptyMVar+  serverConfig <- parseConfigWithDefaults (defaultServerConfig { bindPort = 8000, bindHost = "127.0.0.1" })+  --usurp the serverConfig for our websocket server and make the proxied server run locally+  let wsHost = bindHost serverConfig+      wsPort = bindPort serverConfig+      serverHost = "127.0.0.1"+      serverConfig' = serverConfig {bindPort = 0, bindHost = serverHost}+  _ <- forkFinally (launchServer serverConfig' (Just addressMVar) >> pure ()) (either throwIO pure)+  --wait for server to be listening+  address <- takeMVar addressMVar+  let Just (_, serverPort, _) = decodeEndPointAddress address+  --this built-in server is apparently not meant for production use, but it's easier to test than starting up the wai or snap interfaces+  WS.runServer wsHost (fromIntegral wsPort) (websocketProxyServer (read serverPort) serverHost)+
+ src/bin/ProjectM36/Server/project-m36-server.hs view
@@ -0,0 +1,9 @@+import ProjectM36.Server+import ProjectM36.Server.ParseArgs+import System.Exit (exitSuccess, exitFailure)++main :: IO ()+main = do+  serverConfig <- parseConfig+  ret <- launchServer serverConfig Nothing+  if ret then exitSuccess else exitFailure
+ src/bin/TutorialD/Interpreter.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE GADTs #-}+module TutorialD.Interpreter where+import TutorialD.Interpreter.Base+import TutorialD.Interpreter.RODatabaseContextOperator+import TutorialD.Interpreter.DatabaseContextExpr+import TutorialD.Interpreter.TransactionGraphOperator+import TutorialD.Interpreter.InformationOperator+import TutorialD.Interpreter.DatabaseContextIOOperator+import TutorialD.Interpreter.TransGraphRelationalOperator+import TutorialD.Interpreter.SchemaOperator++import TutorialD.Interpreter.Import.CSV+import TutorialD.Interpreter.Import.TutorialD+import TutorialD.Interpreter.Import.BasicExamples+import TutorialD.Interpreter.Import.Base++import TutorialD.Interpreter.Export.CSV+import TutorialD.Interpreter.Export.Base++import ProjectM36.Base+import ProjectM36.Relation.Show.Term+import ProjectM36.TransactionGraph+import qualified ProjectM36.Client as C+import ProjectM36.Relation (attributes)++import Text.Megaparsec+import Text.Megaparsec.Text+import Control.Monad.State+import System.Console.Haskeline+import System.Directory (getHomeDirectory)+import qualified Data.Text as T+import Data.Maybe (fromMaybe)+import System.IO (hPutStrLn, stderr)+import Data.Monoid+import Control.Exception++{-+context ops are read-only operations which only operate on the database context (relvars and constraints)+database ops are read-write operations which change the database context (such as relvar assignment)+graph ops are read-write operations which change the transaction graph+-}+data ParsedOperation = RODatabaseContextOp RODatabaseContextOperator |+                       DatabaseContextExprOp DatabaseContextExpr |+                       DatabaseContextIOExprOp DatabaseContextIOExpr |+                       InfoOp InformationOperator |+                       GraphOp TransactionGraphOperator |+                       ROGraphOp ROTransactionGraphOperator |+                       ImportRelVarOp RelVarDataImportOperator |+                       ImportDBContextOp DatabaseContextDataImportOperator |+                       ImportBasicExampleOp ImportBasicExampleOperator |+                       RelVarExportOp RelVarDataExportOperator |+                       TransGraphRelationalOp TransGraphRelationalOperator |+                       SchemaOp SchemaOperator+                       deriving (Show)++interpreterParserP :: Parser ParsedOperation+interpreterParserP = safeInterpreterParserP <|>+                     liftM ImportRelVarOp (importCSVP <* eof) <|>+                     liftM ImportDBContextOp (tutdImportP <* eof) <|>+                     liftM RelVarExportOp (exportCSVP <* eof) <|>+                     liftM DatabaseContextIOExprOp (dbContextIOExprP <* eof)+                     +-- the safe interpreter never reads or writes the file system+safeInterpreterParserP :: Parser ParsedOperation+safeInterpreterParserP = liftM RODatabaseContextOp (roDatabaseContextOperatorP <* eof) <|>+                         liftM InfoOp (infoOpP <* eof) <|>+                         liftM GraphOp (transactionGraphOpP <* eof) <|>+                         liftM ROGraphOp (roTransactionGraphOpP <* eof) <|>+                         liftM DatabaseContextExprOp (databaseExprOpP <* eof) <|>+                         liftM ImportBasicExampleOp (importBasicExampleOperatorP <* eof) <|>+                         liftM TransGraphRelationalOp (transGraphRelationalOpP <* eof) <|>+                         liftM SchemaOp (schemaOperatorP <* eof)++promptText :: Maybe HeadName -> Maybe SchemaName -> StringType+promptText mHeadName mSchemaName = "TutorialD (" <> transInfo <> "): "+  where+    transInfo = fromMaybe "<unknown>" mHeadName <> "/" <> fromMaybe "<no schema>" mSchemaName+          +parseTutorialD :: T.Text -> Either (ParseError Char Dec) ParsedOperation+parseTutorialD inputString = parse interpreterParserP "" inputString++--only parse tutoriald which doesn't result in file I/O+safeParseTutorialD :: T.Text -> Either (ParseError Char Dec) ParsedOperation+safeParseTutorialD inputString = parse safeInterpreterParserP "" inputString++data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)++--execute the operation and display result+evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO (TutorialDOperatorResult)+evalTutorialD sessionId conn safe expr = case expr of+  +  --this does not pass through the ProjectM36.Client library because the operations+  --are specific to the interpreter, though some operations may be of general use in the future+  (RODatabaseContextOp execOp) -> do+    evalRODatabaseContextOp sessionId conn execOp+    +  (DatabaseContextExprOp execOp) -> do +    maybeErr <- C.executeDatabaseContextExpr sessionId conn execOp +    case maybeErr of+      Just err -> barf err+      Nothing -> return QuietSuccessResult+      +  (DatabaseContextIOExprOp execOp) -> do+    if needsSafe then+      unsafeError+      else do+      mErr <- C.executeDatabaseContextIOExpr sessionId conn execOp+      case mErr of+        Just err -> barf err+        Nothing -> pure QuietSuccessResult+    +  (GraphOp execOp) -> do+    maybeErr <- C.executeGraphExpr sessionId conn execOp+    case maybeErr of+      Just err -> barf err+      Nothing -> return QuietSuccessResult++  (ROGraphOp execOp) -> do+    opResult <- evalROGraphOp sessionId conn execOp+    case opResult of +      Left err -> barf err+      Right rel -> pure (DisplayRelationResult rel)+      +  (SchemaOp execOp) -> do+    opResult <- evalSchemaOperator sessionId conn execOp+    case opResult of+      Just err -> barf err+      Nothing -> pure QuietSuccessResult+      +  (ImportRelVarOp execOp@(RelVarDataImportOperator relVarName _ _)) -> do+    if needsSafe then+      unsafeError+      else do+      -- collect attributes from relvar name+      -- is there a race condition here? The attributes of the relvar may have since changed, no?+      eImportType <- C.typeForRelationalExpr sessionId conn (RelationVariable relVarName ())+      case eImportType of+        Left err -> barf err+        Right importType -> do+          exprErr <- evalRelVarDataImportOperator execOp (attributes importType)+          case exprErr of+            Left err -> barf err+            Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)+  +  (ImportDBContextOp execOp) -> do+    if needsSafe then+      unsafeError+      else do+      mDbexprs <- evalDatabaseContextDataImportOperator execOp+      case mDbexprs of +        Left err -> barf err+        Right dbexprs -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexprs)+      +  (InfoOp execOp) -> do+    if needsSafe then+      unsafeError+      else+      case evalInformationOperator execOp of+        Left err -> barf err+        Right info -> pure (DisplayResult info)+      +  (RelVarExportOp execOp@(RelVarDataExportOperator relExpr _ _)) -> do+    --eval relexpr to relation and pass to export function+    if needsSafe then+      unsafeError+      else do+        eRel <- C.executeRelationalExpr sessionId conn relExpr+        case eRel of+          Left err -> barf err+          Right rel -> do+            exportResult <- evalRelVarDataExportOperator execOp rel+            case exportResult of+              Just err -> barf err+              Nothing -> pure QuietSuccessResult+  (ImportBasicExampleOp execOp) -> do+    let dbcontextexpr = evalImportBasicExampleOperator execOp+    evalTutorialD sessionId conn safe (DatabaseContextExprOp dbcontextexpr)+  (TransGraphRelationalOp execOp) -> do+    evalTransGraphRelationalOp sessionId conn execOp+  where+    needsSafe = safe == SafeEvaluation+    unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."+    barf err = return $ DisplayErrorResult (T.pack (show err))+  +type GhcPkgPath = String  +data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |+                         RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName++outputNotificationCallback :: C.NotificationCallback+outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ show (reportExpr (C.notification evaldNot)) ++ "\n" ++ prettyEvaluatedNotification evaldNot++prettyEvaluatedNotification :: C.EvaluatedNotification -> String+prettyEvaluatedNotification eNotif = case C.reportRelation eNotif of+  Left err -> show err+  Right reportRel -> T.unpack (showRelation reportRel)++reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO ()+reprLoop config sessionId conn = do+  homeDirectory <- getHomeDirectory+  let settings = defaultSettings {historyFile = Just (homeDirectory ++ "/.tutd_history")}+  mHeadName <- C.headName sessionId conn+  mSchemaName <- C.currentSchemaName sessionId conn+  let prompt = promptText mHeadName mSchemaName+  maybeLine <- runInputT settings $ getInputLine (T.unpack prompt)+  case maybeLine of+    Nothing -> return ()+    Just line -> do+      case parseTutorialD (T.pack line) of+        Left err -> do+          displayOpResult $ DisplayParseErrorResult (T.length prompt) err+        Right parsed -> do +          catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do+            evald <- evalTutorialD sessionId conn UnsafeEvaluation parsed+            displayOpResult evald)+            (\_ -> displayOpResult (DisplayErrorResult "Request timed out."))+      reprLoop config sessionId conn
+ src/bin/TutorialD/Interpreter/Base.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DeriveGeneric, CPP #-}+module TutorialD.Interpreter.Base where+import Text.Megaparsec+import Text.Megaparsec.Text+import qualified Text.Megaparsec.Lexer as Lex+import ProjectM36.Base+import ProjectM36.AtomType+import Data.Text hiding (count)+import System.Random+import qualified Data.Text as T+import qualified Data.List as L+import qualified Data.Vector as V+import qualified Data.Text.IO as TIO+import System.IO+import ProjectM36.Relation.Show.Term+import GHC.Generics+import Data.Monoid+import Control.Monad (void)+import qualified Data.UUID as U+import ProjectM36.Relation+import Control.Monad.Random+import Data.List.NonEmpty as NE++displayOpResult :: TutorialDOperatorResult -> IO ()+displayOpResult QuitResult = return ()+displayOpResult (DisplayResult out) = TIO.putStrLn out+displayOpResult (DisplayIOResult ioout) = ioout+displayOpResult (DisplayErrorResult err) = let outputf = if T.length err > 0 && T.last err /= '\n' then TIO.hPutStrLn else TIO.hPutStr in +  outputf stderr ("ERR: " <> err)+displayOpResult QuietSuccessResult = return ()+displayOpResult (DisplayRelationResult rel) = do+  gen <- newStdGen+  let randomlySortedRel = evalRand (randomizeTupleOrder rel) gen+  TIO.putStrLn (showRelation randomlySortedRel)+displayOpResult (DisplayParseErrorResult promptLength err) = TIO.putStrLn pointyString >> TIO.putStr ("ERR:" <> errString)+  where+    errString = T.pack (parseErrorPretty err)+    errorIndent = unPos (sourceColumn (NE.head (errorPos err)))+    pointyString = T.justifyRight (promptLength + fromIntegral errorIndent) '_' "^"++spaceConsumer :: Parser ()+spaceConsumer = Lex.space (void spaceChar) (Lex.skipLineComment "--") (Lex.skipBlockComment "{-" "-}")+  +opChar :: Parser Char+opChar = oneOf (":!#$%&*+./<=>?\\^|-~" :: String)-- remove "@" so it can be used as attribute marker without spaces++reserved :: String -> Parser ()+reserved word = try (string word *> notFollowedBy opChar *> spaceConsumer)++reservedOp :: String -> Parser ()+reservedOp op = try (string op *> notFollowedBy opChar *> spaceConsumer)++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++braces :: Parser a -> Parser a+braces = between (symbol "{") (symbol "}")++identifier :: Parser Text+identifier = do+  istart <- letterChar <|> char '_'+  irest <- many (alphaNumChar <|> char '_' <|> char '#')+  spaceConsumer+  pure (pack (istart:irest))++symbol :: String -> Parser Text+symbol sym = pack <$> Lex.symbol spaceConsumer sym ++comma :: Parser Text+comma = symbol ","++pipe :: Parser Text+pipe = symbol "|"++quote :: Parser Text+quote = symbol "\""++tripleQuote :: Parser Text+tripleQuote = symbol "\"\"\""++arrow :: Parser Text+arrow = symbol "->"++semi :: Parser Text+semi = symbol ";"++{-+whiteSpace :: Parser ()+whiteSpace = Token.whiteSpace lexer+-}++integer :: Parser Integer+integer = Lex.integer++float :: Parser Double+float = Lex.float++capitalizedIdentifier :: Parser Text+capitalizedIdentifier = do+  fletter <- upperChar+  rest <- option "" identifier +  spaceConsumer+  pure (T.cons fletter rest)+  +uncapitalizedIdentifier :: Parser Text+uncapitalizedIdentifier = do+  fletter <- lowerChar+  rest <- option "" identifier+  spaceConsumer+  pure (T.cons fletter rest)++showRelationAttributes :: Attributes -> Text+showRelationAttributes attrs = "{" <> T.concat (L.intersperse ", " $ L.map showAttribute attrsL) <> "}"+  where+    showAttribute (Attribute name atomType) = name <> " " <> prettyAtomType atomType+    attrsL = V.toList attrs++data TutorialDOperatorResult = QuitResult |+                               DisplayResult StringType |+                               DisplayIOResult (IO ()) |+                               DisplayRelationResult Relation |+                               DisplayErrorResult StringType |+                               DisplayParseErrorResult Int (ParseError Char Dec) | -- Int refers to length of prompt text+                               QuietSuccessResult+                               deriving (Generic)+                               +type TransactionGraphWasUpdated = Bool++--allow for python-style triple quoting because guessing the correct amount of escapes in different contexts is annoying+tripleQuotedString :: Parser Text+tripleQuotedString = do+  _ <- tripleQuote+  pack <$> manyTill anyChar (try (tripleQuote >> notFollowedBy quote))+  +normalQuotedString :: Parser Text+normalQuotedString = quote *> (T.pack <$> manyTill Lex.charLiteral quote)++quotedString :: Parser Text+quotedString = try tripleQuotedString <|> normalQuotedString++uuidP :: Parser U.UUID+uuidP = do+  uuidStart <- count 8 hexDigitChar +  _ <- char '-' -- min 28 with no dashes, maximum 4 dashes+  uuidMid1 <- count 4 hexDigitChar+  _ <- char '-'+  uuidMid2 <- count 4 hexDigitChar+  _ <- char '-'+  uuidMid3 <- count 4 hexDigitChar+  _ <- char '-'+  uuidEnd <- count 12 hexDigitChar+  let uuidStr = L.intercalate "-" [uuidStart, uuidMid1, uuidMid2, uuidMid3, uuidEnd]+  case U.fromString uuidStr of+    Nothing -> fail "Invalid uuid string"+    Just uuid -> return uuid
+ src/bin/TutorialD/Interpreter/DataTypes/DateTime.hs view
@@ -0,0 +1,22 @@+module TutorialD.Interpreter.DataTypes.DateTime where+import Text.Parsec+import ProjectM36.Base+import Text.Parsec.String+import TutorialD.Interpreter.Base+import Data.Time.Clock+import Data.Time.Format++dateTimeAtomP :: Parser Atom+dateTimeAtomP = do+  dateTime' <- try $ do+    dateTime <- dateTimeStringP+    reserved "::datetime"+    return dateTime +  return $ Atom dateTime'++dateTimeStringP :: Parser UTCTime+dateTimeStringP = do+  dateTimeString <- quotedString+  case parseTimeM False defaultTimeLocale "%Y-%m-%d %H:%M:%S" dateTimeString of+    Just utctime -> return $ (utctime :: UTCTime)+    Nothing -> fail $ "Failed to parse datetime from " ++ dateTimeString
+ src/bin/TutorialD/Interpreter/DataTypes/Interval.hs view
@@ -0,0 +1,35 @@+module TutorialD.Interpreter.DataTypes.Interval where+import Text.Parsec+import Text.Parsec.String+import ProjectM36.Base hiding (Finite)+import ProjectM36.DataTypes.Interval ()+import TutorialD.Interpreter.Base+import TutorialD.Interpreter.DataTypes.DateTime+import Data.Interval+import Data.Time.Clock++intervalP :: (Ord a) => Parser (Extended a) -> Parser (Interval a)+intervalP unitP = do+  lBoundClosed <- string "(" *> return False <|> +                  string "[" *> return True+  lBound <- unitP+  reservedOp ","+  uBound <- unitP+  +  uBoundClosed <- string ")" *> return False <|>+                  string "]" *> return True+                  +  return $ interval (lBound, lBoundClosed) (uBound, uBoundClosed)+  +intervalDateTimeUnitP :: Parser (Extended UTCTime)+intervalDateTimeUnitP = Finite <$> dateTimeStringP <|>+  (reserved "inf" *> return PosInf) <|> +  (reserved "-inf" *> return NegInf)+  +intervalDateTimeAtomP :: Parser Atom+intervalDateTimeAtomP = do+  reserved "interval_datetime("+  intv <- intervalP intervalDateTimeUnitP+  reserved ")"+  return $ Atom intv+
+ src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs view
@@ -0,0 +1,219 @@+module TutorialD.Interpreter.DatabaseContextExpr where+import Text.Megaparsec+import Text.Megaparsec.Text+import ProjectM36.Base+import TutorialD.Interpreter.Base+import qualified Data.Text as T+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+import qualified ProjectM36.RelationalExpression as RE+import ProjectM36.Key+import ProjectM36.FunctionalDependency+import Data.Monoid++--parsers which create "database expressions" which modify the database context (such as relvar assignment)+databaseContextExprP :: Parser DatabaseContextExpr+databaseContextExprP = choice [insertP,+                               deleteConstraintP,+                               deleteP,+                               updateP,+                               addConstraintP,+                               keyP,+                               funcDepP,+                               defineP,+                               undefineP,+                               assignP,+                               addNotificationP,+                               removeNotificationP,+                               addTypeConstructorP,+                               removeTypeConstructorP,+                               removeAtomFunctionP,+                               executeDatabaseContextFunctionP,+                               removeDatabaseContextFunctionP,+                               nothingP]+            +nothingP :: Parser DatabaseContextExpr            +nothingP = spaceConsumer >> pure NoOperation++assignP :: Parser DatabaseContextExpr+assignP = do+  relVarName <- try $ do+    relVarName <- identifier+    reservedOp ":="+    return relVarName+  expr <- relExprP+  pure $ Assign relVarName expr+  +multilineSep :: Parser T.Text  +multilineSep = newline >> pure "\n"++multipleDatabaseContextExprP :: Parser DatabaseContextExpr+multipleDatabaseContextExprP = do+  exprs <- sepBy1 databaseContextExprP semi+  pure $ MultipleExpr exprs++insertP :: Parser DatabaseContextExpr+insertP = do+  reservedOp "insert"+  relvar <- identifier+  expr <- relExprP+  pure $ Insert relvar expr++defineP :: Parser DatabaseContextExpr+defineP = do+  relVarName <- try $ do+    relVarName <- identifier+    reservedOp "::"+    return relVarName+  attributeSet <- makeAttributeExprsP+  pure $ Define relVarName attributeSet++undefineP :: Parser DatabaseContextExpr+undefineP = do+  reservedOp "undefine"+  relVarName <- identifier+  return $ Undefine relVarName++deleteP :: Parser DatabaseContextExpr+deleteP = do+  reservedOp "delete"+  relVarName <- identifier+  predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP)+  return $ Delete relVarName predicate++updateP :: Parser DatabaseContextExpr+updateP = do+  reservedOp "update"+  relVarName <- identifier+  predicate <- option TruePredicate (reservedOp "where" *> restrictionPredicateP <* spaceConsumer)+  attributeAssignments <- liftM M.fromList $ parens (sepBy attributeAssignmentP comma)+  return $ Update relVarName attributeAssignments predicate++data IncDepOp = SubsetOp | EqualityOp++addConstraintP :: Parser DatabaseContextExpr+addConstraintP = do+  reservedOp "constraint" <|> reservedOp "foreign key"+  constraintName <- identifier+  subset <- relExprP+  op <- (reservedOp "in" *> pure SubsetOp) <|> (reservedOp "equals" *> pure EqualityOp)+  superset <- relExprP+  let subsetA = incDepSet constraintName subset superset+      subsetB = incDepSet (constraintName <> "_eqInvert") superset subset --inverted args for equality constraint+      incDepSet nam a b = AddInclusionDependency nam (InclusionDependency a b)+  case op of+    SubsetOp -> pure subsetA+    EqualityOp -> pure (MultipleExpr [subsetA, subsetB])+  +deleteConstraintP :: Parser DatabaseContextExpr  +deleteConstraintP = do+  reserved "deleteconstraint"+  constraintName <- identifier+  pure $ RemoveInclusionDependency constraintName+  +-- key <constraint name> {<uniqueness attributes>} <uniqueness relexpr>+keyP :: Parser DatabaseContextExpr  +keyP = do+  reserved "key"+  keyName <- identifier+  uniquenessAttrNames <- braces attributeListP+  uniquenessExpr <- relExprP+  let newIncDep = inclusionDependencyForKey uniquenessAttrNames uniquenessExpr+  pure $ AddInclusionDependency keyName newIncDep+  +funcDepP :: Parser DatabaseContextExpr  +funcDepP = do+  reserved "funcdep"+  keyName <- identifier+  source <- parens attributeListP+  reserved "->"+  dependents <- parens attributeListP+  expr <- relExprP+  let newIncDeps = inclusionDependenciesForFunctionalDependency funcDep+      funcDep = FunctionalDependency source dependents expr+      nameA = keyName <> "_A"+      nameB = keyName <> "_B"+  pure (MultipleExpr [AddInclusionDependency nameA (fst newIncDeps),+                      AddInclusionDependency nameB (snd newIncDeps)])+  +attributeAssignmentP :: Parser (AttributeName, AtomExpr)+attributeAssignmentP = do+  attrName <- identifier+  reservedOp ":="+  atomExpr <- atomExprP+  pure $ (attrName, atomExpr)+  +addNotificationP :: Parser DatabaseContextExpr+addNotificationP = do+  reserved "notify"+  notName <- identifier+  triggerExpr <- relExprP +  resultExpr <- relExprP+  pure $ AddNotification notName triggerExpr resultExpr+  +removeNotificationP :: Parser DatabaseContextExpr  +removeNotificationP = do+  reserved "unnotify"+  notName <- identifier+  pure $ RemoveNotification notName++-- | data Hair = Bald | Color Text+addTypeConstructorP :: Parser DatabaseContextExpr+addTypeConstructorP = do+  reserved "data"+  typeConstructorDef <- typeConstructorDefP+  reservedOp "="+  dataConstructorDefs <- sepBy1 dataConstructorDefP pipe+  pure (AddTypeConstructor typeConstructorDef dataConstructorDefs)++removeTypeConstructorP :: Parser DatabaseContextExpr+removeTypeConstructorP = do+  reserved "undata"+  RemoveTypeConstructor <$> identifier +  +removeAtomFunctionP :: Parser DatabaseContextExpr  +removeAtomFunctionP = do+  reserved "removeatomfunction"+  RemoveAtomFunction <$> quotedString+  +removeDatabaseContextFunctionP :: Parser DatabaseContextExpr+removeDatabaseContextFunctionP = do+  reserved "removedatabasecontextfunction"+  RemoveDatabaseContextFunction <$> quotedString++executeDatabaseContextFunctionP :: Parser DatabaseContextExpr+executeDatabaseContextFunctionP = do+  reserved "execute"+  funcName <- identifier+  args <- parens (sepBy atomExprP comma)+  pure (ExecuteDatabaseContextFunction funcName args)+  +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+        (Nothing, (context',_, _)) -> Right context'+        (Just 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++{-+--no optimization+interpretNO :: DatabaseContext -> String -> (Maybe RelationalError, DatabaseContext)+interpretNO context tutdstring = case parseString tutdstring of+                                    Left err -> (Just err, context)+                                    Right parsed -> runState (evalContextExpr parsed) context+-}+
+ src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs view
@@ -0,0 +1,32 @@+--compiling the script requires the IO monad because it must load modules from the filesystem, so we create the function and generate the requisite DatabaseExpr here.+module TutorialD.Interpreter.DatabaseContextIOOperator where+import ProjectM36.Base++import TutorialD.Interpreter.Base+import TutorialD.Interpreter.Types+import Text.Megaparsec+import Text.Megaparsec.Text++addAtomFunctionExprP :: Parser DatabaseContextIOExpr+addAtomFunctionExprP = do+  reserved "addatomfunction"+  funcName <- quotedString+  funcType <- atomTypeSignatureP+  funcScript <- quotedString+  pure $ AddAtomFunction funcName funcType funcScript++atomTypeSignatureP :: Parser [TypeConstructor]+atomTypeSignatureP = sepBy typeConstructorP arrow++addDatabaseContextFunctionExprP :: Parser DatabaseContextIOExpr+addDatabaseContextFunctionExprP = do+  reserved "adddatabasecontextfunction"+  funcName <- quotedString+  funcType <- atomTypeSignatureP+  funcScript <- quotedString+  pure $ AddDatabaseContextFunction funcName funcType funcScript+  +dbContextIOExprP :: Parser DatabaseContextIOExpr+dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP+  +
+ src/bin/TutorialD/Interpreter/Export/Base.hs view
@@ -0,0 +1,13 @@+module TutorialD.Interpreter.Export.Base where+import ProjectM36.Base+import ProjectM36.Error+import Data.Monoid++data RelVarDataExportOperator = RelVarDataExportOperator RelationalExpr FilePath (RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError))++instance Show RelVarDataExportOperator where+  show (RelVarDataExportOperator expr path _) = "RelVarDataExportOperator " <> show expr <> " " <>  path++evalRelVarDataExportOperator :: RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError)+evalRelVarDataExportOperator op@(RelVarDataExportOperator _ _ exportFunc) rel = exportFunc op rel+
+ src/bin/TutorialD/Interpreter/Export/CSV.hs view
@@ -0,0 +1,28 @@+module TutorialD.Interpreter.Export.CSV where+import ProjectM36.Relation.Show.CSV+import TutorialD.Interpreter.Export.Base+import TutorialD.Interpreter.RelationalExpr+import TutorialD.Interpreter.Base+import ProjectM36.Base+import ProjectM36.Error+import Text.Megaparsec.Text+import qualified Data.ByteString.Lazy as BS+import Control.Exception (try)+import qualified Data.Text as T++exportCSVP :: Parser RelVarDataExportOperator+exportCSVP = do+  reserved ":exportcsv"+  exportExpr <- relExprP+  path <- quotedString+  return $ RelVarDataExportOperator exportExpr (T.unpack path) exportRelationCSV +                               +exportRelationCSV :: RelVarDataExportOperator -> Relation -> IO (Maybe RelationalError)+exportRelationCSV (RelVarDataExportOperator _  pathOut _) rel = do+  case relationAsCSV rel of+    Left err -> return $ Just err+    Right csvData -> do+      writeResult <- try (BS.writeFile pathOut csvData) :: IO (Either IOError ())+      case writeResult of+        Left err -> return $ Just (ExportError $ T.pack (show err))+        Right _ -> return Nothing
+ src/bin/TutorialD/Interpreter/Import/Base.hs view
@@ -0,0 +1,24 @@+module TutorialD.Interpreter.Import.Base where+import ProjectM36.Base+import ProjectM36.Error+import Data.Monoid++-- | import data into a relation variable+data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (RelVarName -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr))++instance Show RelVarDataImportOperator where+  show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path++-- | import data into a database context+data DatabaseContextDataImportOperator = DatabaseContextDataImportOperator FilePath (FilePath -> IO (Either RelationalError DatabaseContextExpr))++instance Show DatabaseContextDataImportOperator where+  show (DatabaseContextDataImportOperator path _) = "DatabaseContextDataImportOperator " <> path++-- perhaps create a structure to import a whole transaction graph section in the future++evalRelVarDataImportOperator :: RelVarDataImportOperator -> Attributes -> IO (Either RelationalError DatabaseContextExpr)+evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) attrs = importFunc relVarName attrs path +        +evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr)        +evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator path importFunc) = importFunc path
+ src/bin/TutorialD/Interpreter/Import/BasicExamples.hs view
@@ -0,0 +1,23 @@+--includes some hardcoded examples which can be imported even during safe evaluation (no file I/O)+module TutorialD.Interpreter.Import.BasicExamples where+import ProjectM36.DateExamples+import ProjectM36.Base+import ProjectM36.DatabaseContext+import TutorialD.Interpreter.Base+import Text.Megaparsec.Text++data ImportBasicExampleOperator = ImportBasicDateExampleOperator+                                deriving (Show)++evalImportBasicExampleOperator :: ImportBasicExampleOperator -> DatabaseContextExpr+evalImportBasicExampleOperator ImportBasicDateExampleOperator = databaseContextAsDatabaseContextExpr dateExamples++importBasicExampleOperatorP :: Parser ImportBasicExampleOperator+importBasicExampleOperatorP = do +  reservedOp ":importexample"+  example <- identifier+  if example == "date" then+    pure ImportBasicDateExampleOperator+    else+    fail "Unknown example name"+
+ src/bin/TutorialD/Interpreter/Import/CSV.hs view
@@ -0,0 +1,29 @@+module TutorialD.Interpreter.Import.CSV where+import TutorialD.Interpreter.Import.Base+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.Relation.Parse.CSV+import qualified Data.ByteString.Lazy as BS+import qualified Data.Text as T+import Text.Megaparsec.Text+import TutorialD.Interpreter.Base+import Control.Exception++importCSVRelation :: RelVarName -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr)+importCSVRelation relVarName attrs pathIn = do+  --TODO: handle filesystem errors+  csvData <- try (BS.readFile pathIn) :: IO (Either IOError BS.ByteString)+  case csvData of +    Left err -> return $ Left (ImportError $ T.pack (show err))+    Right csvData' -> case csvAsRelation csvData' attrs of+      Left err -> return $ Left (ParseError $ T.pack (show err))+      Right csvRel -> return $ Right (Insert relVarName (ExistingRelation csvRel))++importCSVP :: Parser RelVarDataImportOperator+importCSVP = do+  reserved ":importcsv"+  path <- quotedString+  spaceConsumer+  relVarName <- identifier+  return $ RelVarDataImportOperator relVarName (T.unpack path) importCSVRelation+
+ src/bin/TutorialD/Interpreter/Import/TutorialD.hs view
@@ -0,0 +1,31 @@+module TutorialD.Interpreter.Import.TutorialD where+import ProjectM36.Base+import TutorialD.Interpreter.Import.Base+import TutorialD.Interpreter.Base+import TutorialD.Interpreter.DatabaseContextExpr+import Text.Megaparsec.Text+import Text.Megaparsec hiding (try)+import ProjectM36.Error+import qualified ProjectM36.Error as PM36E+import qualified Data.Text as T+import Control.Exception+import qualified Data.Text.IO as TIO+--import a file containing TutorialD database context expressions++importTutorialD :: FilePath -> IO (Either RelationalError DatabaseContextExpr)+importTutorialD pathIn = do+  tutdData <- try (TIO.readFile pathIn) :: IO (Either IOError T.Text)+  case tutdData of +    Left err -> return $ Left (ImportError $ T.pack (show err))+    Right tutdData' -> do +      case parse multipleDatabaseContextExprP "import" tutdData' of+        --parseErrorPretty is new in megaparsec 5+        Left err -> pure (Left (PM36E.ParseError (T.pack (show err))))+        Right expr -> pure (Right expr)++tutdImportP :: Parser DatabaseContextDataImportOperator+tutdImportP = do+  reserved ":importtutd" +  path <- quotedString+  spaceConsumer+  return $ DatabaseContextDataImportOperator (T.unpack path) importTutorialD
+ src/bin/TutorialD/Interpreter/InformationOperator.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+module TutorialD.Interpreter.InformationOperator where+import Data.Text+import Text.Megaparsec+import Text.Megaparsec.Text+import TutorialD.Interpreter.Base++-- this module provides information about the current interpreter++data InformationOperator = HelpOperator |+                           GetVersionOperator +                           deriving (Show)+                           +infoOpP :: Parser InformationOperator                           +infoOpP = helpOpP <|> getVersionP+  +helpOpP :: Parser InformationOperator          +helpOpP = reserved ":help" >> pure HelpOperator++getVersionP :: Parser InformationOperator+getVersionP = reserved ":version" >> pure GetVersionOperator++evalInformationOperator :: InformationOperator -> Either Text Text+evalInformationOperator GetVersionOperator = Right ("tutd " `append` PROJECTM36_VERSION)+-- display generic help+evalInformationOperator HelpOperator = Right $ intercalate "\n" help+  where+    help = ["tutd Help", +            "Quick Examples:",+            ":showexpr true",+            ":showexpr relation{name Text, address Text}{tuple{name \"Steve\", address \"Main St.\"}}",+            "address := relation{tuple{name \"Steve\", address \"Main St.\"}}",+            ":showexpr true join false = false",+            "Relational Operators:",+            ":showexpr relation{a Int, b Text}{} -- relation creation",+            ":showexpr relation{tuple{c t}} -- relation creation",+            ":showexpr relation{tuple{a 4, b 4}}{a} -- projection",+            ":showexpr relation{tuple{a 5}} rename {a as num} -- rename",+            ":showexpr relation{tuple{d 10}} where d=10 or d=5 -- restriction",+            ":showexpr relation{tuple{d 10}} : {e:=add(@d,5)} -- extension",+            "Database Context Operators:",+            "animal := relation{tuple{name \"octopus\", legs_count 8}} -- assignment",+            "insert animal relation{tuple{name \"cat\", legs_count 4}} -- insertion",+            "car :: {model Text, make Text, year Int} -- definition",+            "undefine car -- undefine",+            "delete animal where legs_count=4 -- deletion",+            "update animal where name=\"octopus\" (name:=\"Mr. Octopus\") -- updating",+            "employee:=relation{id Int, name Text, age Int}{}; key emp_unique_id {id} employee --uniqueness constraint",+            "constraint age_gt_zero (employee{age} where ^lt(@age,0)){} equals false -- constraint",+            "notify teenager_added employee where ^lt(@age,20) and ^gte(@age,13) employee{age} where ^lt(@age,20) and ^gte(@age,13) -- change notification",+            "Graph Operators: ",+            ":jumphead <head_name> - change the current database context to point to a current head",+            ":jump <transaction_id> - change the current database context to that of a past transaction",+            ":commit - push the current context into the current head and make it immutable",+            ":rollback - discard any changes made in the current context",+            ":showgraph - display the transaction graph",+            "View more documentation at: https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown"+            ]
+ src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE GADTs #-}+module TutorialD.Interpreter.RODatabaseContextOperator where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.InclusionDependency+import qualified ProjectM36.Client as C+import Text.Megaparsec+import Text.Megaparsec.Text+import TutorialD.Interpreter.Base+import TutorialD.Interpreter.RelationalExpr+import TutorialD.Interpreter.DatabaseContextExpr+import Control.Monad.State+import qualified Data.Text as T+import ProjectM36.Relation.Show.Gnuplot+import qualified Data.Map as M+import Data.Maybe++--operators which only rely on database context reading+data RODatabaseContextOperator where+  ShowRelation :: RelationalExpr -> RODatabaseContextOperator+  PlotRelation :: RelationalExpr -> RODatabaseContextOperator+  ShowRelationType :: RelationalExpr -> RODatabaseContextOperator+  ShowConstraint :: StringType -> RODatabaseContextOperator+  ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator+  ShowTypes :: RODatabaseContextOperator+  ShowRelationVariables :: RODatabaseContextOperator+  Quit :: RODatabaseContextOperator+  deriving (Show)++typeP :: Parser RODatabaseContextOperator+typeP = do+  reservedOp ":type"+  expr <- relExprP+  return $ ShowRelationType expr++showRelP :: Parser RODatabaseContextOperator+showRelP = do+  reservedOp ":showexpr"+  expr <- relExprP+  return $ ShowRelation expr++showPlanP :: Parser RODatabaseContextOperator+showPlanP = do+  reservedOp ":showplan"+  expr <- databaseContextExprP+  return $ ShowPlan expr++showTypesP :: Parser RODatabaseContextOperator+showTypesP = reserved ":showtypes" >> pure ShowTypes++showRelationVariables :: Parser RODatabaseContextOperator+showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables++quitP :: Parser RODatabaseContextOperator+quitP = do+  reservedOp ":quit"+  return Quit++showConstraintsP :: Parser RODatabaseContextOperator+showConstraintsP = do+  reservedOp ":constraints"+  constraintName <- option "" identifier+  return $ ShowConstraint constraintName+  +plotRelExprP :: Parser RODatabaseContextOperator  +plotRelExprP = do+  reserved ":plotexpr"+  expr <- relExprP+  return $ PlotRelation expr++roDatabaseContextOperatorP :: Parser RODatabaseContextOperator+roDatabaseContextOperatorP = typeP+             <|> showRelP+             <|> showRelationVariables+             <|> plotRelExprP+             <|> showConstraintsP+             <|> showPlanP+             <|> showTypesP+             <|> quitP++--logically, these read-only operations could happen purely, but not if a remote call is required+evalRODatabaseContextOp :: C.SessionId -> C.Connection -> RODatabaseContextOperator -> IO TutorialDOperatorResult+evalRODatabaseContextOp sessionId conn (ShowRelationType expr) = do+  res <- C.typeForRelationalExpr sessionId conn expr+  case res of+    Left err -> pure $ DisplayErrorResult $ T.pack (show err)+    Right rel -> pure $ DisplayRelationResult rel++evalRODatabaseContextOp sessionId conn (ShowRelation expr) = do+  res <- C.executeRelationalExpr sessionId conn expr+  case res of+    Left err -> pure $ DisplayErrorResult $ T.pack (show err)+    Right rel -> pure $ DisplayRelationResult rel+    +evalRODatabaseContextOp sessionId conn (PlotRelation expr) = do+  res <- C.executeRelationalExpr sessionId conn expr+  pure $ case res of+    Left err -> DisplayErrorResult $ T.pack (show err)+    Right rel -> DisplayIOResult $ do+      err <- plotRelation rel+      when (isJust err) $ putStrLn (show err)++evalRODatabaseContextOp sessionId conn (ShowConstraint name) = do+  eIncDeps <- C.inclusionDependencies sessionId conn+  let val = case eIncDeps of+        Left err -> Left err+        Right incDeps -> case name of+          "" -> inclusionDependenciesAsRelation incDeps+          depName -> case M.lookup depName incDeps of+            Nothing -> Left (InclusionDependencyNameNotInUseError depName)+            Just dep -> inclusionDependenciesAsRelation (M.singleton depName dep)+  pure $ case val of+     Left err -> DisplayErrorResult (T.pack (show err))+     Right rel -> DisplayRelationResult rel++evalRODatabaseContextOp sessionId conn (ShowPlan dbExpr) = do+  plan <- C.planForDatabaseContextExpr sessionId conn dbExpr+  pure $ case plan of +    Left err -> DisplayErrorResult (T.pack (show err))+    Right optDbExpr -> DisplayResult $ T.pack (show optDbExpr)++evalRODatabaseContextOp sessionId conn ShowTypes = do  +  eRel <- C.atomTypesAsRelation sessionId conn+  case eRel of+    Left err -> pure $ DisplayErrorResult (T.pack (show err))+    Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))+    +evalRODatabaseContextOp sessionId conn ShowRelationVariables = do+  eRel <- C.relationVariablesAsRelation sessionId conn+  case eRel of+    Left err -> pure $ DisplayErrorResult (T.pack (show err))+    Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))+  +evalRODatabaseContextOp _ _ (Quit) = pure QuitResult++interpretRODatabaseContextOp :: C.SessionId -> C.Connection -> T.Text -> IO TutorialDOperatorResult+interpretRODatabaseContextOp sessionId conn tutdstring = case parse roDatabaseContextOperatorP "" tutdstring of+  Left err -> pure $ DisplayErrorResult (T.pack (show err))+  Right parsed -> evalRODatabaseContextOp sessionId conn parsed+  +
+ src/bin/TutorialD/Interpreter/RelationalExpr.hs view
@@ -0,0 +1,248 @@+module TutorialD.Interpreter.RelationalExpr where+import Text.Megaparsec+import Text.Megaparsec.Expr+import ProjectM36.Base+import Text.Megaparsec.Text+import TutorialD.Interpreter.Base+import TutorialD.Interpreter.Types+import qualified Data.Text as T+import qualified Data.Set as S+import qualified Data.Map as M+import Data.List (sort)+import Control.Applicative (liftA)+import ProjectM36.MiscUtils++class RelationalMarkerExpr a where+  parseMarkerP :: Parser a++instance RelationalMarkerExpr () where+  parseMarkerP = pure ()++--used in projection+attributeListP :: Parser AttributeNames+attributeListP = do+  but <- try (string "all but " <* spaceConsumer) <|> string ""+  let constructor = if but == "" then AttributeNames else InvertedAttributeNames+  attrs <- sepBy identifier comma+  pure $ constructor (S.fromList attrs)++makeRelationP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)+makeRelationP = do+  reserved "relation"+  attrExprs <- try (liftA Just makeAttributeExprsP) <|> pure Nothing+  tupleExprs <- braces (sepBy tupleExprP comma) <|> pure []+  pure $ MakeRelationFromExprs attrExprs tupleExprs++--used in relation creation+makeAttributeExprsP :: RelationalMarkerExpr a => Parser [AttributeExprBase a]+makeAttributeExprsP = braces (sepBy attributeAndTypeNameP comma)++attributeAndTypeNameP :: RelationalMarkerExpr a => Parser (AttributeExprBase a)+attributeAndTypeNameP = AttributeAndTypeNameExpr <$> identifier <*> typeConstructorP <*> parseMarkerP+  +--abstract data type parser- in this context, the type constructor must not include any type arguments+--Either Text Int+adTypeConstructorP :: Parser TypeConstructor+adTypeConstructorP = do+  tConsName <- capitalizedIdentifier+  tConsArgs <- many typeConstructorP+  pure $ ADTypeConstructor tConsName tConsArgs++tupleExprP :: RelationalMarkerExpr a => Parser (TupleExprBase a)+tupleExprP = do+  reservedOp "tuple"+  attrAssocs <- braces (sepBy tupleAtomExprP comma)+  --detect duplicate attribute names+  let dupAttrNames = dupes (sort (map fst attrAssocs))+  if length dupAttrNames /= 0 then                    +    fail ("Attribute names duplicated: " ++ show dupAttrNames)+    else+    pure (TupleExpr (M.fromList attrAssocs))++tupleAtomExprP :: RelationalMarkerExpr a => Parser (AttributeName, AtomExprBase a)+tupleAtomExprP = do+  attributeName <- identifier+  atomExpr <- atomExprP+  pure $ (attributeName, atomExpr)+  +projectP :: Parser (RelationalExprBase a  -> RelationalExprBase a)+projectP = do+  attrs <- braces attributeListP+  pure $ Project attrs++renameClauseP :: Parser (T.Text, T.Text)+renameClauseP = do+  oldAttr <- identifier+  reservedOp "as"+  newAttr <- identifier+  pure $ (oldAttr, newAttr)++renameP :: Parser (RelationalExprBase a -> RelationalExprBase a)+renameP = do+  reservedOp "rename"+  renameList <- braces (sepBy renameClauseP comma)+  case renameList of+    [] -> pure (Restrict TruePredicate) --no-op when rename list is empty+    renames -> do+      pure $ \expr -> foldl (\acc (oldAttr, newAttr) -> Rename oldAttr newAttr acc) expr renames++whereClauseP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)+whereClauseP = reservedOp "where" *> (Restrict <$> restrictionPredicateP)++groupClauseP :: Parser (AttributeNames, T.Text)+groupClauseP = do+  attrs <- braces attributeListP+  reservedOp "as"+  newAttrName <- identifier+  return $ (attrs, newAttrName)++groupP :: Parser (RelationalExprBase a -> RelationalExprBase a)+groupP = do+  reservedOp "group"+  (groupAttrList, groupAttrName) <- parens groupClauseP+  pure $ Group groupAttrList groupAttrName++--in "Time and Relational Theory" (2014), Date's Tutorial D grammar for ungroup takes one attribute, while in previous books, it take multiple arguments. Let us assume that nested ungroups are the same as multiple attributes.+ungroupP :: Parser (RelationalExprBase a -> RelationalExprBase a)+ungroupP = do+  reservedOp "ungroup"+  rvaAttrName <- identifier+  pure $ Ungroup rvaAttrName++extendP :: RelationalMarkerExpr a => Parser (RelationalExprBase a -> RelationalExprBase a)+extendP = do+  reservedOp ":"+  tupleExpr <- braces extendTupleExpressionP+  return $ Extend tupleExpr++relOperators :: RelationalMarkerExpr a => [[Operator Parser (RelationalExprBase a)]]+relOperators = [+  [Postfix projectP],+  [Postfix renameP],+  [Postfix whereClauseP],+  [Postfix groupP],+  [Postfix ungroupP],+  [InfixL (reservedOp "join" >> return Join)],+  [InfixL (reservedOp "union" >> return Union)],+  [InfixL (reservedOp "minus" >> return Difference)],+  [InfixN (reservedOp "=" >> return Equals)],+  [Postfix extendP]+  ]++relExprP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)+relExprP = makeExprParser relTerm relOperators++relVarP :: RelationalMarkerExpr a => Parser (RelationalExprBase a)+relVarP = RelationVariable <$> identifier <*> parseMarkerP++relTerm :: RelationalMarkerExpr a => Parser (RelationalExprBase a)+relTerm = parens relExprP+          <|> makeRelationP+          <|> relVarP++restrictionPredicateP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)+restrictionPredicateP = makeExprParser predicateTerm predicateOperators+  where+    predicateOperators = [+      [Prefix (reservedOp "not" >> return NotPredicate)],+      [InfixL (reservedOp "and" >> return AndPredicate)],+      [InfixL (reservedOp "or" >> return OrPredicate)]+      ]+    predicateTerm = parens restrictionPredicateP+                    <|> try restrictionAtomExprP+                    <|> try restrictionAttributeEqualityP+                    <|> try relationalBooleanExprP+++relationalBooleanExprP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)+relationalBooleanExprP = do+  relexpr <- relExprP+  return $ RelationalExprPredicate relexpr+  +restrictionAttributeEqualityP :: RelationalMarkerExpr a => Parser (RestrictionPredicateExprBase a)+restrictionAttributeEqualityP = do+  attributeName <- identifier+  reservedOp "="+  atomexpr <- atomExprP+  return $ AttributeEqualityPredicate attributeName atomexpr++restrictionAtomExprP :: RelationalMarkerExpr a=> Parser (RestrictionPredicateExprBase a) --atoms which are of type "boolean"+restrictionAtomExprP = do+  _ <- char '^' -- not ideal, but allows me to continue to use a context-free grammar+  AtomExprPredicate <$> atomExprP++multiTupleExpressionP :: RelationalMarkerExpr a => Parser [ExtendTupleExprBase a]+multiTupleExpressionP = sepBy extendTupleExpressionP comma++extendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)+extendTupleExpressionP = attributeExtendTupleExpressionP++attributeExtendTupleExpressionP :: RelationalMarkerExpr a => Parser (ExtendTupleExprBase a)+attributeExtendTupleExpressionP = do+  newAttr <- identifier+  reservedOp ":="+  atom <- atomExprP+  return $ AttributeExtendTupleExpr newAttr atom++atomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)+atomExprP = consumeAtomExprP True++consumeAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)+consumeAtomExprP consume = try functionAtomExprP <|>+            try (parens (constructedAtomExprP True)) <|>+            constructedAtomExprP consume <|>+            attributeAtomExprP <|>+            nakedAtomExprP <|>+            relationalAtomExprP++attributeAtomExprP :: Parser (AtomExprBase a)+attributeAtomExprP = do+  _ <- string "@"+  attrName <- identifier+  return $ AttributeAtomExpr attrName++nakedAtomExprP :: Parser (AtomExprBase a)+nakedAtomExprP = NakedAtomExpr <$> atomP++constructedAtomExprP :: RelationalMarkerExpr a => Bool -> Parser (AtomExprBase a)+constructedAtomExprP consume = do+  dConsName <- capitalizedIdentifier+  dConsArgs <- if consume then sepBy (consumeAtomExprP False) spaceConsumer else pure []+  marker <- parseMarkerP+  pure $ ConstructedAtomExpr dConsName dConsArgs marker+  +-- used only for primitive type parsing ?+atomP :: Parser Atom+atomP = stringAtomP <|> +        doubleAtomP <|> +        intAtomP <|> +        boolAtomP+        +functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)+functionAtomExprP = do+  funcName <- identifier+  argList <- parens (sepBy atomExprP comma)+  marker <- parseMarkerP+  return $ FunctionAtomExpr funcName argList marker++relationalAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)+relationalAtomExprP = RelationAtomExpr <$> relExprP++stringAtomP :: Parser Atom+stringAtomP = liftA TextAtom quotedString++doubleAtomP :: Parser Atom    +doubleAtomP = DoubleAtom <$> (try float)++intAtomP :: Parser Atom+intAtomP = do+  i <- integer+  return $ IntAtom (fromIntegral i)++boolAtomP :: Parser Atom+boolAtomP = do+  val <- char 't' <|> char 'f'+  return $ BoolAtom (val == 't')+  +relationAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)+relationAtomExprP = RelationAtomExpr <$> makeRelationP
+ src/bin/TutorialD/Interpreter/SchemaOperator.hs view
@@ -0,0 +1,80 @@+module TutorialD.Interpreter.SchemaOperator where+import Text.Megaparsec+import Text.Megaparsec.Text++import ProjectM36.Base+import ProjectM36.IsomorphicSchema+import ProjectM36.Session+import ProjectM36.Client+import ProjectM36.Error+import TutorialD.Interpreter.RelationalExpr+import TutorialD.Interpreter.Base++data SchemaOperator = ModifySchemaExpr SchemaExpr |+                      SetCurrentSchema SchemaName+                      deriving Show+                      +schemaOperatorP :: Parser SchemaOperator                      +schemaOperatorP = (ModifySchemaExpr <$> schemaExprP) <|>+                  setCurrentSchemaP++setCurrentSchemaP :: Parser SchemaOperator+setCurrentSchemaP = do+  reserved ":setschema"+  SetCurrentSchema <$> identifier+  +schemaExprP :: Parser SchemaExpr+schemaExprP = addSubschemaP <|>+              removeSubschemaP+              +addSubschemaP :: Parser SchemaExpr+addSubschemaP = do+  reserved ":addschema"+  AddSubschema <$> identifier <*> parens (sepBy schemaIsomorphP comma)+  +schemaIsomorphP :: Parser SchemaIsomorph  +schemaIsomorphP = isoRestrictP <|> isoUnionP <|> isoRenameP <|> isoPassthrough++removeSubschemaP :: Parser SchemaExpr+removeSubschemaP = do+  reserved ":removeschema"+  RemoveSubschema <$> identifier++isoRestrictP :: Parser SchemaIsomorph+isoRestrictP = do+  reserved "isorestrict"+  relVarIn <- qrelVarP+  relvarsOut <- isoRestrictOutRelVarsP+  IsoRestrict <$> pure relVarIn <*> restrictionPredicateP <*> pure relvarsOut+  +isoRestrictOutRelVarsP :: Parser (RelVarName, RelVarName)  +isoRestrictOutRelVarsP = (,) <$> qrelVarP <*> qrelVarP++qrelVarP :: Parser RelVarName+qrelVarP = quotedString ++isoUnionP :: Parser SchemaIsomorph+isoUnionP = do+  reserved "isounion"+  relVarsIn <- isoUnionInRelVarsP+  relVarsOut <- qrelVarP+  IsoUnion <$> pure relVarsIn <*> restrictionPredicateP <*> pure relVarsOut+  +isoRenameP :: Parser SchemaIsomorph+isoRenameP = do+  reserved "isorename"+  IsoRename <$> qrelVarP <*> qrelVarP+  +isoPassthrough :: Parser SchemaIsomorph  +isoPassthrough = do+  reserved "isopassthrough"+  rv <- qrelVarP+  pure (IsoRename rv rv)+  +isoUnionInRelVarsP :: Parser (RelVarName, RelVarName)  +isoUnionInRelVarsP = (,) <$> qrelVarP <*> qrelVarP+  +evalSchemaOperator :: SessionId -> Connection -> SchemaOperator -> IO (Maybe RelationalError)+evalSchemaOperator sessionId conn (ModifySchemaExpr expr) =  executeSchemaExpr sessionId conn expr+evalSchemaOperator sessionId conn (SetCurrentSchema sname) = setCurrentSchemaName sessionId conn sname+
+ src/bin/TutorialD/Interpreter/TransGraphRelationalOperator.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module TutorialD.Interpreter.TransGraphRelationalOperator where+import ProjectM36.TransGraphRelationalExpression+import ProjectM36.TransactionGraph+import qualified ProjectM36.Client as C++import TutorialD.Interpreter.Base+import TutorialD.Interpreter.RelationalExpr++import Text.Megaparsec+import Text.Megaparsec.Text++import qualified Data.Text as T++instance RelationalMarkerExpr TransactionIdLookup where+  parseMarkerP = string "@" *> transactionIdLookupP+    +data TransGraphRelationalOperator = ShowTransGraphRelation TransGraphRelationalExpr+                                  deriving Show++transactionIdLookupP :: Parser TransactionIdLookup+transactionIdLookupP =  (TransactionIdLookup <$> uuidP) <|>+                        (TransactionIdHeadNameLookup <$> identifier <*> many transactionIdHeadBacktrackP)+                        +transactionIdHeadBacktrackP :: Parser TransactionIdHeadBacktrack                        +transactionIdHeadBacktrackP = (string "~" *> (TransactionIdHeadParentBacktrack <$> backtrackP)) <|>+                              (string "^" *> (TransactionIdHeadBranchBacktrack <$> backtrackP))+                              +backtrackP :: Parser Int+backtrackP = do+  steps <- integer <|> pure 1+  pure (fromIntegral steps)+  +transGraphRelationalOpP :: Parser TransGraphRelationalOperator                     +transGraphRelationalOpP = showTransGraphRelationalOpP+  +showTransGraphRelationalOpP :: Parser TransGraphRelationalOperator+showTransGraphRelationalOpP = do+  reservedOp ":showtransgraphexpr"+  ShowTransGraphRelation <$> relExprP  +  +evalTransGraphRelationalOp :: C.SessionId -> C.Connection -> TransGraphRelationalOperator -> IO TutorialDOperatorResult+evalTransGraphRelationalOp sessionId conn (ShowTransGraphRelation expr) = do+  res <- C.executeTransGraphRelationalExpr sessionId conn expr+  case res of+    Left err -> pure $ DisplayErrorResult $ T.pack (show err)+    Right rel -> pure $ DisplayRelationResult rel+
+ src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE GADTs #-}+module TutorialD.Interpreter.TransactionGraphOperator where+import TutorialD.Interpreter.Base+import Text.Megaparsec.Text+import Text.Megaparsec+import ProjectM36.TransactionGraph+import ProjectM36.Client+import ProjectM36.Error+import ProjectM36.Base++jumpToHeadP :: Parser TransactionGraphOperator+jumpToHeadP = do+  reservedOp ":jumphead"+  headid <- identifier+  return $ JumpToHead headid++jumpToTransactionP :: Parser TransactionGraphOperator+jumpToTransactionP = do+  reservedOp ":jump"+  uuid <- uuidP+  return $ JumpToTransaction uuid++branchTransactionP :: Parser TransactionGraphOperator+branchTransactionP = do+  reservedOp ":branch"+  branchName <- identifier+  return $ Branch branchName++deleteBranchP :: Parser TransactionGraphOperator+deleteBranchP = do+  reserved ":deletebranch"+  DeleteBranch <$> identifier++commitTransactionP :: Parser TransactionGraphOperator+commitTransactionP = do+  reservedOp ":commit"+  return $ Commit ForbidEmptyCommitOption++rollbackTransactionP :: Parser TransactionGraphOperator+rollbackTransactionP = do+  reservedOp ":rollback"+  return $ Rollback++showGraphP :: Parser ROTransactionGraphOperator+showGraphP = do+  reservedOp ":showgraph"+  return $ ShowGraph+  +mergeTransactionStrategyP :: Parser MergeStrategy+mergeTransactionStrategyP = (reserved "union" *> pure UnionMergeStrategy) <|>+                            (do+                                reserved "selectedbranch"+                                branch <- identifier+                                pure (SelectedBranchMergeStrategy branch)) <|>+                            (do+                                reserved "unionpreferbranch"+                                branch <- identifier+                                pure (UnionPreferMergeStrategy branch))+  +mergeTransactionsP :: Parser TransactionGraphOperator+mergeTransactionsP = do+  reservedOp ":mergetrans"+  strategy <- mergeTransactionStrategyP+  headA <- identifier+  headB <- identifier+  pure (MergeTransactions strategy headA headB)++transactionGraphOpP :: Parser TransactionGraphOperator+transactionGraphOpP = do+  jumpToHeadP+  <|> jumpToTransactionP+  <|> branchTransactionP+  <|> deleteBranchP+  <|> commitTransactionP+  <|> rollbackTransactionP+  <|> mergeTransactionsP++roTransactionGraphOpP :: Parser ROTransactionGraphOperator+roTransactionGraphOpP = showGraphP++++{-+-- for interpreter-specific operations+interpretOps :: U.UUID -> DisconnectedTransaction -> TransactionGraph -> String -> (DisconnectedTransaction, TransactionGraph, TutorialDOperatorResult)+interpretOps newUUID trans@(DisconnectedTransaction _ context) transGraph instring = case parse interpreterOps "" instring of+  Left _ -> (trans, transGraph, NoActionResult)+  Right ops -> case ops of+    Left contextOp -> (trans, transGraph, (evalContextOp context contextOp))+    Right graphOp -> case evalGraphOp newUUID trans transGraph graphOp of+      Left err -> (trans, transGraph, DisplayErrorResult $ T.pack (show err))+      Right (newDiscon, newGraph, result) -> (newDiscon, newGraph, result)+-}++evalROGraphOp :: SessionId -> Connection -> ROTransactionGraphOperator -> IO (Either RelationalError Relation)+evalROGraphOp sessionId conn ShowGraph = transactionGraphAsRelation sessionId conn
+ src/bin/TutorialD/Interpreter/Types.hs view
@@ -0,0 +1,50 @@+--parse type and data constructors+module TutorialD.Interpreter.Types where+import ProjectM36.Base+import Text.Megaparsec.Text+import Text.Megaparsec+import TutorialD.Interpreter.Base+import ProjectM36.DataTypes.Primitive+import qualified Data.Text as T++-- | Upper case names are type names while lower case names are polymorphic typeconstructor arguments.+-- data *Either a b* = Left a | Right b+typeConstructorDefP :: Parser TypeConstructorDef+typeConstructorDefP = ADTypeConstructorDef <$> capitalizedIdentifier <*> typeVarNamesP++typeVarNamesP :: Parser [TypeVarName]+typeVarNamesP = many uncapitalizedIdentifier +  +-- data Either a b = *Left a* | *Right b*+dataConstructorDefP :: Parser DataConstructorDef+dataConstructorDefP = DataConstructorDef <$> capitalizedIdentifier <*> many dataConstructorDefArgP++-- data *Either a b* = Left *a* | Right *b*+dataConstructorDefArgP :: Parser DataConstructorDefArg+dataConstructorDefArgP = parens (DataConstructorDefTypeConstructorArg <$> typeConstructorP) <|>+                         DataConstructorDefTypeConstructorArg <$> typeConstructorP <|>+                         DataConstructorDefTypeVarNameArg <$> uncapitalizedIdentifier+  +--built-in, nullary type constructors+-- Int, Text, etc.+primitiveTypeConstructorP :: Parser TypeConstructor+primitiveTypeConstructorP = choice (map (\(PrimitiveTypeConstructorDef name typ, _) -> do+                                               tName <- try $ symbol (T.unpack name)+                                               pure $ PrimitiveTypeConstructor tName typ)+                                       primitiveTypeConstructorMapping)+                            +-- *Either Int Text*, *Int*+typeConstructorP :: Parser TypeConstructor                  +typeConstructorP = primitiveTypeConstructorP <|>+                   TypeVariable <$> uncapitalizedIdentifier <|>+                   ADTypeConstructor <$> capitalizedIdentifier <*> many (parens typeConstructorP <|>+                                                                         monoTypeConstructorP)+                   +monoTypeConstructorP :: Parser TypeConstructor                   +monoTypeConstructorP = primitiveTypeConstructorP <|>+  ADTypeConstructor <$> capitalizedIdentifier <*> pure [] <|>+  TypeVariable <$> uncapitalizedIdentifier+                   +++
+ src/bin/TutorialD/tutd.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+import TutorialD.Interpreter+import ProjectM36.Base+import ProjectM36.Client+import System.IO+import Options.Applicative+import System.Exit+import Data.Monoid++parseArgs :: Parser InterpreterConfig+parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseGhcPkgPaths <|>+            RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName++parsePersistenceStrategy :: Parser PersistenceStrategy+parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>+                           MinimalPersistence <$> dbdirOpt <|>+                           pure NoPersistence+  where +    dbdirOpt = strOption (short 'd' <> +                          long "database-directory" <> +                          metavar "DIRECTORY" <>+                          showDefaultWith show+                         )+    fsyncOpt = switch (short 'f' <>+                    long "fsync" <>+                    help "Fsync all new transactions.")+               +parseHeadName :: Parser HeadName               +parseHeadName = option auto (long "head" <>+                             help "Start session at head name." <>+                             value "master"+                            )+               +parseDatabaseName :: Parser DatabaseName               +parseDatabaseName = strOption (long "database" <>+                               short 'n' <>+                               help "Remote database name")+               +parseNodeId :: Parser NodeId+parseNodeId = createNodeId <$> +              strOption (long "host" <> +                         short 'h' <>+                         help "Remote host name" <>+                         value "127.0.0.1") <*> +              option auto (long "port" <>+                           short 'p' <>+                      help "Remote port" <>+                      value defaultServerPort)+              +parseGhcPkgPaths :: Parser [GhcPkgPath]              +parseGhcPkgPaths = many (strOption (long "ghc-pkg-dir" <>+                                    metavar "GHC_PACKAGE_DIRECTORY"))++opts :: ParserInfo InterpreterConfig            +opts = info parseArgs idm++connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo+connectionInfoForConfig (LocalInterpreterConfig pStrategy _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths+connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback++headNameForConfig :: InterpreterConfig -> HeadName+headNameForConfig (LocalInterpreterConfig _ headn _) = headn+headNameForConfig (RemoteInterpreterConfig _ _ headn) = headn++{-+ghcPkgPathsForConfig :: InterpreterConfig -> [GhcPkgPath]+ghcPkgPathsForConfig (LocalInterpreterConfig _ _ paths) = paths+ghcPkgPathsForConfig _ = error "Clients cannot configure remote ghc package paths."+-}+                         +errDie :: String -> IO ()                                                           +errDie err = hPutStrLn stderr err >> exitFailure++#ifndef PROJECTM36_VERSION+#error PROJECTM36_VERSION is not defined+#endif+printWelcome :: IO ()+printWelcome = do+  putStrLn $ "Project:M36 TutorialD Interpreter " ++ PROJECTM36_VERSION+  putStrLn "Type \":help\" for more information."+  putStrLn "A full tutorial is available at:"+  putStrLn "https://github.com/agentm/project-m36/blob/master/docs/tutd_tutorial.markdown"++main :: IO ()+main = do+  interpreterConfig <- execParser opts+  let connInfo = connectionInfoForConfig interpreterConfig+  dbconn <- connectProjectM36 connInfo+  case dbconn of +    Left err -> do+      errDie ("Failed to create database connection: " ++ show err)+    Right conn -> do+      let connHeadName = headNameForConfig interpreterConfig+      eSessionId <- createSessionAtHead connHeadName conn+      case eSessionId of +          Left err -> errDie ("Failed to create database session at \"" ++ show connHeadName ++ "\": " ++ show err)+          Right sessionId -> do+            printWelcome+            _ <- reprLoop interpreterConfig sessionId conn+            pure ()+
+ src/bin/benchmark/Relation.hs view
@@ -0,0 +1,27 @@+import Criterion.Main+import ProjectM36.Relation+import ProjectM36.Base+import ProjectM36.Error+import qualified ProjectM36.Attribute as A+import qualified Data.Text as T+import qualified Data.Vector as V++-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long+-- this is useful for performance and resource usage testing+matrixRelation :: Int -> Int -> Either RelationalError Relation+matrixRelation attributeCount tupleCount = do+  let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]+      tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))+      tuples = map (\c -> tuple c) [0 .. tupleCount]+  mkRelationDeferVerify attrs (RelationTupleSet tuples)++main :: IO ()+main = defaultMain [+  bgroup "Big Relation" [ +     bench "100" $ whnf (matrixRelation 10) 100,+     bench "1000" $ whnf (matrixRelation 10) 1000,+     bench "10000" $ whnf (matrixRelation 10) 10000+     ]+  ]+       +
+ src/bin/benchmark/bigrel.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.DateExamples+import ProjectM36.Error+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 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.Monoid++dumpcsv :: Relation -> IO ()+dumpcsv rel = case relationAsCSV rel of+  Left err -> hPutStrLn stderr (show err)+  Right bsData -> BS.putStrLn bsData++data BigrelArgs = BigrelArgs Int Int Text++parseAttributeCount :: Parser Int+parseAttributeCount = option auto (short 'a' <> long "attribute-count")++parseTupleCount :: Parser Int+parseTupleCount = option auto (short 't' <> long "tuple-count")++parseTutD :: Parser String+parseTutD = strOption (short 'd' <> long "tutoriald")++parseArgs :: Parser BigrelArgs+parseArgs =  BigrelArgs <$> parseAttributeCount <*> parseTupleCount <*> (pack <$> parseTutD)++main :: IO ()+main = do+  bigrelArgs <- execParser $ info (helper <*> parseArgs) fullDesc+  --matrixRestrictRun+  matrixRun bigrelArgs+    --vectorMatrixRun+    --intmapMatrixRun++matrixRun :: BigrelArgs -> IO ()+matrixRun (BigrelArgs attributeCount tupleCount tutd) = do+  case matrixRelation attributeCount tupleCount of+    Left err -> putStrLn (show err)+    Right rel -> if tutd == "" then+                   putStrLn "Done."+                 else do+                   let setx = Assign "x" (ExistingRelation (force rel))+                       (context,_,_) = execState (evalDatabaseContextExpr setx) (freshDatabaseState dateExamples)+                       interpreted = interpretDatabaseContextExpr context tutd+                       --plan = interpretRODatabaseContextOp context $ ":showplan " ++ tutd+                   --displayOpResult plan+                   case interpreted of+                     Right context' -> TIO.putStrLn $ relationAsHTML ((relationVariables context') M.! "x")+                     Left err -> hPutStrLn stderr (show err)+++intmapMatrixRun :: IO ()+intmapMatrixRun = do+  let matrix = intmapMatrixRelation 100 100000+  putStrLn (show matrix)++--compare IntMap speed and size+--this is about 3 times faster (9 minutes) for 10x100000 and uses 800 MB+intmapMatrixRelation :: Int -> Int -> HS.HashSet (IM.IntMap Atom)+intmapMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]+  where+    mapper tupCount = IM.fromList $ map (\c-> (c, IntAtom tupCount)) [0..attributeCount]++instance Hash.Hashable (IM.IntMap Atom) where+  hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)++vectorMatrixRun :: IO ()+vectorMatrixRun = do+  let matrix = vectorMatrixRelation 100 100000+  putStrLn (show matrix)++-- 20 s 90 MBs- a clear win- ideal size is 10 * 100000 * 8 bytes = 80 MB! without IntAtom wrapper+--with IntAtom wrapper: 1m12s 90 MB+vectorMatrixRelation :: Int -> Int -> HS.HashSet (V.Vector Atom)+vectorMatrixRelation attributeCount tupleCount = HS.fromList $ map mapper [0..tupleCount]+  where+    mapper tupCount = V.replicate attributeCount (IntAtom tupCount)++instance Hash.Hashable (V.Vector Atom) where+  hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)++-- returns a relation with tupleCount tuples with a set of integer attributes attributesCount long+-- this is useful for performance and resource usage testing+matrixRelation :: Int -> Int -> Either RelationalError Relation+matrixRelation attributeCount tupleCount = do+  let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]+      tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom tupleX))+      tuples = map (\c -> tuple c) [0 .. tupleCount]+  mkRelationDeferVerify attrs (RelationTupleSet tuples)+
+ src/lib/ProjectM36/Atom.hs view
@@ -0,0 +1,36 @@+module ProjectM36.Atom where+import ProjectM36.Base+import ProjectM36.Error+import qualified Data.Text as T+--import Data.Time.Calendar+--import Data.Time.Clock+--import Data.ByteString (ByteString)+import Text.Read++relationForAtom :: Atom -> Either RelationalError Relation+relationForAtom (RelationAtom rel) = Right rel+relationForAtom _ = Left $ AttributeIsNotRelationValuedError ""++makeAtomFromText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom+makeAtomFromText _ IntAtomType textIn = maybe ((Left . ParseError) textIn) (Right . IntAtom) (readMaybe (T.unpack textIn))+makeAtomFromText _ DoubleAtomType textIn = maybe ((Left . ParseError) textIn) (Right . DoubleAtom) (readMaybe (T.unpack textIn))+makeAtomFromText _ TextAtomType textIn = maybe ((Left . ParseError) textIn) (Right . TextAtom) (readMaybe (T.unpack textIn))+makeAtomFromText _ DayAtomType textIn = maybe ((Left . ParseError) textIn) (Right . DayAtom) (readMaybe (T.unpack textIn))+makeAtomFromText _ DateTimeAtomType textIn = maybe ((Left . ParseError) textIn) (Right . DateTimeAtom) (readMaybe (T.unpack textIn))+makeAtomFromText _ ByteStringAtomType textIn = maybe ((Left . ParseError) textIn) (Right . ByteStringAtom) (readMaybe (T.unpack textIn))+makeAtomFromText _ BoolAtomType textIn = maybe ((Left . ParseError) textIn) (Right . BoolAtom) (readMaybe (T.unpack textIn))+makeAtomFromText attrName _ _ = Left $ AtomTypeNotSupported attrName++atomToText :: Atom -> T.Text+atomToText (IntAtom i) = (T.pack . show) i+atomToText (DoubleAtom i) = (T.pack . show) i+atomToText (TextAtom i) = (T.pack . show) i --does this break quoting in CSV export?+atomToText (DayAtom i) = (T.pack . show) i+atomToText (DateTimeAtom i) = (T.pack . show) i+atomToText (ByteStringAtom i) = (T.pack . show) i+atomToText (BoolAtom i) = (T.pack . show) i+atomToText (RelationAtom i) = (T.pack . show) i+atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)+++
+ src/lib/ProjectM36/AtomFunction.hs view
@@ -0,0 +1,66 @@+module ProjectM36.AtomFunction where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.AtomFunctionError+import qualified ProjectM36.Attribute as A+import qualified Data.HashSet as HS++foldAtomFuncType :: AtomType -> AtomType -> [AtomType]+foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]++atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction+atomFunctionForName funcName funcSet = if HS.null foundFunc then+                                         Left $ NoSuchFunctionError funcName+                                        else+                                         Right $ head $ HS.toList foundFunc+  where+    foundFunc = HS.filter (\(AtomFunction name _ _) -> name == funcName) funcSet++-- | Create a junk named atom function for use with searching for an already existing function in the AtomFunctions HashSet.+emptyAtomFunction :: AtomFunctionName -> AtomFunction+emptyAtomFunction name = AtomFunction { atomFuncName = name,+                                        atomFuncType = [TypeVariableType "a", TypeVariableType "a"],+                                        atomFuncBody = AtomFunctionBody Nothing (\(x:_) -> pure x) }+                                          +                                          +-- | AtomFunction constructor for compiled-in functions.+compiledAtomFunction :: AtomFunctionName -> [AtomType] -> AtomFunctionBodyType -> AtomFunction+compiledAtomFunction name aType body = AtomFunction { atomFuncName = name,+                                                      atomFuncType = aType,+                                                      atomFuncBody = AtomFunctionBody Nothing body }++--the atom function really should offer some way to return an error+evalAtomFunction :: AtomFunction -> [Atom] -> Either AtomFunctionError Atom+evalAtomFunction func args = case atomFuncBody func of+  (AtomFunctionBody _ f) -> f args++--expect "Int -> Either AtomFunctionError Int"+--return "Int -> Int" for funcType+extractAtomFunctionType :: [TypeConstructor] -> Either RelationalError [TypeConstructor]+extractAtomFunctionType typeIn = do+  let atomArgs = take (length typeIn - 1) typeIn+      --expected atom ret value - used to make funcType+      lastArg = take 1 (reverse typeIn)+  case lastArg of+    (ADTypeConstructor "Either" +      ((ADTypeConstructor "AtomFunctionError" []):+      atomRetArg:[])):[] -> do+      pure (atomArgs ++ [atomRetArg])+    otherType -> Left (ScriptError (TypeCheckCompilationError "function returning \"Either AtomFunctionError a\"" (show otherType)))+    +isScriptedAtomFunction :: AtomFunction -> Bool    +isScriptedAtomFunction func = case atomFuncBody func of+  AtomFunctionBody (Just _) _ -> True+  AtomFunctionBody Nothing _ -> False+  +atomFunctionScript :: AtomFunction -> Maybe AtomFunctionBodyScript+atomFunctionScript func = case atomFuncBody func of+  AtomFunctionBody script _ -> script+  +-- | Create a 'DatabaseContextIOExpr' which can be used to load a new atom function written in Haskell and loaded at runtime.+createScriptedAtomFunction :: AtomFunctionName -> [TypeConstructor] -> TypeConstructor -> AtomFunctionBodyScript -> DatabaseContextIOExpr+createScriptedAtomFunction funcName argsType retType script = AddAtomFunction funcName (+  argsType ++ [ADTypeConstructor "Either" [+                ADTypeConstructor "AtomFunctionError" [],                     +                retType]]) script+
+ src/lib/ProjectM36/AtomFunctionBody.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE ScopedTypeVariables #-}+--tools to execute an atom function body+module ProjectM36.AtomFunctionBody where+import ProjectM36.Base++compiledAtomFunctionBody :: AtomFunctionBodyType -> AtomFunctionBody  +compiledAtomFunctionBody func = AtomFunctionBody Nothing func
+ src/lib/ProjectM36/AtomFunctionError.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module ProjectM36.AtomFunctionError where+import Data.Binary+import GHC.Generics+import Control.DeepSeq++data AtomFunctionError = AtomFunctionUserError String |+                         AtomFunctionTypeMismatchError |+                         AtomFunctionBytesDecodingError String+                       deriving(Generic, Eq, Show, Binary, NFData)+
+ src/lib/ProjectM36/AtomFunctions/Basic.hs view
@@ -0,0 +1,23 @@+--atom functions on primitive atom values plus the basic atom functions+module ProjectM36.AtomFunctions.Basic where+import ProjectM36.Base+import ProjectM36.DataTypes.Day+import ProjectM36.DataTypes.Either+import ProjectM36.DataTypes.Maybe+import ProjectM36.AtomFunctions.Primitive+import ProjectM36.AtomFunction+import ProjectM36.DataTypes.List+import ProjectM36.DataTypes.DateTime+import qualified Data.HashSet as HS++basicAtomFunctions :: AtomFunctions+basicAtomFunctions = HS.unions [primitiveAtomFunctions, +                                dayAtomFunctions,+                                dateTimeAtomFunctions,+                                eitherAtomFunctions,+                                maybeAtomFunctions,+                                listAtomFunctions]++--these special atom functions aren't scripted so they can't be serialized normally. Instead, the body remains in the binary and the serialization/deserialization happens by name only.+precompiledAtomFunctions :: AtomFunctions+precompiledAtomFunctions = HS.filter (not . isScriptedAtomFunction) basicAtomFunctions
+ src/lib/ProjectM36/AtomFunctions/Primitive.hs view
@@ -0,0 +1,90 @@+module ProjectM36.AtomFunctions.Primitive where+import ProjectM36.Base+import ProjectM36.Relation (relFold)+import ProjectM36.Tuple+import ProjectM36.AtomFunctionError+import ProjectM36.AtomFunction+import qualified Data.HashSet as HS+import qualified Data.Vector as V+import qualified Data.ByteString.Base64 as B64+import qualified Data.Text.Encoding as TE++primitiveAtomFunctions :: AtomFunctions+primitiveAtomFunctions = HS.fromList [+  --match on any relation type+  AtomFunction { atomFuncName = "add",+                 atomFuncType = [IntAtomType, IntAtomType, IntAtomType],+                 atomFuncBody = body (\((IntAtom i1):(IntAtom i2):_) -> pure (IntAtom (i1 + i2)))},+  AtomFunction { atomFuncName = "id",+                 atomFuncType = [TypeVariableType "a", TypeVariableType "a"],+                 atomFuncBody = body (\(x:_) -> pure x)},+  AtomFunction { atomFuncName = "sum",+                 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,+                 atomFuncBody = body (\(RelationAtom rel:_) -> relationSum rel)},+  AtomFunction { atomFuncName = "count",+                 atomFuncType = foldAtomFuncType (TypeVariableType "a") IntAtomType,+                 atomFuncBody = body (\((RelationAtom relIn):_) -> relationCount relIn)},+  AtomFunction { atomFuncName = "max",+                 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,+                 atomFuncBody = body (\((RelationAtom relIn):_) -> relationMax relIn)},+  AtomFunction { atomFuncName = "min",+                 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,+                 atomFuncBody = body (\((RelationAtom relIn):_) -> relationMin relIn)},+  AtomFunction { atomFuncName = "lt",+                 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],+                 atomFuncBody = body $ intAtomFuncLessThan False},+  AtomFunction { atomFuncName = "lte",+                 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],+                 atomFuncBody = body $ intAtomFuncLessThan True},+  AtomFunction { atomFuncName = "gte",+                 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],+                 atomFuncBody = body $ \args -> intAtomFuncLessThan False args >>= boolAtomNot},+  AtomFunction { atomFuncName = "gt",+                 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],+                 atomFuncBody = body $ \args -> intAtomFuncLessThan True args >>= boolAtomNot},+  AtomFunction { atomFuncName = "not",+                 atomFuncType = [BoolAtomType, BoolAtomType],+                 atomFuncBody = body $ \(b:_) -> boolAtomNot b },+  AtomFunction { atomFuncName = "makeByteString",+                 atomFuncType = [TextAtomType, ByteStringAtomType],+                 atomFuncBody = body $ \((TextAtom textIn):_) -> case B64.decode (TE.encodeUtf8 textIn) of+                   Left err -> Left (AtomFunctionBytesDecodingError err)+                   Right bs -> pure (ByteStringAtom bs) }+  ]+  where+    body = AtomFunctionBody Nothing+                         +intAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom+intAtomFuncLessThan equality ((IntAtom i1):(IntAtom i2):_) = pure (BoolAtom (i1 `op` i2))+  where+    op = if equality then (<=) else (<)+intAtomFuncLessThan _ _= pure (BoolAtom False)++boolAtomNot :: Atom -> Either AtomFunctionError Atom+boolAtomNot (BoolAtom b) = pure (BoolAtom (not b))+boolAtomNot _ = error "boolAtomNot called on non-Bool atom"++--used by sum atom function+relationSum :: Relation -> Either AtomFunctionError Atom+relationSum relIn = pure (IntAtom (relFold (\tupIn acc -> acc + (newVal tupIn)) 0 relIn))+  where+    --extract Int from Atom+    newVal :: RelationTuple -> Int+    newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)+    +relationCount :: Relation -> Either AtomFunctionError Atom+relationCount relIn = pure (IntAtom (relFold (\_ acc -> acc + 1) (0::Int) relIn))++relationMax :: Relation -> Either AtomFunctionError Atom+relationMax relIn = pure (IntAtom (relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn))+  where+    newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)++relationMin :: Relation -> Either AtomFunctionError Atom+relationMin relIn = pure (IntAtom (relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn))+  where+    newVal tupIn = castInt ((tupleAtoms tupIn) V.! 0)++castInt :: Atom -> Int+castInt (IntAtom i) = i+castInt _ = error "attempted to cast non-IntAtom to Int"
+ src/lib/ProjectM36/AtomType.hs view
@@ -0,0 +1,291 @@+module ProjectM36.AtomType where+import ProjectM36.Base+import qualified ProjectM36.TypeConstructorDef as TCD+import qualified ProjectM36.TypeConstructor as TC+import qualified ProjectM36.DataConstructorDef as DCD+import ProjectM36.MiscUtils+import ProjectM36.Error+import ProjectM36.DataTypes.Primitive+import qualified ProjectM36.Attribute as A+import qualified Data.Vector as V+import qualified Data.Set as S+import qualified Data.List as L+import Data.Maybe (isJust)+import Data.Either (rights, lefts)+import Control.Monad.Writer+import qualified Data.Map as M+import qualified Data.Text as T++findDataConstructor :: DataConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, DataConstructorDef)+findDataConstructor dName tConsList = foldr tConsFolder Nothing tConsList+  where+    tConsFolder (tCons, dConsList) accum = if isJust accum then+                                accum+                              else+                                case findDCons dConsList of+                                  Just dCons -> Just (tCons, dCons)+                                  Nothing -> Nothing+    findDCons dConsList = case filter (\dCons -> DCD.name dCons == dName) dConsList of+      [] -> Nothing+      [dCons] -> Just dCons+      _ -> error "More than one data constructor with the same name found"+  +-- | Scan the atom types and return the resultant ConstructedAtomType or error.+-- Used in typeFromAtomExpr to validate argument types.+atomTypeForDataConstructorName :: DataConstructorName -> [AtomType] -> TypeConstructorMapping -> Either RelationalError AtomType+-- search for the data constructor and resolve the types' names+atomTypeForDataConstructorName dConsName atomTypesIn tConsList = do+  case findDataConstructor dConsName tConsList of+    Nothing -> Left (NoSuchDataConstructorError dConsName)+    Just (tCons, dCons) -> do+      typeVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList+      pure (ConstructedAtomType (TCD.name tCons) typeVars)+        +atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType+atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss = +  case isValidAtomTypeForTypeConstructor aType tCons tConss of+    Just err -> Left err+    Nothing -> Right aType++atomTypeForDataConstructorDefArg (DataConstructorDefTypeVarNameArg _) aType _ = Right aType --any type is OK+        +--reconcile the atom-in types with the type constructors+isValidAtomTypeForTypeConstructor :: AtomType -> TypeConstructor -> TypeConstructorMapping -> Maybe RelationalError+isValidAtomTypeForTypeConstructor aType (PrimitiveTypeConstructor _ expectedAType) _ = if expectedAType /= aType then Just (AtomTypeMismatchError expectedAType aType) else Nothing++--lookup constructor name and check if the incoming atom types are valid+isValidAtomTypeForTypeConstructor (ConstructedAtomType tConsName _) (ADTypeConstructor expectedTConsName _) _ =  if tConsName /= expectedTConsName then Just (TypeConstructorNameMismatch expectedTConsName tConsName) else Nothing++isValidAtomTypeForTypeConstructor aType tCons _ = Just (AtomTypeTypeConstructorReconciliationError aType (TC.name tCons))++-- | Used to determine if the atom arguments can be used with the data constructor.  +-- | This is the entry point for type-checking from RelationalExpression.hs.+atomTypeForDataConstructor :: TypeConstructorMapping -> DataConstructorName -> [AtomType] -> Either RelationalError AtomType+atomTypeForDataConstructor tConss dConsName atomArgTypes = do+  --lookup the data constructor+  case findDataConstructor dConsName tConss of+    Nothing -> Left (NoSuchDataConstructorError dConsName)+    Just (tCons, dCons) -> do+      --validate that the type constructor arguments are fulfilled in the data constructor+      typeVars <- resolveDataConstructorTypeVars dCons atomArgTypes tConss+      pure (ConstructedAtomType (TCD.name tCons) typeVars)+      +-- | Walks the data and type constructors to extract the type variable map.+resolveDataConstructorTypeVars :: DataConstructorDef -> [AtomType] -> TypeConstructorMapping -> Either RelationalError TypeVarMap+resolveDataConstructorTypeVars dCons aTypeArgs tConss = do+  maps <- mapM (\(dCons',aTypeArg) -> resolveDataConstructorArgTypeVars dCons' aTypeArg tConss) (zip (DCD.fields dCons) aTypeArgs)+  --if any two maps have the same key and different values, this indicates a type arg mismatch+  let typeVarMapFolder valMap acc = case acc of+        Left err -> Left err+        Right accMap -> if accMap `M.isSubmapOf` valMap then+                          Right (M.union accMap valMap)+                        else+                          Left (DataConstructorTypeVarsMismatch (DCD.name dCons) accMap valMap)+  case foldr typeVarMapFolder (Right M.empty) maps of+    Left err -> Left err+    Right typeVarMaps -> pure typeVarMaps+  --if the data constructor cannot complete a type constructor variables (ex. "Nothing" could be Maybe Int or Maybe Text, etc.), then fill that space with TypeVar which is resolved when the relation is constructed- the relation must contain all resolved atom types.+++-- | Attempt to match the data constructor argument to a type constructor type variable.+resolveDataConstructorArgTypeVars :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap+resolveDataConstructorArgTypeVars (DataConstructorDefTypeConstructorArg tCons) aType tConss = resolveTypeConstructorTypeVars tCons aType tConss+  +resolveDataConstructorArgTypeVars (DataConstructorDefTypeVarNameArg pVarName) aType _ = Right (M.singleton pVarName aType)++resolveTypeConstructorTypeVars :: TypeConstructor -> AtomType -> TypeConstructorMapping -> Either RelationalError TypeVarMap+resolveTypeConstructorTypeVars (PrimitiveTypeConstructor _ pType) aType _ = +  if aType /= pType then+    Left (AtomTypeMismatchError pType aType)+  else+    Right M.empty++resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) (ConstructedAtomType tConsName' pVarMap') tConss = +  if tConsName /= tConsName' then+    Left (TypeConstructorNameMismatch tConsName tConsName')+  else+    case findTypeConstructor tConsName tConss of+      Nothing -> Left (NoSuchTypeConstructorName tConsName)+      Just (tConsDef, _) -> let expectedPVarNames = S.fromList (TCD.typeVars tConsDef) in+        if M.keysSet pVarMap' `S.isSubsetOf` expectedPVarNames then+          Right pVarMap' +        else+          Left (TypeConstructorTypeVarsMismatch expectedPVarNames (M.keysSet pVarMap'))+resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)          +resolveTypeConstructorTypeVars x y _ = error $ "Unhandled type vars:"  ++ show x ++ show y                             +    +-- check that type vars on the right also appear on the left+-- check that the data constructor names are unique      +validateTypeConstructorDef :: TypeConstructorDef -> [DataConstructorDef] -> [RelationalError]+validateTypeConstructorDef tConsDef dConsList = execWriter $ do+  let duplicateDConsNames = dupes (L.sort (map DCD.name dConsList))+  mapM_ tell [map DataConstructorNameInUseError duplicateDConsNames]+  let leftSideVars = S.fromList (TCD.typeVars tConsDef)+      rightSideVars = S.unions (map DCD.typeVars dConsList)+      varsDiff = S.difference leftSideVars rightSideVars+  mapM_ tell [map DataConstructorUsesUndeclaredTypeVariable (S.toList varsDiff)]+  pure ()+    ++-- | Create an atom type iff all type variables are provided.+-- Either Int Text -> ConstructedAtomType "Either" {Int , Text}+atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> Either RelationalError AtomType+atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ = Right aType+atomTypeForTypeConstructor (TypeVariable tvname) _ = Right (TypeVariableType tvname)+atomTypeForTypeConstructor tCons tConss = case findTypeConstructor (TC.name tCons) tConss of+  Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))+  Just (tConsDef, _) -> do+      tConsArgTypes <- mapM ((flip atomTypeForTypeConstructor) tConss) (TC.arguments tCons)    +      let pVarNames = TCD.typeVars tConsDef+          tConsArgs = M.fromList (zip pVarNames tConsArgTypes)+      Right (ConstructedAtomType (TC.name tCons) tConsArgs)      ++findTypeConstructor :: TypeConstructorName -> TypeConstructorMapping -> Maybe (TypeConstructorDef, [DataConstructorDef])+findTypeConstructor name tConsList = foldr tConsFolder Nothing tConsList+  where+    tConsFolder (tCons, dConsList) accum = if TCD.name tCons == name then+                                     Just (tCons, dConsList)+                                   else+                                     accum+                                    +resolveAtomType :: AtomType -> AtomType -> Either RelationalError AtomType  +resolveAtomType (ConstructedAtomType tConsName resolvedTypeVarMap) (ConstructedAtomType _ unresolvedTypeVarMap) = do  +  tVarMap <- resolveAtomTypesInTypeVarMap resolvedTypeVarMap unresolvedTypeVarMap+  pure (ConstructedAtomType tConsName tVarMap)+resolveAtomType typeFromRelation unresolvedType = if typeFromRelation == unresolvedType then+                                                    Right typeFromRelation+                                                  else+                                                    Left (AtomTypeMismatchError typeFromRelation unresolvedType)+                                                    +-- this could be optimized to reduce new tuple creation- if anyatomtype does not appear, just return the original typevarmap+resolveAtomTypesInTypeVarMap :: TypeVarMap -> TypeVarMap -> Either RelationalError TypeVarMap+resolveAtomTypesInTypeVarMap resolvedTypeMap unresolvedTypeMap = do+  {-+  let resKeySet = traceShowId $ M.keysSet resolvedTypeMap+      unresKeySet = traceShowId $ M.keysSet unresolvedTypeMap+  when (resKeySet /= unresKeySet) (Left $ TypeConstructorTypeVarsMismatch resKeySet unresKeySet)+  ++  let lookupOrDef key tMap = case M.lookup key tMap of+        Nothing -> Left (TypeConstructorTypeVarMissing key)+        Just val -> Right val+  -}+  let resolveTypePair resKey resType = do+        -- 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 +            --do we need to recurse for RelationAtomType?+            subType@(ConstructedAtomType _ _) -> do+              resSubType <- resolveAtomType resType subType+              pure (resKey, resSubType)+            otherType -> pure (resKey, otherType)+          Nothing -> do+            pure (resKey, resType) --swipe the missing type var from the expected map+  tVarList <- mapM (uncurry resolveTypePair) (M.toList resolvedTypeMap)+  pure (M.fromList tVarList)+  +-- | See notes at `resolveTypesInTuple`. The typeFromRelation must not include any wildcards.+resolveTypeInAtom :: AtomType -> Atom -> Either RelationalError Atom+resolveTypeInAtom typeFromRelation atomIn@(ConstructedAtom dConsName _ args) = do+  newType <- resolveAtomType typeFromRelation (atomTypeForAtom atomIn)+  pure (ConstructedAtom dConsName newType args)+resolveTypeInAtom _ atom = Right atom+  +-- | When creating a tuple, the data constructor may not complete the type constructor arguments, so the wildcard "TypeVar x" fills in the type constructor's argument. The tuple type must be resolved before it can be part of a relation, however.+-- Example: "Nothing" does not specify the the argument in "Maybe a", so allow delayed resolution in the tuple before it is added to the relation. Note that this resolution could cause a type error. Hardly a Hindley-Milner system.+resolveTypesInTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple+resolveTypesInTuple resolvedAttrs (RelationTuple _ tupAtoms) = do+  newAtoms <- mapM (\(atom, resolvedType) -> resolveTypeInAtom resolvedType atom) (zip (V.toList tupAtoms) $ (map A.atomType (V.toList resolvedAttrs)))+  Right (RelationTuple resolvedAttrs (V.fromList newAtoms))+                           +-- | Validate that the type is provided with complete type variables for type constructors.+validateAtomType :: AtomType -> TypeConstructorMapping -> Either RelationalError ()+validateAtomType typ@(ConstructedAtomType tConsName tVarMap) tConss = do+  case findTypeConstructor tConsName tConss of +    Nothing -> Left (TypeConstructorAtomTypeMismatch tConsName typ)+    Just (tConsDef, _) -> case tConsDef of+      ADTypeConstructorDef _ tVarNames -> let expectedTyVarNames = S.fromList tVarNames+                                              actualTyVarNames = M.keysSet tVarMap+                                              diff = S.difference expectedTyVarNames actualTyVarNames in+                                          if not (S.null diff) then+                                            Left $ TypeConstructorTypeVarsMismatch expectedTyVarNames actualTyVarNames+                                          else+                                            Right ()+      _ -> Right ()                                            +validateAtomType _ _ = Right ()++validateTuple :: RelationTuple -> TypeConstructorMapping -> Either RelationalError ()+validateTuple (RelationTuple _ atoms) tConss = mapM_ (\a -> validateAtomType (atomTypeForAtom a) tConss) atoms++-- | Determine if two types are equal or compatible (including special handling for TypeVar x).+atomTypeVerify :: AtomType -> AtomType -> Either RelationalError AtomType+atomTypeVerify (TypeVariableType _) x = Right x+atomTypeVerify x (TypeVariableType _) = Right x+atomTypeVerify x@(ConstructedAtomType tConsNameA tVarMapA) (ConstructedAtomType tConsNameB tVarMapB) = +  if tConsNameA /= tConsNameB then+    Left (TypeConstructorNameMismatch tConsNameA tConsNameB)+  else if not (typeVarMapsVerify tVarMapA tVarMapB) then+         Left (TypeConstructorTypeVarsTypesMismatch tConsNameA tVarMapA tVarMapB)+       else+         Right x+atomTypeVerify x@(RelationAtomType attrs1) y@(RelationAtomType attrs2) = do+  _ <- mapM (\(attr1,attr2) -> let name1 = A.attributeName attr1+                                   name2 = A.attributeName attr2 in+                               if notElem "_" [name1, name2] && name1 /= name2 then +                                 Left $ AtomTypeMismatchError x y+                               else+                                 atomTypeVerify (A.atomType attr1) (A.atomType attr2)) $ V.toList (V.zip attrs1 attrs2)+  return x+atomTypeVerify x y = if x == y then+                       Right x+                     else+                       Left $ AtomTypeMismatchError x y++-- | Determine if two typeVar+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++prettyAtomType :: AtomType -> T.Text+prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"+prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))+  where+    showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"+-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)+prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?"+prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName+  where fullName = (T.pack . show) aType++prettyAttribute :: Attribute -> T.Text+prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)++resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap  +resolveTypeVariables expectedArgTypes actualArgTypes = do+  let tvmaps = map (uncurry resolveTypeVariable) (zip expectedArgTypes actualArgTypes)+  --if there are any new keys which don't have equal values then we have a conflict!+  foldM (\acc tvmap -> do+            let inter = M.intersectionWithKey (\tvName vala valb -> +                                                if vala /= valb then+                                                  Left (AtomFunctionTypeVariableMismatch tvName vala valb)+                                                else+                                                  Right vala) acc tvmap+                errs = lefts (M.elems inter)+            case errs of+              [] -> pure (M.unions tvmaps)+              errs' -> Left (someErrors errs')) M.empty tvmaps+  +resolveTypeVariable :: AtomType -> AtomType -> TypeVarMap+resolveTypeVariable (TypeVariableType tv) typ = M.singleton tv typ+resolveTypeVariable (ConstructedAtomType _ _) (ConstructedAtomType _ actualTvMap) = actualTvMap+resolveTypeVariable _ _ = M.empty++resolveFunctionReturnValue :: AtomFunctionName -> TypeVarMap -> AtomType -> Either RelationalError AtomType+resolveFunctionReturnValue funcName tvMap (ConstructedAtomType tCons retMap) = do+  let diff = M.difference retMap tvMap+  if M.null diff then+    pure (ConstructedAtomType tCons (M.intersection tvMap retMap))+    else+    Left (AtomFunctionTypeVariableResolutionError funcName (fst (head (M.toList diff))))+resolveFunctionReturnValue funcName tvMap (TypeVariableType tvName) = case M.lookup tvName tvMap of+  Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)+  Just typ -> pure typ+resolveFunctionReturnValue _ _ typ = pure typ
+ src/lib/ProjectM36/Atomable.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, DeriveGeneric, DeriveAnyClass #-}+module ProjectM36.Atomable where+--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data+--instances to marshal Haskell ADTs to ConstructedAtoms and back+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.DataTypes.Primitive+import ProjectM36.DataTypes.List+import GHC.Generics+import qualified Data.Map as M+import qualified Data.Text as T+import Control.DeepSeq (NFData)+import Data.Binary+import Control.Applicative+import Data.Time.Calendar+import Data.ByteString (ByteString)+import Data.Time.Clock++--also add haskell scripting atomable support+--rename this module to Atomable along with test++{-+data Test1T = Test1C Int+            deriving (Generic, Show, Eq, Binary, NFData, Atomable)+                     +data Test2T = Test2C Int Int                     +            deriving (Generic, Show, Eq, Binary, NFData, Atomable)+                     +data Test3T = Test3Ca | Test3Cb                     +            deriving (Generic, Show, Eq, Binary, NFData, Atomable)+-}+-- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values.+class (Eq a, NFData a, Binary a, Show a) => Atomable a where+  toAtom :: a -> Atom+  default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom+  toAtom v = toAtomG (from v) (toAtomTypeG (from v))+  +  fromAtom :: Atom -> a+  default fromAtom :: (Generic a, AtomableG (Rep a)) => Atom -> a+  fromAtom v@(ConstructedAtom _ _ args) = case fromAtomG v args of+    Nothing -> error "no fromAtomG traversal found"+    Just x -> to x+  fromAtom v = case fromAtomG v [] of+    Nothing -> error "no fromAtomG for Atom found"+    Just x -> to x+    +  toAtomType :: a -> AtomType+  default toAtomType :: (Generic a, AtomableG (Rep a)) => a -> AtomType+  toAtomType v = toAtomTypeG (from v)+                      +  -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.+  toDatabaseContextExpr :: a -> DatabaseContextExpr+  default toDatabaseContextExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr+  toDatabaseContextExpr v = toDatabaseContextExprG (from v) (toAtomType v)+  +instance Atomable Int where  +  toAtom i = IntAtom i+  fromAtom (IntAtom i) = i+  fromAtom e = error ("improper fromAtom" ++ show e)+  toAtomType _ = IntAtomType+  toDatabaseContextExpr _ = NoOperation++instance Atomable Double where+  toAtom d = DoubleAtom d+  fromAtom (DoubleAtom d) = d+  fromAtom _ = error "improper fromAtom"+  toAtomType _ = DoubleAtomType+  toDatabaseContextExpr _ = NoOperation++instance Atomable T.Text where+  toAtom t = TextAtom t+  fromAtom (TextAtom t) = t+  fromAtom _ = error "improper fromAtom"  +  toAtomType _ = TextAtomType+  toDatabaseContextExpr _ = NoOperation++instance Atomable Day where+  toAtom d = DayAtom d+  fromAtom (DayAtom d) = d+  fromAtom _ = error "improper fromAtom"+  toAtomType _ = DayAtomType+  toDatabaseContextExpr _ = NoOperation++instance Atomable UTCTime where+  toAtom t = DateTimeAtom t+  fromAtom (DateTimeAtom t) = t+  fromAtom _ = error "improper fromAtom"+  toAtomType _ = DateTimeAtomType+  toDatabaseContextExpr _ = NoOperation++instance Atomable ByteString where+  toAtom = ByteStringAtom+  fromAtom (ByteStringAtom b) = b+  fromAtom _ = error "improper fromAtom"+  toAtomType _ = ByteStringAtomType+  toDatabaseContextExpr _ = NoOperation++instance Atomable Bool where+  toAtom = BoolAtom+  fromAtom (BoolAtom b) = b+  fromAtom _ = error "improper fromAtom"+  toAtomType _ = BoolAtomType+  toDatabaseContextExpr _ = NoOperation++instance Atomable Relation where+  toAtom = RelationAtom+  fromAtom (RelationAtom r) = r+  fromAtom _ = error "improper fromAtom"+  --warning: cannot be used with undefined "Relation"+  toAtomType rel = RelationAtomType (attributes rel) +  toDatabaseContextExpr _ = NoOperation+  +--convert to ADT list  +instance Atomable a => Atomable [a] where+  toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (undefined :: a))) []+  toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType x)) (map toAtom (x:xs))+  +  fromAtom (ConstructedAtom "Empty" _ _) = []+  fromAtom (ConstructedAtom "Cons" _ (x:xs)) = fromAtom x:map fromAtom xs+  fromAtom _ = error "improper fromAtom [a]"+  +  toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (undefined :: a)))+  toDatabaseContextExpr _ = NoOperation++-- Generics+class AtomableG g where+  --type AtomTG g+  toAtomG :: g a -> AtomType -> Atom+  fromAtomG :: Atom -> [Atom] -> Maybe (g a)+  toAtomTypeG :: g a -> AtomType --overall ConstructedAtomType+  toAtomsG :: g a -> [Atom]+  toDatabaseContextExprG :: g a -> AtomType -> DatabaseContextExpr+  getConstructorsG :: g a -> [DataConstructorDef]+  getConstructorArgsG :: g a -> [DataConstructorDefArg]+  +--data type metadata+instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where  +  toAtomG (M1 v) t = toAtomG v t+  fromAtomG atom args = M1 <$> fromAtomG atom args+  toAtomsG = undefined+  toAtomTypeG _ = ConstructedAtomType (T.pack typeName) M.empty -- generics don't allow us to get the type constructor variables- alternatives?+    where+      typeName = datatypeName (undefined :: M1 D c a x)+  toDatabaseContextExprG (M1 v) (ConstructedAtomType tcName _) = AddTypeConstructor tcDef dataConstructors+    where+      tcDef = ADTypeConstructorDef tcName []+      dataConstructors = getConstructorsG v+  toDatabaseContextExprG _ _ = NoOperation      +  getConstructorsG (M1 v) = getConstructorsG v+  getConstructorArgsG = undefined+  +--constructor metadata+instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where+  --constructor name needed for Atom but not for atomType+  toAtomG (M1 v) t = ConstructedAtom (T.pack constructorName) t atoms+    where+      atoms = toAtomsG v+      constructorName = conName (undefined :: M1 C c a x)+  fromAtomG atom@(ConstructedAtom dConsName _ _) args = if dName == dConsName then+                                                      M1 <$> fromAtomG atom args+                                                   else+                                                     Nothing+    where+      dName = T.pack (conName (undefined :: M1 C c a x))+  fromAtomG _ _ = error "unsupported generic traversal"+  toAtomsG = undefined+  toAtomTypeG = undefined+  toDatabaseContextExprG = undefined  +  getConstructorsG (M1 v) = [DataConstructorDef (T.pack dName) dArgs]+    where+      dName = conName (undefined :: M1 C c a x)+      dArgs = getConstructorArgsG v+  getConstructorArgsG = undefined++--field metadata+instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where+  toAtomG = undefined+  fromAtomG atom args = M1 <$> fromAtomG atom args+  toAtomsG (M1 v) = toAtomsG v+  toAtomTypeG (M1 v) = toAtomTypeG v+  toDatabaseContextExprG _ _ = undefined  +  getConstructorsG = undefined+  getConstructorArgsG (M1 v) = getConstructorArgsG v++-- field data metadata+instance (Atomable a) => AtomableG (K1 c a) where+  toAtomG (K1 v) _ = toAtom v+  fromAtomG _ args = K1 <$> Just (fromAtom (headatom args))+                     where headatom (x:_) = x+                           headatom [] = error "no more atoms for constructor!"+  toAtomsG (K1 v) = [toAtom v]+  toAtomTypeG _ = toAtomType (undefined :: a)+  toDatabaseContextExprG _ _ = undefined    +  getConstructorsG = undefined+  getConstructorArgsG (K1 v) = [DataConstructorDefTypeConstructorArg tCons]+    where+      tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType+      primitiveAType = toAtomType v+      primitiveATypeName = case foldr (\((PrimitiveTypeConstructorDef name typ), _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping of+        Just x -> x+        Nothing -> error ("primitive type missing: " ++ show primitiveAType)+        +instance AtomableG U1 where+  toAtomG = undefined+  fromAtomG _ _ = pure U1+  toAtomsG _ = []+  toAtomTypeG = undefined+  toDatabaseContextExprG = undefined+  getConstructorsG = undefined+  getConstructorArgsG _ = []+  +-- product types+instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where+  toAtomG = undefined+  fromAtomG atom args = (:*:) <$> (fromAtomG atom [headatom args]) <*> (fromAtomG atom (tailatoms args))+    where headatom (x:_) = x+          headatom [] = error "no more atoms in head for product!"+          tailatoms (_:xs) = xs+          tailatoms [] = error "no more atoms in tail for product!"+  toAtomTypeG = undefined+  toAtomsG (x :*: y) = toAtomsG x ++ toAtomsG y+  toDatabaseContextExprG _ _ = undefined    +  getConstructorsG = undefined+  getConstructorArgsG (x :*: y) = getConstructorArgsG x ++ getConstructorArgsG y++-- sum types+instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where+  toAtomG (L1 x) = toAtomG x+  toAtomG (R1 x) = toAtomG x+  fromAtomG atom args = (L1 <$> fromAtomG atom args) <|> (R1 <$> fromAtomG atom args)+  toAtomTypeG = undefined+  toAtomsG (L1 x) = toAtomsG x+  toAtomsG (R1 x) = toAtomsG x+  toDatabaseContextExprG _ _ = undefined+  getConstructorsG _ = getConstructorsG (undefined :: a x) ++ getConstructorsG (undefined :: b x)+  getConstructorArgsG = undefined  +  +--this represents the unimplemented generics traversals which should never be called+{-+missingError :: a+missingError = error "missing generics traversal"+-}+
+ src/lib/ProjectM36/Attribute.hs view
@@ -0,0 +1,142 @@+module ProjectM36.Attribute where+import ProjectM36.Base+import ProjectM36.Error+import qualified Data.Set as S+import qualified Data.List as L+import qualified Data.Vector as V+import qualified Data.Hashable as Hash+import qualified Data.HashSet as HS+import qualified Data.Map as M++arity :: Attributes -> Int+arity = V.length++emptyAttributes :: Attributes+emptyAttributes = V.empty++null :: Attributes -> Bool+null = V.null++attributesFromList :: [Attribute] -> Attributes+attributesFromList = V.fromList -- . L.nub --too expensive++attributeName :: Attribute -> AttributeName+attributeName (Attribute name _) = name++atomType :: Attribute -> AtomType+atomType (Attribute _ atype) = atype++atomTypes :: Attributes -> V.Vector AtomType+atomTypes attrs = V.map atomType attrs++--hm- no error-checking here+addAttribute :: Attribute -> Attributes -> Attributes+addAttribute attr attrs = attrs `V.snoc` attr++--if some attribute names overlap but the types do not, then spit back an error+joinAttributes :: Attributes -> Attributes -> Either RelationalError Attributes+joinAttributes attrs1 attrs2 = if V.length uniqueOverlappingAttributes /= V.length overlappingAttributes then+                                 Left (TupleAttributeTypeMismatchError overlappingAttributes)+                               else if V.length overlappingAttrsDifferentTypes > 0 then+                                      Left (TupleAttributeTypeMismatchError overlappingAttrsDifferentTypes)+                                    else+                                      Right $ vectorUniqueify (attrs1 V.++ attrs2)+  where+    overlappingAttrsDifferentTypes = V.filter (\attr -> V.elem (attributeName attr) attrNames2 && V.notElem attr attrs2) attrs1+    attrNames2 = V.map attributeName attrs2+    uniqueOverlappingAttributes = vectorUniqueify overlappingAttributes+    overlappingAttributes = V.filter (\attr -> V.elem attr attrs2) attrs1++addAttributes :: Attributes -> Attributes -> Attributes+addAttributes = (V.++)++deleteAttributeName :: AttributeName -> Attributes -> Attributes+deleteAttributeName attrName = V.filter (\attr -> attributeName attr /= attrName)++renameAttribute :: AttributeName -> Attribute -> Attribute+renameAttribute newAttrName (Attribute _ typeo) = Attribute newAttrName typeo++renameAttributes :: AttributeName -> AttributeName -> Attributes -> Attributes+renameAttributes oldAttrName newAttrName attrs = V.map renamer attrs+  where+    renamer attr = if attributeName attr == oldAttrName then+                     renameAttribute newAttrName attr+                   else+                     attr++atomTypeForAttributeName :: AttributeName -> Attributes -> Either RelationalError AtomType+atomTypeForAttributeName attrName attrs = do+  (Attribute _ atype) <- attributeForName attrName attrs+  return atype++attributeForName :: AttributeName -> Attributes -> Either RelationalError Attribute+attributeForName attrName attrs = case V.find (\attr -> attributeName attr == attrName) attrs of+  Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName)+  Just attr -> Right attr++attributesForNames :: S.Set AttributeName -> Attributes -> Attributes+attributesForNames attrNameSet attrs = V.filter filt attrs+  where+    filt attr = S.member (attributeName attr) attrNameSet++attributeNameSet :: Attributes -> S.Set AttributeName+attributeNameSet attrVec = S.fromList $ V.toList $ V.map (\(Attribute name _) -> name) attrVec++attributeNames :: Attributes -> V.Vector AttributeName+attributeNames = V.map attributeName++--checks if set s1 is wholly contained in the set s2+attributesContained :: Attributes -> Attributes -> Bool+attributesContained attrs1 attrs2 = attributeNamesContained (attributeNameSet attrs1) (attributeNameSet attrs2)++attributeNamesContained :: S.Set AttributeName -> S.Set AttributeName -> Bool+attributeNamesContained attrs1 attrs2 = S.isSubsetOf attrs1 attrs2++--returns the disjunction of the AttributeNameSets+nonMatchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName+nonMatchingAttributeNameSet a1 a2 = S.difference (S.union a1 a2) (S.intersection a1 a2)++matchingAttributeNameSet :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName+matchingAttributeNameSet = S.intersection++attributeNamesNotContained :: S.Set AttributeName -> S.Set AttributeName -> S.Set AttributeName+attributeNamesNotContained subset superset = S.filter (flip S.notMember superset) subset++-- this is sorted so the tuples know in which order to output- the ordering is arbitrary+sortedAttributeNameList :: S.Set AttributeName -> [AttributeName]+sortedAttributeNameList attrNameSet= L.sort $ S.toList attrNameSet++-- take two attribute sets and return an attribute set with the attributes which do not match+attributesDifference :: Attributes -> Attributes -> Attributes+attributesDifference attrsA attrsB = V.fromList $ diff (V.toList attrsA) (V.toList attrsB)+  where+    diff a b = (a L.\\ b)  ++ (b L.\\ a)++vectorUniqueify :: (Hash.Hashable a, Eq a) => V.Vector a -> V.Vector a+vectorUniqueify vecIn = V.fromList $ HS.toList $ HS.fromList $ V.toList vecIn++--check that each attribute only appears once+verifyAttributes :: Attributes -> Either RelationalError Attributes+verifyAttributes attrs = if collapsedAttrs /= attrs then+                           Left (TupleAttributeTypeMismatchError (attributesDifference collapsedAttrs attrs))+                         else+                           Right attrs+  where+    collapsedAttrs = vectorUniqueify attrs++attributesEqual :: Attributes -> Attributes -> Bool+attributesEqual attrs1 attrs2 = V.null (attributesDifference attrs1 attrs2)++attributesAsMap :: Attributes -> M.Map AttributeName Attribute+attributesAsMap attrs = (M.fromList . V.toList) (V.map (\attr -> (attributeName attr, attr)) attrs)++-- | Left-biased union of attributes.+union :: Attributes -> Attributes -> Attributes+union attrsA attrsB = V.fromList (M.elems unioned)+  where+    unioned = M.union (attributesAsMap attrsA) (attributesAsMap attrsB)+                      +intersection :: Attributes -> Attributes -> Attributes+intersection attrsA attrsB = V.fromList (M.elems intersected)+  where+    intersected = M.intersection (attributesAsMap attrsA) (attributesAsMap attrsB)
+ src/lib/ProjectM36/AttributeNames.hs view
@@ -0,0 +1,38 @@+module ProjectM36.AttributeNames where+import qualified ProjectM36.Attribute as A+import ProjectM36.Base+import ProjectM36.Error+import qualified Data.Set as S+--AttributeNames is a data structure which can represent inverted projection attributes++empty :: AttributeNames+empty = AttributeNames S.empty++all :: AttributeNames+all = InvertedAttributeNames S.empty++--check that the attribute names are actually in the attributes+projectionAttributesForAttributeNames :: Attributes -> AttributeNames -> Either RelationalError Attributes+projectionAttributesForAttributeNames attrs (AttributeNames attrNameSet) = do+  let nonExistentAttributeNames = A.attributeNamesNotContained attrNameSet (A.attributeNameSet attrs)+  if not $ S.null nonExistentAttributeNames then+    Left $ AttributeNamesMismatchError nonExistentAttributeNames+    else+      return $ A.attributesForNames attrNameSet attrs+projectionAttributesForAttributeNames attrs (InvertedAttributeNames unselectedAttrNameSet) = do+  let nonExistentAttributeNames = A.attributeNamesNotContained unselectedAttrNameSet (A.attributeNameSet attrs)+  if not $ S.null nonExistentAttributeNames then+    Left $ AttributeNamesMismatchError nonExistentAttributeNames+    else+      return $ A.attributesForNames (A.nonMatchingAttributeNameSet unselectedAttrNameSet (A.attributeNameSet attrs)) attrs      +projectionAttributesForAttributeNames attrs (UnionAttributeNames namesA namesB) = do+  attrsA <- projectionAttributesForAttributeNames attrs namesA+  attrsB <- projectionAttributesForAttributeNames attrs namesB+  pure (A.union attrsA attrsB)+projectionAttributesForAttributeNames attrs (IntersectAttributeNames namesA namesB) = A.intersection <$> projectionAttributesForAttributeNames attrs namesA <*> projectionAttributesForAttributeNames attrs namesB  +      +invertAttributeNames :: AttributeNames -> AttributeNames+invertAttributeNames (AttributeNames names) = InvertedAttributeNames names+invertAttributeNames (InvertedAttributeNames names) = AttributeNames names+invertAttributeNames (UnionAttributeNames namesA namesB) = IntersectAttributeNames (invertAttributeNames namesA) (invertAttributeNames namesB)+invertAttributeNames (IntersectAttributeNames namesA namesB) = UnionAttributeNames (invertAttributeNames namesA) (invertAttributeNames namesB)
+ src/lib/ProjectM36/Base.hs view
@@ -0,0 +1,514 @@+{-# LANGUAGE ExistentialQuantification,BangPatterns,DeriveGeneric,DeriveAnyClass, TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Base where+import ProjectM36.DatabaseContextFunctionError+import ProjectM36.AtomFunctionError++import qualified Data.Map as M+import qualified Data.HashSet as HS+import Data.Hashable (Hashable, hashWithSalt)+import qualified Data.Set as S+import Data.UUID (UUID)+import Control.DeepSeq (NFData, rnf)+import Control.DeepSeq.Generics (genericRnf)+import GHC.Generics (Generic)+import qualified Data.Vector as V+import qualified Data.List as L+import Data.Text (Text,unpack)+import Data.Binary+import Data.Vector.Binary()+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Time.Calendar (Day,toGregorian,fromGregorian)+import Data.Hashable.Time ()+import Data.Typeable+import Data.ByteString (ByteString)++type StringType = Text+  +-- | Database atoms are the smallest, undecomposable units of a tuple. Common examples are integers, text, or unique identity keys.+data Atom = IntAtom Int |+            DoubleAtom Double |+            TextAtom Text |+            DayAtom Day |+            DateTimeAtom UTCTime |+            ByteStringAtom ByteString |+            BoolAtom Bool |+            RelationAtom Relation |+            ConstructedAtom DataConstructorName AtomType [Atom]+            deriving (Eq, Show, Binary, Typeable, NFData, Generic)+                     +instance Hashable Atom where                     +  hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms+                                                          `hashWithSalt` dConsName --AtomType is not hashable+  hashWithSalt salt (IntAtom i) = salt `hashWithSalt` i+  hashWithSalt salt (DoubleAtom d) = salt `hashWithSalt` d+  hashWithSalt salt (TextAtom t) = salt `hashWithSalt` t+  hashWithSalt salt (DayAtom d) = salt `hashWithSalt` d+  hashWithSalt salt (DateTimeAtom dt) = salt `hashWithSalt` dt+  hashWithSalt salt (ByteStringAtom bs) = salt `hashWithSalt` bs+  hashWithSalt salt (BoolAtom b) = salt `hashWithSalt` b+  hashWithSalt salt (RelationAtom r) = salt `hashWithSalt` r++instance Binary UTCTime where+  put utc = put $ toRational (utcTimeToPOSIXSeconds utc)+  get = do +    r <- get :: Get Rational+    return (posixSecondsToUTCTime (fromRational r))+    +instance Binary Day where    +  put day = put $ toGregorian day+  get = do+    (y,m,d) <- get :: Get (Integer, Int, Int)+    return (fromGregorian y m d)++-- I suspect the definition of ConstructedAtomType with its name alone is insufficient to disambiguate the cases; for example, one could create a type named X, remove a type named X, and re-add it using different constructors. However, as long as requests are served from only one DatabaseContext at-a-time, the type name is unambiguous. This will become a problem for time-travel, however.+-- | The AtomType uniquely identifies the type of a atom.+data AtomType = IntAtomType |                +                DoubleAtomType |+                TextAtomType |+                DayAtomType |+                DateTimeAtomType |+                ByteStringAtomType |+                BoolAtomType |+                RelationAtomType Attributes |+                ConstructedAtomType TypeConstructorName TypeVarMap |+                TypeVariableType TypeVarName+                --wildcard used in Atom Functions and tuples for data constructors which don't provide all arguments to the type constructor+              deriving (Eq, NFData, Generic, Binary, Show)+                       +type TypeVarMap = M.Map TypeVarName AtomType++instance Hashable TypeVarMap where +  hashWithSalt salt tvmap = hashWithSalt salt (M.keys tvmap)+                       +-- | Return True iff the atom type argument is relation-valued. If True, this indicates that the Atom contains a relation.+isRelationAtomType :: AtomType -> Bool+isRelationAtomType (RelationAtomType _) = True+isRelationAtomType _ = False++-- | The AttributeName is the name of an attribute in a relation.+type AttributeName = StringType++-- | A relation's type is composed of attribute names and types.+data Attribute = Attribute AttributeName AtomType deriving (Eq, Show, Generic, NFData, Binary)++instance Hashable Attribute where+  hashWithSalt salt (Attribute attrName _) = hashWithSalt salt attrName++-- | 'Attributes' represent the head of a relation.+type Attributes = V.Vector Attribute++-- | Equality function for a set of attributes.+attributesEqual :: Attributes -> Attributes -> Bool+attributesEqual attrs1 attrs2 = attrsAsSet attrs1 == attrsAsSet attrs2+  where+    attrsAsSet = HS.fromList . V.toList+    +sortedAttributesIndices :: Attributes -> [(Int, Attribute)]    +sortedAttributesIndices attrs = L.sortBy (\(_, (Attribute name1 _)) (_,(Attribute name2 _)) -> compare name1 name2) $ V.toList (V.indexed attrs)++-- | The relation's tuple set is the body of the relation.+newtype RelationTupleSet = RelationTupleSet { asList :: [RelationTuple] } deriving (Hashable, Show, Generic, Binary)++instance Read Relation where+  readsPrec = error "relation read not supported"++instance Eq RelationTupleSet where+ set1 == set2 = hset set1 == hset set2+   where+     hset = HS.fromList . asList++instance NFData RelationTupleSet where rnf = genericRnf++--the same hash must be generated for equal tuples so that the hashset equality works+instance Hashable RelationTuple where+  --sanity check the tuple for attribute and tuple counts+  --this bit me when tuples were being hashed before being verified+  hashWithSalt salt (RelationTuple attrs tupVec) = if V.length attrs /= V.length tupVec then+                                                     error "invalid tuple: attributes and tuple count mismatch"+                                                   else+                                                     salt `hashWithSalt` +                                                     sortedAttrs `hashWithSalt`+                                                     (V.toList sortedTupVec)+    where+      sortedAttrsIndices = sortedAttributesIndices attrs+      sortedAttrs = map snd sortedAttrsIndices+      sortedTupVec = V.map (\(index, _) -> tupVec V.! index) $ V.fromList sortedAttrsIndices+  +-- | A tuple is a set of attributes mapped to their 'Atom' values.+data RelationTuple = RelationTuple Attributes (V.Vector Atom) deriving (Show, Generic)++instance Binary RelationTuple++instance Eq RelationTuple where+  (==) tuple1@(RelationTuple attrs1 _) tuple2@(RelationTuple attrs2 _) = attributesEqual attrs1 attrs2 && atomsEqual+    where+    atomForAttribute attr (RelationTuple attrs tupVec) = case V.findIndex (== attr) attrs of+      Nothing -> Nothing+      Just index -> tupVec V.!? index+    atomsEqual = V.all (== True) $ V.map (\attr -> atomForAttribute attr tuple1 == atomForAttribute attr tuple2) attrs1++instance NFData RelationTuple where rnf = genericRnf++data Relation = Relation Attributes RelationTupleSet deriving (Show, Generic,Typeable)++instance Eq Relation where+  Relation attrs1 tupSet1 == Relation attrs2 tupSet2 = attributesEqual attrs1 attrs2 && tupSet1 == tupSet2++instance NFData Relation where rnf = genericRnf+                               +instance Hashable Relation where                               +  hashWithSalt salt (Relation attrs tupSet) = salt `hashWithSalt` +                                              sortedAttrs `hashWithSalt`+                                              asList tupSet+    where+      sortedAttrs = map snd (sortedAttributesIndices attrs)+      +instance Binary Relation      +  +-- | Used to represent the number of tuples in a relation.         +data RelationCardinality = Countable | Finite Int deriving (Eq, Show, Generic, Ord)++-- | Relation variables are identified by their names.+type RelVarName = StringType++type RelationalExpr = RelationalExprBase ()++-- | 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] |+  --- | Create and reference a relation from attributes and a tuple set.+  MakeStaticRelation Attributes RelationTupleSet |+  --- | Reference an existing relation in Haskell-space.+  ExistingRelation Relation |+  --MakeFunctionalRelation (creates a relation from a tuple-generating function, potentially infinite)+  --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 |+  --- | Create a projection over attribute names. (Note that the 'AttributeNames' structure allows for the names to be inverted.)+  Project AttributeNames (RelationalExprBase a) |+  --- | Create a union of two relational expressions. The expressions should have identical attributes.+  Union (RelationalExprBase a) (RelationalExprBase a) |+  --- | Create a join of two relational expressions. The join occurs on attributes which are identical. If the expressions have no overlapping attributes, the join becomes a cross-product of both tuple sets.+  Join (RelationalExprBase a) (RelationalExprBase a)  |+  --- | Rename an attribute (first argument) to another (second argument).+  Rename AttributeName AttributeName (RelationalExprBase a) |+  --- | Return a relation containing all tuples of the first argument which do not appear in the second argument (minus).+  Difference (RelationalExprBase a) (RelationalExprBase a) |+  --- | Create a sub-relation composed of the first argument's attributes which will become an attribute of the result expression. The unreferenced attributes are not altered in the result but duplicate tuples in the projection of the expression minus the attribute names are compressed into one. For more information, <https://github.com/agentm/project-m36/blob/master/docs/introduction_to_the_relational_algebra.markdown#group read the relational algebra tutorial.>+  Group AttributeNames AttributeName (RelationalExprBase a) |+  --- | Create an expression to unwrap a sub-relation contained within at an attribute's name. Note that this is not always an inverse of a group operation.+  Ungroup AttributeName (RelationalExprBase a) |+  --- | Filter the tuples of the relational expression to only retain the tuples which evaluate against the restriction predicate to true.+  Restrict (RestrictionPredicateExprBase a) (RelationalExprBase a) |+  --- | Returns the true relation iff +  Equals (RelationalExprBase a) (RelationalExprBase a) |+  NotEquals (RelationalExprBase a) (RelationalExprBase a) |+  Extend (ExtendTupleExprBase a) (RelationalExprBase a)+  --Summarize :: AtomExpr -> AttributeName -> RelationalExpr -> RelationalExpr -> RelationalExpr -- a special case of Extend+  deriving (Show, Eq, Generic, NFData)+           +instance Binary RelationalExpr+           +type NotificationName = StringType+type Notifications = M.Map NotificationName Notification++-- | When the changeExpr returns a different result in the database context, then the reportExpr is triggered and sent asynchronously to all clients.+data Notification = Notification {+  changeExpr :: RelationalExpr,+  reportExpr :: RelationalExpr+  }+  deriving (Show, Eq, Binary, Generic, NFData)++type TypeVarName = StringType+  +-- | Metadata definition for type constructors such as @data Either a b@.+data TypeConstructorDef = ADTypeConstructorDef TypeConstructorName [TypeVarName] |+                          PrimitiveTypeConstructorDef TypeConstructorName AtomType+                        deriving (Show, Generic, Binary, Eq, NFData)+                                 +-- | Found in data constructors and type declarations: Left (Either Int Text) | Right Int+data TypeConstructor = ADTypeConstructor TypeConstructorName [TypeConstructor] |+                       PrimitiveTypeConstructor TypeConstructorName AtomType |+                       TypeVariable TypeVarName+                     deriving (Show, Generic, Binary, Eq, NFData)+            +type TypeConstructorMapping = [(TypeConstructorDef, DataConstructorDefs)]++type TypeConstructorName = StringType+type TypeConstructorArgName = StringType+type DataConstructorName = StringType+type AtomTypeName = StringType++-- | Used to define a data constructor in a type constructor context such as @Left a | Right b@+data DataConstructorDef = DataConstructorDef DataConstructorName [DataConstructorDefArg] deriving (Eq, Show, Binary, Generic, NFData)++type DataConstructorDefs = [DataConstructorDef]++data DataConstructorDefArg = DataConstructorDefTypeConstructorArg TypeConstructor | +                             DataConstructorDefTypeVarNameArg TypeVarName+                           deriving (Show, Generic, Binary, Eq, NFData)+                                    +type InclusionDependencies = M.Map IncDepName InclusionDependency+type RelationVariables = M.Map RelVarName Relation++type SchemaName = StringType                         ++type Subschemas = M.Map SchemaName Schema++-- | Every transaction has one concrete database context and any number of isomorphic subschemas.+data Schemas = Schemas DatabaseContext Subschemas++-- | The DatabaseContext is a snapshot of a database's evolving state and contains everything a database client can change over time.+-- I spent some time thinking about whether the VirtualDatabaseContext/Schema and DatabaseContext data constructors should be the same constructor, but that would allow relation variables to be created in a "virtual" context which would appear to defeat the isomorphisms of the contexts. It should be possible to switch to an alternative schema to view the same equivalent information without information loss. However, allowing all contexts to reference another context while maintaining its own relation variables, new types, etc. could be interesting from a security perspective. For example, if a user creates a new relvar in a virtual context, then does it necessarily appear in all linked contexts? After deliberation, I think the relvar should appear in *all* linked contexts to retain the isomorphic properties, even when the isomorphism is for a subset of the context. This hints that the IsoMorphs should allow for "fall-through"; that is, when a relvar is not defined in the virtual context (for morphing), then the lookup should fall through to the underlying context.+data Schema = Schema SchemaIsomorphs+              deriving (Generic, Binary)+                              +data SchemaIsomorph = IsoRestrict RelVarName RestrictionPredicateExpr (RelVarName, RelVarName) | +                      IsoRename RelVarName RelVarName |+                      IsoUnion (RelVarName, RelVarName) RestrictionPredicateExpr RelVarName  --maps two relvars to one relvar+                      -- IsoTypeConstructor in morphAttrExpr+                      deriving (Generic, Binary, Show)+                      +type SchemaIsomorphs = [SchemaIsomorph]+                              +data DatabaseContext = DatabaseContext {+  inclusionDependencies :: InclusionDependencies,+  relationVariables :: RelationVariables,+  atomFunctions :: AtomFunctions,+  dbcFunctions :: DatabaseContextFunctions,+  notifications :: Notifications,+  typeConstructorMapping :: TypeConstructorMapping+  } deriving (NFData, Generic)+             +type IncDepName = StringType             ++-- | Inclusion dependencies represent every possible database constraint. Constraints enforce specific, arbitrarily-complex rules to which the database context's relation variables must adhere unconditionally.+data InclusionDependency = InclusionDependency RelationalExpr RelationalExpr deriving (Show, Eq, Generic, NFData)++instance Binary InclusionDependency++type AttributeNameAtomExprMap = M.Map AttributeName AtomExpr++--used for returning information about individual expressions+type DatabaseContextExprName = StringType++-- | Database context expressions modify the database context.+data DatabaseContextExpr = +  NoOperation |+  Define RelVarName [AttributeExpr] |+  Undefine RelVarName | --forget existence of relvar X+  Assign RelVarName RelationalExpr |+  Insert RelVarName RelationalExpr |+  Delete RelVarName RestrictionPredicateExpr  |+  Update RelVarName AttributeNameAtomExprMap RestrictionPredicateExpr |+  +  AddInclusionDependency IncDepName InclusionDependency |+  RemoveInclusionDependency IncDepName |+  +  AddNotification NotificationName RelationalExpr RelationalExpr |+  RemoveNotification NotificationName |++  AddTypeConstructor TypeConstructorDef [DataConstructorDef] |+  RemoveTypeConstructor TypeConstructorName |++  --adding an AtomFunction is not a pure operation (required loading GHC modules)+  RemoveAtomFunction AtomFunctionName |+  +  RemoveDatabaseContextFunction DatabaseContextFunctionName |+  +  ExecuteDatabaseContextFunction DatabaseContextFunctionName [AtomExpr] |+  +  MultipleExpr [DatabaseContextExpr]+  deriving (Show, Eq, Binary, Generic)++-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.+data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |+                             AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript+                           deriving (Show, Eq, Generic, Binary)+++type RestrictionPredicateExpr = RestrictionPredicateExprBase ()++-- | Restriction predicates are boolean algebra components which, when composed, indicate whether or not a tuple should be retained during a restriction (filtering) operation.+data RestrictionPredicateExprBase a =+  TruePredicate |+  AndPredicate (RestrictionPredicateExprBase a) (RestrictionPredicateExprBase a) |+  OrPredicate (RestrictionPredicateExprBase a) (RestrictionPredicateExprBase a) |+  NotPredicate (RestrictionPredicateExprBase a)  |+  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)++instance Binary RestrictionPredicateExpr++-- child + parent links+-- | A transaction graph's head name references the leaves of the transaction graph and can be used during session creation to indicate at which point in the graph commits should persist.+type HeadName = StringType++type TransactionHeads = M.Map HeadName Transaction++-- | 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++-- | Every transaction has context-specific information attached to it.+data TransactionInfo = TransactionInfo TransactionId (S.Set TransactionId) | -- 1 parent + n children+                       MergeTransactionInfo TransactionId TransactionId (S.Set TransactionId) -- 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.+type TransactionId = UUID++data Transaction = Transaction TransactionId TransactionInfo Schemas+                            +--instance Binary Transaction+                            +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+                            +transactionId :: Transaction -> TransactionId+transactionId (Transaction tid _ _) = tid++transactionInfo :: Transaction -> TransactionInfo+transactionInfo (Transaction _ info _) = info++instance Eq Transaction where                            +  (Transaction uuidA _ _) == (Transaction uuidB _ _) = uuidA == uuidB+                   +instance Ord Transaction where                            +  compare (Transaction uuidA _ _) (Transaction uuidB _ _) = compare uuidA uuidB++type AtomExpr = AtomExprBase ()++-- | 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)+                       +instance Binary AtomExpr                       ++-- | Used in tuple creation when creating a relation.+data ExtendTupleExprBase a = AttributeExtendTupleExpr AttributeName (AtomExprBase a)+                     deriving (Show, Eq, Generic, NFData)+                              +type ExtendTupleExpr = ExtendTupleExprBase ()                              ++instance Binary ExtendTupleExpr+           +--enumerates the list of functions available to be run as part of tuple expressions           +type AtomFunctions = HS.HashSet AtomFunction++type AtomFunctionName = StringType++type AtomFunctionBodyScript = StringType++type AtomFunctionBodyType = [Atom] -> Either AtomFunctionError Atom++data AtomFunctionBody = AtomFunctionBody (Maybe AtomFunctionBodyScript) AtomFunctionBodyType++instance NFData AtomFunctionBody where+  rnf (AtomFunctionBody mScript _) = rnf mScript+                        +instance Show AtomFunctionBody where+  show (AtomFunctionBody mScript _) = case mScript of+    Just script -> show (unpack script)+    Nothing -> "<compiled>"++-- | An AtomFunction has a name, a type, and a function body to execute when called.+data AtomFunction = AtomFunction {+  atomFuncName :: AtomFunctionName,+  atomFuncType :: [AtomType], +  atomFuncBody :: AtomFunctionBody+  } deriving (Generic, NFData)+                          +instance Hashable AtomFunction where+  hashWithSalt salt func = salt `hashWithSalt` (atomFuncName func)+                           +instance Eq AtomFunction where                           +  f1 == f2 = atomFuncName f1 == atomFuncName f2 +  +instance Show AtomFunction where  +  show aFunc = unpack (atomFuncName aFunc) ++ "::" ++ showArgTypes ++ "; " ++ body+   where+     body = show (atomFuncBody aFunc)+     showArgTypes = concat (L.intersperse "->" $ map show (atomFuncType aFunc))+     +-- | The 'AttributeNames' structure represents a set of attribute names or the same set of names but inverted in the context of a relational expression. For example, if a relational expression has attributes named "a", "b", and "c", the 'InvertedAttributeNames' of ("a","c") is ("b").+data AttributeNames = AttributeNames (S.Set AttributeName) |+                      InvertedAttributeNames (S.Set AttributeName) |+                      UnionAttributeNames AttributeNames AttributeNames |+                      IntersectAttributeNames AttributeNames AttributeNames+                      deriving (Eq, Show, Generic, Binary, NFData)+                                +-- | The persistence strategy is a global database option which represents how to persist the database in the filesystem, if at all.+data PersistenceStrategy = NoPersistence | -- ^ no filesystem persistence/memory-only database+                           MinimalPersistence FilePath | -- ^ fsync off, not crash-safe+                           CrashSafePersistence FilePath -- ^ full fsync to disk (flushes kernel and physical drive buffers to ensure that the transaction is on non-volatile storage)+                           deriving (Show, Read)+                                    +type AttributeExpr = AttributeExprBase ()++-- | Create attributes dynamically.+data AttributeExprBase a = AttributeAndTypeNameExpr AttributeName TypeConstructor a |+                           NakedAttributeExpr Attribute+                         deriving (Eq, Show, Generic, Binary, NFData)+                              +-- | Dynamically create a tuple from attribute names and 'AtomExpr's.+data TupleExprBase a = TupleExpr (M.Map AttributeName (AtomExprBase a))+                 deriving (Eq, Show, Generic, NFData)+                          +instance Binary TupleExpr                          +                          +type TupleExpr = TupleExprBase ()                           ++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 |+  -- | Similar to a union merge, but, on conflict, prefer the unmerged section (relvar, function, etc.) from the branch named as the argument.+  UnionPreferMergeStrategy HeadName |+  -- | Similar to the our/theirs merge strategy in git, the merge transaction's context is identical to that of the last transaction in the selected branch.+  SelectedBranchMergeStrategy HeadName+                     deriving (Eq, Show, Binary, Generic, NFData)++type DatabaseContextFunctionName = StringType++type DatabaseContextFunctionBodyScript = StringType++type DatabaseContextFunctionBodyType = [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext++data DatabaseContextFunctionBody = DatabaseContextFunctionBody (Maybe DatabaseContextFunctionBodyScript) DatabaseContextFunctionBodyType ++instance NFData DatabaseContextFunctionBody where+  rnf (DatabaseContextFunctionBody mScript _) = rnf mScript++data DatabaseContextFunction = DatabaseContextFunction {+  dbcFuncName :: DatabaseContextFunctionName,+  dbcFuncType :: [AtomType],+  dbcFuncBody :: DatabaseContextFunctionBody+  } deriving (Generic, NFData)+                               +type DatabaseContextFunctions = HS.HashSet DatabaseContextFunction++instance Hashable DatabaseContextFunction where+  hashWithSalt salt func = salt `hashWithSalt` (dbcFuncName func)+                           +instance Eq DatabaseContextFunction where                           +  f1 == f2 = dbcFuncName f1 == dbcFuncName f2
+ src/lib/ProjectM36/Client.hs view
@@ -0,0 +1,911 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, ScopedTypeVariables, BangPatterns #-}+{-|+Module: ProjectM36.Client++Client interface to local and remote Project:M36 databases. To get started, connect with 'connectProjectM36', then run some database changes with 'executeDatabaseContextExpr', and issue queries using 'executeRelationalExpr'.+-}+module ProjectM36.Client+       (ConnectionInfo(..),+       Connection(..),+       Port,+       Hostname,+       DatabaseName,+       ConnectionError(..),+       connectProjectM36,+       close,+       closeRemote_,+       executeRelationalExpr,+       executeDatabaseContextExpr,+       executeDatabaseContextIOExpr,       +       executeGraphExpr,+       executeSchemaExpr,+       executeTransGraphRelationalExpr,+       commit,+       rollback,+       typeForRelationalExpr,+       inclusionDependencies,+       planForDatabaseContextExpr,+       currentSchemaName,+       SchemaName,+       HeadName,+       setCurrentSchemaName,+       transactionGraphAsRelation,+       relationVariablesAsRelation,+       headName,+       remoteDBLookupName,+       defaultServerPort,+       headTransactionId,+       defaultDatabaseName,+       defaultRemoteConnectionInfo,+       defaultHeadName,+       PersistenceStrategy(..),+       RelationalExpr,+       RelationalExprBase(..),+       DatabaseContextExpr(..),+       DatabaseContextIOExpr(..),+       Attribute(..),+       attributesFromList,+       createNodeId,+       createSessionAtCommit,+       createSessionAtHead,+       closeSession,+       addClientNode,+       callTestTimeout_,+       RelationCardinality(..),+       TransactionGraphOperator(..),+       CommitOption(..),+       transactionGraph_,+       disconnectedTransaction_,+       TransGraphRelationalExpr,+       TransactionIdLookup(..),+       TransactionIdHeadBacktrack(..),+       NodeId(..),+       Atom(..),+       Session,+       SessionId,+       NotificationCallback,+       emptyNotificationCallback,+       EvaluatedNotification(..),+       atomTypesAsRelation,+       AttributeExpr,+       inclusionDependencyForKey,+       databaseContextExprForUniqueKey,+       databaseContextExprForForeignKey,+       createScriptedAtomFunction,+       AttributeExprBase(..),+       TypeConstructor(..),+       TypeConstructorDef(..),+       DataConstructorDef(..),+       AttributeNames(..),+       RelVarName,+       IncDepName,+       InclusionDependency(..),+       AttributeName,+       RequestTimeoutException(..),+       RemoteProcessDiedException(..),+       AtomType(..),+       Atomable(..),+       TupleExprBase(..),+       AtomExprBase(..),+       RestrictionPredicateExprBase(..)+       ) where+import ProjectM36.Base hiding (inclusionDependencies) --defined in this module as well+import qualified ProjectM36.Base as B+import ProjectM36.Error+import ProjectM36.Atomable+import ProjectM36.AtomFunction+import ProjectM36.StaticOptimizer+import ProjectM36.Key+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 ProjectM36.TransactionGraph+import qualified ProjectM36.Transaction as Trans+import ProjectM36.TransactionGraph.Persist+import ProjectM36.Attribute hiding (atomTypes)+import ProjectM36.TransGraphRelationalExpression (TransGraphRelationalExpr, evalTransGraphRelationalExpr)+import ProjectM36.Persist (DiskSync(..))+import ProjectM36.FileLock+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))+import Network.Transport.TCP (createTransport, defaultTCPParameters, encodeEndPointAddress)+import Control.Distributed.Process.Node (newLocalNode, initRemoteTable, runProcess, LocalNode, forkProcess, closeLocalNode)+import Control.Distributed.Process.Extras.Internal.Types (whereisRemote)+import Control.Distributed.Process.ManagedProcess.Client (call, safeCall)+import Control.Distributed.Process (NodeId(..), reconnect)++import Data.UUID.V4 (nextRandom)+import Data.Word+import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match)+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)+import qualified STMContainers.Map as STMMap+import qualified STMContainers.Set as STMSet+import qualified ProjectM36.Session as Sess+import ProjectM36.Session+import ProjectM36.Sessions+import ListT+import Data.Binary (Binary)+import GHC.Generics (Generic)+import Control.DeepSeq (force)+import System.IO++type Hostname = String++type Port = Word16++type DatabaseName = String++-- | The type for notifications callbacks in the client. When a registered notification fires due to a changed relational expression evaluation, the server propagates the notifications to the clients in the form of the callback.+type NotificationCallback = NotificationName -> EvaluatedNotification -> IO ()++-- | The empty notification callback ignores all callbacks.+emptyNotificationCallback :: NotificationCallback+emptyNotificationCallback _ _ = pure ()++type GhcPkgPath = String++data RemoteProcessDiedException = RemoteProcessDiedException+                                  deriving (Show, Eq)+                                           +instance Exception RemoteProcessDiedException                                          +  +data RequestTimeoutException = RequestTimeoutException+                             deriving (Show, Eq)++instance Exception RequestTimeoutException++-- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'. The database can be run within the current process or running remotely via distributed-process.+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath]|+                      RemoteProcessConnectionInfo DatabaseName NodeId NotificationCallback+                      +type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification++-- | Used for callbacks from the server when monitored changes have been made.+data NotificationMessage = NotificationMessage EvaluatedNotifications+                           deriving (Binary, Eq, Show, Generic)++-- | When a notification is fired, the 'reportExpr' is evaluated in the commit's context, so that is returned along with the original notification.+data EvaluatedNotification = EvaluatedNotification {+  notification :: Notification,+  reportRelation :: Either RelationalError Relation+  }+                           deriving(Binary, Eq, Show, Generic)+                      ++-- | Create a 'NodeId' for use in connecting to a remote server using distributed-process.+createNodeId :: Hostname -> Port -> NodeId                      +createNodeId host port = NodeId $ encodeEndPointAddress host (show port) 1+                      +-- | Use this for connecting to remote servers on the default port.+defaultServerPort :: Port+defaultServerPort = 6543++-- | Use this for connecting to remote servers with the default database name.+defaultDatabaseName :: DatabaseName+defaultDatabaseName = "base"++-- | Use this for connecting to remote servers with the default head name.+defaultHeadName :: HeadName+defaultHeadName = "master"++-- | Create a connection configuration which connects to the localhost on the default server port and default server database name. The configured notification callback is set to ignore all events.+defaultRemoteConnectionInfo :: ConnectionInfo+defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback ++-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.+type ClientNodes = STMSet.Set ProcessId++type TransactionGraphLockHandle = Handle+  +-- internal structure specific to in-process connections+data InProcessConnectionConf = InProcessConnectionConf {+  ipPersistenceStrategy :: PersistenceStrategy, +  ipClientNodes :: ClientNodes, +  ipSessions :: Sessions, +  ipTransactionGraph :: TVar TransactionGraph,+  ipScriptSession :: Maybe ScriptSession,+  ipLocalNode :: LocalNode,+  ipTransport :: Transport, -- we hold onto this so that we can close it gracefully+  ipLocks :: Maybe (TransactionGraphLockHandle, MVar LockFileHash) -- nothing when NoPersistence+  }++data RemoteProcessConnectionConf = RemoteProcessConnectionConf {+  rLocalNode :: LocalNode, +  rProcessId :: ProcessId, --remote processId+  rTransport :: Transport --the TCP socket transport+  }+  +data Connection = InProcessConnection InProcessConnectionConf |+                  RemoteProcessConnection RemoteProcessConnectionConf+                  +-- | There are several reasons why a connection can fail.+data ConnectionError = SetupDatabaseDirectoryError PersistenceError |+                       IOExceptionError IOException |+                       NoSuchDatabaseByNameError DatabaseName |+                       LoginError +                       deriving (Show, Eq, Generic)+                  +remoteDBLookupName :: DatabaseName -> String    +remoteDBLookupName = (++) "db-" ++createLocalNode :: IO (LocalNode, Transport)+createLocalNode = do+  eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters+  case eLocalTransport of+    Left err -> error ("failed to create transport: " ++ show err)+    Right localTransport -> do+      localNode <- newLocalNode localTransport initRemoteTable +      pure (localNode, localTransport)+    +notificationListener :: NotificationCallback -> Process ()    +notificationListener callback = do+  --pid <- getSelfPid+  --liftIO $ putStrLn $ "LISTENER THREAD START " ++ show pid+  _ <- forever $ do  +    receiveWait [+      match (\(NotificationMessage eNots) -> do+            --say $ "NOTIFICATION: " ++ show eNots+            -- when notifications are thrown, they are not adjusted for the current schema which could be problematic, but we don't have access to the current session here+            liftIO $ mapM_ (uncurry callback) (M.toList eNots)+            )+      ]+  --say "LISTENER THREAD EXIT"+  pure ()+  +startNotificationListener :: LocalNode -> NotificationCallback -> IO (ProcessId)+startNotificationListener localNode callback = forkProcess localNode (notificationListener callback)+  +createScriptSession :: [String] -> IO (Maybe ScriptSession)  +createScriptSession ghcPkgPaths = do+  eScriptSession <- initScriptSession ghcPkgPaths+  case eScriptSession of+    Left err -> hPutStrLn stderr ("Failed to load scripting engine- scripting disabled: " ++ (show err)) >> pure Nothing --not a fatal error, but the scripting feature must be disabled+    Right s -> pure (Just s)++-- | To create a 'Connection' to a remote or local database, create a 'ConnectionInfo' and call 'connectProjectM36'.+connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)+--create a new in-memory database/transaction graph+connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do+  freshId <- nextRandom+  let bootstrapContext = basicDatabaseContext +      freshGraph = bootstrapTransactionGraph freshId bootstrapContext+  case strat of+    --create date examples graph for now- probably should be empty context in the future+    NoPersistence -> do+        graphTvar <- newTVarIO freshGraph+        clientNodes <- STMSet.newIO+        sessions <- STMMap.newIO+        (localNode, transport) <- createLocalNode+        notificationPid <- startNotificationListener localNode notificationCallback+        mScriptSession <- createScriptSession ghcPkgPaths+        +        let conn = InProcessConnection (InProcessConnectionConf {+                                           ipPersistenceStrategy = strat, +                                           ipClientNodes = clientNodes, +                                           ipSessions = sessions, +                                           ipTransactionGraph = graphTvar, +                                           ipScriptSession = mScriptSession,+                                           ipLocalNode = localNode,+                                           ipTransport = transport, +                                           ipLocks = Nothing})+        addClientNode conn notificationPid+        pure (Right conn)+    MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths+    CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback ghcPkgPaths+        +connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notificationCallback) = do+  connStatus <- newEmptyMVar+  (localNode, transport) <- createLocalNode+  let dbName = remoteDBLookupName databaseName+  --putStrLn $ "Connecting to " ++ show serverNodeId ++ " " ++ dbName+  notificationListenerPid <- startNotificationListener localNode notificationCallback+  runProcess localNode $ do+    --even a failed connection retains an open socket!+    mServerProcessId <- whereisRemote serverNodeId dbName+    case mServerProcessId of+      Nothing -> liftIO $ putMVar connStatus $ Left (NoSuchDatabaseByNameError databaseName)+      Just serverProcessId -> do+        loginConfirmation <- safeLogin (Login notificationListenerPid) serverProcessId+        if not loginConfirmation then+          liftIO $ putMVar connStatus (Left LoginError)+          else do+          liftIO $ putMVar connStatus (Right $ RemoteProcessConnection (RemoteProcessConnectionConf {rLocalNode = localNode, rProcessId = serverProcessId, rTransport = transport}))+  status <- takeMVar connStatus+  pure status++connectPersistentProjectM36 :: PersistenceStrategy ->+                               DiskSync ->+                               FilePath -> +                               TransactionGraph ->+                               NotificationCallback ->+                               [GhcPkgPath] -> +                               IO (Either ConnectionError Connection)      +connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghcPkgPaths = do+  err <- setupDatabaseDir sync dbdir freshGraph +  case err of+    Left err' -> return $ Left (SetupDatabaseDirectoryError err')+    Right (lockFileH, digest) -> do+      mScriptSession <- createScriptSession ghcPkgPaths+      graph <- transactionGraphLoad dbdir emptyTransactionGraph mScriptSession+      case graph of+        Left err' -> return $ Left (SetupDatabaseDirectoryError err')+        Right graph' -> do+          tvarGraph <- newTVarIO graph'+          sessions <- STMMap.newIO+          clientNodes <- STMSet.newIO+          (localNode, transport) <- createLocalNode+          lockMVar <- newMVar digest+          let conn = InProcessConnection (InProcessConnectionConf {+                                             ipPersistenceStrategy = strat,+                                             ipClientNodes = clientNodes,+                                             ipSessions = sessions,+                                             ipTransactionGraph = tvarGraph,+                                             ipScriptSession = mScriptSession,+                                             ipLocalNode = localNode,+                                             ipTransport = transport,+                                             ipLocks = Just (lockFileH, lockMVar)+                                             })++          notificationPid <- startNotificationListener localNode notificationCallback +          addClientNode conn notificationPid+          pure (Right conn)+          +-- | Create a new session at the transaction id and return the session's Id.+createSessionAtCommit :: TransactionId -> Connection -> IO (Either RelationalError SessionId)+createSessionAtCommit commitId conn@(InProcessConnection _) = do+   newSessionId <- nextRandom+   atomically $ do+      createSessionAtCommit_ commitId newSessionId conn+createSessionAtCommit uuid conn@(RemoteProcessConnection _) = remoteCall conn (CreateSessionAtCommit uuid)++createSessionAtCommit_ :: TransactionId -> SessionId -> Connection -> STM (Either RelationalError SessionId)+createSessionAtCommit_ commitId newSessionId (InProcessConnection conf) = do+    let sessions = ipSessions conf+        graphTvar = ipTransactionGraph conf+    graph <- readTVar graphTvar+    case transactionForId commitId graph of+        Left err -> pure (Left err)+        Right transaction -> do+            let freshDiscon = DisconnectedTransaction commitId (Trans.schemas transaction) False+            keyDuplication <- STMMap.lookup newSessionId sessions+            case keyDuplication of+                Just _ -> pure $ Left (SessionIdInUseError newSessionId)+                Nothing -> do+                   STMMap.insert (Session freshDiscon defaultSchemaName) newSessionId sessions+                   pure $ Right newSessionId+createSessionAtCommit_ _ _ (RemoteProcessConnection _) = error "createSessionAtCommit_ called on remote connection"+  +-- | Call 'createSessionAtHead' with a transaction graph's head's name to create a new session pinned to that head. This function returns a 'SessionId' which can be used in other function calls to reference the point in the transaction graph.+createSessionAtHead :: HeadName -> Connection -> IO (Either RelationalError SessionId)+createSessionAtHead headn conn@(InProcessConnection conf) = do+    let graphTvar = ipTransactionGraph conf+    newSessionId <- nextRandom+    atomically $ do+        graph <- readTVar graphTvar+        case transactionForHead headn graph of+            Nothing -> pure $ Left (NoSuchHeadNameError headn)+            Just trans -> createSessionAtCommit_ (transactionId trans) newSessionId conn+createSessionAtHead headn conn@(RemoteProcessConnection _) = remoteCall conn (CreateSessionAtHead headn)++-- | Used internally for server connections to keep track of remote nodes for the purpose of sending notifications later.+addClientNode :: Connection -> ProcessId -> IO ()+addClientNode (RemoteProcessConnection _) _ = error "addClientNode called on remote connection"+addClientNode (InProcessConnection conf) newProcessId = atomically (STMSet.insert newProcessId (ipClientNodes conf))++-- | Discards a session, eliminating any uncommitted changes present in the session.+closeSession :: SessionId -> Connection -> IO ()+closeSession sessionId (InProcessConnection conf) = do+    atomically $ STMMap.delete sessionId (ipSessions conf)+closeSession sessionId conn@(RemoteProcessConnection _) = remoteCall conn (CloseSession sessionId)       +-- | 'close' cleans up the database access connection and closes any relevant sockets.+close :: Connection -> IO ()+close (InProcessConnection conf) = do+  atomically $ do+    let sessions = ipSessions conf+    STMMap.deleteAll sessions+    pure ()+  closeLocalNode (ipLocalNode conf)+  closeTransport (ipTransport conf)++close conn@(RemoteProcessConnection conf) = do+  _ <- (remoteCall conn Logout) :: IO Bool+  closeLocalNode (rLocalNode conf)+  closeTransport (rTransport conf)++--used only by the server EntryPoints+closeRemote_ :: Connection -> IO ()+closeRemote_ (InProcessConnection _) = error "invalid call of closeRemote_ on InProcessConnection"+closeRemote_ (RemoteProcessConnection conf) = runProcess (rLocalNode conf) (reconnect (rProcessId conf))++  --we need to actually close the localNode's connection to the remote+--within the database server, we must catch and handle all exception lest they take down the database process- this handling might be different for other use-cases+--exceptions should generally *NOT* be thrown from any Project:M36 code paths, but third-party code such as AtomFunction scripts could conceivably throw undefined, etc.++excMaybe :: IO (Maybe RelationalError) -> IO (Maybe RelationalError)+excMaybe m = handle handler m+  where+    handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc+                | otherwise = pure (Just (UnhandledExceptionError (show exc)))+                    +excEither :: IO (Either RelationalError a) -> IO (Either RelationalError a)+excEither m = handle handler m+  where+    handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc+                | otherwise = pure (Left (UnhandledExceptionError (show exc)))+      +runProcessResult :: LocalNode -> Process a -> IO a      +runProcessResult localNode proc = do+  ret <- newEmptyMVar+  runProcess localNode $ do+    val <- proc+    liftIO $ putMVar ret val+  takeMVar ret++safeLogin :: Login -> ProcessId -> Process (Bool)+safeLogin login procId = do +  ret <- call procId login+  case ret of+    Left (_ :: ServerError) -> pure False+    Right val -> pure val++remoteCall :: (Serializable a, Serializable b) => Connection -> a -> IO b+remoteCall (InProcessConnection _ ) _ = error "remoteCall called on local connection"+remoteCall (RemoteProcessConnection conf) arg = runProcessResult localNode $ do+  ret <- safeCall serverProcessId arg+  case ret of+    Left err -> error ("server died: " ++ show err)+    Right ret' -> case ret' of+                       Left RequestTimeoutError -> liftIO (throwIO RequestTimeoutException)+                       Left (ProcessDiedError _) -> liftIO (throwIO RemoteProcessDiedException)+                       Right val -> pure val+  where+    localNode = rLocalNode conf+    serverProcessId = rProcessId conf++sessionForSessionId :: SessionId -> Sessions -> STM (Either RelationalError Session)+sessionForSessionId sessionId sessions = do+  maybeSession <- STMMap.lookup sessionId sessions+  pure $ maybe (Left $ NoSuchSessionError sessionId) Right maybeSession+  +schemaForSessionId :: Session -> STM (Either RelationalError Schema)  +schemaForSessionId session = do+  let sname = schemaName session+  if sname == defaultSchemaName then+    pure (Right (Schema [])) -- the main schema includes no transformations (but neither do empty schemas :/ )+    else+    case M.lookup sname (subschemas session) of+      Nothing -> pure (Left (SubschemaNameNotInUseError sname))+      Just schema -> pure (Right schema)+  +sessionAndSchema :: SessionId -> Sessions -> STM (Either RelationalError (Session, Schema))+sessionAndSchema sessionId sessions = do+  eSession <- sessionForSessionId sessionId sessions+  case eSession of+    Left err -> pure (Left err)+    Right session -> do  +      eSchema <- schemaForSessionId session+      case eSchema of+        Left err -> pure (Left err)+        Right schema -> pure (Right (session, schema))+  +-- | Returns the name of the currently selected isomorphic schema.+currentSchemaName :: SessionId -> Connection -> IO (Maybe SchemaName)+currentSchemaName sessionId (InProcessConnection conf) = atomically $ do+  let sessions = ipSessions conf+  eSession <- sessionForSessionId sessionId sessions+  case eSession of+    Left _ -> pure Nothing+    Right session -> pure (Just (Sess.schemaName session))+currentSchemaName sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveCurrentSchemaName sessionId)++-- | Switch to the named isomorphic schema.+setCurrentSchemaName :: SessionId -> Connection -> SchemaName -> IO (Maybe RelationalError)+setCurrentSchemaName sessionId (InProcessConnection conf) sname = atomically $ do+  let sessions = ipSessions conf+  eSession <- sessionForSessionId sessionId sessions+  case eSession of+    Left _ -> pure Nothing+    Right session -> case Sess.setSchemaName sname session of+      Left err -> pure (Just err)+      Right newSession -> STMMap.insert newSession sessionId sessions >> pure Nothing+setCurrentSchemaName sessionId conn@(RemoteProcessConnection _) sname = remoteCall conn (ExecuteSetCurrentSchema sessionId sname)++-- | Execute a relational expression in the context of the session and connection. Relational expressions are queries and therefore cannot alter the database.+executeRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)+executeRelationalExpr sessionId (InProcessConnection conf) expr = excEither $ atomically $ do+  let sessions = ipSessions conf+  eSession <- sessionAndSchema sessionId sessions+  case eSession of+    Left err -> pure $ Left err+    Right (session, schema) -> do+      let expr' = if schemaName session /= defaultSchemaName then+                    Schema.processRelationalExprInSchema schema expr+                  else+                    Right expr+      case expr' of+        Left err -> pure (Left err)+        Right expr'' -> case runReader (RE.evalRelationalExpr expr'') (RE.mkRelationalExprState (Sess.concreteDatabaseContext session)) of+          Left err -> pure (Left err)+          Right rel -> pure (force (Right rel)) -- this is necessary so that any undefined/error exceptions are spit out here +executeRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteRelationalExpr sessionId relExpr)++-- | Execute a database context expression in the context of the session and connection. Database expressions modify the current session's disconnected transaction but cannot modify the transaction graph.+executeDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Maybe RelationalError)+executeDatabaseContextExpr sessionId (InProcessConnection conf) expr = excMaybe $ atomically $ do+  let sessions = ipSessions conf+  eSession <- sessionAndSchema sessionId sessions+  case eSession of+    Left err -> pure $ Just err+    Right (session, schema) -> do+      let expr' = if schemaName session == defaultSchemaName then+                    Right expr+                  else+                    Schema.processDatabaseContextExprInSchema schema expr+      case expr' of +        Left err -> pure (Just err)+        Right expr'' -> case runState (RE.evalDatabaseContextExpr expr'') (RE.freshDatabaseState (Sess.concreteDatabaseContext session)) of+          (Just err,_) -> return $ Just err+          (Nothing, (_,_,False)) -> pure Nothing --optimization- if nothing was dirtied, nothing to do+          (Nothing, (!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 Nothing+      +executeDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextExpr sessionId dbExpr)++-- | Execute a database context IO-monad-based expression for the given session and connection. `DatabaseContextIOExpr`s modify the DatabaseContext but cannot be purely implemented.+--this is almost completely identical to executeDatabaseContextExpr above+executeDatabaseContextIOExpr :: SessionId -> Connection -> DatabaseContextIOExpr -> IO (Maybe RelationalError)+executeDatabaseContextIOExpr sessionId (InProcessConnection conf) expr = excMaybe $ do+  let sessions = ipSessions conf+      scriptSession = ipScriptSession conf+  eSession <- atomically $ sessionForSessionId sessionId sessions --potentially race condition due to interleaved IO?+  case eSession of+    Left err -> pure $ Just err+    Right session -> do+      res <- RE.evalDatabaseContextIOExpr scriptSession (Sess.concreteDatabaseContext session) expr+      case res of+        Left err -> pure (Just err)+        Right context' -> do+          let newDiscon = DisconnectedTransaction (Sess.parentId session) newSchemas True+              newSchemas = Schemas context' (Sess.subschemas session)+              newSession = Session newDiscon (Sess.schemaName session)+          atomically $ STMMap.insert newSession sessionId sessions+          pure Nothing+executeDatabaseContextIOExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (ExecuteDatabaseContextIOExpr sessionId dbExpr)+         +executeGraphExprSTM_ :: Bool -> TransactionId -> SessionId -> Session -> Sessions -> TransactionGraphOperator -> TransactionGraph -> TVar TransactionGraph -> STM (Either RelationalError TransactionGraph)+executeGraphExprSTM_ updateGraphOnError freshId sessionId session sessions graphExpr graph graphTVar= do+  case evalGraphOp freshId (Sess.disconnectedTransaction session) graph graphExpr of+    Left err -> do+      when updateGraphOnError (writeTVar graphTVar graph)+      pure $ Left err+    Right (discon', graph') -> do+      writeTVar graphTVar graph'+      let newSession = Session discon' (Sess.schemaName session)+      STMMap.insert newSession sessionId sessions+      pure $ Right graph'+  +-- process notifications for commits+executeCommitExprSTM_ :: DatabaseContext -> DatabaseContext -> ClientNodes -> STM (EvaluatedNotifications, ClientNodes)+executeCommitExprSTM_ oldContext newContext nodes = do+  let nots = notifications oldContext+      fireNots = notificationChanges nots oldContext newContext +      evaldNots = M.map mkEvaldNot fireNots+      mkEvaldNot notif = EvaluatedNotification { notification = notif, +                                                 reportRelation = runReader (RE.evalRelationalExpr (reportExpr notif)) (RE.mkRelationalExprState oldContext) }+  pure (evaldNots, nodes)+  +-- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators modify the transaction graph state.++-- OPTIMIZATION OPPORTUNITY: no locks are required to write new transaction data, only to update the transaction graph id file+-- if writing data is re-entrant, we may be able to use unsafeIOtoSTM+-- perhaps keep hash of data file instead of checking if our head was updated on every write+executeGraphExpr :: SessionId -> Connection -> TransactionGraphOperator -> IO (Maybe RelationalError)+executeGraphExpr sessionId (InProcessConnection conf) graphExpr = excMaybe $ do+  let strat = ipPersistenceStrategy conf+      clientNodes = ipClientNodes conf+      sessions = ipSessions conf+      graphTvar = ipTransactionGraph conf+      mLockFileH = ipLocks conf+      lockHandler body = case graphExpr of+        Commit _ -> case mLockFileH of+          Nothing -> body False+          Just (lockFileH, lockMVar) -> let acquireLocks = do+                                              lastWrittenDigest <- takeMVar lockMVar +                                              lockFile lockFileH WriteLock+                                              latestDigest <- readGraphTransactionIdDigest strat+                                              pure (latestDigest /= lastWrittenDigest)+                                              +                                            releaseLocks _ = do+                                              --still holding the lock- get the latest digest+                                              gDigest <- readGraphTransactionIdDigest strat+                                              unlockFile lockFileH +                                              putMVar lockMVar gDigest+                                        in bracket acquireLocks releaseLocks body+        _ -> body False+  freshId <- nextRandom+  lockHandler $ \dbWrittenByOtherProcess -> do+    --if the database file has been updated since we wrote it last, load it before trying to sync our version done- this can result in TransactionNotAHeadErrors+    --read transaction data and compare to existing graph+      --in the future, we can detect if updated transaction graph can be safely merged (such as with a transaction on a separate head) (rebase-able commits should force the user to rebase from the client to confirm that the action makes sense)+      manip <- atomically $ do+        eSession <- sessionForSessionId sessionId sessions+        --handle graph update by other process+        oldGraph <- readTVar graphTvar+        case eSession of+         Left err -> pure (Left err)+         Right session -> do+            let mScriptSession = ipScriptSession conf              +                dbdir = case strat of+                  MinimalPersistence x -> x+                  CrashSafePersistence x -> x+                  _ -> error "accessing dbdir on non-persisted connection"+            eRefreshedGraph <- if dbWrittenByOtherProcess then+                               unsafeIOToSTM (transactionGraphLoad dbdir oldGraph mScriptSession)+                             else+                               pure (Right oldGraph)+            case eRefreshedGraph of+              Left err -> pure (Left (DatabaseLoadError err))+              Right refreshedGraph -> do+                if not (isDirty session) && graphExpr == Commit IgnoreEmptyCommitOption then+                  pure (Right (M.empty, [], oldGraph))+                  else do+                   eGraph <- executeGraphExprSTM_ dbWrittenByOtherProcess freshId sessionId session sessions graphExpr refreshedGraph graphTvar+                   case eGraph of+                     Left err -> pure (Left err)+                     Right newGraph -> do+                       --handle commit+                       if not (isDirty session) && graphExpr == Commit ForbidEmptyCommitOption then+                        pure (Left EmptyCommitError)+                         else if not (isDirty session) && graphExpr == Commit IgnoreEmptyCommitOption then+                             pure (Right (M.empty, [], newGraph)) +                           else if isCommit graphExpr then do+                             case transactionForId (Sess.parentId session) oldGraph of+                               Left err -> pure $ Left err+                               Right previousTrans -> do+                                 (evaldNots, nodes) <- executeCommitExprSTM_ (Trans.concreteDatabaseContext previousTrans) (Sess.concreteDatabaseContext session) clientNodes+                                 nodesToNotify <- toList (STMSet.stream nodes)+                                 pure $ Right (evaldNots, nodesToNotify, newGraph)+                             else+                              pure $ Right (M.empty, [], newGraph)+      case manip of +       Left err -> return $ Just err+       Right (notsToFire, nodesToNotify, newGraph) -> do+        --update filesystem database, if necessary+        processTransactionGraphPersistence strat newGraph+        sendNotifications nodesToNotify (ipLocalNode conf) notsToFire+        pure Nothing+executeGraphExpr sessionId conn@(RemoteProcessConnection _) graphExpr = remoteCall conn (ExecuteGraphExpr sessionId graphExpr)++-- | A trans-graph expression is a relational query executed against the entirety of a transaction graph.+executeTransGraphRelationalExpr :: SessionId -> Connection -> TransGraphRelationalExpr -> IO (Either RelationalError Relation)+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+      Left err -> pure (Left err)+      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'.+executeSchemaExpr :: SessionId -> Connection -> Schema.SchemaExpr -> IO (Maybe RelationalError)+executeSchemaExpr sessionId (InProcessConnection conf) schemaExpr = atomically $ do+  let sessions = ipSessions conf+  eSession <- sessionAndSchema sessionId sessions  +  case eSession of+    Left err -> pure (Just err)+    Right (session, _) -> do+      let subschemas' = subschemas session+      case Schema.evalSchemaExpr schemaExpr (Sess.concreteDatabaseContext session) subschemas' of+        Left err -> pure (Just 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)+          STMMap.insert newSession sessionId sessions+          pure Nothing+executeSchemaExpr sessionId conn@(RemoteProcessConnection _) schemaExpr = remoteCall conn (ExecuteSchemaExpr sessionId schemaExpr)          ++-- | After modifying a 'DatabaseContext', 'commit' the transaction to the transaction graph at the head which the session is referencing. This will also trigger checks for any notifications which need to be propagated.+commit :: SessionId -> Connection -> CommitOption -> IO (Maybe RelationalError)+commit sessionId conn@(InProcessConnection _) cOpt = executeGraphExpr sessionId conn (Commit cOpt)+commit sessionId conn@(RemoteProcessConnection _) cOpt = remoteCall conn (ExecuteGraphExpr sessionId (Commit cOpt))+  +sendNotifications :: [ProcessId] -> LocalNode -> EvaluatedNotifications -> IO ()+sendNotifications pids localNode nots = mapM_ sendNots pids+  where+    sendNots remoteClientPid = do+      when (not (M.null nots)) $ runProcess localNode $ send remoteClientPid (NotificationMessage nots)+          +-- | Discard any changes made in the current 'Session' and 'DatabaseContext'. This resets the disconnected transaction to reference the original database context of the parent transaction and is a very cheap operation.+rollback :: SessionId -> Connection -> IO (Maybe RelationalError)+rollback sessionId conn@(InProcessConnection _) = executeGraphExpr sessionId conn Rollback      +rollback sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteGraphExpr sessionId Rollback)++-- | Write the transaction graph to disk. This function can be used to incrementally write new transactions to disk.+processTransactionGraphPersistence :: PersistenceStrategy -> TransactionGraph -> IO ()+processTransactionGraphPersistence NoPersistence _ = pure ()+processTransactionGraphPersistence (MinimalPersistence dbdir) graph = transactionGraphPersist NoDiskSync dbdir graph >> pure ()+processTransactionGraphPersistence (CrashSafePersistence dbdir) graph = transactionGraphPersist FsyncDiskSync dbdir graph >> pure ()++readGraphTransactionIdDigest :: PersistenceStrategy -> IO (LockFileHash)+readGraphTransactionIdDigest NoPersistence = error "attempt to read digest from transaction log without persistence enabled"+readGraphTransactionIdDigest (MinimalPersistence dbdir) = readGraphTransactionIdFileDigest dbdir +readGraphTransactionIdDigest (CrashSafePersistence dbdir) = readGraphTransactionIdFileDigest dbdir ++-- | Return a relation whose type would match that of the relational expression if it were executed. This is useful for checking types and validating a relational expression's types.+typeForRelationalExpr :: SessionId -> Connection -> RelationalExpr -> IO (Either RelationalError Relation)+typeForRelationalExpr sessionId conn@(InProcessConnection _) relExpr = atomically $ typeForRelationalExprSTM sessionId conn relExpr+typeForRelationalExpr sessionId conn@(RemoteProcessConnection _) relExpr = remoteCall conn (ExecuteTypeForRelationalExpr sessionId relExpr)+    +typeForRelationalExprSTM :: SessionId -> Connection -> RelationalExpr -> STM (Either RelationalError Relation)    +typeForRelationalExprSTM sessionId (InProcessConnection conf) relExpr = do+  let sessions = ipSessions conf+  eSession <- sessionAndSchema sessionId sessions+  case eSession of+    Left err -> pure $ Left err+    Right (session, schema) -> do+      let processed = if schemaName session == defaultSchemaName then+                       Right relExpr+                     else+                       Schema.processRelationalExprInSchema schema relExpr+      case processed of+        Left err -> pure (Left err)+        Right relExpr' -> pure $ runReader (RE.typeForRelationalExpr relExpr') (RE.mkRelationalExprState (Sess.concreteDatabaseContext session))+    +typeForRelationalExprSTM _ _ _ = error "typeForRelationalExprSTM called on non-local connection"++-- | Return a 'Map' of the database's constraints at the context of the session and connection.+inclusionDependencies :: SessionId -> Connection -> IO (Either RelationalError InclusionDependencies)+inclusionDependencies sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf+  atomically $ do+    eSession <- sessionAndSchema sessionId sessions+    case eSession of+      Left err -> pure $ Left err +      Right (session, schema) -> do+            let context = Sess.concreteDatabaseContext session+            if schemaName session == defaultSchemaName then+              pure $ Right (B.inclusionDependencies context)+              else+              pure (Schema.inclusionDependenciesInSchema schema (B.inclusionDependencies context))++inclusionDependencies sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveInclusionDependencies sessionId)++-- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated.+planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError DatabaseContextExpr)  +planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do+  let sessions = ipSessions conf+  atomically $ do+    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)++planForDatabaseContextExpr sessionId conn@(RemoteProcessConnection _) dbExpr = remoteCall conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr)+             +-- | Return a relation which represents the current state of the global transaction graph. The attributes are +--    * current- boolean attribute representing whether or not the current session references this transaction+--    * head- text attribute which is a non-empty 'HeadName' iff the transaction references a head.+--    * id- id attribute of the transaction+--    * parents- a relation-valued attribute which contains a relation of transaction ids which are parent transaction to the transaction+transactionGraphAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)+transactionGraphAsRelation sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf+      tvar = ipTransactionGraph conf+  atomically $ do+    eSession <- sessionForSessionId sessionId sessions+    case eSession of+      Left err -> pure $ Left err+      Right session -> do+        graph <- readTVar tvar+        pure $ graphAsRelation (Sess.disconnectedTransaction session) graph+    +transactionGraphAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTransactionGraph sessionId) ++-- | Returns the names and types of the relation variables in the current 'Session'.+relationVariablesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)+relationVariablesAsRelation sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf+  atomically $ do+    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)+          else+          case Schema.relationVariablesInSchema schema context of+            Left err -> pure (Left err)+            Right relvars -> pure $ R.relationVariablesAsRelation relvars+      +relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)      ++-- | Returns the transaction id for the connection's disconnected transaction committed parent transaction.  +headTransactionId :: SessionId -> Connection -> IO (Maybe TransactionId)+headTransactionId sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf  +  atomically $ do+    eSession <- sessionForSessionId sessionId sessions+    case eSession of+      Left _ -> pure Nothing+      Right session -> pure $ Just (Sess.parentId session)+headTransactionId sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveHeadTransactionId sessionId)+    +headNameSTM_ :: SessionId -> Sessions -> TVar TransactionGraph -> STM (Maybe HeadName)  +headNameSTM_ sessionId sessions graphTvar = do+    graph <- readTVar graphTvar+    eSession <- sessionForSessionId sessionId sessions+    case eSession of+      Left _ -> pure $ Nothing+      Right session -> pure $ case transactionForId (Sess.parentId session) graph of+        Left _ -> Nothing+        Right parentTrans -> headNameForTransaction parentTrans graph+  +-- | Returns Just the name of the head of the current disconnected transaction or Nothing.    +headName :: SessionId -> Connection -> IO (Maybe HeadName)+headName sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf+      graphTvar = ipTransactionGraph conf+  atomically (headNameSTM_ sessionId sessions graphTvar)+headName sessionId conn@(RemoteProcessConnection _) = remoteCall conn (ExecuteHeadName sessionId)++-- | Returns a listing of all available atom types.+atomTypesAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)+atomTypesAsRelation sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf+  atomically $ do+    eSession <- sessionForSessionId sessionId sessions+    case eSession of+      Left err -> pure (Left err)+      Right session -> do+        case typesAsRelation (typeConstructorMapping (Sess.concreteDatabaseContext session)) of+          Left err -> pure (Left err)+          Right rel -> pure (Right rel)+atomTypesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)+        +--used only for testing- we expect this to throw an exception+callTestTimeout_ :: SessionId -> Connection -> IO Bool+callTestTimeout_ _ (InProcessConnection _) = error "bad testing call"+callTestTimeout_ sessionId conn@(RemoteProcessConnection _) = remoteCall conn (TestTimeout sessionId)++--used in tests only+transactionGraph_ :: Connection -> IO TransactionGraph+transactionGraph_ (InProcessConnection conf) = atomically $ readTVar (ipTransactionGraph conf)+transactionGraph_ _ = error "remote connection used"++--used in tests only+disconnectedTransaction_ :: SessionId -> Connection -> IO DisconnectedTransaction+disconnectedTransaction_ sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf+  mSession <- atomically $ do+    STMMap.lookup sessionId sessions+  case mSession of+    Nothing -> error "No such session"+    Just (Sess.Session discon _) -> pure discon+disconnectedTransaction_ _ _= error "remote connection used"
+ src/lib/ProjectM36/DataConstructorDef.hs view
@@ -0,0 +1,20 @@+module ProjectM36.DataConstructorDef where+import ProjectM36.Base+import qualified ProjectM36.TypeConstructor as TC+import qualified Data.Set as S++emptyDataConstructor :: DataConstructorName -> DataConstructorDef+emptyDataConstructor name' = DataConstructorDef name' []++name :: DataConstructorDef -> DataConstructorName+name (DataConstructorDef name' _) = name'++fields :: DataConstructorDef -> [DataConstructorDefArg]+fields (DataConstructorDef _ args) = args++typeVars :: DataConstructorDef -> S.Set TypeVarName+typeVars (DataConstructorDef _ tConsArgs) = S.unions $ map typeVarsInDefArg tConsArgs++typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName+typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = TC.typeVars tCons+typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName
+ src/lib/ProjectM36/DataTypes/Basic.hs view
@@ -0,0 +1,17 @@+-- wraps up primitives plus other basic data types+module ProjectM36.DataTypes.Basic where+import ProjectM36.DataTypes.Primitive+import ProjectM36.DataTypes.Day+import ProjectM36.DataTypes.Either+import ProjectM36.DataTypes.Maybe+import ProjectM36.DataTypes.List+import ProjectM36.Base++basicTypeConstructorMapping :: TypeConstructorMapping+basicTypeConstructorMapping = (primitiveTypeConstructorMapping ++ +                               maybeTypeConstructorMapping ++ +                               eitherTypeConstructorMapping ++ +                               listTypeConstructorMapping +++                               dayTypeConstructorMapping+                              )+
+ src/lib/ProjectM36/DataTypes/DateTime.hs view
@@ -0,0 +1,14 @@+module ProjectM36.DataTypes.DateTime where+import ProjectM36.Base+import ProjectM36.AtomFunctionBody+import qualified Data.HashSet as HS+import Data.Time.Clock.POSIX++dateTimeAtomFunctions :: AtomFunctions+dateTimeAtomFunctions = HS.fromList [ AtomFunction {+                                     atomFuncName = "dateTimeFromEpochSeconds",+                                     atomFuncType = [IntAtomType, DateTimeAtomType],+                                     atomFuncBody = compiledAtomFunctionBody $ \((IntAtom epoch):_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))+                                                                                                       }]++
+ src/lib/ProjectM36/DataTypes/Day.hs view
@@ -0,0 +1,20 @@+module ProjectM36.DataTypes.Day where+import ProjectM36.Base+import ProjectM36.AtomFunctionBody+import qualified Data.HashSet as HS+import Data.Time.Calendar++dayAtomFunctions :: AtomFunctions+dayAtomFunctions = HS.fromList [+  AtomFunction { atomFuncName = "fromGregorian",+                 atomFuncType = [IntAtomType, IntAtomType, IntAtomType, DayAtomType],+                 atomFuncBody = compiledAtomFunctionBody $ \((IntAtom year):(IntAtom month):(IntAtom day):_) -> pure $ DayAtom (fromGregorian (fromIntegral year) month day)+                 },+  AtomFunction { atomFuncName = "dayEarlierThan",+                 atomFuncType = [DayAtomType, DayAtomType, BoolAtomType],+                 atomFuncBody = compiledAtomFunctionBody $ \((ConstructedAtom _ _ (IntAtom dayA:_)):(ConstructedAtom _ _ (IntAtom dayB:_)):_) -> pure (BoolAtom (dayA < dayB))+               }+  ]++dayTypeConstructorMapping :: TypeConstructorMapping+dayTypeConstructorMapping = [] -- use fromGregorian
+ src/lib/ProjectM36/DataTypes/Either.hs view
@@ -0,0 +1,18 @@+module ProjectM36.DataTypes.Either where+import ProjectM36.Base+import ProjectM36.AtomFunction+import qualified Data.HashSet as HS+import qualified Data.Map as M+       +eitherAtomType :: AtomType -> AtomType -> AtomType+eitherAtomType tA tB = ConstructedAtomType "Either" (M.fromList [("a", tA), ("b", tB)])+  +eitherTypeConstructorMapping :: TypeConstructorMapping                +eitherTypeConstructorMapping = [(ADTypeConstructorDef "Either" ["a", "b"],+                                 [DataConstructorDef "Left" [DataConstructorDefTypeVarNameArg "a"],+                                  DataConstructorDef "Right" [DataConstructorDefTypeVarNameArg "b"]])]+       +eitherAtomFunctions :: AtomFunctions                               +eitherAtomFunctions = HS.fromList [+  compiledAtomFunction "isLeft" [eitherAtomType (TypeVariableType "a") (TypeVariableType "b"), BoolAtomType] $ \((ConstructedAtom dConsName _ _):_) -> pure (BoolAtom (dConsName == "Left"))+  ]
+ src/lib/ProjectM36/DataTypes/List.hs view
@@ -0,0 +1,49 @@+module ProjectM36.DataTypes.List where+import ProjectM36.Base+import ProjectM36.DataTypes.Maybe+import ProjectM36.DataTypes.Primitive+import qualified Data.Map as M+import qualified Data.HashSet as HS+import ProjectM36.AtomFunctionError++listAtomType :: AtomType -> AtomType+listAtomType arg = ConstructedAtomType "List" (M.singleton "a" arg)++listTypeConstructorMapping :: TypeConstructorMapping+listTypeConstructorMapping = [(ADTypeConstructorDef "List" ["a"],+                           [DataConstructorDef "Empty" [],+                           DataConstructorDef "Cons" [DataConstructorDefTypeVarNameArg "a",+                                                      DataConstructorDefTypeConstructorArg (ADTypeConstructor "List" [TypeVariable "a"])]])]+                         +listLength :: Atom -> Either AtomFunctionError Int                         +listLength (ConstructedAtom "Cons" _ (_:nextCons:_)) = do+  c <- listLength nextCons+  pure (c + 1)+listLength (ConstructedAtom "Empty" _ _) = pure 0+listLength _ = Left AtomFunctionTypeMismatchError++listMaybeHead :: Atom -> Either AtomFunctionError Atom+listMaybeHead (ConstructedAtom "Cons" _ (val:_)) = pure (ConstructedAtom "Just" aType [val])+  where+    aType = maybeAtomType (atomTypeForAtom val)+listMaybeHead (ConstructedAtom "Empty" (ConstructedAtomType _ tvMap) _) = do+  case M.lookup "a" tvMap of+    Nothing -> Left AtomFunctionTypeMismatchError+    Just aType -> pure (ConstructedAtom "Nothing" aType [])+listMaybeHead _ = Left AtomFunctionTypeMismatchError++listAtomFunctions :: AtomFunctions+listAtomFunctions = HS.fromList [+  AtomFunction {+     atomFuncName = "length",+     atomFuncType = [listAtomType (TypeVariableType "a"), IntAtomType],+     atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> do+                                                 c <- listLength listAtom+                                                 pure (IntAtom c))+     },+  AtomFunction {+    atomFuncName = "maybeHead",+    atomFuncType = [listAtomType (TypeVariableType "a"), maybeAtomType (TypeVariableType "a")],+    atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> listMaybeHead listAtom)+    }+  ]
+ src/lib/ProjectM36/DataTypes/Maybe.hs view
@@ -0,0 +1,38 @@+module ProjectM36.DataTypes.Maybe where+import ProjectM36.Base+import ProjectM36.DataTypes.Primitive+import ProjectM36.AtomFunctionError+import qualified Data.HashSet as HS+import qualified Data.Map as M++maybeAtomType :: AtomType -> AtomType+maybeAtomType arg = ConstructedAtomType "Maybe" (M.singleton "a" arg)+  +maybeTypeConstructorMapping :: TypeConstructorMapping+maybeTypeConstructorMapping = [(ADTypeConstructorDef "Maybe" ["a"],+                                [DataConstructorDef "Nothing" [],+                                 DataConstructorDef "Just" [DataConstructorDefTypeVarNameArg "a"]])+                              ]++maybeAtomFunctions :: AtomFunctions+maybeAtomFunctions = HS.fromList [+  AtomFunction {+     atomFuncName ="isJust",+     atomFuncType = [maybeAtomType (TypeVariableType "a"), BoolAtomType],+     atomFuncBody = AtomFunctionBody Nothing $ \((ConstructedAtom dConsName _ _):_) -> pure $ BoolAtom (dConsName /= "Nothing")+     },+  AtomFunction {+     atomFuncName = "fromMaybe",+     atomFuncType = [TypeVariableType "a", maybeAtomType (TypeVariableType "a"), TypeVariableType "a"],+     atomFuncBody = AtomFunctionBody Nothing $ \(defaultAtom:(ConstructedAtom dConsName _ (atomVal:_)):_) -> if atomTypeForAtom defaultAtom /= atomTypeForAtom atomVal then Left AtomFunctionTypeMismatchError else if dConsName == "Nothing" then pure defaultAtom else pure atomVal+     }+  ]++{- To create an inclusion dependency for uniqueness for "Just a" values only +person := relation{name Text, boss Maybe Text}{tuple{name "Steve",boss Nothing}, tuple{name "Bob", boss Just "Steve"}}+:showexpr ((relation{tuple{}}:{a:=person where ^isJust(@boss)}):{b:=count(@a)}){b}+:showexpr ((relation{tuple{}}:{a:=person{boss} where ^isJust(@boss)}):{b:=count(@a)}){b}+constraint uniqueJust ((relation{tuple{}}:{a:=person where ^isJust(@boss)}):{b:=count(@a)}){b} in ((relation{tuple{}}:{a:=person{boss} where ^isJust(@boss)}):{b:=count(@a)}){b}+person := relation{name Text, boss Maybe Text}{tuple{name "Steve",boss Nothing}, tuple{name "Bob", boss Just "Steve"}, tuple{name "Jim", boss Just "Steve"}} +ERR: InclusionDependencyCheckError "uniqueJust"+-}
+ src/lib/ProjectM36/DataTypes/Primitive.hs view
@@ -0,0 +1,37 @@+module ProjectM36.DataTypes.Primitive where+import ProjectM36.Base++primitiveTypeConstructorMapping :: TypeConstructorMapping+primitiveTypeConstructorMapping = map (\(name, aType) ->+                                  (PrimitiveTypeConstructorDef name aType, [])) prims+  where+    prims = [("Int", IntAtomType),+             ("Text", TextAtomType),+             ("Double", DoubleAtomType),+             ("Bool", BoolAtomType),+             ("ByteString", ByteStringAtomType)+            ]+            +intTypeConstructor :: TypeConstructor            +intTypeConstructor = PrimitiveTypeConstructor "Int" IntAtomType++doubleTypeConstructor :: TypeConstructor+doubleTypeConstructor = PrimitiveTypeConstructor "Double" DoubleAtomType++textTypeConstructor :: TypeConstructor+textTypeConstructor = PrimitiveTypeConstructor "Text" TextAtomType++dayTypeConstructor :: TypeConstructor+dayTypeConstructor = PrimitiveTypeConstructor "Day" DayAtomType++-- | Return the type of an 'Atom'.+atomTypeForAtom :: Atom -> AtomType+atomTypeForAtom (IntAtom _) = IntAtomType+atomTypeForAtom (DoubleAtom _) = DoubleAtomType+atomTypeForAtom (TextAtom _) = TextAtomType+atomTypeForAtom (DayAtom _) = DayAtomType+atomTypeForAtom (DateTimeAtom _) = DateTimeAtomType+atomTypeForAtom (ByteStringAtom _) = ByteStringAtomType+atomTypeForAtom (BoolAtom _) = BoolAtomType+atomTypeForAtom (RelationAtom (Relation attrs _)) = RelationAtomType attrs+atomTypeForAtom (ConstructedAtom _ aType _) = aType
+ src/lib/ProjectM36/DatabaseContext.hs view
@@ -0,0 +1,35 @@+module ProjectM36.DatabaseContext where+import ProjectM36.Base+import qualified Data.Map as M+import qualified Data.HashSet as HS+import ProjectM36.DataTypes.Basic+import ProjectM36.AtomFunctions.Basic+import ProjectM36.DatabaseContextFunction+import ProjectM36.Relation++empty :: DatabaseContext+empty = DatabaseContext { inclusionDependencies = M.empty, +                          relationVariables = M.empty, +                          notifications = M.empty,+                          atomFunctions = HS.empty,+                          dbcFunctions = HS.empty,+                          typeConstructorMapping = [] }+        +-- | 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))+    incDepsExprs :: [DatabaseContextExpr]+    incDepsExprs = map (\(name, dep) -> AddInclusionDependency name dep) (M.toList (inclusionDependencies context))+    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)],+                                         atomFunctions = basicAtomFunctions,+                                         dbcFunctions = basicDatabaseContextFunctions,+                                         notifications = M.empty,+                                         typeConstructorMapping = basicTypeConstructorMapping+                                         }
+ src/lib/ProjectM36/DatabaseContextFunction.hs view
@@ -0,0 +1,56 @@+module ProjectM36.DatabaseContextFunction where+--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr+import ProjectM36.Base+import ProjectM36.Error+import qualified Data.HashSet as HS+import qualified Data.Map as M++emptyDatabaseContextFunction :: DatabaseContextFunctionName -> DatabaseContextFunction+emptyDatabaseContextFunction name = DatabaseContextFunction { +  dbcFuncName = name,+  dbcFuncType = [],+  dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure ctx)+  }++databaseContextFunctionForName :: DatabaseContextFunctionName -> DatabaseContextFunctions -> Either RelationalError DatabaseContextFunction+databaseContextFunctionForName funcName funcs = if HS.null foundFunc then+                                                   Left $ NoSuchFunctionError funcName+                                                else+                                                  Right (head (HS.toList foundFunc))+  where+    foundFunc = HS.filter (\(DatabaseContextFunction name _ _) -> name == funcName) funcs++evalDatabaseContextFunction :: DatabaseContextFunction -> [Atom] -> DatabaseContext -> Either RelationalError DatabaseContext+evalDatabaseContextFunction func args ctx = case dbcFuncBody func of+  (DatabaseContextFunctionBody _ f) -> case f args ctx of+    Left err -> Left (DatabaseContextFunctionUserError err)+    Right c -> pure c+  +basicDatabaseContextFunctions :: DatabaseContextFunctions+basicDatabaseContextFunctions = HS.fromList [+  DatabaseContextFunction { dbcFuncName = "deleteAll",+                            dbcFuncType = [],+                            dbcFuncBody = DatabaseContextFunctionBody Nothing (\_ ctx -> pure $ ctx { relationVariables = M.empty })+                          }+  ]+                                +--the precompiled functions are special because they cannot be serialized. Their names are therefore used in perpetuity so that the functions can be "serialized" (by name).+precompiledDatabaseContextFunctions :: DatabaseContextFunctions+precompiledDatabaseContextFunctions = HS.filter (not . isScriptedDatabaseContextFunction) basicDatabaseContextFunctions+                                +isScriptedDatabaseContextFunction :: DatabaseContextFunction -> Bool+isScriptedDatabaseContextFunction func = case dbcFuncBody func of+  DatabaseContextFunctionBody (Just _) _ -> True+  DatabaseContextFunctionBody Nothing _ -> False+  +databaseContextFunctionScript :: DatabaseContextFunction -> Maybe DatabaseContextFunctionBodyScript+databaseContextFunctionScript func = case dbcFuncBody func of+  DatabaseContextFunctionBody script _ -> script+  +databaseContextFunctionReturnType :: TypeConstructor -> TypeConstructor+databaseContextFunctionReturnType tCons = ADTypeConstructor "Either" [+  (ADTypeConstructor "DatabaseContextFunctionError" []),+  tCons]+                                          +createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeConstructor] -> TypeConstructor -> DatabaseContextFunctionBodyScript -> DatabaseContextIOExpr+createScriptedDatabaseContextFunction funcName argsIn retArg script = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg]) script
+ src/lib/ProjectM36/DatabaseContextFunctionError.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module ProjectM36.DatabaseContextFunctionError where+import GHC.Generics+import Data.Binary+import Control.DeepSeq++data DatabaseContextFunctionError = DatabaseContextFunctionUserError String+                                  deriving (Generic, Eq, Show, Binary, NFData)
+ src/lib/ProjectM36/DateExamples.hs view
@@ -0,0 +1,87 @@+module ProjectM36.DateExamples where+import ProjectM36.Base+import qualified ProjectM36.Attribute as A+import ProjectM36.Key+import ProjectM36.AtomFunctions.Basic+import ProjectM36.DataTypes.Basic+import ProjectM36.DatabaseContext+import ProjectM36.Relation+import qualified Data.Map as M+import qualified Data.Set as S++dateExamples :: DatabaseContext+dateExamples = empty { inclusionDependencies = dateIncDeps,+                                 relationVariables = M.union (relationVariables basicDatabaseContext) dateRelVars,+                                 notifications = M.empty,+                                 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)]+    suppliers = suppliersRel+    products = productsRel+    supplierProducts = supplierProductsRel+    dateIncDeps = M.fromList [("s_pkey", simplePKey ["s#"] "s"),+                              ("p_pkey", simplePKey ["p#"] "p"),+                              ("sp_pkey", simplePKey ["s#", "p#"] "sp")+                              ]+    simplePKey attrNames relvarName = inclusionDependencyForKey (AttributeNames $ S.fromList attrNames) (RelationVariable relvarName ())++suppliersRel :: Relation+suppliersRel = case mkRelationFromList attrs atomMatrix of+  Left _ -> undefined+  Right rel -> rel+  where+    attrs = A.attributesFromList [Attribute "s#" TextAtomType,+                                  Attribute "sname" TextAtomType,+                                  Attribute "status" IntAtomType,+                                  Attribute "city" TextAtomType]+    atomMatrix = [+      [TextAtom "S1", TextAtom "Smith", IntAtom 20, TextAtom "London"],+      [TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"],+      [TextAtom "S3", TextAtom "Blake", IntAtom 30, TextAtom "Paris"],+      [TextAtom "S4", TextAtom "Clark", IntAtom 20, TextAtom "London"],+      [TextAtom "S5", TextAtom "Adams", IntAtom 30, TextAtom "Athens"]]++supplierProductsRel :: Relation+supplierProductsRel = case mkRelationFromList attrs matrix of+  Left _ -> undefined+  Right rel -> rel+  where+    attrs = A.attributesFromList [Attribute "s#" TextAtomType,+                                  Attribute "p#" TextAtomType,+                                  Attribute "qty" IntAtomType]+    matrix = [+      [TextAtom "S1", TextAtom "P1", IntAtom 300],+      [TextAtom "S1", TextAtom "P2", IntAtom 200],+      [TextAtom "S1", TextAtom "P3", IntAtom 400],+      [TextAtom "S1", TextAtom "P4", IntAtom 200],+      [TextAtom "S1", TextAtom "P5", IntAtom 100],+      [TextAtom "S1", TextAtom "P6", IntAtom 100],+      [TextAtom "S2", TextAtom "P1", IntAtom 300],+      [TextAtom "S2", TextAtom "P2", IntAtom 400],+      [TextAtom "S3", TextAtom "P2", IntAtom 200],+      [TextAtom "S4", TextAtom "P2", IntAtom 200],+      [TextAtom "S4", TextAtom "P4", IntAtom 300],+      [TextAtom "S4", TextAtom "P5", IntAtom 400]+      ]++productsRel :: Relation+productsRel = case mkRelationFromList attrs matrix of+  Left _ -> undefined+  Right rel -> rel+  where+    attrs = A.attributesFromList [Attribute "p#" TextAtomType,+                                  Attribute "pname" TextAtomType,+                                  Attribute "color" TextAtomType,+                                  Attribute "weight" IntAtomType,+                                  Attribute "city" TextAtomType]+    matrix = [+      [TextAtom "P1", TextAtom "Nut", TextAtom "Red", IntAtom 12, TextAtom "London"],+      [TextAtom "P2", TextAtom "Bolt", TextAtom "Green", IntAtom 17, TextAtom "Paris"],+      [TextAtom "P3", TextAtom "Screw", TextAtom "Blue", IntAtom 17, TextAtom "Oslo"],+      [TextAtom "P4", TextAtom "Screw", TextAtom "Red", IntAtom 14, TextAtom "London"],+      [TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntAtom 12, TextAtom "Paris"],+      [TextAtom "P6", TextAtom "Cog", TextAtom "Red", IntAtom 19, TextAtom "London"]+      ]
+ src/lib/ProjectM36/DisconnectedTransaction.hs view
@@ -0,0 +1,11 @@+module ProjectM36.DisconnectedTransaction where+import ProjectM36.Base++concreteDatabaseContext :: DisconnectedTransaction -> DatabaseContext+concreteDatabaseContext (DisconnectedTransaction _ (Schemas context _) _) = context++schemas :: DisconnectedTransaction -> Schemas+schemas (DisconnectedTransaction _ s _) = s++parentId :: DisconnectedTransaction -> TransactionId+parentId (DisconnectedTransaction pid _ _) = pid
+ src/lib/ProjectM36/Error.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module ProjectM36.Error where+import ProjectM36.Base+import ProjectM36.DatabaseContextFunctionError+import ProjectM36.AtomFunctionError+import qualified Data.Set as S+import Control.DeepSeq (NFData, rnf)+import Control.DeepSeq.Generics (genericRnf)+import GHC.Generics (Generic)+import qualified Data.Text as T+import Data.Binary+import Data.Typeable+import Control.Exception++data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)+                     | TupleAttributeCountMismatchError Int --attribute name+                     | TupleAttributeTypeMismatchError Attributes+                     | AttributeCountMismatchError Int+                     | AttributeNamesMismatchError (S.Set AttributeName)+                     | AttributeNameInUseError AttributeName+                     | AttributeIsNotRelationValuedError AttributeName+                     | CouldNotInferAttributes+                     | RelVarNotDefinedError RelVarName+                     | RelVarAlreadyDefinedError RelVarName+                     | RelVarAssignmentTypeMismatchError Attributes Attributes --expected, found+                     | InclusionDependencyCheckError IncDepName+                     | InclusionDependencyNameInUseError IncDepName+                     | InclusionDependencyNameNotInUseError IncDepName+                     | ParseError T.Text+                     | PredicateExpressionError T.Text+                     | NoCommonTransactionAncestorError TransactionId TransactionId+                     | NoSuchTransactionError TransactionId+                     | RootTransactionTraversalError +                     | HeadNameSwitchingHeadProhibitedError HeadName+                     | NoSuchHeadNameError HeadName+                     | NewTransactionMayNotHaveChildrenError TransactionId+                     | ParentCountTraversalError Int Int --maximum, requested+                     | NewTransactionMissingParentError TransactionId+                     | TransactionIsNotAHeadError TransactionId+                     | TransactionGraphCycleError TransactionId+                     | SessionIdInUseError TransactionId+                     | NoSuchSessionError TransactionId+                     | FailedToFindTransactionError TransactionId+                     | TransactionIdInUseError TransactionId+                     | NoSuchFunctionError AtomFunctionName+                     | NoSuchTypeConstructorName TypeConstructorName+                     | TypeConstructorAtomTypeMismatch TypeConstructorName AtomType+                     | AtomTypeMismatchError AtomType AtomType+                     | TypeConstructorNameMismatch TypeConstructorName TypeConstructorName+                     | AtomTypeTypeConstructorReconciliationError AtomType TypeConstructorName+                     | DataConstructorNameInUseError DataConstructorName+                     | DataConstructorUsesUndeclaredTypeVariable TypeVarName+                     | TypeConstructorTypeVarsMismatch (S.Set TypeVarName) (S.Set TypeVarName)+                     | TypeConstructorTypeVarMissing TypeVarName+                     | TypeConstructorTypeVarsTypesMismatch TypeConstructorName TypeVarMap TypeVarMap+                     | DataConstructorTypeVarsMismatch DataConstructorName TypeVarMap TypeVarMap+                     | AtomFunctionTypeVariableResolutionError AtomFunctionName TypeVarName+                     | AtomFunctionTypeVariableMismatch TypeVarName AtomType AtomType+                     | AtomTypeNameInUseError AtomTypeName+                     | IncompletelyDefinedAtomTypeWithConstructorError+                     | AtomTypeNameNotInUseError AtomTypeName+                     | FunctionNameInUseError AtomFunctionName+                     | FunctionNameNotInUseError AtomFunctionName+                     | EmptyCommitError+                     | FunctionArgumentCountMismatch Int Int+                     | NoSuchDataConstructorError DataConstructorName+                     | NoSuchTypeConstructorError TypeConstructorName+                     | InvalidAtomTypeName AtomTypeName+                     | AtomTypeNotSupported AttributeName --used by persistent driver+                     | AtomOperatorNotSupported T.Text --used by persistent driver+                     | EmptyTuplesError -- used by persistent driver+                     | AtomTypeCountError [AtomType] [AtomType]+                     | AtomFunctionTypeError AtomFunctionName Int AtomType AtomType --arg number+                     | AtomFunctionUserError AtomFunctionError+                     | PrecompiledFunctionRemoveError AtomFunctionName -- pre-compiled atom functions cannot be serialized, so they cannot change over time- they are referred to in perpetuity+                     | RelationValuedAttributesNotSupportedError [AttributeName]+                     | NotificationNameInUseError NotificationName+                     | NotificationNameNotInUseError NotificationName+                     | ImportError T.Text -- really? This should be broken out into some other error type- this has nothing to do with relational algebra+                     | ExportError T.Text+                     | UnhandledExceptionError String+                     | MergeTransactionError MergeError+                     | ScriptError ScriptCompilationError+                     | DatabaseContextFunctionUserError DatabaseContextFunctionError+                     | DatabaseLoadError PersistenceError+                       +                     | SubschemaNameInUseError SchemaName+                     | SubschemaNameNotInUseError SchemaName+                       +                     | SchemaCreationError SchemaError +                       +                     | ImproperDatabaseStateError+                       +                     | MultipleErrors [RelationalError]+                       deriving (Show,Eq,Generic,Binary,Typeable, NFData) ++data PersistenceError = InvalidDirectoryError FilePath | +                        MissingTransactionError TransactionId+                      deriving (Show, Eq, Generic, Binary, NFData)++--collapse list of errors into normal error- if there is just one, just return one+someErrors :: [RelationalError] -> RelationalError                                      +someErrors [] = error "no errors in error list: function misuse" +someErrors errList  = if length errList == 1 then+                        head errList+                      else+                        MultipleErrors errList+                        +data MergeError = SelectedHeadMismatchMergeError |+                  PreferredHeadMissingMergeError HeadName |+                  StrategyViolatesConstraintMergeError |+                  InvalidMergeStrategyError MergeStrategy | -- this is an internal coding error+                  DisconnectedTransactionNotAMergeHeadError TransactionId |+                  StrategyViolatesComponentMergeError | --failed merge in inc deps, relvars, etc.+                  StrategyViolatesRelationVariableMergeError |+                  StrategyViolatesTypeConstructorMergeError+                  deriving (Show, Eq, Generic, Binary, Typeable)+                           +instance NFData MergeError where rnf = genericRnf                           +                                 +data ScriptCompilationError = TypeCheckCompilationError String String | --expected, got+                              SyntaxErrorCompilationError String |+                              ScriptCompilationDisabledError |+                              OtherScriptCompilationError String+                            deriving (Show,Eq, Generic, Binary, Typeable, NFData)+                                     +instance Exception ScriptCompilationError                                     +                                               +data SchemaError = RelVarReferencesMissing (S.Set RelVarName) |+                   RelVarInReferencedMoreThanOnce RelVarName |+                   RelVarOutReferencedMoreThanOnce RelVarName+                   deriving (Show, Eq, Generic, Binary, Typeable, NFData)+                           +                                               +-- errors returned from the distributed-process call handlers+data ServerError = RequestTimeoutError |+                   ProcessDiedError String+                   deriving (Generic, Binary, Eq)
+ src/lib/ProjectM36/FileLock.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP #-}+--cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking+--hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite+module ProjectM36.FileLock where+import System.IO+++#if defined(mingw32_HOST_OS)+import ProjectM36.Win32Handle+import System.Win32.Types+import Foreign.Marshal.Alloc+import System.Win32.File+import System.Win32.Mem+import Data.Bits++#if defined(i386_HOST_ARCH)+# define WINDOWS_CCONV stdcall+#elif defined(x86_64_HOST_ARCH)+# define WINDOWS_CCONV ccall+#else+# error Unknown mingw32 arch+#endif+foreign import WINDOWS_CCONV "LockFileEx" c_lockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL++foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL++--swiped from System.FileLock package+lockFile :: Handle -> LockType -> IO ()+lockFile handle lock = withHandleToHANDLE handle $ \winHandle -> do+  let exFlag = case lock of+                 WriteLock -> 2+                 ReadLock -> 0+      blockFlag = 0 --always block+      sizeof_OVERLAPPED = 32++  allocaBytes sizeof_OVERLAPPED $ \op -> do+    zeroMemory op $ fromIntegral sizeof_OVERLAPPED+    res <- c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op+    if res then+       pure ()+    else+       error "failed to wait for database lock"++unlockFile :: Handle -> IO ()+unlockFile handle = withHandleToHANDLE handle $ \winHandle -> do+  let sizeof_OVERLAPPED = 32+  allocaBytes sizeof_OVERLAPPED $ \op -> do+    zeroMemory op $ fromIntegral sizeof_OVERLAPPED+    res <- c_unlockFileEx winHandle 0 1 0 op+    if res then+      pure ()+    else+      error ("failed to unlock database lock: " ++ show res)++#else+import qualified System.Posix.IO as P++lockStruct :: P.LockRequest -> P.FileLock+lockStruct req = (req, AbsoluteSeek, 0, 0)++--blocks on lock, if necessary+lockFile :: Handle -> LockType -> IO ()    +lockFile file lock = do+  fd <- P.handleToFd file+  let lockt = case lock of+        WriteLock -> P.WriteLock+        ReadLock -> P.ReadLock+  P.waitToSetLock fd (lockStruct lockt)+  +unlockFile :: Handle -> IO ()  +unlockFile file = do +  fd <- P.handleToFd file+  P.waitToSetLock fd (lockStruct P.Unlock)+#endif++data LockType = ReadLock | WriteLock++{-+lockFileSTM :: Handle -> LockType -> STM ()+lockFileSTM file lock = unsafeIOToSTM $ onException (lockFile file lock) (unlockFile file)++unlockFileSTM :: Handle -> STM ()+unlockFileSTM file = unsafeIOToSTM $ unlockFile file+-}+
+ src/lib/ProjectM36/FunctionalDependency.hs view
@@ -0,0 +1,20 @@+module ProjectM36.FunctionalDependency where+import ProjectM36.Base +import qualified Data.Set as S++data FunctionalDependency = FunctionalDependency AttributeNames AttributeNames RelationalExpr++--(s{city} group ({city} as x) : {z:=count(@x)}) {z}+-- as defined in Relational Algebra and All That Jazz page 21+inclusionDependenciesForFunctionalDependency :: FunctionalDependency -> (InclusionDependency, InclusionDependency)+inclusionDependenciesForFunctionalDependency (FunctionalDependency attrNamesSource attrNamesDependent relExpr) = (+  InclusionDependency countSource countDep,            +  InclusionDependency countDep countSource)+  where+    countDep = relExprCount relExpr (UnionAttributeNames attrNamesSource attrNamesDependent)+    countSource = relExprCount relExpr attrNamesSource+    projectZName = Project (AttributeNames (S.singleton "z"))+    zCount = FunctionAtomExpr "count" [AttributeAtomExpr "x"] ()+    extendZName = Extend (AttributeExtendTupleExpr "z" zCount)+    relExprCount expr projectionAttrNames = projectZName (extendZName+       (Group projectionAttrNames "x" (Project projectionAttrNames expr)))
+ src/lib/ProjectM36/InclusionDependency.hs view
@@ -0,0 +1,20 @@+module ProjectM36.InclusionDependency where+import ProjectM36.Base+import ProjectM36.Attribute+import ProjectM36.Error+import ProjectM36.Relation+import qualified Data.Map as M+import qualified Data.Text as T++inclusionDependenciesAsRelation :: InclusionDependencies -> Either RelationalError Relation+inclusionDependenciesAsRelation incDeps = do+  mkRelationFromList attrs (map incDepAsAtoms (M.toList incDeps))+  where+    attrs = attributesFromList [Attribute "name" TextAtomType,+                                Attribute "sub" TextAtomType,+                                Attribute "super" TextAtomType+                                ]+    incDepAsAtoms (name, (InclusionDependency exprA exprB)) = [TextAtom name,+                                                               TextAtom (T.pack (show exprA)),+                                                               TextAtom (T.pack (show exprB))]+
+ src/lib/ProjectM36/IsomorphicSchema.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module ProjectM36.IsomorphicSchema where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.MiscUtils+import ProjectM36.RelationalExpression+import ProjectM36.Relation+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+import qualified Data.Set as S+import qualified Data.List as L+import qualified Data.Text as T+import Data.Monoid+--import Debug.Trace+-- isomorphic schemas offer bi-directional functors between two schemas++--TODO: note that renaming a relvar should alter any stored isomorphisms as well+--TODO: rel attrs rename or transform (needs bidirectional atom functions)+-- TODO: IsoRestrict should include requirement that union'd relations should retain the same tuple count (no tuples are lost or ambiguous between the two relations)+--TODO: allow morphs to stack (morph a schema to a new schema)+ -- this could be accomplished by morphing the morphs or by chain linking schemas so that they need not directly reference the underlying concrete schema++-- the isomorphic building blocks should not be arbitrarily combined; for example, combing restrict and union on the same target relvar does not make sense as that would create effects at a distance in the secondary schema++data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |+                  RemoveSubschema SchemaName+                  deriving (Generic, Binary, Show)++  +isomorphs :: Schema -> SchemaIsomorphs+isomorphs (Schema i) = i++-- | Return an error if the schema is not isomorphic to the base database context.+-- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once.+--TODO: add relvar must appear exactly once constraint+validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError+validateSchema potentialSchema baseContext = do+  if not (S.null rvDiff) then+    Just (RelVarReferencesMissing rvDiff)+    else if not (null outDupes) then +           Just (RelVarOutReferencedMoreThanOnce (head outDupes))+         else if not (null inDupes) then+           Just (RelVarInReferencedMoreThanOnce (head inDupes))                +         else+           Nothing+  where+    --check that the predicate for IsoUnion and IsoRestrict holds right now+    outDupes = duplicateNames (namesList isomorphOutRelVarNames)+    inDupes = duplicateNames (namesList isomorphInRelVarNames)+    duplicateNames = dupes . L.sort+    namesList isoFunc = concat (map isoFunc (isomorphs potentialSchema))+    expectedRelVars = M.keysSet (relationVariables baseContext)+    schemaRelVars = isomorphsOutRelVarNames (isomorphs potentialSchema)+    rvDiff = S.difference expectedRelVars schemaRelVars++-- useful for transforming a concrete context into a virtual schema and vice versa+invert :: SchemaIsomorph -> SchemaIsomorph+invert (IsoRename rvIn rvOut) = IsoRename rvOut rvIn+invert (IsoRestrict rvIn predi (rvAOut, rvBOut)) = IsoUnion (rvAOut, rvBOut) predi rvIn+invert (IsoUnion (rvAIn, rvBIn) predi rvOut) = IsoRestrict rvOut predi (rvAIn, rvBIn)++isomorphInRelVarNames :: SchemaIsomorph -> [RelVarName]+isomorphInRelVarNames (IsoRestrict rv _ _) = [rv]+isomorphInRelVarNames (IsoUnion (rvA, rvB) _ _) = [rvA, rvB]+isomorphInRelVarNames (IsoRename rv _) = [rv]++-- | Relation variables names represented in the virtual schema space. Useful for determining if a relvar name is valid in the schema.+isomorphsInRelVarNames :: SchemaIsomorphs -> S.Set RelVarName+isomorphsInRelVarNames morphs = S.fromList (foldr rvnames [] morphs)+  where+    rvnames morph acc = acc ++ isomorphInRelVarNames morph+    +isomorphOutRelVarNames :: SchemaIsomorph -> [RelVarName]    +isomorphOutRelVarNames (IsoRestrict _ _ (rvA, rvB)) = [rvA, rvB]+isomorphOutRelVarNames (IsoUnion _ _ rv) = [rv]+isomorphOutRelVarNames (IsoRename _ rv) = [rv]++isomorphsOutRelVarNames :: SchemaIsomorphs -> S.Set RelVarName+isomorphsOutRelVarNames morphs = S.fromList (foldr rvnames [] morphs)+  where+    rvnames morph acc = acc ++ isomorphOutRelVarNames morph++-- | Check that all mentioned relvars are actually present in the current schema.+validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError ()+validateRelationalExprInSchema schema relExprIn = relExprMogrify (\expr -> case expr of+                     RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)+                     ex -> Right ex) relExprIn >> pure ()+  where+    validRelVarNames = isomorphsInRelVarNames (isomorphs schema)+  +processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr+processRelationalExprInSchema schema relExprIn = do+  --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation)+  let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr+  validateRelationalExprInSchema schema relExprIn                    +  foldM processRelExpr relExprIn (isomorphs schema)+  +validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()  +validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) >> pure ()+  +processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr  +processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do+  let relExprMogrifier = processRelationalExprInSchema schema+  --validate that all mentioned relvars are in the valid set+  _ <- validateDatabaseContextExprInSchema schema dbExpr      +  --perform the morph+  foldM (\ex morph -> databaseContextExprMorph morph relExprMogrifier ex) dbExpr morphs++-- | If the database context expression adds or removes a relvar, we need to update the isomorphs to create a passthrough Isomorph.+processDatabaseContextExprSchemaUpdate :: Schema -> DatabaseContextExpr -> Schema+processDatabaseContextExprSchemaUpdate schema@(Schema morphs) expr = case expr of+  Define rv _ | S.notMember rv validSchemaName -> passthru rv+  Assign rv _ | S.notMember rv validSchemaName -> passthru rv+  Undefine rv | S.member rv validSchemaName -> Schema (filter (\morph -> elem rv (isomorphInRelVarNames morph)) morphs)+  MultipleExpr exprs -> foldr (\expr' schema' -> processDatabaseContextExprSchemaUpdate schema' expr') schema exprs+  _ -> schema+  where+    validSchemaName = isomorphsInRelVarNames morphs+    passthru rvname = Schema (morphs ++ [IsoRename rvname rvname])+    +processDatabaseContextExprSchemasUpdate :: Subschemas -> DatabaseContextExpr -> Subschemas    +processDatabaseContextExprSchemasUpdate subschemas expr = M.map (\schema -> processDatabaseContextExprSchemaUpdate schema expr) subschemas+  +-- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema! +-- weird compromise: allow inclusion dependencies failures not in the subschema to be propagated- in the worst case, only the inclusion dependency's name is leaked.+  {-+-- | Convert inclusion dependencies for display in a specific schema.+applySchemaToInclusionDependencies :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies+applySchemaToInclusionDependencies (Schema morphs) incDeps = +  let incDepMorph incDep = --check that the mentioned relvars are in fact in the current schema+  M.update incDepMorph incDeps        +  -}++-- | Morph a relational expression in one schema to another isomorphic schema.+relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)+relExprMorph (IsoRestrict relIn _ (relOutTrue, relOutFalse)) = \expr -> case expr of +  RelationVariable rv () | rv == relIn -> Right (Union (RelationVariable relOutTrue ()) (RelationVariable relOutFalse ()))+  orig -> Right orig+relExprMorph (IsoUnion (relInT, relInF) predi relTarget) = \expr -> case expr of+  --only the true predicate portion appears in the virtual schema  +  RelationVariable rv () | rv == relInT -> Right (Restrict predi (RelationVariable relTarget ()))++  RelationVariable rv () | rv == relInF -> Right (Restrict (NotPredicate predi) (RelationVariable relTarget ()))+  orig -> Right orig+relExprMorph (IsoRename relIn relOut) = \expr -> case expr of+  RelationVariable rv () | rv == relIn -> Right (RelationVariable relOut ())+  orig -> Right orig+  +relExprMogrify :: (RelationalExpr -> Either RelationalError RelationalExpr) -> RelationalExpr -> Either RelationalError RelationalExpr+relExprMogrify func (Project attrs expr) = func expr >>= \ex -> func (Project attrs ex)+relExprMogrify func (Union exprA exprB) = do+  exA <- func exprA+  exB <- func exprB+  func (Union exA exB)+relExprMogrify func (Join exprA exprB) = do+  exA <- func exprA+  exB <- func exprB+  func (Join exA exB)+relExprMogrify func (Rename n1 n2 expr) = func expr >>= \ex -> func (Rename n1 n2 ex)+relExprMogrify func (Difference exprA exprB) = do+  exA <- func exprA+  exB <- func exprB+  func (Difference exA exB)+relExprMogrify func (Group ns n expr) = func expr >>= \ex -> func (Group ns n ex)+relExprMogrify func (Ungroup n expr) = func expr >>= \ex -> func (Ungroup n ex)+relExprMogrify func (Restrict predi expr) = func expr >>= \ex -> func (Restrict predi ex)+relExprMogrify func (Equals exprA exprB) = do+  exA <- func exprA+  exB <- func exprB+  func (Equals exA exB)+relExprMogrify func (NotEquals exprA exprB) = do+  exA <- func exprA+  exB <- func exprB+  func (NotEquals exA exB)+relExprMogrify func (Extend ext expr) = func expr >>= \ex -> func (Extend ext ex)+relExprMogrify func other = func other++{-+spam :: Either RelationalError RelationalExpr+spam = relExprMogrify (relExprMorph (IsoRestrict "emp" TruePredicate (Just "nonboss", Just "boss"))) (RelationVariable "emp" ())++spam2 :: Either RelationalError RelationalExpr+spam2 = relExprMogrify (relExprMorph (IsoUnion ("boss", Just "nonboss") TruePredicate "emp")) (RelationVariable "boss" ()) +-}++databaseContextExprMorph :: SchemaIsomorph  -> (RelationalExpr -> Either RelationalError RelationalExpr) -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr+databaseContextExprMorph iso@(IsoRestrict rvIn filt (rvTrue, rvFalse)) relExprFunc expr = case expr of+  Assign rv relExpr | rv == rvIn -> do+    ex <- relExprFunc relExpr+    let trueExpr n = Assign n (Restrict filt ex)+        falseExpr n = Assign n (Restrict (NotPredicate filt) ex)+    pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]+  Insert rv relExpr | rv == rvIn -> do+    ex <- relExprFunc relExpr+    let trueExpr n = Insert n (Restrict filt ex)+        falseExpr n = Insert n (Restrict (NotPredicate filt) ex)+    pure $ MultipleExpr [trueExpr rvTrue, falseExpr rvFalse]+  Update rv attrMap predi | rv == rvIn -> do+    -- if the update would "shift" a tuple from the true->false relvar or vice versa, that would be a constraint violation in the virtual schema+    let trueExpr n = Update n attrMap (AndPredicate predi filt)+        falseExpr n = Update n attrMap (AndPredicate predi (NotPredicate filt))+    pure (MultipleExpr [trueExpr rvTrue, falseExpr rvFalse])+  MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs+  orig -> pure orig                                    +databaseContextExprMorph iso@(IsoUnion (rvTrue, rvFalse) filt rvOut) relExprFunc expr = case expr of   +  --assign: replace all instances in the portion of the target relvar with the new tuples from the relExpr+  --problem: between the delete->insert, constraints could be violated which would not otherwise be violated in the "in" schema. This implies that there should be a combo operator which can insert/update/delete in a single pass based on relexpr queries, or perhaps MultipleExpr should be the infamous "comma" operator from TutorialD?+  -- if any tuples are filtered out of the insert/assign, we need to simulate a constraint violation+  Assign rv relExpr | rv == rvTrue -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut filt,+                                                                                      Insert rvOut (Restrict filt ex)]+  Assign rv relExpr | rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ MultipleExpr [Delete rvOut (NotPredicate filt),            +                                                                                           Insert rvOut (Restrict (NotPredicate filt) ex)]+  Insert rv relExpr | rv == rvTrue || rv == rvFalse -> relExprFunc relExpr >>= \ex -> pure $ Insert rvOut ex+  Delete rv delPred | rv == rvTrue -> pure $ Delete rvOut (AndPredicate delPred filt)+  Delete rv delPred | rv == rvFalse -> pure $ Delete rvOut (AndPredicate delPred (NotPredicate filt))+  Update rv attrMap predi | rv == rvTrue -> pure $ Update rvOut attrMap (AndPredicate predi filt)+  Update rv attrMap predi | rv == rvFalse -> pure $ Update rvOut attrMap (AndPredicate (NotPredicate filt) predi)+  MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs+  orig -> pure orig+databaseContextExprMorph iso@(IsoRename relIn relOut) relExprFunc expr = case expr of+  Assign rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure (Assign relOut ex)+  Insert rv relExpr | rv == relIn -> relExprFunc relExpr >>= \ex -> pure $ Insert relOut ex+  Delete rv delPred | rv == relIn -> pure $ Delete relOut delPred+  Update rv attrMap predi | rv == relIn -> pure $ Update relOut attrMap predi+  MultipleExpr exprs -> MultipleExpr <$> mapM (databaseContextExprMorph iso relExprFunc) exprs  +  orig -> pure orig+  +-- | Apply the isomorphism transformations to the relational expression to convert the relational expression from operating on one schema to a disparate, isomorphic schema.+applyRelationalExprSchemaIsomorphs :: SchemaIsomorphs -> RelationalExpr -> Either RelationalError RelationalExpr+applyRelationalExprSchemaIsomorphs morphs expr = foldM (\expr' morph -> relExprMogrify (relExprMorph morph) expr') expr morphs++-- the morph must be applied in the opposite direction+--algorithm: create a relexpr for each relvar in the schema, then replace those rel exprs wherever they appear in the inc dep relexprs+-- x = x1 union x2+inclusionDependencyInSchema :: Schema -> InclusionDependency -> Either RelationalError InclusionDependency+inclusionDependencyInSchema schema (InclusionDependency rexprA rexprB) = do+  --collect all relvars which appear in the schema+  let schemaRelVars = isomorphsInRelVarNames (isomorphs schema)+  rvAssoc <- mapM (\rvIn -> do +                      rvOut <- processRelationalExprInSchema schema (RelationVariable rvIn ())+                      pure (rvOut, RelationVariable rvIn ())+                  )+             (S.toList schemaRelVars)+  let replacer exprOrig = foldM (\expr (find, replace) -> if expr == find then+                                                            pure replace+                                                          else+                                                            pure expr) exprOrig rvAssoc+  rexprA' <- relExprMogrify replacer rexprA+  rexprB' <- relExprMogrify replacer rexprB+  pure (InclusionDependency rexprA' rexprB')++-- #55 add two virtual constraints for IsoUnion and enforce them before the tuples disappear+-- this is needed to+-- also, it's inverse to IsoRestrict which adds two constraints at the base level+-- for IsoRestrict, consider hiding the two, generated constraints since they can never be thrown in the isomorphic schema+inclusionDependenciesInSchema :: Schema -> InclusionDependencies -> Either RelationalError InclusionDependencies+inclusionDependenciesInSchema schema incDeps = mapM (\(depName, dep) -> inclusionDependencyInSchema schema dep >>= \newDep -> pure (depName, newDep)) (M.toList incDeps) >>= pure . M.fromList+  +relationVariablesInSchema :: Schema -> DatabaseContext -> Either RelationalError RelationVariables+relationVariablesInSchema schema@(Schema morphs) context = 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+      pure (M.union newRvMap (M.fromList rvAssocs))++++{-+proposal+data DatabaseContext = +Concrete ...|+Virtual Isomorphs+-}+  +applyRelationVariablesSchemaIsomorphs :: SchemaIsomorphs -> RelationVariables -> Either RelationalError RelationVariables                                                                 +applyRelationVariablesSchemaIsomorphs = undefined+  ++applySchemaIsomorphsToDatabaseContext :: SchemaIsomorphs -> DatabaseContext -> Either RelationalError DatabaseContext+applySchemaIsomorphsToDatabaseContext morphs context = do+--  incdeps <- inclusionDependen morphs (inclusionDependencies context)+  relvars <- applyRelationVariablesSchemaIsomorphs morphs (relationVariables context)+  pure (context { --inclusionDependencies = incdeps,+                  relationVariables = relvars+                  --atomFunctions = atomfuncs,+                  --notifications = notifs,+                  --typeConstructorMapping = tconsmapping+                })+    +{-    +validate :: SchemaIsomorph -> S.Set RelVarName -> Either RelationalError SchemaIsomorph+validate morph underlyingRvNames = if S.size invalidRvNames > 0 then +                          Left (MultipleErrors (map RelVarNotDefinedError (S.toList invalidRvNames)))+                         else+                           Right morph+  where+    morphRvNames = S.fromList (isomorphOutRelVarNames morph)+    invalidRvNames = S.difference morphRvNames underlyingRvNames+-}++-- | Create inclusion dependencies mainly for IsoRestrict because the predicate should hold in the base schema.+createIncDepsForIsomorph :: SchemaName -> SchemaIsomorph -> InclusionDependencies+createIncDepsForIsomorph sname (IsoRestrict _ predi (rvTrue, rvFalse)) = let +  newIncDep predicate rv = InclusionDependency (Project AN.empty (Restrict predicate (RelationVariable rv ()))) (ExistingRelation relationTrue)+  incDepName b = "schema" <> "_" <> sname <> "_" <> T.pack (show b) in+  M.fromList [(incDepName True, newIncDep predi rvTrue),+              (incDepName False, newIncDep (NotPredicate predi) rvFalse)]+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 = do+  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+        (Just err, _) -> Left err+        (Nothing, (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+                                           pure (M.delete sname sschemas, context)+                                         else+                                           Left (SubschemaNameNotInUseError sname)+
+ src/lib/ProjectM36/Key.hs view
@@ -0,0 +1,44 @@+module ProjectM36.Key where+import ProjectM36.Base+import ProjectM36.Relation+import qualified Data.Set as S+import Data.Monoid++{-+keys can be implemented using inclusion dependencies as well: the count of the projection of the keys' attributes must be equal to the count of the tuples- p. 120 Database in Depth++example: +:showexpr ((relation{tuple{}}:{a:=S}):{b:=count(@a)}){b}+┌─┐+│b│+├─┤+│5│+└─┘+((relation{tuple{}}:{a:=S{S#}}):{b:=count(@a)}){b}+┌─┐+│b│+├─┤+│5│+└─┘+-}++-- | Create a uniqueness constraint for the attribute names and relational expression. Note that constraint can span multiple relation variables.+inclusionDependencyForKey :: AttributeNames -> RelationalExpr -> InclusionDependency+inclusionDependencyForKey attrNames relExpr = --InclusionDependency name (exprCount relExpr) (exprCount (projectedOnKeys relExpr))+ InclusionDependency equalityExpr (ExistingRelation relationFalse)+  where +    projectedOnKeys expr = Project attrNames expr+    exprAsSubRelation expr = Extend (AttributeExtendTupleExpr "a" (RelationAtomExpr expr)) (ExistingRelation relationTrue)+    exprCount expr = projectionForCount (Extend (AttributeExtendTupleExpr "b" (FunctionAtomExpr "count" [AttributeAtomExpr "a"] () )) (exprAsSubRelation expr))+    projectionForCount expr = Project (AttributeNames $ S.fromList ["b"]) expr+    equalityExpr = NotEquals (exprCount relExpr) (exprCount (projectedOnKeys relExpr))++-- | Create a 'DatabaseContextExpr' which can be used to add a uniqueness constraint to attributes on one relation variable.+databaseContextExprForUniqueKey :: RelVarName -> [AttributeName] -> DatabaseContextExpr+databaseContextExprForUniqueKey rvName attrNames = AddInclusionDependency (rvName <> "_key") $ inclusionDependencyForKey (AttributeNames (S.fromList attrNames)) (RelationVariable rvName ())++-- | Create a foreign key constraint from the first relation variable and attributes to the second.+databaseContextExprForForeignKey :: IncDepName -> (RelVarName, [AttributeName]) -> (RelVarName, [AttributeName]) -> DatabaseContextExpr+databaseContextExprForForeignKey fkName (rvA, attrsA) (rvB, attrsB) = AddInclusionDependency fkName $ InclusionDependency (Project (attrsL attrsA) (RelationVariable rvA ())) (Project (attrsL attrsB) (RelationVariable rvB ()))+  where+    attrsL = AttributeNames . S.fromList
+ src/lib/ProjectM36/MiscUtils.hs view
@@ -0,0 +1,9 @@+module ProjectM36.MiscUtils where++--returns duplicates of a pre-sorted list+dupes :: Eq a => [a] -> [a]    +dupes [] = []+dupes (_:[]) = []+dupes (x:y:[]) = if x == y then [x] else []+dupes (x:y:xs) = dupes(x:[y]) ++ dupes(y : xs)+
+ src/lib/ProjectM36/Notifications.hs view
@@ -0,0 +1,17 @@+module ProjectM36.Notifications where+import ProjectM36.Base+import ProjectM36.RelationalExpression+import Control.Monad.Trans.Reader+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+  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)++
+ src/lib/ProjectM36/Persist.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE ForeignFunctionInterface, CPP #-}+--this module is related to persisting Project:M36 structures to disk and not related to the persistent library+module ProjectM36.Persist (writeFileSync, +                           writeBSFileSync,+                           renameSync, +                           DiskSync(..)) where+-- on Windows, use FlushFileBuffers and MoveFileEx+import qualified Data.Text.IO as TIO+import Data.Text+#if defined(mingw32_HOST_OS)+import qualified System.Win32 as Win32+#else+import qualified System.Posix as Posix+#if defined(linux_HOST_OS)+import System.Posix.Unistd (fileSynchroniseDataOnly)+#else+import System.Posix.Unistd (fileSynchronise)+#endif+import System.Posix.IO (handleToFd)+import Foreign.C+#endif++import System.IO (withFile, IOMode(WriteMode), Handle)+import qualified Data.ByteString.Lazy as BS++#if defined(mingw32_HOST_OS)+import ProjectM36.Win32Handle+#else+foreign import ccall unsafe "cDirectoryFsync" cHSDirectoryFsync :: CString -> IO CInt+#endif++data DiskSync = NoDiskSync | FsyncDiskSync++writeFileSync :: DiskSync -> FilePath -> Text -> IO()+writeFileSync sync path strOut = withFile path WriteMode handler+  where+    handler handle = do+      TIO.hPutStr handle strOut+      syncHandle sync handle++renameSync :: DiskSync -> FilePath -> FilePath -> IO ()+renameSync sync srcPath dstPath = do+  atomicRename srcPath dstPath+  syncDirectory sync dstPath++-- System.Directory's renameFile/renameDirectory almost do exactly what we want except that it needlessly differentiates between directories and files+atomicRename :: FilePath -> FilePath -> IO ()+atomicRename srcPath dstPath = do+#if defined(mingw32_HOST_OS)+  Win32.moveFileEx srcPath dstPath Win32.mOVEFILE_REPLACE_EXISTING+#else+  Posix.rename srcPath dstPath+#endif++syncHandle :: DiskSync -> Handle -> IO ()+syncHandle FsyncDiskSync handle = do+#if defined(mingw32_HOST_OS)+  withHandleToHANDLE handle (\h -> Win32.flushFileBuffers h)+#elif defined(linux_HOST_OS)+  --fdatasync doesn't exist on macOS+  handleToFd handle >>= fileSynchroniseDataOnly+#else +  handleToFd handle >>= fileSynchronise+#endif+syncHandle NoDiskSync _ = pure ()++syncDirectory :: DiskSync -> FilePath -> IO ()+syncDirectory FsyncDiskSync path = directoryFsync path +syncDirectory NoDiskSync _ = pure ()++writeBSFileSync :: DiskSync -> FilePath -> BS.ByteString -> IO ()+writeBSFileSync sync path bstring = do+  withFile path WriteMode $ \handle -> do+    BS.hPut handle bstring+    syncHandle sync handle+  +directoryFsync :: FilePath -> IO ()+#if defined(mingw32_HOST_OS)+directoryFsync _ = pure () -- on Windows directory metadata cannot be synchronized- perhaps there is a workaround? resync a file in the directory? +#else+directoryFsync path = throwErrnoIfMinus1Retry_ "directoryFsync" (withCString path $ \cpath -> cHSDirectoryFsync cpath)+#endif+
+ src/lib/ProjectM36/Relation.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE GADTs,ExistentialQuantification #-}+module ProjectM36.Relation where+import qualified Data.Set as S+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+import qualified ProjectM36.AttributeNames as AS+import ProjectM36.TupleSet+import ProjectM36.Error+import qualified Control.Parallel.Strategies as P+import qualified ProjectM36.TypeConstructorDef as TCD+import qualified ProjectM36.DataConstructorDef as DCD+import qualified Data.Text as T+import Data.Either (isRight)+import System.Random.Shuffle+import Control.Monad.Random++attributes :: Relation -> Attributes+attributes (Relation attrs _ ) = attrs++attributeNames :: Relation -> S.Set AttributeName+attributeNames (Relation attrs _) = A.attributeNameSet attrs++attributeForName :: AttributeName -> Relation -> Either RelationalError Attribute+attributeForName attrName (Relation attrs _) = A.attributeForName attrName attrs++attributesForNames :: S.Set AttributeName -> Relation -> Attributes+attributesForNames attrNameSet (Relation attrs _) = A.attributesForNames attrNameSet attrs++atomTypeForName :: AttributeName -> Relation -> Either RelationalError AtomType+atomTypeForName attrName (Relation attrs _) = A.atomTypeForAttributeName attrName attrs++mkRelationFromList :: Attributes -> [[Atom]] -> Either RelationalError Relation+mkRelationFromList attrs atomMatrix = do+  tupSet <- mkTupleSetFromList attrs atomMatrix+  return $ Relation attrs tupSet+  +emptyRelationWithAttrs :: Attributes -> Relation  +emptyRelationWithAttrs attrs = Relation attrs emptyTupleSet++mkRelation :: Attributes -> RelationTupleSet -> Either RelationalError Relation+mkRelation attrs tupleSet = do+  --check that all tuples have the same keys+  --check that all tuples have keys (1-N) where N is the attribute count+  case verifyTupleSet attrs tupleSet of+    Left err -> Left err+    Right verifiedTupleSet -> return $ Relation attrs verifiedTupleSet+    +--less safe version of mkRelation skips verifyTupleSet+--useful for infinite or thunked tuple sets+--instead of returning a Left RelationalError, if a tuple does not match the relation's attributes, the tuple is simply removed+--duplicate tuples are NOT filtered by this creation method+mkRelationDeferVerify :: Attributes -> RelationTupleSet -> Either RelationalError Relation+mkRelationDeferVerify attrs tupleSet = return $ Relation attrs (RelationTupleSet (filter tupleFilter (asList tupleSet)))+  where+    tupleFilter tuple = isRight (verifyTuple attrs tuple)++mkRelationFromTuples :: Attributes -> [RelationTuple] -> Either RelationalError Relation+mkRelationFromTuples attrs tupleSetList = do+   tupSet <- mkTupleSet attrs tupleSetList+   mkRelation attrs tupSet++relationTrue :: Relation+relationTrue = Relation A.emptyAttributes singletonTupleSet++relationFalse :: Relation+relationFalse = Relation A.emptyAttributes emptyTupleSet++--if the relation contains one tuple, return it, otherwise Nothing+singletonTuple :: Relation -> Maybe RelationTuple+singletonTuple rel@(Relation _ tupleSet) = if cardinality rel == Finite 1 then+                                         Just $ head $ asList tupleSet+                                       else+                                         Nothing++union :: Relation -> Relation -> Either RelationalError Relation+union (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) =+  if not (A.attributesEqual attrs1 attrs2)+     then Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrs1 attrs2))+  else+    Right $ Relation attrs1 newtuples+  where+    newtuples = RelationTupleSet $ HS.toList . HS.fromList $ (asList tupSet1) ++ (map (reorderTuple attrs1) (asList tupSet2))++project :: AttributeNames -> Relation -> Either RelationalError Relation+project projectionAttrNames rel =+  case AS.projectionAttributesForAttributeNames (attributes rel) projectionAttrNames of+    Left err -> Left err+    Right newAttrs -> relFold (folder newAttrs) (Right $ Relation newAttrs emptyTupleSet) rel+  where+    folder newAttrs tupleToProject acc = case acc of+      Left err -> Left err+      Right acc2 -> union acc2 (Relation newAttrs (RelationTupleSet [tupleProject (A.attributeNameSet newAttrs) tupleToProject]))++rename :: AttributeName -> AttributeName -> Relation -> Either RelationalError Relation+rename oldAttrName newAttrName rel@(Relation oldAttrs oldTupSet) =+  if not attributeValid+       then Left $ AttributeNamesMismatchError (S.singleton oldAttrName)+  else if newAttributeInUse+       then Left $ AttributeNameInUseError newAttrName+  else+    mkRelation newAttrs newTupSet+  where+    newAttributeInUse = A.attributeNamesContained (S.singleton newAttrName) (attributeNames rel)+    attributeValid = A.attributeNamesContained (S.singleton oldAttrName) (attributeNames rel)+    newAttrs = A.renameAttributes oldAttrName newAttrName oldAttrs+    newTupSet = RelationTupleSet $ map tupsetmapper (asList oldTupSet)+    tupsetmapper tuple = tupleRenameAttribute oldAttrName newAttrName tuple++--the algebra should return a relation of one attribute and one row with the arity+arity :: Relation -> Int+arity (Relation attrs _) = A.arity attrs++degree :: Relation -> Int+degree = arity++cardinality :: Relation -> RelationCardinality --we need to detect infinite tuple sets- perhaps with a flag+cardinality (Relation _ tupSet) = Finite (length (asList tupSet))++--find tuples where the atoms in the relation which are NOT in the AttributeNameSet are equal+-- create a relation for each tuple where the attributes NOT in the AttributeNameSet are equal+--the attrname set attrs end up in the nested relation++--algorithm:+-- map projection of non-grouped attributes to restriction of matching grouped attribute tuples and then project on grouped attributes to construct the sub-relation+{-+group :: S.Set AttributeName -> AttributeName -> Relation -> Either RelationalError Relation+group groupAttrNames newAttrName rel@(Relation oldAttrs tupleSet) = do+  nonGroupProjection <- project nonGroupAttrNames rel+  relFold folder (Right (Relation newAttrs emptyTupleSet)) nonGroupProjection+  where+    newAttrs = M.union (attributesForNames nonGroupAttrNames rel) groupAttr+    groupAttr = Attribute newAttrName RelationAtomType (invertedAttributeNames groupAttrNames (attributes rel))+    nonGroupAttrNames = invertAttributeNames (attributes rel) groupAttrNames+    --map the projection to add the additional new attribute+    --create the new attribute (a new relation) by filtering and projecting the tupleSet+    folder tupleFromProjection acc = case acc of+      Left err -> Left err+      Right acc -> union acc (Relation newAttrs (HS.singleton (tupleExtend tupleFromProjection (matchingRelTuple tupleFromProjection))))+-}++--algorithm: self-join with image relation+group :: AttributeNames -> AttributeName -> Relation -> Either RelationalError Relation+group groupAttrNames newAttrName rel = do+  let nonGroupAttrNames = AS.invertAttributeNames groupAttrNames+  nonGroupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) nonGroupAttrNames+  groupProjectionAttributes <- AS.projectionAttributesForAttributeNames (attributes rel) groupAttrNames+  let groupAttr = Attribute newAttrName (RelationAtomType groupProjectionAttributes)+      matchingRelTuple tupIn = case imageRelationFor tupIn rel of+        Right rel2 -> RelationTuple (V.singleton groupAttr) (V.singleton (RelationAtom rel2))+        Left _ -> undefined+      mogrifier tupIn = pure (tupleExtend tupIn (matchingRelTuple tupIn))+      newAttrs = A.addAttribute groupAttr nonGroupProjectionAttributes+  nonGroupProjection <- project nonGroupAttrNames rel+  relMogrify mogrifier newAttrs nonGroupProjection+++--help restriction function+--returns a subrelation of+restrictEq :: RelationTuple -> Relation -> Either RelationalError Relation+restrictEq tuple rel = restrict rfilter rel+  where+    rfilter :: RelationTuple -> Bool+    rfilter tupleIn = tupleIntersection tuple tupleIn == tuple++-- unwrap relation-valued attribute+-- return error if relval attrs and nongroup attrs overlap+ungroup :: AttributeName -> Relation -> Either RelationalError Relation+ungroup relvalAttrName rel = case attributesForRelval relvalAttrName rel of+  Left err -> Left err+  Right relvalAttrs -> relFold relFolder (Right $ Relation newAttrs emptyTupleSet) rel+   where+    newAttrs = A.addAttributes relvalAttrs nonGroupAttrs+    nonGroupAttrs = A.deleteAttributeName relvalAttrName (attributes rel)+    relFolder :: RelationTuple -> Either RelationalError Relation -> Either RelationalError Relation+    relFolder tupleIn acc = case acc of+        Left err -> Left err+        Right accRel -> do+                        ungrouped <- tupleUngroup relvalAttrName newAttrs tupleIn+                        union accRel ungrouped++--take an relval attribute name and a tuple and ungroup the relval+tupleUngroup :: AttributeName -> Attributes -> RelationTuple -> Either RelationalError Relation+tupleUngroup relvalAttrName newAttrs tuple = do+  relvalRelation <- relationForAttributeName relvalAttrName tuple+  relFold folder (Right $ Relation newAttrs emptyTupleSet) relvalRelation+  where+    nonGroupTupleProjection = tupleProject nonGroupAttrNames tuple+    nonGroupAttrNames = A.attributeNameSet newAttrs+    folder tupleIn acc = case acc of+      Left err -> Left err+      Right accRel -> union accRel $ Relation newAttrs (RelationTupleSet [tupleExtend nonGroupTupleProjection tupleIn])++attributesForRelval :: AttributeName -> Relation -> Either RelationalError Attributes+attributesForRelval relvalAttrName (Relation attrs _) = do+  atomType <- A.atomTypeForAttributeName relvalAttrName attrs+  case atomType of+    (RelationAtomType relAttrs) -> Right relAttrs+    _ -> Left $ AttributeIsNotRelationValuedError relvalAttrName++restrict :: (RelationTuple -> Bool) -> Relation -> Either RelationalError Relation+--restrict rfilter (Relation attrs tupset) = Right $ Relation attrs $ HS.filter rfilter tupset+restrict rfilter (Relation attrs tupset) = Right $ Relation attrs processedTupSet+  where+    processedTupSet = RelationTupleSet ((filter rfilter (asList tupset)) `P.using` (P.parListChunk 1000 P.rdeepseq))++--joins on columns with the same name- use rename to avoid this- base case: cartesian product+--after changing from string atoms, there needs to be a type-checking step!+--this is a "nested loop" scan as described by the postgresql documentation+join :: Relation -> Relation -> Either RelationalError Relation+join (Relation attrs1 tupSet1) (Relation attrs2 tupSet2) = do+  newAttrs <- A.joinAttributes attrs1 attrs2+  let tupleSetJoiner accumulator tuple1 = do+        joinedTupSet <- singleTupleSetJoin newAttrs tuple1 tupSet2+        return $ joinedTupSet ++ accumulator+  newTupSetList <- foldM tupleSetJoiner [] (asList tupSet1)+  newTupSet <- mkTupleSet newAttrs newTupSetList+  return $ Relation newAttrs newTupSet+  +-- | Difference takes two relations of the same type and returns a new relation which contains only tuples which appear in the first relation but not the second.+difference :: Relation -> Relation -> Either RelationalError Relation  +difference relA relB = +  if not (A.attributesEqual (attributes relA) (attributes relB))+  then +    Left $ AttributeNamesMismatchError (A.attributeNameSet (A.attributesDifference attrsA attrsB))+  else +    restrict rfilter relA+  where+    attrsA = attributes relA+    attrsB = attributes relB+    rfilter tupInA = relFold (\tupInB acc -> if acc == False then False else if tupInB == tupInA then False else True) True relB+      +--a map should NOT change the structure of a relation, so attributes should be constant+relMap :: (RelationTuple -> Either RelationalError RelationTuple) -> Relation -> Either RelationalError Relation+relMap mapper (Relation attrs tupleSet) = do+  case forM (asList tupleSet) typeMapCheck of+    Right remappedTupleSet -> mkRelation attrs (RelationTupleSet remappedTupleSet)+    Left err -> Left err+  where+    typeMapCheck tupleIn = do+      remappedTuple <- mapper tupleIn+      if tupleAttributes remappedTuple == tupleAttributes tupleIn+        then Right remappedTuple+        else Left (TupleAttributeTypeMismatchError (A.attributesDifference (tupleAttributes tupleIn) attrs))++relMogrify :: (RelationTuple -> Either RelationalError RelationTuple) -> Attributes -> Relation -> Either RelationalError Relation+relMogrify mapper newAttributes (Relation _ tupSet) = do+  newTuples <- mapM mapper (asList tupSet)  +  mkRelationFromTuples newAttributes newTuples++relFold :: (RelationTuple -> a -> a) -> a -> Relation -> a+relFold folder acc (Relation _ tupleSet) = foldr folder acc (asList tupleSet)++--image relation as defined by CJ Date+--given tupleA and relationB, return restricted relation where tuple attributes are not the attribues in tupleA but are attributes in relationB and match the tuple's value++--check that matching attribute names have the same types+imageRelationFor ::  RelationTuple -> Relation -> Either RelationalError Relation+imageRelationFor matchTuple rel = do+  restricted <- restrictEq matchTuple rel --restrict across matching tuples+  let projectionAttrNames = AttributeNames $ A.nonMatchingAttributeNameSet (attributeNames rel) (tupleAttributeNameSet matchTuple)+  project projectionAttrNames restricted --project across attributes not in rel++--returns a relation-valued attribute image relation for each tuple in rel1+--algorithm:+  {-+imageRelationJoin :: Relation -> Relation -> Either RelationalError Relation+imageRelationJoin rel1@(Relation attrNameSet1 tupSet1) rel2@(Relation attrNameSet2 tupSet2) = do+  Right $ Relation undefined+  where+    matchingAttrs = matchingAttributeNameSet attrNameSet1 attrNameSet2+    newAttrs = nonMatchingAttributeNameSet matchingAttrs $ S.union attrNameSet1 attrNameSet2++    tupleSetJoiner tup1 acc = undefined+-}++-- | Return a Relation describing the types in the mapping.+typesAsRelation :: TypeConstructorMapping -> Either RelationalError Relation+typesAsRelation types = mkRelationFromTuples attrs tuples+  where+    attrs = A.attributesFromList [Attribute "TypeConstructor" TextAtomType,+                                Attribute "DataConstructors" dConsType]+    subAttrs = A.attributesFromList [Attribute "DataConstructor" TextAtomType]+    dConsType = RelationAtomType subAttrs+    tuples = map mkTypeConsDescription types+    +    mkTypeConsDescription (tCons, dConsList) = RelationTuple attrs (V.fromList [TextAtom (TCD.name tCons), mkDataConsRelation dConsList])+    +    mkDataConsRelation dConsList = case mkRelationFromTuples subAttrs $ map (\dCons -> RelationTuple subAttrs (V.singleton $ TextAtom $ T.intercalate " " ((DCD.name dCons):(map (T.pack . show) (DCD.fields dCons))))) dConsList of+      Left err -> error ("mkRelationFromTuples pooped " ++ show err)+      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+randomizeTupleOrder (Relation attrs tupSet) = do+  newTupSet <- shuffleM (asList tupSet)+  pure (Relation attrs (RelationTupleSet newTupSet))+
+ src/lib/ProjectM36/Relation/Parse/CSV.hs view
@@ -0,0 +1,53 @@+module ProjectM36.Relation.Parse.CSV where+--parse Relations from CSV+import Data.Csv.Parser+import qualified Data.Vector as V+import Data.Char (ord)+import qualified Data.ByteString.Lazy as BS+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.Error+import Data.Text.Encoding (decodeUtf8)+import qualified ProjectM36.Attribute as A+import qualified Data.Set as S+import Data.HashMap.Lazy as HM+import qualified Data.List as L+import qualified Data.Text as T+import Data.Attoparsec.ByteString.Lazy+import ProjectM36.Atom++data CsvImportError = CsvParseError String |+                      AttributeMappingError RelationalError |+                      HeaderAttributeMismatchError (S.Set AttributeName)+                    deriving (Show)++csvDecodeOptions :: DecodeOptions+csvDecodeOptions = DecodeOptions {decDelimiter = fromIntegral (ord ',')}++--special case from Text- outer quotes are *not* required in CSV, so we have to add them to make it parseable+makeAtomFromCSVText :: AttributeName -> AtomType -> T.Text -> Either RelationalError Atom+makeAtomFromCSVText attrName aType textIn = makeAtomFromText attrName aType $ if aType == TextAtomType then+                                                                                ("\"" `T.append` textIn `T.append` "\"")+                                                                              else+                                                                                textIn++csvAsRelation :: BS.ByteString -> Attributes -> Either CsvImportError Relation+csvAsRelation inString attrs = case parse (csvWithHeader csvDecodeOptions) inString of+  Fail _ _ err -> Left (CsvParseError err)+  Done _ (headerRaw,vecMapsRaw) -> do+    let strHeader = V.map decodeUtf8 headerRaw+        strMapRecords = V.map convertMap vecMapsRaw+        convertMap hmap = HM.fromList $ L.map (\(k,v) -> (decodeUtf8 k, (T.unpack . decodeUtf8) v)) (HM.toList hmap)+        attrNames = V.map A.attributeName attrs+        attrNameSet = S.fromList (V.toList attrNames)+        headerSet = S.fromList (V.toList strHeader)+        makeTupleList :: HM.HashMap AttributeName String -> [Either CsvImportError Atom]+        makeTupleList tupMap = V.toList $ V.map (\attr -> either (Left . AttributeMappingError) Right $ makeAtomFromCSVText (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! (A.attributeName attr))) attrs+    case attrNameSet == headerSet of+      False -> Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet)+      True -> do+        tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)+        case mkRelationFromList attrs tupleList of+          Left err -> Left (AttributeMappingError err)+          Right rel -> Right rel+
+ src/lib/ProjectM36/Relation/Show/CSV.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module ProjectM36.Relation.Show.CSV where+import ProjectM36.Base+import ProjectM36.Attribute+import Data.Csv+import ProjectM36.Tuple+import qualified Data.ByteString.Lazy as BS+import qualified Data.Vector as V+import ProjectM36.Error+import qualified Data.Text.Encoding as TE+import qualified Data.Text as T+import ProjectM36.Atom++--spit out error for relations without attributes (since relTrue and relFalse cannot be distinguished then as CSV) and for relations with relation-valued attributes+relationAsCSV :: Relation -> Either RelationalError BS.ByteString+relationAsCSV (Relation attrs tupleSet) = if relValAttrs /= [] then --check for relvalued attributes+                                            Left $ RelationValuedAttributesNotSupportedError (map attributeName relValAttrs)+                                            else if V.length attrs == 0 then --check that there is at least one attribute+                                                   Left $ TupleAttributeCountMismatchError 0+                                                 else+                                                   Right $ encodeByName bsAttrNames $ map RecordRelationTuple (asList tupleSet)+  where+    relValAttrs = V.toList $ V.filter (isRelationAtomType . atomType) attrs+    bsAttrNames = V.map (TE.encodeUtf8 . attributeName) attrs++{-+instance ToRecord RelationTuple where+  toRecord tuple = toRecord $ map toField (V.toList $ tupleAtoms tuple)+-}++newtype RecordRelationTuple = RecordRelationTuple {unTuple :: RelationTuple}++instance ToNamedRecord RecordRelationTuple where  +  toNamedRecord rTuple = namedRecord $ map (\(k,v) -> TE.encodeUtf8 k .= (RecordAtom v)) (tupleAssocs $ unTuple rTuple)+  +instance DefaultOrdered RecordRelationTuple where  +  headerOrder (RecordRelationTuple tuple) = V.map (TE.encodeUtf8 . attributeName) (tupleAttributes tuple)+  +newtype RecordAtom = RecordAtom {unAtom :: Atom}+      +instance ToField RecordAtom where+  toField (RecordAtom (ConstructedAtom dConsName _ atomList)) = TE.encodeUtf8 $ dConsName `T.append` T.intercalate " " (map atomToText atomList)+  toField (RecordAtom (TextAtom atomVal)) = TE.encodeUtf8 atomVal --squelch extraneous quotes for text type- the CSV library will add them if necessary+  toField (RecordAtom atomVal) = (TE.encodeUtf8 . atomToText) atomVal++
+ src/lib/ProjectM36/Relation/Show/Gnuplot.hs view
@@ -0,0 +1,91 @@+module ProjectM36.Relation.Show.Gnuplot where+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.Tuple+import ProjectM36.AtomFunctions.Primitive+import qualified ProjectM36.Attribute as A+import qualified Data.Vector as V++import qualified Graphics.Gnuplot.Plot.ThreeDimensional as Plot3D+import qualified Graphics.Gnuplot.Graph.ThreeDimensional as Graph3D++import qualified Graphics.Gnuplot.Plot.TwoDimensional as Plot2D+import qualified Graphics.Gnuplot.Graph.TwoDimensional as Graph2D++import qualified Graphics.Gnuplot.Advanced as GPA++--this module support plotting relations containing integer attributes with arity 1,2, or 3 only+--nested relations?++data PlotError = InvalidAttributeCountError |+                 InvalidAttributeTypeError+                 deriving (Show)++--plotRelation :: Relation -> Either PlotError++intFromAtomIndex :: Int -> RelationTuple -> Int+intFromAtomIndex index tup = (\i -> castInt i) $ (tupleAtoms tup) V.! index++graph1DRelation :: Relation -> Plot2D.T Int Int+graph1DRelation rel = Plot2D.list Graph2D.listPoints $ points1DRelation rel++points1DRelation :: Relation -> [Int]+points1DRelation rel = relFold folder [] rel+  where+    folder tup acc = intFromAtomIndex 0 tup : acc++graph2DRelation :: Relation -> Plot2D.T Int Int+graph2DRelation rel = Plot2D.list Graph2D.points (points2DRelation rel)++points2DRelation :: Relation -> [(Int, Int)]+points2DRelation rel = relFold folder [] rel+  where+    folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup) : acc++graph3DRelation :: Relation -> Plot3D.T Int Int Int+graph3DRelation rel = do+  Plot3D.cloud Graph3D.points $ points3DRelation rel++points3DRelation :: Relation -> [(Int, Int, Int)]+points3DRelation rel = relFold folder [] rel+  where+    folder tup acc = (intFromAtomIndex 0 tup, intFromAtomIndex 1 tup, intFromAtomIndex 2 tup) : acc++{-+sample1DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType]) [[IntAtom 2], [IntAtom 3]] of+  Right rel -> rel+  Left _ -> undefined++sample2DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType]) [[IntAtom 2, IntAtom 3],+                                                                                                                          [IntAtom 2, IntAtom 4]] of+                     Right rel -> rel+                     Left _ -> undefined++sample3DRelation = case mkRelationFromList (A.attributesFromList [Attribute "x" IntAtomType, Attribute "y" IntAtomType, Attribute "z" IntAtomType]) [[IntAtom 2, IntAtom 3, IntAtom 3],+                             [IntAtom 2, IntAtom 4, IntAtom 4]] of+                     Right rel -> rel+                     Left _ -> undefined++-}++plotRelation :: Relation -> IO (Maybe PlotError)+plotRelation rel = let attrTypes = V.replicate (arity rel) IntAtomType in+  if attrTypes /= A.atomTypes (attributes rel) then+    return $ Just InvalidAttributeTypeError+  else do+    case arity rel of+      1 -> (GPA.plotDefault $ graph1DRelation rel) >> return Nothing+      2 -> (GPA.plotDefault $ graph2DRelation rel) >> return Nothing+      3 -> (GPA.plotDefault $ graph3DRelation rel) >> return Nothing+      _ -> return $ Just InvalidAttributeCountError+++{-+--PNG+savePlottedRelation :: String -> Relation -> IO ()+savePlottedRelation path rel = case plotRelation rel of+  Left err -> putStrLn (show err)+  Right (Left g2d) -> plot' [] (PNG path) g2d >> return ()+  Right (Right g3d) -> plot' [] (PNG path) g3d >> return ()+-}+
+ src/lib/ProjectM36/Relation/Show/HTML.hs view
@@ -0,0 +1,37 @@+module ProjectM36.Relation.Show.HTML where+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.Tuple+import ProjectM36.Atom+import qualified Data.List as L+import ProjectM36.Attribute+import Data.Text (append, Text, pack)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO++attributesAsHTML :: Attributes -> Text+attributesAsHTML attrs = "<tr>" `append` (T.concat $ map oneAttrHTML attrNameList) `append` "</tr>"+  where+    oneAttrHTML attrName = "<th>" `append` attrName `append` "</th>"+    attrNameList = sortedAttributeNameList (attributeNameSet attrs)++relationAsHTML :: Relation -> Text+relationAsHTML rel@(Relation attrNameSet tupleSet) = "<table border=\"1\">" `append` (attributesAsHTML attrNameSet) `append` (tupleSetAsHTML tupleSet) `append` "<tfoot>" `append` tablefooter `append` "</tfoot></table>"+  where+    tablefooter = "<tr><td colspan=\"100%\">" `append` (pack $ show (cardinality rel)) `append` " tuples</td></tr>"++writeHTML :: Text -> IO ()+writeHTML = TIO.writeFile "/home/agentm/rel.html"++writeRel :: Relation -> IO ()+writeRel = writeHTML . relationAsHTML++tupleAsHTML :: RelationTuple -> Text+tupleAsHTML tuple = "<tr>" `append` T.concat (L.map tupleFrag (tupleSortedAssocs tuple)) `append` "</tr>"+  where+    tupleFrag tup = "<td>" `append` atomToText (snd tup) `append` "</td>"++tupleSetAsHTML :: RelationTupleSet -> Text+tupleSetAsHTML tupSet = foldr folder "" (asList tupSet)+  where+    folder tuple acc = acc `append` tupleAsHTML tuple
+ src/lib/ProjectM36/Relation/Show/Term.hs view
@@ -0,0 +1,155 @@+--writes Relation to a String suitable for terminal output+module ProjectM36.Relation.Show.Term where+import ProjectM36.Base+import ProjectM36.Atom+import ProjectM36.AtomType+import ProjectM36.Tuple+import ProjectM36.Relation+import ProjectM36.Attribute+import qualified Data.List as L+import qualified Data.Text as T+import qualified Data.Vector as V++boxV :: StringType+boxV = "│"+boxH :: StringType+boxH = "─"++boxTL :: StringType+boxTL = "┌"+boxTR :: StringType+boxTR = "┐"+boxBL :: StringType+boxBL = "└"+boxBR :: StringType+boxBR = "┘"++boxLB :: StringType+boxLB = "├"+boxRB :: StringType+boxRB = "┤"+boxTB :: StringType+boxTB = "┬"+boxBB :: StringType+boxBB = "┴"++boxC :: StringType+boxC = "┼"++dboxH :: StringType+dboxH = "═"+dboxL :: StringType+dboxL = "╞"+dboxR :: StringType+dboxR = "╡"++class TermSize a where+  termLength :: a -> Int++--represent a relation as a table similar to those drawn by Date+type Cell = StringType+type Table = ([Cell], [[Cell]]) --header, body++addRow :: [Cell] -> Table -> Table+addRow cells (header,body) = (header, body ++ [cells])++--calculate maximum per-row and per-column sizes++cellLocations :: Table -> ([Int],[Int]) --column size, row size+cellLocations tab@(header, _) = (maxWidths, maxHeights)+  where+    cellSizeMatrix = cellSizes tab+    maxWidths = foldl mergeMax (baseSize (length header)) (map fst cellSizeMatrix)+    baseSize num = take num (repeat 0)+    rowHeights = map snd cellSizeMatrix+    maxHeights = map (\l -> if length l == 0 then 0 else L.maximumBy compare l) rowHeights+    mergeMax a b = map (\(c,d) -> max c d) (zip a b)++--the normal "lines" function returns an empty list for an empty string which is not what we want+breakLines :: StringType -> [StringType]+breakLines "" = [""]+breakLines x = T.lines x++cellSizes :: Table -> [([Int], [Int])]+cellSizes (header, body) = map (\row -> (map maxRowWidth row, map (length . breakLines) row)) allRows+  where+    maxRowWidth row = if length (lengths row) == 0 then+                         0+                      else+                        L.maximumBy compare (lengths row)+    lengths row = map T.length (breakLines row)+    allRows = [header] ++ body+    +relationAsTable :: Relation -> Table+relationAsTable rel@(Relation _ tupleSet) = (header, body)+  where+    oAttrs = orderedAttributes rel+    oAttrNames = orderedAttributeNames rel+    header = map prettyAttribute oAttrs+    body :: [[Cell]]+    body = L.foldl' tupleFolder [] (asList tupleSet)+    tupleFolder acc tuple = acc ++ [map (\attrName -> case atomForAttributeName attrName tuple of+                                            Left _ -> "?"+                                            Right atom -> showAtom 0 atom+                                            ) oAttrNames]++showParens :: Bool -> StringType -> StringType+showParens predicate f = if predicate then+                      "(" `T.append` f `T.append` ")"+                    else+                      f++showAtom :: Int -> Atom -> StringType+showAtom _ (RelationAtom rel) = renderTable $ relationAsTable rel+showAtom level (ConstructedAtom dConsName _ atoms) = showParens (level >= 1 && length atoms >= 1) $ T.concat (L.intersperse " " (dConsName : (map (showAtom 1) atoms)))+showAtom _ atom = atomToText atom++renderTable :: Table -> StringType+renderTable table = renderHeader table (fst cellLocs) `T.append` renderBody (snd table) cellLocs+  where+    cellLocs = cellLocations table++renderHeader :: Table -> [Int] -> StringType+renderHeader (header, body) columnLocations = renderTopBar `T.append` renderHeaderNames `T.append` renderBottomBar+  where+    renderTopBar = boxTL `T.append` T.concat (L.intersperse boxTB (map (\x -> repeatString x boxH) columnLocations)) `T.append` boxTR `T.append` "\n"+    renderHeaderNames = renderRow header columnLocations 1 boxV+    renderBottomBar = if length body == 0 then ""+                      else renderHBar boxLB boxC boxRB columnLocations `T.append` "\n"++renderHBar :: StringType -> StringType -> StringType -> [Int] -> StringType+renderHBar left middle end columnLocations = left `T.append` T.concat (L.intersperse middle (map (\x -> repeatString x boxH) columnLocations)) `T.append` end++leftPaddedString :: Int -> Int -> StringType -> StringType+leftPaddedString lineNum size str = if lineNum > length paddedLines -1 then+                                      repeatString size " "+                                    else+                                      paddedLines !! lineNum+  where+    paddedLines = map (\line -> line `T.append` repeatString (size - T.length line) " ") (breakLines str)++renderRow :: [Cell] -> [Int] -> Int -> StringType -> StringType+renderRow cells columnLocations rowHeight interspersed = T.unlines $ map renderOneLine [0..rowHeight-1]+  where+    renderOneLine lineNum = boxV `T.append` T.concat (L.intersperse interspersed (map (\(size, value) -> leftPaddedString lineNum size value) (zip columnLocations cells))) `T.append` boxV++renderBody :: [[Cell]] -> ([Int],[Int]) -> StringType+renderBody cellMatrix cellLocs = renderRows `T.append` renderBottomBar+  where+    columnLocations = fst cellLocs+    rowLocations = snd cellLocs+    renderRows = T.concat (map (\(row, rowHeight)-> renderRow row columnLocations rowHeight boxV) rowHeightMatrix)+    rowHeightMatrix = zip cellMatrix (tail rowLocations)+    renderBottomBar = renderHBar boxBL boxBB boxBR columnLocations++orderedAttributes :: Relation -> [Attribute]+orderedAttributes rel = L.sortBy (\a b -> attributeName a `compare` attributeName b) (V.toList (attributes rel))++orderedAttributeNames :: Relation -> [AttributeName]+orderedAttributeNames rel = map attributeName (orderedAttributes rel)++repeatString :: Int -> StringType -> StringType+repeatString c s = T.concat (take c (repeat s))++showRelation :: Relation -> StringType+showRelation rel = renderTable (relationAsTable rel)
+ src/lib/ProjectM36/RelationalExpression.hs view
@@ -0,0 +1,855 @@+{-# 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 qualified ProjectM36.Attribute as A+import qualified Data.Map as M+import qualified Data.HashSet as HS+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 GHC+import GHC.Paths++data DatabaseContextExprDetails = CountUpdatedTuples++databaseContextExprDetailsFunc :: DatabaseContextExprDetails -> ResultAccumFunc+databaseContextExprDetailsFunc CountUpdatedTuples _ relIn = Relation attrs newTups+  where+    attrs = A.attributesFromList [Attribute "count" IntAtomType]+    existingTuple = case singletonTuple relIn of+      Just t -> t+      Nothing -> error "impossible counting error in singletonTuple"+    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 ctx = RelationalExprStateElems ctx++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 <- liftM (relationVariables . stateElemsContext) ask+  return $ case M.lookup name relvarTable of+    Just res -> Right res+    Nothing -> Left $ RelVarNotDefinedError name++evalRelationalExpr (Project attrNames expr) = do+    rel <- evalRelationalExpr expr+    case rel of+      Right rel2 -> return $ project attrNames rel2+      Left err -> return $ Left err++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) = do+  case mkRelation attributeSet tupleSet of+    Right rel -> return $ Right rel+    Left err -> return $ Left err+    +evalRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do+  currentContext <- liftM 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 _ -> do +        attrs <- mapM (\expr -> either throwE pure (evalAttrExpr tConss expr)) (fromMaybe [] mAttrExprs)+        pure (Just (A.attributesFromList attrs))+      Nothing -> pure Nothing+    tuples <- mapM (\expr -> liftE (evalTupleExpr mAttrs expr)) tupleExprs+    let attrs = fromMaybe firstTupleAttrs mAttrs+        firstTupleAttrs = if length tuples == 0 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 oldAttrNameSet newAttrName relExpr) = 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 -> return $ 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++--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 (Maybe RelationalError)+setRelVar relVarName rel = do+  currentContext <- getStateContext+  let newRelVars = M.insert relVarName rel $ relationVariables currentContext+      potentialContext = currentContext { relationVariables = newRelVars }+                        +  case checkConstraints potentialContext of+    Just err -> return $ Just err+    Nothing -> do+      putStateContext potentialContext+      return Nothing++-- it is not an error to delete a relvar which does not exist, just like it is not an error to insert a pre-existing tuple into a relation+deleteRelVar :: RelVarName -> DatabaseState (Maybe RelationalError)+deleteRelVar relVarName = do+  currContext <- getStateContext+  let relVars = relationVariables currContext+  if M.notMember relVarName relVars then+    pure Nothing+    else do+    let newRelVars = M.delete relVarName relVars+        newContext = currContext { relationVariables = newRelVars }+    putStateContext newContext+    pure Nothing++evalDatabaseContextExpr :: DatabaseContextExpr -> DatabaseState (Maybe RelationalError)+evalDatabaseContextExpr NoOperation = pure Nothing+  +evalDatabaseContextExpr (Define relVarName attrExprs) = do+  relvars <- liftM relationVariables getStateContext+  tConss <- liftM typeConstructorMapping getStateContext+  let eAttrs = map (evalAttrExpr tConss) attrExprs+  case lefts eAttrs of+    err:_ -> pure (Just err)+    [] -> case M.member relVarName relvars of+      True -> return (Just (RelVarAlreadyDefinedError relVarName))+      False -> setRelVar relVarName emptyRelation >> pure Nothing+        where+          attrs = A.attributesFromList (rights eAttrs)+          emptyRelation = Relation attrs emptyTupleSet++evalDatabaseContextExpr (Undefine relVarName) = do+  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 -> return $ Just 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+                            return $ Just (RelVarAssignmentTypeMismatchError 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 (Just err)+    Right unioned' -> case origRel of+      Left err -> pure (Just err)+      Right origRel' -> if cardinality unioned' == cardinality origRel' then --no tuples actually inserted+                          pure Nothing+                        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 (Just err)+    Right updatedRel' -> case origRel of+                      Left err -> pure (Just err)+                      Right origRel' -> if cardinality origRel' == cardinality updatedRel' then+                                          pure Nothing+                                        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 -> return $ Just (RelVarNotDefinedError relVarName)+    Just rel -> do+      case runReader (predicateRestrictionFilter (attributes rel) restrictionPredicateExpr) (RelationalExprStateElems context) of+        Left err -> return $ Just err+        Right predicateFunc -> do+          let ret = do+                restrictedPortion <- restrict predicateFunc rel+                if cardinality restrictedPortion == Finite 0 then +                  pure Nothing+                  else do+                  unrestrictedPortion <- restrict (not . predicateFunc) rel+                  updatedPortion <- relMap (updateTupleWithAtomExprs atomExprMap context) restrictedPortion+                  updatedRel <- union updatedPortion unrestrictedPortion+                  pure (Just updatedRel)+          case ret of +            Left err -> pure (Just err)+            Right Nothing -> pure Nothing+            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+    return $ Just (InclusionDependencyNameInUseError newDepName)+    else do+      let potentialContext = currContext { inclusionDependencies = newDeps }+      case checkConstraints potentialContext of+        Just err -> return $ Just err+        Nothing -> do+          putStateContext potentialContext+          return Nothing++evalDatabaseContextExpr (RemoveInclusionDependency depName) = do+  currContext <- getStateContext+  let currDeps = inclusionDependencies currContext+      newDeps = M.delete depName currDeps+  if M.notMember depName currDeps then+    return $ Just (InclusionDependencyNameNotInUseError depName)+    else do+    putStateContext $ currContext {inclusionDependencies = newDeps }+    return Nothing+    +-- | Add a notification which will send the resultExpr when triggerExpr changes between commits.+evalDatabaseContextExpr (AddNotification notName triggerExpr resultExpr) = do+  currentContext <- getStateContext+  let nots = notifications currentContext+  if M.member notName nots then+    return $ Just (NotificationNameInUseError notName)+    else do+      let newNotifications = M.insert notName newNotification nots+          newNotification = Notification { changeExpr = triggerExpr,+                                           reportExpr = resultExpr }+      putStateContext $ currentContext { notifications = newNotifications }+      return Nothing+  +evalDatabaseContextExpr (RemoveNotification notName) = do+  currentContext <- getStateContext+  let nots = notifications currentContext+  if M.notMember notName nots then+    return $ Just (NotificationNameNotInUseError notName)+    else do+    let newNotifications = M.delete notName nots+    putStateContext $ currentContext { notifications = newNotifications }+    return Nothing++-- | 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 of+    errs@(_:_) -> pure $ Just (someErrors errs)+    [] -> do+      if T.length tConsName < 1 || not (isUpper (T.head tConsName)) then+        pure $ Just (InvalidAtomTypeName tConsName)+        else if isJust (findTypeConstructor tConsName oldTypes) then+               pure $ Just (AtomTypeNameInUseError tConsName)+             else do+               let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]+               putStateContext $ currentContext { typeConstructorMapping = newTypes }+               pure Nothing++-- | 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 findTypeConstructor tConsName oldTypes == Nothing then+    pure $ Just (AtomTypeNameNotInUseError tConsName)+    else do+      let newTypes = filter (\(tCons, _) -> TCD.name tCons /= tConsName) oldTypes+      putStateContext $ currentContext { typeConstructorMapping = newTypes }+      pure Nothing++evalDatabaseContextExpr (MultipleExpr exprs) = do+  --the multiple expressions must pass the same context around- not the old unmodified context+  evald <- forM exprs evalDatabaseContextExpr+  --some lifting magic needed here+  case catMaybes evald of+    [] -> return $ Nothing+    err:_ -> return $ Just err+             +evalDatabaseContextExpr (RemoveAtomFunction funcName) = do+  currentContext <- getStateContext+  let atomFuncs = atomFunctions currentContext+  case atomFunctionForName funcName atomFuncs of+    Left err -> pure (Just err)+    Right realFunc -> if isScriptedAtomFunction realFunc then do+      let updatedFuncs = HS.delete realFunc atomFuncs+      putStateContext (currentContext {atomFunctions = updatedFuncs })+      pure Nothing+                      else+                        pure (Just (PrecompiledFunctionRemoveError funcName))++      +evalDatabaseContextExpr (RemoveDatabaseContextFunction funcName) = do      +  context <- getStateContext+  let dbcFuncs = dbcFunctions context+  case databaseContextFunctionForName funcName dbcFuncs of+    Left err -> pure (Just err)+    Right realFunc -> if isScriptedDatabaseContextFunction realFunc then do+      let updatedFuncs = HS.delete realFunc dbcFuncs+      putStateContext (context { dbcFunctions = updatedFuncs })+      pure Nothing+                      else+                        pure (Just (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 (Just err)+      Right func -> do+        let expectedArgCount = length (dbcFuncType func)+            actualArgCount = length atomArgExprs+        if expectedArgCount /= actualArgCount then+          pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))+          else do+          --check that the atom types are valid+          case lefts eAtomTypes of+            _:_ -> pure (Just (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 (Just (someErrors (lefts eAtomArgs)))+                else if length typeErrors > 0 then+                     pure (Just (someErrors typeErrors))                   +                   else do+                     case evalDatabaseContextFunction func (rights eAtomArgs) context of+                       Left err -> pure (Just err)+                       Right newContext -> putStateContext newContext >> pure Nothing+      +evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)+evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) = do+  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 -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) 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 do+                  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) = do+  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)) 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 do+                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')+              +    +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 -> Maybe RelationalError+checkConstraints context = case failures of+  [] -> Nothing+  l:_ -> Just l+  where+    failures = M.elems $ M.mapMaybeWithKey checkIncDep deps+    deps = inclusionDependencies context+    eval expr = runReader (evalRelationalExpr expr) (RelationalExprStateElems context)+    checkIncDep depName (InclusionDependency subsetExpr supersetExpr) = do+      let checkExpr = Equals supersetExpr (Union subsetExpr supersetExpr)+      case eval checkExpr of+        Left err -> Just err+        Right resultRel -> if resultRel == relationTrue then+                                   Nothing+                                else +                                  Just $ 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'+  pure (runReader (evalRelationalExpr expr) rstate')++--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 (RelationTuple -> Bool))+predicateRestrictionFilter attrs (AndPredicate expr1 expr2) = do+  runExceptT $ do+    expr1v <- liftE (predicateRestrictionFilter attrs expr1)+    expr2v <- liftE (predicateRestrictionFilter attrs expr2)+    pure (\x -> expr1v x && expr2v x)++predicateRestrictionFilter attrs (OrPredicate expr1 expr2) = do+  runExceptT $ do+    expr1v <- liftE (predicateRestrictionFilter attrs expr1)+    expr2v <- liftE (predicateRestrictionFilter attrs expr2)+    pure (\x -> expr1v x || expr2v x)++predicateRestrictionFilter _ TruePredicate = pure (Right (\_ -> True))++predicateRestrictionFilter attrs (NotPredicate expr) = do+  runExceptT $ do+    exprv <- liftE (predicateRestrictionFilter attrs expr)+    pure (\x -> not (exprv x))++predicateRestrictionFilter _ (RelationalExprPredicate relExpr) = runExceptT $ do+    --merge attrs into to state attributes+    rel <- liftE (evalRelationalExpr relExpr)+    if rel == relationTrue then+      pure (\_ -> True)+      else if rel == relationFalse then+             pure (\_ -> False)+           else+             throwE (PredicateExpressionError "Relational restriction filter must evaluate to 'true' or 'false'")++predicateRestrictionFilter attrs (AttributeEqualityPredicate attrName atomExpr) = do+  --merge attrs into the state attributes+  rstate <- ask+  runExceptT $ do+    atomExprType <- liftE (typeFromAtomExpr attrs atomExpr)+    attr <- either throwE pure (A.attributeForName attrName attrs)+    if atomExprType /= A.atomType attr then+      throwE (TupleAttributeTypeMismatchError (A.attributesFromList [attr]))+      else+      pure $ \tupleIn -> case atomForAttributeName attrName tupleIn of+        Left _ -> False+        Right atomIn -> +          let atomEvald = runReader (evalAtomExpr tupleIn atomExpr) rstate in+          case atomEvald of+            Right atomCmp -> atomCmp == atomIn+            Left _ -> False+-- 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 -> do+                case runReader (evalAtomExpr tupleIn atomExpr) rstate of+                  Left _ -> False+                  Right boolAtomValue -> 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 <- liftM 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 [_] = []+        safeInit [] = [] -- different behavior from normal init+        safeInit (_:xs) = safeInit xs+    if expectedArgCount /= actualArgCount then+      throwE (FunctionArgumentCountMismatch expectedArgCount actualArgCount)+      else do+      _ <- mapM (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))+      evaldArgs <- mapM (\arg -> liftE (evalAtomExpr tupIn arg)) arguments+      case evalAtomFunction func evaldArgs of+        Left err -> throwE (AtomFunctionUserError err)+        Right 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+  --first, check if the attribute is in the immediate attributes+  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 <- liftM 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 = reverse (tail (reverse (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 (\arg -> liftE (typeFromAtomExpr attrs arg)) dConsArgs  +    context <- liftM stateElemsContext (lift ask)+    aType <- either throwE pure (atomTypeForDataConstructor (typeConstructorMapping context) dConsName argsTypes)+    pure aType++-- | 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 -> pure 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 do+      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 <- atomTypeForTypeConstructor tCons aTypes+  Right (Attribute attrName aType)+  +evalAttrExpr _ (NakedAttributeExpr attr) = Right attr+  +evalTupleExpr :: Maybe Attributes -> TupleExpr -> RelationalExprState (Either RelationalError RelationTuple)+evalTupleExpr attrs (TupleExpr tupMap) = do+  context <- liftM 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+    attrAtoms <- mapM (\(attrName, aExpr) -> do+                          newAtomType <- liftE (typeFromAtomExpr A.emptyAttributes aExpr)+                          newAtom <- liftE (evalAtomExpr emptyTuple aExpr)+                          pure (attrName, newAtom, newAtomType)+                      ) (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 attrs+    --verify that the attributes match+    when (A.attributeNameSet finalAttrs /= A.attributeNameSet tupAttrs) $ throwE (TupleAttributeTypeMismatchError tupAttrs)+    tup' <- either throwE pure (resolveTypesInTuple finalAttrs (reorderTuple finalAttrs tup))+    _ <- either throwE pure (validateTuple tup' tConss)+    pure tup'+
+ src/lib/ProjectM36/ScriptSession.hs view
@@ -0,0 +1,173 @@+module ProjectM36.ScriptSession where++import ProjectM36.Error++import Control.Exception+import Control.Monad+import System.IO.Error+import System.Directory+import Control.Monad.IO.Class+import System.FilePath.Glob+import System.FilePath+import Data.Text (Text, unpack)+import Data.Maybe++import GHC+import GHC.Paths (libdir)+#if __GLASGOW_HASKELL__ >= 800+import GHC.LanguageExtensions+#endif+import DynFlags+import Panic+import Outputable --hiding ((<>))+import PprTyThing+import Unsafe.Coerce+import Type hiding (pprTyThing)  ++data ScriptSession = ScriptSession {+  hscEnv :: HscEnv, +  atomFunctionBodyType :: Type,+  dbcFunctionBodyType :: Type+  }+                     +data ScriptSessionError = ScriptSessionLoadError GhcException+                          deriving (Show)++-- | Configure a GHC environment/session which we will use for all script compilation.+initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)+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+  let homeDir = either (const "/") id eHomeDir+  let excHandler exc = pure $ Left (ScriptSessionLoadError exc)+  handleGhcException excHandler $ runGhc (Just libdir) $ do+    dflags <- getSessionDynFlags+    let ghcVersion = projectVersion dflags++    sandboxPkgPaths <- liftIO $ liftM concat $ mapM glob [+      "./dist-newstyle/packagedb/ghc-" ++ ghcVersion,+      ".cabal-sandbox/*ghc-" ++ ghcVersion ++ "-packages.conf.d", +      homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"+      ]+    +    let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)+      +    let dflags' = applyGopts . applyXopts $ dflags { hscTarget = HscInterpreted , +                           ghcLink = LinkInMemory, +                           safeHaskell = Sf_Trustworthy,+                           safeInfer = True,+                           safeInferred = True,+                           --verbosity = 3,+#if __GLASGOW_HASKELL__ >= 800                           +                           trustFlags = map TrustPackage required_packages,+#endif                                        +                           packageFlags = (packageFlags dflags) ++ packages,+                           extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])+                         }+        applyGopts flags = foldl gopt_set flags gopts+        applyXopts flags = foldl xopt_set flags xopts+#if __GLASGOW_HASKELL__ >= 800+        xopts = [OverloadedStrings, ExtendedDefaultRules, ImplicitPrelude, ScopedTypeVariables]+#else               +        xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude,  Opt_ScopedTypeVariables]+#endif+        gopts = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]+        required_packages = ["base", +                             "containers",+                             "Glob",+                             "directory",+                             "unordered-containers",+                             "hashable",+                             "uuid",+                             "vector",+                             "text",+                             "binary",+                             "vector-binary-instances",+                             "time",+                             "project-m36",+                             "bytestring"]+#if __GLASGOW_HASKELL__ >= 800+        packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages+#else+        packages = map TrustPackage required_packages+#endif+  --liftIO $ traceShowM (showSDoc dflags' (ppr packages))+    _ <- setSessionDynFlags dflags'+    let safeImportDecl mn mQual = ImportDecl {+          ideclSourceSrc = Nothing,+          ideclName      = noLoc mn,+          ideclPkgQual   = Nothing,+          ideclSource    = False,+          ideclSafe      = True,+          ideclImplicit  = False,+          ideclQualified = (isJust mQual),+          ideclAs        = mQual,+          ideclHiding    = Nothing+          }+        unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn) Nothing) [+          "Prelude",+          "Data.Map",+          "Data.Either",+          "Data.Time.Calendar",+          "Control.Monad.State",+          "ProjectM36.Base",+          "ProjectM36.Relation",+          "ProjectM36.AtomFunctionError",+          "ProjectM36.DatabaseContextFunctionError",+          "ProjectM36.RelationalExpression"]+        qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl (mkModuleName modn) (Just (mkModuleName qualNam))) [+          ("Data.Text", "T")+          ]+    setContext (unqualifiedModules ++ qualifiedModules)+    env <- getSession+    atomFuncType <- mkTypeForName "AtomFunctionBodyType"+    dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"+    pure (Right (ScriptSession env atomFuncType dbcFuncType))++addImport :: String -> Ghc ()+addImport moduleNam = do+  ctx <- getContext+  setContext ( (IIDecl $ simpleImportDecl (mkModuleName moduleNam)) : ctx )+  +showType :: DynFlags -> Type -> String+showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)++mkTypeForName :: String -> Ghc Type+mkTypeForName name = do+  lBodyName <- parseName name+  case lBodyName of+    [] -> error ("failed to parse " ++ name)+    _:_:_ -> error "too many name matches"+    bodyName:[] -> do+      mThing <- lookupName bodyName+      case mThing of+        Nothing -> error ("failed to find " ++ name)+        Just (ATyCon tyCon) -> case synTyConRhs_maybe tyCon of+          Just typ -> pure typ+          Nothing -> error (name ++ " is not a type synonym")+        Just _ -> error ("failed to find type synonym " ++ name)++compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)+compileScript funcType script = do+  let sScript = unpack script+  mErr <- typeCheckScript funcType script+  case mErr of+    Just err -> pure (Left err)+    Nothing -> do+      --catch exception here+      --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example.+      -- we can't use dynCompileExpr here because+      func <- compileExpr sScript+      pure $ Right (unsafeCoerce func)+      +typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)    +typeCheckScript expectedType inp = do+  dflags <- getSessionDynFlags  +  --catch exception for SyntaxError+  funcType <- GHC.exprType (unpack inp)+  --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType +  if eqType funcType expectedType then+    pure Nothing+    else+    pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))+
+ src/lib/ProjectM36/Server.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE ScopedTypeVariables #-}+module ProjectM36.Server where++import ProjectM36.Client+import ProjectM36.Server.EntryPoints +import ProjectM36.Server.RemoteCallTypes+import ProjectM36.Server.Config (ServerConfig(..))++import Control.Monad.IO.Class (liftIO)+import Network.Transport.TCP (createTransport, defaultTCPParameters)+import Network.Transport (EndPointAddress(..), newEndPoint, address)+import Control.Distributed.Process.Node (initRemoteTable, runProcess, newLocalNode, initRemoteTable)+import Control.Distributed.Process.Extras.Time (Delay(..))+import Control.Distributed.Process (Process, register, getSelfPid)+import Control.Distributed.Process.ManagedProcess (defaultProcess, UnhandledMessagePolicy(..), ProcessDefinition(..), handleCall, serve, InitHandler, InitResult(..))+import Control.Concurrent.MVar (putMVar, MVar)+import System.IO (stderr, hPutStrLn)++-- the state should be a mapping of remote connection to the disconnected transaction- the graph should be the same, so discon must be removed from the stm tuple+--trying to refactor this for less repetition is very challenging because the return type cannot be polymorphic or the distributed-process call gets confused and drops messages+serverDefinition :: Bool -> Timeout -> ProcessDefinition Connection+serverDefinition testBool ti = defaultProcess {+  apiHandlers = [                 +     handleCall (\conn (ExecuteHeadName sessionId) -> handleExecuteHeadName ti sessionId conn),+     handleCall (\conn (ExecuteRelationalExpr sessionId expr) -> handleExecuteRelationalExpr ti sessionId conn expr),+     handleCall (\conn (ExecuteDatabaseContextExpr sessionId expr) -> handleExecuteDatabaseContextExpr ti sessionId conn expr),+     handleCall (\conn (ExecuteDatabaseContextIOExpr sessionId expr) -> handleExecuteDatabaseContextIOExpr ti sessionId conn expr),+     handleCall (\conn (ExecuteGraphExpr sessionId expr) -> handleExecuteGraphExpr ti sessionId conn expr),+     handleCall (\conn (ExecuteTransGraphRelationalExpr sessionId expr) -> handleExecuteTransGraphRelationalExpr ti sessionId conn expr),     +     handleCall (\conn (ExecuteTypeForRelationalExpr sessionId expr) -> handleExecuteTypeForRelationalExpr ti sessionId conn expr),+     handleCall (\conn (RetrieveInclusionDependencies sessionId) -> handleRetrieveInclusionDependencies ti sessionId conn),+     handleCall (\conn (RetrievePlanForDatabaseContextExpr sessionId dbExpr) -> handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr),+     handleCall (\conn (RetrieveHeadTransactionId sessionId) -> handleRetrieveHeadTransactionId ti sessionId conn),+     handleCall (\conn (RetrieveTransactionGraph sessionId) -> handleRetrieveTransactionGraph ti sessionId conn),+     handleCall (\conn (Login procId) -> handleLogin ti conn procId),+     handleCall (\conn (CreateSessionAtHead headn) -> handleCreateSessionAtHead ti headn conn),+     handleCall (\conn (CreateSessionAtCommit commitId) -> handleCreateSessionAtCommit ti commitId conn),+     handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),+     handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),+     handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),+     handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),+     handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),+     handleCall (\conn Logout -> handleLogout ti conn)+     ] ++ testModeHandlers,+  unhandledMessagePolicy = Terminate+  --unhandledMessagePolicy = Log+  }+  where+    testModeHandlers = if not testBool then+                         []+                       else+                         [handleCall (\conn (TestTimeout sessionId) -> handleTestTimeout ti sessionId conn)]+                               +                 +initServer :: InitHandler (Connection, DatabaseName, Maybe (MVar EndPointAddress), EndPointAddress) Connection+initServer (conn, dbname, mAddressMVar, saddress) = do+  registerDB dbname+  case mAddressMVar of+       Nothing -> pure ()+       Just addressMVar -> liftIO $ putMVar addressMVar saddress+  --traceShowM ("server started on " ++ show saddress)+  pure $ InitOk conn Infinity++registerDB :: DatabaseName -> Process ()+registerDB dbname = do+  self <- getSelfPid+  let dbname' = remoteDBLookupName dbname  +  register dbname' self+  --liftIO $ putStrLn $ "registered " ++ (show self) ++ " " ++ dbname'++-- | A notification callback which logs the notification to stderr and does nothing else.+loggingNotificationCallback :: NotificationCallback+loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received \"" ++ show notName ++ "\": " ++ show evaldNot++-- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.+launchServer :: ServerConfig -> Maybe (MVar EndPointAddress) -> IO (Bool)+launchServer daemonConfig mAddressMVar = do  +  econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))+  case econn of +    Left err -> do      +      hPutStrLn stderr ("Failed to create database connection: " ++ show err)+      pure False+    Right conn -> do+      let hostname = bindHost daemonConfig+          port = bindPort daemonConfig+      etransport <- createTransport hostname (show port) defaultTCPParameters+      case etransport of+        Left err -> error ("failed to create transport: " ++ show err)+        Right transport -> do+          eEndpoint <- newEndPoint transport+          case eEndpoint of +            Left err -> hPutStrLn stderr ("Failed to create transport: " ++ show err) >> pure False+            Right endpoint -> do+              localTCPNode <- newLocalNode transport initRemoteTable+              --traceShowM ("newLocalNode in Server " ++ show (localNodeId localTCPNode))+              runProcess localTCPNode $ do+                let testBool = testMode daemonConfig+                    reqTimeout = perRequestTimeout daemonConfig+                serve (conn, databaseName daemonConfig, mAddressMVar, (address endpoint)) initServer (serverDefinition testBool reqTimeout)+              liftIO $ putStrLn "serve returned"+              pure True+
+ src/lib/ProjectM36/Server/Config.hs view
@@ -0,0 +1,22 @@+module ProjectM36.Server.Config where+import ProjectM36.Client++data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy, +                                   databaseName :: DatabaseName,+                                   bindHost :: Hostname,+                                   bindPort :: Port,+                                   ghcPkgPaths :: [String], -- used for AtomFunction dynamic compilation+                                   perRequestTimeout :: Int,+                                   testMode :: Bool -- used exclusively for automated testing of the server, thus not accessible from the command line+                                   }+                    deriving (Show)++defaultServerConfig :: ServerConfig+defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,+                                     databaseName = "base", +                                     bindHost = "127.0.0.1",+                                     bindPort = 6543,+                                     ghcPkgPaths = [],+                                     perRequestTimeout = 0,+                                     testMode = False+                                     }
+ src/lib/ProjectM36/Server/EntryPoints.hs view
@@ -0,0 +1,144 @@+module ProjectM36.Server.EntryPoints where+import ProjectM36.Base hiding (inclusionDependencies)+import ProjectM36.IsomorphicSchema+import ProjectM36.Client+import ProjectM36.Error+import Control.Distributed.Process (Process, ProcessId)+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)++timeoutOrDie :: Serializable a => Timeout -> IO a -> Process (Either ServerError a)+timeoutOrDie micros act = do+  if micros == 0 then+    liftIO act >>= \x -> pure (Right x)+    else do+    asyncUnit <- async (task (liftIO act))+    asyncRes <- waitCancelTimeout micros asyncUnit+    case asyncRes of+      AsyncDone x -> pure (Right x)+      AsyncCancelled -> pure (Left RequestTimeoutError)+      AsyncFailed reason -> pure (Left (ProcessDiedError (show reason)))+      AsyncLinkFailed reason -> pure (Left (ProcessDiedError (show reason)))+      AsyncPending -> pure (Left (ProcessDiedError "process pending"))+    +type Timeout = Int++type Reply a = Process (ProcessReply (Either ServerError a) Connection)+    +handleExecuteRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)+handleExecuteRelationalExpr ti sessionId conn expr = do+  ret <- timeoutOrDie ti (executeRelationalExpr sessionId conn expr)+  reply ret conn+  +handleExecuteDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Maybe RelationalError)+handleExecuteDatabaseContextExpr ti sessionId conn dbexpr = do+  ret <- timeoutOrDie ti (executeDatabaseContextExpr sessionId conn dbexpr)+  reply ret conn+  +handleExecuteDatabaseContextIOExpr :: Timeout -> SessionId -> Connection -> DatabaseContextIOExpr -> Reply (Maybe RelationalError)+handleExecuteDatabaseContextIOExpr ti sessionId conn dbexpr = do+  ret <- timeoutOrDie ti (executeDatabaseContextIOExpr sessionId conn dbexpr)+  reply ret conn+  +handleExecuteHeadName :: Timeout -> SessionId -> Connection -> Reply (Maybe HeadName)+handleExecuteHeadName ti sessionId conn = do+  ret <- timeoutOrDie ti (headName sessionId conn)+  reply ret conn+  +handleLogin :: Timeout -> Connection -> ProcessId -> Reply Bool+handleLogin ti conn newClientProcessId = do+  ret <- timeoutOrDie ti (addClientNode conn newClientProcessId)+  case ret of+    Right () -> reply (Right True) conn+    Left err -> reply (Left err) conn+  +handleExecuteGraphExpr :: Timeout -> SessionId -> Connection -> TransactionGraphOperator -> Reply (Maybe RelationalError)+handleExecuteGraphExpr ti sessionId conn graphExpr = do+  ret <- timeoutOrDie ti (executeGraphExpr sessionId conn graphExpr)+  reply ret conn+  +handleExecuteTransGraphRelationalExpr :: Timeout -> SessionId -> Connection -> TransGraphRelationalExpr -> Reply (Either RelationalError Relation)+handleExecuteTransGraphRelationalExpr ti sessionId conn graphExpr = do+  ret <- timeoutOrDie ti (executeTransGraphRelationalExpr sessionId conn graphExpr)+  reply ret conn++handleExecuteTypeForRelationalExpr :: Timeout -> SessionId -> Connection -> RelationalExpr -> Reply (Either RelationalError Relation)+handleExecuteTypeForRelationalExpr ti sessionId conn relExpr = do+  ret <- timeoutOrDie ti (typeForRelationalExpr sessionId conn relExpr)+  reply ret conn+  +handleRetrieveInclusionDependencies :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError (Map IncDepName InclusionDependency))+handleRetrieveInclusionDependencies ti sessionId conn = do+  ret <- timeoutOrDie ti (inclusionDependencies sessionId conn)+  reply ret conn+  +handleRetrievePlanForDatabaseContextExpr :: Timeout -> SessionId -> Connection -> DatabaseContextExpr -> Reply (Either RelationalError DatabaseContextExpr)+handleRetrievePlanForDatabaseContextExpr ti sessionId conn dbExpr = do+  ret <- timeoutOrDie ti (planForDatabaseContextExpr sessionId conn dbExpr)+  reply ret conn+  +handleRetrieveTransactionGraph :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation) +handleRetrieveTransactionGraph ti sessionId conn = do  +  ret <- timeoutOrDie ti (transactionGraphAsRelation sessionId conn)+  reply ret conn+  +handleRetrieveHeadTransactionId :: Timeout -> SessionId -> Connection -> Reply (Maybe TransactionId)+handleRetrieveHeadTransactionId ti sessionId conn = do+  ret <- timeoutOrDie ti (headTransactionId sessionId conn)+  reply ret conn+  +handleCreateSessionAtCommit :: Timeout -> TransactionId -> Connection -> Reply (Either RelationalError SessionId)+handleCreateSessionAtCommit ti commitId conn = do+  ret <- timeoutOrDie ti (createSessionAtCommit commitId conn)+  reply ret conn+  +handleCreateSessionAtHead :: Timeout -> HeadName -> Connection -> Reply (Either RelationalError SessionId)+handleCreateSessionAtHead ti headn conn = do+  ret <- timeoutOrDie ti (createSessionAtHead headn conn)+  reply ret conn+  +handleCloseSession :: Timeout -> SessionId -> Connection -> Reply ()   +handleCloseSession ti sessionId conn = do+  ret <- timeoutOrDie ti (closeSession sessionId conn)+  case ret of+    Right () -> reply (Right ()) conn+    Left err -> reply (Left err) conn+  +handleRetrieveAtomTypesAsRelation :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)+handleRetrieveAtomTypesAsRelation ti sessionId conn = do+  ret <- timeoutOrDie ti (atomTypesAsRelation sessionId conn)+  reply ret conn+  +-- | Returns a relation which lists the names of relvars in the current session as well as  its types.  +handleRetrieveRelationVariableSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)+handleRetrieveRelationVariableSummary ti sessionId conn = do+  ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)+  reply ret conn  +  +handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Maybe SchemaName)+handleRetrieveCurrentSchemaName ti sessionId conn = do+  ret <- timeoutOrDie ti (currentSchemaName sessionId conn)+  reply ret conn  ++handleExecuteSchemaExpr :: Timeout -> SessionId -> Connection -> SchemaExpr -> Reply (Maybe RelationalError)+handleExecuteSchemaExpr ti sessionId conn schemaExpr = do+  ret <- timeoutOrDie ti (executeSchemaExpr sessionId conn schemaExpr)+  reply ret conn+  +handleLogout :: Timeout -> Connection -> Reply Bool+handleLogout _ conn = do+  --liftIO $ closeRemote_ conn+  reply (pure True) conn+    +handleTestTimeout :: Timeout -> SessionId -> Connection -> Reply Bool  +handleTestTimeout ti _ conn = do+  ret <- timeoutOrDie ti (threadDelay 100000 >> pure True)+  reply ret conn++  +
+ src/lib/ProjectM36/Server/ParseArgs.hs view
@@ -0,0 +1,62 @@+module ProjectM36.Server.ParseArgs where+import ProjectM36.Base+import ProjectM36.Client+import Options.Applicative+import ProjectM36.Server.Config+import Data.Monoid++parseArgsWithDefaults :: ServerConfig -> Parser ServerConfig+parseArgsWithDefaults defaults = ServerConfig <$> +                     parsePersistenceStrategy <*> +                     parseDatabaseName <*> +                     parseHostname (bindHost defaults) <*> +                     parsePort (bindPort defaults) <*> +                     many parseGhcPkgPaths <*> +                     parseTimeout (perRequestTimeout defaults) <*> +                     pure False+                     +parsePersistenceStrategy :: Parser PersistenceStrategy+parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>+                           MinimalPersistence <$> dbdirOpt <|>+                           pure NoPersistence+  where +    dbdirOpt = strOption (short 'd' <> +                          long "database-directory" <> +                          metavar "DIRECTORY" <>+                          showDefaultWith show+                         )+    fsyncOpt = switch (short 'f' <>+                    long "fsync" <>+                    help "Fsync all new transactions.")+               +parseDatabaseName :: Parser DatabaseName+parseDatabaseName = strOption (short 'n' <>+                               long "database" <>+                               metavar "DATABASE_NAME")+                    +parseHostname :: Hostname -> Parser Hostname                    +parseHostname defHostname = strOption (short 'h' <>+                           long "hostname" <>+                           metavar "HOST_NAME" <>+                           value defHostname)+                +parsePort :: Port -> Parser Port                +parsePort defPort = option auto (short 'p' <>+                         long "port" <>+                         metavar "PORT_NUMBER" <>+                         value defPort)+            +parseGhcPkgPaths :: Parser String+parseGhcPkgPaths = strOption (long "ghc-pkg-dir" <>+                              metavar "GHC_PACKAGE_DIRECTORY")+                   +parseTimeout :: Int -> Parser Int              +parseTimeout defTimeout = option auto (long "timeout" <>+                            metavar "MICROSECONDS" <>+                            value defTimeout)++parseConfig :: IO ServerConfig+parseConfig = parseConfigWithDefaults defaultServerConfig+  +parseConfigWithDefaults :: ServerConfig -> IO ServerConfig+parseConfigWithDefaults defaults = execParser (info (parseArgsWithDefaults defaults) idm)
+ src/lib/ProjectM36/Server/RemoteCallTypes.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}+module ProjectM36.Server.RemoteCallTypes where+import ProjectM36.Base+import ProjectM36.IsomorphicSchema+import ProjectM36.TransactionGraph+import ProjectM36.TransGraphRelationalExpression+import ProjectM36.Session+import GHC.Generics+import Data.Binary+import Control.Distributed.Process (ProcessId)++-- | The initial login message. The argument should be the process id of the initiating client. This ProcessId will receive notification callbacks.+data Login = Login ProcessId+           deriving (Binary, Generic)+                    +data Logout = Logout+            deriving (Binary, Generic)+data ExecuteRelationalExpr = ExecuteRelationalExpr SessionId RelationalExpr +                           deriving (Binary, Generic)+data ExecuteDatabaseContextExpr = ExecuteDatabaseContextExpr SessionId DatabaseContextExpr+                                deriving (Binary, Generic)+data ExecuteDatabaseContextIOExpr = ExecuteDatabaseContextIOExpr SessionId DatabaseContextIOExpr+                                deriving (Binary, Generic)                                         +data ExecuteGraphExpr = ExecuteGraphExpr SessionId TransactionGraphOperator +                      deriving (Binary, Generic)+data ExecuteTransGraphRelationalExpr = ExecuteTransGraphRelationalExpr SessionId TransGraphRelationalExpr                               +                                     deriving (Binary, Generic)+data ExecuteHeadName = ExecuteHeadName SessionId+                     deriving (Binary, Generic)+data ExecuteTypeForRelationalExpr = ExecuteTypeForRelationalExpr SessionId RelationalExpr+                                  deriving (Binary, Generic)+data ExecuteSchemaExpr = ExecuteSchemaExpr SessionId SchemaExpr                                 +                         deriving (Binary, Generic)+data ExecuteSetCurrentSchema = ExecuteSetCurrentSchema SessionId SchemaName+                               deriving (Binary, Generic)+data RetrieveInclusionDependencies = RetrieveInclusionDependencies SessionId+                                   deriving (Binary, Generic)+data RetrievePlanForDatabaseContextExpr = RetrievePlanForDatabaseContextExpr SessionId DatabaseContextExpr+                                        deriving (Binary, Generic)+data RetrieveTransactionGraph = RetrieveTransactionGraph SessionId+                              deriving (Binary, Generic)+data RetrieveHeadTransactionId = RetrieveHeadTransactionId SessionId+                                 deriving (Binary, Generic)+data CreateSessionAtCommit = CreateSessionAtCommit TransactionId+                                    deriving (Binary, Generic)+data CreateSessionAtHead = CreateSessionAtHead HeadName+                                  deriving (Binary, Generic)+data CloseSession = CloseSession SessionId+                    deriving (Binary, Generic)+data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId+                                   deriving (Binary, Generic)+data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId+                                     deriving (Binary, Generic)+data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId+                                 deriving (Binary, Generic)+data TestTimeout = TestTimeout SessionId                                          +                   deriving (Binary, Generic)
+ src/lib/ProjectM36/Session.hs view
@@ -0,0 +1,43 @@+module ProjectM36.Session where+import ProjectM36.Base+import Data.UUID+import qualified Data.Map as M+import ProjectM36.Error++type SessionId = UUID++--the persistence of a session is as long as the life of the database (not serialized to disk)+-- sessions are not associated with connections and have separate lifetimes+-- | Represents a pointer into the database's transaction graph which the 'DatabaseContextExpr's can then modify subsequently be committed to extend the transaction graph. The session contains staged (uncommitted) database changes as well as the means to switch between isomorphic schemas.+data Session = Session DisconnectedTransaction SchemaName++defaultSchemaName :: SchemaName+defaultSchemaName = "main"++disconnectedTransaction :: Session -> DisconnectedTransaction+disconnectedTransaction (Session discon _) = discon++isDirty :: Session -> DirtyFlag+isDirty (Session (DisconnectedTransaction _ _ dirtyFlag) _) = dirtyFlag++concreteDatabaseContext :: Session -> DatabaseContext+concreteDatabaseContext (Session (DisconnectedTransaction _ (Schemas context _) _) _) = context++parentId :: Session -> TransactionId+parentId (Session (DisconnectedTransaction parentUUID _ _) _) = parentUUID++subschemas :: Session -> Subschemas+subschemas (Session (DisconnectedTransaction _ (Schemas _ s) _) _) = s++schemas :: Session -> Schemas+schemas (Session (DisconnectedTransaction _ s _) _) = s++schemaName :: Session -> SchemaName+schemaName (Session _ s) = s++setSchemaName :: SchemaName -> Session -> Either RelationalError Session+setSchemaName sname session = if sname == defaultSchemaName || M.member sname (subschemas session) then+                                pure (Session (disconnectedTransaction session) sname)+                              else+                                Left (SubschemaNameNotInUseError sname)+
+ src/lib/ProjectM36/Sessions.hs view
@@ -0,0 +1,27 @@+module ProjectM36.Sessions where+import Control.Concurrent.STM+import qualified STMContainers.Map as STMMap+import ListT+import ProjectM36.Attribute+import ProjectM36.Base+import ProjectM36.Session+import ProjectM36.Relation+import ProjectM36.Error+import qualified Data.UUID as U++type Sessions = STMMap.Map SessionId Session++stmMapToList :: STMMap.Map k v -> STM [(k, v)]+stmMapToList = ListT.fold (\l -> return . (:l)) [] . STMMap.stream++uuidAtom :: U.UUID -> Atom+uuidAtom = TextAtom . U.toText++sessionsAsRelation :: Sessions -> STM (Either RelationalError Relation)+sessionsAsRelation sessions = do+  sessionAssocs <- stmMapToList sessions+  let atomMatrix = map (\(sessionId, session) -> [uuidAtom sessionId, uuidAtom (parentId session)]) sessionAssocs+  pure $ mkRelationFromList (attributesFromList [Attribute "sessionid" TextAtomType,+                             Attribute "parentCommit" TextAtomType]) atomMatrix+    +
+ src/lib/ProjectM36/StaticOptimizer.hs view
@@ -0,0 +1,190 @@+module ProjectM36.StaticOptimizer where+import ProjectM36.Base+import ProjectM36.RelationalExpression+import ProjectM36.Relation+import ProjectM36.Error+import qualified ProjectM36.AttributeNames as AS+import ProjectM36.TupleSet+import Control.Monad.State hiding (join)+import Data.Either (rights, lefts)+import Control.Monad.Trans.Reader+import qualified Data.Map as M++-- the static optimizer performs optimizations which need not take any specific-relation statistics into account+-- apply optimizations which merely remove steps to become no-ops: example: projection of a relation across all of its attributes => original relation++--should optimizations offer the possibility to return errors? If they perform the up-front type-checking, maybe so+applyStaticRelationalOptimization :: RelationalExpr -> RelationalExprState (Either RelationalError RelationalExpr)+applyStaticRelationalOptimization e@(MakeStaticRelation _ _) = return $ Right e++applyStaticRelationalOptimization e@(MakeRelationFromExprs _ _) = return $ Right e++applyStaticRelationalOptimization e@(ExistingRelation _) = return $ Right e++applyStaticRelationalOptimization e@(RelationVariable _ _) = return $ Right e++--remove project of attributes which removes no attributes+applyStaticRelationalOptimization (Project attrNameSet expr) = do+  relType <- typeForRelationalExpr expr+  case relType of+    Left err -> return $ Left err+    Right relType2 -> if AS.all == attrNameSet then+                        applyStaticRelationalOptimization expr+                      else if AttributeNames (attributeNames relType2) == attrNameSet then+                       applyStaticRelationalOptimization expr+                       else do+                         optimizedSubExpression <- applyStaticRelationalOptimization expr +                         case optimizedSubExpression of+                           Left err -> return $ Left err+                           Right optSubExpr -> return $ Right $ Project attrNameSet optSubExpr+                           +applyStaticRelationalOptimization (Union exprA exprB) = do+  optExprA <- applyStaticRelationalOptimization exprA+  optExprB <- applyStaticRelationalOptimization exprB+  case optExprA of +    Left err -> return $ Left err+    Right optExprAx -> case optExprB of+      Left err -> return $ Left err+      Right optExprBx -> if optExprAx == optExprBx then                          +                          return (Right optExprAx)+                          else+                            return $ Right $ Union optExprAx optExprBx+                            +applyStaticRelationalOptimization (Join exprA exprB) = do+  optExprA <- applyStaticRelationalOptimization exprA+  optExprB <- applyStaticRelationalOptimization exprB+  case optExprA of+    Left err -> return $ Left err+    Right optExprA2 -> case optExprB of+      Left err -> return $ Left err+      Right optExprB2 -> if optExprA == optExprB then --A join A == A+                           return optExprA+                         else+                           return $ Right (Join optExprA2 optExprB2)+                           +applyStaticRelationalOptimization (Difference exprA exprB) = do+  optExprA <- applyStaticRelationalOptimization exprA+  optExprB <- applyStaticRelationalOptimization exprB+  case optExprA of+    Left err -> return $ Left err+    Right optExprA2 -> case optExprB of+      Left err -> return $ Left err+      Right optExprB2 -> if optExprA == optExprB then do --A difference A == A where false+                           eEmptyRel <- typeForRelationalExpr optExprA2+                           case eEmptyRel of+                             Left err -> pure (Left err)+                             Right emptyRel -> pure (Right (ExistingRelation emptyRel))+                         else+                           return $ Right (Difference optExprA2 optExprB2)+                           +applyStaticRelationalOptimization e@(Rename _ _ _) = return $ Right e++applyStaticRelationalOptimization (Group oldAttrNames newAttrName expr) = do +  return $ Right $ Group oldAttrNames newAttrName expr+  +applyStaticRelationalOptimization (Ungroup attrName expr) = do +  return $ Right $ Ungroup attrName expr+  +--remove restriction of nothing+applyStaticRelationalOptimization (Restrict predicate expr) = do+  optimizedPredicate <- applyStaticPredicateOptimization predicate+  case optimizedPredicate of+    Left err -> return $ Left err+    Right optimizedPredicate2 -> if optimizedPredicate2 == TruePredicate then+                                  applyStaticRelationalOptimization expr+                                  else if optimizedPredicate2 == NotPredicate TruePredicate then do+                                    attributesRel <- typeForRelationalExpr expr+                                    case attributesRel of +                                      Left err -> return $ Left err+                                      Right attributesRelA -> return $ Right $ MakeStaticRelation (attributes attributesRelA) emptyTupleSet+                                      else do+                                      optimizedSubExpression <- applyStaticRelationalOptimization expr+                                      case optimizedSubExpression of+                                        Left err -> return $ Left err+                                        Right optSubExpr -> return $ Right $ Restrict optimizedPredicate2 optSubExpr+  +applyStaticRelationalOptimization e@(Equals _ _) = return $ Right e ++applyStaticRelationalOptimization e@(NotEquals _ _) = return $ Right e +  +applyStaticRelationalOptimization e@(Extend _ _) = return $ Right e  ++applyStaticDatabaseOptimization :: DatabaseContextExpr -> DatabaseState (Either RelationalError DatabaseContextExpr)+applyStaticDatabaseOptimization x@NoOperation = pure $ Right x+applyStaticDatabaseOptimization x@(Define _ _) = pure $ Right x++applyStaticDatabaseOptimization x@(Undefine _) = pure $ Right x++applyStaticDatabaseOptimization (Assign name expr) = do+  context <- getStateContext+  let optimizedExpr = runReader (applyStaticRelationalOptimization expr) (RelationalExprStateElems context)+  case optimizedExpr of+    Left err -> return $ Left err+    Right optimizedExpr2 -> return $ Right (Assign name optimizedExpr2)+    +applyStaticDatabaseOptimization (Insert name expr) = do+  context <- getStateContext+  let optimizedExpr = runReader (applyStaticRelationalOptimization expr) (RelationalExprStateElems context)+  case optimizedExpr of+    Left err -> return $ Left err+    Right optimizedExpr2 -> return $ Right (Insert name optimizedExpr2)+  +applyStaticDatabaseOptimization (Delete name predicate) = do  +  context <- getStateContext+  let optimizedPredicate = runReader (applyStaticPredicateOptimization predicate) (RelationalExprStateElems context)+  case optimizedPredicate of+      Left err -> return $ Left err+      Right optimizedPredicate2 -> return $ Right (Delete name optimizedPredicate2)++applyStaticDatabaseOptimization (Update name upmap predicate) = do +  context <- getStateContext+  let optimizedPredicate = runReader (applyStaticPredicateOptimization predicate) (RelationalExprStateElems context)+  case optimizedPredicate of+      Left err -> return $ Left err+      Right optimizedPredicate2 -> return $ Right (Update name upmap optimizedPredicate2)+      +applyStaticDatabaseOptimization dep@(AddInclusionDependency _ _) = return $ Right dep++applyStaticDatabaseOptimization (RemoveInclusionDependency name) = return $ Right (RemoveInclusionDependency name)++applyStaticDatabaseOptimization (AddNotification name triggerExpr resultExpr) = do+  context <- getStateContext+  let eTriggerExprOpt = runReader (applyStaticRelationalOptimization triggerExpr) (RelationalExprStateElems context)+  case eTriggerExprOpt of+         Left err -> pure $ Left err+         Right triggerExprOpt -> do+           let eResultExprOpt = runReader (applyStaticRelationalOptimization resultExpr) (RelationalExprStateElems context)+           case eResultExprOpt of+                  Left err -> pure $ Left err+                  Right resultExprOpt -> pure (Right (AddNotification name triggerExprOpt resultExprOpt))++applyStaticDatabaseOptimization notif@(RemoveNotification _) = pure (Right 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)++--optimization: from pgsql lists- check for join condition referencing foreign key- if join projection project away the referenced table, then it does not need to be scanned++--applyStaticDatabaseOptimization (MultipleExpr exprs) = return $ Right $ MultipleExpr exprs+--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 length errors > 0 then+    return $ Left (head errors)+    else+      return $ 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++applyStaticPredicateOptimization :: RestrictionPredicateExpr -> RelationalExprState (Either RelationalError RestrictionPredicateExpr)+applyStaticPredicateOptimization predicate = return $ Right predicate
+ src/lib/ProjectM36/TransGraphRelationalExpression.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+--really, a better name for this module could be "TransTransactionGraphRelationalExpr", but that name is too long+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 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).+type TransGraphRelationalExpr = RelationalExprBase TransactionIdLookup++instance Binary TransGraphRelationalExpr++type TransGraphExtendTupleExpr = ExtendTupleExprBase TransactionIdLookup++instance Binary TransGraphExtendTupleExpr++type TransGraphTupleExpr = TupleExprBase TransactionIdLookup++instance Binary TransGraphTupleExpr++type TransGraphRestrictionPredicateExpr = RestrictionPredicateExprBase TransactionIdLookup++instance Binary TransGraphRestrictionPredicateExpr++type TransGraphAtomExpr = AtomExprBase TransactionIdLookup++instance Binary TransGraphAtomExpr ++type TransGraphAttributeExpr = AttributeExprBase TransactionIdLookup++-- 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+  case mAttrExprs of+    Nothing -> pure (MakeRelationFromExprs Nothing tupleExprs')+    Just attrExprs -> do+      attrExprs' <- mapM (evalTransGraphAttributeExpr graph) 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 attrNames expr) graph = do+  expr' <- evalTransGraphRelationalExpr expr 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+  expr' <- evalTransGraphRelationalExpr expr graph  +  pure (Rename attrName1 attrName2 expr')+evalTransGraphRelationalExpr (Difference exprA exprB) graph = do  +  exprA' <- evalTransGraphRelationalExpr exprA graph+  exprB' <- evalTransGraphRelationalExpr exprB graph+  pure (Difference exprA' exprB')+evalTransGraphRelationalExpr (Group attrNames attrName expr) graph = do  +  expr' <- evalTransGraphRelationalExpr expr graph+  pure (Group attrNames attrName expr')+evalTransGraphRelationalExpr (Ungroup attrName expr) graph = do  +  expr' <- evalTransGraphRelationalExpr expr graph    +  pure (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+  pure (Equals exprA' exprB')+evalTransGraphRelationalExpr (NotEquals exprA exprB) graph = do  +  exprA' <- evalTransGraphRelationalExpr exprA graph+  exprB' <- evalTransGraphRelationalExpr exprB graph+  pure (NotEquals exprA' exprB')+evalTransGraphRelationalExpr (Extend extendExpr expr) graph = do+  extendExpr' <- evalTransGraphExtendTupleExpr extendExpr graph+  expr' <- evalTransGraphRelationalExpr expr graph+  pure (Extend extendExpr' expr')+  +evalTransGraphTupleExpr :: TransactionGraph -> TransGraphTupleExpr -> Either RelationalError TupleExpr+evalTransGraphTupleExpr graph (TupleExpr attrMap) = do+  attrAssoc <- mapM (\(attrName, atomExpr) -> do +                        aExpr <- evalTransGraphAtomExpr graph atomExpr+                        pure (attrName, aExpr)+                    ) (M.toList attrMap)+  pure (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+  expr' <- evalTransGraphRelationalExpr expr graph +  pure (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+  pure (AndPredicate exprA' exprB')+evalTransGraphRestrictionPredicateExpr (OrPredicate exprA exprB) graph = do  +  exprA' <- evalTransGraphRestrictionPredicateExpr exprA graph+  exprB' <- evalTransGraphRestrictionPredicateExpr exprB graph+  pure (OrPredicate exprA' exprB')+evalTransGraphRestrictionPredicateExpr (NotPredicate expr) graph = do+  expr' <- evalTransGraphRestrictionPredicateExpr expr graph+  pure (NotPredicate expr')+evalTransGraphRestrictionPredicateExpr (RelationalExprPredicate expr) graph = do  +  expr' <- evalTransGraphRelationalExpr expr graph+  pure (RelationalExprPredicate expr')+evalTransGraphRestrictionPredicateExpr (AtomExprPredicate expr) graph = do+  expr' <- evalTransGraphAtomExpr graph expr+  pure (AtomExprPredicate expr')+evalTransGraphRestrictionPredicateExpr (AttributeEqualityPredicate attrName expr) graph = do  +  expr' <- evalTransGraphAtomExpr graph expr+  pure (AttributeEqualityPredicate attrName expr')+  +evalTransGraphExtendTupleExpr :: TransGraphExtendTupleExpr -> TransactionGraph -> Either RelationalError ExtendTupleExpr+evalTransGraphExtendTupleExpr (AttributeExtendTupleExpr attrName expr) graph = do+  expr' <- evalTransGraphAtomExpr graph expr+  pure (AttributeExtendTupleExpr attrName expr')++evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr+evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do+  trans <- lookupTransaction graph tLookup+  aType <- atomTypeForTypeConstructor tCons (typeConstructorMapping (concreteDatabaseContext trans))+  pure (NakedAttributeExpr (Attribute attrName aType))+evalTransGraphAttributeExpr _ (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)
+ src/lib/ProjectM36/Transaction.hs view
@@ -0,0 +1,41 @@+module ProjectM36.Transaction where+import ProjectM36.Base+import qualified Data.Set as S+import qualified Data.UUID as U++transactionParentIds :: Transaction -> S.Set TransactionId+transactionParentIds (Transaction _ (TransactionInfo pId _) _) = S.singleton pId+transactionParentIds (Transaction _ (MergeTransactionInfo pId1 pId2 _) _) = S.fromList [pId1, pId2]++transactionChildIds :: Transaction -> S.Set TransactionId+transactionChildIds (Transaction _ (TransactionInfo _ children) _) = children+transactionChildIds (Transaction _ (MergeTransactionInfo _ _ children) _) = children++-- | 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 _) schemas') childIds = Transaction (transactionId t) (TransactionInfo pId childIds) schemas'+transactionSetChildren t@(Transaction _ (MergeTransactionInfo pId1 pId2 _) schemas') childIds =  Transaction (transactionId t) (MergeTransactionInfo pId1 pId2 childIds) schemas'++-- | 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) = TransactionInfo (filterParent parentId filterIds) (S.intersection childIds filterIds)+filterTransactionInfoTransactions filterIds (MergeTransactionInfo parentIdA parentIdB childIds) = MergeTransactionInfo (filterParent parentIdA filterIds) (filterParent parentIdB filterIds) (S.intersection childIds filterIds)++filterParent :: TransactionId -> S.Set TransactionId -> TransactionId+filterParent parentId validIds = if S.member parentId validIds then parentId else U.nil++-- | Remove any child or parent transaction references not in the valud UUID set.+filterTransaction :: S.Set TransactionId -> Transaction -> Transaction+filterTransaction filterIds (Transaction selfId tInfo context) = Transaction selfId (filterTransactionInfoTransactions filterIds tInfo) context++-- | Return the singular context which is not virtual.+concreteDatabaseContext :: Transaction -> DatabaseContext+concreteDatabaseContext (Transaction _ _ (Schemas context _)) = context++-- | Returns all schemas including the concrete schema.+schemas :: Transaction -> Schemas+schemas (Transaction _ _ schemas') = schemas'+    +-- | Returns all subschemas which are isomorphic or sub-isomorphic to the concrete schema.+subschemas :: Transaction -> Subschemas+subschemas (Transaction _ _ (Schemas _ sschemas)) = sschemas
+ src/lib/ProjectM36/Transaction/Persist.hs view
@@ -0,0 +1,236 @@+module ProjectM36.Transaction.Persist where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.Transaction+import ProjectM36.DatabaseContextFunction+import ProjectM36.AtomFunction+import ProjectM36.Persist (writeBSFileSync, DiskSync, renameSync)+import qualified Data.Map as M+import qualified Data.HashSet as HS+import qualified Data.Binary as B+import qualified Data.ByteString.Lazy 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+import GHC+import GHC.Paths++getDirectoryNames :: FilePath -> IO [FilePath]+getDirectoryNames path = do+  subpaths <- getDirectoryContents path+  return $ filter (\n -> n `notElem` ["..", "."]) subpaths++tempTransactionDir :: FilePath -> TransactionId -> FilePath+tempTransactionDir dbdir transId = dbdir </> "." ++ show transId++transactionDir :: FilePath -> TransactionId -> FilePath+transactionDir dbdir transId = dbdir </> show transId++transactionInfoPath :: FilePath -> FilePath+transactionInfoPath transdir = transdir </> "info"++relvarsDir :: FilePath -> FilePath        +relvarsDir transdir = transdir </> "relvars"++incDepsDir :: FilePath -> FilePath+incDepsDir transdir = transdir </> "incdeps"++atomFuncsDir :: FilePath -> FilePath+atomFuncsDir transdir = transdir </> "atomfuncs"++dbcFuncsDir :: FilePath -> FilePath+dbcFuncsDir transdir = transdir </> "dbcfuncs"++typeConsPath :: FilePath -> FilePath+typeConsPath transdir = transdir </> "typecons"++subschemasPath :: FilePath -> FilePath+subschemasPath transdir = transdir </> "schemas"++readTransaction :: FilePath -> TransactionId -> Maybe ScriptSession -> IO (Either PersistenceError Transaction)+readTransaction dbdir transId mScriptSession = do+  let transDir = transactionDir dbdir transId+  transDirExists <- doesDirectoryExist transDir+  if not transDirExists then    +    return $ Left $ MissingTransactionError transId+    else do+    relvars <- readRelVars transDir+    transInfo <- liftM B.decode $ BS.readFile (transactionInfoPath transDir)+    incDeps <- readIncDeps transDir+    typeCons <- readTypeConstructorMapping transDir+    sschemas <- readSubschemas transDir+    dbcFuncs <- readDBCFuncs transDir mScriptSession+    atomFuncs <- readAtomFuncs transDir mScriptSession+    let newContext = DatabaseContext { inclusionDependencies = incDeps,+                                       relationVariables = relvars,+                                       typeConstructorMapping = typeCons,+                                       notifications = M.empty,+                                       atomFunctions = atomFuncs, +                                       dbcFunctions = dbcFuncs }+        newSchemas = Schemas newContext sschemas+    return $ Right $ Transaction transId transInfo newSchemas+        +writeTransaction :: DiskSync -> FilePath -> Transaction -> IO ()+writeTransaction sync dbdir trans = do+  let tempTransDir = tempTransactionDir dbdir (transactionId trans)+      finalTransDir = transactionDir dbdir (transactionId trans)+      context = concreteDatabaseContext trans+  transDirExists <- doesDirectoryExist finalTransDir+  if not transDirExists then do+    --create sub directories+    mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, atomFuncsDir tempTransDir, dbcFuncsDir tempTransDir]+    writeRelVars sync tempTransDir (relationVariables context)+    writeIncDeps sync tempTransDir (inclusionDependencies context)+    writeAtomFuncs sync tempTransDir (atomFunctions context)+    writeDBCFuncs sync tempTransDir (dbcFunctions context)+    writeTypeConstructorMapping sync tempTransDir (typeConstructorMapping context)+    writeSubschemas sync tempTransDir (subschemas trans)+    BS.writeFile (transactionInfoPath tempTransDir) (B.encode $ transactionInfo trans)+    --move the temp directory to final location+    renameSync sync tempTransDir finalTransDir+    else+      return ()+  +writeRelVar :: DiskSync -> FilePath -> (RelVarName, Relation) -> IO ()+writeRelVar sync transDir (relvarName, rel) = do+  let relvarPath = relvarsDir transDir </> T.unpack relvarName+  writeBSFileSync sync relvarPath (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+  relvars <- mapM (\name -> do+                      rel <- liftM B.decode $ BS.readFile (relvarsPath </> name)+                      return (T.pack name, rel)) relvarNames+  return $ M.fromList relvars++writeAtomFuncs :: DiskSync -> FilePath -> AtomFunctions -> IO ()+writeAtomFuncs sync transDir funcs = mapM_ (writeAtomFunc sync transDir) $ HS.toList funcs++--all the atom functions are in one file (???)+readAtomFuncs :: FilePath -> Maybe ScriptSession -> IO AtomFunctions+readAtomFuncs transDir mScriptSession = do+  funcNames <- getDirectoryNames (atomFuncsDir transDir)+  --only Haskell script functions can be serialized+  --we always return the pre-compiled functions+  funcs <- mapM (\name -> readAtomFunc transDir name mScriptSession precompiledAtomFunctions) (map T.pack funcNames)+  pure (HS.union precompiledAtomFunctions (HS.fromList funcs))+  +--to write the atom functions, we really some bytecode to write (GHCi bytecode?)+writeAtomFunc :: DiskSync -> FilePath -> AtomFunction -> IO ()+writeAtomFunc sync transDir func = do+  let atomFuncPath = atomFuncsDir transDir </> T.unpack (atomFuncName func)+  writeBSFileSync sync atomFuncPath (B.encode (atomFuncType func, atomFunctionScript func))+  +--if the script session is enabled, compile the script, otherwise, hard error!  +readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO (AtomFunction)+readAtomFunc transDir funcName mScriptSession precompiledFuncs = do+  let atomFuncPath = atomFuncsDir transDir </> T.unpack funcName  +  (funcType, mFuncScript) <- liftM B.decode (BS.readFile atomFuncPath)+  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 -> do+      case mScriptSession of+        Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"+        Just scriptSession -> do+          --risk of GHC exception during compilation here+          eCompiledScript <- runGhc (Just libdir) $ do+            setSession (hscEnv scriptSession)+            compileScript (atomFunctionBodyType scriptSession) funcScript+          case eCompiledScript of+            Left err -> throwIO err+            Right compiledScript -> pure (AtomFunction { atomFuncName = funcName,+                                                         atomFuncType = funcType,+                                                         atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript })++writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()+writeDBCFuncs sync transDir funcs = mapM_ (writeDBCFunc sync transDir) (HS.toList funcs)+  +writeDBCFunc :: DiskSync -> FilePath -> DatabaseContextFunction -> IO ()+writeDBCFunc sync transDir func = do+  let dbcFuncPath = dbcFuncsDir transDir </> T.unpack (dbcFuncName func)  +  writeBSFileSync sync dbcFuncPath (B.encode (dbcFuncType func, databaseContextFunctionScript func))++readDBCFuncs :: FilePath -> Maybe ScriptSession -> IO DatabaseContextFunctions+readDBCFuncs transDir mScriptSession = do+  funcNames <- getDirectoryNames (dbcFuncsDir transDir)+  --only Haskell script functions can be serialized+  --we always return the pre-compiled functions+  funcs <- mapM (\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) (map T.pack funcNames)+  return $ HS.union basicDatabaseContextFunctions (HS.fromList funcs)+  +readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction  +readDBCFunc transDir funcName mScriptSession precompiledFuncs = do+  let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName+  (funcType, mFuncScript) <- liftM B.decode (BS.readFile 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 -> do+      case mScriptSession of+        Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"+        Just scriptSession -> do+          eCompiledScript <- runGhc (Just libdir) $ do+            setSession (hscEnv scriptSession)+            compileScript (dbcFunctionBodyType scriptSession) funcScript+          case eCompiledScript of+            Left err -> throwIO err+            Right compiledScript -> pure (DatabaseContextFunction { dbcFuncName = funcName,+                                                                    dbcFuncType = funcType,+                                                                    dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript})++writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()  +writeIncDep sync transDir (incDepName, incDep) = do+  writeBSFileSync sync (incDepsDir transDir </> T.unpack incDepName) $ B.encode incDep+  +writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO ()  +writeIncDeps sync transDir incdeps = mapM_ (writeIncDep sync transDir) $ M.toList incdeps +  +readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)+readIncDep transDir incdepName = do+  let incDepPath = incDepsDir transDir </> T.unpack incdepName+  incDepData <- BS.readFile incDepPath+  return $ (incdepName, B.decode incDepData)+  +readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)  +readIncDeps transDir = do+  let incDepsPath = incDepsDir transDir+  incDepNames <- getDirectoryNames incDepsPath+  incDeps <- mapM (readIncDep transDir) (map T.pack incDepNames)+  return $ M.fromList incDeps+  +readSubschemas :: FilePath -> IO Subschemas  +readSubschemas transDir = do+  let sschemasPath = subschemasPath transDir+  bytes <- BS.readFile sschemasPath+  pure (B.decode bytes)+  +writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()  +writeSubschemas sync transDir sschemas = do+  let sschemasPath = subschemasPath transDir+  writeBSFileSync sync sschemasPath (B.encode sschemas)+  +writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()  +writeTypeConstructorMapping sync path types = let atPath = typeConsPath path in+  writeBSFileSync sync atPath $ B.encode types++readTypeConstructorMapping :: FilePath -> IO (TypeConstructorMapping)+readTypeConstructorMapping path = do+  let atPath = typeConsPath path+  liftM B.decode (BS.readFile atPath)+  +
+ src/lib/ProjectM36/TransactionGraph.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}+module ProjectM36.TransactionGraph where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.Transaction+import ProjectM36.Relation+import ProjectM36.TupleSet+import ProjectM36.Tuple+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.Text as T+import GHC.Generics+import Data.Binary+import ProjectM36.TransactionGraph.Merge+import Data.Either (lefts, rights, isRight)++-- | Record a lookup for a specific transaction in the graph.+data TransactionIdLookup = TransactionIdLookup TransactionId |+                           TransactionIdHeadNameLookup HeadName [TransactionIdHeadBacktrack]+                           deriving (Show, Eq, Binary, Generic)+                           +-- | Used for git-style head backtracking such as topic~3^2.+data TransactionIdHeadBacktrack = TransactionIdHeadParentBacktrack Int | -- ^ git equivalent of ~: walk back n parents, arbitrarily choosing a parent when a choice must be made+                                  TransactionIdHeadBranchBacktrack Int -- ^ git equivalent of ^: walk back one parent level to the nth arbitrarily-chosen parent+                                  deriving (Show, Eq, Binary, Generic)++data CommitOption = AllowEmptyCommitOption | -- allow empty commit and add it to the graph+                    ForbidEmptyCommitOption | --return error on empty commit- probably the safest option+                    IgnoreEmptyCommitOption -- don't add the commit and don't add it to the graph (no-op) +                    deriving (Eq, Show, Binary, Generic)+  +-- | Operators which manipulate a transaction graph and which transaction the current 'Session' is based upon.+data TransactionGraphOperator = JumpToHead HeadName  |+                                JumpToTransaction TransactionId |+                                Branch HeadName |+                                DeleteBranch HeadName |+                                MergeTransactions MergeStrategy HeadName HeadName |+                                Commit CommitOption |+                                Rollback+                              deriving (Eq, Show, Binary, Generic)+                                       +isCommit :: TransactionGraphOperator -> Bool                                       +isCommit (Commit _) = True+isCommit _ = False+                                       +data ROTransactionGraphOperator = ShowGraph+                                  deriving Show++bootstrapTransactionGraph :: TransactionId -> DatabaseContext -> TransactionGraph+bootstrapTransactionGraph freshId context = TransactionGraph bootstrapHeads bootstrapTransactions+  where+    bootstrapHeads = M.singleton "master" freshTransaction+    newSchemas = Schemas context M.empty+    freshTransaction = Transaction freshId (TransactionInfo U.nil S.empty) newSchemas+    bootstrapTransactions = S.singleton freshTransaction++emptyTransactionGraph :: TransactionGraph+emptyTransactionGraph = TransactionGraph M.empty S.empty++transactionForHead :: HeadName -> TransactionGraph -> Maybe Transaction+transactionForHead headName graph = M.lookup headName (transactionHeadsForGraph graph)++headList :: TransactionGraph -> [(HeadName, TransactionId)]+headList graph = map (\(k,v) -> (k, transactionId v)) (M.assocs (transactionHeadsForGraph graph))++headNameForTransaction :: Transaction -> TransactionGraph -> Maybe HeadName+headNameForTransaction transaction (TransactionGraph heads _) = if M.null matchingTrans then+                                                                  Nothing+                                                                else+                                                                  Just $ (head . M.keys) matchingTrans+  where+    matchingTrans = M.filter (transaction ==) heads++transactionForId :: TransactionId -> TransactionGraph -> Either RelationalError Transaction+transactionForId tid graph = if tid == U.nil then+                                  Left RootTransactionTraversalError+                                else if S.null matchingTrans then+                                  Left $ NoSuchTransactionError tid+                                else+                                  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 = do+  transList <- forM (S.toList idSet) ((flip transactionForId) graph)+  return (S.fromList transList)++isRootTransaction :: Transaction -> TransactionGraph -> Bool+isRootTransaction (Transaction _ (TransactionInfo pId _) _) _ = U.null pId+isRootTransaction (Transaction _ (MergeTransactionInfo _ _ _) _) _  = False++-- the first transaction has no parent - all other do have parents- merges have two parents+parentTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)+parentTransactions (Transaction _ (TransactionInfo pId _) _) graph = do+  trans <- transactionForId pId graph+  return (S.singleton trans)++parentTransactions (Transaction _ (MergeTransactionInfo pId1 pId2 _) _ ) graph = transactionsForIds (S.fromList [pId1, pId2]) graph+++childTransactions :: Transaction -> TransactionGraph -> Either RelationalError (S.Set Transaction)+childTransactions (Transaction _ (TransactionInfo _ children) _) = transactionsForIds children+childTransactions (Transaction _ (MergeTransactionInfo _ _ children) _) = transactionsForIds children++-- 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 :: TransactionId -> HeadName -> TransactionId -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)+addBranch newId newBranchName branchPointId graph = do+  parentTrans <- transactionForId branchPointId graph+  let newTrans = Transaction newId (TransactionInfo branchPointId S.empty) (schemas parentTrans)+  addTransactionToGraph newBranchName newTrans graph++--adds a disconnected transaction to a transaction graph at some head+addDisconnectedTransaction :: TransactionId -> HeadName -> DisconnectedTransaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)+addDisconnectedTransaction newId headName (DisconnectedTransaction parentId schemas' _) graph = addTransactionToGraph headName (Transaction newId (TransactionInfo parentId S.empty) schemas') graph+++addTransactionToGraph :: HeadName -> Transaction -> TransactionGraph -> Either RelationalError (Transaction, TransactionGraph)+addTransactionToGraph headName newTrans graph = do+  let parentIds = transactionParentIds newTrans+      childIds = transactionChildIds newTrans+      newId = transactionId newTrans+      validateIds ids = mapM (\i -> transactionForId i graph) (S.toList ids)+      addChildTransaction trans = transactionSetChildren trans (S.insert newId (transactionChildIds trans))+  --validate that the parent transactions are in the graph+  _ <- 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))+  --validate that the transaction has no children+  when (not (S.null childIds)) (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 (\tid -> transactionForId tid 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))++validateGraph :: TransactionGraph -> Maybe [RelationalError]+validateGraph graph@(TransactionGraph _ transSet) = do+  --check that all transaction ids are unique in the graph+  --FINISH ME!+  --uuids = map transactionId transSet+  --check that all heads appear in the transSet+  --check that all forward and backward links are in place+  _ <- mapM (walkParentTransactions S.empty graph) (S.toList transSet)+  mapM (walkChildTransactions S.empty graph) (S.toList transSet)++--verify that all parent links exist and that all children exist+--maybe verify that all parents end at transaction id nil and all children end at leaves+walkParentTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError+walkParentTransactions seenTransSet graph trans =+  let transId = transactionId trans in+  if transId == U.nil then+    Nothing+  else if S.member transId seenTransSet then+    Just $ TransactionGraphCycleError transId+    else+      let parentTransSetOrError = parentTransactions trans graph in+      case parentTransSetOrError of+        Left err -> Just err+        Right parentTransSet -> do+          walk <- mapM (walkParentTransactions (S.insert transId seenTransSet) graph) (S.toList parentTransSet)+          case walk of+            err:_ -> Just err+            _ -> Nothing++--refactor: needless duplication in these two functions+walkChildTransactions :: S.Set TransactionId -> TransactionGraph -> Transaction -> Maybe RelationalError+walkChildTransactions seenTransSet graph trans =+  let transId = transactionId trans in+  if childTransactions trans graph == Right S.empty then+    Nothing+  else if S.member transId seenTransSet then+    Just $ TransactionGraphCycleError transId+    else+     let childTransSetOrError = childTransactions trans graph in+     case childTransSetOrError of+       Left err -> Just err+       Right childTransSet -> do+         walk <- mapM (walkChildTransactions (S.insert transId seenTransSet) graph) (S.toList childTransSet)+         case walk of+           err:_ -> Just err+           _ -> Nothing++-- returns the new "current" transaction, updated graph, and tutorial d result+-- the current transaction is not part of the transaction graph until it is committed+evalGraphOp :: TransactionId -> DisconnectedTransaction -> TransactionGraph -> TransactionGraphOperator -> Either RelationalError (DisconnectedTransaction, TransactionGraph)++evalGraphOp _ _ graph (JumpToTransaction jumpId) = case transactionForId jumpId graph of+  Left err -> Left err+  Right parentTrans -> Right (newTrans, graph)+    where+      newTrans = DisconnectedTransaction jumpId (schemas parentTrans) False++-- switch from one head to another+evalGraphOp _ _ graph (JumpToHead headName) =+  case transactionForHead headName graph of+    Just newHeadTransaction -> let disconnectedTrans = DisconnectedTransaction (transactionId newHeadTransaction) (schemas newHeadTransaction) False in+      Right (disconnectedTrans, graph)+    Nothing -> Left $ NoSuchHeadNameError headName+-- add new head pointing to branchPoint+-- repoint the disconnected transaction to the new branch commit (with a potentially different disconnected context)+-- affects transactiongraph and the disconnectedtransaction is recreated based off the branch+    {-+evalGraphOp newId discon@(DisconnectedTransaction parentId disconContext) graph (Branch newBranchName) = case transactionForId parentId graph of+  Nothing -> (discon, graph, DisplayErrorResult "Failed to find parent transaction.")+  Just parentTrans -> case addBranch newBranchName parentTrans graph of+    Nothing -> (discon, graph, DisplayErrorResult "Failed to add branch.")+    Just newGraph -> (newDiscon, newGraph, DisplayResult "Branched.")+     where+       newDiscon = DisconnectedTransaction (transactionId parentTrans) disconContext+-}++-- 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 newId (DisconnectedTransaction parentId schemas' _) graph (Branch newBranchName) = do+  let newDiscon = DisconnectedTransaction newId schemas' False+  case addBranch 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 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+    Just headName -> case maybeUpdatedGraph of+      Left err-> Left err+      Right (_, updatedGraph) -> Right (newDisconnectedTrans, updatedGraph)+      where+        newDisconnectedTrans = DisconnectedTransaction newTransId schemas' False+        maybeUpdatedGraph = addDisconnectedTransaction 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+      +evalGraphOp newId (DisconnectedTransaction parentId _ _) graph (MergeTransactions mergeStrategy headNameA headNameB) = mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph++evalGraphOp _ discon graph@(TransactionGraph graphHeads transSet) (DeleteBranch branchName) = case transactionForHead branchName graph of+  Nothing -> Left (NoSuchHeadNameError branchName)+  Just _ -> Right (discon, TransactionGraph (M.delete branchName graphHeads) transSet)++--present a transaction graph as a relation showing the uuids, parentuuids, and flag for the current location of the disconnected transaction+graphAsRelation :: DisconnectedTransaction -> TransactionGraph -> Either RelationalError Relation+graphAsRelation (DisconnectedTransaction parentId _ _) graph@(TransactionGraph _ transSet) = do+  tupleMatrix <- mapM tupleGenerator (S.toList transSet)+  mkRelationFromList attrs tupleMatrix+  where+    attrs = A.attributesFromList [Attribute "id" TextAtomType,+                                  Attribute "parents" (RelationAtomType parentAttributes),+                                  Attribute "current" BoolAtomType,+                                  Attribute "head" TextAtomType+                                 ]+    parentAttributes = A.attributesFromList [Attribute "id" TextAtomType]+    tupleGenerator transaction = case transactionParentsRelation transaction graph of+      Left err -> Left err+      Right parentTransRel -> Right [TextAtom $ T.pack $ show (transactionId transaction),+                                     RelationAtom parentTransRel,+                                     BoolAtom $ parentId == transactionId transaction,+                                     TextAtom $ case headNameForTransaction transaction graph of+                                       Just headName -> headName+                                       Nothing -> ""+                                      ]++transactionParentsRelation :: Transaction -> TransactionGraph -> Either RelationalError Relation+transactionParentsRelation trans graph = do+  if isRootTransaction trans graph then do+    mkRelation attrs emptyTupleSet+    else do+      parentTransSet <- parentTransactions trans graph+      let tuples = map trans2tuple (S.toList parentTransSet)+      mkRelationFromTuples attrs tuples+  where+    attrs = A.attributesFromList [Attribute "id" TextAtomType]+    trans2tuple trans2 = mkRelationTuple attrs $ V.singleton (TextAtom (T.pack (show $ transactionId trans2)))++{-+--display transaction graph as relation+evalROGraphOp :: DisconnectedTransaction -> TransactionGraph -> ROTransactionGraphOperator -> Either RelationalError Relation+evalROGraphOp discon graph ShowGraph = do+  graphRel <- graphAsRelation discon graph+  return graphRel+-}++-- | Execute the merge strategy against the transactions, returning a new transaction which can be then added to the transaction graph+createMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction+createMergeTransaction newId (SelectedBranchMergeStrategy selectedBranch) graph t2@(trans1, trans2) = do+  selectedTrans <- validateHeadName selectedBranch graph t2+  pure $ Transaction newId (MergeTransactionInfo (transactionId trans1) (transactionId trans2) S.empty) (schemas selectedTrans)+                       +-- merge functions, relvars, individually+createMergeTransaction newId strat@UnionMergeStrategy graph t2 = createUnionMergeTransaction newId strat graph t2++-- merge function, relvars, but, on error, just take the component from the preferred branch+createMergeTransaction newId strat@(UnionPreferMergeStrategy _) graph t2 = createUnionMergeTransaction newId strat graph 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 graph (t1, t2) = do+  case transactionForHead headName graph of+    Nothing -> Left SelectedHeadMismatchMergeError+    Just trans -> if trans /= t1 && trans /= t2 then +                    Left SelectedHeadMismatchMergeError +                  else+                    Right 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+      goalid = transactionId goalTrans+  if currentTrans == goalTrans then+    Right (TransactionGraph resultHeads traverseSet) -- add filter+    --catch root transaction to improve error?+    else do+    currentTransChildren <- liftM S.fromList $ mapM (flip 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)+        childSearches = map searchChild (S.toList searchChildren)+        errors = lefts childSearches+        pathsFound = rights childSearches+        realErrors = filter (/= (FailedToFindTransactionError goalid)) errors+    -- report any non-search-related errors        +    when (not (null realErrors)) (Left (head realErrors))+    -- if no paths found, search the parent+    if null pathsFound then+      case oneParent currentTrans of+        Left RootTransactionTraversalError -> Left (NoCommonTransactionAncestorError currentid goalid)+        Left err -> Left err+        Right currentTransParent -> do      +          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++-- | 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+  let targetId = transactionId targetTransaction+  if transactionId targetTransaction == transactionId currentTransaction then do+    Right accumTransSet+    else do+    currentTransChildren <- mapM (flip transactionForId graph) (S.toList (transactionChildIds currentTransaction))        +    if length currentTransChildren == 0 then+      Left (FailedToFindTransactionError targetId)+      else do+      let searches = map (\t -> pathToTransaction graph t targetTransaction (S.insert t accumTransSet)) currentTransChildren+      let realErrors = filter (/= FailedToFindTransactionError targetId) (lefts searches)+          paths = rights searches+      if length realErrors > 0 then -- found some real errors+        Left (head realErrors)+      else if length paths == 0 then -- failed to find transaction in all children+             Left (FailedToFindTransactionError targetId)+           else --we have some paths!+             Right (S.unions paths)++mergeTransactions :: TransactionId -> TransactionId -> MergeStrategy -> (HeadName, HeadName) -> TransactionGraph -> Either RelationalError (DisconnectedTransaction, TransactionGraph)+mergeTransactions newId parentId mergeStrategy (headNameA, headNameB) graph = do+  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+  let subHeads = M.filterWithKey (\k _ -> elem k [headNameA, headNameB]) (transactionHeadsForGraph graph)+  subGraph <- subGraphOfFirstCommonAncestor graph subHeads transA transB S.empty+  subGraph' <- filterSubGraph subGraph subHeads+  case createMergeTransaction newId mergeStrategy subGraph' (transA, transB) of+    Left err -> Left (MergeTransactionError err)+    Right mergedTrans -> case headNameForTransaction disconParent graph of+      Nothing -> Left (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')+  +--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+      Left err -> show err+      Right parentTransSet -> concat $ S.toList $ S.map (show . transactionId) parentTransSet+  +showGraphStructureX :: TransactionGraph -> String+showGraphStructureX graph@(TransactionGraph heads transSet) = headsInfo ++ S.foldr folder "" transSet+  where+    folder trans acc = acc ++ showTransactionStructureX trans graph ++ "\n"+    headsInfo = show $ M.map transactionId heads+    +-- | After splicing out a subgraph, run it through this function to remove references to transactions which are not in the subgraph.+filterSubGraph :: TransactionGraph -> TransactionHeads -> Either RelationalError TransactionGraph+filterSubGraph graph heads = Right $ TransactionGraph newHeads newTransSet+  where+    validIds = S.map transactionId (transactionsForGraph graph)+    newTransSet = S.map (filterTransaction validIds) (transactionsForGraph graph)+    newHeads = M.map (filterTransaction validIds) heads+    +--helper function for commonalities in union merge+createUnionMergeTransaction :: TransactionId -> MergeStrategy -> TransactionGraph -> (Transaction, Transaction) -> Either MergeError Transaction+createUnionMergeTransaction newId strategy graph (t1,t2) = do+  let contextA = concreteDatabaseContext t1+      contextB = concreteDatabaseContext t2+  +  preference <- case strategy of +    UnionMergeStrategy -> pure PreferNeither+    UnionPreferMergeStrategy preferBranch -> do+      case transactionForHead preferBranch graph of+        Nothing -> Left (PreferredHeadMissingMergeError preferBranch)+        Just preferredTrans -> pure $ if t1 == preferredTrans then PreferFirst else PreferSecond+    badStrat -> Left (InvalidMergeStrategyError badStrat)+          +  incDeps <- 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)+  -- TODO: add merge of subschemas+  let newContext = DatabaseContext {+        inclusionDependencies = incDeps, +        relationVariables = relVars, +        atomFunctions = atomFuncs, +        dbcFunctions = undefined,+        notifications = notifs,+        typeConstructorMapping = types+        }+      newSchemas = Schemas newContext (subschemas t1)+  pure (Transaction newId (MergeTransactionInfo (transactionId t1) (transactionId t2) S.empty) newSchemas)++lookupTransaction :: TransactionGraph -> TransactionIdLookup -> Either RelationalError Transaction+lookupTransaction graph (TransactionIdLookup tid) = transactionForId tid graph+lookupTransaction graph (TransactionIdHeadNameLookup headName backtracks) = case transactionForHead headName graph of +  Nothing -> Left (NoSuchHeadNameError headName)+  Just headTrans -> do+    traversedId <- traverseGraph graph (transactionId headTrans) backtracks+    transactionForId traversedId graph+    +traverseGraph :: TransactionGraph -> TransactionId -> [TransactionIdHeadBacktrack] -> Either RelationalError TransactionId+traverseGraph graph currentTid backtrackSteps = foldM (backtrackGraph graph) currentTid backtrackSteps+             +backtrackGraph :: TransactionGraph -> TransactionId -> TransactionIdHeadBacktrack -> Either RelationalError TransactionId+-- tilde, step back one parent link- if a choice must be made, choose the "first" link arbitrarily+backtrackGraph graph currentTid (TransactionIdHeadParentBacktrack steps) = do+  trans <- transactionForId currentTid graph+  let parents = S.toAscList (transactionParentIds trans)+  if length parents < 1 then+    Left RootTransactionTraversalError+    else do+    parentTrans <- transactionForId (head parents) graph+    if steps == 1 then do+      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+    Left RootTransactionTraversalError    +    else if S.size parents < steps then+           Left (ParentCountTraversalError (S.size parents) steps)+         else+           pure (S.elemAt (steps - 1) parents)+
+ src/lib/ProjectM36/TransactionGraph/Merge.hs view
@@ -0,0 +1,85 @@+--Transaction Merge Engines+module ProjectM36.TransactionGraph.Merge where+import ProjectM36.Base+import ProjectM36.Error+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++data MergePreference = PreferFirst | PreferSecond | PreferNeither++-- Check for overlapping keys. If the values differ, try a preference resolution+unionMergeMaps :: (Ord k, Eq a) => MergePreference -> M.Map k a -> M.Map k a -> Either MergeError (M.Map k a)+unionMergeMaps prefer mapA mapB = case prefer of+  PreferFirst -> pure $ M.union mapA mapB+  PreferSecond -> pure $ M.union mapB mapA+  PreferNeither -> if M.intersection mapA mapB == M.intersection mapA mapB then+                     pure $ M.union mapA mapB+                   else+                     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 union relA 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++--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 prefer relvarsA relvarsB = do+  let allNames = S.toList (S.union (M.keysSet relvarsA) (M.keysSet relvarsB))+  foldM (\acc name -> do+            mergedRel <- do+              let findRel = M.lookup name+                  lookupA = findRel relvarsA+                  lookupB = findRel relvarsB+              case (lookupA, lookupB) of+                (Just relA, Just relB) -> do+                  unionMergeRelation prefer relA relB+                (Nothing, Just relB) -> pure relB +                (Just relA, Nothing) -> pure relA +                (Nothing, Nothing) -> error "impossible relvar naming lookup"+            pure $ M.insert name mergedRel acc+            ) M.empty allNames++-- if two functions have the same name, ensure that the functions are identical, otherwise, conflict or prefer+--because we don't have a bytecode, there is no way to verify that function bodies are equal, so if the types match up, just choose the first function. This is a serious bug, but intractable until we have a function bytecode.+unionMergeAtomFunctions :: MergePreference -> AtomFunctions -> AtomFunctions -> Either MergeError AtomFunctions  +unionMergeAtomFunctions prefer funcsA funcsB = case prefer of+  PreferFirst -> pure $ HS.union funcsA funcsB+  PreferSecond -> pure $ HS.union funcsB funcsA+  PreferNeither -> pure $ HS.union funcsA funcsB+  +unionMergeTypeConstructorMapping :: MergePreference -> TypeConstructorMapping -> TypeConstructorMapping -> Either MergeError TypeConstructorMapping  +unionMergeTypeConstructorMapping prefer typesA typesB = do+  let allFuncNames = S.fromList $ map (\(tc,_) -> TCD.name tc) (typesA ++ typesB)+  foldM (\acc name -> do+            let findType tcm = case filter (\(t,_) -> TCD.name t == name) tcm of+                  [] -> Nothing+                  x:[] -> Just x+                  _ -> error "multiple names matching in TypeConstructorMapping"+                lookupA = findType typesA+                lookupB = findType typesB+                cat t = pure (t : acc)+            case (lookupA, lookupB) of+               (Nothing, Nothing) -> error "type name lookup failure"+               (Just typeA, Nothing) -> cat typeA+               (Nothing, Just typeB) -> cat typeB+               (Just typeA, Just typeB) -> if typeA == typeB then+                                             cat typeA+                                           else --merge conflict+                                             case prefer of +                                               PreferFirst -> cat typeA+                                               PreferSecond -> cat typeB+                                               PreferNeither -> Left StrategyViolatesTypeConstructorMergeError+            ) [] (S.toList allFuncNames)+
+ src/lib/ProjectM36/TransactionGraph/Persist.hs view
@@ -0,0 +1,183 @@+module ProjectM36.TransactionGraph.Persist where+import ProjectM36.Error+import ProjectM36.TransactionGraph+import ProjectM36.Transaction+import ProjectM36.Transaction.Persist+import ProjectM36.Base+import ProjectM36.ScriptSession+import ProjectM36.Persist (writeFileSync, renameSync, DiskSync)+import ProjectM36.FileLock+import System.Directory+import System.FilePath+import System.IO.Temp+import System.IO+import qualified Data.UUID as U+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T+import Data.Text.Encoding+import Control.Monad (foldM)+import Data.Either (isRight)+import Data.Maybe (catMaybes)+import Control.Exception.Base+import qualified Data.Text.IO as TIO+import Data.ByteString (ByteString)+import Data.Monoid+import qualified Crypto.Hash.SHA256 as SHA256++type LockFileHash = ByteString++{-+The "m36v1" file at the top-level of the destination directory contains the the transaction graph as a set of transaction ids referencing their parents (1 or more)+Each Transaction is written to it own directory named by its transaction id. Partially written transactions ids are prefixed with a "." to indicate incompleteness in the graph.++Persistence requires a POSIX-compliant, journaled-metadata filesystem.+-}++transactionLogPath :: FilePath -> FilePath+transactionLogPath dbdir = dbdir </> "m36v1"++headsPath :: FilePath -> FilePath+headsPath dbdir = dbdir </> "heads"++lockFilePath :: FilePath -> FilePath+lockFilePath dbdir = dbdir </> "lockFile"++{-+verify that the database directory is valid or bootstrap it +-note: checking for the existence of every transaction may be prohibitively expensive+- return error or lock file handle which is already locked with a read lock+-}++setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (Handle, LockFileHash))+setupDatabaseDir sync dbdir bootstrapGraph = do+  dbdirExists <- doesDirectoryExist dbdir+  m36exists <- doesFileExist (transactionLogPath dbdir)  +  if dbdirExists && m36exists then do+      --no directories to write, just +      lockFileH <- openLockFile dbdir+      gDigest <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (readGraphTransactionIdFileDigest dbdir)+      pure (Right (lockFileH, gDigest))+    else if not m36exists then do+    locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph+    pure (Right locks)+         else+           pure (Left (InvalidDirectoryError dbdir))+{- +initialize a database directory with the graph from which to bootstrap- return lock file handle+-}+bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Handle, LockFileHash)+bootstrapDatabaseDir sync dbdir bootstrapGraph = do+  createDirectory dbdir+  lockFileH <- openLockFile dbdir+  digest  <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (transactionGraphPersist sync dbdir bootstrapGraph)+  pure (lockFileH, digest)+  +openLockFile :: FilePath -> IO (Handle)  +openLockFile dbdir = do+  lockFileH <- openFile (lockFilePath dbdir) WriteMode+  pure lockFileH++{- +incrementally updates an existing database directory+--algorithm: +--assume that all transaction data has already been written+-assume that all non-head transactions have already been written because this is an incremental (and concurrent!) write method+--store the head names with a symlink to the transaction under "heads"+-}+transactionGraphPersist :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash+transactionGraphPersist sync destDirectory graph = do+  transactionHeadTransactionsPersist sync destDirectory graph+  --write graph file+  newDigest <- writeGraphTransactionIdFile sync destDirectory graph+  --write heads file+  transactionGraphHeadsPersist sync destDirectory graph+  pure newDigest+  +-- | The incremental writer which only writes from the set of heads. New heads must be written on every commit. Most heads will already be written on every commit.+transactionHeadTransactionsPersist :: DiskSync -> FilePath -> TransactionGraph -> IO ()+transactionHeadTransactionsPersist sync destDirectory graphIn = mapM_ (writeTransaction sync destDirectory) $ M.elems (transactionHeadsForGraph graphIn)+  +{- +write graph heads to a file which can be atomically swapped+-}+--writing the heads in a directory is a synchronization nightmare, so just write the binary to a file and swap atomically+transactionGraphHeadsPersist :: DiskSync -> FilePath -> TransactionGraph -> IO ()+transactionGraphHeadsPersist sync dbdir graph = do+  let headFileStr :: (HeadName, Transaction) -> T.Text+      headFileStr (headName, trans) =  headName <> " " <> U.toText (transactionId trans)+  withTempDirectory dbdir ".heads.tmp" $ \tempHeadsDir -> do+    let tempHeadsPath = tempHeadsDir </> "heads"+        headsStrLines = map headFileStr $ M.toList (transactionHeadsForGraph graph)+    writeFileSync sync tempHeadsPath $ T.intercalate "\n" headsStrLines+    renameSync sync tempHeadsPath (headsPath dbdir)+                                                             +transactionGraphHeadsLoad :: FilePath -> IO [(HeadName,TransactionId)]+transactionGraphHeadsLoad dbdir = do+  headsData <- readFile (headsPath dbdir)+  let headsAssocs = map (\l -> let headName:uuidStr:[] = words l in+                          (headName,uuidStr)+                          ) (lines headsData)+  return [(T.pack headName, uuid) | (headName, Just uuid) <- map (\(h,u) -> (h, U.fromString u)) headsAssocs]+  +{-  +load any transactions which are not already part of the incoming transaction graph+-}++transactionGraphLoad :: FilePath -> TransactionGraph -> Maybe ScriptSession -> IO (Either PersistenceError TransactionGraph)+transactionGraphLoad dbdir graphIn mScriptSession = do+  --optimization: perform tail-bisection search to find last-recorded transaction in the existing stream- replay the rest+  --read in all missing transactions from transaction directories and add to graph+  uuidInfo <- readGraphTransactionIdFile dbdir+  freshHeadsAssoc <- transactionGraphHeadsLoad dbdir+  case uuidInfo of+    Left err -> return $ Left err+    Right info -> do  +      let folder = \eitherGraph transId -> case eitherGraph of+            Left err -> return $ Left err+            Right graph -> readTransactionIfNecessary dbdir transId mScriptSession graph+      loadedGraph <- foldM folder (Right graphIn) (map fst info)+      case loadedGraph of +        Left err -> return $ Left err+        Right freshGraph -> do+          let maybeTransHeads = [(headName, transactionForId uuid freshGraph) | (headName, uuid) <- freshHeadsAssoc]+              freshHeads = M.fromList [(headName,trans) | (headName, Right trans) <- maybeTransHeads]+          return $ Right $ TransactionGraph freshHeads (transactionsForGraph freshGraph)+  +{-  +if the transaction with the TransactionId argument is not yet part of the graph, then read the transaction and add it - this does not update the heads+-}+readTransactionIfNecessary :: FilePath -> TransactionId -> Maybe ScriptSession -> TransactionGraph -> IO (Either PersistenceError TransactionGraph)  +readTransactionIfNecessary dbdir transId mScriptSession graphIn = do+  if isRight $ transactionForId transId graphIn then+    --the transaction is already known and loaded- done+    return $ Right graphIn+    else do+    trans <- readTransaction dbdir transId mScriptSession+    case trans of+      Left err -> return $ Left err+      Right trans' -> return $ Right $ TransactionGraph (transactionHeadsForGraph graphIn) (S.insert trans' (transactionsForGraph graphIn))+  +writeGraphTransactionIdFile :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash+writeGraphTransactionIdFile sync destDirectory (TransactionGraph _ transSet) = writeFileSync sync graphFile uuidInfo >> pure digest+  where+    graphFile = destDirectory </> "m36v1"+    uuidInfo = T.intercalate "\n" graphLines+    digest = SHA256.hash (encodeUtf8 uuidInfo)+    graphLines = S.toList $ S.map graphLine transSet +    graphLine trans = U.toText (transactionId trans) <> " " <> T.intercalate " " (S.toList (S.map U.toText $ transactionParentIds trans))+    +readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash+readGraphTransactionIdFileDigest dbdir = do+  graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)+  pure (SHA256.hash (encodeUtf8 graphTransactionIdData))+    +readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, [TransactionId])])+readGraphTransactionIdFile dbdir = do+  --read in all transactions' uuids+  let grapher line = let tids = catMaybes (map U.fromText (T.words line)) in+        (head tids, tail tids)+  --warning: uses lazy IO+  graphTransactionIdData <- TIO.readFile (transactionLogPath dbdir)+  return $ Right (map grapher $ T.lines graphTransactionIdData)+
+ src/lib/ProjectM36/TransactionGraph/Show.hs view
@@ -0,0 +1,21 @@+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+  where+    headInfo = maybe "" show (headNameForTransaction trans graph)+    parentTransactionsInfo = if isRootTransaction trans graph 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+  where+    folder trans acc = acc ++ showTransactionStructure trans graph ++ "\n"+    +
+ src/lib/ProjectM36/Tuple.hs view
@@ -0,0 +1,210 @@+module ProjectM36.Tuple where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.Attribute+import ProjectM36.Atom+import ProjectM36.AtomType+import ProjectM36.DataTypes.Primitive++import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Vector as V+import Data.Either (rights)+import Control.Monad++emptyTuple :: RelationTuple+emptyTuple = RelationTuple V.empty V.empty++tupleSize :: RelationTuple -> Int+tupleSize (RelationTuple tupAttrs _) = V.length tupAttrs++tupleAttributeNameSet :: RelationTuple -> S.Set AttributeName+tupleAttributeNameSet (RelationTuple tupAttrs _) = S.fromList $ V.toList $ V.map attributeName tupAttrs++tupleAttributes :: RelationTuple -> Attributes+tupleAttributes (RelationTuple tupAttrs _) = tupAttrs++tupleAssocs :: RelationTuple -> [(AttributeName, Atom)]+tupleAssocs (RelationTuple attrVec tupVec) = V.toList $ V.map (\(k,v) -> (attributeName k, v)) (V.zip attrVec tupVec)++-- return atoms in some arbitrary but consistent key order+tupleAtoms :: RelationTuple -> V.Vector Atom+tupleAtoms (RelationTuple _ tupVec) = tupVec++atomForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom+atomForAttributeName attrName (RelationTuple tupAttrs tupVec) = case V.findIndex (\attr -> attributeName attr == attrName) tupAttrs of+  Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName)+  Just index -> case tupVec V.!? index of+    Nothing -> Left $ NoSuchAttributeNamesError (S.singleton attrName)+    Just atom -> Right atom++{- -- resolve naming clash with Attribute and Relation later+atomTypeForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Atom+atomTypeForAttributeName attrName tup = do+  atom <- atomForAttributeName attrName tup+  return $ atomTypeForAtom atom+-}++atomsForAttributeNames :: V.Vector AttributeName -> RelationTuple -> Either RelationalError (V.Vector Atom)+atomsForAttributeNames attrNames tuple = do+  vindices <- vectorIndicesForAttributeNames attrNames (tupleAttributes tuple)+  return $ V.map (\index -> tupleAtoms tuple V.! index) vindices+      +vectorIndicesForAttributeNames :: V.Vector AttributeName -> Attributes -> Either RelationalError (V.Vector Int)+vectorIndicesForAttributeNames attrNameVec attrs = if not $ V.null unknownAttrNames then+                                                     Left $ NoSuchAttributeNamesError (S.fromList (V.toList unknownAttrNames))+                                                   else+                                                     Right $ V.map mapper attrNameVec+  where+    unknownAttrNames = V.filter ((flip V.notElem) (attributeNames attrs)) attrNameVec+    mapper attrName = case V.elemIndex attrName (V.map attributeName attrs) of+      Nothing -> error "logic failure in vectorIndicesForAttributeNames"+      Just index -> index++relationForAttributeName :: AttributeName -> RelationTuple -> Either RelationalError Relation+relationForAttributeName attrName tuple = do+  aType <- atomTypeForAttributeName attrName (tupleAttributes tuple)+  if not (isRelationAtomType aType) then+    Left $ AttributeIsNotRelationValuedError attrName+    else do+     atomVal <- atomForAttributeName attrName tuple+     relationForAtom atomVal++--in case the oldattr does not exist in the tuple, then return the old tuple+tupleRenameAttribute :: AttributeName -> AttributeName -> RelationTuple -> RelationTuple+tupleRenameAttribute oldattr newattr (RelationTuple tupAttrs tupVec) = RelationTuple newAttrs tupVec+  where+    newAttrs = renameAttributes oldattr newattr tupAttrs++mkRelationTuple :: Attributes -> V.Vector Atom -> RelationTuple+mkRelationTuple attrs atoms = RelationTuple attrs atoms++mkRelationTuples :: Attributes -> [V.Vector Atom] -> [RelationTuple]+mkRelationTuples attrs atomsVec = map mapper atomsVec+  where+    mapper = mkRelationTuple attrs+    +mkRelationTupleFromMap :: M.Map AttributeName Atom -> RelationTuple+mkRelationTupleFromMap attrMap = RelationTuple attrs (V.map (\attrName -> attrMap M.! attrName) attrNames)+  where+    attrNames = V.fromList (M.keys attrMap)+    attrs = V.map (\attrName -> Attribute attrName (atomTypeForAtom (attrMap M.! attrName))) attrNames++--return error if attribute names match but their types do not+singleTupleSetJoin :: Attributes -> RelationTuple -> RelationTupleSet -> Either RelationalError [RelationTuple]+singleTupleSetJoin joinAttrs tup tupSet = do+    foldM tupleJoiner [] (asList tupSet) +  where+    tupleJoiner :: [RelationTuple] -> RelationTuple -> Either RelationalError [RelationTuple]+    tupleJoiner accumulator tuple2 = case singleTupleJoin joinAttrs tup tuple2 of+        Right Nothing -> Right accumulator+        Right (Just relTuple) -> Right $ relTuple : accumulator+        Left err -> Left err+            +{-            +singleTupleSetJoin :: RelationTuple -> RelationTupleSet -> RelationTupleSet+singleTupleSetJoin tup1 tupSet = HS.union +  where+    mapper tup2 = singleTupleJoin tup1 tup2+-}+            +-- if the keys share some keys and values, then merge the tuples+-- if there are shared attributes, if they match, create a new tuple from the atoms of both tuples based on the attribute ordering argument+singleTupleJoin :: Attributes -> RelationTuple -> RelationTuple -> Either RelationalError (Maybe RelationTuple)+singleTupleJoin joinedAttrs tup1@(RelationTuple tupAttrs1 _) tup2@(RelationTuple tupAttrs2 _) = if+  V.null keysIntersection || atomsForAttributeNames keysIntersection tup1 /= atomsForAttributeNames keysIntersection tup2+  then+    return $ Nothing+  else+    return $ Just $ RelationTuple joinedAttrs newVec+  where+    keysIntersection = V.map attributeName attrsIntersection+    attrsIntersection = V.filter (flip V.elem $ tupAttrs1) tupAttrs2+    newVec = V.map (findAtomForAttributeName . attributeName) joinedAttrs+    --search both tuples for the attribute+    findAtomForAttributeName attrName = head $ rights $ fmap (atomForAttributeName attrName) [tup1, tup2]++--same consideration as Data.List.union- duplicates in v1 are not de-duped+vectorUnion :: (Eq a) => V.Vector a -> V.Vector a -> V.Vector a+vectorUnion v1 v2 = V.foldr folder v1 v2+  where+    folder e acc = if V.elem e v1 then+                     acc+                   else+                     V.snoc acc e++--precondition- no overlap in attributes+tupleExtend :: RelationTuple -> RelationTuple -> RelationTuple+tupleExtend (RelationTuple tupAttrs1 tupVec1) (RelationTuple tupAttrs2 tupVec2) = RelationTuple newAttrs newVec+  where+    newAttrs = tupAttrs1 V.++ tupAttrs2+    newVec = tupVec1 V.++ tupVec2++tupleAtomExtend :: AttributeName -> Atom -> RelationTuple -> RelationTuple+tupleAtomExtend newAttrName atom tupIn = tupleExtend tupIn newTup+  where+    newTup = RelationTuple (V.singleton $ Attribute newAttrName (atomTypeForAtom atom)) (V.singleton atom)++{- sort the associative list to match the header sorting -}+tupleSortedAssocs :: RelationTuple -> [(AttributeName, Atom)]+tupleSortedAssocs (RelationTuple tupAttrs tupVec) = V.toList $ V.map (\(index,attr) -> (attributeName attr, tupVec V.! index)) $ V.indexed tupAttrs++--this could be cheaper- it may not be wortwhile to update all the tuples for projection, but then the attribute management must be slightly different- perhaps the attributes should be a vector of association tuples [(name, index)]+tupleProject :: S.Set AttributeName -> RelationTuple -> RelationTuple+tupleProject projectAttrs (RelationTuple attrs tupVec) = RelationTuple newAttrs newTupVec+  where+    deleteIndices = V.findIndices (\attr -> S.notMember (attributeName attr) projectAttrs) attrs+    indexDeleter = V.ifilter (\index _ -> V.notElem index deleteIndices)+    newAttrs = indexDeleter attrs+    newTupVec = indexDeleter tupVec++--return the attributes and atoms which are equal in both vectors+--semi-join+tupleIntersection :: RelationTuple -> RelationTuple -> RelationTuple+tupleIntersection tuple1 tuple2 = RelationTuple newAttrs newTupVec+  where+    attrs1 = tupleAttributes tuple1+    attrs2 = tupleAttributes tuple2+    matchingIndices = V.findIndices (\attr -> V.elem attr attrs2 &&+                                              atomForAttributeName (attributeName attr) tuple1 ==+                                              atomForAttributeName (attributeName attr) tuple2+                                    ) attrs1+    indexFilter = V.ifilter (\index _ -> V.elem index matchingIndices)+    newAttrs = indexFilter attrs1+    newTupVec = indexFilter (tupleAtoms tuple1)++-- | An optimized form of tuple update which updates vectors efficiently.+updateTupleWithAtoms :: (M.Map AttributeName Atom) -> RelationTuple -> RelationTuple+updateTupleWithAtoms updateMap (RelationTuple attrs tupVec) = RelationTuple attrs newVec+  where+    updateKeysSet = M.keysSet updateMap+    updateKeysIVec = V.filter (\(_,attr) -> S.member (attributeName attr) updateKeysSet) (V.indexed attrs)+    newVec = V.update tupVec updateVec+    updateVec = V.map (\(index, attr) -> (index, updateMap M.! (attributeName attr))) updateKeysIVec++tupleToMap :: RelationTuple -> (M.Map AttributeName Atom)+tupleToMap (RelationTuple attrs tupVec) = M.fromList assocList+  where+    assocList = V.toList $ V.map (\(index, attr) -> (attributeName attr, tupVec V.! index)) (V.indexed attrs)++verifyTuple :: Attributes -> RelationTuple -> Either RelationalError RelationTuple+verifyTuple attrs tuple = let attrsTypes = V.map atomType attrs+                              tupleTypes = V.map atomTypeForAtom (tupleAtoms tuple) in+  if V.length attrs /= V.length tupleTypes then+    Left $ TupleAttributeCountMismatchError 0+  else do+    mapM_ (uncurry atomTypeVerify) (V.zip attrsTypes tupleTypes)+    Right tuple++--two tuples can be equal but the vectors of attributes could be out-of-order+--reorder if necessary- this is useful during relMogrify so that all the relation's tuples have identical atom/attribute ordering+reorderTuple :: Attributes -> RelationTuple -> RelationTuple+reorderTuple attrs tupIn = if tupleAttributes tupIn == attrs then+                             tupIn+                           else do+                             RelationTuple attrs (V.map mapper attrs)+  where+    mapper attr = case atomForAttributeName (attributeName attr) tupIn of+      Left _ -> error "logic failure in reorderTuple"+      Right atom -> atom+
+ src/lib/ProjectM36/TupleSet.hs view
@@ -0,0 +1,33 @@+module ProjectM36.TupleSet where+import ProjectM36.Base+import ProjectM36.Tuple+import ProjectM36.Error+import qualified Data.HashSet as HS+import qualified Data.Vector as V+import qualified Control.Parallel.Strategies as P+import Data.Either++emptyTupleSet :: RelationTupleSet+emptyTupleSet = RelationTupleSet []++singletonTupleSet :: RelationTupleSet+singletonTupleSet = RelationTupleSet [emptyTuple]++--ensure that all maps have the same keys and key count++verifyTupleSet :: Attributes -> RelationTupleSet -> Either RelationalError RelationTupleSet+verifyTupleSet attrs tupleSet = do+  --check that all tuples have the same attributes and that the atom types match+  let tupleList = (map (verifyTuple attrs) (asList tupleSet)) `P.using` P.parListChunk chunkSize P.r0+      chunkSize = ((length . asList) tupleSet) `div` 24+  --let tupleList = P.parMap P.rdeepseq (verifyTuple attrs) (HS.toList tupleSet)+  if length (lefts tupleList) > 0 then+    Left $ head (lefts tupleList)+   else+     return $ RelationTupleSet $ (HS.toList . HS.fromList) (rights tupleList)++mkTupleSet :: Attributes -> [RelationTuple] -> Either RelationalError RelationTupleSet+mkTupleSet attrs tuples = verifyTupleSet attrs (RelationTupleSet tuples)++mkTupleSetFromList :: Attributes -> [[Atom]] -> Either RelationalError RelationTupleSet+mkTupleSetFromList attrs atomMatrix = mkTupleSet attrs $ map (\atomList -> mkRelationTuple attrs (V.fromList atomList)) atomMatrix
+ src/lib/ProjectM36/TypeConstructor.hs view
@@ -0,0 +1,19 @@+module ProjectM36.TypeConstructor where+import ProjectM36.Base+import qualified Data.Set as S++name :: TypeConstructor -> TypeConstructorName+name (ADTypeConstructor name' _) = name'+name (PrimitiveTypeConstructor name' _) = name'+name (TypeVariable _) = error "spam" --v --not really the name, but this is used for display only++arguments :: TypeConstructor -> [TypeConstructor]+arguments (ADTypeConstructor _ args) = args+arguments (PrimitiveTypeConstructor _ _) = []+arguments (TypeVariable _) = []++typeVars :: TypeConstructor -> S.Set TypeVarName+typeVars (PrimitiveTypeConstructor _ _) = S.empty+typeVars (ADTypeConstructor _ args) = S.unions (map typeVars args)+typeVars (TypeVariable v) = S.singleton v+
+ src/lib/ProjectM36/TypeConstructorDef.hs view
@@ -0,0 +1,11 @@+module ProjectM36.TypeConstructorDef where+import ProjectM36.Base++name :: TypeConstructorDef -> TypeConstructorName+name (ADTypeConstructorDef nam _) = nam+name (PrimitiveTypeConstructorDef nam _) = nam++typeVars :: TypeConstructorDef -> [TypeVarName]+typeVars (PrimitiveTypeConstructorDef _ _) = []                      +typeVars (ADTypeConstructorDef _ args) = args+
+ src/lib/ProjectM36/Win32Handle.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}+module ProjectM36.Win32Handle where+import System.Win32.Types+import Control.Exception (bracket)+import Foreign.StablePtr+import Foreign.C.Types+import Control.Concurrent.MVar++#if __GLASGOW_HASKELL__ >= 612+import GHC.IO.Handle.Types (Handle(..), Handle__(..))+import GHC.IO.FD (FD(..)) -- A wrapper around an Int32+import Data.Typeable+#else+import GHC.IOBase (Handle(..), Handle__(..))+import qualified GHC.IOBase as IOBase (FD) -- Just an Int32+#endif++-- This essential function comes from the C runtime system. It is certainly provided by msvcrt, and also seems to be provided by the mingw C library - hurrah!+#if __GLASGOW_HASKELL__ >= 612+foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: CInt -> IO HANDLE+#else+foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE+#endif++-- copied from ansi-terminal package+-- | This bit is all highly dubious.  The problem is that we want to output ANSI to arbitrary Handles rather than forcing+-- people to use stdout.  However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able+-- to extract one of those from the Haskell Handle.+--+-- This code accomplishes this, albeit at the cost of only being compatible with GHC.+withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a+withHandleToHANDLE haskell_handle action = +    -- Create a stable pointer to the Handle. This prevents the garbage collector+    -- getting to it while we are doing horrible manipulations with it, and hence+    -- stops it being finalized (and closed).+    withStablePtr haskell_handle $ const $ do+        -- Grab the write handle variable from the Handle+        let write_handle_mvar = case haskell_handle of+                FileHandle _ handle_mvar     -> handle_mvar+                DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one+        +        -- Get the FD from the algebraic data type+#if __GLASGOW_HASKELL__ < 612+        fd <- fmap haFD $ readMVar write_handle_mvar+#else+        --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev)+        Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar+#endif++        -- Finally, turn that (C-land) FD into a HANDLE using msvcrt+        windows_handle <- cget_osfhandle fd+        +        -- Do what the user originally wanted+        action windows_handle++withStablePtr :: a -> (StablePtr a -> IO b) -> IO b+withStablePtr value = bracket (newStablePtr value) freeStablePtr
+ test/IsomorphicSchema.hs view
@@ -0,0 +1,128 @@+import Test.HUnit+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.IsomorphicSchema+import ProjectM36.Relation+import ProjectM36.RelationalExpression+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]++main :: IO ()           +main = do +  tcounts <- runTestTT testList+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++assertEither :: (Show a) => Either a b -> IO b+assertEither x = case x of+  Left err -> assertFailure (show err) >> undefined+  Right val -> pure val++{-  +assertMaybe :: Maybe a -> String -> IO a  +assertMaybe x msg = case x of+  Nothing -> assertFailure msg >> undefined+  Just x' -> pure x'+-}+  +-- create some potential schemas which should not be accepted  +testSchemaValidation :: Test+testSchemaValidation = TestCase $ do  +  let potentialSchema = DBC.basicDatabaseContext {+        relationVariables = M.singleton "anotherRel" relationTrue+        }+  -- missing relvars failure+      morphs = [IsoRename "true" "true", IsoRename "false" "false"]+      missingRelVarError = Just (RelVarReferencesMissing (S.singleton "anotherRel"))+  assertEqual "missing relvar validation" missingRelVarError (validateSchema (Schema morphs) potentialSchema)+  -- duplicate relvar mention+  let morphs' = [IsoRename "true" "true", IsoRename "false" "true", IsoRename "true" "anotherRel"]+      duplicateRelVarError = Just (RelVarOutReferencedMoreThanOnce "true")+  assertEqual "duplicate relvars in morphs" duplicateRelVarError (validateSchema (Schema morphs') potentialSchema)+  +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)]+        }+      isomorphsAtoB = [IsoRename "emp" "employee", +                       IsoRename "department" "department"]+      unionExpr = Union (RelationVariable "emp" ()) (RelationVariable "department" ())      +  relExpr <- assertEither (applyRelationalExprSchemaIsomorphs isomorphsAtoB unionExpr)+  let relResult = runReader (evalRelationalExpr relExpr) schemaA                             +  assertEqual "employee relation morph" (Right relationTrue) relResult+  +testIsoRestrict :: Test+testIsoRestrict = TestCase $ do+  -- create a emp relation which is restricted into two boss, nonboss rel vars+  -- the virtual schema has an employee+  let empattrs = (A.attributesFromList [Attribute "name" TextAtomType,+                                        Attribute "boss" TextAtomType])+  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)+            +  let schemaA = mkRelationalExprState DBC.empty {+        relationVariables = M.fromList [("nonboss", nonBossRel),+                                        ("boss", 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+  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)+  --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)+  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+  motorsRel <- assertEither $ mkRelationFromList (A.attributesFromList [Attribute "name" TextAtomType,+                                                                        Attribute "power" IntAtomType]) +               [[TextAtom "Puny", IntAtom 10],+                [TextAtom "Scooter", IntAtom 49],+                [TextAtom "Auto", IntAtom 200],+                [TextAtom "Tractor", IntAtom 500]]+  let baseSchema = mkRelationalExprState DBC.basicDatabaseContext {+        relationVariables = M.singleton "motor" motorsRel+        }+      splitPredicate = AtomExprPredicate (FunctionAtomExpr "lt" [AttributeAtomExpr "power", NakedAtomExpr (IntAtom 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+  lowpowerExpr <- assertEither (processRelationalExprInSchema (Schema splitIsomorphs) (RelationVariable "lowpower" ()))+  lowpowerRel <- assertEither (relResult lowpowerExpr)+  highpowerExpr <- assertEither (processRelationalExprInSchema (Schema splitIsomorphs) (RelationVariable "highpower" ()))+  highpowerRel <- assertEither (relResult highpowerExpr)+  assertEqual "lowpower relation difference" (Right lowpowerRel) lowmotors+  assertEqual "highpower relation difference" (Right highpowerRel) highmotors
+ test/MultiProcessDatabaseAccess.hs view
@@ -0,0 +1,53 @@+--tests which cover multi-process access to the same database directory+import Test.HUnit+import ProjectM36.Client+import ProjectM36.Error++import System.IO.Temp+import System.Exit+import System.FilePath++main :: IO ()+main = do+  tcounts <- runTestTT testList+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess  +  +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+  +assertIONothing :: (Show a) => IO (Maybe a) -> IO ()+assertIONothing x = do+  ret <- x+  case ret of+    Nothing -> pure ()+    Just err -> assertFailure (show err)+  +testList :: Test+testList = TestList [testMultipleProcessAccess]++testMultipleProcessAccess :: Test+testMultipleProcessAccess = TestCase $ do+  withSystemTempDirectory "pm36" $ \tmpdir -> do+    let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []+        master = "master"+        dudExpr = Assign "x" (RelationVariable "true" ())+        dbdir = tmpdir </> "db"+    conn1 <- assertIOEither $ connectProjectM36 connInfo+    conn2 <- assertIOEither $ connectProjectM36 connInfo+    session1 <- assertIOEither (createSessionAtHead master conn1)+    session2 <- assertIOEither (createSessionAtHead master conn2)+    --add a commit on conn1 which conn2 doesn't know about+    assertIONothing $ executeDatabaseContextExpr session1 conn1 dudExpr+    assertIONothing $ commit session1 conn1 ForbidEmptyCommitOption+    +    assertIONothing $ executeDatabaseContextExpr session2 conn2 dudExpr+    mHeadId <- headTransactionId session2 conn2+    headId <- case mHeadId of+      Nothing -> assertFailure "headTransactionId failed" >> undefined+      Just x -> pure x+    res <- commit session2 conn2 ForbidEmptyCommitOption+    assertEqual "commit should fail" (Just (TransactionIsNotAHeadError headId)) res
+ test/Relation/Atomable.hs view
@@ -0,0 +1,116 @@+--Test Atomable typeclass which allows users to use existing Haskell datatypes to marshal them to and from the database as ConstructedAtoms.+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, OverloadedStrings #-}+import Test.HUnit+import ProjectM36.Client+import Data.Binary+import Control.DeepSeq+import System.Exit+import TutorialD.Interpreter.TestBase+import GHC.Generics+import ProjectM36.Relation+import ProjectM36.Base+import Data.Time.Calendar (fromGregorian)+import Data.Text+import qualified Data.Map as M++data Test1T = Test1C Int+            deriving (Generic, Show, Eq, Binary, NFData, Atomable)+                    +data Test2T x = Test2C x+              deriving (Show, Generic, Eq, Binary, NFData, Atomable)+                       +data Test3T = Test3C Int Int                        +              deriving (Show, Generic, Eq, Binary, NFData, Atomable)+                       +data Test4T = Test4Ca Int |                       +              Test4Cb Int +              deriving (Show, Generic, Eq, Binary, NFData, Atomable)+                       +data TestListT = TestListC [Int]+              deriving (Show, Generic, Eq, Binary, NFData, Atomable)+                       +data Test5T = Test5C {+  con1 :: Int,+  con2 :: Int+  } deriving (Show, Generic, Eq, Binary, NFData, Atomable)+                       +main :: IO ()+main = do+  tcounts <- runTestTT testList+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testList :: Test+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance]++-- test some basic data types like int, day, etc.+testBasicMarshaling :: Test+testBasicMarshaling = TestCase $ do+    assertEqual "to IntAtom" (IntAtom 5) (toAtom (5 :: Int))+    assertEqual "from IntAtom" (5 :: Int) (fromAtom (IntAtom 5))++    assertEqual "to BoolAtom" (BoolAtom False) (toAtom False)+    assertEqual "from BoolAtom" False (fromAtom (BoolAtom False))++    let day = fromGregorian 2012 10 19+    assertEqual "to DayAtom" (DayAtom day) (toAtom day)+    assertEqual "from DayAtom" day (fromAtom (DayAtom day))+  +--test marshaling of Generics-derived Atom to database ADT+testHaskell2DB :: Test+testHaskell2DB = TestCase $ do+  --validate generated database context expression+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  let test1TExpr = toDatabaseContextExpr (undefined :: Test1T)+      expectedTest1TExpr = AddTypeConstructor (ADTypeConstructorDef "Test1T" []) [DataConstructorDef "Test1C" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" IntAtomType)]]+  assertEqual "simple ADT1" expectedTest1TExpr test1TExpr+  checkExecuteDatabaseContextExpr sessionId dbconn test1TExpr+  --execute some expressions involving Atomable data types+ +  let createRelExpr = Assign "x" rel+            +      rel = MakeRelationFromExprs Nothing+            [TupleExpr (M.singleton "a1" (NakedAtomExpr atomVal))]+      atomVal = toAtom exampleVal+      exampleVal = Test1C 10+  checkExecuteDatabaseContextExpr sessionId dbconn createRelExpr+  +  let retrieveValExpr = Restrict (AttributeEqualityPredicate "a1" (NakedAtomExpr atomVal)) (RelationVariable "x" ())+  ret <- executeRelationalExpr sessionId dbconn retrieveValExpr+  let expectedRel = mkRelationFromList (attributesFromList [Attribute "a1" (toAtomType exampleVal)]) [[atomVal]]+  assertEqual "retrieve atomable atom" expectedRel ret+  +testADT1 :: Test+testADT1 = TestCase $ do+  let example = Test1C 3+  assertEqual "one arg constructor" example (fromAtom (toAtom example))+  +testADT2 :: Test  +testADT2 = TestCase $ do+  let sampletext = "text" :: Text+      example = Test2C sampletext+  assertEqual "polymorphic type constructor" example (fromAtom (toAtom example))+  +testADT3 :: Test  +testADT3 = TestCase $ do+  let example = Test3C 3 4+  assertEqual "product type" example (fromAtom (toAtom example))+  +testADT4 :: Test  +testADT4 = TestCase $ do+  let example = Test4Ca 3+      example2 = Test4Cb 4+  assertEqual "sum type + one constructor arg 1" example (fromAtom (toAtom example))+  assertEqual "sum type + one constructor arg 2" example2 (fromAtom (toAtom example2))+  +testADT5 :: Test  +testADT5 = TestCase $ do+  let example = Test5C {con1=3, con2=4}+  assertEqual "record-based ADT" example (fromAtom (toAtom example))  +  +checkExecuteDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO ()+checkExecuteDatabaseContextExpr sessionId dbconn expr = executeDatabaseContextExpr sessionId dbconn expr >>= maybe (pure ()) (\err -> assertFailure (show err))++testListInstance :: Test+testListInstance = TestCase $ do+  let example = TestListC [3,4,5]+  assertEqual "List instance" example (fromAtom (toAtom example))
+ test/Relation/Basic.hs view
@@ -0,0 +1,95 @@+import Test.HUnit+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.Error+import ProjectM36.DateExamples+import ProjectM36.DataTypes.Primitive+import ProjectM36.RelationalExpression+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+import qualified Data.Set as S+import System.Exit+++testList :: Test+testList = TestList [testRelation "relationTrue" relationTrue, testRelation "relationFalse" relationFalse,+                     testMkRelation1,+                     testRename1, testRename2,+                     testRelation "suppliers" suppliersRel,+                     testRelation "products" productsRel,+                     testRelation "supplierProducts" supplierProductsRel,+                     testMkRelationFromExprsBadAttrs]++main :: IO ()           +main = do +  tcounts <- runTestTT testList+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testRelation :: String -> Relation -> Test+testRelation testName rel = TestCase $ assertEqual testName relationValidation (Right rel)+  where+    relationValidation = validateRelation rel++-- run common relation checks+validateRelation :: Relation -> Either RelationalError Relation+validateRelation rel = do+  _ <- validateAttrNamesMatchTupleAttrNames rel+  validateAttrTypesMatchTupleAttrTypes rel+  +validateAttrNamesMatchTupleAttrNames :: Relation -> Either RelationalError Relation+validateAttrNamesMatchTupleAttrNames rel@(Relation _ tupSet) +  | null invalidSet = Right rel+  | otherwise = Left $ AttributeNamesMismatchError S.empty+  where+    nameCheck tuple = attributeNames rel == tupleAttributeNameSet tuple+    invalidSet = filter (not . nameCheck) (asList tupSet)+    +validateAttrTypesMatchTupleAttrTypes :: Relation -> Either RelationalError Relation+validateAttrTypesMatchTupleAttrTypes rel@(Relation attrs tupSet) = foldr (\tuple acc -> +                                                                              if (tupleAttributes tuple) == attrs && tupleAtomCheck tuple then +                                                                                acc +                                                                              else+                                                                                Left $ TupleAttributeTypeMismatchError A.emptyAttributes+                                                                            ) (Right rel) (asList tupSet)+  where+    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) ==+                                  A.atomTypeForAttributeName (A.attributeName attr) attrs) (attributes rel)+    +simpleRel :: Relation    +simpleRel = case mkRelation attrs tupleSet of+  Right rel -> rel+  Left _ -> undefined+  where+    attrs = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" TextAtomType]+    tupleSet = RelationTupleSet [mkRelationTuple attrs (V.fromList [TextAtom "spam", TextAtom "spam2"])]+    +--rename tests+testRename1 :: Test+testRename1 = TestCase $ assertEqual "attribute invalid" (rename "a" "b" relationTrue) (Left $ AttributeNamesMismatchError (S.singleton "a"))++testRename2 :: Test+testRename2 = TestCase $ assertEqual "attribute in use" (rename "b" "a" simpleRel) (Left $ AttributeNameInUseError "a")++--mkRelation tests+--test tupleset key mismatch failure+testMkRelation1 :: Test+testMkRelation1 = TestCase $ assertEqual "key mismatch" expectedError (mkRelation testAttrs testTupSet) -- the error attribute set is empty due to an optimization- the tuple attrs do not match the atoms' types+  where+    expectedError = Left (AtomTypeMismatchError TextAtomType IntAtomType)+    testAttrs = A.attributesFromList [Attribute "a" TextAtomType]+    testTupSet = RelationTupleSet [mkRelationTuple testAttrs $ V.fromList [TextAtom "v"],+                                   mkRelationTuple testAttrs $ V.fromList [IntAtom 2]]++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+    Left err -> assertEqual "tuple type mismatch" (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "badAttr2" IntAtomType])) err+    Right _ -> assertFailure "expected tuple type mismatch"
+ test/Relation/Export/CSV.hs view
@@ -0,0 +1,32 @@+import Test.HUnit+import ProjectM36.Base+import System.Exit+import ProjectM36.Relation.Show.CSV+import ProjectM36.Relation.Parse.CSV+import qualified ProjectM36.Attribute as A+import ProjectM36.Relation++main :: IO ()           +main = do +  tcounts <- runTestTT $ TestList [testCSVExport]+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++--round-trip a basic relation through CSV+testCSVExport :: Test+testCSVExport = TestCase $ do+  let attrs = A.attributesFromList [Attribute "S#" TextAtomType, +                                    Attribute "SNAME" TextAtomType, +                                    Attribute "STATUS" IntAtomType, +                                    Attribute "CITY" TextAtomType]+      relOrErr = mkRelationFromList attrs [+        [TextAtom "S9", TextAtom "Perry", IntAtom 170, TextAtom "Londonderry"],+        [TextAtom "S8", TextAtom "Mike", IntAtom 150, TextAtom "Boston"]]+  case relOrErr of +    Left err -> assertFailure $ "export relation creation failure: " ++ (show err)+    Right rel -> do+      case relationAsCSV rel of+        Left err -> assertFailure $ "export failed: " ++ (show err)+        Right csvData -> case csvAsRelation csvData attrs of -- import csv data back to relation+          Left err -> assertFailure $ "re-import failed: " ++ (show err)+          Right rel' -> assertEqual "relation CSV comparison" rel rel'+
+ test/Relation/Import/CSV.hs view
@@ -0,0 +1,29 @@+import Test.HUnit+import ProjectM36.Base+import ProjectM36.Relation.Parse.CSV+import ProjectM36.Relation+import qualified ProjectM36.Attribute as A+import System.Exit+import qualified Data.Text.Lazy as T+import Data.Text.Lazy.Encoding+++main :: IO ()           +main = do +  tcounts <- runTestTT $ TestList [testCSVSuccess]+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testCSVSuccess :: Test+testCSVSuccess = TestCase $ do+  let sampleCSV = (encodeUtf8 . T.pack) "S#,CITY,STATUS,SNAME\n\"S8\",\"Boston\",150,\"Mike\"\nS9,Londonderry,170,Perry"+      expectedAttrs = A.attributesFromList [Attribute "S#" TextAtomType, +                                            Attribute "SNAME" TextAtomType, +                                            Attribute "STATUS" IntAtomType, +                                            Attribute "CITY" TextAtomType]+      expectedRel = mkRelationFromList expectedAttrs [+        [TextAtom "S9", TextAtom "Perry", IntAtom 170, TextAtom "Londonderry"],+        [TextAtom "S8", TextAtom "Mike", IntAtom 150, TextAtom "Boston"]]+  case csvAsRelation sampleCSV expectedAttrs of+    Left err -> assertFailure $ show err+    Right csvRel -> assertEqual "csv->relation" expectedRel (Right csvRel)+
+ test/Relation/StaticOptimizer.hs view
@@ -0,0 +1,39 @@+import ProjectM36.Base+import ProjectM36.Relation+import ProjectM36.RelationalExpression+import ProjectM36.DateExamples+import ProjectM36.TupleSet+import ProjectM36.StaticOptimizer+import System.Exit+import Control.Monad.State+import Control.Monad.Trans.Reader+import Test.HUnit++main :: IO ()+main = do+  tcounts <- runTestTT (TestList tests)+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess+  where+    tests = relationOptTests ++ databaseOptTests+    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")),+      ("StaticRestrictTrue", Right $ relvar "s", Restrict TruePredicate (relvar "s")),+      ("StaticRestrictFalse", Right $ MakeStaticRelation (attributes suppliersRel) emptyTupleSet, Restrict (NotPredicate TruePredicate) (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"))])+      ]
+ test/Server/Main.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE CPP #-}+{-+test client/server interaction+-}+import Test.HUnit+import ProjectM36.Client+import qualified ProjectM36.Client as C+import ProjectM36.Server.EntryPoints+import ProjectM36.Server+import ProjectM36.Server.Config+import ProjectM36.Relation+import ProjectM36.TupleSet+import ProjectM36.IsomorphicSchema+import ProjectM36.Base++import System.Exit++import Control.Concurrent+import Network.Transport (EndPointAddress)+import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)+import Data.Either (isRight)+import Data.Maybe (isJust)+import Control.Exception+--import Control.Monad.IO.Class+#if defined(linux_HOST_OS)+import System.Directory+#endif++testList :: SessionId -> Connection -> MVar () -> Test+testList sessionId conn notificationTestMVar = TestList $ serverTests ++ sessionTests+  where+    sessionTests = map (\t -> t sessionId conn) [+      testRelationalExpr,+      testSchemaExpr,+      testTypeForRelationalExpr,  +      testDatabaseContextExpr,+      testGraphExpr,+      testPlanForDatabaseContextExpr,+      testTransactionGraphAsRelation,+      testHeadTransactionId,+      testHeadName,+      testSession,+      testRelationVariableSummary,+      testNotification notificationTestMVar+      ] +    serverTests = [testRequestTimeout, testFileDescriptorCount]+           +main :: IO ()+main = do+  (serverAddress, _) <- launchTestServer 0+  notificationTestMVar <- newEmptyMVar +  eTestConn <- testConnection serverAddress notificationTestMVar+  case eTestConn of+    Left err -> putStrLn (show err) >> exitFailure+    Right (session, testConn) -> do+      tcounts <- runTestTT (testList session testConn notificationTestMVar)+      if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++{-main = do+    tcounts <- runTestTT (TestList [testRequestTimeout])+    if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess-}+                                                                     +testDatabaseName :: DatabaseName+testDatabaseName = "test"++testConnection :: EndPointAddress -> MVar () -> IO (Either ConnectionError (SessionId, Connection))+testConnection serverAddress mvar = do+  let Just (host, service, _) = decodeEndPointAddress serverAddress+      serverAddress' = encodeEndPointAddress host service 1  +  let connInfo = RemoteProcessConnectionInfo testDatabaseName (NodeId serverAddress') (testNotificationCallback mvar)+  --putStrLn ("testConnection: " ++ show serverAddress)+  eConn <- connectProjectM36 connInfo+  case eConn of +    Left err -> pure $ Left err+    Right conn -> do+      eSessionId <- createSessionAtHead defaultHeadName conn+      case eSessionId of+        Left _ -> error "failed to create session"+        Right sessionId -> pure $ Right (sessionId, conn)++-- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread+launchTestServer :: Timeout -> IO (EndPointAddress, ThreadId)+launchTestServer ti = do+  let config = defaultServerConfig { databaseName = testDatabaseName, +                                     perRequestTimeout = ti,+                                     testMode = True,+                                     bindPort = 0+                                   }+  addressMVar <- newEmptyMVar+  tid <- forkIO $ launchServer config (Just addressMVar) >> pure ()+  endPointAddress <- takeMVar addressMVar+  --liftIO $ putStrLn ("launched server on " ++ show endPointAddress)+  pure (endPointAddress, tid)+  +testRelationalExpr :: SessionId -> Connection -> Test  +testRelationalExpr sessionId conn = TestCase $ do+  relResult <- executeRelationalExpr sessionId conn (RelationVariable "true" ())+  assertEqual "invalid relation result" (Right relationTrue) relResult+  +-- test adding an removing a schema against true/false relations  +testSchemaExpr :: SessionId -> Connection -> Test+testSchemaExpr sessionId conn = TestCase $ do+  result <- executeSchemaExpr sessionId conn (AddSubschema "test-schema" [IsoRename "table_dee" "true", IsoRename "table_dum" "false"])+  assertEqual "executeSchemaExpr" Nothing result+  result' <- executeSchemaExpr sessionId conn (RemoveSubschema "test-schema")+  assertEqual "executeSchemaExpr2" Nothing result'+  +testDatabaseContextExpr :: SessionId -> Connection -> Test+testDatabaseContextExpr sessionId conn = TestCase $ do +  let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Text" TextAtomType) ()]+      attrs = attributesFromList [Attribute "x" TextAtomType]+      testrv = "testrv"+  dbResult <- executeDatabaseContextExpr sessionId conn (Define testrv attrExprs)+  case dbResult of+    Just err -> assertFailure (show err)+    Nothing -> do+      eRel <- executeRelationalExpr sessionId conn (RelationVariable testrv ())+      let expected = mkRelation attrs emptyTupleSet+      case eRel of+        Left err -> assertFailure (show err)+        Right rel -> assertEqual "dbcontext definition failed" expected (Right rel)+        +testGraphExpr :: SessionId -> Connection -> Test        +testGraphExpr sessionId conn = TestCase $ do+  graphResult <- executeGraphExpr sessionId conn (JumpToHead "master")+  case graphResult of+    Just err -> assertFailure (show err)+    Nothing -> pure ()+    +testTypeForRelationalExpr :: SessionId -> Connection -> Test+testTypeForRelationalExpr sessionId conn = TestCase $ do+  relResult <- typeForRelationalExpr sessionId conn (RelationVariable "true" ())+  case relResult of+    Left err -> assertFailure (show err)+    Right rel -> assertEqual "typeForRelationalExpr failure" relationFalse rel+    +testPlanForDatabaseContextExpr :: SessionId -> Connection -> Test    +testPlanForDatabaseContextExpr sessionId conn = TestCase $ do+  let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Int" IntAtomType) ()]+      testrv = "testrv"+      dbExpr = Define testrv attrExprs+  planResult <- planForDatabaseContextExpr sessionId conn dbExpr+  case planResult of+    Left err -> assertFailure (show err)+    Right plan -> assertEqual "planForDatabaseContextExpr failure" dbExpr plan+        +testTransactionGraphAsRelation :: SessionId -> Connection -> Test    +testTransactionGraphAsRelation sessionId conn = TestCase $ do+  eGraph <- transactionGraphAsRelation sessionId conn+  case eGraph of+    Left err -> assertFailure (show err)+    Right _ -> pure ()+    +testHeadTransactionId :: SessionId -> Connection -> Test    +testHeadTransactionId sessionId conn = TestCase $ do+  uuid <- headTransactionId sessionId conn+  assertBool "invalid head transaction uuid" (isJust uuid)+  pure ()+  +testHeadName :: SessionId -> Connection -> Test+testHeadName sessionId conn = TestCase $ do+  mHeadName <- headName sessionId conn+  assertEqual "headName failure" (Just "master") mHeadName+  +testRelationVariableSummary :: SessionId -> Connection -> Test  +testRelationVariableSummary sessionId conn = TestCase $ do+  eRel <- C.relationVariablesAsRelation sessionId conn+  case eRel of +    Left err -> assertFailure ("relvar summary failed " ++ show err)+    Right rel -> assertBool "invalid tuple count in relvar summary" (cardinality rel == Finite 2)+  +testSession :: SessionId -> Connection -> Test+testSession _ conn = TestCase $ do+  -- create and close a new session using AtHead and AtCommit+  eSessionId1 <- createSessionAtHead defaultHeadName conn+  case eSessionId1 of+    Left _ -> assertFailure "invalid session" +    Right sessionId1 -> do+      mHeadId <- headTransactionId sessionId1 conn+      case mHeadId of+        Nothing -> assertFailure "invalid head id"+        Just headId -> do+          eSessionId2 <- createSessionAtCommit headId conn+          assertBool ("invalid session: " ++ show eSessionId2) (isRight eSessionId2)+          closeSession sessionId1 conn++testNotificationCallback :: MVar () -> NotificationCallback+testNotificationCallback mvar _ _ = putMVar mvar ()++-- create a relvar x, add a notification on x, update x and wait for the notification+testNotification :: MVar () -> SessionId -> Connection -> Test+testNotification mvar sess conn = TestCase $ do+  let relvarx = RelationVariable "x" ()+      check x = x >>= maybe  (pure ()) (\err -> assertFailure (show err))+  check $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue))+  check $ executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx)  +  check $ commit sess conn ForbidEmptyCommitOption+  check $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse))+  check $ commit sess conn ForbidEmptyCommitOption+  takeMVar mvar++testRequestTimeout :: Test+testRequestTimeout = TestCase $ do+  (serverAddress, serverTid) <- launchTestServer 1000+  unusedMVar <- newEmptyMVar       +  eTestConn <- testConnection serverAddress unusedMVar  +  --eTestConn <- testConnection (encodeEndPointAddress "127.0.0.1" "10000" 1) unusedMVar+  case eTestConn of+    Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure+    Right (session, testConn) -> do+      res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))+      assertBool "exception was not thrown" (not res)+      killThread serverTid+      +testFileDescriptorCount :: Test+#if defined(linux_HOST_OS)+--validate that creating a server, connecting a client, and then disconnecting doesn't leak file descriptors+testFileDescriptorCount = TestCase $ do+  (serverAddress, serverTid) <- launchTestServer 1000+  startCount <- fdCount+  unusedMVar <- newEmptyMVar+  Right (_, testConn) <- testConnection serverAddress unusedMVar+  close testConn+  endCount <- fdCount+  assertEqual "fd leak" startCount endCount+  killThread serverTid+  +-- returns the number of open file descriptors -- linux only /proc usage+fdCount :: IO Int+fdCount = do+  fds <- getDirectoryContents "/proc/self/fd"+  pure ((length fds) - 2)+#else +--pass on non-linux platforms+testFileDescriptorCount = TestCase (pure ())+#endif
+ test/Server/WebSocket.hs view
@@ -0,0 +1,104 @@+-- test the websocket server++import Test.HUnit+import qualified Network.WebSockets as WS+import ProjectM36.Server.WebSocket+import ProjectM36.Server.Config+import ProjectM36.Server+import ProjectM36.Client+import Network.Socket+import Control.Exception+import Control.Concurrent+import System.Exit+import Data.Typeable+import Data.Text hiding (map)+import Data.Aeson+import ProjectM36.Base+import qualified Data.Map as M+import qualified Data.ByteString.Lazy as BS+import ProjectM36.Relation+import Network.Transport.TCP (decodeEndPointAddress)++--start the websocket server+-- run some tutoriald against it++launchTestServer :: IO (PortNumber, DatabaseName)+launchTestServer = do+  addressMVar <- newEmptyMVar+  let config = defaultServerConfig { databaseName = testDatabaseName, +                                     bindPort = 0 }+      testDatabaseName = "test"+  -- start normal server+  _ <- forkIO (launchServer config (Just addressMVar) >> pure ())+  serverAddress <- takeMVar addressMVar+  let wsServerHost = "127.0.0.1"+      wsServerPort = 8889+      Just (dbHost, dbPort, _) = decodeEndPointAddress serverAddress      +  -- start websocket server proxy -- runServer doesn't support returning an arbitrary socket+  _ <- forkIO (WS.runServer wsServerHost wsServerPort (websocketProxyServer (read dbPort) dbHost))+  --wait for socket to be listening+  waitForListenSocket 5 (fromIntegral wsServerPort)+  pure (fromIntegral wsServerPort, testDatabaseName)+  +data TestException = WaitForSocketListenException+                   deriving (Show, Typeable)+                            +instance Exception TestException                            ++waitForListenSocket :: Int -> PortNumber -> IO ()  +waitForListenSocket secondsToTry port = do+  if secondsToTry <= 0 then+    throw WaitForSocketListenException+    else do+    hostaddr <- inet_addr "127.0.0.1"+    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+  +main :: IO ()+main = do+  (port, dbname) <- launchTestServer+  tcounts <- runTestTT (testList port dbname)+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testList :: PortNumber -> DatabaseName -> Test+testList port dbName = TestList $ map (\f -> f port dbName) [testBasicConnection,+                                                             testTutorialD]+                          +basicConnection :: PortNumber -> WS.ClientApp () -> IO ()+basicConnection port block = WS.runClient "127.0.0.1" (fromIntegral port) "/" block++basicConnectionWithDatabase :: PortNumber -> DatabaseName -> WS.ClientApp () -> IO ()+basicConnectionWithDatabase port dbname block = basicConnection port (\conn -> do+                                                                WS.sendTextData conn ("connectdb:" `append` (pack dbname))+                                                                block conn)+    +testBasicConnection :: PortNumber -> DatabaseName -> Test+testBasicConnection port _ = TestCase $ basicConnection port (\conn -> WS.sendClose conn ("test close"::Text))++testTutorialD :: PortNumber -> DatabaseName -> Test+testTutorialD port dbname = TestCase $ basicConnectionWithDatabase port dbname testtutd+  where+    discardPromptInfo conn = do+      response <- WS.receiveData conn :: IO BS.ByteString+      let decoded = decode response :: Maybe (M.Map Text (M.Map Text Text))+      case decoded of+        Just _ -> pure ()+        Nothing ->  assertFailure ("failed to decode prompt info: " ++ show response)+      +    testtutd conn = do+      discardPromptInfo conn+      WS.sendTextData conn ("executetutd:" `append` ":showexpr true")+      discardPromptInfo conn+      discardPromptInfo conn+      +      --receive relation response+      response <- WS.receiveData conn :: IO BS.ByteString      +      let decoded = decode response :: Maybe (M.Map Text Relation)+      +      case decoded of+        Just val -> assertEqual "round-trip true relation" (M.lookup "displayrelation" val) (Just relationTrue) >> WS.sendClose conn ("test close"::Text)+        Nothing -> assertFailure ("failed to decode relation from: " ++ show response)
+ test/TransactionGraph/Merge.hs view
@@ -0,0 +1,223 @@+-- tests for transaction merging+import Test.HUnit+import ProjectM36.Base+import ProjectM36.Attribute+import ProjectM36.Relation+import ProjectM36.Transaction+import ProjectM36.TransactionGraph+import ProjectM36.Error+import qualified Data.ByteString.Lazy as BS+import System.Exit+import Data.Word+import ProjectM36.RelationalExpression+import qualified ProjectM36.DisconnectedTransaction as Discon+import qualified Data.UUID as U+import qualified Data.Set as S+import qualified Data.Map as M+import qualified ProjectM36.DatabaseContext as DBC+import Control.Monad.State hiding (join)++main :: IO ()           +main = do +  tcounts <- runTestTT testList+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testList :: Test+testList = TestList [+  testSubGraphToFirstAncestorBasic,+  testSubGraphToFirstAncestorSnipBranch,+  testSubGraphToFirstAncestorMoreTransactions,+  testSelectedBranchMerge,+  testUnionMergeStrategy,+  testUnionPreferMergeStrategy+  ]++-- | Create a transaction graph with two branches and no changes between them.+{-+root 1+|--- branchA aaaa +|--- branchB bbbb+-}++createTrans :: TransactionId -> TransactionInfo -> DatabaseContext -> Transaction+createTrans tid info ctx = Transaction tid info (Schemas ctx M.empty)++basicTransactionGraph :: IO TransactionGraph+basicTransactionGraph = do+  let bsGraph = bootstrapTransactionGraph uuidRoot DBC.empty --dateExamples+      rootTrans = case transactionForHead "master" bsGraph of+        Just trans -> trans+        Nothing -> error "bonk"+      uuidA = fakeUUID 10+      uuidB = fakeUUID 11+      uuidRoot = fakeUUID 1+      rootContext = concreteDatabaseContext rootTrans+  (_, bsGraph') <- addTransaction "branchA" (createTrans uuidA (TransactionInfo uuidRoot S.empty) rootContext) bsGraph+  (_, bsGraph'') <- addTransaction "branchB" (createTrans uuidB (TransactionInfo uuidRoot S.empty) rootContext) bsGraph'+  pure bsGraph''+  +addTransaction :: HeadName -> Transaction -> TransactionGraph -> IO (Transaction, TransactionGraph)+addTransaction headName transaction graph = case addTransactionToGraph headName transaction graph of+  Left err -> assertFailure (show err) >> error ""+  Right (t,g) -> pure (t,g)+              +fakeUUID :: Word8 -> TransactionId+fakeUUID x = case U.fromByteString (BS.concat (replicate 4 w32)) of+  Nothing -> error "impossible uuid"+  Just u -> u+  where w32 = BS.pack (replicate 4 x)+  +assertEither :: (Show a) => Either a b -> IO b+assertEither x = case x of+  Left err -> assertFailure (show err) >> undefined+  Right val -> pure val+  +assertGraph :: TransactionGraph -> IO ()  +assertGraph graph = case validateGraph graph of+  Nothing -> pure ()+  Just errs -> assertFailure (show errs)+  +assertMaybe :: Maybe a -> String -> IO a+assertMaybe x msg = case x of+  Nothing -> assertFailure msg >> undefined+  Just x' -> pure x'+  +-- | Test that a subgraph of the basic graph is equal to the original graph (nothing to filter).+testSubGraphToFirstAncestorBasic :: Test  +testSubGraphToFirstAncestorBasic = TestCase $ do+  graph <- basicTransactionGraph +  assertGraph graph+  transA <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA"+  transB <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB"+  subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph graph) transA transB S.empty+  let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)  +  assertEqual "no graph changes" (graphEq subgraph) (graphEq graph)+  +-- | Test that a branch anchored at the root transaction is removed when using the first ancestor function.+testSubGraphToFirstAncestorSnipBranch :: Test  +testSubGraphToFirstAncestorSnipBranch = TestCase $ do+  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) (concreteDatabaseContext transA)) baseGraph+  subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph (transactionHeadsForGraph baseGraph) transA transB S.empty+  assertGraph subgraph+  let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)  +  assertEqual "failed to snip branch" (graphEq baseGraph) (graphEq subgraph)+  +-- | Test that the subgraph function recurses properly through multiple parent transactions.  +testSubGraphToFirstAncestorMoreTransactions :: Test+testSubGraphToFirstAncestorMoreTransactions = TestCase $ do+  graph <- basicTransactionGraph+  assertGraph graph+  +  -- add another relvar to branchB+  branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"+  (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of+    (Just err, _) -> assertFailure (show err) >> undefined+    (Nothing, context) -> pure context+  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) 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) (concreteDatabaseContext branchATrans)) graph'+  branchATrans' <- assertMaybe (transactionForHead "branchA" graph'') "failed to get branchA head"+  assertEqual "branchA id 4" (fakeUUID 4) (transactionId branchATrans')+                                              +  --retrieve subgraph                                            +  let subGraphHeads = M.filter (\t -> elem (transactionId t) [fakeUUID 3, fakeUUID 4]) (transactionHeadsForGraph graph'')+  subgraph <- assertEither $ subGraphOfFirstCommonAncestor graph'' subGraphHeads branchATrans' branchBTrans' S.empty+  --verify that the subgraph includes both the heads and the common ancestor+  let expectedTransSet = S.fromList (map fakeUUID [1,3,4])+  assertBool "validate transactions in subgraph" (S.isProperSubsetOf expectedTransSet (S.map transactionId (transactionsForGraph subgraph)))+  +testSelectedBranchMerge :: Test+testSelectedBranchMerge = TestCase $ do+  graph <- basicTransactionGraph+  assertGraph graph+  +  -- add another relvar to branchB+  branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"+  (updatedBranchBContext,_,_) <- case runState (evalDatabaseContextExpr (Assign "branchBOnlyRelvar" (ExistingRelation relationTrue))) (freshDatabaseState (concreteDatabaseContext branchBTrans)) of+    (Just err, _) -> assertFailure (show err) >> undefined+    (Nothing, context) -> pure context+  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph+  --create the merge transaction in the graph+  let eGraph' = mergeTransactions (fakeUUID 4) (fakeUUID 10) (SelectedBranchMergeStrategy "branchA") ("branchA", "branchB") graph'+      +  (_, graph'') <- assertEither eGraph'++  assertGraph graph''+  --validate that the branchB remains+  branchBTrans' <- assertMaybe (transactionForHead "branchB" graph'') "failed to find branchB head"+  assertEqual "head of merged transaction was removed" (transactionId branchBTrans') (fakeUUID 3)++  --validate that the branchB relvar does *not* appear in the merge because branchA was selected+  mergeTrans <- assertEither (transactionForId (fakeUUID 4) graph'')+  assertBool "branchOnlyRelvar is present in merge" (M.notMember "branchBOnlyRelvar" (relationVariables (concreteDatabaseContext mergeTrans)))++-- try various individual component conflicts and check for resolution+testUnionPreferMergeStrategy :: Test+testUnionPreferMergeStrategy = TestCase $ do+  -- create a graph with a relvar conflict+  graph <- basicTransactionGraph+  branchATrans <- assertMaybe (transactionForHead "branchA" graph) "branchATrans"+  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"++  (_, graph') <- addTransaction "branchA" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchATrans) S.empty) branchAContext) graph+  (_, graph'') <- addTransaction "branchB" (createTrans (fakeUUID 4) (TransactionInfo (transactionId branchBTrans) S.empty) branchBContext) graph'+  -- validate that the conflict is hidden because we preferred a branch+  let merged = mergeTransactions (fakeUUID 5) (fakeUUID 3) (UnionPreferMergeStrategy "branchB") ("branchA", "branchB") graph''+  case merged of+    Left err -> assertFailure ("expected merge success: " ++ show err)+    Right (discon, _) -> do+      assertEqual "branchB relvar preferred in conflict" (Just branchBRelVar) (M.lookup conflictRelVarName (relationVariables (Discon.concreteDatabaseContext discon)))+  +-- try various individual component conflicts and check for merge failure+testUnionMergeStrategy :: Test+testUnionMergeStrategy = TestCase $ do+  graph <- basicTransactionGraph+  assertGraph graph+  +  branchBTrans <- assertMaybe (transactionForHead "branchB" graph) "failed to get branchB head"+  branchATrans <- assertMaybe (transactionForHead "branchA" graph) "failed to get branchA head"+  -- add another relvar to branchB - branchBOnlyRelvar should appear in the merge  +  -- add inclusion dependency in branchA++  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+      branchAOnlyIncDepName = "branchAOnlyIncDep"+      branchBOnlyRelVarName = "branchBOnlyRelVar"+      branchAOnlyIncDep = InclusionDependency (ExistingRelation relationTrue) (ExistingRelation relationTrue)+  (_, graph') <- addTransaction "branchB" (createTrans (fakeUUID 3) (TransactionInfo (transactionId branchBTrans) S.empty) updatedBranchBContext) graph+  (discon, _) <- assertEither $ mergeTransactions (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) updatedBranchAContext) graph'+  let eMergeGraph = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") 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])+      -- 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))+      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) }+      conflictBranchATrans <- assertMaybe (transactionForHead "branchA" graph'') "retrieving head transaction for expected conflict"+      (_, graph''') <- addTransaction "branchA" (createTrans (fakeUUID 6) (TransactionInfo (transactionId conflictBranchATrans) S.empty) conflictContextA) graph''+      let failingMerge = mergeTransactions (fakeUUID 5) (fakeUUID 3) UnionMergeStrategy ("branchA", "branchB") graph'''+      case failingMerge of+        Right _ -> assertFailure "expected merge failure"+        Left err -> assertEqual "merge failure" err (MergeTransactionError StrategyViolatesRelationVariableMergeError)
+ test/TransactionGraph/Persist.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE LambdaCase #-}+import Test.HUnit+import ProjectM36.Base+import ProjectM36.Persist (DiskSync(NoDiskSync))+import ProjectM36.TransactionGraph.Persist+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+import Data.UUID.V4 (nextRandom)+import System.FilePath+import TutorialD.Interpreter.DatabaseContextExpr+import qualified Data.Map as M+import qualified Data.Set as S++main :: IO ()           +main = do +  tcounts <- runTestTT testList+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess+  +testList :: Test+testList = TestList [testBootstrapDB, +                     testDBSimplePersistence, +                     testFunctionPersistence]++{- bootstrap a database, ensure that it can be read -}+testBootstrapDB :: Test+testBootstrapDB = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do+  let dbdir = tempdir </> "dbdir"+  freshId <- nextRandom+  _ <- bootstrapDatabaseDir NoDiskSync dbdir (bootstrapTransactionGraph freshId dateExamples)+  loadedGraph <- transactionGraphLoad dbdir emptyTransactionGraph Nothing+  assertBool "transactionGraphLoad" $ isRight loadedGraph++{- create a database with several transactions, ensure that all transactions can be read -}+testDBSimplePersistence :: Test+testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do+  let dbdir = tempdir </> "dbdir"+  freshId <- nextRandom+  let graph = bootstrapTransactionGraph freshId dateExamples+  _ <- bootstrapDatabaseDir NoDiskSync dbdir graph+  case transactionForHead "master" graph of+    Nothing -> assertFailure "Failed to retrieve head transaction for master branch."+    Just headTrans -> do+          case interpretDatabaseContextExpr (concreteDatabaseContext headTrans) "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 freshId' "master" newdiscon graph+              --add a transaction to the graph+              case addTrans of+                Left err -> assertFailure (show err)+                Right (_, graph') -> do+                  --persist the new graph+                  _ <- transactionGraphPersist NoDiskSync dbdir graph'+                  --reload the graph from the filesystem and confirm that the transaction is present+                  graphErr <- transactionGraphLoad dbdir emptyTransactionGraph Nothing+                  let mapEq graphArg = S.map transactionId (transactionsForGraph graphArg)+                  case graphErr of+                    Left err -> assertFailure (show err)+                    Right graph'' -> assertBool "graph equality" (mapEq graph'' == mapEq graph')+      ++--only Haskell-scripted dbc and atom functions can be serialized                   +testFunctionPersistence :: Test+testFunctionPersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \tempdir -> do+  let dbdir = tempdir </> "dbdir"+      connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []+  Right conn <- connectProjectM36 connInfo+  Right sess <- createSessionAtHead "master" conn+  let intTCons = PrimitiveTypeConstructor "Int" IntAtomType+      addfunc = AddAtomFunction "testdisk" [+        intTCons, +        ADTypeConstructor "Either" [ADTypeConstructor "AtomFunctionError" [],+                                    intTCons]] "(\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom"+  Nothing <- executeDatabaseContextIOExpr sess conn addfunc+  Nothing <- commit sess conn ForbidEmptyCommitOption+  close conn+  --re-open the connection to reload the graph+  Right conn2 <- connectProjectM36 connInfo+  Right sess2 <- createSessionAtHead "master" conn2+  +  res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))])+  let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]+  assertEqual "testdisk dbc function run" expectedRel res+    +
+ test/TutorialD/Interpreter.hs view
@@ -0,0 +1,432 @@+import TutorialD.Interpreter.DatabaseContextExpr+import TutorialD.Interpreter.TestBase+import TutorialD.Interpreter+import TutorialD.Interpreter.Base+import Test.HUnit+import ProjectM36.Relation+import ProjectM36.Tuple+import ProjectM36.TupleSet+import ProjectM36.Error+import ProjectM36.DatabaseContext+import ProjectM36.AtomFunctions.Primitive+import ProjectM36.DataTypes.Either+import ProjectM36.DateExamples+import ProjectM36.Base hiding (Finite)+import ProjectM36.TransactionGraph+import ProjectM36.Client+import qualified ProjectM36.DisconnectedTransaction as Discon+import qualified ProjectM36.Session as Sess+import qualified ProjectM36.Attribute as A+import qualified Data.Map as M+import System.Exit+import Data.Maybe (isJust)+import qualified Data.Vector as V+import Data.Text.Encoding as TE+import Control.Concurrent+import qualified Data.Set as S+import Data.Text hiding (map)+import qualified Data.Text as T+import Data.Time.Clock.POSIX++main :: IO ()+main = do+  tcounts <- runTestTT (TestList tests)+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess+  where+    tests = map (\(tutd, expected) -> TestCase $ assertTutdEqual basicDatabaseContext expected tutd) simpleRelTests ++ map (\(tutd, expected) -> TestCase $ assertTutdEqual dateExamples expected tutd) dateExampleRelTests ++ [transactionGraphBasicTest, transactionGraphAddCommitTest, transactionRollbackTest, transactionJumpTest, transactionBranchTest, simpleJoinTest, testNotification, testTypeConstructors, testMergeTransactions, testComments, testTransGraphRelationalExpr, failJoinTest, testMultiAttributeRename, testSchemaExpr, testRelationalExprStateTupleElems, testFunctionalDependencies, testEmptyCommits]+    simpleRelTests = [("x:=true", Right relationTrue),+                      ("x:=false", Right relationFalse),+                      ("x:=true union false", Right relationTrue),+                      ("x:=true minus false", Right relationTrue),+                      ("x:=false minus true", Right relationFalse),                      +                      ("x:=true; x:=false", Right relationFalse),+                      ("x:=relation{a Int}{}", mkRelation simpleAAttributes emptyTupleSet),+                      ("x:=relation{c Int}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),+                      ("y:=relation{b Int, c Int}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),+                      ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [(RelationTuple simpleCAttributes) (V.fromList [TextAtom "spam", IntAtom 5])]),+                      ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),+                      ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),+                      ("x:=relation{}{}", Right relationFalse),+                      ("x:=relation{tuple{}}", Right relationTrue),+                      ("x:=true where true", Right relationTrue),+                      ("x:=true where false", Right relationFalse),+                      ("x:=true where true or false", Right relationTrue),+                      ("x:=true where false or false", Right relationFalse),+                      ("x:=true where true and false", Right relationFalse),+                      ("x:=true where true and true", Right relationTrue),+                      ("x:=true=true", Right relationTrue),+                      ("x:=true=false", Right relationFalse),+                      ("x:=true; undefine x", Left (RelVarNotDefinedError "x")),+                      ("x:=relation {b Int, a Text}{}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList[TextAtom "spam", IntAtom 5]]),+                      -- test nested relation constructor+                      ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [IntAtom 5, RelationAtom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [IntAtom 6]])])]),+                      ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntAtom 5])]),+                      ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 5])]),+                      ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 6])]),+                      ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 10])]),+                      ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntAtomType TextAtomType)),+                      ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntAtom 5, IntAtom 12])])+                     ]+    simpleAAttributes = A.attributesFromList [Attribute "a" IntAtomType]+    simpleBAttributes = A.attributesFromList [Attribute "d" IntAtomType]+    simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntAtomType]+    simpleDAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" IntAtomType]+    maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)+    maybeIntAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntAtomType)+    simpleMaybeTextAttributes = A.attributesFromList [Attribute "a" maybeTextAtomType]+    simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntAtomType]+    simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntAtomType TextAtomType)]+    simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntAtomType]+    nestedRelationAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntAtomType])]+    extendTestAttributes = A.attributesFromList [Attribute "a" IntAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]+    byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]    +    groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]+    minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntAtomType]+    updateParisPlus10 = relMap (\tuple -> do+                                   statusAtom <- atomForAttributeName "status" tuple+                                   cityAtom <- atomForAttributeName "city" tuple+                                   if cityAtom == TextAtom "Paris" then+                                     Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom ((castInt statusAtom) + 10))) tuple+                                     else Right tuple) suppliersRel+    dateExampleRelTests = [("x:=s where true", Right suppliersRel),+                           ("x:=s where city = \"London\"", restrict (\tuple -> atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),+                           ("x:=s where false", Right $ Relation (attributes suppliersRel) emptyTupleSet),+                           ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntAtom 12, TextAtom "Paris"]]),+                           ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntAtomType]) (V.fromList [IntAtom 50])])),+                           ("x:=s minus (s where status=20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntAtom 30, TextAtom "Athens"]]),+                           --atom function tests+                           ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),+                           ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel])])),+                           ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == (Right $ TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),+                           ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),+                           --relatom function tests+                           ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1)])),+                           ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),+                           --boolean function restriction+                           ("x:=s where ^lt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"]]),+                           ("x:=s where ^gt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntAtom 30, TextAtom "Paris"],+                                                                                                       [TextAtom "S5", TextAtom "Adams", IntAtom 30, TextAtom "Athens"]]),+                           ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntAtomType BoolAtomType),+                           ("x:=s where ^not(gte(@status,20))", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntAtom 10, TextAtom "Paris"]]),+                           --test "all but" attribute inversion syntax+                           ("x:=s{all but s#} = s{city,sname,status}", Right $ relationTrue),+                           --test key syntax+                           ("x:=s; key testconstraint {s#,city} x; insert x relation{tuple{city \"London\", s# \"S1\", sname \"gonk\", status 50}}", Left (InclusionDependencyCheckError "testconstraint")),+                           ("y:=s; key testconstraint {s#} y; insert y relation{tuple{city \"London\", s# \"S6\", sname \"gonk\", status 50}}; x:=y{s#} = s{s#} union relation{tuple{s# \"S6\"}}", Right $ relationTrue),+                           --test binary bytestring data type+                           ("x:=relation{tuple{y makeByteString(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),+                           --test Maybe Text+                           ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]),+                           --test Maybe Int+                           ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntAtomType [IntAtom 3]]]),+                           --test Either Int Text+                           ("x:=relation{tuple{a Left 3}}",  Left (TypeConstructorTypeVarsMismatch (S.fromList ["a","b"]) (S.fromList ["a"]))), -- Left 3, alone is not enough information to imply the type+                           ("x:=relation{a Either Int Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntAtomType TextAtomType) [IntAtom 3]]]),+                           --test datetime constructor+                           ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]])+                          ]++assertTutdEqual :: DatabaseContext -> Either RelationalError Relation -> Text -> Assertion+assertTutdEqual databaseContext expected tutd = assertEqual (unpack tutd) expected interpreted+  where+    interpreted = case interpretDatabaseContextExpr databaseContext tutd of+      Left err -> Left err+      Right context -> case M.lookup "x" (relationVariables context) of+        Nothing -> Left $ RelVarNotDefinedError "x"+        Just rel -> Right rel++transactionGraphBasicTest :: Test+transactionGraphBasicTest = TestCase $ do+  (_, dbconn) <- dateExamplesConnection emptyNotificationCallback+  graph <- transactionGraph_ dbconn+  assertEqual "validate bootstrapped graph" (validateGraph graph) Nothing++--add a new transaction to the graph, validate it is in the graph+transactionGraphAddCommitTest :: Test+transactionGraphAddCommitTest = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  case parseTutorialD "x:=s" of+    Left err -> assertFailure (show err)+    Right parsed -> do +      result <- evalTutorialD sessionId dbconn UnsafeEvaluation parsed+      case result of+        QuitResult -> assertFailure "quit?"+        DisplayResult _ -> assertFailure "display?"+        DisplayIOResult _ -> assertFailure "displayIO?"+        DisplayRelationResult _ -> assertFailure "displayrelation?"+        DisplayParseErrorResult _ _ -> assertFailure "displayparseerror?"+        DisplayErrorResult err -> assertFailure (show err)   +        QuietSuccessResult -> do+          commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail+          discon <- disconnectedTransaction_ sessionId dbconn+          let context = Discon.concreteDatabaseContext discon+          assertEqual "ensure x was added" (M.lookup "x" (relationVariables context)) (Just suppliersRel)++transactionRollbackTest :: Test+transactionRollbackTest = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  graph <- transactionGraph_ dbconn+  maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ()))+  case maybeErr of+    Just err -> assertFailure (show err)+    Nothing -> do+      rollback sessionId dbconn >>= maybeFail+      discon <- disconnectedTransaction_ sessionId dbconn+      graph' <- transactionGraph_ dbconn+      assertEqual "validate context" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))+      let graphEq graphArg = S.map transactionId (transactionsForGraph graphArg)+      assertEqual "validate graph" (graphEq graph) (graphEq graph')++--commit a new transaction with "x" relation, jump to first transaction, verify that "x" is not present+transactionJumpTest :: Test+transactionJumpTest = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  (DisconnectedTransaction firstUUID _ _) <- disconnectedTransaction_ sessionId dbconn+  maybeErr <- executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ()))+  case maybeErr of+    Just err -> assertFailure (show err)+    Nothing -> do+      commit sessionId dbconn ForbidEmptyCommitOption >>= maybeFail+      --perform the jump+      maybeErr2 <- executeGraphExpr sessionId dbconn (JumpToTransaction firstUUID)+      case maybeErr2 of+        Just err -> assertFailure (show err)+        Nothing -> do+          --check that the disconnected transaction does not include "x"+          discon <- disconnectedTransaction_ sessionId dbconn+          assertEqual "ensure x is not present" Nothing (M.lookup "x" (relationVariables (Discon.concreteDatabaseContext discon)))          +--branch from the first transaction and verify that there are two heads+transactionBranchTest :: Test+transactionBranchTest = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  mapM_ (\x -> x >>= maybeFail) [executeGraphExpr sessionId dbconn (Branch "test"),+                  executeDatabaseContextExpr sessionId dbconn (Assign "x" (RelationVariable "s" ())),+                  commit sessionId dbconn ForbidEmptyCommitOption,+                  executeGraphExpr sessionId dbconn (JumpToHead "master"),+                  executeDatabaseContextExpr sessionId dbconn (Assign "y" (RelationVariable "s" ()))+                  ]+  graph <- transactionGraph_ dbconn+  assertBool "master branch exists" $ isJust (transactionForHead "master" graph)+  assertBool "test branch exists" $ isJust (transactionForHead "test" graph)++-- test that overlapping attribute names with different types fail with an error+failJoinTest :: Test+failJoinTest = TestCase $ assertTutdEqual basicDatabaseContext err "x:=relation{tuple{test 4}} join relation{tuple{test \"test\"}}"+  where+    err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntAtomType]))++simpleJoinTest :: Test+simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=s join sp"+    where+        attrs = A.attributesFromList [Attribute "city" TextAtomType,+                                      Attribute "qty" IntAtomType,+                                      Attribute "p#" TextAtomType,+                                      Attribute "s#" TextAtomType,+                                      Attribute "sname" TextAtomType,+                                      Attribute "status" IntAtomType]+        joinedRel = mkRelationFromList attrs [[TextAtom "London", IntAtom 100, TextAtom "P6", TextAtom "S1", TextAtom "Smith", IntAtom 20],+                                              [TextAtom "London", IntAtom 400, TextAtom "P3", TextAtom "S1", TextAtom "Smith", IntAtom 20],+                                              [TextAtom "London", IntAtom 400, TextAtom "P5", TextAtom "S4", TextAtom "Clark", IntAtom 20],+                                              [TextAtom "London", IntAtom 300, TextAtom "P1", TextAtom "S1", TextAtom "Smith", IntAtom 20],+                                              [TextAtom "Paris", IntAtom 200, TextAtom "P2", TextAtom "S3", TextAtom "Blake", IntAtom 30],+                                              [TextAtom "Paris", IntAtom 300, TextAtom "P1", TextAtom "S2", TextAtom "Jones", IntAtom 10],+                                              [TextAtom "London", IntAtom 100, TextAtom "P5", TextAtom "S1", TextAtom "Smith", IntAtom 20],+                                              [TextAtom "London", IntAtom 300, TextAtom "P4", TextAtom "S4", TextAtom "Clark", IntAtom 20],+                                              [TextAtom "Paris", IntAtom 400, TextAtom "P2", TextAtom "S2", TextAtom "Jones", IntAtom 10],+                                              [TextAtom "London", IntAtom 200, TextAtom "P2", TextAtom "S1", TextAtom "Smith", IntAtom 20],+                                              [TextAtom "London", IntAtom 200, TextAtom "P4", TextAtom "S1", TextAtom "Smith", IntAtom 20],+                                              [TextAtom "London", IntAtom 200, TextAtom "P2", TextAtom "S4", TextAtom "Clark", IntAtom 20]+                                              ]+                    +                    +{-+inclusionDependencies :: Connection -> M.Map IncDepName InclusionDependency+inclusionDependencies (InProcessConnection (DisconnectedTransaction _ context)) = inclusionDependencies context+inclusionDependencies _ = error "remote connection used"                       +-}+                           +-- test notifications over the InProcessConnection+testNotification :: Test+testNotification = TestCase $ do+  notifmvar <- newEmptyMVar+  let notifCallback mvar = \_ _ -> putMVar mvar ()+      relvarx = RelationVariable "x" ()+  (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)+  let check' x = x >>= maybe (pure ()) (\err -> assertFailure (show err))  +  check' $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue))+  check' $ executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx)  +  check' $ commit sess conn ForbidEmptyCommitOption+  check' $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse))+  check' $ commit sess conn ForbidEmptyCommitOption+  takeMVar notifmvar+    +testTypeConstructors :: Test+testTypeConstructors = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "data Hair = Color Text | Bald | UserRefusesToSpecify"+  executeTutorialD sessionId dbconn "x:=relation{a Hair}{tuple{a Color \"Blonde\"},tuple{a Bald},tuple{a UserRefusesToSpecify}}"+  executeTutorialD sessionId dbconn "data Tree a = Node a (Tree a) (Tree a) | EmptyNode"+  executeTutorialD sessionId dbconn "y:=relation{a Tree Int}{tuple{a Node 3 (Node 4 EmptyNode EmptyNode) EmptyNode},tuple{a Node 4 EmptyNode EmptyNode}}"+  +testMergeTransactions :: Test+testMergeTransactions = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  mapM_ (executeTutorialD sessionId dbconn) [+   ":branch branchA",+   "conflictrv := relation{conflict Int}{tuple{conflict 1}}",+   ":commit",+   ":jumphead master",+   ":branch branchB",+   "conflictrv := relation{conflict Int}{tuple{conflict 2}}",+   ":commit",+   ":mergetrans union branchA branchB"+   ]+  case mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) [[IntAtom 1],[IntAtom 2]] of+    Left err -> assertFailure (show err)+    Right conflictCheck -> do+      eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "conflictrv" ())+      case eRv of+        Left err -> assertFailure (show err)+        Right conflictrv -> assertEqual "conflict union merge relvar" conflictCheck conflictrv++testComments :: Test+testComments = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  mapM_ (executeTutorialD sessionId dbconn) [+    ":branch testbranch --test comment\n",+    ":jumphead {- test comment -} master"]+  +-- create a graph and query from two disparate contexts  +testTransGraphRelationalExpr :: Test    +testTransGraphRelationalExpr = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  mapM_ (executeTutorialD sessionId dbconn) [+    "x:=s", --dud relvar so that the commit isn't empty+    ":commit",+    ":branch testbranch",+    "insert s relation{tuple{city \"Boston\", s# \"S9\", sname \"Smithers\", status 50}}",+    ":commit"+    ]+  let masterMarker = TransactionIdHeadNameLookup "master" []+      testBranchMarker = TransactionIdHeadNameLookup "testbranch" []+      sattrs = attributesFromList [Attribute "city" TextAtomType,+                                   Attribute "sname" TextAtomType,+                                   Attribute "s#" TextAtomType,+                                   Attribute "status" IntAtomType]+      expectedRel = mkRelationFromList sattrs [[TextAtom "Boston",+                                                TextAtom "Smithers",+                                                TextAtom "S9",+                                                IntAtom 50]]+  diff <- executeTransGraphRelationalExpr sessionId dbconn (Difference (RelationVariable "s" testBranchMarker) (RelationVariable "s" masterMarker))+  assertEqual "difference in s" expectedRel diff +  +  --test graph traversal (head backtracking)+  let testBranchBacktrack = TransactionIdHeadNameLookup "testbranch" [TransactionIdHeadParentBacktrack 1]+  backtrackRel <- executeTransGraphRelationalExpr sessionId dbconn (Equals (RelationVariable "s" testBranchBacktrack) (RelationVariable "s" masterMarker))+  assertEqual "backtrack to master" (Right relationTrue) backtrackRel++  --test branch deletion+  mapM_ (executeTutorialD sessionId dbconn) [+        ":jumphead master",+        ":deletebranch testbranch"]+  eEvald <- case parseTutorialD ":jumphead testbranch" of+    Left _ -> assertFailure "jumphead parse error" >> error "x"+    Right parsed -> evalTutorialD sessionId dbconn UnsafeEvaluation parsed+  case eEvald of+    DisplayErrorResult err -> assertEqual "testbranch deletion"  (show (NoSuchHeadNameError "testbranch")) (unpack err)+    _ -> assertFailure "failed to delete branch"+                 +  +testMultiAttributeRename :: Test+testMultiAttributeRename = TestCase $ assertTutdEqual dateExamples renamedRel "x:=s rename {city as town, status as price} where false"+  where+    sattrs = attributesFromList [Attribute "town" TextAtomType,+                                 Attribute "sname" TextAtomType,+                                 Attribute "s#" TextAtomType,+                                 Attribute "price" IntAtomType]+    renamedRel = mkRelationFromList sattrs []++testSchemaExpr :: Test+testSchemaExpr = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  mapM_ (executeTutorialD sessionId dbconn) [+    ":addschema test (isopassthrough \"true\", isopassthrough \"false\", isorename \"supplier\" \"s\", isorename \"supplier_product\" \"sp\", isounion \"heavy_product\" \"light_product\" \"p\" ^gte(17,@weight))",+    ":setschema test",+    ""+    ]+  eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ())+  lightProduct <- assertEither eLightProduct+  let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntAtom 17), AttributeAtomExpr "weight"] ()))+  mErr <- setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName+  case mErr of+    Just err -> assertFailure (show err)+    Nothing -> do +      eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))+      restrictedProduct <- assertEither eRestrictedProduct+      assertEqual "light product" restrictedProduct lightProduct+  +assertEither :: (Show a) => Either a b -> IO b+assertEither x = case x of+  Left err -> assertFailure (show err) >> undefined+  Right val -> pure val+  +-- | Validate that a tuple passed through the context correctly typechecks and propagates to the AttributeAtomExpr.+testRelationalExprStateTupleElems :: Test+testRelationalExprStateTupleElems = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "x := (s : { parts := p rename {city as pcity} where pcity=@city}) : {z:=count(@parts)}"++  executeTutorialD sessionId dbconn "y:=x{city,z}"+  eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "y" ())+  let expectedRel = mkRelationFromList (attributesFromList [Attribute "city" TextAtomType,+                                                            Attribute "z" IntAtomType])+                    [[TextAtom "Paris", IntAtom 2],+                     [TextAtom "London", IntAtom 3],+                     [TextAtom "Athens", IntAtom 0]]+  assertEqual "validate parts count" expectedRel eRv+  +-- | Add a functional dependency on sname -> status and insert one tuple which is valid and another tuple which is invalid.+testFunctionalDependencies :: Test    +testFunctionalDependencies = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  executeTutorialD sessionId dbconn "funcdep sname_status (sname) -> (status) s"+  --insert a new, valid tuple+  executeTutorialD sessionId dbconn "insert s relation{tuple{city \"Boston\", s# \"S6\", sname \"Stevens\", status 30}}"+  --insert an constraint-violating tuple+  let expectedError = "InclusionDependencyCheckError \"sname_status_A\""+  expectTutorialDErr sessionId dbconn (T.isPrefixOf expectedError) "insert s relation{tuple{city \"Boston\", s# \"S7\", sname \"Jones\", status 20}}"++testEmptyCommits :: Test+testEmptyCommits = TestCase $ do +  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  err1 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption)+  assertEqual "no updates empty commit" (Just EmptyCommitError) err1+  --insert no tuples+  Nothing <- executeDatabaseContextExpr sessionId dbconn (Insert "s" (RelationVariable "s" ()))+  err2 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption)+  assertEqual "empty insert empty commit" (Just EmptyCommitError) err2+  --update no tuples+  Nothing <- executeDatabaseContextExpr sessionId dbconn (Update "s" (M.singleton "sname" (NakedAtomExpr (TextAtom "Bob"))) (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))+  err3 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption)+  assertEqual "empty update empty commit" (Just EmptyCommitError) err3+  --delete no tuples+  Nothing <- executeDatabaseContextExpr sessionId dbconn (Delete "s" (AttributeEqualityPredicate "sname" (NakedAtomExpr (TextAtom "Mike"))))+  err4 <- executeGraphExpr sessionId dbconn (Commit ForbidEmptyCommitOption)+  assertEqual "empty delete empty commit" (Just EmptyCommitError) err4+  +  --test allow empty commit option+  headId5 <- headTransactionId sessionId dbconn +  err5 <- executeGraphExpr sessionId dbconn (Commit AllowEmptyCommitOption)+  assertEqual "allow empty commit" Nothing err5+  headId5' <- headTransactionId sessionId dbconn +  assertBool "different heads" (headId5 /= headId5')+  +  --test ignore empty commit option+  headId6 <- headTransactionId sessionId dbconn   +  err6 <- executeGraphExpr sessionId dbconn (Commit IgnoreEmptyCommitOption)+  assertEqual "ignore empty commit" Nothing err6  +  headId6' <- headTransactionId sessionId dbconn     +  assertEqual "same heads" headId6 headId6'
+ test/TutorialD/Interpreter/AtomFunctionScript.hs view
@@ -0,0 +1,114 @@+import TutorialD.Interpreter.TestBase+import System.Exit+import Test.HUnit+import ProjectM36.Client+import ProjectM36.Relation+import ProjectM36.Error+import ProjectM36.DataTypes.Maybe+import qualified Data.Vector as V+import qualified Data.Map as M++main :: IO ()+main = do+  tcounts <- runTestTT (TestList [testBasicAtomFunction,+                                  testExceptionAtomFunction,+                                  testErrorAtomFunction,+                                  testNoArgumentAtomFunction,+                                  testArgumentTypeMismatch,+                                  testPolymorphicReturnType,+                                  testScriptedTypeVariable+                                  ])+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++--add an atom function and run it+testBasicAtomFunction :: Test+testBasicAtomFunction = TestCase $ do+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Either AtomFunctionError Int \"(\\\\(IntAtom x:xs) -> pure (IntAtom x)) :: [Atom] -> Either AtomFunctionError Atom\""+  let attrs = [Attribute "x" IntAtomType]+      funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntAtom 3)] ()+      tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]+      expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]+  result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)++  assertEqual "simple atom function equality" expectedResult result+  +--add an atom function which bombs out  +testExceptionAtomFunction :: Test+testExceptionAtomFunction = TestCase $ do+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Either AtomFunctionError Int \"\"\"(\\(IntAtom x:xs) -> (error (show 1))) :: [Atom] -> Either AtomFunctionError Atom\"\"\""+  let attrs = [Attribute "x" IntAtomType]+      funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntAtom 3)] ()+      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+                                                     _ -> False)+    +testErrorAtomFunction :: Test    +testErrorAtomFunction = TestCase $ do+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sess conn "addatomfunction \"errorAtom\" Int -> Either AtomFunctionError Int \"\"\"(\\(IntAtom x:xs) -> Left (AtomFunctionUserError \"user\")) :: [Atom] -> Either AtomFunctionError Atom\"\"\""+  +testNoArgumentAtomFunction :: Test+testNoArgumentAtomFunction = TestCase $ do+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sess conn "addatomfunction \"mkTest\" Either AtomFunctionError Int \"\"\"(\\x -> pure (IntAtom 5)) :: [Atom] -> Either AtomFunctionError Atom\"\"\""+  let attrs = [Attribute "x" IntAtomType]+      funcAtomExpr = FunctionAtomExpr  "mkTest" [] ()+      tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]+      expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 5]]+  result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)+  assertEqual "no argument scripted function" expectedResult result+  +testArgumentTypeMismatch :: Test+testArgumentTypeMismatch = TestCase $ do+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sess conn "addatomfunction \"mkTest\" Int -> Either AtomFunctionError Int \"\"\"(\\(IntAtom x:_) -> pure $ TextAtom \"wrong type\") :: [Atom] -> Either AtomFunctionError Atom\"\"\""+  let tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]+      funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntAtom 3)] ()+      attrs = [Attribute "x" IntAtomType]+      expectedResult = Left (AtomTypeMismatchError IntAtomType TextAtomType)+  result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)+  assertEqual "type mismatch not detected" expectedResult result+  +testPolymorphicReturnType :: Test  +testPolymorphicReturnType = TestCase $ do+  --test that polymorphic function return type resolves to concrete type using fromMaybe builtin atom function+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback  +  let funcAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntAtom 5),+                                                   NakedAtomExpr maybeAtom] ()+      maybeAtom = ConstructedAtom "Just" (maybeAtomType IntAtomType) [IntAtom 3]+      relExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" funcAtomExpr)]+  mRelType <- typeForRelationalExpr sess conn relExpr+  case mRelType of+    Left err -> assertFailure (show err)+    Right relType -> do+      let expectedRetAttrs = V.fromList [Attribute "x" IntAtomType]+      assertEqual "fromMaybe type" expectedRetAttrs (attributes relType)+      mRes <- executeRelationalExpr sess conn relExpr+      let expectedRel = mkRelationFromList (V.fromList [Attribute "x" IntAtomType]) [[IntAtom 3]]+      assertEqual "fromMaybe result" expectedRel mRes+  --test that type mismatch occurs for different types appearing in same type variable+  let failFuncAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntAtom 5),+                                                       NakedAtomExpr mismatchAtom] ()+      mismatchAtom = ConstructedAtom "Just" (maybeAtomType TextAtomType) [TextAtom "fail"]+      failRelExpr = MakeRelationFromExprs Nothing [TupleExpr (M.singleton "x" failFuncAtomExpr)]+  mFailRes <- executeRelationalExpr sess conn failRelExpr+  let expectedErr = Left (AtomFunctionTypeVariableMismatch "a" IntAtomType TextAtomType)+  assertEqual "expected type variable mismatch" expectedErr mFailRes+                                                       +--test that a user can create a function with a type variable argument+testScriptedTypeVariable :: Test+testScriptedTypeVariable = TestCase $ do+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sess conn "addatomfunction \"idTest\" a -> Either AtomFunctionError a \"(\\\\(x:_) -> pure x) :: [Atom] -> Either AtomFunctionError Atom\""+  let attrs = [Attribute "x" IntAtomType]+      funcAtomExpr = FunctionAtomExpr  "idTest" [NakedAtomExpr (IntAtom 3)] ()+      tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]+      expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]+  result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)++  assertEqual "id function equality" expectedResult result+
+ test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs view
@@ -0,0 +1,66 @@+import TutorialD.Interpreter.TestBase+import System.Exit+import Test.HUnit+import ProjectM36.Client+import ProjectM36.Relation+import qualified Data.Text as T++main :: IO ()+main = do+  tcounts <- runTestTT (TestList [testBasicDBCFunction,+                                  testErrorDBCFunction,             +                                  testExceptionDBCFunction,+                                  testDBCFunctionWithAtomArguments+                                  ])+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++{-+adddatabasecontextfunction "addtruerv" DatabaseContext -> DatabaseContext """(\[] ctx -> execState (evalDatabaseContextExpr (Assign "true2" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""+-}+testBasicDBCFunction :: Test+testBasicDBCFunction = TestCase $ do  +  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  let addfunc = "adddatabasecontextfunction \"addTrue2\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext  \"\"\"(\\[] ctx -> pure $ execState (evalDatabaseContextExpr (Assign \"true2\" (ExistingRelation relationTrue))) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""+  executeTutorialD sess conn addfunc+  executeTutorialD sess conn "execute addTrue2()"+  let true2Expr = RelationVariable "true2" ()+  result <- executeRelationalExpr sess conn true2Expr+  assertEqual "simple atom function equality" (Right relationTrue) result++testErrorDBCFunction :: Test+testErrorDBCFunction = TestCase $ do+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback  +  let addfunc = "adddatabasecontextfunction \"retErr\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] ctx -> Left (DatabaseContextFunctionUserError \"err\")) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""+  executeTutorialD sess conn addfunc+  expectTutorialDErr sess conn (T.isPrefixOf "DatabaseContextFunctionUserError (DatabaseContextFunctionUserError \"err\")") "execute retErr()"+  +testExceptionDBCFunction :: Test+testExceptionDBCFunction = TestCase $ do+  -- throw an error, make sure it is caught- it might not be caught, for example, if the function is not forced+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  let addfunc = "adddatabasecontextfunction \"bomb\" DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\[] _ -> error \"boom\") :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""+  executeTutorialD sess conn addfunc+  expectTutorialDErr sess conn (\err -> "UnhandledExceptionError" `T.isPrefixOf` err) "execute bomb()"+  ++{-+adddatabasecontextfunction "multiArgFunc" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> execState (evalDatabaseContextExpr (Assign "person" (MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", NakedAtomExpr name), ("age", NakedAtomExpr age)])]))) ctx)"""+-}+testDBCFunctionWithAtomArguments :: Test+testDBCFunctionWithAtomArguments = TestCase $ do+  --test function with creation of a relvar with some arguments+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  let addfunc = "adddatabasecontextfunction \"multiArgFunc\" Int -> Text -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\(age:name:_) ctx -> pure $ execState (evalDatabaseContextExpr (Assign \"person\" (MakeRelationFromExprs Nothing [TupleExpr (fromList [(\"name\", NakedAtomExpr name), (\"age\", NakedAtomExpr age)])]))) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""+  executeTutorialD sess conn addfunc+  executeTutorialD sess conn "execute multiArgFunc(30,\"Steve\")"+  result <- executeRelationalExpr sess conn (RelationVariable "person" ())+  let expectedPerson = mkRelationFromList (attributesFromList [Attribute "name" TextAtomType,+                                                               Attribute "age" IntAtomType]) [+        [TextAtom "Steve", IntAtom 30]]+  assertEqual "person relation" expectedPerson result+  expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"++{-+adddatabasecontextfunction "addperson" Int -> Text -> DatabaseContext -> DatabaseContext """(\(age:name:_) ctx -> let newrel = MakeRelationFromExprs Nothing [TupleExpr (fromList [("name", name),("age",age))]] in if isRight (runState (executeRelationalExpr (RelationVariable "person" ()) ctx)) then execState (executeContextExpr (Insert "person" newrel)) ctx else execState (executeContextExpr (Assign "person" newrel)) ctx) :: [Atom] -> DatabaseContext -> DatabaseContext"""+-}+
+ test/TutorialD/Interpreter/Import/TutorialD.hs view
@@ -0,0 +1,21 @@+import Test.HUnit+import ProjectM36.Base+import TutorialD.Interpreter.Import.TutorialD+import System.Exit+import System.IO.Temp+import qualified Data.Map as M+import System.IO++main :: IO ()+main = do +  tcounts <- runTestTT $ TestList [testTutdImport]+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess++testTutdImport :: Test+testTutdImport = TestCase $ do+  withSystemTempFile "m.tutd" $ \tempPath handle -> do+    hPutStrLn handle "x:=relation{tuple{a 5,b \"spam\"}}"+    hClose handle+    let expectedExpr = MultipleExpr [Assign "x" (MakeRelationFromExprs Nothing [TupleExpr (M.fromList [("a",NakedAtomExpr $ IntAtom 5),("b",NakedAtomExpr $ TextAtom "spam")])])]+    imported <- importTutorialD tempPath+    assertEqual "import tutd" (Right expectedExpr) imported
+ test/TutorialD/Interpreter/TestBase.hs view
@@ -0,0 +1,58 @@+module TutorialD.Interpreter.TestBase where+import ProjectM36.Client+import TutorialD.Interpreter+import TutorialD.Interpreter.Base+import qualified ProjectM36.Base as Base+import ProjectM36.DateExamples+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+      eSessionId <- createSessionAtHead "master" conn+      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)+      --skipping atom functions for now- there are no atom function manipulation operators yet+          commit sessionId conn ForbidEmptyCommitOption >>= maybeFail+          pure (sessionId, conn)++executeTutorialD :: SessionId -> Connection -> Text -> IO ()+executeTutorialD sessionId conn tutd = case parseTutorialD tutd of+    Left err -> assertFailure (show tutd ++ ": " ++ show err)+    Right parsed -> do +      result <- evalTutorialD sessionId conn UnsafeEvaluation parsed+      case result of+        QuitResult -> assertFailure "quit?"+        DisplayResult _ -> assertFailure "display?"+        DisplayIOResult _ -> assertFailure "displayIO?"+        DisplayRelationResult _ -> assertFailure "displayrelation?"+        DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"+        DisplayErrorResult err -> assertFailure (show err)        +        QuietSuccessResult -> pure ()+        +expectTutorialDErr :: SessionId -> Connection -> (Text -> Bool) -> Text -> IO ()        +expectTutorialDErr sessionId conn matchFunc tutd = case parseTutorialD tutd of+    Left err -> assertFailure (show tutd ++ ": " ++ show err)  +    Right parsed -> do+      result <- evalTutorialD sessionId conn UnsafeEvaluation parsed      +      case result of+        QuitResult -> assertFailure "quit?"+        DisplayResult _ -> assertFailure "display?"+        DisplayIOResult _ -> assertFailure "displayIO?"+        DisplayRelationResult _ -> assertFailure "displayrelation?"+        DisplayParseErrorResult _ _ -> assertFailure "displayparseerrorresult?"+        DisplayErrorResult err -> assertBool ("match error on: " ++ unpack err) (matchFunc err)+        QuietSuccessResult -> pure ()+        +maybeFail :: (Show a) => Maybe a -> IO ()+maybeFail (Just err) = assertFailure (show err)+maybeFail Nothing = return ()
+ test/scripts.hs view
@@ -0,0 +1,26 @@+-- read each .tutd file in the /scripts directory and execute it with the tutd interpreter+import Test.HUnit+import TutorialD.Interpreter.Import.TutorialD+import System.Directory+import Data.List (isSuffixOf)+import System.Exit++testList :: IO Test+testList = do+  let scriptsDir = "scripts/"+  dirFiles <- getDirectoryContents scriptsDir+  let scriptList = map (scriptsDir ++) $ filter (".tutd" `isSuffixOf`) dirFiles +  pure (TestList $ map testScript scriptList)++main :: IO ()+main = do+  tests <- testList+  tcounts <- runTestTT tests+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess+  +testScript :: FilePath -> Test+testScript tutdFile = TestCase $ do+  eImport <- importTutorialD tutdFile +  case eImport of+    Left err -> assertFailure ("tutd import failure in " ++ tutdFile ++ ": " ++ show err)+    Right _ -> pure ()