project-m36 1.2.0 → 1.2.3

raw patch · 23 files changed

+600/−190 lines, 23 filesdep ~aesondep ~basedep ~base16-bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, base, base16-bytestring, cassava, curryer-rpc, megaparsec, scotty, stm-containers, streamly, uuid, winery

API changes (from Hackage documentation)

Files

• Changelog.markdown +9/−0
• README.markdown +1/−0
• examples/blog.hs +22/−23
• examples/hair.hs +1/−1
• examples/zoo.hs +1/−0
• project-m36.cabal +24/−5
• src/bin/ProjectM36/Interpreter.hs +3/−4
• src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +19/−5
• src/bin/benchmark/bigrel.hs +1/−1
• src/lib/ProjectM36/AtomFunctionError.hs +1/−0
• src/lib/ProjectM36/Base.hs +4/−0
• src/lib/ProjectM36/Error.hs +2/−1
• src/lib/ProjectM36/Function.hs +59/−1
• src/lib/ProjectM36/Module.hs +61/−0
• src/lib/ProjectM36/NormalizeExpr.hs +1/−0
• src/lib/ProjectM36/RelationalExpression.hs +199/−64
• src/lib/ProjectM36/ScriptSession.hs +132/−80
• src/lib/ProjectM36/Transaction/Persist.hs +1/−1
• test/Relation/Atomable.hs +1/−1
• test/Server/WebSocket.hs +1/−1
• test/TutorialD/Interpreter/Module.hs +46/−0
• test/TutorialD/Interpreter/TestBase.hs +1/−1
• test/TutorialD/InterpreterTest.hs +10/−1

@@ -1,3 +1,12 @@+# 2026-02-09 (v1.2.3)++* add support for importing whole Haskell modules for easier application logic programming+	+# 2026-01-15 (v1.2.1)++* fix critical type resolution error in MakeRelationFromExprs+* upgrade to crypton 1.8.0 and friends+ # 2026-01-06 (v1.2.0)  * add LRU result caching layer

