project-m36 0.2 → 0.3

raw patch · 62 files changed

+1229/−510 lines, 62 filesdep +blaze-htmldep +http-typesdep +scottydep ~basedep ~cassavadep ~ghcnew-component:exe:handles

Dependencies added: blaze-html, http-types, scotty, zlib

Dependency ranges changed: base, cassava, ghc, stm-containers, uuid

Files

• Changelog.markdown +21/−0
• README.markdown +2/−0
• examples/blog.hs +130/−15
• examples/hair.hs +2/−1
• examples/out_of_the_tarpit.hs +12/−11
• project-m36.cabal +31/−2
• src/bin/ProjectM36/Server/RemoteCallTypes/Json.hs +3/−0
• src/bin/TutorialD/Interpreter.hs +79/−24
• src/bin/TutorialD/Interpreter/DatabaseContextExpr.hs +3/−2
• src/bin/TutorialD/Interpreter/Import/Base.hs +3/−3
• src/bin/TutorialD/Interpreter/Import/CSV.hs +4/−4
• src/bin/TutorialD/Interpreter/RelationalExpr.hs +3/−5
• src/bin/TutorialD/Interpreter/SchemaOperator.hs +0/−1
• src/bin/TutorialD/Interpreter/TransactionGraphOperator.hs +0/−1
• src/bin/TutorialD/tutd.hs +26/−10
• src/bin/benchmark/Handles.hs +108/−0
• src/bin/benchmark/bigrel.hs +3/−3
• src/lib/ProjectM36/Atom.hs +10/−12
• src/lib/ProjectM36/AtomFunctionError.hs +5/−4
• src/lib/ProjectM36/AtomFunctions/Primitive.hs +35/−28
• src/lib/ProjectM36/AtomType.hs +37/−20
• src/lib/ProjectM36/Atomable.hs +45/−13
• src/lib/ProjectM36/Base.hs +8/−4
• src/lib/ProjectM36/Client.hs +26/−7
• src/lib/ProjectM36/Client/Simple.hs +52/−36
• src/lib/ProjectM36/DataConstructorDef.hs +1/−0
• src/lib/ProjectM36/DataTypes/DateTime.hs +2/−2
• src/lib/ProjectM36/DataTypes/Day.hs +1/−1
• src/lib/ProjectM36/DataTypes/Interval.hs +7/−4
• src/lib/ProjectM36/DataTypes/List.hs +6/−1
• src/lib/ProjectM36/DataTypes/Primitive.hs +3/−1
• src/lib/ProjectM36/DateExamples.hs +26/−26
• src/lib/ProjectM36/Error.hs +2/−1
• src/lib/ProjectM36/FileLock.hs +30/−14
• src/lib/ProjectM36/Notifications.hs +2/−2
• src/lib/ProjectM36/Relation.hs +4/−0
• src/lib/ProjectM36/Relation/Parse/CSV.hs +123/−20
• src/lib/ProjectM36/Relation/Show/CSV.hs +0/−2
• src/lib/ProjectM36/Relation/Show/Gnuplot.hs +2/−2
• src/lib/ProjectM36/RelationalExpression.hs +15/−14
• src/lib/ProjectM36/Server.hs +1/−0
• src/lib/ProjectM36/Server/EntryPoints.hs +5/−2
• src/lib/ProjectM36/Server/RemoteCallTypes.hs +2/−0
• src/lib/ProjectM36/StaticOptimizer.hs +3/−6
• src/lib/ProjectM36/TransGraphRelationalExpression.hs +1/−1
• src/lib/ProjectM36/Transaction/Persist.hs +49/−27
• src/lib/ProjectM36/TransactionGraph.hs +1/−1
• src/lib/ProjectM36/TransactionGraph/Persist.hs +9/−15
• src/lib/ProjectM36/Tupleable.hs +24/−14
• test/Client/Simple.hs +0/−1
• test/MultiProcessDatabaseAccess.hs +0/−1
• test/Relation/Atomable.hs +30/−13
• test/Relation/Export/CSV.hs +75/−13
• test/Relation/Import/CSV.hs +3/−1
• test/Relation/Tupleable.hs +13/−12
• test/Server/Main.hs +1/−1
• test/TransactionGraph/Automerge.hs +0/−1
• test/TutorialD/Interpreter.hs +112/−75
• test/TutorialD/Interpreter/AtomFunctionScript.hs +24/−25
• test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs +3/−3
• test/TutorialD/Interpreter/Import/TutorialD.hs +1/−1
• test/TutorialD/Interpreter/TestBase.hs +0/−1

@@ -1,3 +1,24 @@+# 2017-10-08 (v0.3)++* replaced overuse of `undefined` with `Proxy` in `Tupleable` and `Atomable` typeclasses+* allow notifications to return query results from before *and* after the commit which triggered the notification+* alert users in `tutd` console before a transaction graph expression is evaluated which would throw out their changes+* drastically-improved CSV import/export now supports all possible types except `RelationAtom`+* fix serious file handle leaks when using on-disk persistence+* fix case where invalid number of arguments to `ConstructedAtom` did not result in an error+* add support for `IntegerAtom` (previously, only `IntAtom` was supported)++# 2017-09-16 (v0.2)++* a new [simple client API](https://github.com/agentm/project-m36/blob/master/docs/simple_api.markdown) with a monadic transaction manager+* complete hlint compliance+* the generics-based [Tupleable typeclass](	https://github.com/agentm/project-m36/blob/master/docs/tupleable.markdown+) which makes it easy to marshal Haskell data types to-and-from the database+* timestamps attached to transactions to allow specific point-in-time travel+* autoMergeToHead, a variant of commit which attempts to merge and commit to the latest head transaction to reduce incidents of TransactionNotAHeadErrors+* interval data types+* transaction dirtiness detection which allows the client to determine if an update expression actually changed the database state+ # 2017-08-01  ## autoMergeToHead

@@ -42,6 +42,7 @@ * [Mailing List/Discussion Group](https://groups.google.com/d/forum/project-m36) * IRC Channel: chat.freenode.net #project-m36 * [Hackage](https://hackage.haskell.org/package/project-m36)+* [Diogo Biazus' Project:M36 Video Tutorial](https://www.youtube.com/watch?v=_GC_lxlVEnE)  ## Documentation @@ -52,6 +53,7 @@ 1. [TutorialD Tutorial](docs/tutd_tutorial.markdown) 1. [15 Minute Tutorial](docs/15_minute_tutorial.markdown) 1. [Developer's Change Log](Changelog.markdown)+1. [Simple Client API](docs/simple_api.markdown)  ### Database Comparisons 

@@ -2,20 +2,37 @@ {-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-}  import ProjectM36.Client+import ProjectM36.Base import ProjectM36.Relation import ProjectM36.Tupleable+import ProjectM36.Atom (relationForAtom)+import ProjectM36.Tuple (atomForAttributeName)  import Data.Either import GHC.Generics import Data.Binary import qualified Data.Text as T+import qualified Data.Text.Lazy as TL import Data.Time.Clock import Data.Time.Calendar import Control.DeepSeq+import Data.Proxy+import Data.Monoid+import Data.List+import Control.Monad (when, forM_) +import Web.Scotty as S+import Text.Blaze.Html5 (h1, h2, h3, p, form, input, (!), toHtml, Html, a, toValue, hr, textarea)+import Text.Blaze.Html5.Attributes (name, href, type_, method, action, value)+import Text.Blaze.Html.Renderer.Text+import Control.Monad.IO.Class (liftIO)+import Network.HTTP.Types.Status+import Data.Time.Format+ --define your data types data Blog = Blog {   title :: T.Text,+  entry :: T.Text,   stamp :: UTCTime,   category :: Category --note that this type is an algebraic data type   }@@ -63,41 +80,139 @@    createSchema sessionId conn     insertSampleData sessionId conn-  executeSampleQueries sessionId conn+  --create the web routes+  scotty 3000 $ do+    S.get "/" (listBlogs sessionId conn)+    S.get "/blog/:blogid" (showBlogEntry sessionId conn)+    S.post "/comment" (addComment sessionId conn)    --define the schema with the new Category atom (data) type, blog relvar, a comment relvar, and a foreign key relationship between them createSchema :: SessionId -> Connection -> IO ()   createSchema sessionId conn = do   _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) [-    toAddTypeExpr (undefined :: Category),-    toDefineExpr (undefined :: Blog) "blog",-    toDefineExpr (undefined :: Comment) "comment",-    databaseContextExprForForeignKey "blog_comment" ("comment", ["blogTitle"]) ("blog", ["title"]) ]+    toAddTypeExpr (Proxy :: Proxy Category),+    toDefineExpr (Proxy :: Proxy Blog) "blog",+    toDefineExpr (Proxy :: Proxy Comment) "comment",+    databaseContextExprForForeignKey "blog_comment" ("comment", ["blogTitle"]) ("blog", ["title"]),+    databaseContextExprForUniqueKey "blog" ["title"]+    ]   pure ()  --create some sample values and insert them into the database's relation variables insertSampleData :: SessionId -> Connection -> IO () insertSampleData sessionId conn = do-  let blogs = [Blog { title = "Eat More Tofu",+  let blogs = [Blog { title = "Haskell Lenses",+                      entry = "I wear Haskell rose-colored lenses.",                       stamp = UTCTime (fromGregorian 2017 5 8) (secondsToDiffTime 1000),                       category = Food },-               Blog { title = "Cat Falls Off Table",+               Blog { title = "Haskell Monad Analogy",+                      entry = "Monads are like burritos going through intestines.",                       stamp = UTCTime (fromGregorian 2017 6 10) (secondsToDiffTime 2000),                       category = Cats }                ]-      comments = [Comment { blogTitle = "Cat Falls Off Table",+      comments = [Comment { blogTitle = "Haskell Lenses",                             commentTime = UTCTime (fromGregorian 2017 7 8) (secondsToDiffTime 3000),-                            contents = "more cats please" }]+                            contents = "You suck!" },+                  Comment {blogTitle = "Haskell Lenses",+                           commentTime = UTCTime (fromGregorian 2017 7 9) (secondsToDiffTime 2000),+                           contents = "I find your ideas intriguing and would like to subscribe to your newsletter."}+                 ]   insertBlogsExpr <- handleError $ toInsertExpr blogs "blog"                  handleIOError $ executeDatabaseContextExpr sessionId conn insertBlogsExpr      insertCommentsExpr <- handleError $ toInsertExpr comments "comment"   handleIOError $ executeDatabaseContextExpr sessionId conn insertCommentsExpr   ---issue a query and marshal the data back to the original data value  -executeSampleQueries :: SessionId -> Connection -> IO ()  -executeSampleQueries sessionId conn = do-  commentsRelation <- handleIOError $ executeRelationalExpr sessionId conn (RelationVariable "comment" ())+-- handle relational errors with scotty+handleWebError :: Either RelationalError a -> ActionM a +handleWebError (Left err) = render500 (toHtml (show err)) >> pure (error "bad")+handleWebError (Right v) = pure v++-- show a page with all the blog entries+listBlogs :: SessionId -> Connection -> ActionM ()+listBlogs sessionId conn = do+  eRel <- liftIO $ executeRelationalExpr sessionId conn (RelationVariable "blog" ())+  case eRel of+    Left err -> render500 (toHtml (show err))+    Right blogRel -> do+      blogs <- liftIO (toList blogRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Blog]+      let sortedBlogs = sortBy (\b1 b2 -> stamp b1 `compare` stamp b2) blogs+      html . renderHtml $ do+        h1 "Blog Posts"+        forM_ sortedBlogs $ \blog -> a ! href (toValue $ "/blog/" <> title blog) $ h2 (toHtml (title blog))++render500 :: Html -> ActionM ()+render500 msg = do +  html . renderHtml $ do+    h1 "Internal Server Error"  +    p msg+  status internalServerError500   -  comments <- toList commentsRelation >>= mapM (handleError . fromTuple) :: IO [Comment]-  print comments+--display one blog post along with its comments+showBlogEntry :: SessionId -> Connection -> ActionM ()+showBlogEntry sessionId conn = do+  blogid <- param "blogid"+  --query the database to return the blog entry with a relation-valued attribute of the associated comments+  let blogRestrictionExpr = AttributeEqualityPredicate "title" (NakedAtomExpr (TextAtom blogid))+      extendExpr = AttributeExtendTupleExpr "comments" (RelationAtomExpr commentsRestriction)+      commentsRestriction = Restrict+                           (AttributeEqualityPredicate "blogTitle" (AttributeAtomExpr "title"))+                           (RelationVariable "comment" ())+  eRel <- liftIO $ executeRelationalExpr sessionId conn (Extend extendExpr +                                                         (Restrict +                                                          blogRestrictionExpr +                                                          (RelationVariable "blog" ())))+  let render = html . renderHtml+      formatStamp = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))+  case eRel of +    Left err -> render500 (toHtml (show err))+    --handle successful query execution+    Right rel -> case singletonTuple rel of+      Nothing -> do --no results for this blog id+        render (h1 "No such blog post")+        status status404+      Just blogTuple -> case fromTuple blogTuple of --just one blog post found- it's a match!+        Left err -> render500 (toHtml (show err))+        Right blog -> do+          --extract comments for the blog+          commentsAtom <- handleWebError (atomForAttributeName "comments" blogTuple)+          commentsRel <- handleWebError (relationForAtom commentsAtom)+          comments <- liftIO (toList commentsRel) >>= mapM (handleWebError . fromTuple) :: ActionM [Comment]+          let commentsSorted = sortBy (\c1 c2 -> commentTime c1 `compare` commentTime c2) comments+          render $ do+            --show blog details+            h1 (toHtml (title blog))+            p (toHtml ("Posted at " <> formatStamp (stamp blog) <> " under " <> show (category blog)))+            p (toHtml (entry blog))+            hr+            h3 "Comments"+            --list the comments+            forM_ commentsSorted $ \comment -> do+              p (toHtml ("Commented at " <> formatStamp (commentTime comment)))+              p (toHtml (contents comment))+            when (null comments) (p "No comments.")+            --add a comment form+            h3 "Add a Comment"+            form ! method "POST" ! action "/comment" $ do+              input ! type_ "hidden" ! name "blogid" ! value (toValue blogid)+              textarea ! name "contents" $ ""+              input ! type_ "submit"+            +--add a comment to a blog post+addComment :: SessionId -> Connection -> ActionM ()            +addComment sessionId conn = do+  blogid <- param "blogid"+  commentText <- param "contents"+  now <- liftIO getCurrentTime+  +  case toInsertExpr [Comment {blogTitle = blogid,+                              commentTime = now,+                              contents = commentText }] "comment" of+    Left err -> handleWebError (Left err)+    Right insertExpr -> do      +      eRet <- liftIO (withTransaction sessionId conn (executeDatabaseContextExpr sessionId conn insertExpr) (commit sessionId conn))+      case eRet of+        Left err -> handleWebError (Left err)+        Right _ ->+          redirect (TL.fromStrict ("/blog/" <> blogid))+      

@@ -7,6 +7,7 @@ import Control.DeepSeq import qualified Data.Map as M import qualified Data.Text.IO as TIO+import Data.Proxy  data Hair = Bald | Brown | Blond | OtherColor Text    deriving (Generic, Show, Eq, Binary, NFData, Atomable)@@ -26,7 +27,7 @@   sessionId <- eCheck $ createSessionAtHead conn "master"      --create the data type in the database context-  eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (undefined :: Hair))+  eCheck $ executeDatabaseContextExpr sessionId conn (toAddTypeExpr (Proxy :: Proxy Hair))    --create a relation with the new Hair AtomType   let blond = NakedAtomExpr (toAtom Blond)

