d534943 · project-m36 · git.iko.soy

project-m36.cabal+1

@@ -68,6 +68,7 @@ Library

6868 ,stm-containers

6969 ,list-t

7070 ,optparse-applicative

71+ ,Glob

7172 Exposed-Modules: ProjectM36.Error,

7273 ProjectM36.Transaction,

7374 ProjectM36.TransactionGraph,

src/bin/TutorialD/Interpreter.hs+2−1

@@ -166,7 +166,8 @@ evalTutorialD sessionId conn safe expr = case expr of

166166 unsafeError = pure $ DisplayErrorResult "File I/O operation prohibited."

167167 barf err = return $ DisplayErrorResult (T.pack (show err))

168168

169−data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName|

169+type GhcPkgPath = String

170+data InterpreterConfig = LocalInterpreterConfig PersistenceStrategy HeadName [GhcPkgPath] |

170171 RemoteInterpreterConfig C.NodeId C.DatabaseName HeadName

171172

172173outputNotificationCallback :: C.NotificationCallback

src/bin/TutorialD/tutd.hs+14−4

@@ -7,7 +7,7 @@ import Options.Applicative

77import System.Exit

88

99parseArgs :: Parser InterpreterConfig

10−parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <|>

10+parseArgs = LocalInterpreterConfig <$> parsePersistenceStrategy <*> parseHeadName <*> parseGhcPkgPaths <|>

1111 RemoteInterpreterConfig <$> parseNodeId <*> parseDatabaseName <*> parseHeadName

1212

1313parsePersistenceStrategy :: Parser PersistenceStrategy

@@ -44,18 +44,28 @@ parseNodeId = createNodeId <$>

4444 short 'p' <>

4545 help "Remote port" <>

4646 value defaultServerPort)

47+

48+parseGhcPkgPaths :: Parser [GhcPkgPath]

49+parseGhcPkgPaths = many (strOption (long "ghc-pkg-dir" <>

50+ metavar "GHC_PACKAGE_DIRECTORY"))

4751

4852opts :: ParserInfo InterpreterConfig

4953opts = info parseArgs idm

5054

5155connectionInfoForConfig :: InterpreterConfig -> ConnectionInfo

52−connectionInfoForConfig (LocalInterpreterConfig pStrategy _) = InProcessConnectionInfo pStrategy outputNotificationCallback

56+connectionInfoForConfig (LocalInterpreterConfig pStrategy _ ghcPkgPaths) = InProcessConnectionInfo pStrategy outputNotificationCallback ghcPkgPaths

5357connectionInfoForConfig (RemoteInterpreterConfig remoteNodeId remoteDBName _) = RemoteProcessConnectionInfo remoteDBName remoteNodeId outputNotificationCallback

5458

5559headNameForConfig :: InterpreterConfig -> HeadName

56−headNameForConfig (LocalInterpreterConfig _ headn) = headn

60+headNameForConfig (LocalInterpreterConfig _ headn _) = headn

5761headNameForConfig (RemoteInterpreterConfig _ _ headn) = headn

58−

62+

63+{-

64+ghcPkgPathsForConfig :: InterpreterConfig -> [GhcPkgPath]

65+ghcPkgPathsForConfig (LocalInterpreterConfig _ _ paths) = paths

66+ghcPkgPathsForConfig _ = error "Clients cannot configure remote ghc package paths."

67+-}

68+

5969errDie :: String -> IO ()

6070errDie err = hPutStrLn stderr err >> exitFailure

6171

src/lib/ProjectM36/AtomFunctionBody.hs+38−30

@@ -15,6 +15,7 @@ import DynFlags

1515import Outputable hiding ((<>))

1616import PprTyThing

1717import Type hiding (pprTyThing)

18+import System.FilePath.Glob

1819

