4bbe64a · project-m36 · git.iko.soy

project-m36.cabal+4−3

compare with master

unifiedsplit

@@ -26,6 +26,7 @@ Library

26 Build-Depends: base>=4.8 && < 6.0

27 ,ghc >= 7.8 && < 8.3

28 ,ghc-paths

29+ ,ghci

29 ,mtl

30 ,mtl

30 ,containers

31 ,containers

31 ,unordered-containers

32 ,unordered-containers

@@ -152,14 +153,14 @@ Library

152 ProjectM36.TypeConstructorDef,

153 ProjectM36.TypeConstructorDef,

153 ProjectM36.FileLock,

154 ProjectM36.FileLock,

154 ProjectM36.FSType

155 ProjectM36.FSType

155− GHC-Options: -Wall

156+ GHC-Options: -Wall -rdynamic

156 if os(windows)

157 if os(windows)

157 Build-Depends: Win32 >= 2.3

158 Build-Depends: Win32 >= 2.3

158 Other-Modules: ProjectM36.Win32Handle

159 Other-Modules: ProjectM36.Win32Handle

159 else

160 else

160 C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c

161 C-sources: cbits/DirectoryFsync.c, cbits/darwin_statfs.c

161 Build-Depends: unix

162 Build-Depends: unix

162− CC-Options: -fPIC

163+ CC-Options: -fPIC

163 Hs-Source-Dirs: ./src/lib

164 Hs-Source-Dirs: ./src/lib

164 Default-Language: Haskell2010

165 Default-Language: Haskell2010

165 Default-Extensions: OverloadedStrings, CPP

166 Default-Extensions: OverloadedStrings, CPP

@@ -225,7 +226,7 @@ Executable tutd

225 TutorialD.Interpreter.SchemaOperator

226 TutorialD.Interpreter.SchemaOperator

226 main-is: TutorialD/tutd.hs

227 main-is: TutorialD/tutd.hs

227 CC-Options: -fPIC

228 CC-Options: -fPIC

228− GHC-Options: -Wall

229+ GHC-Options: -Wall -rdynamic

229 Hs-Source-Dirs: ./src/bin

230 Hs-Source-Dirs: ./src/bin

230 Default-Language: Haskell2010

231 Default-Language: Haskell2010

231 Default-Extensions: OverloadedStrings

232 Default-Extensions: OverloadedStrings

src/bin/TutorialD/Interpreter/DatabaseContextIOOperator.hs+7−1

@@ -26,6 +26,12 @@ atomTypeSignatureP :: Parser [TypeConstructor]

26atomTypeSignatureP = sepBy typeConstructorP arrow

27

28dbContextIOExprP :: Parser DatabaseContextIOExpr

29−dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP

29+dbContextIOExprP = addAtomFunctionExprP <|> addDatabaseContextFunctionExprP <|> loadAtomFunctionsP

30+

31+loadAtomFunctionsP :: Parser DatabaseContextIOExpr

32+loadAtomFunctionsP = do

33+ reserved "loadatomfunctions"

34+ LoadAtomFunctions <$> quotedString <*> quotedString <*> fmap unpack quotedString

35+

30

36

31

37

src/bin/TutorialD/Interpreter/RODatabaseContextOperator.hs+11

@@ -24,6 +24,7 @@ data RODatabaseContextOperator where

24 ShowPlan :: DatabaseContextExpr -> RODatabaseContextOperator

25 ShowTypes :: RODatabaseContextOperator

26 ShowRelationVariables :: RODatabaseContextOperator

27+ ShowAtomFunctions :: RODatabaseContextOperator

27 Quit :: RODatabaseContextOperator

28 Quit :: RODatabaseContextOperator

28 deriving (Show)

29 deriving (Show)

29

30

@@ -48,6 +49,9 @@ showTypesP = reserved ":showtypes" >> pure ShowTypes

48showRelationVariables :: Parser RODatabaseContextOperator

49showRelationVariables :: Parser RODatabaseContextOperator

49showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables

50showRelationVariables = reserved ":showrelvars" >> pure ShowRelationVariables

50

51

52+showAtomFunctionsP :: Parser RODatabaseContextOperator

53+showAtomFunctionsP = reserved ":showatomfunctions" >> pure ShowAtomFunctions

54+

51quitP :: Parser RODatabaseContextOperator