@@ -11,6 +11,7 @@ import Control.DeepSeq import qualified Data.Text as T import Data.Time.Calendar+import Data.Proxy  --create various database value (atom) types type Price = Double@@ -97,7 +98,7 @@ data Floor = Floor {   floorAddress :: Address,   floorRoomName :: Name,-  floorNum :: Int+  floorNum :: Integer   }   deriving (Generic, Eq)            @@ -142,17 +143,17 @@                     ]       incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys       --define the relvars-      rvExprs = [toDefineExpr (undefined :: Property) "property",-                 toDefineExpr (undefined :: Offer) "offer",-                 toDefineExpr (undefined :: Decision) "decision",-                 toDefineExpr (undefined :: Room) "room",-                 toDefineExpr (undefined :: Floor) "floor",-                 toDefineExpr (undefined :: Commission) "commission"]+      rvExprs = [toDefineExpr (Proxy :: Proxy Property) "property",+                 toDefineExpr (Proxy :: Proxy Offer) "offer",+                 toDefineExpr (Proxy :: Proxy Decision) "decision",+                 toDefineExpr (Proxy :: Proxy Room) "room",+                 toDefineExpr (Proxy :: Proxy Floor) "floor",+                 toDefineExpr (Proxy :: Proxy Commission) "commission"]       --create the new algebraic data types-      new_adts = [toAddTypeExpr (undefined :: RoomType),-                  toAddTypeExpr (undefined :: PriceBand),-                  toAddTypeExpr (undefined :: AreaCode),-                  toAddTypeExpr (undefined :: SpeedBand)]+      new_adts = [toAddTypeExpr (Proxy :: Proxy RoomType),+                  toAddTypeExpr (Proxy :: Proxy PriceBand),+                  toAddTypeExpr (Proxy :: Proxy AreaCode),+                  toAddTypeExpr (Proxy :: Proxy 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"

@@ -1,5 +1,5 @@ Name: project-m36-Version: 0.2+Version: 0.3 License: PublicDomain Build-Type: Simple Homepage: https://github.com/agentm/project-m36@@ -48,6 +48,7 @@                    ,gnuplot                    ,binary                    ,filepath+                   ,zlib                    ,directory                    ,vector-binary-instances                    ,temporary@@ -55,6 +56,7 @@                    ,time                    ,hashable-time                    ,old-locale+                   --used for CSV parsing                    ,attoparsec                    ,either                    ,base64-bytestring@@ -408,7 +410,7 @@ Executable Example-Blog     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, 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+    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, scotty, blaze-html, http-types     Main-Is: examples/blog.hs     GHC-Options: -Wall @@ -504,3 +506,30 @@     GHC-Options: -Wall     Hs-Source-Dirs: ./src/bin, ., test/ +-- test for file handle leaks+Executable handles+    Default-Language: Haskell2010+    Default-Extensions: OverloadedStrings+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, vector-binary-instances, time, hashable-time, bytestring, uuid, stm, deepseq, deepseq-generics, 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, random, MonadRandom, semigroups+    main-is: benchmark/Handles.hs+    Other-Modules: TutorialD.Interpreter,+      TutorialD.Interpreter.Base,+      TutorialD.Interpreter.DatabaseContextExpr,+      TutorialD.Interpreter.DatabaseContextIOOperator,+      TutorialD.Interpreter.Export.Base,+      TutorialD.Interpreter.Export.CSV,+      TutorialD.Interpreter.Import.Base,+      TutorialD.Interpreter.Import.BasicExamples,+      TutorialD.Interpreter.Import.CSV,+      TutorialD.Interpreter.Import.TutorialD,+      TutorialD.Interpreter.InformationOperator,+      TutorialD.Interpreter.RODatabaseContextOperator,+      TutorialD.Interpreter.RelationalExpr,+      TutorialD.Interpreter.SchemaOperator,+      TutorialD.Interpreter.TransGraphRelationalOperator,+      TutorialD.Interpreter.TransactionGraphOperator,+      TutorialD.Interpreter.Types+    GHC-Options: -Wall -threaded -rtsopts+    HS-Source-Dirs: ./src/bin+    if flag(profiler)+      GHC-Prof-Options: -fprof-auto -rtsopts -threaded -Wall

@@ -64,6 +64,8 @@ instance FromJSON SchemaIsomorph  instance ToJSON Atom where+  toJSON atom@(IntegerAtom i) = object [ "type" .= atomTypeForAtom atom,+                                     "val" .= i ]     toJSON atom@(IntAtom i) = object [ "type" .= atomTypeForAtom atom,                                      "val" .= i ]   toJSON atom@(DoubleAtom i) = object [ "type" .= atomTypeForAtom atom,@@ -105,6 +107,7 @@         rel <- o .: "val"         pure $ RelationAtom rel       IntAtomType -> IntAtom <$> o .: "val"+      IntegerAtomType -> IntegerAtom <$> o .: "val"       DoubleAtomType -> DoubleAtom <$> o .: "val"       TextAtomType -> TextAtom <$> o .: "val"       DayAtomType -> do

@@ -31,7 +31,9 @@ import qualified Data.Text as T import System.IO (hPutStrLn, stderr) import Data.Monoid+import Data.List (isPrefixOf) import Control.Exception+import System.Exit  {- context ops are read-only operations which only operate on the database context (relvars and constraints)@@ -86,13 +88,24 @@  data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq) ---execute the operation and display result+type InteractiveConsole = Bool+ evalTutorialD :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> ParsedOperation -> IO TutorialDOperatorResult-evalTutorialD sessionId conn safe expr = case expr of+evalTutorialD sessionId conn safe = evalTutorialDInteractive sessionId conn safe False++--execute the operation and display result+evalTutorialDInteractive :: C.SessionId -> C.Connection -> SafeEvaluationFlag -> InteractiveConsole -> ParsedOperation -> IO TutorialDOperatorResult+evalTutorialDInteractive sessionId conn safe interactive 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) -> -    evalRODatabaseContextOp sessionId conn execOp+  (RODatabaseContextOp execOp) -> do+    res <- evalRODatabaseContextOp sessionId conn execOp+    case res of+      QuitResult -> if safe == UnsafeEvaluation && interactive then+                      putStrLn "Goodbye." >> exitSuccess+                    else+                      pure res+      _ -> pure res        (DatabaseContextExprOp execOp) ->      eHandler $ C.executeDatabaseContextExpr sessionId conn execOp @@ -103,8 +116,33 @@       else       eHandler $ C.executeDatabaseContextIOExpr sessionId conn execOp     -  (GraphOp execOp) -> -    eHandler $ C.executeGraphExpr sessionId conn execOp+  (GraphOp execOp) -> do+    -- warn if the graph op could cause uncommited changes to be discarded+    eIsDirty <- C.disconnectedTransactionIsDirty sessionId conn+    let runGraphOp = eHandler $ C.executeGraphExpr sessionId conn execOp    +        settings = Settings {complete = noCompletion,+                             historyFile = Nothing,+                             autoAddHistory = False}+    case eIsDirty of+      Left err -> barf err+      Right False -> runGraphOp+      Right True -> do+        cancel <- runInputT settings $ do+          let promptDiscardChanges = do+                isatty <- haveTerminalUI+                if isatty && interactive && execOp /= Commit && execOp /= Rollback then do+                  mYesOrNo <- getInputLine "The current transaction has uncommitted changes. If you continue, the changes will be lost. Continue? (Y/n): "+                  case mYesOrNo of+                    Nothing -> promptDiscardChanges+                    Just "" -> promptDiscardChanges+                    Just yesOrNo -> pure (not ("Y" `isPrefixOf` yesOrNo))+                  else+                  pure False+          promptDiscardChanges+        if cancel then+          pure (DisplayErrorResult "Graph operation cancelled.")+          else+          runGraphOp        (ConvenienceGraphOp execOp) ->     eHandler $ evalConvenienceGraphOp sessionId conn execOp@@ -128,10 +166,14 @@       case eImportType of         Left err -> barf err         Right importType -> do-          exprErr <- evalRelVarDataImportOperator execOp (attributes importType)-          case exprErr of+          eTConsMap <- C.typeConstructorMapping sessionId conn+          case eTConsMap of             Left err -> barf err-            Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)+            Right tConsMap -> do+              exprErr <- evalRelVarDataImportOperator execOp tConsMap (attributes importType)+              case exprErr of+                Left err -> barf err+                Right dbexpr -> evalTutorialD sessionId conn safe (DatabaseContextExprOp dbexpr)      (ImportDBContextOp execOp) ->      if needsSafe then@@ -181,16 +223,19 @@         Right () -> return QuietSuccessResult        type GhcPkgPath = String  -data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |-                         RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName+type TutorialDExec = String+  +data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName (Maybe TutorialDExec) [GhcPkgPath] |+                         RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName (Maybe TutorialDExec)  outputNotificationCallback :: C.NotificationCallback-outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ show (reportExpr (C.notification evaldNot)) ++ "\n" ++ prettyEvaluatedNotification evaldNot+outputNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification received " ++ show notName ++ ":\n" ++ "\n" ++ prettyEvaluatedNotification evaldNot  prettyEvaluatedNotification :: C.EvaluatedNotification -> String-prettyEvaluatedNotification eNotif = case C.reportRelation eNotif of-  Left err -> show err-  Right reportRel -> T.unpack (showRelation reportRel)+prettyEvaluatedNotification eNotif = let eRelShow eRel = case eRel of+                                           Left err -> show err+                                           Right reportRel -> T.unpack (showRelation reportRel) in+  eRelShow (C.reportOldRelation eNotif) <> "\n" <> eRelShow (C.reportNewRelation eNotif)  reprLoop :: InterpreterConfig -> C.SessionId -> C.Connection -> IO () reprLoop config sessionId conn = do@@ -199,16 +244,26 @@   eHeadName <- C.headName sessionId conn   eSchemaName <- C.currentSchemaName sessionId conn   let prompt = promptText eHeadName eSchemaName-  maybeLine <- runInputT settings $ getInputLine (T.unpack prompt)+      catchInterrupt = handleJust (\exc -> case exc of+                                      UserInterrupt -> Just Nothing+                                      _ -> Nothing) (\_ -> do+                                                        hPutStrLn stderr "Statement cancelled. Use \":quit\" to exit tutd."+                                                        pure (Just ""))+  maybeLine <- catchInterrupt $ runInputT settings $ getInputLine (T.unpack prompt)   case maybeLine of     Nothing -> return ()     Just line -> do-      case parseTutorialD (T.pack line) of-        Left err -> -          displayOpResult $ DisplayParseErrorResult (T.length prompt) err-        Right parsed ->-          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."))+      runTutorialD sessionId conn (T.pack line)       reprLoop config sessionId conn+      ++runTutorialD :: C.SessionId -> C.Connection -> T.Text -> IO ()+runTutorialD sessionId conn tutd = +  case parseTutorialD tutd of+    Left err -> +      displayOpResult $ DisplayParseErrorResult 0 err+    Right parsed ->+      catchJust (\exc -> if exc == C.RequestTimeoutException then Just exc else Nothing) (do+        evald <- evalTutorialDInteractive sessionId conn UnsafeEvaluation True parsed+        displayOpResult evald)+        (\_ -> displayOpResult (DisplayErrorResult "Request timed out."))

@@ -153,8 +153,9 @@   reserved "notify"   notName <- identifier   triggerExpr <- relExprP -  resultExpr <- relExprP-  pure $ AddNotification notName triggerExpr resultExpr+  resultOldExpr <- relExprP+  resultNewExpr <- relExprP+  pure $ AddNotification notName triggerExpr resultOldExpr resultNewExpr    removeNotificationP :: Parser DatabaseContextExpr   removeNotificationP = do

@@ -4,7 +4,7 @@ import Data.Monoid  -- | import data into a relation variable-data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (RelVarName -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr))+data RelVarDataImportOperator = RelVarDataImportOperator RelVarName FilePath (RelVarName -> TypeConstructorMapping -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr))  instance Show RelVarDataImportOperator where   show (RelVarDataImportOperator rv path _) = "RelVarDataImportOperator " <> show rv <> " " <> path@@ -17,8 +17,8 @@  -- 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 +evalRelVarDataImportOperator :: RelVarDataImportOperator -> TypeConstructorMapping -> Attributes -> IO (Either RelationalError DatabaseContextExpr)+evalRelVarDataImportOperator (RelVarDataImportOperator relVarName path importFunc) tConsMap attrs = importFunc relVarName tConsMap attrs path           evalDatabaseContextDataImportOperator :: DatabaseContextDataImportOperator -> IO (Either RelationalError DatabaseContextExpr)         evalDatabaseContextDataImportOperator (DatabaseContextDataImportOperator path importFunc) = importFunc path

@@ -2,20 +2,20 @@ import TutorialD.Interpreter.Import.Base import ProjectM36.Base import ProjectM36.Error-import ProjectM36.Relation.Parse.CSV+import ProjectM36.Relation.Parse.CSV hiding (quotedString) 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+importCSVRelation :: RelVarName -> TypeConstructorMapping -> Attributes -> FilePath -> IO (Either RelationalError DatabaseContextExpr)+importCSVRelation relVarName tConsMap 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+    Right csvData' -> case csvAsRelation attrs tConsMap csvData' of       Left err -> return $ Left (ParseError $ T.pack (show err))       Right csvRel -> return $ Right (Insert relVarName (ExistingRelation csvRel)) 

@@ -215,7 +215,7 @@ atomP :: Parser Atom atomP = stringAtomP <|>          doubleAtomP <|> -        intAtomP <|> +        integerAtomP <|>          boolAtomP          functionAtomExprP :: RelationalMarkerExpr a => Parser (AtomExprBase a)@@ -234,10 +234,8 @@ doubleAtomP :: Parser Atom     doubleAtomP = DoubleAtom <$> try float -intAtomP :: Parser Atom-intAtomP = do-  i <- integer-  return $ IntAtom (fromIntegral i)+integerAtomP :: Parser Atom+integerAtomP = IntegerAtom <$> integer  boolAtomP :: Parser Atom boolAtomP = do

@@ -6,7 +6,6 @@ import ProjectM36.IsomorphicSchema import ProjectM36.Session import ProjectM36.Client-import ProjectM36.Error import TutorialD.Interpreter.RelationalExpr import TutorialD.Interpreter.Base 

@@ -5,7 +5,6 @@ import Text.Megaparsec import ProjectM36.TransactionGraph hiding (autoMergeToHead) import ProjectM36.Client-import ProjectM36.Error import ProjectM36.Base  data ConvenienceTransactionGraphOperator = AutoMergeToHead MergeStrategy HeadName

@@ -6,10 +6,11 @@ import Options.Applicative import System.Exit import Data.Monoid+import qualified Data.Text as T  parseArgs :: Parser InterpreterConfig-parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseGhcPkgPaths <|>-            RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName+parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseTutDExec <*> parseGhcPkgPaths <|>+            RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName <*> parseTutDExec  parsePersistenceStrategy :: Parser PersistenceStrategy parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>@@ -47,6 +48,13 @@                       help "Remote port" <>                       value defaultServerPort)               +--just execute some tutd and exit+parseTutDExec :: Parser (Maybe TutorialDExec)+parseTutDExec = optional $ strOption (long "exec-tutd" <>+                           short 'e' <>+                           help "Execute TutorialD expression and exit"+                           )+               parseGhcPkgPaths :: Parser [GhcPkgPath]               parseGhcPkgPaths = many (strOption (long "ghc-pkg-dir" <>                                     metavar "GHC_PACKAGE_DIRECTORY"))@@ -55,13 +63,17 @@ opts = info parseArgs idm  connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo-connectionInfoForConfig (LocalInterpreterConfig pStrategy _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths-connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback+connectionInfoForConfig (LocalInterpreterConfig pStrategy _ _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths+connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _ _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback  headNameForConfig :: InterpreterConfig -> HeadName-headNameForConfig (LocalInterpreterConfig _ headn _) = headn-headNameForConfig (RemoteInterpreterConfig _ _ headn) = headn+headNameForConfig (LocalInterpreterConfig _ headn _ _) = headn+headNameForConfig (RemoteInterpreterConfig _ _ headn _) = headn +execTutDForConfig :: InterpreterConfig -> Maybe String+execTutDForConfig (LocalInterpreterConfig _ _ t _) = t+execTutDForConfig (RemoteInterpreterConfig _ _ _ t) = t+ {- ghcPkgPathsForConfig :: InterpreterConfig -> [GhcPkgPath] ghcPkgPathsForConfig (LocalInterpreterConfig _ _ paths) = paths@@ -94,8 +106,12 @@       eSessionId <- createSessionAtHead conn connHeadName       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 ()+          Right sessionId -> +            case execTutDForConfig interpreterConfig of+              Nothing -> do+                printWelcome+                _ <- reprLoop interpreterConfig sessionId conn+                pure ()+              Just tutdStr -> +                runTutorialD sessionId conn (T.pack tutdStr) 

@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+--benchmark test for file handle leaks+import ProjectM36.Client+import Options.Applicative+import TutorialD.Interpreter+import TutorialD.Interpreter.Base+import qualified Data.Text as T+import Text.Megaparsec hiding (option)+import Data.Monoid+import System.Directory+import Control.Monad++data HandlesArgs = HandlesArgs {+  openCloseCount :: Int,+  transactionCount :: Int,+  dbdir :: FilePath, +  tutdSetup :: String,+  tutdIterate :: String+  }++parseArgs :: Parser HandlesArgs+parseArgs = HandlesArgs <$> parseOpenAndCloseCount <*> parseTransactionCount <*> parseDbDir <*> parseTutdSetup <*> parseTutdIterate++parseOpenAndCloseCount :: Parser Int+parseOpenAndCloseCount = option auto (short 'o' <> long "open-close-count")++parseTransactionCount :: Parser Int+parseTransactionCount = option auto (short 't' <> long "transaction-count")++parseDbDir :: Parser FilePath+parseDbDir = strOption (short 'd' <> long "dbdir")++parseTutdSetup :: Parser String+parseTutdSetup = strOption (short 's' <> long "setup-tutd" <> value "x:=relation{tuple{v t}}")++parseTutdIterate :: Parser String+parseTutdIterate = strOption (short 'i' <> long "iterate-tutd" <> value "update x (v:=not(@v))")++main :: IO ()+main = do+  args <- execParser $ info (helper <*> parseArgs) fullDesc+  replicateM_ (openCloseCount args) (runOpenClose +                                     (T.pack (tutdSetup args))+                                     (T.pack (tutdIterate args))+                                     (transactionCount args) +                                     (dbdir args))+  +runOpenClose :: T.Text -> T.Text -> Int -> FilePath -> IO ()  +runOpenClose tutdSetup' tutdIterate' tCount dbdir' = do+  let connInfo = InProcessConnectionInfo (MinimalPersistence dbdir') emptyNotificationCallback []+  eConn <- connectProjectM36 connInfo+  case eConn of+    Left err -> error (show err)+    Right conn -> do+      eSess <- createSessionAtHead conn "master"+      case eSess of+        Left err -> error (show err)+        Right session -> +          --database setup+          case parseTutorialD tutdSetup' of+            Left err -> error (show err)+            Right parsed -> do+              res <- evalTutorialD session conn UnsafeEvaluation parsed+              case res of+                DisplayErrorResult err -> error (T.unpack err)+                DisplayParseErrorResult _ err -> error (parseErrorPretty err)+                _ -> do +                  replicateM_ tCount (runTransaction tutdIterate' session conn)+                  close conn+                  printFdCount+  +runTransaction :: T.Text -> SessionId -> Connection -> IO ()+runTransaction tutdIterate' sess conn = +  --run tutd on every iteration+  case parseTutorialD tutdIterate' of+    Left err -> error (show err)+    Right parsed -> do+      res <- evalTutorialD sess conn UnsafeEvaluation parsed+      case res of+        DisplayErrorResult err -> error (T.unpack err)+        DisplayParseErrorResult _ err -> error (parseErrorPretty err)+        _ -> do +          eErr <- commit sess conn +          case eErr of+            Left err -> error (show err)+            Right _ -> printFdCount+      +--prints out number of consumed file descriptors      +printFdCount :: IO ()+#if defined(linux_HOST_OS)+printFdCount = do+  fdc <- fdCount+  putStrLn ("Fd count: " ++ show fdc)+  --getLine >> pure ()+#else+printFdCount = putStrLn "Fd count not supported on this OS."+#endif+++fdCount :: IO Int+#if defined(linux_HOST_OS)+fdCount = do+  fds <- getDirectoryContents "/proc/self/fd"+  pure ((length fds) - 2)+#else +--not supported on non-linux+fdCount = pure 0+#endif

@@ -78,7 +78,7 @@ 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]+    mapper tupCount = IM.fromList $ map (\c-> (c, IntAtom (fromIntegral tupCount))) [0..attributeCount]  instance Hash.Hashable (IM.IntMap Atom) where   hashWithSalt salt tupMap = Hash.hashWithSalt salt (show tupMap)@@ -93,7 +93,7 @@ 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)+    mapper tupCount = V.replicate attributeCount (IntAtom (fromIntegral tupCount))  instance Hash.Hashable (V.Vector Atom) where   hashWithSalt salt vec = Hash.hashWithSalt salt (show vec)@@ -103,7 +103,7 @@ 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))+      tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom (fromIntegral tupleX)))       tuples = map tuple [0 .. tupleCount]   mkRelationDeferVerify attrs (RelationTupleSet tuples) 

