{-# LANGUAGE UnboxedTuples, KindSignatures, DataKinds #-}
#ifdef PM36_HASKELL_SCRIPTING
{-# LANGUAGE MagicHash #-}
#endif
module ProjectM36.ScriptSession where
#ifdef PM36_HASKELL_SCRIPTING
import ProjectM36.Error
import GHC
import Control.Exception
import Control.Monad
import System.IO.Error
import System.Directory
import Control.Monad.IO.Class
import System.FilePath.Glob
import System.FilePath
import System.Info (os, arch)
import Data.Text (Text, unpack)
import Data.Maybe
import GHC.Paths (libdir)
import System.Environment
#if __GLASGOW_HASKELL__ >= 800
import GHC.LanguageExtensions
import GHCi.ObjLink
#else
import ObjLink
#endif
#if __GLASGOW_HASKELL__ >= 802
import BasicTypes
#endif
import DynFlags
import Panic
import Outputable
import PprTyThing
import Unsafe.Coerce
#if __GLASGOW_HASKELL__ >= 802
import Type
#elif __GLASGOW_HASKELL__ >= 710
import Type hiding (pprTyThing)
#else
#endif
import GHC.Exts (addrToAny#)
import GHC.Ptr (Ptr(..))
import Encoding
#endif
data ScriptSession = ScriptSession {
#ifdef PM36_HASKELL_SCRIPTING
ScriptSession -> HscEnv
hscEnv :: HscEnv,
ScriptSession -> Type
atomFunctionBodyType :: Type,
ScriptSession -> Type
dbcFunctionBodyType :: Type
#endif
}
#ifdef PM36_HASKELL_SCRIPTING
data ScriptSessionError = ScriptSessionLoadError GhcException
| ScriptingDisabled
deriving (Int -> ScriptSessionError -> ShowS
[ScriptSessionError] -> ShowS
ScriptSessionError -> String
(Int -> ScriptSessionError -> ShowS)
-> (ScriptSessionError -> String)
-> ([ScriptSessionError] -> ShowS)
-> Show ScriptSessionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptSessionError] -> ShowS
$cshowList :: [ScriptSessionError] -> ShowS
show :: ScriptSessionError -> String
$cshow :: ScriptSessionError -> String
showsPrec :: Int -> ScriptSessionError -> ShowS
$cshowsPrec :: Int -> ScriptSessionError -> ShowS
Show)
#else
data ScriptSessionError = ScriptingDisabled
deriving (Show)
#endif
data LoadSymbolError = LoadSymbolError | SecurityLoadSymbolError
type ModName = String
type FuncName = String
initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)
#if !defined(PM36_HASKELL_SCRIPTING)
initScriptSession _ = pure (Left ScriptingDisabled)
#else
initScriptSession :: [String] -> IO (Either ScriptSessionError ScriptSession)
initScriptSession [String]
ghcPkgPaths = do
Either () String
eHomeDir <- (IOError -> Maybe ()) -> IO String -> IO (Either () String)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) IO String
getHomeDirectory
let homeDir :: String
homeDir = (() -> String) -> ShowS -> Either () String -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> () -> String
forall a b. a -> b -> a
const String
"/") ShowS
forall a. a -> a
id Either () String
eHomeDir
let excHandler :: GhcException -> f (Either ScriptSessionError b)
excHandler GhcException
exc = Either ScriptSessionError b -> f (Either ScriptSessionError b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ScriptSessionError b -> f (Either ScriptSessionError b))
-> Either ScriptSessionError b -> f (Either ScriptSessionError b)
forall a b. (a -> b) -> a -> b
$ ScriptSessionError -> Either ScriptSessionError b
forall a b. a -> Either a b
Left (GhcException -> ScriptSessionError
ScriptSessionLoadError GhcException
exc)
(GhcException -> IO (Either ScriptSessionError ScriptSession))
-> IO (Either ScriptSessionError ScriptSession)
-> IO (Either ScriptSessionError ScriptSession)
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException GhcException -> IO (Either ScriptSessionError ScriptSession)
forall (f :: * -> *) b.
Applicative f =>
GhcException -> f (Either ScriptSessionError b)
excHandler (IO (Either ScriptSessionError ScriptSession)
-> IO (Either ScriptSessionError ScriptSession))
-> IO (Either ScriptSessionError ScriptSession)
-> IO (Either ScriptSessionError ScriptSession)
forall a b. (a -> b) -> a -> b
$ Maybe String
-> Ghc (Either ScriptSessionError ScriptSession)
-> IO (Either ScriptSessionError ScriptSession)
forall a. Maybe String -> Ghc a -> IO a
runGhc (String -> Maybe String
forall a. a -> Maybe a
Just String
libdir) (Ghc (Either ScriptSessionError ScriptSession)
-> IO (Either ScriptSessionError ScriptSession))
-> Ghc (Either ScriptSessionError ScriptSession)
-> IO (Either ScriptSessionError ScriptSession)
forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
let ghcVersion :: String
ghcVersion = DynFlags -> String
projectVersion DynFlags
dflags
Maybe String
mNixLibDir <- IO (Maybe String) -> Ghc (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Ghc (Maybe String))
-> IO (Maybe String) -> Ghc (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"NIX_GHC_LIBDIR"
[String]
sandboxPkgPaths <- IO [String] -> Ghc [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> Ghc [String]) -> IO [String] -> Ghc [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
glob [
String
".cabal-sandbox/*ghc-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ghcVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-packages.conf.d",
String
".stack-work/install/*/*/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ghcVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/pkgdb",
String
".stack-work/install/*/pkgdb/",
String
"C:/sr/snapshots/b201cfe6/pkgdb",
String
homeDir String -> ShowS
</> String
".stack/snapshots/*/*/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ghcVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/pkgdb"
]
let localPkgPaths :: [PkgConfRef]
localPkgPaths = (String -> PkgConfRef) -> [String] -> [PkgConfRef]
forall a b. (a -> b) -> [a] -> [b]
map String -> PkgConfRef
PkgConfFile ([String]
ghcPkgPaths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
sandboxPkgPaths [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList Maybe String
mNixLibDir)
let dflags' :: DynFlags
dflags' = DynFlags -> DynFlags
applyGopts (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
applyXopts (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
dflags { hscTarget :: HscTarget
hscTarget = HscTarget
HscInterpreted ,
ghcLink :: GhcLink
ghcLink = GhcLink
LinkInMemory,
safeHaskell :: SafeHaskellMode
safeHaskell = SafeHaskellMode
Sf_Trustworthy,
safeInfer :: Bool
safeInfer = Bool
True,
safeInferred :: Bool
safeInferred = Bool
True,
#if __GLASGOW_HASKELL__ >= 800
trustFlags :: [TrustFlag]
trustFlags = (String -> TrustFlag) -> [String] -> [TrustFlag]
forall a b. (a -> b) -> [a] -> [b]
map String -> TrustFlag
TrustPackage [String]
required_packages,
#endif
packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags [PackageFlag] -> [PackageFlag] -> [PackageFlag]
forall a. [a] -> [a] -> [a]
++ [PackageFlag]
packages,
#if __GLASGOW_HASKELL__ >= 802
packageDBFlags :: [PackageDBFlag]
packageDBFlags = (PkgConfRef -> PackageDBFlag) -> [PkgConfRef] -> [PackageDBFlag]
forall a b. (a -> b) -> [a] -> [b]
map PkgConfRef -> PackageDBFlag
PackageDB [PkgConfRef]
localPkgPaths
#else
extraPkgConfs = const (localPkgPaths ++ [UserPkgConf, GlobalPkgConf])
#endif
}
applyGopts :: DynFlags -> DynFlags
applyGopts DynFlags
flags = (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
flags [GeneralFlag]
forall a. [a]
gopts
applyXopts :: DynFlags -> DynFlags
applyXopts DynFlags
flags = (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> Extension -> DynFlags
xopt_set DynFlags
flags [Extension]
xopts
#if __GLASGOW_HASKELL__ >= 800
xopts :: [Extension]
xopts = [Extension
OverloadedStrings, Extension
ExtendedDefaultRules, Extension
ImplicitPrelude, Extension
ScopedTypeVariables]
#else
xopts = [Opt_OverloadedStrings, Opt_ExtendedDefaultRules, Opt_ImplicitPrelude, Opt_ScopedTypeVariables]
#endif
gopts :: [a]
gopts = []
required_packages :: [String]
required_packages = [String
"base",
String
"containers",
String
"Glob",
String
"directory",
String
"unordered-containers",
String
"hashable",
String
"uuid",
String
"mtl",
String
"vector",
String
"text",
String
"time",
String
"project-m36",
String
"bytestring"]
#if __GLASGOW_HASKELL__ >= 800
packages :: [PackageFlag]
packages = (String -> PackageFlag) -> [String] -> [PackageFlag]
forall a b. (a -> b) -> [a] -> [b]
map (\String
m -> String -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage (String
"-package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m) (String -> PackageArg
PackageArg String
m) (Bool -> [(ModuleName, ModuleName)] -> ModRenaming
ModRenaming Bool
True [])) [String]
required_packages
#else
packages = map TrustPackage required_packages
#endif
[InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
dflags'
let safeImportDecl :: ModuleName -> Maybe (Located ModuleName) -> ImportDecl (GhcPass c)
safeImportDecl ModuleName
mn Maybe (Located ModuleName)
mQual = ImportDecl :: forall pass.
XCImportDecl pass
-> SourceText
-> Located ModuleName
-> Maybe StringLiteral
-> Bool
-> Bool
-> ImportDeclQualifiedStyle
-> Bool
-> Maybe (Located ModuleName)
-> Maybe (Bool, Located [LIE pass])
-> ImportDecl pass
ImportDecl {
#if __GLASGOW_HASKELL__ >= 802
ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText,
#else
ideclSourceSrc = Nothing,
#endif
#if __GLASGOW_HASKELL__ >= 810
ideclExt :: XCImportDecl (GhcPass c)
ideclExt = NoExtField
XCImportDecl (GhcPass c)
noExtField,
#elif __GLASGOW_HASKELL__ >= 806
ideclExt = NoExt,
#endif
ideclName :: Located ModuleName
ideclName = SrcSpanLess (Located ModuleName) -> Located ModuleName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc SrcSpanLess (Located ModuleName)
ModuleName
mn,
ideclPkgQual :: Maybe StringLiteral
ideclPkgQual = Maybe StringLiteral
forall a. Maybe a
Nothing,
ideclSource :: Bool
ideclSource = Bool
False,
ideclSafe :: Bool
ideclSafe = Bool
True,
ideclImplicit :: Bool
ideclImplicit = Bool
False,
#if __GLASGOW_HASKELL__ >= 810
ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = if Maybe (Located ModuleName) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Located ModuleName)
mQual then ImportDeclQualifiedStyle
QualifiedPre else ImportDeclQualifiedStyle
NotQualified,
#else
ideclQualified = isJust mQual,
#endif
ideclAs :: Maybe (Located ModuleName)
ideclAs = Maybe (Located ModuleName)
mQual,
ideclHiding :: Maybe (Bool, Located [LIE (GhcPass c)])
ideclHiding = Maybe (Bool, Located [LIE (GhcPass c)])
forall a. Maybe a
Nothing
}
#if __GLASGOW_HASKELL__ >= 806
:: ImportDecl (GhcPass (c :: Pass))
#endif
unqualifiedModules :: [InteractiveImport]
unqualifiedModules = (String -> InteractiveImport) -> [String] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map (\String
modn -> ImportDecl GhcPs -> InteractiveImport
IIDecl (ImportDecl GhcPs -> InteractiveImport)
-> ImportDecl GhcPs -> InteractiveImport
forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe (Located ModuleName) -> ImportDecl GhcPs
forall (c :: Pass).
ModuleName -> Maybe (Located ModuleName) -> ImportDecl (GhcPass c)
safeImportDecl (String -> ModuleName
mkModuleName String
modn) Maybe (Located ModuleName)
forall a. Maybe a
Nothing) [
String
"Prelude",
String
"Data.Map",
String
"Data.Either",
String
"Data.Time.Calendar",
String
"Control.Monad.State",
String
"ProjectM36.Base",
String
"ProjectM36.Relation",
String
"ProjectM36.AtomFunctionError",
String
"ProjectM36.DatabaseContextFunctionError",
String
"ProjectM36.DatabaseContextFunctionUtils",
String
"ProjectM36.RelationalExpression"]
#if __GLASGOW_HASKELL__ >= 802
mkModName :: String -> Located ModuleName
mkModName = ModuleName -> Located ModuleName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (ModuleName -> Located ModuleName)
-> (String -> ModuleName) -> String -> Located ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
mkModuleName
#else
mkModName = mkModuleName
#endif
qualifiedModules :: [InteractiveImport]
qualifiedModules = ((String, String) -> InteractiveImport)
-> [(String, String)] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
modn, String
qualNam) -> ImportDecl GhcPs -> InteractiveImport
IIDecl (ImportDecl GhcPs -> InteractiveImport)
-> ImportDecl GhcPs -> InteractiveImport
forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe (Located ModuleName) -> ImportDecl GhcPs
forall (c :: Pass).
ModuleName -> Maybe (Located ModuleName) -> ImportDecl (GhcPass c)
safeImportDecl (String -> ModuleName
mkModuleName String
modn) (Located ModuleName -> Maybe (Located ModuleName)
forall a. a -> Maybe a
Just (String -> Located ModuleName
mkModName String
qualNam))) [
(String
"Data.Text", String
"T")
]
[InteractiveImport] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext ([InteractiveImport]
unqualifiedModules [InteractiveImport] -> [InteractiveImport] -> [InteractiveImport]
forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
qualifiedModules)
HscEnv
env <- Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
Type
atomFuncType <- String -> Ghc Type
mkTypeForName String
"AtomFunctionBodyType"
Type
dbcFuncType <- String -> Ghc Type
mkTypeForName String
"DatabaseContextFunctionBodyType"
Either ScriptSessionError ScriptSession
-> Ghc (Either ScriptSessionError ScriptSession)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptSession -> Either ScriptSessionError ScriptSession
forall a b. b -> Either a b
Right (HscEnv -> Type -> Type -> ScriptSession
ScriptSession HscEnv
env Type
atomFuncType Type
dbcFuncType))
addImport :: String -> Ghc ()
addImport :: String -> Ghc ()
addImport String
moduleNam = do
[InteractiveImport]
ctx <- Ghc [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
[InteractiveImport] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext (ImportDecl GhcPs -> InteractiveImport
IIDecl (ModuleName -> ImportDecl GhcPs
forall (p :: Pass). ModuleName -> ImportDecl (GhcPass p)
simpleImportDecl (String -> ModuleName
mkModuleName String
moduleNam)) InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
forall a. a -> [a] -> [a]
: [InteractiveImport]
ctx)
showType :: DynFlags -> Type -> String
showType :: DynFlags -> Type -> String
showType DynFlags
dflags Type
ty = DynFlags -> PrintUnqualified -> SDoc -> String
showSDocForUser DynFlags
dflags PrintUnqualified
alwaysQualify (Type -> SDoc
pprTypeForUser Type
ty)
mkTypeForName :: String -> Ghc Type
mkTypeForName :: String -> Ghc Type
mkTypeForName String
name = do
[Name]
lBodyName <- String -> Ghc [Name]
forall (m :: * -> *). GhcMonad m => String -> m [Name]
parseName String
name
case [Name]
lBodyName of
[] -> String -> Ghc Type
forall a. HasCallStack => String -> a
error (String
"failed to parse " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)
Name
_:Name
_:[Name]
_ -> String -> Ghc Type
forall a. HasCallStack => String -> a
error String
"too many name matches"
[Name
bodyName] -> do
Maybe TyThing
mThing <- Name -> Ghc (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
lookupName Name
bodyName
case Maybe TyThing
mThing of
Maybe TyThing
Nothing -> String -> Ghc Type
forall a. HasCallStack => String -> a
error (String
"failed to find " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)
Just (ATyCon TyCon
tyCon) -> case TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tyCon of
Just Type
typ -> Type -> Ghc Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
Maybe Type
Nothing -> String -> Ghc Type
forall a. HasCallStack => String -> a
error (String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a type synonym")
Just TyThing
_ -> String -> Ghc Type
forall a. HasCallStack => String -> a
error (String
"failed to find type synonym " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)
compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)
compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)
compileScript Type
funcType Text
script = do
let sScript :: String
sScript = Text -> String
unpack Text
script
Maybe ScriptCompilationError
mErr <- Type -> Text -> Ghc (Maybe ScriptCompilationError)
typeCheckScript Type
funcType Text
script
case Maybe ScriptCompilationError
mErr of
Just ScriptCompilationError
err -> Either ScriptCompilationError a
-> Ghc (Either ScriptCompilationError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptCompilationError -> Either ScriptCompilationError a
forall a b. a -> Either a b
Left ScriptCompilationError
err)
Maybe ScriptCompilationError
Nothing ->
a -> Either ScriptCompilationError a
forall a b. b -> Either a b
Right (a -> Either ScriptCompilationError a)
-> (HValue -> a) -> HValue -> Either ScriptCompilationError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HValue -> a
forall a b. a -> b
unsafeCoerce (HValue -> Either ScriptCompilationError a)
-> Ghc HValue -> Ghc (Either ScriptCompilationError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ghc HValue
forall (m :: * -> *). GhcMonad m => String -> m HValue
compileExpr String
sScript
typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)
typeCheckScript :: Type -> Text -> Ghc (Maybe ScriptCompilationError)
typeCheckScript Type
expectedType Text
inp = do
DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
#if __GLASGOW_HASKELL__ >= 802
Type
funcType <- TcRnExprMode -> String -> Ghc Type
forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Type
GHC.exprType TcRnExprMode
TM_Inst (Text -> String
unpack Text
inp)
#else
funcType <- GHC.exprType (unpack inp)
#endif
if Type -> Type -> Bool
eqType Type
funcType Type
expectedType then
Maybe ScriptCompilationError -> Ghc (Maybe ScriptCompilationError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ScriptCompilationError
forall a. Maybe a
Nothing
else
Maybe ScriptCompilationError -> Ghc (Maybe ScriptCompilationError)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptCompilationError -> Maybe ScriptCompilationError
forall a. a -> Maybe a
Just (String -> String -> ScriptCompilationError
TypeCheckCompilationError (DynFlags -> Type -> String
showType DynFlags
dflags Type
expectedType) (DynFlags -> Type -> String
showType DynFlags
dflags Type
funcType)))
mangleSymbol :: Maybe String -> String -> String -> String
mangleSymbol :: Maybe String -> String -> ShowS
mangleSymbol Maybe String
pkg String
module' String
valsym =
String
prefixUnderscore String -> ShowS
forall a. [a] -> [a] -> [a]
++
String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
p -> ShowS
zEncodeString String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_") Maybe String
pkg String -> ShowS
forall a. [a] -> [a] -> [a]
++
ShowS
zEncodeString String
module' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
zEncodeString String
valsym String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_closure"
data ObjectLoadMode = LoadObjectFile |
LoadDLLFile |
LoadAutoObjectFile
type ModuleDirectory = FilePath
loadFunctionFromDirectory :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> FilePath -> IO (Either LoadSymbolError a)
loadFunctionFromDirectory :: ObjectLoadMode
-> String
-> String
-> String
-> String
-> IO (Either LoadSymbolError a)
loadFunctionFromDirectory ObjectLoadMode
mode String
modName String
funcName String
modDir String
objPath =
if ShowS
takeFileName String
objPath String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
objPath then
Either LoadSymbolError a -> IO (Either LoadSymbolError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadSymbolError -> Either LoadSymbolError a
forall a b. a -> Either a b
Left LoadSymbolError
SecurityLoadSymbolError)
else
let fullObjPath :: String
fullObjPath = String
modDir String -> ShowS
</> String
objPath in
ObjectLoadMode
-> String -> String -> String -> IO (Either LoadSymbolError a)
forall a.
ObjectLoadMode
-> String -> String -> String -> IO (Either LoadSymbolError a)
loadFunction ObjectLoadMode
mode String
modName String
funcName String
fullObjPath
loadFunction :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> IO (Either LoadSymbolError a)
loadFunction :: ObjectLoadMode
-> String -> String -> String -> IO (Either LoadSymbolError a)
loadFunction ObjectLoadMode
loadMode String
modName String
funcName String
objPath = do
#if __GLASGOW_HASKELL__ >= 802
ShouldRetainCAFs -> IO ()
initObjLinker ShouldRetainCAFs
RetainCAFs
#else
initObjLinker
#endif
let loadFuncForSymbol :: IO (Either LoadSymbolError b)
loadFuncForSymbol = do
Bool
_ <- IO Bool
resolveObjs
Maybe (Ptr Any)
ptr <- String -> IO (Maybe (Ptr Any))
forall a. String -> IO (Maybe (Ptr a))
lookupSymbol (Maybe String -> String -> ShowS
mangleSymbol Maybe String
forall a. Maybe a
Nothing String
modName String
funcName)
case Maybe (Ptr Any)
ptr of
Maybe (Ptr Any)
Nothing -> Either LoadSymbolError b -> IO (Either LoadSymbolError b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadSymbolError -> Either LoadSymbolError b
forall a b. a -> Either a b
Left LoadSymbolError
LoadSymbolError)
Just (Ptr Addr#
addr) -> case Addr# -> (# b #)
forall a. Addr# -> (# a #)
addrToAny# Addr#
addr of
(# b
hval #) -> Either LoadSymbolError b -> IO (Either LoadSymbolError b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either LoadSymbolError b
forall a b. b -> Either a b
Right b
hval)
case ObjectLoadMode
loadMode of
ObjectLoadMode
LoadAutoObjectFile ->
if ShowS
takeExtension String
objPath String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".o" then
ObjectLoadMode
-> String -> String -> String -> IO (Either LoadSymbolError a)
forall a.
ObjectLoadMode
-> String -> String -> String -> IO (Either LoadSymbolError a)
loadFunction ObjectLoadMode
LoadObjectFile String
modName String
funcName String
objPath
else
ObjectLoadMode
-> String -> String -> String -> IO (Either LoadSymbolError a)
forall a.
ObjectLoadMode
-> String -> String -> String -> IO (Either LoadSymbolError a)
loadFunction ObjectLoadMode
LoadDLLFile String
modName String
funcName String
objPath
ObjectLoadMode
LoadObjectFile -> do
String -> IO ()
loadObj String
objPath
IO (Either LoadSymbolError a)
forall b. IO (Either LoadSymbolError b)
loadFuncForSymbol
ObjectLoadMode
LoadDLLFile -> do
Maybe String
mErr <- String -> IO (Maybe String)
loadDLL String
objPath
case Maybe String
mErr of
Just String
_ -> Either LoadSymbolError a -> IO (Either LoadSymbolError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadSymbolError -> Either LoadSymbolError a
forall a b. a -> Either a b
Left LoadSymbolError
LoadSymbolError)
Maybe String
Nothing -> IO (Either LoadSymbolError a)
forall b. IO (Either LoadSymbolError b)
loadFuncForSymbol
prefixUnderscore :: String
prefixUnderscore :: String
prefixUnderscore =
case (String
os,String
arch) of
(String
"mingw32",String
"x86_64") -> String
""
(String
"cygwin",String
"x86_64") -> String
""
(String
"mingw32",String
_) -> String
"_"
(String
"darwin",String
_) -> String
"_"
(String
"cygwin",String
_) -> String
"_"
(String, String)
_ -> String
""
#endif