1920data ScriptSession = ScriptSession {

2021 hscEnv :: HscEnv,

@@ -22,25 +23,31 @@ data ScriptSession = ScriptSession {

2223 }

2324

2425-- | Configure a GHC environment/session which we will use for all script compilation.

25−initScriptSession :: IO ScriptSession

26−initScriptSession = runGhc (Just libdir) $ do

27− dflags <- getSessionDynFlags

28− let dflags' = dflags { hscTarget = HscInterpreted ,

29− ghcLink = LinkInMemory,

30− safeHaskell = Sf_Trustworthy,

31− safeInfer = True,

32− safeInferred = True,

33− --trustFlags = [TrustPackage "base"] -- new in 8

34− packageFlags = (packageFlags dflags) ++ packages,

35− extraPkgConfs = const [GlobalPkgConf, PkgConfFile "/home/agentm/Dev/project-m36/.cabal-sandbox/x86_64-linux-ghc-7.10.3-packages.conf.d/"] --different in 8

26+initScriptSession :: [String] -> IO ScriptSession

27+initScriptSession ghcPkgPaths = do

28+ --for the sake of convenience, for developers' builds, include the local cabal sandbox pacakge database

29+ sandboxPkgPaths <- liftIO (glob ".cabal-sandbox/*packages.conf.d")

30+ runGhc (Just libdir) $ do

31+ dflags <- getSessionDynFlags

32+ let localPkgPaths = map PkgConfFile (ghcPkgPaths ++ sandboxPkgPaths)

33+

34+ let dflags' = dflags { hscTarget = HscInterpreted ,

35+ ghcLink = LinkInMemory,

36+ safeHaskell = Sf_Trustworthy,

37+ safeInfer = True,

38+ safeInferred = True,

39+ --trustFlags = [TrustPackage "base"] -- new in 8

40+ packageFlags = (packageFlags dflags) ++ packages,

41+ extraPkgConfs = const ([GlobalPkgConf, UserPkgConf] ++ localPkgPaths)

3642 }

3743 `xopt_set` Opt_ExtendedDefaultRules

3844 `xopt_set` Opt_ImplicitPrelude

45+ `xopt_set` Opt_OverloadedStrings

3946 `gopt_set` Opt_DistrustAllPackages

4047 `xopt_set` Opt_ScopedTypeVariables

4148 `gopt_set` Opt_PackageTrust

4249 --`gopt_set` Opt_ImplicitImportQualified

43− packages = map TrustPackage ["base",

50+ packages = map TrustPackage ["base",

4451 "containers",

4552 "unordered-containers",

4653 "hashable",

@@ -52,24 +59,25 @@ initScriptSession = runGhc (Just libdir) $ do

5259 "time",

5360 "project-m36",

5461 "bytestring"] -- package flags changed in 8.0

55− _ <- setSessionDynFlags dflags'

56− let safeImportDecl mn = ImportDecl {

57− ideclSourceSrc = Nothing,

58− ideclName = noLoc mn,

59− ideclPkgQual = Nothing,

60− ideclSource = False,

61− ideclSafe = True,

62− ideclImplicit = False,

63− ideclQualified = False,

64− ideclAs = Nothing,

65− ideclHiding = Nothing

66− }

67− setContext (map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn))

68− ["Prelude",

69− "ProjectM36.Base"])

70− env <- getSession

71− fType <- mkAtomFunctionBodyType

72− pure (ScriptSession env fType)

62+ _ <- setSessionDynFlags dflags'

63+ let safeImportDecl mn = ImportDecl {

64+ ideclSourceSrc = Nothing,

65+ ideclName = noLoc mn,

66+ ideclPkgQual = Nothing,

67+ ideclSource = False,

68+ ideclSafe = True,

69+ ideclImplicit = False,

70+ ideclQualified = False,

71+ ideclAs = Nothing,

72+ ideclHiding = Nothing

73+ }

74+ setContext (map (\modn -> IIDecl $ safeImportDecl (mkModuleName modn))

75+ ["Prelude",

76+ "Data.Map",

77+ "ProjectM36.Base"])

78+ env <- getSession

79+ fType <- mkAtomFunctionBodyType

80+ pure (ScriptSession env fType)

7381

7482mkAtomFunctionBodyType :: Ghc Type

7583mkAtomFunctionBodyType = do

src/lib/ProjectM36/Client.hs+17−13

@@ -76,7 +76,7 @@ import Data.UUID.V4 (nextRandom)

7676import Control.Concurrent.STM

7777import Data.Word

7878import Control.Distributed.Process (ProcessId, Process, receiveWait, send, match)

79−import Control.Exception (IOException, SomeException(..), handle)

79+import Control.Exception (IOException, SomeException(..), handle, AsyncException, throwIO, fromException, Exception)

8080import Control.Concurrent.MVar

8181import qualified Data.Map as M

8282import Control.Distributed.Process.Serializable (Serializable)

@@ -104,8 +104,10 @@ type NotificationCallback = NotificationName -> EvaluatedNotification -> IO ()

104104emptyNotificationCallback :: NotificationCallback

105105emptyNotificationCallback _ _ = pure ()

106106

107+type GhcPkgPath = String

108+

107109-- | Construct a 'ConnectionInfo' to describe how to make the 'Connection'.