@@ -5,24 +5,14 @@ --import Data.Time.Calendar --import Data.Time.Clock --import Data.ByteString (ByteString)-import Text.Read import Data.Monoid  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 (IntegerAtom i) = (T.pack . show) i atomToText (IntAtom i) = (T.pack . show) i atomToText (DoubleAtom i) = (T.pack . show) i atomToText (TextAtom i) = (T.pack . show) i --does this break quoting in CSV export?@@ -37,7 +27,15 @@         endp = if be then ")" else "]"  atomToText (RelationAtom i) = (T.pack . show) i-atomToText (ConstructedAtom dConsName _ atoms) = dConsName `T.append` T.intercalate " " (map atomToText atoms)+atomToText (ConstructedAtom dConsName _ atoms) = dConsName <> dConsArgs+  where+    parensAtomToText a@(ConstructedAtom _ _ []) = atomToText a+    parensAtomToText a@ConstructedAtom{} = "(" <> atomToText a <> ")"+    parensAtomToText a = atomToText a+    +    dConsArgs = case atoms of+      [] -> ""+      args -> " " <> T.intercalate " " (map parensAtomToText args)   

@@ -7,10 +7,11 @@  data AtomFunctionError = AtomFunctionUserError String |                          AtomFunctionTypeMismatchError |-                         InvalidIntervalOrdering |-                         InvalidIntervalBoundaries |-                         AtomTypeDoesNotSupportOrdering Text |-                         AtomTypeDoesNotSupportInterval Text |+                         InvalidIntervalOrderingError |+                         InvalidIntervalBoundariesError |+                         AtomFunctionEmptyRelationError |+                         AtomTypeDoesNotSupportOrderingError Text |+                         AtomTypeDoesNotSupportIntervalError Text |                          AtomFunctionBytesDecodingError String                        deriving(Generic, Eq, Show, Binary, NFData) 

@@ -1,6 +1,6 @@ module ProjectM36.AtomFunctions.Primitive where import ProjectM36.Base-import ProjectM36.Relation (relFold)+import ProjectM36.Relation (relFold, oneTuple) import ProjectM36.Tuple import ProjectM36.AtomFunctionError import ProjectM36.AtomFunction@@ -12,47 +12,47 @@ 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)))},+                 atomFuncType = [IntegerAtomType, IntegerAtomType, IntegerAtomType],+                 atomFuncBody = body (\(IntegerAtom i1:IntegerAtom i2:_) -> pure (IntegerAtom (i1 + i2)))},   AtomFunction { atomFuncName = "id",                  atomFuncType = [TypeVariableType "a", TypeVariableType "a"],                  atomFuncBody = body (\(x:_) -> pure x)},   AtomFunction { atomFuncName = "sum",-                 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,+                 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,                  atomFuncBody = body (\(RelationAtom rel:_) -> relationSum rel)},   AtomFunction { atomFuncName = "count",-                 atomFuncType = foldAtomFuncType (TypeVariableType "a") IntAtomType,+                 atomFuncType = foldAtomFuncType (TypeVariableType "a") IntegerAtomType,                  atomFuncBody = body (\(RelationAtom relIn:_) -> relationCount relIn)},   AtomFunction { atomFuncName = "max",-                 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,+                 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,                  atomFuncBody = body (\(RelationAtom relIn:_) -> relationMax relIn)},   AtomFunction { atomFuncName = "min",-                 atomFuncType = foldAtomFuncType IntAtomType IntAtomType,+                 atomFuncType = foldAtomFuncType IntegerAtomType IntegerAtomType,                  atomFuncBody = body (\(RelationAtom relIn:_) -> relationMin relIn)},   AtomFunction { atomFuncName = "lt",-                 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],-                 atomFuncBody = body $ intAtomFuncLessThan False},+                 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+                 atomFuncBody = body $ integerAtomFuncLessThan False},   AtomFunction { atomFuncName = "lte",-                 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],-                 atomFuncBody = body $ intAtomFuncLessThan True},+                 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+                 atomFuncBody = body $ integerAtomFuncLessThan True},   AtomFunction { atomFuncName = "gte",-                 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],-                 atomFuncBody = body $ intAtomFuncLessThan False >=> boolAtomNot},+                 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+                 atomFuncBody = body $ integerAtomFuncLessThan False >=> boolAtomNot},   AtomFunction { atomFuncName = "gt",-                 atomFuncType = [IntAtomType, IntAtomType, BoolAtomType],-                 atomFuncBody = body $ intAtomFuncLessThan True >=> boolAtomNot},+                 atomFuncType = [IntegerAtomType, IntegerAtomType, BoolAtomType],+                 atomFuncBody = body $ integerAtomFuncLessThan True >=> boolAtomNot},   AtomFunction { atomFuncName = "not",                  atomFuncType = [BoolAtomType, BoolAtomType],-                 atomFuncBody = body $ \(b:_) -> boolAtomNot b }+                 atomFuncBody = body $ \(b:_) -> boolAtomNot b }     ]   where     body = AtomFunctionBody Nothing                          -intAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom-intAtomFuncLessThan equality (IntAtom i1:IntAtom i2:_) = pure (BoolAtom (i1 `op` i2))+integerAtomFuncLessThan :: Bool -> [Atom] -> Either AtomFunctionError Atom+integerAtomFuncLessThan equality (IntegerAtom i1:IntegerAtom i2:_) = pure (BoolAtom (i1 `op` i2))   where     op = if equality then (<=) else (<)-intAtomFuncLessThan _ _= pure (BoolAtom False)+integerAtomFuncLessThan _ _= pure (BoolAtom False)  boolAtomNot :: Atom -> Either AtomFunctionError Atom boolAtomNot (BoolAtom b) = pure (BoolAtom (not b))@@ -60,25 +60,32 @@  --used by sum atom function relationSum :: Relation -> Either AtomFunctionError Atom-relationSum relIn = pure (IntAtom (relFold (\tupIn acc -> acc + newVal tupIn) 0 relIn))+relationSum relIn = pure (IntegerAtom (relFold (\tupIn acc -> acc + newVal tupIn) 0 relIn))   where-    --extract Int from Atom-    newVal :: RelationTuple -> Int-    newVal tupIn = castInt (tupleAtoms tupIn V.! 0)+    --extract Integer from Atom+    newVal tupIn = castInteger (tupleAtoms tupIn V.! 0)      relationCount :: Relation -> Either AtomFunctionError Atom-relationCount relIn = pure (IntAtom (relFold (\_ acc -> acc + 1) (0::Int) relIn))+relationCount relIn = pure (IntegerAtom (relFold (\_ acc -> acc + 1) (0::Integer) relIn))  relationMax :: Relation -> Either AtomFunctionError Atom-relationMax relIn = pure (IntAtom (relFold (\tupIn acc -> max acc (newVal tupIn)) minBound relIn))+relationMax relIn = case oneTuple relIn of+    Nothing -> Left AtomFunctionEmptyRelationError+    Just oneTup -> pure (IntegerAtom (relFold (\tupIn acc -> max acc (newVal tupIn)) (newVal oneTup) relIn))   where-    newVal tupIn = castInt (tupleAtoms tupIn V.! 0)+    newVal tupIn = castInteger (tupleAtoms tupIn V.! 0)  relationMin :: Relation -> Either AtomFunctionError Atom-relationMin relIn = pure (IntAtom (relFold (\tupIn acc -> min acc (newVal tupIn)) maxBound relIn))+relationMin relIn = case oneTuple relIn of +  Nothing -> Left AtomFunctionEmptyRelationError+  Just oneTup -> pure (IntegerAtom (relFold (\tupIn acc -> min acc (newVal tupIn)) (newVal oneTup) relIn))   where-    newVal tupIn = castInt (tupleAtoms tupIn V.! 0)+    newVal tupIn = castInteger (tupleAtoms tupIn V.! 0)  castInt :: Atom -> Int castInt (IntAtom i) = i castInt _ = error "attempted to cast non-IntAtom to Int"++castInteger :: Atom -> Integer+castInteger (IntegerAtom i) = i +castInteger _ = error "attempted to cast non-IntegerAtom to Int"

@@ -41,7 +41,7 @@       typeVars <- resolveDataConstructorTypeVars dCons atomTypesIn tConsList       pure (ConstructedAtomType (TCD.name tCons) typeVars)         -atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping -> Either RelationalError AtomType+atomTypeForDataConstructorDefArg :: DataConstructorDefArg -> AtomType -> TypeConstructorMapping ->  Either RelationalError AtomType atomTypeForDataConstructorDefArg (DataConstructorDefTypeConstructorArg tCons) aType tConss =    case isValidAtomTypeForTypeConstructor aType tCons tConss of     Just err -> Left err@@ -72,18 +72,23 @@        -- | 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)+resolveDataConstructorTypeVars dCons@(DataConstructorDef _ defArgs) aTypeArgs tConss = do+  let defCount = length defArgs+      argCount = length aTypeArgs+  if defCount /= argCount then+    Left (ConstructedAtomArgumentCountMismatchError defCount argCount)+    else 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+    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.  @@ -111,8 +116,8 @@           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                             +resolveTypeConstructorTypeVars (TypeVariable tvName) typ _ = Right (M.singleton tvName typ)+resolveTypeConstructorTypeVars (ADTypeConstructor tConsName _) typ _ = Left (TypeConstructorAtomTypeMismatch tConsName typ)      -- check that type vars on the right also appear on the left -- check that the data constructor names are unique      @@ -129,13 +134,15 @@  -- | 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+atomTypeForTypeConstructor :: TypeConstructor -> TypeConstructorMapping -> TypeVarMap -> Either RelationalError AtomType+atomTypeForTypeConstructor (PrimitiveTypeConstructor _ aType) _ _ = Right aType+atomTypeForTypeConstructor (TypeVariable tvname) _ tvMap = case M.lookup tvname tvMap of+  Nothing -> Right (TypeVariableType tvname)+  Just typ -> Right typ+atomTypeForTypeConstructor tCons tConss tvMap = case findTypeConstructor (TC.name tCons) tConss of   Nothing -> Left (NoSuchTypeConstructorError (TC.name tCons))   Just (tConsDef, _) -> do-      tConsArgTypes <- mapM (`atomTypeForTypeConstructor` tConss) (TC.arguments tCons)    +      tConsArgTypes <- mapM (\tConsArg -> atomTypeForTypeConstructor tConsArg tConss tvMap) (TC.arguments tCons)           let pVarNames = TCD.typeVars tConsDef           tConsArgs = M.fromList (zip pVarNames tConsArgTypes)       Right (ConstructedAtomType (TC.name tCons) tConsArgs)      @@ -240,7 +247,7 @@                      else                        Left $ AtomTypeMismatchError x y --- | Determine if two typeVar+-- | Determine if two typeVars are logically compatible. typeVarMapsVerify :: TypeVarMap -> TypeVarMap -> Bool typeVarMapsVerify a b = M.keysSet a == M.keysSet b && (length . rights) (map (\((_,v1),(_,v2)) -> atomTypeVerify v1 v2) (zip (M.toAscList a) (M.toAscList b))) == M.size a @@ -291,3 +298,13 @@   Nothing -> Left (AtomFunctionTypeVariableResolutionError funcName tvName)   Just typ -> pure typ resolveFunctionReturnValue _ _ typ = pure typ++-- convert a typevarmap and data constructor definition into a list of atomtypes which represent the arguments-- no type variables are allowed to remain+resolvedAtomTypesForDataConstructorDefArgs :: TypeConstructorMapping -> TypeVarMap -> DataConstructorDef -> Either RelationalError [AtomType] +resolvedAtomTypesForDataConstructorDefArgs tConsMap tvMap (DataConstructorDef _ args) = mapM (resolvedAtomTypeForDataConstructorDefArg tConsMap tvMap) args++resolvedAtomTypeForDataConstructorDefArg :: TypeConstructorMapping -> TypeVarMap -> DataConstructorDefArg -> Either RelationalError AtomType+resolvedAtomTypeForDataConstructorDefArg tConsMap tvMap (DataConstructorDefTypeConstructorArg typCons) = atomTypeForTypeConstructor typCons tConsMap tvMap+resolvedAtomTypeForDataConstructorDefArg _ tvMap (DataConstructorDefTypeVarNameArg tvName) = case M.lookup tvName tvMap of+  Nothing -> Left (DataConstructorUsesUndeclaredTypeVariable tvName)+  Just typ -> Right typ

@@ -3,9 +3,10 @@ --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 ProjectM36.DataTypes.Maybe+import ProjectM36.DataTypes.Either import GHC.Generics import qualified Data.Map as M import qualified Data.Text as T@@ -16,6 +17,7 @@ import Data.ByteString (ByteString) import Data.Time.Clock import Data.Maybe+import Data.Proxy  --also add haskell scripting atomable support --rename this module to Atomable along with test@@ -45,15 +47,22 @@     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)+  toAtomType :: proxy a -> AtomType+  default toAtomType :: (Generic a, AtomableG (Rep a)) => proxy a -> AtomType+  toAtomType _ = toAtomTypeG (from (undefined :: a))                          -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.-  toAddTypeExpr :: a -> DatabaseContextExpr-  default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => a -> DatabaseContextExpr-  toAddTypeExpr v = toAddTypeExprG (from v) (toAtomType v)+  toAddTypeExpr :: Proxy a -> DatabaseContextExpr+  default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => proxy a -> DatabaseContextExpr+  toAddTypeExpr _ = toAddTypeExprG (from (undefined :: a)) (toAtomType (Proxy :: Proxy a))   +instance Atomable Integer where  +  toAtom = IntegerAtom+  fromAtom (IntegerAtom i) = i+  fromAtom e = error ("improper fromAtom" ++ show e)+  toAtomType _ = IntegerAtomType+  toAddTypeExpr _ = NoOperation+   instance Atomable Int where     toAtom = IntAtom   fromAtom (IntAtom i) = i@@ -103,6 +112,7 @@   toAtomType _ = BoolAtomType   toAddTypeExpr _ = NoOperation   +{- instance Atomable Relation where   toAtom = RelationAtom   fromAtom (RelationAtom r) = r@@ -110,17 +120,39 @@   --warning: cannot be used with undefined "Relation"   toAtomType rel = RelationAtomType (attributes rel)    toAddTypeExpr _ = NoOperation+-}   +instance Atomable a => Atomable (Maybe a) where+  toAtom (Just v) = ConstructedAtom "Just" (maybeAtomType (toAtomType (Proxy :: Proxy a))) [toAtom v]+  toAtom Nothing = ConstructedAtom "Nothing" (maybeAtomType (toAtomType (Proxy :: Proxy a))) []+  +  fromAtom (ConstructedAtom "Just" _ [val]) = Just (fromAtom val)+  fromAtom (ConstructedAtom "Nothing" _ []) = Nothing+  fromAtom _ = error "improper fromAtom (Maybe a)"+  +  toAtomType _ = ConstructedAtomType "Maybe" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))+  toAddTypeExpr _ = NoOperation+  +instance (Atomable a, Atomable b) => Atomable (Either a b) where+  toAtom (Left l) = ConstructedAtom "Left" (eitherAtomType (toAtomType (Proxy :: Proxy a)) +                                            (toAtomType (Proxy :: Proxy b))) [toAtom l]+  toAtom (Right r) = ConstructedAtom "Right" (eitherAtomType (toAtomType (Proxy :: Proxy a)) +                                              (toAtomType (Proxy :: Proxy b))) [toAtom r]+  +  fromAtom (ConstructedAtom "Left" _ [val]) = Left (fromAtom val)+  fromAtom (ConstructedAtom "Right" _ [val]) = Right (fromAtom val)+  fromAtom _ = error "improper fromAtom (Either a b)"+   --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))+  toAtom [] = ConstructedAtom "Empty" (listAtomType (toAtomType (Proxy :: Proxy a))) []+  toAtom (x:xs) = ConstructedAtom "Cons" (listAtomType (toAtomType (Proxy :: Proxy a))) (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)))+  toAtomType _ = ConstructedAtomType "List" (M.singleton "a" (toAtomType (Proxy :: Proxy a)))   toAddTypeExpr _ = NoOperation  -- Generics@@ -190,13 +222,13 @@                      where headatom (x:_) = x                            headatom [] = error "no more atoms for constructor!"   toAtomsG (K1 v) = [toAtom v]-  toAtomTypeG _ = toAtomType (undefined :: a)+  toAtomTypeG _ = toAtomType (Proxy :: Proxy a)   toAddTypeExprG _ _ = undefined       getConstructorsG = undefined-  getConstructorArgsG (K1 v) = [DataConstructorDefTypeConstructorArg tCons]+  getConstructorArgsG (K1 _) = [DataConstructorDefTypeConstructorArg tCons]     where       tCons = PrimitiveTypeConstructor primitiveATypeName primitiveAType-      primitiveAType = toAtomType v+      primitiveAType = toAtomType (Proxy :: Proxy a)       primitiveATypeName = fromMaybe (error ("primitive type missing: " ++ show primitiveAType)) (foldr (\(PrimitiveTypeConstructorDef name typ, _) _ -> if typ == primitiveAType then Just name else Nothing) Nothing primitiveTypeConstructorMapping)          instance AtomableG U1 where

