git.iko.soy/project-m36
on master help sign in
make linking against GHC optional to save space
f66c404AgentM
project-m36.cabal+17−7
compare with master
unifiedsplit
@@ -28,8 +28,19 @@ Flag stack
28 Manual: True
28 Manual: True
29 Default: False
29 Default: False
30
30
31+Flag haskell-scripting
32+ Description: enables Haskell scripting which links against GHC as a library
33+ Manual: True
34+ Default: True
35+
31Library
36Library
32− Build-Depends: base>=4.8 && < 4.13, ghc >= 8.2 && < 8.7, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256
37+ Build-Depends: base>=4.8 && < 4.13, ghc-paths, mtl, containers, unordered-containers, hashable, haskeline, directory, MonadRandom, random-shuffle, uuid >= 1.3.12, cassava >= 0.4.5.1 && < 0.6, text, bytestring, deepseq, deepseq-generics, vector, parallel, monad-parallel, exceptions, transformers, gnuplot, binary, filepath, zlib, directory, vector-binary-instances, temporary, stm, time, hashable-time, old-locale, rset, attoparsec, either, base64-bytestring, data-interval, extended-reals, network-transport, aeson >= 1.1, path-pieces, conduit, resourcet, http-api-data, semigroups, QuickCheck, quickcheck-instances, distributed-process-client-server >= 0.2.3, distributed-process >= 0.7.4, distributed-process-extras >= 0.3.2, distributed-process-async >= 0.2.4.1, network-transport-tcp >= 0.6.0, network-transport, list-t, stm-containers >= 0.2.15, foldl, optparse-applicative, Glob, cryptohash-sha256
38+ if flag(haskell-scripting)
39+ Build-Depends: ghc >= 8.2 && < 8.7
40+ CPP-Options: -DPM36_HASKELL_SCRIPTING
41+ if impl(ghc>= 8) && flag(haskell-scripting)
42+ build-depends:
43+ ghc-boot, ghci
33 if impl(ghc>= 8.6)
44 if impl(ghc>= 8.6)
34 Build-Depends: deferred-folds
45 Build-Depends: deferred-folds
35 Exposed-Modules: ProjectM36.Error,
46 Exposed-Modules: ProjectM36.Error,
@@ -118,15 +129,13 @@ Library
118 Hs-Source-Dirs: ./src/lib
129 Hs-Source-Dirs: ./src/lib
119 Default-Language: Haskell2010
130 Default-Language: Haskell2010
120 Default-Extensions: OverloadedStrings, CPP
131 Default-Extensions: OverloadedStrings, CPP
121− if impl(ghc>= 8)
122− build-depends:
123− ghc-boot, ghci
124− if !flag(stack)
132+ if !flag(stack)
125 Build-Depends: deferred-folds
133 Build-Depends: deferred-folds
126
134
127Executable tutd
135Executable tutd
136+ if flag(haskell-scripting)
137+ Build-Depends: ghc >= 8.2 && < 8.7
128 Build-Depends: base >=4.8 && <5.0,
138 Build-Depends: base >=4.8 && <5.0,
129− ghc >= 7.8 && < 8.7,
130 ghc-paths,
139 ghc-paths,
131 project-m36,
140 project-m36,
132 containers,
141 containers,
@@ -189,8 +198,9 @@ Executable tutd
189 Default-Extensions: OverloadedStrings
198 Default-Extensions: OverloadedStrings
190
199
191Executable project-m36-server
200Executable project-m36-server
201+ if flag(haskell-scripting)
202+ Build-Depends: ghc >= 8.2 && < 8.7
192 Build-Depends: base,
203 Build-Depends: base,
193− ghc >= 7.8 && < 8.7,
194 ghc-paths,
204 ghc-paths,
195 project-m36,
205 project-m36,
196 binary,
206 binary,
src/lib/ProjectM36/AtomFunction.hs+6−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1module ProjectM36.AtomFunction where
2module ProjectM36.AtomFunction where
2import ProjectM36.Base
3import ProjectM36.Base
3import ProjectM36.Error
4import ProjectM36.Error
@@ -72,7 +73,11 @@ createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName
72 retType]])
73 retType]])
73
74
74loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])
75loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])
76+#ifdef PM36_HASKELL_SCRIPTING
75loadAtomFunctions = loadFunction
77loadAtomFunctions = loadFunction
78+#else
79+loadAtomFunctions _ _ _ = pure (Left LoadSymbolError)
80+#endif
76
81
77atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation
82atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation
78atomFunctionsAsRelation funcs = mkRelationFromList attrs tups
83atomFunctionsAsRelation funcs = mkRelationFromList attrs tups
@@ -81,4 +86,4 @@ atomFunctionsAsRelation funcs = mkRelationFromList attrs tups
81 Attribute "arguments" TextAtomType]
86 Attribute "arguments" TextAtomType]
82 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),
87 atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),
83 TextAtom (atomFuncTypeToText aFunc)]
88 TextAtom (atomFuncTypeToText aFunc)]
84− atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))
89+ atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))
src/lib/ProjectM36/DatabaseContextFunction.hs+5
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1module ProjectM36.DatabaseContextFunction where
2module ProjectM36.DatabaseContextFunction where
2--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
3--implements functions which operate as: [Atom] -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
3import ProjectM36.Base
4import ProjectM36.Base
@@ -61,7 +62,11 @@ createScriptedDatabaseContextFunction :: DatabaseContextFunctionName -> [TypeCon
61createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])
62createScriptedDatabaseContextFunction funcName argsIn retArg = AddDatabaseContextFunction funcName (argsIn ++ [databaseContextFunctionReturnType retArg])
62
63
63loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction])
64loadDatabaseContextFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [DatabaseContextFunction])
65+#ifdef PM36_HASKELL_SCRIPTING
64loadDatabaseContextFunctions = loadFunction
66loadDatabaseContextFunctions = loadFunction
67+#else
68+loadDatabaseContextFunctions _ _ _ = pure (Left LoadSymbolError)
69+#endif
65
70
66databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation
71databaseContextFunctionsAsRelation :: DatabaseContextFunctions -> Either RelationalError Relation
67databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups
72databaseContextFunctionsAsRelation dbcFuncs = mkRelationFromList attrs tups
src/lib/ProjectM36/RelationalExpression.hs+12−1
@@ -17,7 +17,6 @@ import qualified Data.Map as M
17import qualified Data.HashSet as HS
17import qualified Data.HashSet as HS
18import qualified Data.Set as S
18import qualified Data.Set as S
19import Control.Monad.State hiding (join)
19import Control.Monad.State hiding (join)
20−import Control.Exception
21import Data.Maybe
20import Data.Maybe
22import Data.Either
21import Data.Either
23import Data.Char (isUpper)
22import Data.Char (isUpper)
@@ -27,8 +26,13 @@ import qualified ProjectM36.TypeConstructorDef as TCD
27import Control.Monad.Trans.Except
26import Control.Monad.Trans.Except
28import Control.Monad.Trans.Reader
27import Control.Monad.Trans.Reader
29import Test.QuickCheck
28import Test.QuickCheck
29+
30+#ifdef PM36_HASKELL_SCRIPTING
30import GHC
31import GHC
32+import Control.Exception
31import GHC.Paths
33import GHC.Paths
34+#endif
35+
32
36
33data DatabaseContextExprDetails = CountUpdatedTuples
37data DatabaseContextExprDetails = CountUpdatedTuples
34
38
@@ -520,6 +524,12 @@ evalDatabaseContextExpr (ExecuteDatabaseContextFunction funcName atomArgExprs) =
520 Right newContext -> putStateContext newContext >> pure (Right ())
524 Right newContext -> putStateContext newContext >> pure (Right ())
521
525
522evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
526evalDatabaseContextIOExpr :: Maybe ScriptSession -> DatabaseContext -> DatabaseContextIOExpr -> IO (Either RelationalError DatabaseContext)
527+#if !defined(PM36_HASKELL_SCRIPTING)
528+evalDatabaseContextIOExpr _ _ AddAtomFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
529+evalDatabaseContextIOExpr _ _ AddDatabaseContextFunction{} = pure (Left (ScriptError ScriptCompilationDisabledError))
530+evalDatabaseContextIOExpr _ _ LoadAtomFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
531+evalDatabaseContextIOExpr _ _ LoadDatabaseContextFunctions{} = pure (Left (ScriptError ScriptCompilationDisabledError))
532+#else
523evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =
533evalDatabaseContextIOExpr mScriptSession currentContext (AddAtomFunction funcName funcType script) =
524 case mScriptSession of
534 case mScriptSession of
525 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
535 Nothing -> pure (Left (ScriptError ScriptCompilationDisabledError))
@@ -605,6 +615,7 @@ evalDatabaseContextIOExpr _ currentContext (LoadDatabaseContextFunctions modName
605 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
615 Right dbcListFunc -> let newContext = currentContext { dbcFunctions = mergedFuncs }
606 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
616 mergedFuncs = HS.union (dbcFunctions currentContext) (HS.fromList dbcListFunc)
607 in pure (Right newContext)
617 in pure (Right newContext)
618+#endif
608
619
609evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =
620evalDatabaseContextIOExpr _ currentContext (CreateArbitraryRelation relVarName attrExprs range) =
610 --Define
621 --Define
src/lib/ProjectM36/ScriptSession.hs+25−11
@@ -1,8 +1,12 @@
1−{-# LANGUAGE MagicHash, UnboxedTuples, KindSignatures, DataKinds #-}
1+{-# LANGUAGE UnboxedTuples, KindSignatures, DataKinds #-}
2+#ifdef PM36_HASKELL_SCRIPTING
3+{-# LANGUAGE MagicHash #-}
4+#endif
2module ProjectM36.ScriptSession where
5module ProjectM36.ScriptSession where
3
6
7+#ifdef PM36_HASKELL_SCRIPTING
4import ProjectM36.Error
8import ProjectM36.Error
5−
9+import GHC
6import Control.Exception
10import Control.Exception
7import Control.Monad
11import Control.Monad
8import System.IO.Error
12import System.IO.Error
@@ -13,8 +17,6 @@ import System.FilePath
13import System.Info (os, arch)
17import System.Info (os, arch)
14import Data.Text (Text, unpack)
18import Data.Text (Text, unpack)
15import Data.Maybe
19import Data.Maybe
16−
17−import GHC
18import GHC.Paths (libdir)
20import GHC.Paths (libdir)
19#if __GLASGOW_HASKELL__ >= 800
21#if __GLASGOW_HASKELL__ >= 800
20import GHC.LanguageExtensions
22import GHC.LanguageExtensions
@@ -36,22 +38,38 @@ import Type
36import Type hiding (pprTyThing)
38import Type hiding (pprTyThing)
37#else
39#else
38#endif
40#endif
39−
40import GHC.Exts (addrToAny#)
41import GHC.Exts (addrToAny#)
41import GHC.Ptr (Ptr(..))
42import GHC.Ptr (Ptr(..))
42import Encoding
43import Encoding
44+#endif
45+
43
46
44data ScriptSession = ScriptSession {
47data ScriptSession = ScriptSession {
48+#ifdef PM36_HASKELL_SCRIPTING
45 hscEnv :: HscEnv,
49 hscEnv :: HscEnv,
46 atomFunctionBodyType :: Type,
50 atomFunctionBodyType :: Type,
47 dbcFunctionBodyType :: Type
51 dbcFunctionBodyType :: Type
52+#endif
48 }
53 }
49
54
55+#ifdef PM36_HASKELL_SCRIPTING
50−newtype ScriptSessionError = ScriptSessionLoadError GhcException
56+data ScriptSessionError = ScriptSessionLoadError GhcException
57+ | ScriptingDisabled
51 deriving (Show)
58 deriving (Show)
59+#else
60+data ScriptSessionError = ScriptingDisabled
61+ deriving (Show)
62+#endif
63+
64+data LoadSymbolError = LoadSymbolError
65+type ModName = String
66+type FuncName = String
52
67
53-- | Configure a GHC environment/session which we will use for all script compilation.
68-- | Configure a GHC environment/session which we will use for all script compilation.
54initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)
69initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)
70+#if !defined(PM36_HASKELL_SCRIPTING)
71+initScriptSession _ = pure (Left ScriptingDisabled)
72+#else
55initScriptSession ghcPkgPaths = do
73initScriptSession ghcPkgPaths = do
56 --for the sake of convenience, for developers' builds, include the local cabal sandbox package database and the cabal new-build package database
74 --for the sake of convenience, for developers' builds, include the local cabal sandbox package database and the cabal new-build package database
57 eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory
75 eHomeDir <- tryJust (guard . isDoesNotExistError) getHomeDirectory
@@ -223,11 +241,6 @@ mangleSymbol pkg module' valsym =
223 maybe "" (\p -> zEncodeString p ++ "_") pkg ++
241 maybe "" (\p -> zEncodeString p ++ "_") pkg ++
224 zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"
242 zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"
225
243
226−type ModName = String
227−type FuncName = String
228−
229−data LoadSymbolError = LoadSymbolError
230−
231loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)
244loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)
232loadFunction modName funcName objPath = do
245loadFunction modName funcName objPath = do
233#if __GLASGOW_HASKELL__ >= 802
246#if __GLASGOW_HASKELL__ >= 802
@@ -252,3 +265,4 @@ prefixUnderscore =
252 ("darwin",_) -> "_"
265 ("darwin",_) -> "_"
253 ("cygwin",_) -> "_"
266 ("cygwin",_) -> "_"
254 _ -> ""
267 _ -> ""
268+#endif
src/lib/ProjectM36/Transaction/Persist.hs+40−18
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TypeApplications #-}
1module ProjectM36.Transaction.Persist where
2module ProjectM36.Transaction.Persist where
2import ProjectM36.Base
3import ProjectM36.Base
3import ProjectM36.Error
4import ProjectM36.Error
@@ -15,13 +16,17 @@ import qualified Data.Text as T
15import Control.Monad
16import Control.Monad
16import ProjectM36.ScriptSession
17import ProjectM36.ScriptSession
17import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)
18import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)
18−import Control.Exception
19+
19−import GHC
20−import GHC.Paths
21import Codec.Compression.GZip
20import Codec.Compression.GZip
22import qualified Data.ByteString as BS
21import qualified Data.ByteString as BS
23import qualified Data.ByteString.Lazy as BSL
22import qualified Data.ByteString.Lazy as BSL
24
23
24+#ifdef PM36_HASKELL_SCRIPTING
25+import GHC
26+import Control.Exception
27+import GHC.Paths
28+#endif
29+
25getDirectoryNames :: FilePath -> IO [FilePath]
30getDirectoryNames :: FilePath -> IO [FilePath]
26getDirectoryNames path =
31getDirectoryNames path =
27 filter (\ n -> n `notElem` ["..", "."]) <$> getDirectoryContents path
32 filter (\ n -> n `notElem` ["..", "."]) <$> getDirectoryContents path
@@ -128,33 +133,40 @@ readAtomFuncs transDir mScriptSession = do
128 pure (HS.union precompiledAtomFunctions (HS.fromList funcs))
133 pure (HS.union precompiledAtomFunctions (HS.fromList funcs))
129
134
130loadAtomFunc :: AtomFunctions -> Maybe ScriptSession -> AtomFunctionName -> [AtomType] -> Maybe AtomFunctionBodyScript -> IO AtomFunction
135loadAtomFunc :: AtomFunctions -> Maybe ScriptSession -> AtomFunctionName -> [AtomType] -> Maybe AtomFunctionBodyScript -> IO AtomFunction
131−loadAtomFunc precompiledFuncs mScriptSession funcName funcType mFuncScript = case mFuncScript of
136+loadAtomFunc precompiledFuncs _mScriptSession funcName _funcType mFuncScript = case mFuncScript of
132 --handle pre-compiled case- pull it from the precompiled list
137 --handle pre-compiled case- pull it from the precompiled list
133 Nothing -> case atomFunctionForName funcName precompiledFuncs of
138 Nothing -> case atomFunctionForName funcName precompiledFuncs of
134 --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored
139 --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored
135 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)
140 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)
136 Right realFunc -> pure realFunc
141 Right realFunc -> pure realFunc
137 --handle a real Haskell scripted function- compile and load
142 --handle a real Haskell scripted function- compile and load
138− Just funcScript ->
143+ Just _funcScript ->
139− case mScriptSession of
144+#ifdef PM36_HASKELL_SCRIPTING
145+ case _mScriptSession of
140 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
146 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
141 Just scriptSession -> do
147 Just scriptSession -> do
142 --risk of GHC exception during compilation here
148 --risk of GHC exception during compilation here
143 eCompiledScript <- runGhc (Just libdir) $ do
149 eCompiledScript <- runGhc (Just libdir) $ do
144 setSession (hscEnv scriptSession)
150 setSession (hscEnv scriptSession)
145− compileScript (atomFunctionBodyType scriptSession) funcScript
151+ compileScript (atomFunctionBodyType scriptSession) _funcScript
146 case eCompiledScript of
152 case eCompiledScript of
147 Left err -> throwIO err
153 Left err -> throwIO err
148 Right compiledScript -> pure AtomFunction { atomFuncName = funcName,
154 Right compiledScript -> pure AtomFunction { atomFuncName = funcName,
149− atomFuncType = funcType,
155+ atomFuncType = _funcType,
150− atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }
156+ atomFuncBody = AtomFunctionBody (Just _funcScript) compiledScript }
157+#else
158+ error "Haskell scripting is disabled"
159+#endif
151
160
152--if the script session is enabled, compile the script, otherwise, hard error!
161--if the script session is enabled, compile the script, otherwise, hard error!
153
162
154readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction
163readAtomFunc :: FilePath -> AtomFunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction
164+#if !defined(PM36_HASKELL_SCRIPTING)
165+readAtomFunc _ _ _ _ = error "Haskell scripting is disabled"
166+#else
155readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
167readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
156 let atomFuncPath = atomFuncsPath transDir
168 let atomFuncPath = atomFuncsPath transDir
157− (funcType, mFuncScript) <- B.decodeFile atomFuncPath
169+ (funcType, mFuncScript) <- B.decodeFile @([AtomType],Maybe T.Text) atomFuncPath
158 case mFuncScript of
170 case mFuncScript of
159 --handle pre-compiled case- pull it from the precompiled list
171 --handle pre-compiled case- pull it from the precompiled list
160 Nothing -> case atomFunctionForName funcName precompiledFuncs of
172 Nothing -> case atomFunctionForName funcName precompiledFuncs of
@@ -162,7 +174,8 @@ readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
162 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)
174 Left _ -> error ("expected precompiled atom function: " ++ T.unpack funcName)
163 Right realFunc -> pure realFunc
175 Right realFunc -> pure realFunc
164 --handle a real Haskell scripted function- compile and load
176 --handle a real Haskell scripted function- compile and load
165− Just funcScript ->
177+ Just funcScript ->
178+
166 case mScriptSession of
179 case mScriptSession of
167 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
180 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
168 Just scriptSession -> do
181 Just scriptSession -> do
@@ -175,6 +188,7 @@ readAtomFunc transDir funcName mScriptSession precompiledFuncs = do
175 Right compiledScript -> pure AtomFunction { atomFuncName = funcName,
188 Right compiledScript -> pure AtomFunction { atomFuncName = funcName,
176 atomFuncType = funcType,
189 atomFuncType = funcType,
177 atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }
190 atomFuncBody = AtomFunctionBody (Just funcScript) compiledScript }
191+#endif
178
192
179
193
180writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()
194writeDBCFuncs :: DiskSync -> FilePath -> DatabaseContextFunctions -> IO ()
@@ -193,26 +207,34 @@ readDBCFuncs transDir mScriptSession = do
193 let funcs = mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames
207 let funcs = mapM ((\name -> readDBCFunc transDir name mScriptSession precompiledDatabaseContextFunctions) . T.pack) funcNames
194 HS.union basicDatabaseContextFunctions . HS.fromList <$> funcs
208 HS.union basicDatabaseContextFunctions . HS.fromList <$> funcs
195
209
196−readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction
210+readDBCFunc :: FilePath -> DatabaseContextFunctionName -> Maybe ScriptSession -> DatabaseContextFunctions -> IO DatabaseContextFunction
211+#if !defined(PM36_HASKELL_SCRIPTING)
212+readDBCFunc transDir funcName _ precompiledFuncs = do
213+#else
197readDBCFunc transDir funcName mScriptSession precompiledFuncs = do
214readDBCFunc transDir funcName mScriptSession precompiledFuncs = do
215+#endif
198 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName
216 let dbcFuncPath = dbcFuncsDir transDir </> T.unpack funcName
199− (funcType, mFuncScript) <- B.decodeFile dbcFuncPath
217+ (_funcType, mFuncScript) <- B.decodeFile @([AtomType], Maybe T.Text) dbcFuncPath
200 case mFuncScript of
218 case mFuncScript of
201 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of
219 Nothing -> case databaseContextFunctionForName funcName precompiledFuncs of
202 Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)
220 Left _ -> error ("expected precompiled dbc function: " ++ T.unpack funcName)
203 Right realFunc -> pure realFunc --return precompiled function
221 Right realFunc -> pure realFunc --return precompiled function
204− Just funcScript ->
222+ Just _funcScript ->
223+#ifdef PM36_HASKELL_SCRIPTING
205 case mScriptSession of
224 case mScriptSession of
206 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
225 Nothing -> error "attempted to read serialized AtomFunction without scripting enabled"
207 Just scriptSession -> do
226 Just scriptSession -> do
208 eCompiledScript <- runGhc (Just libdir) $ do
227 eCompiledScript <- runGhc (Just libdir) $ do
209 setSession (hscEnv scriptSession)
228 setSession (hscEnv scriptSession)
210− compileScript (dbcFunctionBodyType scriptSession) funcScript
229+ compileScript (dbcFunctionBodyType scriptSession) _funcScript
211 case eCompiledScript of
230 case eCompiledScript of
212 Left err -> throwIO err
231 Left err -> throwIO err
213 Right compiledScript -> pure DatabaseContextFunction { dbcFuncName = funcName,
232 Right compiledScript -> pure DatabaseContextFunction { dbcFuncName = funcName,
214− dbcFuncType = funcType,
233+ dbcFuncType = _funcType,
215− dbcFuncBody = DatabaseContextFunctionBody (Just funcScript) compiledScript}
234+ dbcFuncBody = DatabaseContextFunctionBody (Just _funcScript) compiledScript}
235+#else
236+ error "Haskell scripting is disabled"
237+#endif
216
238
217writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()
239writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()
218writeIncDep sync transDir (incDepName, incDep) =
240writeIncDep sync transDir (incDepName, incDep) =
@@ -252,4 +274,4 @@ readTypeConstructorMapping path = do
252 let atPath = typeConsPath path
274 let atPath = typeConsPath path
253 B.decodeFile atPath
275 B.decodeFile atPath
254
276
255−
277+
test/TransactionGraph/Persist.hs+11−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1import Test.HUnit
2import Test.HUnit
2import ProjectM36.Base
3import ProjectM36.Base
3import ProjectM36.Persist (DiskSync(NoDiskSync))
4import ProjectM36.Persist (DiskSync(NoDiskSync))
@@ -5,8 +6,6 @@ import ProjectM36.TransactionGraph.Persist
5import ProjectM36.TransactionGraph
6import ProjectM36.TransactionGraph
6import ProjectM36.Transaction
7import ProjectM36.Transaction
7import ProjectM36.DateExamples
8import ProjectM36.DateExamples
8−import ProjectM36.Client
9−import ProjectM36.Relation
10import System.IO.Temp
9import System.IO.Temp
11import System.Exit
10import System.Exit
12import Data.Either
11import Data.Either
@@ -17,6 +16,10 @@ import qualified Data.Map as M
17import qualified Data.Set as S
16import qualified Data.Set as S
18import Data.Time.Clock
17import Data.Time.Clock
19import Data.Time.Calendar
18import Data.Time.Calendar
19+#ifdef PM36_HASKELL_SCRIPTING
20+import ProjectM36.Client
21+import ProjectM36.Relation
22+#endif
20
23
21main :: IO ()
24main :: IO ()
22main = do
25main = do
@@ -75,7 +78,10 @@ testDBSimplePersistence = TestCase $ withSystemTempDirectory "m36testdb" $ \temp
75
78
76--only Haskell-scripted dbc and atom functions can be serialized
79--only Haskell-scripted dbc and atom functions can be serialized
77testFunctionPersistence :: Test
80testFunctionPersistence :: Test
81+#if !defined(PM36_HASKELL_SCRIPTING)
78−testFunctionPersistence = TestCase $
82+testFunctionPersistence = TestCase $ pure ()
83+#else
84+testFunctionPersistence = TestCase $
79 withSystemTempDirectory "m36testdb" $ \tempdir -> do
85 withSystemTempDirectory "m36testdb" $ \tempdir -> do
80 let dbdir = tempdir </> "dbdir"
86 let dbdir = tempdir </> "dbdir"
81 connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []
87 connInfo = InProcessConnectionInfo (MinimalPersistence dbdir) emptyNotificationCallback []
@@ -96,10 +102,11 @@ testFunctionPersistence = TestCase $
96 res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))])
102 res <- executeRelationalExpr sess2 conn2 (MakeRelationFromExprs Nothing [TupleExpr (M.singleton "a" (FunctionAtomExpr "testdisk" [NakedAtomExpr (IntAtom 3)] ()))])
97 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]
103 let expectedRel = mkRelationFromList (attributesFromList [Attribute "a" IntAtomType]) [[IntAtom 3]]
98 assertEqual "testdisk dbc function run" expectedRel res
104 assertEqual "testdisk dbc function run" expectedRel res
99−
105+
100assertIOEither :: (Show a) => IO (Either a b) -> IO b
106assertIOEither :: (Show a) => IO (Either a b) -> IO b
101assertIOEither x = do
107assertIOEither x = do
102 ret <- x
108 ret <- x
103 case ret of
109 case ret of
104 Left err -> assertFailure (show err) >> undefined
110 Left err -> assertFailure (show err) >> undefined
105 Right val -> pure val
111 Right val -> pure val
112+#endif
test/TutorialD/Interpreter/AtomFunctionScript.hs+18−10
@@ -1,25 +1,32 @@
1−import TutorialD.Interpreter.TestBase
1+{-# LANGUAGE CPP #-}
2import System.Exit
2import System.Exit
3import Test.HUnit
3import Test.HUnit
4+#ifdef PM36_HASKELL_SCRIPTING
5+import TutorialD.Interpreter.TestBase
4import ProjectM36.Client
6import ProjectM36.Client
5import ProjectM36.Relation
7import ProjectM36.Relation
6import ProjectM36.DataTypes.Maybe
8import ProjectM36.DataTypes.Maybe
7import qualified Data.Vector as V
9import qualified Data.Vector as V
8import qualified Data.Map as M
10import qualified Data.Map as M
11+#endif
9
12
10{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
13{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
11main :: IO ()
14main :: IO ()
12main = do
15main = do
13− tcounts <- runTestTT (TestList [testBasicAtomFunction,
16+ tcounts <- runTestTT (TestList [
17+#ifdef PM36_HASKELL_SCRIPTING
18+ testBasicAtomFunction,
14− testExceptionAtomFunction,
19+ testExceptionAtomFunction,
15− testErrorAtomFunction,
20+ testErrorAtomFunction,
16− testNoArgumentAtomFunction,
21+ testNoArgumentAtomFunction,
17− testArgumentTypeMismatch,
22+ testArgumentTypeMismatch,
18− testPolymorphicReturnType,
23+ testPolymorphicReturnType,
19− testScriptedTypeVariable
24+ testScriptedTypeVariable
25+#endif
20− ])
26+ ])
21 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
27 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
22
28
29+#ifdef PM36_HASKELL_SCRIPTING
23--add an atom function and run it
30--add an atom function and run it
24testBasicAtomFunction :: Test
31testBasicAtomFunction :: Test
25testBasicAtomFunction = TestCase $ do
32testBasicAtomFunction = TestCase $ do
@@ -111,4 +118,5 @@ testScriptedTypeVariable = TestCase $ do
111 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)
118 result <- executeRelationalExpr sess conn (MakeRelationFromExprs (Just (map NakedAttributeExpr attrs)) tupleExprs)
112
119
113 assertEqual "id function equality" expectedResult result
120 assertEqual "id function equality" expectedResult result
114−
121+
122+#endif
test/TutorialD/Interpreter/DatabaseContextFunctionScript.hs+13−6
@@ -1,19 +1,26 @@
1−import TutorialD.Interpreter.TestBase
1+{-# LANGUAGE CPP #-}
2import System.Exit
2import System.Exit
3import Test.HUnit
3import Test.HUnit
4+#ifdef PM36_HASKELL_SCRIPTING
5+import TutorialD.Interpreter.TestBase
4import ProjectM36.Client
6import ProjectM36.Client
5import ProjectM36.Relation
7import ProjectM36.Relation
6import qualified Data.Text as T
8import qualified Data.Text as T
9+#endif
7
10
8main :: IO ()
11main :: IO ()
9main = do
12main = do
10− tcounts <- runTestTT (TestList [testBasicDBCFunction,
13+ tcounts <- runTestTT (TestList [
14+#ifdef PM36_HASKELL_SCRIPTING
15+ testBasicDBCFunction,
11− testErrorDBCFunction,
16+ testErrorDBCFunction,
12− testExceptionDBCFunction,
17+ testExceptionDBCFunction,
13− testDBCFunctionWithAtomArguments
18+ testDBCFunctionWithAtomArguments
19+#endif
14 ])
20 ])
15 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
21 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
16
22
23+#ifdef PM36_HASKELL_SCRIPTING
17testBasicDBCFunction :: Test
24testBasicDBCFunction :: Test
18testBasicDBCFunction = TestCase $ do
25testBasicDBCFunction = TestCase $ do
19 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
26 (sess, conn) <- dateExamplesConnection emptyNotificationCallback
@@ -55,4 +62,4 @@ testDBCFunctionWithAtomArguments = TestCase $ do
55 assertEqual "person relation" expectedPerson result
62 assertEqual "person relation" expectedPerson result
56 expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"
63 expectTutorialDErr sess conn (T.isPrefixOf "AtomTypeMismatchError") "execute multiArgFunc(\"fail\", \"fail\")"
57
64
58−
65+#endif