55quitP :: Parser RODatabaseContextOperator

52quitP = do

56quitP = do

53 reservedOp ":quit"

57 reservedOp ":quit"

@@ -71,6 +75,7 @@ roDatabaseContextOperatorP = typeP

71 <|> showConstraintsP

75 <|> showConstraintsP

72 <|> showPlanP

76 <|> showPlanP

73 <|> showTypesP

77 <|> showTypesP

78+ <|> showAtomFunctionsP

74 <|> quitP

79 <|> quitP

75

80

76--logically, these read-only operations could happen purely, but not if a remote call is required

81--logically, these read-only operations could happen purely, but not if a remote call is required

@@ -125,6 +130,12 @@ evalRODatabaseContextOp sessionId conn ShowRelationVariables = do

125 case eRel of

130 case eRel of

126 Left err -> pure $ DisplayErrorResult (T.pack (show err))

131 Left err -> pure $ DisplayErrorResult (T.pack (show err))

127 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

132 Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

133+

134+evalRODatabaseContextOp sessionId conn ShowAtomFunctions = do

135+ eRel <- C.atomFunctionsAsRelation sessionId conn

136+ case eRel of

137+ Left err -> pure $ DisplayErrorResult (T.pack (show err))

138+ Right rel -> evalRODatabaseContextOp sessionId conn (ShowRelation (ExistingRelation rel))

128

139

129evalRODatabaseContextOp _ _ Quit = pure QuitResult

140evalRODatabaseContextOp _ _ Quit = pure QuitResult

130

141

src/lib/ProjectM36/AtomFunction.hs+19−2

@@ -1,12 +1,17 @@

1module ProjectM36.AtomFunction where

2import ProjectM36.Base

3import ProjectM36.Error

4+import ProjectM36.Relation

5+import ProjectM36.AtomType

4import ProjectM36.AtomFunctionError

6import ProjectM36.AtomFunctionError

7+import ProjectM36.ScriptSession

5import qualified ProjectM36.Attribute as A

8import qualified ProjectM36.Attribute as A

6import qualified Data.HashSet as HS

9import qualified Data.HashSet as HS

10+import qualified Data.Text as T

11+

7

12

8foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

13foldAtomFuncType :: AtomType -> AtomType -> [AtomType]

9−foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "_" foldType]), returnType]

14+foldAtomFuncType foldType returnType = [RelationAtomType (A.attributesFromList [Attribute "a" foldType]), returnType]

10

15

11atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction

16atomFunctionForName :: AtomFunctionName -> AtomFunctions -> Either RelationalError AtomFunction

12atomFunctionForName funcName funcSet = if HS.null foundFunc then

17atomFunctionForName funcName funcSet = if HS.null foundFunc then

@@ -64,4 +69,16 @@ createScriptedAtomFunction funcName argsType retType = AddAtomFunction funcName

64 argsType ++ [ADTypeConstructor "Either" [

69 argsType ++ [ADTypeConstructor "Either" [

65 ADTypeConstructor "AtomFunctionError" [],

70 ADTypeConstructor "AtomFunctionError" [],

66 retType]])

71 retType]])

67−

72+

73+loadAtomFunctions :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError [AtomFunction])

74+loadAtomFunctions modName funcName objPath = do

75+ loadFunction modName funcName objPath

76+

77+atomFunctionsAsRelation :: AtomFunctions -> Either RelationalError Relation

78+atomFunctionsAsRelation funcs = mkRelationFromList attrs tups

79+ where tups = map atomFuncToTuple (HS.toList funcs)

80+ attrs = A.attributesFromList [Attribute "name" TextAtomType,

81+ Attribute "arguments" TextAtomType]

82+ atomFuncToTuple aFunc = [TextAtom (atomFuncName aFunc),

83+ TextAtom (atomFuncTypeToText aFunc)]

84+ atomFuncTypeToText aFunc = T.intercalate " -> " (map prettyAtomType (atomFuncType aFunc))

src/lib/ProjectM36/AtomType.hs+4−2

@@ -252,14 +252,16 @@ prettyAtomType :: AtomType -> T.Text

252prettyAtomType (RelationAtomType attrs) = "relation {" `T.append` T.intercalate "," (map prettyAttribute (V.toList attrs)) `T.append` "}"