@@ -27,7 +27,8 @@ 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 |+data Atom = IntegerAtom Integer |+            IntAtom Int |             DoubleAtom Double |             TextAtom Text |             DayAtom Day |@@ -45,6 +46,7 @@   hashWithSalt salt (ConstructedAtom dConsName _ atoms) = salt `hashWithSalt` atoms                                                           `hashWithSalt` dConsName --AtomType is not hashable   hashWithSalt salt (IntAtom i) = salt `hashWithSalt` i+  hashWithSalt salt (IntegerAtom 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@@ -68,7 +70,8 @@  -- 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 |                +data AtomType = IntAtomType |+                IntegerAtomType |                 DoubleAtomType |                 TextAtomType |                 DayAtomType |@@ -224,7 +227,8 @@ -- | 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+  reportOldExpr :: RelationalExpr, --run the expression in the pre-change context+  reportNewExpr :: RelationalExpr --run the expression in the post-change context   }   deriving (Show, Eq, Binary, Generic, NFData) @@ -314,7 +318,7 @@   AddInclusionDependency IncDepName InclusionDependency |   RemoveInclusionDependency IncDepName |   -  AddNotification NotificationName RelationalExpr RelationalExpr |+  AddNotification NotificationName RelationalExpr RelationalExpr RelationalExpr |   RemoveNotification NotificationName |    AddTypeConstructor TypeConstructorDef [DataConstructorDef] |

@@ -24,6 +24,7 @@        rollback,        typeForRelationalExpr,        inclusionDependencies,+       ProjectM36.Client.typeConstructorMapping,        planForDatabaseContextExpr,        currentSchemaName,        SchemaName,@@ -83,6 +84,7 @@        IncDepName,        InclusionDependency(..),        AttributeName,+       RelationalError(..),        RequestTimeoutException(..),        RemoteProcessDiedException(..),        AtomType(..),@@ -182,10 +184,11 @@ newtype 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.+-- | When a notification is fired, the 'reportOldExpr' is evaluated in the commit's pre-change context while the 'reportNewExpr' is evaluated in the post-change context and they are returned along with the original notification. data EvaluatedNotification = EvaluatedNotification {   notification :: Notification,-  reportRelation :: Either RelationalError Relation+  reportOldRelation :: Either RelationalError Relation,+  reportNewRelation :: Either RelationalError Relation   }                            deriving(Binary, Eq, Show, Generic)                       @@ -213,8 +216,6 @@ -- | 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, @@ -224,7 +225,7 @@   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+  ipLocks :: Maybe (LockFile, MVar LockFileHash) -- nothing when NoPersistence   }  data RemoteProcessConnectionConf = RemoteProcessConnectionConf {@@ -415,6 +416,7 @@ closeSession sessionId (InProcessConnection conf) =      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@@ -424,6 +426,10 @@     pure ()   closeLocalNode (ipLocalNode conf)   closeTransport (ipTransport conf)+  let mLocks = ipLocks conf+  case mLocks of+    Nothing -> pure ()+    Just (lockFileH, _) -> closeLockFile lockFileH  close conn@(RemoteProcessConnection conf) = do   _ <- remoteCall conn Logout :: IO Bool@@ -627,8 +633,10 @@   let nots = notifications oldContext       fireNots = notificationChanges nots oldContext newContext        evaldNots = M.map mkEvaldNot fireNots+      evalInContext expr ctx = runReader (RE.evalRelationalExpr expr) (RE.mkRelationalExprState ctx)       mkEvaldNot notif = EvaluatedNotification { notification = notif, -                                                 reportRelation = runReader (RE.evalRelationalExpr (reportExpr notif)) (RE.mkRelationalExprState oldContext) }+                                                 reportOldRelation = evalInContext (reportOldExpr notif) oldContext,+                                                 reportNewRelation = evalInContext (reportNewExpr notif) newContext}   pure (evaldNots, nodes)    -- | Execute a transaction graph expression in the context of the session and connection. Transaction graph operators modify the transaction graph state.@@ -824,6 +832,17 @@  inclusionDependencies sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveInclusionDependencies sessionId) +typeConstructorMapping :: SessionId -> Connection -> IO (Either RelationalError TypeConstructorMapping)+typeConstructorMapping sessionId (InProcessConnection conf) = do+  let sessions = ipSessions conf+  atomically $ do+    eSession <- sessionAndSchema sessionId sessions+    case eSession of+      Left err -> pure $ Left err +      Right (session, _) -> --warning, no schema support for typeconstructors+        pure (Right (B.typeConstructorMapping (Sess.concreteDatabaseContext session)))+typeConstructorMapping sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveTypeConstructorMapping sessionId)+ -- | Return an optimized database expression which is logically equivalent to the input database expression. This function can be used to determine which expression will actually be evaluated. planForDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO (Either RelationalError DatabaseContextExpr)   planForDatabaseContextExpr sessionId (InProcessConnection conf) dbExpr = do@@ -917,7 +936,7 @@     case eSession of       Left err -> pure (Left err)       Right session ->-        case typesAsRelation (typeConstructorMapping (Sess.concreteDatabaseContext session)) of+        case typesAsRelation (B.typeConstructorMapping (Sess.concreteDatabaseContext session)) of           Left err -> pure (Left err)           Right rel -> pure (Right rel) atomTypesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomTypesAsRelation sessionId)

@@ -1,76 +1,95 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | A simplified client interface for Project:M36 database access. module ProjectM36.Client.Simple (   simpleConnectProjectM36,+  simpleConnectProjectM36At,   withTransaction,+  withTransactionUsing,   execute,+  executeOrErr,   query,+  queryOrErr,+  cancelTransaction,+  orCancelTransaction,   rollback,   close,   Atom(..),   AtomType(..),+  Db,+  DbConn,   DbError(..),+  RelationalError(..),   Attribute(..),+  C.Atomable(toAtom, fromAtom),   C.ConnectionInfo(..),   C.PersistenceStrategy(..),   C.NotificationCallback,   C.emptyNotificationCallback,   C.DatabaseContextExpr(..),-  C.RelationalExprBase(..)  +  C.RelationalExprBase(..)   ) where--- | A simplified client interface for Project:M36 database access.-import ProjectM36.Error++import Control.Exception.Base+import Control.Monad ((<=<))+import Control.Monad.Reader import ProjectM36.Base import qualified ProjectM36.Client as C-import Control.Monad.Reader-import Control.Exception.Base+import ProjectM36.Error  type DbConn = (C.SessionId, C.Connection) -newtype Db a = Db {runDB :: ReaderT DbConn IO a}+newtype Db a = Db {runDb :: ReaderT DbConn IO a}   deriving (Functor, Applicative, Monad, MonadIO)-           ++-- This exception type should never be observable by the API users.+-- It merely carries errors which end up as RelError at the end of a transaction. newtype TransactionCancelled = TransactionCancelled DbError deriving Show instance Exception TransactionCancelled --- | A simple alternative to 'connectProjectM36' which includes simple session management-simpleConnectProjectM36 :: C.ConnectionInfo -> IO (Either DbError DbConn)-simpleConnectProjectM36 connInfo = do+-- | A simple alternative to 'connectProjectM36' which includes simple session management.+simpleConnectProjectM36At :: HeadName -> C.ConnectionInfo -> IO (Either DbError DbConn)+simpleConnectProjectM36At headName connInfo = do   eConn <- C.connectProjectM36 connInfo   case eConn of     Left err -> pure (Left (ConnError err))     Right conn -> do-      eSess <- C.createSessionAtHead conn "master"+      eSess <- C.createSessionAtHead conn headName       case eSess of         Left err -> do           C.close conn           pure (Left (RelError err))         Right sess -> pure (Right (sess, conn))-        -close :: DbConn -> IO ()        ++-- | Same as 'simpleConnectProjectM36At' but always connects to the @master@ branch.+simpleConnectProjectM36 :: C.ConnectionInfo -> IO (Either DbError DbConn)+simpleConnectProjectM36 = simpleConnectProjectM36At "master"++-- | Closes the database connection.+close :: DbConn -> IO () close (_ , conn) = C.close conn  -- | Runs a Db monad which may include some database updates. If an exception or error occurs, the transaction is rolled back. Otherwise, the transaction is committed to the head of the current branch. withTransaction :: DbConn -> Db a -> IO (Either DbError a)-withTransaction sessconn = withTransactionUsing sessconn UnionMergeStrategy +withTransaction sessconn = withTransactionUsing sessconn UnionMergeStrategy  -- | Same a 'withTransaction' except that the merge strategy can be specified. withTransactionUsing :: DbConn -> MergeStrategy -> Db a -> IO (Either DbError a) withTransactionUsing (sess, conn) strat dbm = do   eHeadName <- C.headName sess conn-  case eHeadName of +  case eHeadName of     Left err -> pure (Left (RelError err))     Right headName -> do       let successFunc = C.autoMergeToHead sess conn strat headName-          block = runReaderT (runDB dbm) (sess, conn)+          block = runReaderT (runDb dbm) (sess, conn)           handler :: TransactionCancelled -> IO (Either DbError a)           handler (TransactionCancelled err) = pure (Left err)       handle handler $ do         ret <- C.withTransaction sess conn (block >>= pure . Right) successFunc-        case ret of -          Left err -> pure (Left (RelError err))+        case ret of+          Left err  -> pure (Left (RelError err))           Right val -> pure (Right val) --- | A union of connection and other errors that can be returned from 'withDBConnection'.+-- | A union of connection and other errors that can be returned from 'withTransaction'. data DbError = ConnError C.ConnectionError |                RelError RelationalError |                TransactionRolledBack@@ -78,26 +97,18 @@  -- | Execute a 'DatabaseContextExpr' in the 'DB' monad. Database context expressions manipulate the state of the database. In case of an error, the transaction is terminated and the connection's session is rolled back. execute :: C.DatabaseContextExpr -> Db ()-execute expr = do-  ret <- executeOrErr expr-  case ret of-    Left err -> liftIO $ cancelTransaction (RelError err)-    Right _ -> pure ()-    +execute = orCancelTransaction <=< executeOrErr+ -- | Run a 'RelationalExpr' query in the 'DB' monad. Relational expressions perform read-only queries against the current database state. query :: C.RelationalExpr -> Db Relation-query expr = do-  ret <- queryOrErr expr-  case ret of-    Left err -> liftIO $ cancelTransaction (RelError err)-    Right rel -> pure rel-    +query = orCancelTransaction <=< queryOrErr+ -- | Run a 'DatabaseContextExpr' update expression. If there is an error, just return it without cancelling the current transaction. executeOrErr :: C.DatabaseContextExpr -> Db (Either RelationalError ()) executeOrErr expr = Db $ do-  (sess, conn) <- ask  +  (sess, conn) <- ask   lift $ C.executeDatabaseContextExpr sess conn expr-  + -- | Run a 'RelationalExpr' query expression. If there is an error, just return it without cancelling the transaction. queryOrErr :: C.RelationalExpr -> Db (Either RelationalError Relation) queryOrErr expr = Db $ do@@ -106,7 +117,12 @@  -- | Unconditionally roll back the current transaction and throw an exception to terminate the execution of the Db monad. rollback :: Db ()-rollback = Db $ lift $ cancelTransaction TransactionRolledBack+rollback = cancelTransaction TransactionRolledBack -cancelTransaction :: DbError -> IO a-cancelTransaction err = throwIO (TransactionCancelled err)+-- | Cancel a transaction and carry some error information with it.+cancelTransaction :: DbError -> Db a+cancelTransaction err = liftIO $ throwIO (TransactionCancelled err)++-- | Converts the 'Either' result from a 'Db' action into an immediate cancel in the case of error.+orCancelTransaction :: Either RelationalError a -> Db a+orCancelTransaction = either (cancelTransaction . RelError) pure

@@ -18,3 +18,4 @@ typeVarsInDefArg :: DataConstructorDefArg -> S.Set TypeVarName typeVarsInDefArg (DataConstructorDefTypeConstructorArg tCons) = TC.typeVars tCons typeVarsInDefArg (DataConstructorDefTypeVarNameArg pVarName) = S.singleton pVarName+

@@ -7,8 +7,8 @@ dateTimeAtomFunctions :: AtomFunctions dateTimeAtomFunctions = HS.fromList [ AtomFunction {                                      atomFuncName = "dateTimeFromEpochSeconds",-                                     atomFuncType = [IntAtomType, DateTimeAtomType],-                                     atomFuncBody = compiledAtomFunctionBody $ \(IntAtom epoch:_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))+                                     atomFuncType = [IntegerAtomType, DateTimeAtomType],+                                     atomFuncBody = compiledAtomFunctionBody $ \(IntegerAtom epoch:_) -> pure (DateTimeAtom (posixSecondsToUTCTime (realToFrac epoch)))                                                                                                        }]                                                   

@@ -8,7 +8,7 @@ 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)+                 atomFuncBody = compiledAtomFunctionBody $ \(IntAtom year:IntAtom month:IntAtom day:_) -> pure $ DayAtom (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))                  },   AtomFunction { atomFuncName = "dayEarlierThan",                  atomFuncType = [DayAtomType, DayAtomType, BoolAtomType],

@@ -11,6 +11,7 @@ supportsInterval :: AtomType -> Bool supportsInterval typ = case typ of   IntAtomType -> True+  IntegerAtomType -> True   DoubleAtomType -> True   TextAtomType -> False -- just because it supports ordering, doesn't mean it makes sense in an interval   DayAtomType -> True               @@ -25,6 +26,7 @@ supportsOrdering :: AtomType -> Bool   supportsOrdering typ = case typ of   IntAtomType -> True+  IntegerAtomType -> True     DoubleAtomType -> True   TextAtomType -> True   DayAtomType -> True               @@ -39,13 +41,14 @@ atomCompare :: Atom -> Atom -> Either AtomFunctionError Ordering atomCompare a1 a2 = let aType = atomTypeForAtom a1                          go a b = Right (compare a b)-                        typError = Left (AtomTypeDoesNotSupportOrdering (prettyAtomType aType)) in+                        typError = Left (AtomTypeDoesNotSupportOrderingError (prettyAtomType aType)) in                     if atomTypeForAtom a1 /= atomTypeForAtom a2 then                       Left AtomFunctionTypeMismatchError                     else if not (supportsOrdering aType) then                            typError                          else                            case (a1, a2) of+                             (IntegerAtom a, IntegerAtom b) -> go a b                              (IntAtom a, IntAtom b) -> go a b                              (DoubleAtom a, DoubleAtom b) -> go a b                              (TextAtom a, TextAtom b) -> go a b@@ -58,9 +61,9 @@ createInterval atom1 atom2 bopen eopen = do   cmp <- atomCompare atom1 atom2   case cmp of-    GT -> Left InvalidIntervalOrdering+    GT -> Left InvalidIntervalOrderingError     EQ -> if bopen || eopen then-            Left InvalidIntervalBoundaries+            Left InvalidIntervalBoundariesError           else              Right valid     LT -> Right valid@@ -79,7 +82,7 @@                    if supportsInterval aType then                      createInterval atom1 atom2 bopen eopen                      else-                     Left (AtomTypeDoesNotSupportInterval (prettyAtomType aType))+                     Left (AtomTypeDoesNotSupportIntervalError (prettyAtomType aType))                },   AtomFunction {     atomFuncName = "interval_overlaps",

@@ -39,7 +39,7 @@      atomFuncType = [listAtomType (TypeVariableType "a"), IntAtomType],      atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> do                                                  c <- listLength listAtom-                                                 pure (IntAtom c))+                                                 pure (IntAtom (fromIntegral c)))      },   AtomFunction {     atomFuncName = "maybeHead",@@ -47,3 +47,8 @@     atomFuncBody = AtomFunctionBody Nothing (\(listAtom:_) -> listMaybeHead listAtom)     }   ]+                    +--just a private utility function+listCons :: AtomType -> [Atom] -> Atom+listCons typ [] = ConstructedAtom "Empty" (listAtomType typ) []+listCons typ (a:as) = ConstructedAtom "Cons" (listAtomType typ) [a, listCons typ as]