@@ -99,6 +99,7 @@ 1. [Basic Operator Benchmarks](https://rawgit.com/agentm/project-m36/master/docs/basic_benchmarks.html) 1. [Merkle Transaction Hashes](docs/merkle_transaction_graph.markdown) 1. [Handling DDL Changes](docs/Handling_DDL_Changes.markdown)+1. [Importing a Haskell Module](docs/import_haskell_module.markdown)  ### Integrations 

@@ -2,7 +2,6 @@ {-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings, CPP, DerivingVia #-}  import ProjectM36.Client-import ProjectM36.Base import ProjectM36.Relation import ProjectM36.Tupleable import ProjectM36.Atom (relationForAtom)@@ -20,7 +19,7 @@ import Control.Monad (when, forM_) import Codec.Winery -import Web.Scotty as S+import qualified 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@@ -83,7 +82,7 @@   createSchema sessionId conn     insertSampleData sessionId conn   --create the web routes-  scotty 3000 $ do+  S.scotty 3000 $ do     S.get "/" (listBlogs sessionId conn)     S.get "/blog/:blogid" (showBlogEntry sessionId conn)     S.post "/comment" (addComment sessionId conn)@@ -126,45 +125,45 @@   handleIOError $ executeDatabaseContextExpr sessionId conn insertCommentsExpr    -- handle relational errors with scotty-handleWebError :: Either RelationalError a -> ActionM a +handleWebError :: Either RelationalError a -> S.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 -> Connection -> S.ActionM () listBlogs sessionId conn = do-  eRel <- liftIO $ executeRelationalExpr sessionId conn (RelationVariable "blog" ())+  eRel <- S.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]+      blogs <- S.liftIO (toList blogRel) >>= mapM (handleWebError . fromTuple) :: S.ActionM [Blog]       let sortedBlogs = sortBy (\b1 b2 -> tstamp b1 `compare` tstamp b2) blogs-      html . renderHtml $ do+      S.html . renderHtml $ do         h1 "Blog Posts"         forM_ sortedBlogs $ \blog -> a ! href (toValue $ "/blog/" <> title blog) $ h2 (toHtml (title blog)) -render500 :: Html -> ActionM ()+render500 :: Html -> S.ActionM () render500 msg = do -  html . renderHtml $ do+  S.html . renderHtml $ do     h1 "Internal Server Error"       p msg-  status internalServerError500+  S.status internalServerError500    --display one blog post along with its comments-showBlogEntry :: SessionId -> Connection -> ActionM ()+showBlogEntry :: SessionId -> Connection -> S.ActionM () showBlogEntry sessionId conn = do-  blogid <- pathParam "blogid"+  blogid <- S.pathParam "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 +  eRel <- S.liftIO $ executeRelationalExpr sessionId conn (Extend extendExpr                                                           (Restrict                                                            blogRestrictionExpr                                                            (RelationVariable "blog" ())))-  let render = html . renderHtml+  let render = S.html . renderHtml       formatStamp = iso8601Show --formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))   case eRel of      Left err -> render500 (toHtml (show err))@@ -172,14 +171,14 @@     Right rel -> case singletonTuple rel of       Nothing -> do --no results for this blog id         render (h1 "No such blog post")-        status status404+        S.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]+          comments <- S.liftIO (toList commentsRel) >>= mapM (handleWebError . fromTuple) :: S.ActionM [Comment]           let commentsSorted = sortBy (\c1 c2 -> commentTime c1 `compare` commentTime c2) comments           render $ do             --show blog details@@ -201,20 +200,20 @@               input ! type_ "submit"              --add a comment to a blog post-addComment :: SessionId -> Connection -> ActionM ()            +addComment :: SessionId -> Connection -> S.ActionM ()             addComment sessionId conn = do-  blogid <- pathParam "blogid"-  commentText <- formParam "contents"-  now <- liftIO getCurrentTime+  blogid <- S.pathParam "blogid"+  commentText <- S.formParam "contents"+  now <- S.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))+      eRet <- S.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))+          S.redirect (TL.fromStrict ("/blog/" <> blogid))       

@@ -2,7 +2,7 @@ import ProjectM36.Client import ProjectM36.Relation.Show.Term import GHC.Generics-import Data.Text+import Data.Text (Text) import Control.DeepSeq import qualified Data.Map as M import qualified Data.Text.IO as TIO

@@ -11,6 +11,7 @@ import Data.Time.Calendar import qualified Data.Text.IO as T +--TODO add dbc func ACLs data Ticket = Ticket   { ticketId   :: Integer   , visitorAge :: Integer    -- years

@@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: project-m36-Version: 1.2.0+Version: 1.2.3 License: MIT --note that this license specification is erroneous and only labeled MIT to appease hackage which does not recognize public domain packages in cabal >2.2- Project:M36 is dedicated to the public domain Build-Type: Simple@@ -91,7 +91,7 @@                   cryptohash-sha256,                   text-manipulate >= 0.2.0.1 && < 0.4,                   winery >= 1.4,-                  curryer-rpc>=0.5.0,+                  curryer-rpc>=0.5.1,                   network,                   async,                   vector-instances,@@ -245,7 +245,8 @@                      ProjectM36.AccessControlList,                      ProjectM36.AccessControl,                      ProjectM36.LoginRoles,-                     ProjectM36.PrettyBytes+                     ProjectM36.PrettyBytes,+                     ProjectM36.Module     GHC-Options: -Wall -rdynamic     if os(windows)       Build-Depends: Win32 >= 2.12@@ -582,6 +583,25 @@     main-is: TutorialD/Interpreter/Import/ImportTest.hs     Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer +Test-Suite test-tutoriald-import-module+    import: commontest+    type: exitcode-stdio-1.0+    main-is: TutorialD/Interpreter/Module.hs+    if flag(haskell-scripting)+        CPP-Options: -DPM36_HASKELL_SCRIPTING+    Other-Modules: TutorialD.Interpreter.Base, TutorialD.Interpreter.Import.Base, TutorialD.Interpreter.Import.TutorialD, TutorialD.Interpreter.RelationalExpr, TutorialD.Interpreter.Types, TutorialD.Interpreter.DatabaseContextExpr, TutorialD.Interpreter.Import.BasicExamples, TutorialD.Printer,         TutorialD.Interpreter,+        TutorialD.Interpreter.DatabaseContextIOOperator,+        TutorialD.Interpreter.Export.Base,+        TutorialD.Interpreter.Export.CSV,+        TutorialD.Interpreter.Import.CSV,+        TutorialD.Interpreter.InformationOperator,+        TutorialD.Interpreter.LoginRolesOperator,+        TutorialD.Interpreter.RODatabaseContextOperator,+        TutorialD.Interpreter.SchemaOperator,+        TutorialD.Interpreter.TestBase,+        TutorialD.Interpreter.TransGraphRelationalOperator,+        TutorialD.Interpreter.TransactionGraphOperator+ Test-Suite test-relation-export-csv     import: commontest     type: exitcode-stdio-1.0@@ -656,7 +676,7 @@ Executable Example-Blog     Default-Language: Haskell2010     Default-Extensions: OverloadedStrings-    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty >= 0.22, blaze-html, http-types, winery, random+    Build-Depends: base, HUnit, Cabal, containers, hashable, unordered-containers, mtl, vector, time, bytestring, uuid, stm, deepseq, deepseq-generics,parallel, cassava, attoparsec, gnuplot, directory, temporary, haskeline, megaparsec, text, base64-bytestring, data-interval, filepath, transformers, stm-containers, list-t, aeson, path-pieces, either, conduit, http-api-data, template-haskell, ghc, ghc-paths, project-m36, scotty >= 0.30, blaze-html, http-types, winery, random     Main-Is: examples/blog.hs     GHC-Options: -Wall -threaded @@ -833,4 +853,3 @@         TutorialD.Interpreter.TransactionGraphOperator         TutorialD.Interpreter.Types         TutorialD.Printer- 

@@ -6,7 +6,6 @@ import ProjectM36.DataFrame import Text.Megaparsec import Data.Void-import Data.Text import GHC.Generics import qualified Data.Text.IO as TIO import qualified Data.Text as T@@ -16,8 +15,8 @@ import ProjectM36.Relation.Show.Term import ProjectM36.Relation -type Parser = Parsec Void Text-type ParserError = ParseErrorBundle Text Void+type Parser = Parsec Void T.Text+type ParserError = ParseErrorBundle T.Text Void type PromptLength = Int  data SafeEvaluationFlag = SafeEvaluation | UnsafeEvaluation deriving (Eq)@@ -27,7 +26,7 @@                      DisplayIOResult (IO ()) |                      DisplayRelationResult Relation |                      DisplayDataFrameResult DataFrame |-                     DisplayHintWith Text ConsoleResult |+                     DisplayHintWith T.Text ConsoleResult |                      DisplayErrorResult StringType |                      DisplayRelationalErrorResult RelationalError |                      DisplayParseErrorResult (Maybe PromptLength) ParserError | -- PromptLength refers to length of prompt text

@@ -12,7 +12,8 @@ data DatabaseContextIOOperator =   DatabaseContextIOOp DatabaseContextIOExpr |   LoadAtomFunctionFromFileOp FunctionName [TypeConstructor] FilePath |-  LoadDatabaseContextFunctionFromFileOp FunctionName [TypeConstructor] FilePath+  LoadDatabaseContextFunctionFromFileOp FunctionName [TypeConstructor] FilePath |+  LoadModuleFromFileOp FilePath   deriving (Show, Eq)  addAtomFunctionExprP :: Parser DatabaseContextIOExpr@@ -52,7 +53,8 @@ databaseContextIOOperatorP =    (DatabaseContextIOOp <$> databaseContextIOExprP) <|>   (reserved "loadatomfunctionfromfile" >> (LoadAtomFunctionFromFileOp <$> quotedString <*> atomTypeSignatureP <*> quotedFilePath)) <|>-  (reserved "loaddatabasecontextfunctionfromfile" >> (LoadDatabaseContextFunctionFromFileOp <$> quotedString <*> atomTypeSignatureP <*> quotedFilePath))+  (reserved "loaddatabasecontextfunctionfromfile" >> (LoadDatabaseContextFunctionFromFileOp <$> quotedString <*> atomTypeSignatureP <*> quotedFilePath)) <|>+  loadModuleFromFileP    loadAtomFunctionsP :: Parser DatabaseContextIOExpr loadAtomFunctionsP = do@@ -63,17 +65,22 @@ loadDatabaseContextFunctionsP = do   reserved "loaddatabasecontextfunctions"   LoadDatabaseContextFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString++loadModuleFromFileP :: Parser DatabaseContextIOOperator+loadModuleFromFileP = do+  reserved "loadmodulefromfile"+  LoadModuleFromFileOp <$> quotedFilePath                                               interpretDatabaseContextIOOperator :: DatabaseContextIOOperator -> IO (Either RelationalError DatabaseContextIOExpr) interpretDatabaseContextIOOperator expr = do   let loadFromFile typ functionName functionArgs functionFilePath = do-        let handler :: IOException -> IO (Either RelationalError Text)-            handler e = pure (Left (ImportError (ImportFileError (T.pack (displayException e)))))-        eFuncBody <- handle handler (Right <$> TIO.readFile functionFilePath)+        eFuncBody <- handle ioExcHandler (Right <$> TIO.readFile functionFilePath)         case eFuncBody of           Left err -> pure (Left err)           Right functionBody ->             pure (Right (typ functionName functionArgs functionBody))+      ioExcHandler :: IOException -> IO (Either RelationalError Text)+      ioExcHandler e = pure (Left (ImportError (ImportFileError (T.pack (displayException e)))))            case expr of     DatabaseContextIOOp expr' ->@@ -82,5 +89,12 @@       loadFromFile AddAtomFunction functionName functionArgs functionFilePath     LoadDatabaseContextFunctionFromFileOp functionName functionArgs functionFilePath ->       loadFromFile AddDatabaseContextFunction functionName functionArgs functionFilePath+    -- pass module contents via Text so that remote client can upload a module, duh+    LoadModuleFromFileOp modPath -> do+      eModBody <- handle ioExcHandler (Right <$> TIO.readFile modPath)+      case eModBody of+        Left err -> pure (Left err)+        Right modBody ->+          pure (Right (LoadModuleWithFunctions modBody))  

@@ -23,7 +23,7 @@ import qualified Data.Text.IO as TIO import System.IO import Control.DeepSeq-import Data.Text hiding (map)+import Data.Text (Text, pack) import Data.Time.Clock import Data.UUID.V4 import qualified ProjectM36.DatabaseContextFunctionUtils as Util

@@ -7,6 +7,7 @@ data AtomFunctionError = AtomFunctionUserError String |                          AtomFunctionTypeMismatchError |                          AtomFunctionParseError String |+                         AtomFunctionMissingReturnTypeError |                          InvalidIntervalOrderingError |                          InvalidIntervalBoundariesError |                          AtomFunctionAttributeNameNotFoundError Text |

@@ -402,9 +402,12 @@   LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |   AddDatabaseContextFunction FunctionName [TypeConstructor] FunctionBodyScript |   LoadDatabaseContextFunctions ObjModuleName ObjFunctionName FilePath |+  LoadModuleWithFunctions ModuleBody |   CreateArbitraryRelation RelVarName [AttributeExprBase a] Range                            deriving (Show, Eq, Generic) +type ModuleBody = StringType+ type GraphRefDatabaseContextIOExpr = DatabaseContextIOExprBase GraphRefTransactionMarker  type DatabaseContextIOExpr = DatabaseContextIOExprBase ()@@ -545,6 +548,7 @@  type FunctionName = StringType type FunctionBodyScript = StringType+type ModuleBodyScript = StringType  -- | Represents stored, user-created or built-in functions which can operates of types such as Atoms or DatabaseContexts. data Function a acl = Function {

@@ -155,7 +155,8 @@ data ScriptCompilationError = TypeCheckCompilationError String String | --expected, got                               SyntaxErrorCompilationError String |                               ScriptCompilationDisabledError |-                              OtherScriptCompilationError String+                              OtherScriptCompilationError String |+                              ModuleLoadError                             deriving (Show, Eq, Generic, Typeable, NFData)                                       instance Exception ScriptCompilationError

@@ -1,10 +1,13 @@ -- | Module for functionality common between the various Function types (AtomFunction, DatabaseContextFunction).+{-# LANGUAGE TypeApplications #-} module ProjectM36.Function where import ProjectM36.Base import ProjectM36.Error---import ProjectM36.Serialise.Base ()+import ProjectM36.AtomFunctionError (AtomFunctionError(AtomFunctionMissingReturnTypeError)) import ProjectM36.ScriptSession import qualified Data.HashSet as HS+import Data.List (intercalate)+import qualified Data.Text as T  -- for merkle hash                        @@ -56,3 +59,58 @@   case HS.toList $ HS.filter (\f -> funcName f == funcName') funcSet of     [] -> Left $ NoSuchFunctionError funcName'     x : _ -> Right x++{-+  \[IntegerAtom val1, IntegerAtom val2] -> +     Right $ IntegerAtom $ apply_discount val1 val2+-}+wrapAtomFunction :: [AtomType] -> FunctionName -> Either RelationalError String+wrapAtomFunction aType@(_:_) funcName' =+  pure $+  -- we have to make a string-based, dynamic wrapper since we need to get a consistent function type out of the code+  -- there's no value in having an AtomFunction with no return type, so there must be a list with at least one value+    "\\[" <>+    wrapAtomArguments aType <>+    "] -> Right $ " <> +    convType (last aType) <>+    " $ " <>+    T.unpack funcName' <>+    " " <>+    unwords (map (\i -> "val" <> show i) [1 .. length aType - 1])+wrapAtomFunction [] _ = Left (AtomFunctionUserError AtomFunctionMissingReturnTypeError)++-- | convert an AtomType into its constituent String value for use in constructing the Haskell scripting utility wrapper.+convType :: AtomType -> String+convType typ =+  case typ of+    IntegerAtomType -> "IntegerAtom"+    IntAtomType -> "IntAtom"+    ScientificAtomType -> "ScientificAtom"+    DoubleAtomType -> "DoubleAtom"+    TextAtomType -> "TextAtom"+    DayAtomType -> "DayAtom"+    DateTimeAtomType -> "DateTimeAtom"+    ByteStringAtomType -> "ByteStringAtom"+    BoolAtomType -> "BoolAtom"+    UUIDAtomType -> "UUIDAtom"+    RelationAtomType _ -> "RelationAtom" +    SubrelationFoldAtomType _ -> "SubrelationFoldAtom" -- probably won't work+    ConstructedAtomType _ _ -> "ConstructedAtom" -- needs more work to render full atom metadata+    RelationalExprAtomType -> "RelationalExprAtom"+    TypeVariableType _ -> "" -- nonsense+    ++wrapAtomArguments :: [AtomType] -> String+wrapAtomArguments atomArgs =+  intercalate "," (zipWith (\i c -> convType c <> " val" <> show @Int i) [1 ..] (init atomArgs))++wrapDatabaseContextFunction :: [AtomType] -> FunctionName -> String+wrapDatabaseContextFunction aType funcName' =+  "\\dbcfuncutils [" <>+  wrapAtomArguments (aType <> [TypeVariableType "databaseContextFunctionMonad"]) <> -- last type is throwaway+  "] dbContext -> " <>+  "let env = DatabaseContextFunctionMonadEnv dbcfuncutils in\n" <>+  "runDatabaseContextFunctionMonad env dbContext $ do\n" <>+  "  " <> T.unpack funcName' <> " " <>+  unwords (map (\i -> "val" <> show i) [1 .. length aType])+  

@@ -0,0 +1,61 @@+-- | Utility module for importing scripted atom and database context functions.+module ProjectM36.Module where+import ProjectM36.Base+import ProjectM36.Error+import ProjectM36.AccessControlList+import ProjectM36.DatabaseContext.Types as DBCT+import Control.Monad.Trans.Writer+import Control.Monad.RWS.Strict (RWST, get, put, ask, runRWST)+import Control.Monad.Except (ExceptT, throwError, runExceptT)+import Data.Functor.Identity++declareAtomFunction :: FunctionName -> EntryPoints ()+declareAtomFunction nam = tell [DeclareAtomFunction nam]++declareDatabaseContextFunction :: FunctionName -> DBCFunctionAccessControlList -> EntryPoints ()+declareDatabaseContextFunction nam acl' = tell [DeclareDatabaseContextFunction nam acl']++type EntryPoints = Writer [DeclareFunction]++runEntryPoints :: EntryPoints () -> [DeclareFunction]+runEntryPoints = execWriter++data DeclareFunctionBase a = DeclareAtomFunction a |+                             DeclareDatabaseContextFunction a DBCFunctionAccessControlList+  deriving (Show)++type DeclareFunction = DeclareFunctionBase FunctionName++type DatabaseContextFunctionMonad a = RWST DatabaseContextFunctionMonadEnv () DatabaseContext (ExceptT RelationalError Identity) a++newtype DatabaseContextFunctionMonadEnv =+  DatabaseContextFunctionMonadEnv+  {+    utils :: DatabaseContextFunctionUtils+  }++executeRelationalExpr :: RelationalExpr -> DatabaseContextFunctionMonad Relation+executeRelationalExpr expr = do+  env <- ask+  ctx <- get+  case DBCT.executeRelationalExpr (utils env) ctx expr of+    Left err -> throwError err+    Right rel -> pure rel++executeDatabaseContextExpr :: DatabaseContextExpr -> DatabaseContextFunctionMonad ()+executeDatabaseContextExpr expr = do+  env <- ask+  ctx <- get+  case DBCT.executeDatabaseContextExpr (utils env) ctx expr of+    Left err -> throwError err+    Right ctx' ->+      put ctx'++runDatabaseContextFunctionMonad ::+  DatabaseContextFunctionMonadEnv ->+  DatabaseContext ->+  DatabaseContextFunctionMonad () ->+  Either RelationalError DatabaseContext+runDatabaseContextFunctionMonad env ctx m = do+  (_,ctx',_) <- runIdentity $ runExceptT $ runRWST m env ctx+  pure ctx'

@@ -92,6 +92,7 @@   pure (AddDatabaseContextFunction mod' fun path) processDatabaseContextIOExpr (LoadDatabaseContextFunctions mod' fun path) =   pure (LoadDatabaseContextFunctions mod' fun path)+processDatabaseContextIOExpr (LoadModuleWithFunctions modPath) = pure (LoadModuleWithFunctions modPath) processDatabaseContextIOExpr (CreateArbitraryRelation rvName attrExprs range) =   CreateArbitraryRelation rvName <$> mapM processAttributeExpr attrExprs <*> pure range   

@@ -36,7 +36,6 @@ import Control.Monad.IO.Class (liftIO) import Data.Bifunctor (second) import Data.Maybe-import Data.Tuple (swap) import Data.Either import Data.List (foldl') import Data.Char (isUpper)@@ -58,9 +57,27 @@ import qualified Data.Functor.Foldable as Fold import Control.Applicative #ifdef PM36_HASKELL_SCRIPTING+import System.IO.Temp+import System.IO (hClose)+import qualified Data.Text.IO as TIO+import Data.Default+import ProjectM36.Module import GHC hiding (getContext) import Control.Exception import GHC.Paths+--import GHC.Unit.State (emptyUnitState)+--import GHC.Driver.Ppr (showSDocForUser)+--import GHC.Unit.Finder.Types (FindResult(..))+--import GHC.Unit.Finder (findImportedModule)+import GHC.Types.Name.Occurrence (mkVarOcc, mkTcOcc)+import GHC.Iface.Env (lookupOrig)+import GHC.Types.Name (getOccString)+import GHC.Core.Type (mkTyConApp)+import GHC.Builtin.Types (unitTy)+import GHC.Core.TyCo.Compare (eqType)+import Unsafe.Coerce+import Control.Monad (forM)+--import GHC.Utils.Outputable (ppr) #endif  data DatabaseContextExprDetails = CountUpdatedTuples@@ -318,14 +335,13 @@         Left err -> dbErr err         Right expectedType -> do       -- if we are targeting an existing rv, we can morph a MakeRelationFromExprs datum to fill in missing type variables'-          let hintedExpr = addTargetTypeHints (attributes expectedType) expr-              eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr hintedExpr)+          let eNewExprType = runGraphRefRelationalExprM reEnv (typeForGraphRefRelationalExpr' (Just (attributes expectedType)) expr)           case eNewExprType of             Left err -> dbErr err             Right newExprType -> do               if newExprType == expectedType then do                 lift $ except $ validateAttributes tConsMapping (attributes newExprType)-                setRelVar relVarName hintedExpr +                setRelVar relVarName expr               else do                 dbErr (RelationTypeMismatchError (attributes expectedType) (attributes newExprType)) @@ -723,6 +739,12 @@                               case runDatabaseContextEvalMonad currentContext evalEnv (setRelVar relVarName (ExistingRelation rel)) of                                 Left err -> throwError err                                 Right dbstate' -> putDBCIOContext (dbc_context dbstate')+evalGraphRefDatabaseContextIOExpr (LoadModuleWithFunctions moduleBody) = do+  scriptSession <- requireScriptSession+  importModuleFromPath scriptSession moduleBody +  -- copy the module source in the db directory -- ideally this would be written into the transaction directory, but at this point, it does not yet exist+  -- load the module using GHC+  -- run the entrypoint function to get names of functions to convert to Atom and DBC functions  -- | run verification of all constraints -- needs DatabaseContext to create dummy Transaction@@ -1299,14 +1321,20 @@         x : _ -> Right x  typeForGraphRefRelationalExpr :: GraphRefRelationalExpr -> GraphRefRelationalExprM Relation-typeForGraphRefRelationalExpr (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs TS.empty-typeForGraphRefRelationalExpr (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))-typeForGraphRefRelationalExpr (MakeRelationFromExprs mAttrExprs tupleExprs) = do-  mAttrs <- case mAttrExprs of-              Just attrExprs -> do-                attrs <- mapM evalGraphRefAttributeExpr attrExprs-                pure (Just (attributesFromList attrs))-              Nothing -> pure Nothing+typeForGraphRefRelationalExpr = typeForGraphRefRelationalExpr' Nothing++typeForGraphRefRelationalExpr' :: Maybe Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExprM Relation+typeForGraphRefRelationalExpr' _thints (MakeStaticRelation attrs _) = lift $ except $ mkRelation attrs TS.empty+typeForGraphRefRelationalExpr' _thints (ExistingRelation rel) = pure (emptyRelationWithAttrs (attributes rel))+typeForGraphRefRelationalExpr' mAttributeTypeHints (MakeRelationFromExprs mAttrExprs tupleExprs) = do+  mAttrs <- case mAttributeTypeHints of+              Nothing ->+                case mAttrExprs of+                  Just attrExprs -> do+                    attrs <- mapM evalGraphRefAttributeExpr attrExprs+                    pure (Just (attributesFromList attrs))+                  Nothing -> pure Nothing+              Just attrTypeHints -> pure (Just attrTypeHints)   retAttrs <- typeForGraphRefTupleExprs mAttrs tupleExprs   case mAttrs of     Nothing ->@@ -1317,7 +1345,7 @@         Right retAttrs' ->            pure $ emptyRelationWithAttrs retAttrs'   -typeForGraphRefRelationalExpr (RelationVariable rvName tid) = do+typeForGraphRefRelationalExpr' _th (RelationVariable rvName tid) = do   ctx <- gfDatabaseContextForMarker tid   graph <- gfGraph   case resolveDBC' graph ctx relationVariables of@@ -1327,7 +1355,7 @@         Nothing -> throwError (RelVarNotDefinedError rvName)         Just rvExpr ->            typeForGraphRefRelationalExpr rvExpr-typeForGraphRefRelationalExpr (RelationValuedAttribute attrName) = do+typeForGraphRefRelationalExpr' _th (RelationValuedAttribute attrName) = do   env <- askEnv   case gre_extra env of     Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName)) -- or can this be an attribute at the top-level?@@ -1343,46 +1371,46 @@           case typ of             RelationAtomType relAttrs -> pure $ emptyRelationWithAttrs relAttrs             other -> throwError (AtomTypeMismatchError (RelationAtomType A.emptyAttributes) other)-typeForGraphRefRelationalExpr (Project attrNames expr) = do+typeForGraphRefRelationalExpr' _th (Project attrNames expr) = do   exprType' <- typeForGraphRefRelationalExpr expr   projectionAttrs <- evalGraphRefAttributeNames attrNames expr   lift $ except $ project projectionAttrs exprType'-typeForGraphRefRelationalExpr (Union exprA exprB) = do+typeForGraphRefRelationalExpr' _th (Union exprA exprB) = do   exprA' <- typeForGraphRefRelationalExpr exprA   exprB' <- typeForGraphRefRelationalExpr exprB   lift $ except $ union exprA' exprB'-typeForGraphRefRelationalExpr (Join exprA exprB) = do+typeForGraphRefRelationalExpr' _th (Join exprA exprB) = do   exprA' <- typeForGraphRefRelationalExpr exprA   exprB' <- typeForGraphRefRelationalExpr exprB   lift $ except $ join exprA' exprB'-typeForGraphRefRelationalExpr (Rename attrs expr) = do+typeForGraphRefRelationalExpr' _th (Rename attrs expr) = do   expr' <- typeForGraphRefRelationalExpr expr   lift $ except $ renameMany attrs expr'-typeForGraphRefRelationalExpr (Difference exprA exprB) = do  +typeForGraphRefRelationalExpr' _th (Difference exprA exprB) = do     exprA' <- typeForGraphRefRelationalExpr exprA   exprB' <- typeForGraphRefRelationalExpr exprB   lift $ except $ difference exprA' exprB'-typeForGraphRefRelationalExpr (Group groupNames attrName expr) = do-  expr' <- typeForGraphRefRelationalExpr expr+typeForGraphRefRelationalExpr' mHints (Group groupNames attrName expr) = do+  expr' <- typeForGraphRefRelationalExpr' mHints expr   groupNames' <- evalGraphRefAttributeNames groupNames expr   lift $ except $ group groupNames' attrName expr'-typeForGraphRefRelationalExpr (Ungroup groupAttrName expr) = do+typeForGraphRefRelationalExpr' _th (Ungroup groupAttrName expr) = do   expr' <- typeForGraphRefRelationalExpr expr   lift $ except $ ungroup groupAttrName expr'-typeForGraphRefRelationalExpr (Restrict pred' expr) = do+typeForGraphRefRelationalExpr' _th (Restrict pred' expr) = do   expr' <- typeForGraphRefRelationalExpr expr   let mergedAttrsEnv = mergeAttributesIntoGraphRefRelationalExprEnv (attributes expr')   R.local mergedAttrsEnv (typeForGraphRefRestrictionPredicateExpr pred')   filt <- predicateRestrictionFilter (attributes expr') pred'   lift $ except $ restrict filt expr'-typeForGraphRefRelationalExpr Equals{} = +typeForGraphRefRelationalExpr' _th Equals{} =    pure relationFalse-typeForGraphRefRelationalExpr NotEquals{} = +typeForGraphRefRelationalExpr' _th NotEquals{} =    pure relationFalse-typeForGraphRefRelationalExpr (Extend extendTupleExpr expr) = do+typeForGraphRefRelationalExpr' _th (Extend extendTupleExpr expr) = do   rel <- typeForGraphRefRelationalExpr expr   evalGraphRefRelationalExpr (Extend extendTupleExpr (ExistingRelation rel))-typeForGraphRefRelationalExpr expr@(With withs _) = do+typeForGraphRefRelationalExpr' _th expr@(With withs _) = do   let expr' = substituteWithNameMacros [] expr       checkMacroName (WithNameExpr macroName tid) = do         ctx <- gfDatabaseContextForMarker tid@@ -1687,42 +1715,6 @@     Nothing -> throwError (NoSuchAttributeNamesError (S.singleton attrName))     Just match -> pure match --- | Optionally add type hints to resolve type variables. For example, if we are inserting into a known relvar, then we have its concrete type.    -addTargetTypeHints :: Attributes -> GraphRefRelationalExpr -> GraphRefRelationalExpr-addTargetTypeHints targetAttrs expr =-  case expr of-    MakeRelationFromExprs Nothing tupExprs ->-      MakeRelationFromExprs (Just targetAttrExprs) tupExprs-    Project attrs e ->-      Project attrs (hint e)-    Union a b ->-      Union (hint a) (hint b)-    Join a b ->-      Join (hint a) (hint b)-    Rename rens e ->-      let renamedAttrs = A.renameAttributes' (S.map swap rens) targetAttrs in-      Rename rens (addTargetTypeHints renamedAttrs e)-    Difference a b ->-      Difference (hint a) (hint b)-    Group attrs gname e ->-      Group attrs gname (hint e)-    Ungroup gname e ->-      Ungroup gname (hint e)-    Restrict restriction e ->-      Restrict restriction (hint e)-    Equals a b ->-      Equals (hint a) (hint b)-    NotEquals a b ->-      NotEquals (hint a) (hint b)-    Extend tupExprs e ->-      Extend tupExprs (hint e)-    With withs e ->-      With withs (hint e)-    _ -> expr-  where-    targetAttrExprs = map NakedAttributeExpr (A.toList targetAttrs)-    hint = addTargetTypeHints targetAttrs- resolveDBC :: (DatabaseContext -> ValueMarker a) -> DatabaseContextEvalMonad a resolveDBC f = do   graph <- dbcGraph@@ -1890,4 +1882,147 @@         pure (Attribute attrName resolvedType)   attrList <- mapM resolveOneAtomType (M.toList tupMap)   pure (A.attributesFromList attrList)-        ++importModuleFromPath :: ScriptSession -> ModuleBody -> DatabaseContextIOEvalMonad ()+#if !defined(PM36_HASKELL_SCRIPTING)+importModuleFromPath _scriptSession _moduleSource = throwError (ScriptError ScriptCompilationDisabledError)+#else+importModuleFromPath scriptSession moduleSource = do+  res <- liftIO $ try $ do+    withSystemTempFile "pm36module" $ \tempModulePath tempModuleHandle -> do+      hClose tempModuleHandle+      TIO.writeFile tempModulePath moduleSource+      runGhc (Just libdir) $ do+    -- GHC needs to see the module on disk, so we write it to a temporary location+        setSession (hscEnv scriptSession)+        dflags <- getSessionDynFlags        +        let target = Target {+              targetId = TargetFile tempModulePath Nothing,+              targetAllowObjCode = False,+              targetUnitId = homeUnitId_ dflags,+              targetContents = Nothing+            }+        setTargets [target]+        loadSuccess <- load LoadAllTargets+        case loadSuccess of+          Failed -> pure (Left (ScriptError ModuleLoadError))+          Succeeded -> do+            {-modRes <- liftIO $ findImportedModule (hscEnv scriptSession) (mkModuleName "ProjectM36.Base") NoPkgQual+            liftIO $ case modRes of+              Found modLoc _mod -> do+                let packageLoc = takeDirectory (takeDirectory (takeDirectory (ml_dyn_obj_file modLoc)))+                putStrLn packageLoc+              NoPackage{} -> error "no package"+              FoundMultiple{} -> error "multiple matches"+              NotFound{} -> error "not found"-}+            modGraph <- depanal [] False+            case mgModSummaries modGraph of+              [] -> pure (Left (ScriptError ModuleLoadError))+              (modSummary:_) -> do+                let modName = ms_mod_name modSummary+                    modModS = "ProjectM36.Module"+                    modModName = mkModuleName modModS +                    pm36FuncName = "projectM36Functions"+                    occName = mkVarOcc pm36FuncName+                    occExpectedType = mkTcOcc "EntryPoints"+                setContext [IIModule modName,+                            IIDecl $ safeImportDecl "ProjectM36.Base" Nothing+                           ]+                +                userModule <- findModule modName Nothing+                moduleModule <- findModule modModName Nothing+                (_msgs, Just (entrypointFunc, entryPointsMonadName)) <- liftIO $ runTcInteractive (hscEnv scriptSession) $ do+                  pm36Name <- lookupOrig userModule occName+                  entryPointsName <- lookupOrig moduleModule occExpectedType+                  pure (pm36Name, entryPointsName)+                monadTy <- lookupName entryPointsMonadName+                let unexpectedEP s = throw (ScriptError (OtherScriptCompilationError ("expected " <> pm36FuncName <> " signature: " <> s)))+                entryPointsTyCon <- case monadTy of+                                         Just (ATyCon tc) -> pure $ mkTyConApp tc [unitTy]+                                         Just (AnId _tc) -> unexpectedEP "AnId"+                                         Just (AConLike _clike) -> unexpectedEP "AConLike"+                                         Just (ACoAxiom _cax) -> unexpectedEP "ACoAxiom"+                                         Nothing -> unexpectedEP "missing"+                tyThing <- lookupName entrypointFunc+                case tyThing of+                      Just (ATyCon _iCon) -> unexpectedEP "ATyCon"+                      Just (ACoAxiom _) -> unexpectedEP "ACoAxoim"+                      --run the entrypoints monad+                      Just (AnId aid)+                        | getOccString aid == pm36FuncName ->+                            -- typecheck entrypoint function+                            if idType aid `eqType` entryPointsTyCon then do+                              -- call entrypoint+                              result <- compileExpr pm36FuncName+                              let funcDeclarations = runEntryPoints (unsafeCoerce result)+                              tyConv <- mkTypeConversions                              +                              mkFunctions <- forM funcDeclarations $ \funcDecl -> do+                                  case funcDecl of+                                    DeclareDatabaseContextFunction funcS acl' -> do+                                      fType <- exprType TM_Default (T.unpack funcS)+                                      dbcFuncMonadType <- exprType TM_Default "undefined :: DatabaseContextFunctionMonad ()"                                      +                                      -- extract arguments for dbc function+                                      let eAtomFuncType = convertGhcTypeToDatabaseContextFunctionAtomType dflags tyConv dbcFuncMonadType fType+                                      case eAtomFuncType of+                                        Left err -> throw (OtherScriptCompilationError (show err))+                                        Right dbcFuncType -> do+                                          let interpretedFunc = wrapDatabaseContextFunction dbcFuncType funcS+                                          dbcFunc :: DatabaseContextFunctionBodyType <- unsafeCoerce <$> compileExpr interpretedFunc+                                          let newDBCFunc = Function { funcName = funcS,+                                                                            funcType = dbcFuncType,+                                                                            funcBody = FunctionScriptBody (T.pack interpretedFunc) dbcFunc,+                                                                            funcACL = acl' }+                                          pure (MkDatabaseContextFunction newDBCFunc)+                                    DeclareAtomFunction funcS -> do+                                      --extract type from function in script+                                      fType <- exprType TM_Default (T.unpack funcS)+                                      let eAtomFuncType = convertGhcTypeToFunctionAtomType dflags tyConv fType +                                      --liftIO $ print eAtomFuncType+                                      --liftIO $ putStrLn $ showSDocForUser dflags emptyUnitState alwaysQualify (ppr fType)+                                      case eAtomFuncType of+                                        Left err -> error (show err)+                                        Right atomFuncType -> do+                                          let eInterpretedFunc = wrapAtomFunction atomFuncType funcS+                                          --liftIO $ print eInterpretedFunc+                                          case eInterpretedFunc of+                                            Left err -> error (show err)+                                            Right interpretedFunc -> do+                                              atomFunc :: AtomFunctionBodyType <- unsafeCoerce <$> compileExpr interpretedFunc+                                              --todo - return atom functions and dbc functions out of Ghc monad to add them to the context+                                              let newAtomFunc = Function { funcName = funcS,+                                                                           funcType = atomFuncType,+                                                                           funcBody = FunctionScriptBody (T.pack interpretedFunc) atomFunc,+                                                                           funcACL = def }+                                              --let execd = atomFunc [IntegerAtom 10, IntegerAtom 20]+                                              --liftIO $ print execd++                                              pure (MkAtomFunction newAtomFunc)+                              pure (Right mkFunctions)+                              else+                              unexpectedEP "type mismatch"+                      Just AnId{} -> unexpectedEP "AnId"+                      Just AConLike{} -> unexpectedEP "AConLike"+                      Nothing -> unexpectedEP "Nothing"+  case res of+      Left exc -> throwError exc+      Right eMkFunctions ->+        case eMkFunctions of+          Left err -> throwError err+          Right mkFunctions -> do+            ctx <- getDBCIOContext+            atomFuncs <- resolveIODBC atomFunctions+            dbcFuncs <- resolveIODBC dbcFunctions+            let foldMkFunction (atomFuncHS, dbcFuncHS) (MkAtomFunction atomFunc) =+                  (HS.insert atomFunc atomFuncHS, dbcFuncHS)+                foldMkFunction (atomFuncHS, dbcFuncHS) (MkDatabaseContextFunction dbcFunc) =+                  (atomFuncHS, HS.insert dbcFunc dbcFuncHS)+                (newAtomFuncs, newDBCFuncs) = foldl' foldMkFunction (mempty, mempty) mkFunctions+                ctx' = ctx { dbcFunctions = ValueMarker $ HS.union newDBCFuncs dbcFuncs,+                             atomFunctions = ValueMarker $ HS.union newAtomFuncs atomFuncs+                           }++            putDBCIOContext ctx'+#endif++data MkFunction = MkAtomFunction AtomFunction |+                  MkDatabaseContextFunction DatabaseContextFunction 

@@ -1,12 +1,15 @@ {-# LANGUAGE UnboxedTuples, KindSignatures, DataKinds #-} #ifdef PM36_HASKELL_SCRIPTING {-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-} #endif module ProjectM36.ScriptSession where  #ifdef PM36_HASKELL_SCRIPTING import ProjectM36.Error+import ProjectM36.Base import GHC+import GHC.Core.TyCo.Rep import Control.Exception import Control.Monad import System.IO.Error@@ -22,65 +25,33 @@  import Unsafe.Coerce import GHC.LanguageExtensions (Extension(OverloadedStrings,ExtendedDefaultRules,ImplicitPrelude,ScopedTypeVariables))-#if MIN_VERSION_ghc(9,6,0)+-- GHC 9.4+ import Data.List.NonEmpty(NonEmpty(..))-#else-#endif-#if MIN_VERSION_ghc(9,6,0)-#else-#endif-#if MIN_VERSION_ghc(9,6,0)-import GHC.Core.TyCo.Compare (eqType)-#elif MIN_VERSION_ghc(9,0,0)-import GHC.Core.Type (eqType)-#else-import Type (eqType)-#endif-#if MIN_VERSION_ghc(9,6,0)-#elif MIN_VERSION_ghc(9,0,0)-import GHC.Unit.Types (IsBootInterface(NotBoot))-#else-#endif-#if MIN_VERSION_ghc(9,4,0) import GHC.Utils.Panic (handleGhcException) import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming)) import GHC.Types.SourceText (SourceText(NoSourceText)) import GHC.Driver.Ppr (showSDocForUser)+import GHC.Utils.Outputable (ppr, Outputable)+--import GHC.Unit.Module.Graph (showModMsg, mgModSummaries') import GHC.Core.TyCo.Ppr (pprType) import GHC.Utils.Encoding (zEncodeString) import GHC.Unit.State (emptyUnitState) import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual))-#elif MIN_VERSION_ghc(9,2,0)--- GHC 9.2.2-import GHC.Utils.Panic (handleGhcException)-import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming))-import GHC.Types.SourceText (SourceText(NoSourceText))-import GHC.Driver.Ppr (showSDocForUser)-import GHC.Types.TyThing.Ppr (pprTypeForUser)-import GHC.Utils.Encoding (zEncodeString)-import GHC.Unit.State (emptyUnitState)-#elif MIN_VERSION_ghc(9,0,0)--- GHC 9.0.0-import GHC.Utils.Panic (handleGhcException)-import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming))-import GHC.Types.Basic (SourceText(NoSourceText))-import GHC.Utils.Outputable (showSDocForUser)-import GHC.Utils.Encoding (zEncodeString)-import GHC.Core.Ppr.TyThing (pprTypeForUser)-#else--- GHC 8.10.7-import BasicTypes (SourceText(NoSourceText))-import Outputable (showSDocForUser)-import PprTyThing (pprTypeForUser)-import Encoding (zEncodeString)-import Panic (handleGhcException)-import DynFlags (projectVersion, PkgConfRef(PkgConfFile), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming), PackageDBFlag(PackageDB))-#endif- import GHC.Exts (addrToAny#) import GHC.Ptr (Ptr(..)) import GHCi.ObjLink (initObjLinker, ShouldRetainCAFs(RetainCAFs), resolveObjs, lookupSymbol, loadDLL, loadObj)+--import GHC.Builtin.Types (integerTyCon, intTyCon, doubleTyCon, eqTyCon)+--import qualified Data.Map as M+import Data.List (find)+import qualified Control.Monad.Catch as CMC++#if MIN_VERSION_ghc(9,6,0)+import GHC.Core.TyCo.Compare (eqType)+import GHC.Unit.Types (UnitId)+import GHC.Driver.Env (hsc_home_unit)+import GHC.Unit.Home (homeUnitId) #endif+#endif -- endif for SCRIPTING FLAG  data ScriptSession = ScriptSession {@@ -179,8 +150,36 @@         packages = map (\m -> ExposePackage ("-package " ++ m) (PackageArg m) (ModRenaming True [])) required_packages   --liftIO $ traceShowM (showSDoc dflags' (ppr packages))     _ <- setSessionDynFlags dflags'-    let safeImportDecl :: String -> Maybe String -> ImportDecl (GhcPass 'Parsed)-        safeImportDecl fullModuleName _mQualifiedName = ImportDecl {+    let unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl modn Nothing) [+          "Prelude",+          "Data.Map",+          "Data.Either",+          "Data.Time.Calendar",+--          "Data.Scientific",+          "Control.Monad.State",+          "ProjectM36.Base",+          "ProjectM36.Error",+          "ProjectM36.Relation",+          "ProjectM36.DatabaseContext",+          "ProjectM36.DatabaseContext.Types",+          "ProjectM36.AtomFunctionError",+          "ProjectM36.RelationalExpression"]+        qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl modn (Just qualNam)) [+          ("Data.Text", "T")+          ]+    setContext (unqualifiedModules ++ qualifiedModules)+    env <- getSession+{-    case mgLookupModule (mkModuleName "ProjectM36") moduleInfos of+       Nothing -> error "failed to load project-m36 module"+       Just moduleInfo ->+  -}        +    atomFuncType <- mkTypeForName "AtomFunctionBodyType"+    dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"++    pure (Right (ScriptSession env atomFuncType dbcFuncType))++safeImportDecl :: String -> Maybe String -> ImportDecl (GhcPass 'Parsed)+safeImportDecl fullModuleName _mQualifiedName = ImportDecl { #if MIN_VERSION_ghc(9,6,0) #else           ideclSourceSrc = NoSourceText,@@ -237,28 +236,8 @@ #endif           ideclSafe      = True           }-        unqualifiedModules = map (\modn -> IIDecl $ safeImportDecl modn Nothing) [-          "Prelude",-          "Data.Map",-          "Data.Either",-          "Data.Time.Calendar",-          "Control.Monad.State",-          "ProjectM36.Base",-          "ProjectM36.Error",-          "ProjectM36.Relation",-          "ProjectM36.DatabaseContext",-          "ProjectM36.DatabaseContext.Types",-          "ProjectM36.AtomFunctionError",-          "ProjectM36.RelationalExpression"]-        qualifiedModules = map (\(modn, qualNam) -> IIDecl $ safeImportDecl modn (Just qualNam)) [-          ("Data.Text", "T")-          ]-    setContext (unqualifiedModules ++ qualifiedModules)-    env <- getSession-    atomFuncType <- mkTypeForName "AtomFunctionBodyType"-    dbcFuncType <- mkTypeForName "DatabaseContextFunctionBodyType"-    pure (Right (ScriptSession env atomFuncType dbcFuncType)) + addImport :: String -> Ghc () addImport moduleNam = do   ctx <- getContext@@ -294,9 +273,9 @@         Just _ -> error ("failed to find type synonym " ++ name)  compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)-compileScript funcType script = do+compileScript funcType' script = do   let sScript = unpack script-  mErr <- typeCheckScript funcType script+  mErr <- typeCheckScript funcType' script   case mErr of     Just err -> pure (Left err)     Nothing ->@@ -309,12 +288,12 @@ typeCheckScript expectedType inp = do   dflags <- getSessionDynFlags   --catch exception for SyntaxError-  funcType <- GHC.exprType TM_Inst (unpack inp)+  funcType' <- GHC.exprType TM_Inst (unpack inp)   --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType-  if eqType funcType expectedType then+  if eqType funcType' expectedType then     pure Nothing     else-    pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))+    pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType')))  mangleSymbol :: Maybe String -> String -> String -> String mangleSymbol pkg module' valsym =@@ -335,20 +314,20 @@ type ModuleDirectory = FilePath  loadFunctionFromDirectory :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> FilePath -> IO (Either LoadSymbolError a)-loadFunctionFromDirectory mode modName funcName modDir objPath =+loadFunctionFromDirectory mode modName funcName' modDir objPath =   if takeFileName objPath /= objPath then     pure (Left SecurityLoadSymbolError)   else     let fullObjPath = modDir </> objPath in-      loadFunction mode modName funcName fullObjPath+      loadFunction mode modName funcName' fullObjPath   loadFunction :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)-loadFunction loadMode modName funcName objPath = do+loadFunction loadMode modName funcName' objPath = do   initObjLinker RetainCAFs   let loadFuncForSymbol = do             _ <- resolveObjs-        ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)+        ptr <- lookupSymbol (mangleSymbol Nothing modName funcName')         case ptr of           Nothing -> pure (Left LoadSymbolError)           Just (Ptr addr) -> case addrToAny# addr of@@ -356,17 +335,24 @@   case loadMode of     LoadAutoObjectFile ->       if takeExtension objPath == ".o" then-          loadFunction LoadObjectFile modName funcName objPath+          loadFunction LoadObjectFile modName funcName' objPath         else-          loadFunction LoadDLLFile modName funcName objPath+          loadFunction LoadDLLFile modName funcName' objPath     LoadObjectFile -> do       loadObj objPath       loadFuncForSymbol     LoadDLLFile -> do+#if MIN_VERSION_ghc(9,10,2)+      eErr <- loadDLL objPath+      case eErr of+        Left _err -> pure (Left LoadSymbolError)+        Right _ptr -> loadFuncForSymbol+#else       mErr <- loadDLL objPath       case mErr of         Just _ -> pure (Left LoadSymbolError)         Nothing -> loadFuncForSymbol+#endif  prefixUnderscore :: String prefixUnderscore =@@ -377,4 +363,70 @@       ("darwin",_) -> "_"       ("cygwin",_) -> "_"       _ -> ""++getHomeUnitId :: ScriptSession -> UnitId+getHomeUnitId sSession =+  homeUnitId (hsc_home_unit (hscEnv sSession))++data TypeConversionError = UnsupportedTypeConversionError String+  deriving Show++mkTypeConversions :: GhcMonad m => m [(Type, AtomType)]+mkTypeConversions = do+  let extTypes = [("Integer", IntegerAtomType),+                  ("Int", IntAtomType),+                  ("Double", DoubleAtomType),+                  ("Scientific", ScientificAtomType), -- found in multiple modules?+                  ("Text", TextAtomType),+                  ("Day", DayAtomType),+                  ("UTCTime", DateTimeAtomType),+                  ("ByteString", ByteStringAtomType),+                  ("Bool", BoolAtomType),+                  ("UUID", UUIDAtomType)+                 ]+  res <- forM extTypes $ \(nam, typ) -> do+    -- extract type from bottom value+    ghcType <- (Just <$> exprType TM_Default ("undefined :: " <> nam)) `CMC.catch` (\(_ :: SomeException) -> pure Nothing)+    pure (ghcType, typ)+  let mapFilter (Nothing, _) = Nothing+      mapFilter (Just t, at) = Just (t, at)+  pure (mapMaybe mapFilter res)+                                +convertGhcTypeToFunctionAtomType :: DynFlags -> [(Type, AtomType)] -> Type -> Either TypeConversionError [AtomType]+convertGhcTypeToFunctionAtomType dflags tyConv typ =+  case typ of+    TyConApp _tycon _args -> do+      aType <- findTypeConv dflags typ tyConv+      pure [aType]+    fun@FunTy{} -> do+      arg <- convertGhcTypeToFunctionAtomType dflags tyConv (ft_arg fun)+      rest <- convertGhcTypeToFunctionAtomType dflags tyConv (ft_res fun)+      pure (arg <> rest)+    other -> Left (UnsupportedTypeConversionError (pprShow other dflags))++    +pprShow :: Outputable a => a -> DynFlags -> String+pprShow x dflags = showSDocForUser dflags emptyUnitState alwaysQualify (ppr x)++findTypeConv :: DynFlags -> Type -> [(Type, AtomType)] -> Either TypeConversionError AtomType+findTypeConv dflags typ tyConv =+  case find (\(k,_v) -> k `eqType` typ) tyConv of+    Nothing -> Left (UnsupportedTypeConversionError (pprShow typ dflags))+    Just (_,match') -> +      pure match'++-- | Last argument should be `DatabaseContextFunctionMonad ()`+convertGhcTypeToDatabaseContextFunctionAtomType :: DynFlags -> [(Type, AtomType)] -> Type -> Type -> Either TypeConversionError [AtomType]+convertGhcTypeToDatabaseContextFunctionAtomType dflags tyConv dbcFuncMonadType typ =+  case typ of+    TyConApp{} |+      typ `eqType` dbcFuncMonadType -> pure []+    TyConApp{} -> do+      aType <- findTypeConv dflags typ tyConv+      pure [aType]+    fun@FunTy{} -> do+      arg <- convertGhcTypeToDatabaseContextFunctionAtomType dflags tyConv dbcFuncMonadType (ft_arg fun)+      rest <- convertGhcTypeToDatabaseContextFunctionAtomType dflags tyConv dbcFuncMonadType (ft_res fun)+      pure (arg <> rest)+    other -> Left (UnsupportedTypeConversionError (pprShow other dflags)) #endif

@@ -16,7 +16,6 @@ import ProjectM36.DatabaseContext.Types import ProjectM36.IsomorphicSchema.Types hiding (concreteDatabaseContext, subschemas) import ProjectM36.DatabaseContextFunctions.Basic-import ProjectM36.AtomFunction import ProjectM36.Persist (DiskSync, renameSync, writeSerialiseSync, readDeserialise) import ProjectM36.Function import ProjectM36.AccessControlList@@ -48,6 +47,7 @@ import GHC import Control.Exception import GHC.Paths+import ProjectM36.AtomFunction #endif  xattrName :: String

@@ -9,7 +9,7 @@ import ProjectM36.Relation import ProjectM36.Base import Data.Time.Calendar (fromGregorian)-import Data.Text+import Data.Text (Text) import qualified Data.Map as M import Data.Proxy import Codec.Winery

@@ -13,7 +13,7 @@ import Control.Concurrent import System.Exit import Data.Typeable-import Data.Text hiding (map)+import Data.Text (Text) import Data.Aeson import qualified Data.ByteString.Lazy as BS import ProjectM36.Relation

@@ -0,0 +1,46 @@+-- | Test import via ProjectM36.Module which allows a user to import any number of atom functions or database context functions.+{-# LANGUAGE CPP #-}+import System.Exit+import Test.HUnit+#ifdef PM36_HASKELL_SCRIPTING+import Data.Time.Calendar+import TutorialD.Interpreter.TestBase+import ProjectM36.Client+import qualified ProjectM36.Attribute as A+import ProjectM36.Relation+#endif++main :: IO ()+main = do+  tcounts <- runTestTT (TestList [+#ifdef PM36_HASKELL_SCRIPTING+    testImportModule+#endif                                  +    ])+  if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess+    +    +#ifdef PM36_HASKELL_SCRIPTING+testImportModule :: Test+testImportModule = TestCase $ do+  (sess, conn) <- dateExamplesConnection emptyNotificationCallback+  let importmodule = "loadmodulefromfile \"test/TutorialD/Interpreter/TestModule.hs\""+  executeTutorialD sess conn importmodule+  -- install relvar+  executeTutorialD sess conn "ticket_sales:=relation{ticketId Integer, visitorAge Integer, basePrice Integer, visitDate Day}"+  --execute the atom function in the module+  executeTutorialD sess conn "x:=relation{tuple{a applyDiscount(8,20)}}"+  eres <- executeRelationalExpr sess conn (RelationVariable "x" ())+  let expectedres = mkRelationFromList (A.attributesFromList [Attribute "a" IntegerAtomType]) [[IntegerAtom 10]]+  assertEqual "x applyDiscount" expectedres eres++  --execute the dbc function in the module+  executeTutorialD sess conn "execute addSale(1,8,20,fromGregorian(2025, 10, 3))"+  let salesAttrs = A.attributesFromList [Attribute "ticketId" IntegerAtomType,+                                         Attribute "visitorAge" IntegerAtomType,+                                         Attribute "basePrice" IntegerAtomType,+                                         Attribute "visitDate" DayAtomType]+  let expectedres' = mkRelationFromList salesAttrs [[IntegerAtom 1, IntegerAtom 8, IntegerAtom 10, DayAtom (fromGregorian 2025 10 03)]]+  eres' <- executeRelationalExpr sess conn (RelationVariable "ticket_sales" ())+  assertEqual "ticket_sales addSale" expectedres' eres'+#endif

@@ -5,7 +5,7 @@ import ProjectM36.DateExamples import ProjectM36.DatabaseContextExpr import Test.HUnit-import Data.Text+import Data.Text (Text, unpack) import System.Random (mkStdGen)  dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection)

@@ -101,7 +101,8 @@       testSubrelationAttributeAtomExpr,       testComplexTypeVarResolution,       testNotifications,-      testDBCFunctionAccessControl+      testDBCFunctionAccessControl,+      testAttributeTypeHintsFromExistingRelVar       ]  simpleRelTests :: Test@@ -950,3 +951,11 @@   -- check that the non-privileged role can run the dbc function   executeTutorialD session user1conn "execute deleteAll()"   +testAttributeTypeHintsFromExistingRelVar :: Test+testAttributeTypeHintsFromExistingRelVar = TestCase $ do+  (session, dbconn) <- dateExamplesConnection emptyNotificationCallback+  -- validate that declaring a relvar and then changing its type fails+  executeTutorialD session dbconn "x:=relation{a Integer}"+  let err1 = "RelationTypeMismatchError"+  expectTutorialDErr session dbconn (T.isPrefixOf err1) "x:=relation{tuple{a 3, b 4}}"+