diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -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 diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -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 diff --git a/examples/blog.hs b/examples/blog.hs --- a/examples/blog.hs +++ b/examples/blog.hs @@ -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)) diff --git a/examples/hair.hs b/examples/hair.hs --- a/examples/hair.hs +++ b/examples/hair.hs @@ -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 diff --git a/examples/zoo.hs b/examples/zoo.hs --- a/examples/zoo.hs +++ b/examples/zoo.hs @@ -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 diff --git a/project-m36.cabal b/project-m36.cabal --- a/project-m36.cabal +++ b/project-m36.cabal @@ -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 - diff --git a/src/bin/ProjectM36/Interpreter.hs b/src/bin/ProjectM36/Interpreter.hs --- a/src/bin/ProjectM36/Interpreter.hs +++ b/src/bin/ProjectM36/Interpreter.hs @@ -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 diff --git a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs --- a/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs +++ b/src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs @@ -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)) diff --git a/src/bin/benchmark/bigrel.hs b/src/bin/benchmark/bigrel.hs --- a/src/bin/benchmark/bigrel.hs +++ b/src/bin/benchmark/bigrel.hs @@ -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 diff --git a/src/lib/ProjectM36/AtomFunctionError.hs b/src/lib/ProjectM36/AtomFunctionError.hs --- a/src/lib/ProjectM36/AtomFunctionError.hs +++ b/src/lib/ProjectM36/AtomFunctionError.hs @@ -7,6 +7,7 @@ data AtomFunctionError = AtomFunctionUserError String | AtomFunctionTypeMismatchError | AtomFunctionParseError String | + AtomFunctionMissingReturnTypeError | InvalidIntervalOrderingError | InvalidIntervalBoundariesError | AtomFunctionAttributeNameNotFoundError Text | diff --git a/src/lib/ProjectM36/Base.hs b/src/lib/ProjectM36/Base.hs --- a/src/lib/ProjectM36/Base.hs +++ b/src/lib/ProjectM36/Base.hs @@ -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 { diff --git a/src/lib/ProjectM36/Error.hs b/src/lib/ProjectM36/Error.hs --- a/src/lib/ProjectM36/Error.hs +++ b/src/lib/ProjectM36/Error.hs @@ -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 diff --git a/src/lib/ProjectM36/Function.hs b/src/lib/ProjectM36/Function.hs --- a/src/lib/ProjectM36/Function.hs +++ b/src/lib/ProjectM36/Function.hs @@ -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]) + diff --git a/src/lib/ProjectM36/Module.hs b/src/lib/ProjectM36/Module.hs new file mode 100644 --- /dev/null +++ b/src/lib/ProjectM36/Module.hs @@ -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' diff --git a/src/lib/ProjectM36/NormalizeExpr.hs b/src/lib/ProjectM36/NormalizeExpr.hs --- a/src/lib/ProjectM36/NormalizeExpr.hs +++ b/src/lib/ProjectM36/NormalizeExpr.hs @@ -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 diff --git a/src/lib/ProjectM36/RelationalExpression.hs b/src/lib/ProjectM36/RelationalExpression.hs --- a/src/lib/ProjectM36/RelationalExpression.hs +++ b/src/lib/ProjectM36/RelationalExpression.hs @@ -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 diff --git a/src/lib/ProjectM36/ScriptSession.hs b/src/lib/ProjectM36/ScriptSession.hs --- a/src/lib/ProjectM36/ScriptSession.hs +++ b/src/lib/ProjectM36/ScriptSession.hs @@ -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 diff --git a/src/lib/ProjectM36/Transaction/Persist.hs b/src/lib/ProjectM36/Transaction/Persist.hs --- a/src/lib/ProjectM36/Transaction/Persist.hs +++ b/src/lib/ProjectM36/Transaction/Persist.hs @@ -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 diff --git a/test/Relation/Atomable.hs b/test/Relation/Atomable.hs --- a/test/Relation/Atomable.hs +++ b/test/Relation/Atomable.hs @@ -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 diff --git a/test/Server/WebSocket.hs b/test/Server/WebSocket.hs --- a/test/Server/WebSocket.hs +++ b/test/Server/WebSocket.hs @@ -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 diff --git a/test/TutorialD/Interpreter/Module.hs b/test/TutorialD/Interpreter/Module.hs new file mode 100644 --- /dev/null +++ b/test/TutorialD/Interpreter/Module.hs @@ -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 diff --git a/test/TutorialD/Interpreter/TestBase.hs b/test/TutorialD/Interpreter/TestBase.hs --- a/test/TutorialD/Interpreter/TestBase.hs +++ b/test/TutorialD/Interpreter/TestBase.hs @@ -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) diff --git a/test/TutorialD/InterpreterTest.hs b/test/TutorialD/InterpreterTest.hs --- a/test/TutorialD/InterpreterTest.hs +++ b/test/TutorialD/InterpreterTest.hs @@ -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}}" +