@@ -5,7 +5,8 @@ primitiveTypeConstructorMapping = map (\(name, aType) ->                                   (PrimitiveTypeConstructorDef name aType, [])) prims   where-    prims = [("Int", IntAtomType),+    prims = [("Integer", IntegerAtomType),+             ("Int", IntAtomType),              ("Text", TextAtomType),              ("Double", DoubleAtomType),              ("Bool", BoolAtomType),@@ -27,6 +28,7 @@ -- | Return the type of an 'Atom'. atomTypeForAtom :: Atom -> AtomType atomTypeForAtom (IntAtom _) = IntAtomType+atomTypeForAtom (IntegerAtom _) = IntegerAtomType atomTypeForAtom (DoubleAtom _) = DoubleAtomType atomTypeForAtom (TextAtom _) = TextAtomType atomTypeForAtom (DayAtom _) = DayAtomType

@@ -35,14 +35,14 @@   where     attrs = A.attributesFromList [Attribute "s#" TextAtomType,                                   Attribute "sname" TextAtomType,-                                  Attribute "status" IntAtomType,+                                  Attribute "status" IntegerAtomType,                                   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"]]+      [TextAtom "S1", TextAtom "Smith", IntegerAtom 20, TextAtom "London"],+      [TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"],+      [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],+      [TextAtom "S4", TextAtom "Clark", IntegerAtom 20, TextAtom "London"],+      [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]  supplierProductsRel :: Relation supplierProductsRel = case mkRelationFromList attrs matrix of@@ -51,20 +51,20 @@   where     attrs = A.attributesFromList [Attribute "s#" TextAtomType,                                   Attribute "p#" TextAtomType,-                                  Attribute "qty" IntAtomType]+                                  Attribute "qty" IntegerAtomType]     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]+      [TextAtom "S1", TextAtom "P1", IntegerAtom 300],+      [TextAtom "S1", TextAtom "P2", IntegerAtom 200],+      [TextAtom "S1", TextAtom "P3", IntegerAtom 400],+      [TextAtom "S1", TextAtom "P4", IntegerAtom 200],+      [TextAtom "S1", TextAtom "P5", IntegerAtom 100],+      [TextAtom "S1", TextAtom "P6", IntegerAtom 100],+      [TextAtom "S2", TextAtom "P1", IntegerAtom 300],+      [TextAtom "S2", TextAtom "P2", IntegerAtom 400],+      [TextAtom "S3", TextAtom "P2", IntegerAtom 200],+      [TextAtom "S4", TextAtom "P2", IntegerAtom 200],+      [TextAtom "S4", TextAtom "P4", IntegerAtom 300],+      [TextAtom "S4", TextAtom "P5", IntegerAtom 400]       ]  productsRel :: Relation@@ -75,13 +75,13 @@     attrs = A.attributesFromList [Attribute "p#" TextAtomType,                                   Attribute "pname" TextAtomType,                                   Attribute "color" TextAtomType,-                                  Attribute "weight" IntAtomType,+                                  Attribute "weight" IntegerAtomType,                                   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"]+      [TextAtom "P1", TextAtom "Nut", TextAtom "Red", IntegerAtom 12, TextAtom "London"],+      [TextAtom "P2", TextAtom "Bolt", TextAtom "Green", IntegerAtom 17, TextAtom "Paris"],+      [TextAtom "P3", TextAtom "Screw", TextAtom "Blue", IntegerAtom 17, TextAtom "Oslo"],+      [TextAtom "P4", TextAtom "Screw", TextAtom "Red", IntegerAtom 14, TextAtom "London"],+      [TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"],+      [TextAtom "P6", TextAtom "Cog", TextAtom "Red", IntegerAtom 19, TextAtom "London"]       ]

@@ -63,7 +63,8 @@                      | FunctionNameInUseError AtomFunctionName                      | FunctionNameNotInUseError AtomFunctionName                      | EmptyCommitError-                     | FunctionArgumentCountMismatch Int Int+                     | FunctionArgumentCountMismatchError Int Int+                     | ConstructedAtomArgumentCountMismatchError Int Int                      | NoSuchDataConstructorError DataConstructorName                      | NoSuchTypeConstructorError TypeConstructorName                      | InvalidAtomTypeName AtomTypeName

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, NamedFieldPuns #-} --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@@ -24,6 +24,16 @@  foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL +type LockFile = Handle++openLockFile :: FilePath -> IO LockFile+openLockFile path = openFile path ReadMode++closeLockFile :: LockFile -> IO ()+closeLockFile file = do+   unlockFile file+   hClose file+ --swiped from System.FileLock package lockFile :: Handle -> LockType -> IO () lockFile handle lock = withHandleToHANDLE handle $ \winHandle -> do@@ -53,33 +63,39 @@       error ("failed to unlock database lock: " ++ show res)  #else+--all of this complicated nonsense is fixed if we switch to GHC 8.2 which includes native flock support on handles import qualified System.Posix.IO as P+import System.Posix.Types+import System.Posix.Files  lockStruct :: P.LockRequest -> P.FileLock lockStruct req = (req, AbsoluteSeek, 0, 0) +newtype LockFile = LockFile Fd++--we cannot use openFile from System.IO because it implements complicated locking which prevents opening the same file twice in write mode in the same process with no way to bypass the check.+openLockFile :: FilePath -> IO LockFile+openLockFile path =+  LockFile <$> P.createFile path ownerWriteMode+  +closeLockFile :: LockFile -> IO ()+closeLockFile l@(LockFile fd) = do+  unlockFile l+  P.closeFd fd+   --blocks on lock, if necessary-lockFile :: Handle -> LockType -> IO ()    -lockFile file lock = do-  fd <- P.handleToFd file+lockFile :: LockFile -> LockType -> IO ()    +lockFile (LockFile fd) lock = do   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+unlockFile :: LockFile -> IO ()  +unlockFile (LockFile fd) =    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--}   

@@ -9,8 +9,8 @@ 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+    notificationFilter (Notification chExpr _ _) = let oldChangeEval = evalChangeExpr chExpr (RelationalExprStateElems context1)+                                                       newChangeEval = evalChangeExpr chExpr (RelationalExprStateElems context2) in                                                  oldChangeEval /= newChangeEval && isRight oldChangeEval     evalChangeExpr chExpr = runReader (evalRelationalExpr chExpr) 

@@ -319,3 +319,7 @@   newTupSet <- shuffleM (asList tupSet)   pure (Relation attrs (RelationTupleSet newTupSet)) +-- returns a tuple from the tupleset- this is useful for priming folds over the tuples+oneTuple :: Relation -> Maybe RelationTuple+oneTuple (Relation _ (RelationTupleSet [])) = Nothing+oneTuple (Relation _ (RelationTupleSet (x:_))) = Just x

@@ -1,21 +1,26 @@ module ProjectM36.Relation.Parse.CSV where --parse Relations from CSV+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.Relation+import ProjectM36.AtomType+import qualified ProjectM36.Attribute as A+ import Data.Csv.Parser import qualified Data.Vector as V-import Data.Char (ord)+import Data.Char (ord, isUpper, isSpace) 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.HashMap.Lazy as HM import qualified Data.List as L import qualified Data.Text as T-import Data.Attoparsec.ByteString.Lazy-import ProjectM36.Atom+import qualified Data.Attoparsec.ByteString.Lazy as APBL+import qualified Data.Attoparsec.Text as APT import Control.Arrow+import Text.Read hiding (parens)+import Control.Applicative+import Data.Either  data CsvImportError = CsvParseError String |                       AttributeMappingError RelationalError |@@ -25,25 +30,23 @@ 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+csvAsRelation :: Attributes -> TypeConstructorMapping -> BS.ByteString -> Either CsvImportError Relation+csvAsRelation attrs tConsMap inString = case APBL.parse (csvWithHeader csvDecodeOptions) inString of+  APBL.Fail _ _ err -> Left (CsvParseError err)+  APBL.Done _ (headerRaw,vecMapsRaw) -> do     let strHeader = V.map decodeUtf8 headerRaw         strMapRecords = V.map convertMap vecMapsRaw         convertMap hmap = HM.fromList $ L.map (decodeUtf8 *** (T.unpack . decodeUtf8)) (HM.toList hmap)         attrNames = V.map A.attributeName attrs         attrNameSet = S.fromList (V.toList attrNames)         headerSet = S.fromList (V.toList strHeader)+        parseAtom attrName aType textIn = case APT.parseOnly (parseCSVAtomP attrName tConsMap aType <* APT.endOfInput) textIn of+          Left err -> Left (ParseError (T.pack err))+          Right eAtom -> eAtom          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+        makeTupleList tupMap = V.toList $ V.map (\attr -> +                                                  either (Left . AttributeMappingError) Right $ +                                                  parseAtom (A.attributeName attr) (A.atomType attr) (T.pack $ tupMap HM.! A.attributeName attr)) attrs     if attrNameSet == headerSet then do       tupleList <- mapM sequence $ V.toList (V.map makeTupleList strMapRecords)       case mkRelationFromList attrs tupleList of@@ -52,3 +55,103 @@       else       Left $ HeaderAttributeMismatchError (S.difference attrNameSet headerSet) ++parseCSVAtomP :: AttributeName -> TypeConstructorMapping -> AtomType -> APT.Parser (Either RelationalError Atom)+parseCSVAtomP _ _ IntegerAtomType = (Right . IntegerAtom) <$> APT.decimal+parseCSVAtomP _ _ IntAtomType = Right . IntAtom <$> APT.decimal+parseCSVAtomP _ _ DoubleAtomType = Right . DoubleAtom <$> APT.double+parseCSVAtomP _ _ TextAtomType = do +  s <- quotedString <|> takeToEndOfData+  pure (Right (TextAtom s))+parseCSVAtomP _ _ DayAtomType = do+  dString <- T.unpack <$> takeToEndOfData+  case readMaybe dString of+    Nothing -> fail ("invalid Day string: " ++ dString)+    Just date -> pure (Right (DayAtom date))+parseCSVAtomP _ _ DateTimeAtomType = do    +  dString <- T.unpack <$> takeToEndOfData+  case readMaybe dString of+    Nothing -> fail ("invalid Date string: " ++ dString)+    Just date -> pure (Right (DateTimeAtom date))+parseCSVAtomP _ _ ByteStringAtomType = do    +  bsString <- T.unpack <$> takeToEndOfData+  case readMaybe bsString of+    Nothing -> fail ("invalid ByteString string: " ++ bsString)+    Just bs -> pure (Right (ByteStringAtom bs))+parseCSVAtomP _ _ BoolAtomType = do    +  bString <- T.unpack <$> takeToEndOfData+  case readMaybe bString of+    Nothing -> fail ("invalid BoolAtom string: " ++ bString)+    Just b -> pure (Right (BoolAtom b))+parseCSVAtomP attrName tConsMap (IntervalAtomType iType) = do+  begin <- (APT.char '[' >> pure False) <|> (APT.char '(' >> pure True)+  eBeginv <- parseCSVAtomP attrName tConsMap iType+  case eBeginv of+    Left err -> pure (Left err)+    Right beginv -> do+      _ <- APT.char ','+      eEndv <- parseCSVAtomP attrName tConsMap iType+      case eEndv of+        Left err -> pure (Left err)+        Right endv -> do+          end <- (APT.char ']' >> pure False) <|> (APT.char ')' >> pure True)+          pure (Right (IntervalAtom beginv endv begin end))+parseCSVAtomP attrName tConsMap typ@(ConstructedAtomType _ tvmap) = do+  dConsName <- capitalizedIdentifier+  APT.skipSpace+  --we need to look up the name right away in order to determine the types of the following arguments+  -- grab the data constructor+  case findDataConstructor dConsName tConsMap of+    Nothing -> pure (Left (NoSuchDataConstructorError dConsName))+    Just (_, dConsDef) -> +      -- identify the data constructor's expected atom type args+      case resolvedAtomTypesForDataConstructorDefArgs tConsMap tvmap dConsDef of+        Left err -> pure (Left err)+        Right argAtomTypes -> do+              atomArgs <- mapM (\argTyp -> let parseNextAtom = parseCSVAtomP attrName tConsMap argTyp <* APT.skipSpace in+                                 case argTyp of+                                   ConstructedAtomType _ _ -> +                                     parens parseNextAtom <|>+                                     parseNextAtom+                                   _ -> parseNextAtom+                               ) argAtomTypes+              case lefts atomArgs of+                [] -> pure (Right (ConstructedAtom dConsName typ (rights atomArgs)))+                errs -> pure (Left (someErrors errs))+parseCSVAtomP attrName _ (RelationAtomType _) = pure (Left (RelationValuedAttributesNotSupportedError [attrName]))+parseCSVAtomP _ _ (TypeVariableType x) = pure (Left (TypeConstructorTypeVarMissing x))+      +capitalizedIdentifier :: APT.Parser T.Text+capitalizedIdentifier = do+  fletter <- APT.satisfy isUpper APT.<?> "capitalized data constructor letter"+  rest <- APT.takeWhile (\c -> not (isSpace c || c == ')')) APT.<?> "data constructor name"+  pure (fletter `T.cons` rest)+  +--read data for Text.Read parser but be wary of end of interval blocks  +takeToEndOfData :: APT.Parser T.Text+takeToEndOfData = APT.takeWhile (APT.notInClass ",)]")+  +parens :: APT.Parser a -> APT.Parser a  +parens p = do+  APT.skip (== '(')+  APT.skipSpace+  v <- p+  APT.skipSpace+  APT.skip (== ')')+  pure v+  +quotedString :: APT.Parser T.Text+quotedString = do+  let escapeMap = [('"','"'), ('n', '\n'), ('r', '\r')]+  APT.skip (== '"')+  (_, s) <- APT.runScanner [] (\prevl nextChar -> case prevl of+                             [] -> Just [nextChar]+                             chars | last chars == '\\' ->+                                        case lookup nextChar escapeMap of +                                          Nothing -> Just (chars ++ [nextChar]) --there is no escape sequence, so leave backslash + char+                                          Just escapeVal -> Just (init chars ++ [escapeVal]) -- nuke the backslash and add the escapeVal+                                   | nextChar == '"' -> Nothing+                                   | otherwise -> Just (chars ++ [nextChar]))+  APT.skip (== '"')+  pure (T.pack s)+  

@@ -8,7 +8,6 @@ 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@@ -42,7 +41,6 @@ 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 

@@ -23,8 +23,8 @@  --plotRelation :: Relation -> Either PlotError -intFromAtomIndex :: Int -> RelationTuple -> Int-intFromAtomIndex index tup = castInt $ tupleAtoms tup V.! index+intFromAtomIndex :: Int -> RelationTuple -> Int --warning- clips or overflows Integer -> Int+intFromAtomIndex index tup = fromIntegral $ castInt $ tupleAtoms tup V.! index  graph1DRelation :: Relation -> Plot2D.T Int Int graph1DRelation rel = Plot2D.list Graph2D.listPoints $ points1DRelation rel

@@ -366,7 +366,7 @@     return Nothing      -- | Add a notification which will send the resultExpr when triggerExpr changes between commits.-evalDatabaseContextExpr (AddNotification notName triggerExpr resultExpr) = do+evalDatabaseContextExpr (AddNotification notName triggerExpr resultOldExpr resultNewExpr) = do   currentContext <- getStateContext   let nots = notifications currentContext   if M.member notName nots then@@ -374,7 +374,8 @@     else do       let newNotifications = M.insert notName newNotification nots           newNotification = Notification { changeExpr = triggerExpr,-                                           reportExpr = resultExpr }+                                           reportOldExpr = resultOldExpr, +                                           reportNewExpr = resultNewExpr}       putStateContext $ currentContext { notifications = newNotifications }       return Nothing   @@ -399,7 +400,7 @@     errs@(_:_) -> pure $ Just (someErrors errs)     [] | T.null tConsName || not (isUpper (T.head tConsName)) -> pure $ Just (InvalidAtomTypeName tConsName)        | isJust (findTypeConstructor tConsName oldTypes) -> pure $ Just (AtomTypeNameInUseError tConsName)-       | otherwise -> do              +       | otherwise -> do       let newTypes = oldTypes ++ [(tConsDef, dConsDefList)]       putStateContext $ currentContext { typeConstructorMapping = newTypes }       pure Nothing@@ -460,7 +461,7 @@         let expectedArgCount = length (dbcFuncType func)             actualArgCount = length atomArgExprs         if expectedArgCount /= actualArgCount then-          pure (Just (FunctionArgumentCountMismatch expectedArgCount actualArgCount))+          pure (Just (FunctionArgumentCountMismatchError expectedArgCount actualArgCount))           else            --check that the atom types are valid           case lefts eAtomTypes of@@ -497,7 +498,7 @@             pure $ case eCompiledFunc of               Left err -> Left (ScriptError err)               Right compiledFunc -> do-                funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext)) adjustedAtomTypeCons+                funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) adjustedAtomTypeCons                 let updatedFuncs = HS.insert newAtomFunc atomFuncs                     newContext = currentContext { atomFunctions = updatedFuncs }                     newAtomFunc = AtomFunction { atomFuncName = funcName,@@ -534,7 +535,7 @@             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+              funcAtomType <- mapM (\funcTypeArg -> atomTypeForTypeConstructor funcTypeArg (typeConstructorMapping currentContext) M.empty) atomArgs               let updatedDBCFuncs = HS.insert newDBCFunc (dbcFunctions currentContext)                   newContext = currentContext { dbcFunctions = updatedDBCFuncs }                   dbcFuncs = dbcFunctions currentContext@@ -735,7 +736,7 @@         safeInit [] = [] -- different behavior from normal init         safeInit (_:xs) = safeInit xs     if expectedArgCount /= actualArgCount then-      throwE (FunctionArgumentCountMismatch expectedArgCount actualArgCount)+      throwE (FunctionArgumentCountMismatchError expectedArgCount actualArgCount)       else do       _ <- mapM (\(expType, actType) -> either throwE pure (atomTypeVerify expType actType)) (safeInit (zip (atomFuncType func) argTypes))       evaldArgs <- mapM (liftE . evalAtomExpr tupIn) arguments@@ -766,13 +767,13 @@     Right aType -> pure (Right aType)     Left err@(NoSuchAttributeNamesError _) -> case rstate of         RelationalExprStateAttrsElems _ attrs' -> case A.attributeForName attrName attrs' of-          Left err' -> pure (error "SPAMMO2" $ Left err')+          Left err' -> pure (Left err')           Right attr -> pure (Right (A.atomType attr))-        RelationalExprStateElems _ -> pure (error (show attrs) $ Left err)+        RelationalExprStateElems _ -> pure (Left err)         RelationalExprStateTupleElems _ tup -> case atomForAttributeName attrName tup of-          Left err' -> pure (error "STAMP" $ Left err')+          Left err' -> pure (Left err')           Right atom -> pure (Right (atomTypeForAtom atom))-    Left err -> pure (error "GONK" $ Left err)+    Left err -> pure (Left err) typeFromAtomExpr _ (NakedAtomExpr atom) = pure (Right (atomTypeForAtom atom)) typeFromAtomExpr attrs (FunctionAtomExpr funcName atomArgs _) = do   context <- fmap stateElemsContext ask@@ -808,12 +809,12 @@ verifyAtomExprTypes relIn (AttributeAtomExpr attrName) expectedType = runExceptT $ do   rstate <- lift ask   case A.atomTypeForAttributeName attrName (attributes relIn) of-    Right aType -> pure aType+    Right aType -> either throwE pure (atomTypeVerify expectedType aType)     (Left err@(NoSuchAttributeNamesError _)) -> case rstate of       RelationalExprStateTupleElems _ _ -> throwE err       RelationalExprStateElems _ -> throwE err       RelationalExprStateAttrsElems _ attrs -> case A.attributeForName attrName attrs of-        Left err' -> throwE (error "GONK" err')+        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))@@ -844,7 +845,7 @@ -- | 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+  aType <- atomTypeForTypeConstructor tCons aTypes M.empty   Right (Attribute attrName aType)    evalAttrExpr _ (NakedAttributeExpr attr) = Right attr

