{-# 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"

-- | where compiled modules are stored within the database directory
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
    --create sub directories
    (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)    --move the temp directory to final location
    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 })
  --write additional data for object-loaded functions (which are not built-in or scripted)
  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
  --we always return the pre-compiled functions
  --load object files and functions in objects (shared libraries or flat object files)
  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)
-- deriving Serialise via WineryVariant ObjectFileInfo

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
    --load from shared or static object library
    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
        --handle pre-compiled case- pull it from the precompiled list
        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
          --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored
          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
        --handle a real Haskell scripted function- compile and load
        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
              --risk of GHC exception during compilation here
              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                                    

--if the script session is enabled, compile the script, otherwise, hard error!  
  
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
    --handle pre-compiled case- pull it from the precompiled list
    Maybe IncDepName
Nothing -> case IncDepName
-> HashSet (Function AtomFunctionBodyType)
-> Either RelationalError (Function AtomFunctionBodyType)
atomFunctionForName IncDepName
funcName' HashSet (Function AtomFunctionBodyType)
precompiledFuncs of
      --WARNING: possible landmine here if we remove a precompiled atom function in the future, then the transaction cannot be restored
      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
    --handle a real Haskell scripted function- compile and load
    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
          --risk of GHC exception during compilation here
          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