253prettyAtomType (ConstructedAtomType tConsName typeVarMap) = tConsName `T.append` T.concat (map showTypeVars (M.toList typeVarMap))

254 where

255+ showTypeVars (_, TypeVariableType x) = " " <> x

255 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

256 showTypeVars (tyVarName, aType) = " (" `T.append` tyVarName `T.append` "::" `T.append` prettyAtomType aType `T.append` ")"

256-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

257-- it would be nice to have the original ordering, but we don't have access to the type constructor here- maybe the typevarmap should be also positional (ordered map?)

257−prettyAtomType (TypeVariableType x) = "?TypeVariableType " <> x <> "?"

258+prettyAtomType (TypeVariableType x) = x

258−prettyAtomType (IntervalAtomType tv) = "Interval (" <> prettyAtomType tv <> ")"

259+prettyAtomType (IntervalAtomType tv) = "Interval " <> prettyAtomType tv

259prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName

260prettyAtomType aType = T.take (T.length fullName - T.length "AtomType") fullName

260 where fullName = (T.pack . show) aType

261 where fullName = (T.pack . show) aType

261

262

262prettyAttribute :: Attribute -> T.Text

263prettyAttribute :: Attribute -> T.Text

264+prettyAttribute (Attribute _ (TypeVariableType x)) = x

263prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)

265prettyAttribute attr = A.attributeName attr `T.append` "::" `T.append` prettyAtomType (A.atomType attr)

264

266

265resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap

267resolveTypeVariables :: [AtomType] -> [AtomType] -> Either RelationalError TypeVarMap

src/lib/ProjectM36/Base.hs+5−1

@@ -332,9 +332,13 @@ data DatabaseContextExpr =

332 MultipleExpr [DatabaseContextExpr]

333 deriving (Show, Eq, Binary, Generic)

334

335+type ObjModuleName = StringType

336+type ObjFunctionName = StringType

337+

335-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.

338-- | Adding an atom function should be nominally a DatabaseExpr except for the fact that it cannot be performed purely. Thus, we create the DatabaseContextIOExpr.

336data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |

339data DatabaseContextIOExpr = AddAtomFunction AtomFunctionName [TypeConstructor] AtomFunctionBodyScript |

340+ LoadAtomFunctions ObjModuleName ObjFunctionName FilePath |

337− AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript

341+ AddDatabaseContextFunction DatabaseContextFunctionName [TypeConstructor] DatabaseContextFunctionBodyScript

338 deriving (Show, Eq, Generic, Binary)

342 deriving (Show, Eq, Generic, Binary)

339

343

340

344

src/lib/ProjectM36/Client.hs+16−2

@@ -32,6 +32,7 @@ module ProjectM36.Client

32 setCurrentSchemaName,

33 transactionGraphAsRelation,

34 relationVariablesAsRelation,

35+ ProjectM36.Client.atomFunctionsAsRelation,

35 disconnectedTransactionIsDirty,

36 disconnectedTransactionIsDirty,

36 headName,

37 headName,

37 remoteDBLookupName,

38 remoteDBLookupName,

@@ -98,7 +99,7 @@ import ProjectM36.Base hiding (inclusionDependencies) --defined in this module a

98import qualified ProjectM36.Base as B

99import qualified ProjectM36.Base as B

99import ProjectM36.Error

100import ProjectM36.Error

100import ProjectM36.Atomable

101import ProjectM36.Atomable

101−import ProjectM36.AtomFunction

102+import ProjectM36.AtomFunction as AF

102import ProjectM36.StaticOptimizer

103import ProjectM36.StaticOptimizer

103import ProjectM36.Key

104import ProjectM36.Key

104import qualified ProjectM36.IsomorphicSchema as Schema

105import qualified ProjectM36.IsomorphicSchema as Schema

@@ -910,7 +911,20 @@ relationVariablesAsRelation sessionId (InProcessConnection conf) = do

910 Left err -> pure (Left err)

911 Left err -> pure (Left err)

911 Right relvars -> pure $ R.relationVariablesAsRelation relvars

912 Right relvars -> pure $ R.relationVariablesAsRelation relvars

912

913

913−relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

914+relationVariablesAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveRelationVariableSummary sessionId)

915+

916+-- | Returns the names and types of the atom functions in the current 'Session'.