@@ -42,6 +42,7 @@      handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),      handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),      handleCall (\conn (ExecuteAutoMergeToHead sessionId strat headName') -> handleExecuteAutoMergeToHead ti sessionId conn strat headName'),+     handleCall (\conn (RetrieveTypeConstructorMapping sessionId) -> handleRetrieveTypeConstructorMapping ti sessionId conn),      handleCall (\conn Logout -> handleLogout ti conn)      ] ++ testModeHandlers,   unhandledMessagePolicy = Terminate

@@ -1,7 +1,7 @@ module ProjectM36.Server.EntryPoints where import ProjectM36.Base hiding (inclusionDependencies) import ProjectM36.IsomorphicSchema-import ProjectM36.Client+import ProjectM36.Client as C import ProjectM36.Error import Control.Distributed.Process (Process, ProcessId) import Control.Distributed.Process.ManagedProcess (ProcessReply)@@ -150,5 +150,8 @@   ret <- timeoutOrDie ti (autoMergeToHead sessionId conn strat headName')   reply ret conn -  +handleRetrieveTypeConstructorMapping :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError TypeConstructorMapping)  +handleRetrieveTypeConstructorMapping ti sessionId conn = do+  ret <- timeoutOrDie ti (C.typeConstructorMapping sessionId conn)+  reply ret conn  

@@ -60,3 +60,5 @@                             deriving (Binary, Generic) data ExecuteAutoMergeToHead = ExecuteAutoMergeToHead SessionId MergeStrategy HeadName                               deriving (Binary, Generic)+data RetrieveTypeConstructorMapping = RetrieveTypeConstructorMapping SessionId +                                      deriving (Binary, Generic)

@@ -148,16 +148,13 @@  applyStaticDatabaseOptimization (RemoveInclusionDependency name) = return $ Right (RemoveInclusionDependency name) -applyStaticDatabaseOptimization (AddNotification name triggerExpr resultExpr) = do+applyStaticDatabaseOptimization (AddNotification name triggerExpr resultOldExpr resultNewExpr) = 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))+         Right triggerExprOpt -> --it doesn't make sense to optimize queries when we don't have their proper contexts+           pure (Right (AddNotification name triggerExprOpt resultOldExpr resultNewExpr))  applyStaticDatabaseOptimization notif@(RemoveNotification _) = pure (Right notif) 

@@ -149,6 +149,6 @@ evalTransGraphAttributeExpr :: TransactionGraph -> TransGraphAttributeExpr -> Either RelationalError AttributeExpr evalTransGraphAttributeExpr graph (AttributeAndTypeNameExpr attrName tCons tLookup) = do   trans <- lookupTransaction graph tLookup-  aType <- atomTypeForTypeConstructor tCons (typeConstructorMapping (concreteDatabaseContext trans))+  aType <- atomTypeForTypeConstructor tCons (typeConstructorMapping (concreteDatabaseContext trans)) M.empty   pure (NakedAttributeExpr (Attribute attrName aType)) evalTransGraphAttributeExpr _ (NakedAttributeExpr attr) = pure (NakedAttributeExpr attr)  

@@ -8,7 +8,7 @@ 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 qualified Data.ByteString as BS import System.FilePath import System.Directory import qualified Data.Text as T@@ -18,6 +18,9 @@ import Control.Exception import GHC import GHC.Paths+import Codec.Compression.GZip+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL  getDirectoryNames :: FilePath -> IO [FilePath] getDirectoryNames path = do@@ -39,8 +42,8 @@ incDepsDir :: FilePath -> FilePath incDepsDir transdir = transdir </> "incdeps" -atomFuncsDir :: FilePath -> FilePath-atomFuncsDir transdir = transdir </> "atomfuncs"+atomFuncsPath :: FilePath -> FilePath+atomFuncsPath transdir = transdir </> "atomfuncs"  dbcFuncsDir :: FilePath -> FilePath dbcFuncsDir transdir = transdir </> "dbcfuncs"@@ -59,7 +62,7 @@     return $ Left $ MissingTransactionError transId     else do     relvars <- readRelVars transDir-    transInfo <- B.decode <$> BS.readFile (transactionInfoPath transDir)+    transInfo <- B.decodeFile (transactionInfoPath transDir)     incDeps <- readIncDeps transDir     typeCons <- readTypeConstructorMapping transDir     sschemas <- readSubschemas transDir@@ -82,14 +85,14 @@   transDirExists <- doesDirectoryExist finalTransDir   unless transDirExists $ do     --create sub directories-    mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir tempTransDir, atomFuncsDir tempTransDir, dbcFuncsDir tempTransDir]+    mapM_ createDirectory [tempTransDir, relvarsDir tempTransDir, incDepsDir 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)+    B.encodeFile (transactionInfoPath tempTransDir) (transactionInfo trans)     --move the temp directory to final location     renameSync sync tempTransDir finalTransDir   pure ()@@ -97,43 +100,62 @@ 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)+  writeBSFileSync sync relvarPath (compress (B.encode rel))    writeRelVars :: DiskSync -> FilePath -> M.Map RelVarName Relation -> IO () writeRelVars sync transDir relvars = mapM_ (writeRelVar sync transDir) $ M.toList relvars-    + readRelVars :: FilePath -> IO (M.Map RelVarName Relation) readRelVars transDir = do   let relvarsPath = relvarsDir transDir   relvarNames <- getDirectoryNames relvarsPath   relvars <- mapM (\name -> do-                      rel <- B.decode <$> BS.readFile (relvarsPath </> name)+                      rel <- B.decode . decompress . BSL.fromStrict <$> 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+writeAtomFuncs sync transDir funcs = do+  let atomFuncPath = atomFuncsPath transDir +  writeBSFileSync sync atomFuncPath (B.encode $ map (\f -> (atomFuncType f, atomFuncName f, atomFunctionScript f)) (HS.toList funcs)) ---all the atom functions are in one file (???)+--all the atom functions are in one file readAtomFuncs :: FilePath -> Maybe ScriptSession -> IO AtomFunctions readAtomFuncs transDir mScriptSession = do-  funcNames <- getDirectoryNames (atomFuncsDir transDir)+  atomFuncsList <- B.decodeFile (atomFuncsPath transDir)   --only Haskell script functions can be serialized   --we always return the pre-compiled functions-  funcs <- mapM ((\name -> readAtomFunc transDir name mScriptSession precompiledAtomFunctions) . T.pack) funcNames+  funcs <- mapM (\(funcType, funcName, mFuncScript) -> loadAtomFunc precompiledAtomFunctions mScriptSession funcName funcType mFuncScript) atomFuncsList   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))-  +loadAtomFunc :: AtomFunctions -> Maybe ScriptSession -> AtomFunctionName -> [AtomType] -> Maybe AtomFunctionBodyScript -> IO AtomFunction+loadAtomFunc precompiledFuncs mScriptSession funcName funcType mFuncScript = case mFuncScript of+    --handle pre-compiled case- pull it from the precompiled list+    Nothing -> case atomFunctionForName funcName precompiledFuncs of+      --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored+      Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)+      Right realFunc -> pure realFunc+    --handle a real Haskell scripted function- compile and load+    Just funcScript -> +      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 }+ --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) <- B.decode <$> BS.readFile atomFuncPath+  let atomFuncPath = atomFuncsPath transDir+  (funcType, mFuncScript) <- B.decodeFile atomFuncPath   case mFuncScript of     --handle pre-compiled case- pull it from the precompiled list     Nothing -> case atomFunctionForName funcName precompiledFuncs of@@ -155,6 +177,7 @@                                                          atomFuncType = funcType,                                                          atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript } + writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO () writeDBCFuncs sync transDir funcs = mapM_ (writeDBCFunc sync transDir) (HS.toList funcs)   @@ -174,7 +197,7 @@ readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction   readDBCFunc transDir funcName mScriptSession precompiledFuncs = do   let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName-  (funcType, mFuncScript) <- B.decode <$> BS.readFile dbcFuncPath+  (funcType, mFuncScript) <- B.decodeFile dbcFuncPath   case mFuncScript of     Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of       Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)@@ -202,8 +225,8 @@ readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency) readIncDep transDir incdepName = do   let incDepPath = incDepsDir transDir </> T.unpack incdepName-  incDepData <- BS.readFile incDepPath-  pure (incdepName, B.decode incDepData)+  incDepData <- B.decodeFile incDepPath+  pure (incdepName, incDepData)    readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)   readIncDeps transDir = do@@ -215,8 +238,7 @@ readSubschemas :: FilePath -> IO Subschemas   readSubschemas transDir = do   let sschemasPath = subschemasPath transDir-  bytes <- BS.readFile sschemasPath-  pure (B.decode bytes)+  B.decodeFile sschemasPath    writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()   writeSubschemas sync transDir sschemas = do@@ -230,6 +252,6 @@ readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping readTypeConstructorMapping path = do   let atPath = typeConsPath path-  B.decode <$> BS.readFile atPath+  B.decodeFile atPath      

@@ -26,7 +26,7 @@ import Data.Maybe  {--import Debug.Trace+--import Debug.Trace import Control.Monad.Reader import qualified ProjectM36.DisconnectedTransaction as D -}

@@ -10,7 +10,6 @@ import System.Directory import System.FilePath import System.IO.Temp-import System.IO import Data.Time.Clock.POSIX import qualified Data.UUID as U import qualified Data.Set as S@@ -41,7 +40,7 @@ -}  expectedVersion :: Int-expectedVersion = 2+expectedVersion = 5  transactionLogFileName :: FilePath  transactionLogFileName = "m36v" ++ show expectedVersion@@ -71,7 +70,7 @@      pure (Right ())   -setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (Handle, LockFileHash))+setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (LockFile, LockFileHash)) setupDatabaseDir sync dbdir bootstrapGraph = do   dbdirExists <- doesDirectoryExist dbdir   eWrongVersion <- checkForOtherVersions dbdir@@ -81,9 +80,9 @@       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))+        locker <- openLockFile (lockFilePath dbdir)+        gDigest <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (readGraphTransactionIdFileDigest dbdir)+        pure (Right (locker, gDigest))       else if not m36exists then do         locks <- bootstrapDatabaseDir sync dbdir bootstrapGraph         pure (Right locks)@@ -92,19 +91,14 @@ {-  initialize a database directory with the graph from which to bootstrap- return lock file handle -}-bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Handle, LockFileHash)+bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (LockFile, LockFileHash) bootstrapDatabaseDir sync dbdir bootstrapGraph = do   createDirectory dbdir-  lockFileH <- openLockFile dbdir+  locker <- openLockFile (lockFilePath dbdir)   let allTransIds = map transactionId (S.toList (transactionsForGraph bootstrapGraph))-  digest  <- bracket_ (lockFile lockFileH WriteLock) (unlockFile lockFileH) (transactionGraphPersist sync dbdir allTransIds bootstrapGraph)-  pure (lockFileH, digest)+  digest  <- bracket_ (lockFile locker WriteLock) (unlockFile locker) (transactionGraphPersist sync dbdir allTransIds bootstrapGraph)+  pure (locker, digest)   -openLockFile :: FilePath -> IO Handle-openLockFile dbdir = do-  lockFileH <- openFile (lockFilePath dbdir) WriteMode-  pure lockFileH- {-  incrementally updates an existing database directory --algorithm: 

@@ -2,8 +2,8 @@ module ProjectM36.Tupleable where import ProjectM36.Base import ProjectM36.Error-import ProjectM36.Tuple import ProjectM36.TupleSet+import ProjectM36.Tuple import ProjectM36.Atomable import ProjectM36.DataTypes.Primitive import ProjectM36.Attribute hiding (null)@@ -11,9 +11,12 @@ import qualified Data.Vector as V import qualified Data.Text as T import Data.Monoid+import Data.Proxy import Data.Foldable -{-+{-import Data.Binary+import Control.DeepSeq+ data Test1T = Test1C {   attrA :: Int   }@@ -32,31 +35,38 @@ data TestUnnamed1 = TestUnnamed1 Int Double T.Text                     deriving (Show,Eq, Generic)                              -instance Tupleable TestUnnamed1          +instance Tupleable TestUnnamed1 ++data Test7A = Test7AC Integer+            deriving (Generic, Show, Eq, Atomable, NFData, Binary)+                       +                       +data Test7T = Test7C Test7A                       +              deriving (Generic, Show, Eq)++instance Tupleable Test7T -}  -- | Convert a 'Traverseable' of 'Tupleable's to an 'Insert' 'DatabaseContextExpr'. This is useful for converting, for example, a list of data values to a set of Insert expressions which can be used to add the values to the database.-toInsertExpr :: (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr+toInsertExpr :: forall a t. (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr toInsertExpr vals rvName = do-  let attrs = toAttributes (head (toList vals))+  let attrs = toAttributes (Proxy :: Proxy a)   tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)   let rel = MakeStaticRelation attrs tuples      pure (Insert rvName rel)   --- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'undefined'.-toDefineExpr :: Tupleable a => a -> RelVarName -> DatabaseContextExpr-toDefineExpr val rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))+-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'Data.Proxy'.+toDefineExpr :: forall a proxy. Tupleable a => proxy a -> RelVarName -> DatabaseContextExpr+toDefineExpr _ rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))   where -    attrs = toAttributes val--  +    attrs = toAttributes (Proxy :: Proxy a)  class Tupleable a where   toTuple :: a -> RelationTuple      fromTuple :: RelationTuple -> Either RelationalError a   -  toAttributes :: a -> Attributes+  toAttributes :: proxy a -> Attributes    default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple   toTuple v = toTupleG (from v)@@ -64,8 +74,8 @@   default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a   fromTuple tup = to <$> fromTupleG tup     -  default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes-  toAttributes v = toAttributesG (from v)+  default toAttributes :: (Generic a, TupleableG (Rep a)) => proxy a -> Attributes+  toAttributes _ = toAttributesG (from (undefined :: a))    class TupleableG g where     toTupleG :: g a -> RelationTuple

@@ -7,7 +7,6 @@ import System.FilePath import ProjectM36.TupleSet import ProjectM36.Attribute-import ProjectM36.Error import qualified Data.Vector as V  main :: IO ()           

@@ -1,7 +1,6 @@ --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