108−data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback |

110+data ConnectionInfo = InProcessConnectionInfo PersistenceStrategy NotificationCallback [GhcPkgPath]|

109111 RemoteProcessConnectionInfo DatabaseName NodeId NotificationCallback

110112

111113type EvaluatedNotifications = M.Map NotificationName EvaluatedNotification

@@ -134,7 +136,7 @@ defaultHeadName :: HeadName

134136defaultHeadName = "master"

135137

136138defaultRemoteConnectionInfo :: ConnectionInfo

137−defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback

139+defaultRemoteConnectionInfo = RemoteProcessConnectionInfo defaultDatabaseName (createNodeId "127.0.0.1" defaultServerPort) emptyNotificationCallback

138140

139141-- | The 'Connection' represents either local or remote access to a database. All operations flow through the connection.

140142type ClientNodes = STMSet.Set ProcessId

@@ -152,7 +154,6 @@ data ConnectionError = SetupDatabaseDirectoryError PersistenceError |

152154remoteDBLookupName :: DatabaseName -> String

153155remoteDBLookupName = (++) "db-"

154156

155−

156157commonLocalNode :: IO (Either ConnectionError LocalNode)

157158commonLocalNode = do

158159 eLocalTransport <- createTransport "127.0.0.1" "0" defaultTCPParameters

@@ -184,7 +185,7 @@ startNotificationListener callback = do

184185-- | To create a 'Connection' to a remote or local database, create a connectionInfo and call 'connectProjectM36'.

185186connectProjectM36 :: ConnectionInfo -> IO (Either ConnectionError Connection)

186187--create a new in-memory database/transaction graph

187−connectProjectM36 (InProcessConnectionInfo strat notificationCallback) = do

188+connectProjectM36 (InProcessConnectionInfo strat notificationCallback ghcPkgPaths) = do

188189 freshId <- nextRandom

189190 let bootstrapContext = basicDatabaseContext

190191 freshGraph = bootstrapTransactionGraph freshId bootstrapContext

@@ -195,12 +196,12 @@ connectProjectM36 (InProcessConnectionInfo strat notificationCallback) = do

195196 clientNodes <- STMSet.newIO

196197 sessions <- STMMap.newIO

197198 notificationPid <- startNotificationListener notificationCallback

198− interpreterSession <- initScriptSession

199+ interpreterSession <- initScriptSession ghcPkgPaths

199200 let conn = InProcessConnection strat clientNodes sessions graphTvar interpreterSession

200201 addClientNode conn notificationPid

201202 pure (Right conn)

202− MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback

203− CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback

203+ MinimalPersistence dbdir -> connectPersistentProjectM36 strat NoDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

204+ CrashSafePersistence dbdir -> connectPersistentProjectM36 strat FsyncDiskSync dbdir freshGraph notificationCallback ghcPkgPaths

204205

205206connectProjectM36 (RemoteProcessConnectionInfo databaseName serverNodeId notificationCallback) = do

206207 connStatus <- newEmptyMVar

@@ -229,8 +230,9 @@ connectPersistentProjectM36 :: PersistenceStrategy ->

229230 FilePath ->

230231 TransactionGraph ->

231232 NotificationCallback ->

233+ [GhcPkgPath] ->

232234 IO (Either ConnectionError Connection)

233−connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback = do

235+connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback ghcPkgPaths = do

234236 err <- setupDatabaseDir sync dbdir freshGraph

235237 case err of

236238 Just err' -> return $ Left (SetupDatabaseDirectoryError err')

@@ -242,7 +244,7 @@ connectPersistentProjectM36 strat sync dbdir freshGraph notificationCallback = d

242244 tvarGraph <- newTVarIO graph'

243245 sessions <- STMMap.newIO

244246 clientNodes <- STMSet.newIO

245− scriptSession <- initScriptSession

247+ scriptSession <- initScriptSession ghcPkgPaths

246248 let conn = InProcessConnection strat clientNodes sessions tvarGraph scriptSession

247249 notificationPid <- startNotificationListener notificationCallback

248250 addClientNode conn notificationPid

@@ -308,12 +310,14 @@ close (RemoteProcessConnection localNode serverProcessId) = do

308310excMaybe :: IO (Maybe RelationalError) -> IO (Maybe RelationalError)

309311excMaybe m = handle handler m

310312 where

311− handler (exc :: SomeException) = pure (Just (UnhandledExceptionError (show exc)))

312−

313+ handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc

314+ | otherwise = pure (Just (UnhandledExceptionError (show exc)))

315+

313316excEither :: IO (Either RelationalError a) -> IO (Either RelationalError a)

314317excEither m = handle handler m

315318 where

316− handler (exc :: SomeException) = pure (Left (UnhandledExceptionError (show exc)))

319+ handler exc | Just (_ :: AsyncException) <- fromException exc = throwIO exc

320+ | otherwise = pure (Left (UnhandledExceptionError (show exc)))

317321

318322runProcessResult :: LocalNode -> Process a -> IO a

319323runProcessResult localNode proc = do

src/lib/ProjectM36/Server.hs+1−1

@@ -65,7 +65,7 @@ loggingNotificationCallback notName evaldNot = hPutStrLn stderr $ "Notification

6565-- | A synchronous function to start the project-m36 daemon given an appropriate 'ServerConfig'. Note that this function only returns if the server exits. Returns False if the daemon exited due to an error. If the second argument is not Nothing, the port is put after the server is ready to service the port.

6666launchServer :: ServerConfig -> Maybe (MVar Port) -> IO (Bool)

6767launchServer daemonConfig mPortMVar = do

68− econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback)

68+ econn <- connectProjectM36 (InProcessConnectionInfo (persistenceStrategy daemonConfig) loggingNotificationCallback (ghcPkgPaths daemonConfig))

6969 case econn of

7070 Left err -> do

7171 hPutStrLn stderr ("Failed to create database connection: " ++ show err)

src/lib/ProjectM36/Server/Config.hs+4−2

@@ -4,12 +4,14 @@ import ProjectM36.Client

44data ServerConfig = ServerConfig { persistenceStrategy :: PersistenceStrategy,

55 databaseName :: DatabaseName,

66 bindHost :: Hostname,

7− bindPort :: Port

7+ bindPort :: Port,

8+ ghcPkgPaths :: [String] -- used for AtomFunction dynamic compilation

89 }

910

1011defaultServerConfig :: ServerConfig

1112defaultServerConfig = ServerConfig { persistenceStrategy = NoPersistence,

1213 databaseName = "base",

1314 bindHost = "127.0.0.1",

14− bindPort = 6543

15+ bindPort = 6543,

16+ ghcPkgPaths = []

1517 }

src/lib/ProjectM36/Server/ParseArgs.hs+7−2

@@ -5,7 +5,7 @@ import Options.Applicative

55import ProjectM36.Server.Config

66

77parseArgs :: Parser ServerConfig

8−parseArgs = ServerConfig <$> parsePersistenceStrategy <*> parseDatabaseName <*> parseHostname <*> parsePort

8+parseArgs = ServerConfig <$> parsePersistenceStrategy <*> parseDatabaseName <*> parseHostname <*> parsePort <*> parseGhcPkgPaths

99

1010parsePersistenceStrategy :: Parser PersistenceStrategy

1111parsePersistenceStrategy = CrashSafePersistence <$> (dbdirOpt <* fsyncOpt) <|>

@@ -37,7 +37,12 @@ parsePort = option auto (short 'p' <>

3737 long "port" <>

3838 metavar "PORT_NUMBER" <>

3939 value (bindPort defaultServerConfig))

40+

41+parseGhcPkgPaths :: Parser [String]

42+parseGhcPkgPaths = option auto (long "ghc-pkg-dir" <>

43+ metavar "GHC_PACKAGE_DIRECTORY")

4044

4145parseConfig :: IO ServerConfig

4246parseConfig = execParser $ info parseArgs idm

43−

47+

48+

test/TutorialD/Interpreter/TestBase.hs+1−1

@@ -9,7 +9,7 @@ import qualified Data.Map as M

99

1010dateExamplesConnection :: NotificationCallback -> IO (SessionId, Connection)

1111dateExamplesConnection callback = do

12− dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback)

12+ dbconn <- connectProjectM36 (InProcessConnectionInfo NoPersistence callback [])

1313 let incDeps = Base.inclusionDependencies dateExamples

1414 case dbconn of

1515 Left err -> error (show err)

test/persistent-driver/test.hs+1−1

@@ -37,7 +37,7 @@ main = do

3737 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

3838

3939inProcSettings :: ConnectionInfo

40−inProcSettings = InProcessConnectionInfo NoPersistence emptyNotificationCallback

40+inProcSettings = InProcessConnectionInfo NoPersistence emptyNotificationCallback []

4141

4242defPersonRel :: SessionId -> Connection -> IO ()

4343defPersonRel sessionId conn = do