917+atomFunctionsAsRelation :: SessionId -> Connection -> IO (Either RelationalError Relation)

918+atomFunctionsAsRelation sessionId (InProcessConnection conf) = do

919+ let sessions = ipSessions conf

920+ atomically $ do

921+ eSession <- sessionAndSchema sessionId sessions

922+ case eSession of

923+ Left err -> pure (Left err)

924+ Right (session, _) -> do

925+ pure (AF.atomFunctionsAsRelation (atomFunctions (concreteDatabaseContext session)))

926+

927+atomFunctionsAsRelation sessionId conn@(RemoteProcessConnection _) = remoteCall conn (RetrieveAtomFunctionSummary sessionId)

914

928

915-- | Returns the transaction id for the connection's disconnected transaction committed parent transaction.

929-- | Returns the transaction id for the connection's disconnected transaction committed parent transaction.

916headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId)

930headTransactionId :: SessionId -> Connection -> IO (Either RelationalError TransactionId)

src/lib/ProjectM36/Error.hs+1

@@ -85,6 +85,7 @@ data RelationalError = NoSuchAttributeNamesError (S.Set AttributeName)

85 | UnhandledExceptionError String

86 | MergeTransactionError MergeError

87 | ScriptError ScriptCompilationError

88+ | LoadFunctionError

88 | DatabaseContextFunctionUserError DatabaseContextFunctionError

89 | DatabaseContextFunctionUserError DatabaseContextFunctionError

89 | DatabaseLoadError PersistenceError

90 | DatabaseLoadError PersistenceError

90

91

src/lib/ProjectM36/RelationalExpression.hs+7−1

@@ -561,7 +561,13 @@ evalDatabaseContextIOExpr mScriptSession currentContext (AddDatabaseContextFunct

561 Right eContext -> case eContext of

562 Left err -> pure (Left err)

563 Right context' -> pure (Right context')

564−

564+evalDatabaseContextIOExpr _ currentContext (LoadAtomFunctions modName funcName modPath) = do

565+ eLoadFunc <- loadAtomFunctions (T.unpack modName) (T.unpack funcName) modPath

566+ case eLoadFunc of

567+ Left LoadSymbolError -> pure (Left LoadFunctionError)

568+ Right atomFunctionListFunc -> let newContext = currentContext { atomFunctions = mergedFuncs }

569+ mergedFuncs = HS.union (atomFunctions currentContext) (HS.fromList atomFunctionListFunc)

570+ in pure (Right newContext)

565

571

566updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

572updateTupleWithAtomExprs :: M.Map AttributeName AtomExpr -> DatabaseContext -> RelationTuple -> Either RelationalError RelationTuple

567updateTupleWithAtomExprs exprMap context tupIn = do

573updateTupleWithAtomExprs exprMap context tupIn = do

src/lib/ProjectM36/ScriptSession.hs+38

@@ -1,3 +1,4 @@