@@ -12,28 +12,35 @@ import Data.Time.Calendar (fromGregorian) import Data.Text import qualified Data.Map as M+import Data.Proxy  {-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}-data Test1T = Test1C Int+data Test1T = Test1C Integer             deriving (Generic, Show, Eq, Binary, NFData, Atomable)                      data Test2T x = Test2C x               deriving (Show, Generic, Eq, Binary, NFData, Atomable)                        -data Test3T = Test3C Int Int                        +data Test3T = Test3C Integer Integer                                       deriving (Show, Generic, Eq, Binary, NFData, Atomable)                        -data Test4T = Test4Ca Int |                       -              Test4Cb Int +data Test4T = Test4Ca Integer |                       +              Test4Cb Integer                deriving (Show, Generic, Eq, Binary, NFData, Atomable)                        -data TestListT = TestListC [Int]+data TestListT = TestListC [Integer]               deriving (Show, Generic, Eq, Binary, NFData, Atomable)                         data Test5T = Test5C {-  con1 :: Int,-  con2 :: Int+  con1 :: Integer,+  con2 :: Integer   } deriving (Show, Generic, Eq, Binary, NFData, Atomable)+             +data Test6T = Test6C (Maybe Integer)             +            deriving (Show, Generic, Eq, Binary, NFData, Atomable)++data Test7T = Test7C (Either Integer Integer)+            deriving (Show, Generic, Eq, Binary, NFData, Atomable)                         main :: IO () main = do@@ -41,13 +48,13 @@   if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess  testList :: Test-testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance]+testList = TestList [testHaskell2DB, testADT1, testADT2, testADT3, testADT4, testADT5, testBasicMarshaling, testListInstance, testADT6Maybe, testADT7Either]  -- 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 IntAtom" (IntegerAtom 5) (toAtom (5 :: Integer))+    assertEqual "from IntAtom" (5 :: Integer) (fromAtom (IntegerAtom 5))      assertEqual "to BoolAtom" (BoolAtom False) (toAtom False)     assertEqual "from BoolAtom" False (fromAtom (BoolAtom False))@@ -61,8 +68,8 @@ testHaskell2DB = TestCase $ do   --validate generated database context expression   (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback-  let test1TExpr = toAddTypeExpr (undefined :: Test1T)-      expectedTest1TExpr = AddTypeConstructor (ADTypeConstructorDef "Test1T" []) [DataConstructorDef "Test1C" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Int" IntAtomType)]]+  let test1TExpr = toAddTypeExpr (Proxy :: Proxy Test1T)+      expectedTest1TExpr = AddTypeConstructor (ADTypeConstructorDef "Test1T" []) [DataConstructorDef "Test1C" [DataConstructorDefTypeConstructorArg (PrimitiveTypeConstructor "Integer" IntegerAtomType)]]   assertEqual "simple ADT1" expectedTest1TExpr test1TExpr   checkExecuteDatabaseContextExpr sessionId dbconn test1TExpr   --execute some expressions involving Atomable data types@@ -77,7 +84,7 @@      let retrieveValExpr = Restrict (AttributeEqualityPredicate "a1" (NakedAtomExpr atomVal)) (RelationVariable "x" ())   ret <- executeRelationalExpr sessionId dbconn retrieveValExpr-  let expectedRel = mkRelationFromList (attributesFromList [Attribute "a1" (toAtomType exampleVal)]) [[atomVal]]+  let expectedRel = mkRelationFromList (attributesFromList [Attribute "a1" (toAtomType (Proxy :: Proxy Test1T))]) [[atomVal]]   assertEqual "retrieve atomable atom" expectedRel ret    testADT1 :: Test@@ -107,6 +114,16 @@ testADT5 = TestCase $ do   let example = Test5C {con1=3, con2=4}   assertEqual "record-based ADT" example (fromAtom (toAtom example))  +  +testADT6Maybe :: Test  +testADT6Maybe = TestCase $ do+  let example = Test6C (Just 4)+  assertEqual "maybe type" example (fromAtom (toAtom example))+  +testADT7Either :: Test +testADT7Either = TestCase $ do+  let example = Test7C (Right 10)+  assertEqual "either type" example (fromAtom (toAtom example))    checkExecuteDatabaseContextExpr :: SessionId -> Connection -> DatabaseContextExpr -> IO () checkExecuteDatabaseContextExpr sessionId dbconn expr = executeDatabaseContextExpr sessionId dbconn expr >>= either (assertFailure . show) (const (pure ()))

@@ -1,32 +1,94 @@-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+import ProjectM36.DataTypes.Basic+import ProjectM36.DataTypes.List+import ProjectM36.DataTypes.Interval +import System.Exit+import Test.HUnit+import Data.Time.Calendar+import Data.Time.Clock+import Data.Monoid+{-+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TE+import ProjectM36.Relation.Show.Term+import qualified Data.ByteString.Lazy as BS+-}+ main :: IO ()            main = do -  tcounts <- runTestTT $ TestList [testCSVExport]+  tcounts <- runTestTT $ TestList [testCSVExport, +                                   testADTExport]   if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess ---round-trip a basic relation through CSV+assertEither :: (Show a) => IO (Either a b) -> IO b+assertEither x = do+  res <- x+  case res of+    Left err -> assertFailure (show err) >> undefined+    Right val -> pure val+    +testADTExport :: Test    +testADTExport = TestCase $ do+  let adtCSV = "a\nCons 4 (Cons 5 Empty)\n"+      attrs = A.attributesFromList [Attribute "a" (listAtomType IntegerAtomType)]+      expectedRel = mkRelationFromList attrs [[listCons IntegerAtomType [IntegerAtom 4, IntegerAtom 5]]]+  case csvAsRelation attrs basicTypeConstructorMapping adtCSV of+    Left err -> assertFailure ("import failure: " <> show err)+    Right rel -> assertEqual "import cons list" expectedRel (Right rel)+    +--round-trip various atom types through CSV export/import testCSVExport :: Test testCSVExport = TestCase $ do-  let attrs = A.attributesFromList [Attribute "S#" TextAtomType, -                                    Attribute "SNAME" TextAtomType, -                                    Attribute "STATUS" IntAtomType, -                                    Attribute "CITY" TextAtomType]+  now <- getCurrentTime+  testInterval <- assertEither $ pure (createInterval +                                (DateTimeAtom now) +                                (DateTimeAtom (addUTCTime 86400 now))+                                True+                                False)+  let attrs = A.attributesFromList [Attribute "textattr" TextAtomType, +                                    Attribute "integerattr" IntegerAtomType,+                                    Attribute "dayattr" DayAtomType,+                                    Attribute "datetimeattr" DateTimeAtomType,+                                    Attribute "bytestringattr" ByteStringAtomType,+                                    Attribute "listintegerattr" (listAtomType IntegerAtomType),+                                    Attribute "listtextattr" (listAtomType TextAtomType),+                                    Attribute "intervalattr" (IntervalAtomType DateTimeAtomType)+                                   ]+      sampleByteString = "\1\0\244\34\150"       relOrErr = mkRelationFromList attrs [-        [TextAtom "S9", TextAtom "Perry", IntAtom 170, TextAtom "Londonderry"],-        [TextAtom "S8", TextAtom "Mike", IntAtom 150, TextAtom "Boston"]]+        [TextAtom "text atom with \"quote\"", +         IntegerAtom 123, +         DayAtom (fromGregorian 2017 4 10),+         DateTimeAtom now,+         ByteStringAtom sampleByteString,+         listCons IntegerAtomType [IntegerAtom 5, IntegerAtom 6, IntegerAtom 7],+         listCons TextAtomType [TextAtom "text1", TextAtom "text2"],+         testInterval+         ],+        [TextAtom "second text atom", +         IntegerAtom 314, +         DayAtom (fromGregorian 1001 6 28),+         DateTimeAtom (addUTCTime 360 now),+         ByteStringAtom sampleByteString,         +         listCons IntegerAtomType [IntegerAtom 10, IntegerAtom 11, IntegerAtom 12],+         listCons TextAtomType [TextAtom "text5\"", TextAtom "text6\r\n"],+         testInterval+        ]]+           case relOrErr of      Left err -> assertFailure $ "export relation creation failure: " ++ show err     Right rel ->        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'+        Right csvData -> +          --BS.writeFile "/tmp/csv" csvData+          --putStrLn (TL.unpack (TE.decodeUtf8 csvData))+          case csvAsRelation attrs basicTypeConstructorMapping csvData of -- import csv data back to relation+            Left err -> assertFailure $ "re-import failed: " ++ show err+            Right rel' -> assertEqual "relation CSV comparison" rel rel' 

@@ -3,6 +3,8 @@ import ProjectM36.Relation.Parse.CSV import ProjectM36.Relation import qualified ProjectM36.Attribute as A+import ProjectM36.DataTypes.Basic+ import System.Exit import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding@@ -23,7 +25,7 @@       expectedRel = mkRelationFromList expectedAttrs [         [TextAtom "S9", TextAtom "Perry", IntAtom 170, TextAtom "Londonderry"],         [TextAtom "S8", TextAtom "Mike", IntAtom 150, TextAtom "Boston"]]-  case csvAsRelation sampleCSV expectedAttrs of+  case csvAsRelation expectedAttrs basicTypeConstructorMapping sampleCSV of     Left err -> assertFailure $ show err     Right csvRel -> assertEqual "csv->relation" expectedRel (Right csvRel) 

@@ -11,34 +11,35 @@ import qualified Data.Map as M import qualified Data.Text as T import System.Exit+import Data.Proxy  {-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}  data Test1T = Test1C {-  attrA :: Int+  attrA :: Integer   }   deriving (Generic, Eq, Show)             data Test2T = Test2C {-  attrB :: Int,-  attrC :: Int+  attrB :: Integer,+  attrC :: Integer   }   deriving (Generic, Eq, Show)            -data Test3T = Test3C Int            +data Test3T = Test3C Integer                         deriving (Generic, Eq, Show)                       data Test4T = Test4C                                    deriving (Generic, Eq, Show)                        -data Test5T = Test5C1 Int |                       -              Test5C2 Int+data Test5T = Test5C1 Integer |                       +              Test5C2 Integer               deriving (Generic, Eq, Show)                        -data Test6T = Test6C T.Text Int Double+data Test6T = Test6C T.Text Integer Double               deriving (Generic, Eq, Show)                        -data Test7A = Test7AC Int+data Test7A = Test7AC Integer             deriving (Generic, Show, Eq, Binary, NFData, Atomable)                                                @@ -83,9 +84,9 @@   let example = Test2C { attrB = 4, attrC = 6 }   assertEqual "two record constructor" (Right example) (fromTuple (toTuple example))   --this was a tricky case that was throwing the undefined exception because of insufficient laziness in the :*: matching- see ProjectM36.Tupleable-  let expectedAttributes = attributesFromList [Attribute "attrB" IntAtomType,-                                               Attribute "attrC" IntAtomType]-  assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (undefined :: Test2T))+  let expectedAttributes = attributesFromList [Attribute "attrB" IntegerAtomType,+                                               Attribute "attrC" IntegerAtomType]+  assertEqual "two record constructor toAttributes" expectedAttributes (toAttributes (Proxy :: Proxy Test2T))         testADT3 :: Test@@ -110,7 +111,7 @@   let example = Test7C (Test7AC 3)   assertEqual "atom type" (Right example) (fromTuple (toTuple example))   let expectedAttrs = V.singleton (Attribute "" (ConstructedAtomType "Test7A" M.empty))-  assertEqual "adt atomtype" expectedAttrs (toAttributes (undefined :: Test7T))+  assertEqual "adt atomtype" expectedAttrs (toAttributes (Proxy :: Proxy Test7T))      testADT8 :: Test     testADT8 = TestCase $ assertEqual "single value" (Right example) (fromTuple (toTuple example))

@@ -188,7 +188,7 @@ testNotification mvar sess conn = TestCase $ do   let relvarx = RelationVariable "x" ()   executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail-  executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) >>= eitherFail+  executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx relvarx) >>= eitherFail   commit sess conn >>= eitherFail   executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail   commit sess conn >>= eitherFail

@@ -1,7 +1,6 @@ import Test.HUnit import ProjectM36.Client import ProjectM36.Relation-import ProjectM36.Error import qualified Data.Set as S import TutorialD.Interpreter.TestBase 

