{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
#ifdef PM36_HASKELL_SCRIPTING
{-# LANGUAGE TypeApplications #-}
#endif
module ProjectM36.Transaction.Persist where
import ProjectM36.Trace
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.Transaction
import ProjectM36.DatabaseContextFunction
import ProjectM36.AtomFunction
import ProjectM36.Persist (DiskSync, renameSync, writeSerialiseSync)
import ProjectM36.Function
import qualified Data.Map as M
import qualified Data.HashSet as HS
import System.FilePath
import System.Directory
import qualified Data.Text as T
import Data.Foldable (toList)
import Control.Monad
import ProjectM36.ScriptSession
import ProjectM36.AtomFunctions.Basic (precompiledAtomFunctions)
import Codec.Winery
#ifdef PM36_HASKELL_SCRIPTING
import GHC
import Control.Exception
import GHC.Paths
#endif
getDirectoryNames :: FilePath -> IO [FilePath]
getDirectoryNames :: FilePath -> IO [FilePath]
getDirectoryNames FilePath
path =
(FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ FilePath
n -> FilePath
n FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath
"..", FilePath
"."]) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
path
tempTransactionDir :: FilePath -> TransactionId -> FilePath
tempTransactionDir :: FilePath -> TransactionId -> FilePath
tempTransactionDir FilePath
dbdir TransactionId
transId = FilePath
dbdir FilePath -> FilePath -> FilePath
</> FilePath
"." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TransactionId -> FilePath
forall a. Show a => a -> FilePath
show TransactionId
transId
transactionDir :: FilePath -> TransactionId -> FilePath
transactionDir :: FilePath -> TransactionId -> FilePath
transactionDir FilePath
dbdir TransactionId
transId = FilePath
dbdir FilePath -> FilePath -> FilePath
</> TransactionId -> FilePath
forall a. Show a => a -> FilePath
show TransactionId
transId
transactionInfoPath :: FilePath -> FilePath
transactionInfoPath :: FilePath -> FilePath
transactionInfoPath FilePath
transdir = FilePath
transdir FilePath -> FilePath -> FilePath
</> FilePath
"info"
relvarsPath :: FilePath -> FilePath
relvarsPath :: FilePath -> FilePath
relvarsPath FilePath
transdir = FilePath
transdir FilePath -> FilePath -> FilePath
</> FilePath
"relvars"
incDepsDir :: FilePath -> FilePath
incDepsDir :: FilePath -> FilePath
incDepsDir FilePath
transdir = FilePath
transdir FilePath -> FilePath -> FilePath
</> FilePath
"incdeps"
atomFuncsPath :: FilePath -> FilePath
atomFuncsPath :: FilePath -> FilePath
atomFuncsPath FilePath
transdir = FilePath
transdir FilePath -> FilePath -> FilePath
</> FilePath
"atomfuncs"
dbcFuncsPath :: FilePath -> FilePath
dbcFuncsPath :: FilePath -> FilePath
dbcFuncsPath FilePath
transdir = FilePath
transdir FilePath -> FilePath -> FilePath
</> FilePath
"dbcfuncs"
typeConsPath :: FilePath -> FilePath
typeConsPath :: FilePath -> FilePath
typeConsPath FilePath
transdir = FilePath
transdir FilePath -> FilePath -> FilePath
</> FilePath
"typecons"
subschemasPath :: FilePath -> FilePath
subschemasPath :: FilePath -> FilePath
subschemasPath FilePath
transdir = FilePath
transdir FilePath -> FilePath -> FilePath
</> FilePath
"schemas"
objectFilesPath :: FilePath -> FilePath
objectFilesPath :: FilePath -> FilePath
objectFilesPath FilePath
transdir = FilePath
transdir FilePath -> FilePath -> FilePath
</> FilePath
".." FilePath -> FilePath -> FilePath
</> FilePath
"compiled_modules"
readTransaction :: FilePath -> TransactionId -> Maybe ScriptSession -> IO (Either PersistenceError Transaction)
readTransaction :: FilePath
-> TransactionId
-> Maybe ScriptSession
-> IO (Either PersistenceError Transaction)
readTransaction FilePath
dbdir TransactionId
transId Maybe ScriptSession
mScriptSession = do
let transDir :: FilePath
transDir = FilePath -> TransactionId -> FilePath
transactionDir FilePath
dbdir TransactionId
transId
Bool
transDirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
transDir
if Bool -> Bool
not Bool
transDirExists then
Either PersistenceError Transaction
-> IO (Either PersistenceError Transaction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError Transaction
-> IO (Either PersistenceError Transaction))
-> Either PersistenceError Transaction
-> IO (Either PersistenceError Transaction)
forall a b. (a -> b) -> a -> b
$ PersistenceError -> Either PersistenceError Transaction
forall a b. a -> Either a b
Left (PersistenceError -> Either PersistenceError Transaction)
-> PersistenceError -> Either PersistenceError Transaction
forall a b. (a -> b) -> a -> b
$ TransactionId -> PersistenceError
MissingTransactionError TransactionId
transId
else do
RelationVariables
relvars <- FilePath -> IO RelationVariables
readRelVars FilePath
transDir
TransactionInfo
transInfo <- FilePath -> IO TransactionInfo
forall a. Serialise a => FilePath -> IO a
readFileDeserialise (FilePath -> FilePath
transactionInfoPath FilePath
transDir)
Map IncDepName InclusionDependency
incDeps <- FilePath -> IO (Map IncDepName InclusionDependency)
readIncDeps FilePath
transDir
TypeConstructorMapping
typeCons <- FilePath -> IO TypeConstructorMapping
readTypeConstructorMapping FilePath
transDir
Subschemas
sschemas <- FilePath -> IO Subschemas
readSubschemas FilePath
transDir
HashSet (Function DatabaseContextFunctionBodyType)
dbcFuncs <- FilePath
-> FilePath
-> HashSet (Function DatabaseContextFunctionBodyType)
-> Maybe ScriptSession
-> IO (HashSet (Function DatabaseContextFunctionBodyType))
forall a.
FilePath
-> FilePath
-> HashSet (Function a)
-> Maybe ScriptSession
-> IO (HashSet (Function a))
readFuncs FilePath
transDir (FilePath -> FilePath
dbcFuncsPath FilePath
transDir) HashSet (Function DatabaseContextFunctionBodyType)
basicDatabaseContextFunctions Maybe ScriptSession
mScriptSession
HashSet (Function AtomFunctionBodyType)
atomFuncs <- FilePath
-> FilePath
-> HashSet (Function AtomFunctionBodyType)
-> Maybe ScriptSession
-> IO (HashSet (Function AtomFunctionBodyType))
forall a.
FilePath
-> FilePath
-> HashSet (Function a)
-> Maybe ScriptSession
-> IO (HashSet (Function a))
readFuncs FilePath
transDir (FilePath -> FilePath
atomFuncsPath FilePath
transDir) HashSet (Function AtomFunctionBodyType)
precompiledAtomFunctions Maybe ScriptSession
mScriptSession
let newContext :: DatabaseContext
newContext = DatabaseContext :: Map IncDepName InclusionDependency
-> RelationVariables
-> HashSet (Function AtomFunctionBodyType)
-> HashSet (Function DatabaseContextFunctionBodyType)
-> Notifications
-> TypeConstructorMapping
-> DatabaseContext
DatabaseContext { inclusionDependencies :: Map IncDepName InclusionDependency
inclusionDependencies = Map IncDepName InclusionDependency
incDeps,
relationVariables :: RelationVariables
relationVariables = RelationVariables
relvars,
typeConstructorMapping :: TypeConstructorMapping
typeConstructorMapping = TypeConstructorMapping
typeCons,
notifications :: Notifications
notifications = Notifications
forall k a. Map k a
M.empty,
atomFunctions :: HashSet (Function AtomFunctionBodyType)
atomFunctions = HashSet (Function AtomFunctionBodyType)
atomFuncs,
dbcFunctions :: HashSet (Function DatabaseContextFunctionBodyType)
dbcFunctions = HashSet (Function DatabaseContextFunctionBodyType)
dbcFuncs }
newSchemas :: Schemas
newSchemas = DatabaseContext -> Subschemas -> Schemas
Schemas DatabaseContext
newContext Subschemas
sschemas
Either PersistenceError Transaction
-> IO (Either PersistenceError Transaction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError Transaction
-> IO (Either PersistenceError Transaction))
-> Either PersistenceError Transaction
-> IO (Either PersistenceError Transaction)
forall a b. (a -> b) -> a -> b
$ Transaction -> Either PersistenceError Transaction
forall a b. b -> Either a b
Right (Transaction -> Either PersistenceError Transaction)
-> Transaction -> Either PersistenceError Transaction
forall a b. (a -> b) -> a -> b
$ TransactionId -> TransactionInfo -> Schemas -> Transaction
Transaction TransactionId
transId TransactionInfo
transInfo Schemas
newSchemas
writeTransaction :: DiskSync -> FilePath -> Transaction -> IO ()
writeTransaction :: DiskSync -> FilePath -> Transaction -> IO ()
writeTransaction DiskSync
sync FilePath
dbdir Transaction
trans = do
let tempTransDir :: FilePath
tempTransDir = FilePath -> TransactionId -> FilePath
tempTransactionDir FilePath
dbdir (Transaction -> TransactionId
transactionId Transaction
trans)
finalTransDir :: FilePath
finalTransDir = FilePath -> TransactionId -> FilePath
transactionDir FilePath
dbdir (Transaction -> TransactionId
transactionId Transaction
trans)
context :: DatabaseContext
context = Transaction -> DatabaseContext
concreteDatabaseContext Transaction
trans
Bool
transDirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
finalTransDir
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
transDirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
createDirectory [FilePath
tempTransDir, FilePath -> FilePath
incDepsDir FilePath
tempTransDir]
DiskSync -> FilePath -> RelationVariables -> IO ()
writeRelVars DiskSync
sync FilePath
tempTransDir (DatabaseContext -> RelationVariables
relationVariables DatabaseContext
context)
DiskSync -> FilePath -> Map IncDepName InclusionDependency -> IO ()
writeIncDeps DiskSync
sync FilePath
tempTransDir (DatabaseContext -> Map IncDepName InclusionDependency
inclusionDependencies DatabaseContext
context)
DiskSync -> FilePath -> [Function AtomFunctionBodyType] -> IO ()
forall (t :: * -> *) a.
Traversable t =>
DiskSync -> FilePath -> t (Function a) -> IO ()
writeFuncs DiskSync
sync (FilePath -> FilePath
atomFuncsPath FilePath
tempTransDir) (HashSet (Function AtomFunctionBodyType)
-> [Function AtomFunctionBodyType]
forall a. HashSet a -> [a]
HS.toList (DatabaseContext -> HashSet (Function AtomFunctionBodyType)
atomFunctions DatabaseContext
context))
DiskSync
-> FilePath -> [Function DatabaseContextFunctionBodyType] -> IO ()
forall (t :: * -> *) a.
Traversable t =>
DiskSync -> FilePath -> t (Function a) -> IO ()
writeFuncs DiskSync
sync (FilePath -> FilePath
dbcFuncsPath FilePath
tempTransDir) (HashSet (Function DatabaseContextFunctionBodyType)
-> [Function DatabaseContextFunctionBodyType]
forall a. HashSet a -> [a]
HS.toList (DatabaseContext
-> HashSet (Function DatabaseContextFunctionBodyType)
dbcFunctions DatabaseContext
context))
DiskSync -> FilePath -> TypeConstructorMapping -> IO ()
writeTypeConstructorMapping DiskSync
sync FilePath
tempTransDir (DatabaseContext -> TypeConstructorMapping
typeConstructorMapping DatabaseContext
context)
DiskSync -> FilePath -> Subschemas -> IO ()
writeSubschemas DiskSync
sync FilePath
tempTransDir (Transaction -> Subschemas
subschemas Transaction
trans)
FilePath -> TransactionInfo -> IO ()
forall a. Serialise a => FilePath -> a -> IO ()
writeFileSerialise (FilePath -> FilePath
transactionInfoPath FilePath
tempTransDir) (Transaction -> TransactionInfo
transactionInfo Transaction
trans)
DiskSync -> FilePath -> FilePath -> IO ()
renameSync DiskSync
sync FilePath
tempTransDir FilePath
finalTransDir
writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()
writeRelVars :: DiskSync -> FilePath -> RelationVariables -> IO ()
writeRelVars DiskSync
sync FilePath
transDir RelationVariables
relvars = do
let path :: FilePath
path = FilePath -> FilePath
relvarsPath FilePath
transDir
FilePath -> IO () -> IO ()
traceBlock FilePath
"write relvars" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DiskSync -> FilePath -> RelationVariables -> IO ()
forall a. Serialise a => DiskSync -> FilePath -> a -> IO ()
writeSerialiseSync DiskSync
sync FilePath
path RelationVariables
relvars
readRelVars :: FilePath -> IO RelationVariables
readRelVars :: FilePath -> IO RelationVariables
readRelVars FilePath
transDir =
FilePath -> IO RelationVariables
forall a. Serialise a => FilePath -> IO a
readFileDeserialise (FilePath -> FilePath
relvarsPath FilePath
transDir)
writeFuncs :: Traversable t => DiskSync -> FilePath -> t (Function a) -> IO ()
writeFuncs :: DiskSync -> FilePath -> t (Function a) -> IO ()
writeFuncs DiskSync
sync FilePath
funcWritePath t (Function a)
funcs = FilePath -> IO () -> IO ()
traceBlock FilePath
"write functions" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
t (Function a)
funcs' <- t (Function a)
-> (Function a -> IO (Function a)) -> IO (t (Function a))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t (Function a)
funcs ((Function a -> IO (Function a)) -> IO (t (Function a)))
-> (Function a -> IO (Function a)) -> IO (t (Function a))
forall a b. (a -> b) -> a -> b
$ \Function a
fun -> do
case Function a -> FunctionBody a
forall a. Function a -> FunctionBody a
funcBody Function a
fun of
FunctionScriptBody{} -> Function a -> IO (Function a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Function a
fun
FunctionBuiltInBody{} -> Function a -> IO (Function a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Function a
fun
FunctionObjectLoadedBody FilePath
objPath FilePath
a FilePath
b a
c -> do
let newFuncBody :: FunctionBody a
newFuncBody = FilePath -> FilePath -> FilePath -> a -> FunctionBody a
forall a. FilePath -> FilePath -> FilePath -> a -> FunctionBody a
FunctionObjectLoadedBody FilePath
objPath FilePath
a FilePath
b a
c
Function a -> IO (Function a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Function a
fun { funcBody :: FunctionBody a
funcBody = FunctionBody a
newFuncBody })
let functionData :: Function a
-> ([AtomType], IncDepName, Maybe IncDepName, Maybe ObjectFileInfo)
functionData Function a
f =
(Function a -> [AtomType]
forall a. Function a -> [AtomType]
funcType Function a
f, Function a -> IncDepName
forall a. Function a -> IncDepName
funcName Function a
f, Function a -> Maybe IncDepName
forall a. Function a -> Maybe IncDepName
functionScript Function a
f, Function a -> Maybe ObjectFileInfo
forall a. Function a -> Maybe ObjectFileInfo
objInfo Function a
f)
objInfo :: Function a -> Maybe ObjectFileInfo
objInfo :: Function a -> Maybe ObjectFileInfo
objInfo Function a
f =
case Function a -> FunctionBody a
forall a. Function a -> FunctionBody a
funcBody Function a
f of
FunctionObjectLoadedBody FilePath
objPath FilePath
modName FilePath
entryFunc a
_ ->
ObjectFileInfo -> Maybe ObjectFileInfo
forall a. a -> Maybe a
Just ((FilePath, FilePath, FilePath) -> ObjectFileInfo
ObjectFileInfo (FilePath
objPath, FilePath
modName, FilePath
entryFunc))
FunctionScriptBody{} -> Maybe ObjectFileInfo
forall a. Maybe a
Nothing
FunctionBuiltInBody{} -> Maybe ObjectFileInfo
forall a. Maybe a
Nothing
DiskSync
-> FilePath
-> [([AtomType], IncDepName, Maybe IncDepName,
Maybe ObjectFileInfo)]
-> IO ()
forall a. Serialise a => DiskSync -> FilePath -> a -> IO ()
writeSerialiseSync DiskSync
sync FilePath
funcWritePath ((Function a
-> ([AtomType], IncDepName, Maybe IncDepName,
Maybe ObjectFileInfo))
-> [Function a]
-> [([AtomType], IncDepName, Maybe IncDepName,
Maybe ObjectFileInfo)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Function a
-> ([AtomType], IncDepName, Maybe IncDepName, Maybe ObjectFileInfo)
forall a.
Function a
-> ([AtomType], IncDepName, Maybe IncDepName, Maybe ObjectFileInfo)
functionData (t (Function a) -> [Function a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Function a)
funcs'))
readFuncs :: FilePath -> FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> IO (HS.HashSet (Function a))
readFuncs :: FilePath
-> FilePath
-> HashSet (Function a)
-> Maybe ScriptSession
-> IO (HashSet (Function a))
readFuncs FilePath
transDir FilePath
funcPath HashSet (Function a)
precompiledFunctions Maybe ScriptSession
mScriptSession = do
[([AtomType], IncDepName, Maybe IncDepName, Maybe ObjectFileInfo)]
funcsList <- FilePath
-> IO
[([AtomType], IncDepName, Maybe IncDepName, Maybe ObjectFileInfo)]
forall a. Serialise a => FilePath -> IO a
readFileDeserialise FilePath
funcPath
let objFilesDir :: FilePath
objFilesDir = FilePath -> FilePath
objectFilesPath FilePath
transDir
[Function a]
funcs <- (([AtomType], IncDepName, Maybe IncDepName, Maybe ObjectFileInfo)
-> IO (Function a))
-> [([AtomType], IncDepName, Maybe IncDepName,
Maybe ObjectFileInfo)]
-> IO [Function a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\([AtomType]
funcType', IncDepName
funcName', Maybe IncDepName
mFuncScript, Maybe ObjectFileInfo
mObjInfo) ->
FilePath
-> HashSet (Function a)
-> Maybe ScriptSession
-> IncDepName
-> [AtomType]
-> Maybe IncDepName
-> Maybe ObjectFileInfo
-> IO (Function a)
forall a.
FilePath
-> HashSet (Function a)
-> Maybe ScriptSession
-> IncDepName
-> [AtomType]
-> Maybe IncDepName
-> Maybe ObjectFileInfo
-> IO (Function a)
loadFunc FilePath
objFilesDir HashSet (Function a)
precompiledFunctions Maybe ScriptSession
mScriptSession IncDepName
funcName' [AtomType]
funcType' Maybe IncDepName
mFuncScript Maybe ObjectFileInfo
mObjInfo) [([AtomType], IncDepName, Maybe IncDepName, Maybe ObjectFileInfo)]
funcsList
HashSet (Function a) -> IO (HashSet (Function a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet (Function a)
-> HashSet (Function a) -> HashSet (Function a)
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HS.union HashSet (Function a)
precompiledFunctions ([Function a] -> HashSet (Function a)
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [Function a]
funcs))
newtype ObjectFileInfo = ObjectFileInfo { ObjectFileInfo -> (FilePath, FilePath, FilePath)
_unFileInfo :: (FilePath, String, String) }
deriving (Int -> ObjectFileInfo -> FilePath -> FilePath
[ObjectFileInfo] -> FilePath -> FilePath
ObjectFileInfo -> FilePath
(Int -> ObjectFileInfo -> FilePath -> FilePath)
-> (ObjectFileInfo -> FilePath)
-> ([ObjectFileInfo] -> FilePath -> FilePath)
-> Show ObjectFileInfo
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [ObjectFileInfo] -> FilePath -> FilePath
$cshowList :: [ObjectFileInfo] -> FilePath -> FilePath
show :: ObjectFileInfo -> FilePath
$cshow :: ObjectFileInfo -> FilePath
showsPrec :: Int -> ObjectFileInfo -> FilePath -> FilePath
$cshowsPrec :: Int -> ObjectFileInfo -> FilePath -> FilePath
Show, Typeable ObjectFileInfo
BundleSerialise ObjectFileInfo
Extractor ObjectFileInfo
Decoder ObjectFileInfo
Typeable ObjectFileInfo
-> (Proxy ObjectFileInfo -> SchemaGen Schema)
-> (ObjectFileInfo -> Builder)
-> Extractor ObjectFileInfo
-> Decoder ObjectFileInfo
-> BundleSerialise ObjectFileInfo
-> Serialise ObjectFileInfo
Proxy ObjectFileInfo -> SchemaGen Schema
ObjectFileInfo -> Builder
forall a.
Typeable a
-> (Proxy a -> SchemaGen Schema)
-> (a -> Builder)
-> Extractor a
-> Decoder a
-> BundleSerialise a
-> Serialise a
bundleSerialise :: BundleSerialise ObjectFileInfo
$cbundleSerialise :: BundleSerialise ObjectFileInfo
decodeCurrent :: Decoder ObjectFileInfo
$cdecodeCurrent :: Decoder ObjectFileInfo
extractor :: Extractor ObjectFileInfo
$cextractor :: Extractor ObjectFileInfo
toBuilder :: ObjectFileInfo -> Builder
$ctoBuilder :: ObjectFileInfo -> Builder
schemaGen :: Proxy ObjectFileInfo -> SchemaGen Schema
$cschemaGen :: Proxy ObjectFileInfo -> SchemaGen Schema
$cp1Serialise :: Typeable ObjectFileInfo
Serialise)
loadFunc :: FilePath -> HS.HashSet (Function a) -> Maybe ScriptSession -> FunctionName -> [AtomType] -> Maybe FunctionBodyScript -> Maybe ObjectFileInfo -> IO (Function a)
loadFunc :: FilePath
-> HashSet (Function a)
-> Maybe ScriptSession
-> IncDepName
-> [AtomType]
-> Maybe IncDepName
-> Maybe ObjectFileInfo
-> IO (Function a)
loadFunc FilePath
objFilesDir HashSet (Function a)
precompiledFuncs Maybe ScriptSession
_mScriptSession IncDepName
funcName' [AtomType]
_funcType Maybe IncDepName
mFuncScript Maybe ObjectFileInfo
mObjInfo = do
case Maybe ObjectFileInfo
mObjInfo of
Just (ObjectFileInfo (FilePath
path, FilePath
modName, FilePath
entryFunc)) -> do
Either LoadSymbolError [Function a]
eFuncs <- FilePath
-> FilePath
-> Maybe FilePath
-> FilePath
-> IO (Either LoadSymbolError [Function a])
forall a.
FilePath
-> FilePath
-> Maybe FilePath
-> FilePath
-> IO (Either LoadSymbolError [Function a])
loadFunctions FilePath
modName FilePath
entryFunc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
objFilesDir) FilePath
path
case Either LoadSymbolError [Function a]
eFuncs of
Left LoadSymbolError
_ -> FilePath -> IO (Function a)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Function a)) -> FilePath -> IO (Function a)
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to load " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
path
Right [Function a]
funcs ->
case (Function a -> Bool) -> [Function a] -> [Function a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Function a
f -> Function a -> IncDepName
forall a. Function a -> IncDepName
funcName Function a
f IncDepName -> IncDepName -> Bool
forall a. Eq a => a -> a -> Bool
== IncDepName
funcName'
) [Function a]
funcs of
[Function a
f] -> Function a -> IO (Function a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Function a
f
[] -> FilePath -> IO (Function a)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Function a)) -> FilePath -> IO (Function a)
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to find function \"" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> IncDepName -> FilePath
T.unpack IncDepName
funcName' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\" in " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
path
[Function a]
_ -> FilePath -> IO (Function a)
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO (Function a)) -> FilePath -> IO (Function a)
forall a b. (a -> b) -> a -> b
$ FilePath
"impossible error in loading \"" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> IncDepName -> FilePath
T.unpack IncDepName
funcName' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""
Maybe ObjectFileInfo
Nothing ->
case Maybe IncDepName
mFuncScript of
Maybe IncDepName
Nothing -> case IncDepName
-> HashSet (Function a) -> Either RelationalError (Function a)
forall a.
IncDepName
-> HashSet (Function a) -> Either RelationalError (Function a)
functionForName IncDepName
funcName' HashSet (Function a)
precompiledFuncs of
Left RelationalError
_ -> FilePath -> IO (Function a)
forall a. HasCallStack => FilePath -> a
error (FilePath
"expected precompiled atom function: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IncDepName -> FilePath
T.unpack IncDepName
funcName')
Right Function a
realFunc -> Function a -> IO (Function a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Function a
realFunc
Just IncDepName
_funcScript ->
#ifdef PM36_HASKELL_SCRIPTING
case Maybe ScriptSession
_mScriptSession of
Maybe ScriptSession
Nothing -> FilePath -> IO (Function a)
forall a. HasCallStack => FilePath -> a
error FilePath
"attempted to read serialized AtomFunction without scripting enabled"
Just ScriptSession
scriptSession -> do
Either ScriptCompilationError a
eCompiledScript <- Maybe FilePath
-> Ghc (Either ScriptCompilationError a)
-> IO (Either ScriptCompilationError a)
forall a. Maybe FilePath -> Ghc a -> IO a
runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libdir) (Ghc (Either ScriptCompilationError a)
-> IO (Either ScriptCompilationError a))
-> Ghc (Either ScriptCompilationError a)
-> IO (Either ScriptCompilationError a)
forall a b. (a -> b) -> a -> b
$ do
HscEnv -> Ghc ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (ScriptSession -> HscEnv
hscEnv ScriptSession
scriptSession)
Type -> IncDepName -> Ghc (Either ScriptCompilationError a)
forall a.
Type -> IncDepName -> Ghc (Either ScriptCompilationError a)
compileScript (ScriptSession -> Type
atomFunctionBodyType ScriptSession
scriptSession) IncDepName
_funcScript
case Either ScriptCompilationError a
eCompiledScript of
Left ScriptCompilationError
err -> ScriptCompilationError -> IO (Function a)
forall e a. Exception e => e -> IO a
throwIO ScriptCompilationError
err
Right a
compiledScript -> Function a -> IO (Function a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Function :: forall a. IncDepName -> [AtomType] -> FunctionBody a -> Function a
Function { funcName :: IncDepName
funcName = IncDepName
funcName',
funcType :: [AtomType]
funcType = [AtomType]
_funcType,
funcBody :: FunctionBody a
funcBody = IncDepName -> a -> FunctionBody a
forall a. IncDepName -> a -> FunctionBody a
FunctionScriptBody IncDepName
_funcScript a
compiledScript }
#else
error "Haskell scripting is disabled"
#endif
readAtomFunc :: FilePath -> FunctionName -> Maybe ScriptSession -> AtomFunctions -> IO AtomFunction
#if !defined(PM36_HASKELL_SCRIPTING)
readAtomFunc _ _ _ _ = error "Haskell scripting is disabled"
#else
readAtomFunc :: FilePath
-> IncDepName
-> Maybe ScriptSession
-> HashSet (Function AtomFunctionBodyType)
-> IO (Function AtomFunctionBodyType)
readAtomFunc FilePath
transDir IncDepName
funcName' Maybe ScriptSession
mScriptSession HashSet (Function AtomFunctionBodyType)
precompiledFuncs = do
let atomFuncPath :: FilePath
atomFuncPath = FilePath -> FilePath
atomFuncsPath FilePath
transDir
([AtomType]
funcType', Maybe IncDepName
mFuncScript) <- FilePath -> IO ([AtomType], Maybe IncDepName)
forall a. Serialise a => FilePath -> IO a
readFileDeserialise @([AtomType],Maybe T.Text) FilePath
atomFuncPath
case Maybe IncDepName
mFuncScript of
Maybe IncDepName
Nothing -> case IncDepName
-> HashSet (Function AtomFunctionBodyType)
-> Either RelationalError (Function AtomFunctionBodyType)
atomFunctionForName IncDepName
funcName' HashSet (Function AtomFunctionBodyType)
precompiledFuncs of
Left RelationalError
_ -> FilePath -> IO (Function AtomFunctionBodyType)
forall a. HasCallStack => FilePath -> a
error (FilePath
"expected precompiled atom function: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IncDepName -> FilePath
T.unpack IncDepName
funcName')
Right Function AtomFunctionBodyType
realFunc -> Function AtomFunctionBodyType -> IO (Function AtomFunctionBodyType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Function AtomFunctionBodyType
realFunc
Just IncDepName
funcScript ->
case Maybe ScriptSession
mScriptSession of
Maybe ScriptSession
Nothing -> FilePath -> IO (Function AtomFunctionBodyType)
forall a. HasCallStack => FilePath -> a
error FilePath
"attempted to read serialized AtomFunction without scripting enabled"
Just ScriptSession
scriptSession -> do
Either ScriptCompilationError AtomFunctionBodyType
eCompiledScript <- Maybe FilePath
-> Ghc (Either ScriptCompilationError AtomFunctionBodyType)
-> IO (Either ScriptCompilationError AtomFunctionBodyType)
forall a. Maybe FilePath -> Ghc a -> IO a
runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libdir) (Ghc (Either ScriptCompilationError AtomFunctionBodyType)
-> IO (Either ScriptCompilationError AtomFunctionBodyType))
-> Ghc (Either ScriptCompilationError AtomFunctionBodyType)
-> IO (Either ScriptCompilationError AtomFunctionBodyType)
forall a b. (a -> b) -> a -> b
$ do
HscEnv -> Ghc ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (ScriptSession -> HscEnv
hscEnv ScriptSession
scriptSession)
Type
-> IncDepName
-> Ghc (Either ScriptCompilationError AtomFunctionBodyType)
forall a.
Type -> IncDepName -> Ghc (Either ScriptCompilationError a)
compileScript (ScriptSession -> Type
atomFunctionBodyType ScriptSession
scriptSession) IncDepName
funcScript
case Either ScriptCompilationError AtomFunctionBodyType
eCompiledScript of
Left ScriptCompilationError
err -> ScriptCompilationError -> IO (Function AtomFunctionBodyType)
forall e a. Exception e => e -> IO a
throwIO ScriptCompilationError
err
Right AtomFunctionBodyType
compiledScript -> Function AtomFunctionBodyType -> IO (Function AtomFunctionBodyType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Function :: forall a. IncDepName -> [AtomType] -> FunctionBody a -> Function a
Function { funcName :: IncDepName
funcName = IncDepName
funcName',
funcType :: [AtomType]
funcType = [AtomType]
funcType',
funcBody :: FunctionBody AtomFunctionBodyType
funcBody = IncDepName
-> AtomFunctionBodyType -> FunctionBody AtomFunctionBodyType
forall a. IncDepName -> a -> FunctionBody a
FunctionScriptBody IncDepName
funcScript AtomFunctionBodyType
compiledScript }
#endif
writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()
writeIncDep :: DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()
writeIncDep DiskSync
sync FilePath
transDir (IncDepName
incDepName, InclusionDependency
incDep) = do
DiskSync -> FilePath -> InclusionDependency -> IO ()
forall a. Serialise a => DiskSync -> FilePath -> a -> IO ()
writeSerialiseSync DiskSync
sync (FilePath -> FilePath
incDepsDir FilePath
transDir FilePath -> FilePath -> FilePath
</> IncDepName -> FilePath
T.unpack IncDepName
incDepName) InclusionDependency
incDep
writeIncDeps :: DiskSync -> FilePath -> M.Map IncDepName InclusionDependency -> IO ()
writeIncDeps :: DiskSync -> FilePath -> Map IncDepName InclusionDependency -> IO ()
writeIncDeps DiskSync
sync FilePath
transDir Map IncDepName InclusionDependency
incdeps =
FilePath -> IO () -> IO ()
traceBlock FilePath
"write incdeps" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ((IncDepName, InclusionDependency) -> IO ())
-> [(IncDepName, InclusionDependency)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DiskSync -> FilePath -> (IncDepName, InclusionDependency) -> IO ()
writeIncDep DiskSync
sync FilePath
transDir) ([(IncDepName, InclusionDependency)] -> IO ())
-> [(IncDepName, InclusionDependency)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map IncDepName InclusionDependency
-> [(IncDepName, InclusionDependency)]
forall k a. Map k a -> [(k, a)]
M.toList Map IncDepName InclusionDependency
incdeps
readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)
readIncDep :: FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)
readIncDep FilePath
transDir IncDepName
incdepName = do
let incDepPath :: FilePath
incDepPath = FilePath -> FilePath
incDepsDir FilePath
transDir FilePath -> FilePath -> FilePath
</> IncDepName -> FilePath
T.unpack IncDepName
incdepName
InclusionDependency
incDepData <- FilePath -> IO InclusionDependency
forall a. Serialise a => FilePath -> IO a
readFileDeserialise FilePath
incDepPath
(IncDepName, InclusionDependency)
-> IO (IncDepName, InclusionDependency)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IncDepName
incdepName, InclusionDependency
incDepData)
readIncDeps :: FilePath -> IO (M.Map IncDepName InclusionDependency)
readIncDeps :: FilePath -> IO (Map IncDepName InclusionDependency)
readIncDeps FilePath
transDir = do
let incDepsPath :: FilePath
incDepsPath = FilePath -> FilePath
incDepsDir FilePath
transDir
[FilePath]
incDepNames <- FilePath -> IO [FilePath]
getDirectoryNames FilePath
incDepsPath
[(IncDepName, InclusionDependency)]
-> Map IncDepName InclusionDependency
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(IncDepName, InclusionDependency)]
-> Map IncDepName InclusionDependency)
-> IO [(IncDepName, InclusionDependency)]
-> IO (Map IncDepName InclusionDependency)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (IncDepName, InclusionDependency))
-> [FilePath] -> IO [(IncDepName, InclusionDependency)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> IncDepName -> IO (IncDepName, InclusionDependency)
readIncDep FilePath
transDir (IncDepName -> IO (IncDepName, InclusionDependency))
-> (FilePath -> IncDepName)
-> FilePath
-> IO (IncDepName, InclusionDependency)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IncDepName
T.pack) [FilePath]
incDepNames
readSubschemas :: FilePath -> IO Subschemas
readSubschemas :: FilePath -> IO Subschemas
readSubschemas FilePath
transDir = do
let sschemasPath :: FilePath
sschemasPath = FilePath -> FilePath
subschemasPath FilePath
transDir
FilePath -> IO Subschemas
forall a. Serialise a => FilePath -> IO a
readFileDeserialise FilePath
sschemasPath
writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()
writeSubschemas :: DiskSync -> FilePath -> Subschemas -> IO ()
writeSubschemas DiskSync
sync FilePath
transDir Subschemas
sschemas = do
let sschemasPath :: FilePath
sschemasPath = FilePath -> FilePath
subschemasPath FilePath
transDir
FilePath -> IO () -> IO ()
traceBlock FilePath
"write subschemas" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DiskSync -> FilePath -> Subschemas -> IO ()
forall a. Serialise a => DiskSync -> FilePath -> a -> IO ()
writeSerialiseSync DiskSync
sync FilePath
sschemasPath Subschemas
sschemas
writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()
writeTypeConstructorMapping :: DiskSync -> FilePath -> TypeConstructorMapping -> IO ()
writeTypeConstructorMapping DiskSync
sync FilePath
path TypeConstructorMapping
types = do
let atPath :: FilePath
atPath = FilePath -> FilePath
typeConsPath FilePath
path
FilePath -> IO () -> IO ()
traceBlock FilePath
"write tconsmap" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DiskSync -> FilePath -> TypeConstructorMapping -> IO ()
forall a. Serialise a => DiskSync -> FilePath -> a -> IO ()
writeSerialiseSync DiskSync
sync FilePath
atPath TypeConstructorMapping
types
readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping
readTypeConstructorMapping :: FilePath -> IO TypeConstructorMapping
readTypeConstructorMapping FilePath
path = do
let atPath :: FilePath
atPath = FilePath -> FilePath
typeConsPath FilePath
path
FilePath -> IO TypeConstructorMapping
forall a. Serialise a => FilePath -> IO a
readFileDeserialise FilePath
atPath