1+{-# LANGUAGE MagicHash, UnboxedTuples #-}

1module ProjectM36.ScriptSession where

2module ProjectM36.ScriptSession where

2

3

3import ProjectM36.Error

4import ProjectM36.Error

@@ -9,6 +10,7 @@ import System.Directory

9import Control.Monad.IO.Class

10import Control.Monad.IO.Class

10import System.FilePath.Glob

11import System.FilePath.Glob

11import System.FilePath

12import System.FilePath

13+import System.Info (os, arch)

12import Data.Text (Text, unpack)

14import Data.Text (Text, unpack)

13import Data.Maybe

15import Data.Maybe

14

16

@@ -24,6 +26,11 @@ import PprTyThing

24import Unsafe.Coerce

26import Unsafe.Coerce

25import Type

27import Type

26

28

29+import GHC.Exts (addrToAny#)

30+import GHC.Ptr (Ptr(..))

31+import GHCi.ObjLink

32+import Encoding

33+

27data ScriptSession = ScriptSession {

34data ScriptSession = ScriptSession {

28 hscEnv :: HscEnv,

35 hscEnv :: HscEnv,

29 atomFunctionBodyType :: Type,

36 atomFunctionBodyType :: Type,

@@ -174,4 +181,35 @@ typeCheckScript expectedType inp = do

174 pure Nothing

181 pure Nothing

175 else

182 else

176 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))

183 pure (Just (TypeCheckCompilationError (showType dflags expectedType) (showType dflags funcType)))

184+

185+mangleSymbol :: Maybe String -> String -> String -> String

186+mangleSymbol pkg module' valsym =

187+ prefixUnderscore ++

188+ maybe "" (\p -> zEncodeString p ++ "_") pkg ++

189+ zEncodeString module' ++ "_" ++ zEncodeString valsym ++ "_closure"

190+

191+type ModName = String

192+type FuncName = String

193+

194+data LoadSymbolError = LoadSymbolError

195+

196+loadFunction :: ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)

197+loadFunction modName funcName objPath = do

198+ initObjLinker

199+ loadObj objPath

200+ _ <- resolveObjs

201+ ptr <- lookupSymbol (mangleSymbol Nothing modName funcName)

202+ case ptr of

203+ Nothing -> pure (Left LoadSymbolError)

204+ Just (Ptr addr) -> case addrToAny# addr of

205+ (# hval #) -> pure (Right hval)

177

206

207+prefixUnderscore :: String

208+prefixUnderscore =

209+ case (os,arch) of

210+ ("mingw32","x86_64") -> ""

211+ ("cygwin","x86_64") -> ""

212+ ("mingw32",_) -> "_"

213+ ("darwin",_) -> "_"

214+ ("cygwin",_) -> "_"

215+ _ -> ""

src/lib/ProjectM36/Server.hs+1

@@ -41,6 +41,7 @@ serverDefinition testBool ti = defaultProcess {

41 handleCall (\conn (CloseSession sessionId) -> handleCloseSession ti sessionId conn),

42 handleCall (\conn (RetrieveAtomTypesAsRelation sessionId) -> handleRetrieveAtomTypesAsRelation ti sessionId conn),

43 handleCall (\conn (RetrieveRelationVariableSummary sessionId) -> handleRetrieveRelationVariableSummary ti sessionId conn),

44+ handleCall (\conn (RetrieveAtomFunctionSummary sessionId) -> handleRetrieveAtomFunctionSummary ti sessionId conn),

44 handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

45 handleCall (\conn (RetrieveCurrentSchemaName sessionId) -> handleRetrieveCurrentSchemaName ti sessionId conn),

45 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

46 handleCall (\conn (ExecuteSchemaExpr sessionId schemaExpr) -> handleExecuteSchemaExpr ti sessionId conn schemaExpr),

46 handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

47 handleCall (\conn (RetrieveSessionIsDirty sessionId) -> handleRetrieveSessionIsDirty ti sessionId conn),

src/lib/ProjectM36/Server/EntryPoints.hs+5

@@ -120,6 +120,11 @@ handleRetrieveRelationVariableSummary ti sessionId conn = do

120 ret <- timeoutOrDie ti (relationVariablesAsRelation sessionId conn)

121 reply ret conn

122

123+handleRetrieveAtomFunctionSummary :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError Relation)

124+handleRetrieveAtomFunctionSummary ti sessionId conn = do

125+ ret <- timeoutOrDie ti (atomFunctionsAsRelation sessionId conn)

126+ reply ret conn

127+

123handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)

128handleRetrieveCurrentSchemaName :: Timeout -> SessionId -> Connection -> Reply (Either RelationalError SchemaName)

124handleRetrieveCurrentSchemaName ti sessionId conn = do

129handleRetrieveCurrentSchemaName ti sessionId conn = do

125 ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

130 ret <- timeoutOrDie ti (currentSchemaName sessionId conn)

src/lib/ProjectM36/Server/RemoteCallTypes.hs+2

@@ -52,6 +52,8 @@ data RetrieveAtomTypesAsRelation = RetrieveAtomTypesAsRelation SessionId

52 deriving (Binary, Generic)

53data RetrieveRelationVariableSummary = RetrieveRelationVariableSummary SessionId

54 deriving (Binary, Generic)

55+data RetrieveAtomFunctionSummary = RetrieveAtomFunctionSummary SessionId

56+ deriving (Binary, Generic)

55data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

57data RetrieveCurrentSchemaName = RetrieveCurrentSchemaName SessionId

56 deriving (Binary, Generic)

58 deriving (Binary, Generic)

57data TestTimeout = TestTimeout SessionId

59data TestTimeout = TestTimeout SessionId