@@ -35,17 +35,38 @@   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,testIntervalAtom]+    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,+      testIntervalAtom,+      testListConstructedAtom,+      testTypeChecker+      ]     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])]),+                      ("x:=relation{a Integer}{}", mkRelation simpleAAttributes emptyTupleSet),+                      ("x:=relation{c Integer}{} rename {c as d}", mkRelation simpleBAttributes emptyTupleSet),+                      ("y:=relation{b Integer, c Integer}{}; x:=y{c}", mkRelation simpleProjectionAttributes emptyTupleSet),+                      ("x:=relation{tuple{a \"spam\", b 5}}", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntegerAtom 5])]),                       ("constraint failc true in false; x:=true", Left $ InclusionDependencyCheckError "failc"),                       ("x:=y; x:=true", Left $ RelVarNotDefinedError "y"),                       ("x:=relation{}{}", Right relationFalse),@@ -59,60 +80,60 @@                       ("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]]),+                      ("x:=relation {b Integer, a Text}{}; insert x relation{tuple{b 5, a \"spam\"}}", mkRelationFromTuples simpleCAttributes [RelationTuple simpleCAttributes $ V.fromList [TextAtom "spam", IntegerAtom 5]]),                       -- test nested relation constructor-                      ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [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])])+                      ("x:=relation{tuple{a 5, b relation{tuple{a 6}}}}", mkRelation nestedRelationAttributes $ RelationTupleSet [RelationTuple nestedRelationAttributes (V.fromList [IntegerAtom 5, RelationAtom (Relation simpleAAttributes $ RelationTupleSet [RelationTuple simpleAAttributes $ V.fromList [IntegerAtom 6]])])]),+                      ("x:=relation{tuple{b 5,a \"spam\"},tuple{b 6,a \"sam\"}}; delete x where b=6", mkRelation simpleCAttributes $ RelationTupleSet [RelationTuple simpleCAttributes (V.fromList [TextAtom "spam", IntegerAtom 5])]),+                      ("x:=relation{tuple{a 5}} : {b:=@a}", mkRelation simpleDAttributes $ RelationTupleSet [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 5])]),+                      ("x:=relation{tuple{a 5}} : {b:=6}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 6])]),+                      ("x:=relation{tuple{a 5}} : {b:=add(@a,5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 10])]),+                      ("x:=relation{tuple{a 5}} : {b:=add(@a,\"spam\")}", Left (AtomFunctionTypeError "add" 2 IntegerAtomType TextAtomType)),+                      ("x:=relation{tuple{a 5}} : {b:=add(add(@a,2),5)}", mkRelationFromTuples simpleDAttributes [RelationTuple simpleDAttributes (V.fromList [IntegerAtom 5, IntegerAtom 12])])                      ]-    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]+    simpleAAttributes = A.attributesFromList [Attribute "a" IntegerAtomType]+    simpleBAttributes = A.attributesFromList [Attribute "d" IntegerAtomType]+    simpleCAttributes = A.attributesFromList [Attribute "a" TextAtomType, Attribute "b" IntegerAtomType]+    simpleDAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" IntegerAtomType]     maybeTextAtomType = ConstructedAtomType "Maybe" (M.singleton "a" TextAtomType)-    maybeIntAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntAtomType)+    maybeIntegerAtomType = ConstructedAtomType "Maybe" (M.singleton "a" IntegerAtomType)     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)]+    simpleMaybeIntAttributes = A.attributesFromList [Attribute "a" maybeIntegerAtomType]+    simpleEitherIntTextAttributes = A.attributesFromList [Attribute "a" (eitherAtomType IntegerAtomType TextAtomType)]+    simpleProjectionAttributes = A.attributesFromList [Attribute "c" IntegerAtomType]+    nestedRelationAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" (RelationAtomType $ A.attributesFromList [Attribute "a" IntegerAtomType])]+    extendTestAttributes = A.attributesFromList [Attribute "a" IntegerAtomType, Attribute "b" $ RelationAtomType (attributes suppliersRel)]     byteStringAttributes = A.attributesFromList [Attribute "y" ByteStringAtomType]    -    groupCountAttrs = A.attributesFromList [Attribute "z" IntAtomType]-    minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntAtomType]+    groupCountAttrs = A.attributesFromList [Attribute "z" IntegerAtomType]+    minMaxAttrs = A.attributesFromList [Attribute "s#" TextAtomType, Attribute "z" IntegerAtomType]     updateParisPlus10 = relMap (\tuple -> do                                    statusAtom <- atomForAttributeName "status" tuple                                    cityAtom <- atomForAttributeName "city" tuple                                    if cityAtom == TextAtom "Paris" then-                                     Right $ updateTupleWithAtoms (M.singleton "status" (IntAtom (castInt statusAtom + 10))) tuple+                                     Right $ updateTupleWithAtoms (M.singleton "status" (IntegerAtom (castInteger statusAtom + 10))) tuple                                      else Right tuple) suppliersRel     dateExampleRelTests = [("x:=s where true", Right suppliersRel),                            ("x:=s where city = \"London\"", restrict (\tuple -> pure $ atomForAttributeName "city" tuple == (Right $ TextAtom "London")) suppliersRel),                            ("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"]]),+                           ("x:=p where color=\"Blue\" and city=\"Paris\"", mkRelationFromList (attributes productsRel) [[TextAtom "P5", TextAtom "Cam", TextAtom "Blue", IntegerAtom 12, TextAtom "Paris"]]),+                           ("a:=s; update a (status:=50); x:=a{status}", mkRelation (A.attributesFromList [Attribute "status" IntegerAtomType]) (RelationTupleSet [mkRelationTuple (A.attributesFromList [Attribute "status" IntegerAtomType]) (V.fromList [IntegerAtom 50])])),+                           ("x:=s minus (s where status=20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"], [TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"], [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),                            --atom function tests                            ("x:=((s : {status2 := add(10,@status)}) where status2=add(10,@status)){city,s#,sname,status}", Right suppliersRel),-                           ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntAtom 5, RelationAtom suppliersRel])])),+                           ("x:=relation{tuple{a 5}} : {b:=s}", mkRelation extendTestAttributes (RelationTupleSet [mkRelationTuple extendTestAttributes (V.fromList [IntegerAtom 5, RelationAtom suppliersRel])])),                            ("x:=s; update x where sname=\"Blake\" (city:=\"Boston\")", relMap (\tuple -> if atomForAttributeName "sname" tuple == (Right $ TextAtom "Blake") then Right $ updateTupleWithAtoms (M.singleton "city" (TextAtom "Boston")) tuple else Right tuple) suppliersRel),                            ("x:=s; update x where city=\"Paris\" (status:=add(@status,10))", updateParisPlus10),                            --relatom function tests-                           ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntAtom 1)])),+                           ("x:=((s group ({city} as y)):{z:=count(@y)}){z}", mkRelation groupCountAttrs (RelationTupleSet [mkRelationTuple groupCountAttrs (V.singleton $ IntegerAtom 1)])),                            ("x:=(sp group ({s#} as y)) ungroup y", Right supplierProductsRel),-                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,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)])),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=max(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 400), ("S2", 400), ("S3", 200), ("S4", 400)])),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=min(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 100), ("S2", 300), ("S3", 200), ("S4", 200)])),+                           ("x:=((sp{s#,qty}) group ({qty} as x):{z:=sum(@x)}){s#,z}", mkRelationFromList minMaxAttrs (map (\(s,i) -> [TextAtom s,IntegerAtom i]) [("S1", 1000), ("S2", 700), ("S3", 200), ("S4", 900)])),                            --boolean function restriction-                           ("x:=s where ^lt(@status,20)", mkRelationFromList (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"]]),+                           ("x:=s where ^lt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),+                           ("x:=s where ^gt(@status,20)", mkRelationFromList (attributes suppliersRel) [[TextAtom "S3", TextAtom "Blake", IntegerAtom 30, TextAtom "Paris"],+                                                                                                       [TextAtom "S5", TextAtom "Adams", IntegerAtom 30, TextAtom "Athens"]]),+                           ("x:=s where ^sum(@status)", Left $ AtomTypeMismatchError IntegerAtomType BoolAtomType),+                           ("x:=s where ^not(gte(@status,20))", mkRelationFromList (attributes suppliersRel) [[TextAtom "S2", TextAtom "Jones", IntegerAtom 10, TextAtom "Paris"]]),                            --test "all but" attribute inversion syntax                            ("x:=s{all but s#} = s{city,sname,status}", Right relationTrue),                            --test key syntax@@ -122,11 +143,11 @@                            ("x:=relation{tuple{y bytestring(\"dGVzdGRhdGE=\")}}", mkRelationFromList byteStringAttributes [[ByteStringAtom (TE.encodeUtf8 "testdata")]]),                            --test Maybe Text                            ("x:=relation{tuple{a Just \"spam\"}}", mkRelationFromList simpleMaybeTextAttributes [[ConstructedAtom "Just" maybeTextAtomType [TextAtom "spam"]]]),-                           --test Maybe Int-                           ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntAtomType [IntAtom 3]]]),-                           --test Either Int Text+                           --test Maybe Integer+                           ("x:=relation{tuple{a Just 3}}", mkRelationFromList simpleMaybeIntAttributes [[ConstructedAtom "Just" maybeIntegerAtomType [IntegerAtom 3]]]),+                           --test Either Integer Text                            ("x:=relation{tuple{a Left 3}}",  Left (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]]]),+                           ("x:=relation{a Either Integer Text}{tuple{a Left 3}}", mkRelationFromList simpleEitherIntTextAttributes [[ConstructedAtom "Left" (eitherAtomType IntegerAtomType TextAtomType) [IntegerAtom 3]]]),                            --test datetime constructor                            ("x:=relation{tuple{a dateTimeFromEpochSeconds(1495199790)}}", mkRelationFromList (A.attributesFromList [Attribute "a" DateTimeAtomType]) [[DateTimeAtom (posixSecondsToUTCTime(realToFrac (1495199790 :: Int)))]])                           ]@@ -209,29 +230,29 @@ 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]))+    err = Left (TupleAttributeTypeMismatchError (A.attributesFromList [Attribute "test" IntegerAtomType]))  simpleJoinTest :: Test simpleJoinTest = TestCase $ assertTutdEqual dateExamples joinedRel "x:=s join sp"     where         attrs = A.attributesFromList [Attribute "city" TextAtomType,-                                      Attribute "qty" IntAtomType,+                                      Attribute "qty" IntegerAtomType,                                       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]+                                      Attribute "status" IntegerAtomType]+        joinedRel = mkRelationFromList attrs [[TextAtom "London", IntegerAtom 100, TextAtom "P6", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 400, TextAtom "P3", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 400, TextAtom "P5", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 300, TextAtom "P1", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "Paris", IntegerAtom 200, TextAtom "P2", TextAtom "S3", TextAtom "Blake", IntegerAtom 30],+                                              [TextAtom "Paris", IntegerAtom 300, TextAtom "P1", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],+                                              [TextAtom "London", IntegerAtom 100, TextAtom "P5", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 300, TextAtom "P4", TextAtom "S4", TextAtom "Clark", IntegerAtom 20],+                                              [TextAtom "Paris", IntegerAtom 400, TextAtom "P2", TextAtom "S2", TextAtom "Jones", IntegerAtom 10],+                                              [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 200, TextAtom "P4", TextAtom "S1", TextAtom "Smith", IntegerAtom 20],+                                              [TextAtom "London", IntegerAtom 200, TextAtom "P2", TextAtom "S4", TextAtom "Clark", IntegerAtom 20]                                               ]                                          @@ -249,7 +270,7 @@       relvarx = RelationVariable "x" ()   (sess, conn) <- dateExamplesConnection (notifCallback notifmvar)   executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail-  executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx) >>= eitherFail+  executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx relvarx) >>= eitherFail   commit sess conn >>= eitherFail   executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail   commit sess conn >>= eitherFail@@ -261,22 +282,22 @@   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}}"+  executeTutorialD sessionId dbconn "y:=relation{a Tree Integer}{tuple{a Node 3 (Node 4 EmptyNode EmptyNode) EmptyNode},tuple{a Node 4 EmptyNode EmptyNode}}"    testMergeTransactions :: Test testMergeTransactions = TestCase $ do   (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback   mapM_ (executeTutorialD sessionId dbconn) [    ":branch branchA",-   "conflictrv := relation{conflict Int}{tuple{conflict 1}}",+   "conflictrv := relation{conflict Integer}{tuple{conflict 1}}",    ":commit",    ":jumphead master",    ":branch branchB",-   "conflictrv := relation{conflict Int}{tuple{conflict 2}}",+   "conflictrv := relation{conflict Integer}{tuple{conflict 2}}",    ":commit",    ":mergetrans union branchA branchB"    ]-  case mkRelationFromList (attributesFromList [Attribute "conflict" IntAtomType]) [[IntAtom 1],[IntAtom 2]] of+  case mkRelationFromList (attributesFromList [Attribute "conflict" IntegerAtomType]) [[IntegerAtom 1],[IntegerAtom 2]] of     Left err -> assertFailure (show err)     Right conflictCheck -> do       eRv <- executeRelationalExpr sessionId dbconn (RelationVariable "conflictrv" ())@@ -307,11 +328,11 @@       sattrs = attributesFromList [Attribute "city" TextAtomType,                                    Attribute "sname" TextAtomType,                                    Attribute "s#" TextAtomType,-                                   Attribute "status" IntAtomType]+                                   Attribute "status" IntegerAtomType]       expectedRel = mkRelationFromList sattrs [[TextAtom "Boston",                                                 TextAtom "Smithers",                                                 TextAtom "S9",-                                                IntAtom 50]]+                                                IntegerAtom 50]]   diff <- executeTransGraphRelationalExpr sessionId dbconn (Difference (RelationVariable "s" testBranchMarker) (RelationVariable "s" masterMarker))   assertEqual "difference in s" expectedRel diff    @@ -344,7 +365,7 @@     sattrs = attributesFromList [Attribute "town" TextAtomType,                                  Attribute "sname" TextAtomType,                                  Attribute "s#" TextAtomType,-                                 Attribute "price" IntAtomType]+                                 Attribute "price" IntegerAtomType]     renamedRel = mkRelationFromList sattrs []  testSchemaExpr :: Test@@ -357,7 +378,7 @@     ]   eLightProduct <- executeRelationalExpr sessionId dbconn (RelationVariable "light_product" ())   lightProduct <- assertEither eLightProduct-  let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntAtom 17), AttributeAtomExpr "weight"] ()))+  let restriction = NotPredicate (AtomExprPredicate (FunctionAtomExpr "gte" [NakedAtomExpr (IntegerAtom 17), AttributeAtomExpr "weight"] ()))   setCurrentSchemaName sessionId dbconn Sess.defaultSchemaName >>= eitherFail   eRestrictedProduct <- executeRelationalExpr sessionId dbconn (Restrict restriction (RelationVariable "p" ()))   restrictedProduct <- assertEither eRestrictedProduct@@ -377,10 +398,10 @@   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]]+                                                            Attribute "z" IntegerAtomType])+                    [[TextAtom "Paris", IntegerAtom 2],+                     [TextAtom "London", IntegerAtom 3],+                     [TextAtom "Athens", IntegerAtom 0]]   assertEqual "validate parts count" expectedRel eRv      executeTutorialD sessionId dbconn "rv1:=relation{tuple{test 1}}"@@ -392,7 +413,7 @@                          (RelationalExprPredicate                           (Project AN.empty subexpr)) (RelationVariable "rv1" ())   eRv2 <- executeRelationalExpr sessionId dbconn (mainExpr correctSubexpr)-  let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntAtomType]) [[IntAtom 1]]+  let expectedRel2 = mkRelationFromList (attributesFromList [Attribute "test" IntegerAtomType]) [[IntegerAtom 1]]   assertEqual "validate sub-expression attribute" expectedRel2 eRv2      --check error in subexpression@@ -441,12 +462,28 @@   (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback     executeTutorialD sessionId dbconn "x:=relation{tuple{n 1, a interval(3,4,f,f), b interval(4,5,f,f)}, tuple{n 2,a interval(3,4,t,t), b interval(4,5,t,t)}}"   --test failed interval creation-  let err1 = "AtomFunctionUserError InvalidIntervalOrdering"-      err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportInterval \"Text\")"+  let err1 = "AtomFunctionUserError InvalidIntervalOrderingError"+      err2 = "AtomFunctionUserError (AtomTypeDoesNotSupportIntervalError \"Text\")"   expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{a interval(4,3,f,f)}}"   expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{a interval(\"s\",\"t\",f,f)}}"      --test interval_overlaps   executeTutorialD sessionId dbconn "y:=x:{c:=interval_overlaps(@a,@b)}"   eRv <- executeRelationalExpr sessionId dbconn (Project (AttributeNames (S.fromList ["n","c"])) (RelationVariable "y" ()))-  assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntAtomType]) [[BoolAtom True, IntAtom 1], [BoolAtom False, IntAtom 2]]) eRv+  assertEqual "interval overlap check" (mkRelationFromList (attributesFromList [Attribute "c" BoolAtomType,Attribute "n" IntegerAtomType]) [[BoolAtom True, IntegerAtom 1], [BoolAtom False, IntegerAtom 2]]) eRv++testListConstructedAtom :: Test+testListConstructedAtom = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback+  executeTutorialD sessionId dbconn "x:=relation{tuple{l Cons 4 (Cons 5 Empty)}}"+  let err1 = "ConstructedAtomArgumentCountMismatchError 2 1"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "z:=relation{tuple{l Cons 4}}"+  let err2 = "TypeConstructorAtomTypeMismatch \"List\" IntegerAtomType"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err2) "z:=relation{tuple{l Cons 4 5}}"+  +testTypeChecker :: Test  +testTypeChecker = TestCase $ do+  (sessionId, dbconn) <- dateExamplesConnection emptyNotificationCallback  +  let err1 = "AtomFunctionTypeError \"max\" 1 (RelationAtomType [Attribute \"_\" IntegerAtomType]) IntegerAtomType"+  expectTutorialDErr sessionId dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 0}}:{b:=max(@a)}"+  

@@ -3,7 +3,6 @@ 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@@ -25,11 +24,11 @@ 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)] ()+  executeTutorialD sess conn "addatomfunction \"mkTest\" Integer -> Either AtomFunctionError Integer \"(\\\\(IntegerAtom x:xs) -> pure (IntegerAtom x)) :: [Atom] -> Either AtomFunctionError Atom\""+  let attrs = [Attribute "x" IntegerAtomType]+      funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()       tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]-      expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]+      expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 3]]   result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)    assertEqual "simple atom function equality" expectedResult result@@ -38,9 +37,9 @@ 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)] ()+  executeTutorialD sess conn "addatomfunction \"mkTest\" Integer -> Either AtomFunctionError Integer \"\"\"(\\(IntegerAtom x:xs) -> (error (show 1))) :: [Atom] -> Either AtomFunctionError Atom\"\"\""+  let attrs = [Attribute "x" IntegerAtomType]+      funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()       tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]   result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)   assertBool "catch error exception from script" (case result of@@ -50,27 +49,27 @@ 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\"\"\""+  executeTutorialD sess conn "addatomfunction \"errorAtom\" Integer -> Either AtomFunctionError Integer \"\"\"(\\(IntegerAtom 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]+  executeTutorialD sess conn "addatomfunction \"mkTest\" Either AtomFunctionError Integer \"\"\"(\\x -> pure (IntegerAtom 5)) :: [Atom] -> Either AtomFunctionError Atom\"\"\""+  let attrs = [Attribute "x" IntegerAtomType]       funcAtomExpr = FunctionAtomExpr  "mkTest" [] ()       tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]-      expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 5]]+      expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 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\"\"\""+  executeTutorialD sess conn "addatomfunction \"mkTest\" Integer -> Either AtomFunctionError Integer \"\"\"(\\(IntegerAtom x:_) -> pure $ TextAtom \"wrong type\") :: [Atom] -> Either AtomFunctionError Atom\"\"\""   let tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]-      funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntAtom 3)] ()-      attrs = [Attribute "x" IntAtomType]-      expectedResult = Left (AtomTypeMismatchError IntAtomType TextAtomType)+      funcAtomExpr = FunctionAtomExpr  "mkTest" [NakedAtomExpr (IntegerAtom 3)] ()+      attrs = [Attribute "x" IntegerAtomType]+      expectedResult = Left (AtomTypeMismatchError IntegerAtomType TextAtomType)   result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)   assertEqual "type mismatch not detected" expectedResult result   @@ -78,26 +77,26 @@ 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),+  let funcAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntegerAtom 5),                                                    NakedAtomExpr maybeAtom] ()-      maybeAtom = ConstructedAtom "Just" (maybeAtomType IntAtomType) [IntAtom 3]+      maybeAtom = ConstructedAtom "Just" (maybeAtomType IntegerAtomType) [IntegerAtom 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]+      let expectedRetAttrs = V.fromList [Attribute "x" IntegerAtomType]       assertEqual "fromMaybe type" expectedRetAttrs (attributes relType)       mRes <- executeRelationalExpr sess conn relExpr-      let expectedRel = mkRelationFromList (V.fromList [Attribute "x" IntAtomType]) [[IntAtom 3]]+      let expectedRel = mkRelationFromList (V.fromList [Attribute "x" IntegerAtomType]) [[IntegerAtom 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),+  let failFuncAtomExpr = FunctionAtomExpr "fromMaybe" [NakedAtomExpr (IntegerAtom 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)+  let expectedErr = Left (AtomFunctionTypeVariableMismatch "a" IntegerAtomType TextAtomType)   assertEqual "expected type variable mismatch" expectedErr mFailRes                                                         --test that a user can create a function with a type variable argument@@ -105,10 +104,10 @@ 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)] ()+  let attrs = [Attribute "x" IntegerAtomType]+      funcAtomExpr = FunctionAtomExpr  "idTest" [NakedAtomExpr (IntegerAtom 3)] ()       tupleExprs = [TupleExpr (M.singleton "x" funcAtomExpr)]-      expectedResult = mkRelationFromList (V.fromList attrs) [[IntAtom 3]]+      expectedResult = mkRelationFromList (V.fromList attrs) [[IntegerAtom 3]]   result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)    assertEqual "id function equality" expectedResult result

@@ -50,13 +50,13 @@ 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 -> executeDatabaseContextExpr (Assign \"person\" (MakeRelationFromExprs Nothing [TupleExpr (fromList [(\"name\", NakedAtomExpr name), (\"age\", NakedAtomExpr age)])])) ctx) :: [Atom] -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext\"\"\""+  let addfunc = "adddatabasecontextfunction \"multiArgFunc\" Integer -> Text -> DatabaseContext -> Either DatabaseContextFunctionError DatabaseContext \"\"\"(\\(age:name:_) ctx -> executeDatabaseContextExpr (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]]+                                                               Attribute "age" IntegerAtomType]) [+        [TextAtom "Steve", IntegerAtom 30]]   assertEqual "person relation" expectedPerson result   expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")" 

@@ -16,6 +16,6 @@   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")])])]+    let expectedExpr = MultipleExpr [Assign "x" (MakeRelationFromExprs Nothing [TupleExpr (M.fromList [("a",NakedAtomExpr $ IntegerAtom 5),("b",NakedAtomExpr $ TextAtom "spam")])])]     imported <- importTutorialD tempPath     assertEqual "import tutd" (Right expectedExpr) imported

@@ -1,6 +1,5 @@ module TutorialD.Interpreter.TestBase where import ProjectM36.Client-import ProjectM36.Error import TutorialD.Interpreter import TutorialD.Interpreter.Base import qualified ProjectM36.Base as Base