{-# 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
import Unsafe.Coerce
import GHC.LanguageExtensions (Extension(OverloadedStrings,ExtendedDefaultRules,ImplicitPrelude,ScopedTypeVariables))
#if MIN_VERSION_ghc(9,2,0)
import GHC.Utils.Panic (handleGhcException)
import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming))
import GHC.Types.SourceText (SourceText(NoSourceText))
import GHC.Unit.Types (IsBootInterface(NotBoot))
import GHC.Driver.Ppr (showSDocForUser)
import GHC.Core.Type (eqType)
import GHC.Types.TyThing.Ppr (pprTypeForUser)
import GHC.Utils.Encoding (zEncodeString)
import GHC.Unit.State (emptyUnitState)
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Utils.Panic (handleGhcException)
import GHC.Driver.Session (projectVersion, PackageDBFlag(PackageDB), PkgDbRef(PkgDbPath), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming))
import GHC.Types.Basic (SourceText(NoSourceText))
import GHC.Unit.Types (IsBootInterface(NotBoot))
import GHC.Core.Type (eqType)
import GHC.Utils.Outputable (showSDocForUser)
import GHC.Utils.Encoding (zEncodeString)
import GHC.Core.Ppr.TyThing (pprTypeForUser)
#else
import BasicTypes (SourceText(NoSourceText))
import Outputable (showSDocForUser)
import PprTyThing (pprTypeForUser)
import Type (eqType)
import Encoding (zEncodeString)
import Panic (handleGhcException)
import DynFlags (projectVersion, PkgConfRef(PkgConfFile), TrustFlag(TrustPackage), gopt_set, xopt_set, PackageFlag(ExposePackage), PackageArg(PackageArg), ModRenaming(ModRenaming), PackageDBFlag(PackageDB))
#endif
import GHC.Exts (addrToAny#)
import GHC.Ptr (Ptr(..))
import GHCi.ObjLink (initObjLinker, ShouldRetainCAFs(RetainCAFs), resolveObjs, lookupSymbol, loadDLL, loadObj)
#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"
]
#if MIN_VERSION_ghc(9,0,0)
let pkgConf = PkgDbPath
#else
let pkgConf :: String -> PkgConfRef
pkgConf = String -> PkgConfRef
PkgConfFile
#endif
let localPkgPaths :: [PkgConfRef]
localPkgPaths = (String -> PkgConfRef) -> [String] -> [PkgConfRef]
forall a b. (a -> b) -> [a] -> [b]
map String -> PkgConfRef
pkgConf ([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 {
#if MIN_VERSION_ghc(9,2,0)
backend = Interpreter,
#else
hscTarget :: HscTarget
hscTarget = HscTarget
HscInterpreted ,
#endif
ghcLink :: GhcLink
ghcLink = GhcLink
LinkInMemory,
safeHaskell :: SafeHaskellMode
safeHaskell = SafeHaskellMode
Sf_Trustworthy,
safeInfer :: Bool
safeInfer = Bool
True,
safeInferred :: Bool
safeInferred = Bool
True,
trustFlags :: [TrustFlag]
trustFlags = (String -> TrustFlag) -> [String] -> [TrustFlag]
forall a b. (a -> b) -> [a] -> [b]
map String -> TrustFlag
TrustPackage [String]
required_packages,
packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags [PackageFlag] -> [PackageFlag] -> [PackageFlag]
forall a. [a] -> [a] -> [a]
++ [PackageFlag]
packages,
packageDBFlags :: [PackageDBFlag]
packageDBFlags = (PkgConfRef -> PackageDBFlag) -> [PkgConfRef] -> [PackageDBFlag]
forall a b. (a -> b) -> [a] -> [b]
map PkgConfRef -> PackageDBFlag
PackageDB [PkgConfRef]
localPkgPaths
}
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
xopts :: [Extension]
xopts = [Extension
OverloadedStrings, Extension
ExtendedDefaultRules, Extension
ImplicitPrelude, Extension
ScopedTypeVariables]
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"]
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
[InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags DynFlags
dflags'
let safeImportDecl :: String -> Maybe String -> ImportDecl (GhcPass 'Parsed)
safeImportDecl :: String -> Maybe String -> ImportDecl (GhcPass 'Parsed)
safeImportDecl String
fullModuleName Maybe String
mQualifiedName = 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 {
ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText,
#if MIN_VERSION_ghc(9,2,0)
ideclExt = noAnn,
#else
ideclExt :: XCImportDecl (GhcPass 'Parsed)
ideclExt = NoExtField
XCImportDecl (GhcPass 'Parsed)
noExtField,
#endif
#if MIN_VERSION_ghc(9,2,0)
ideclName = noLocA (mkModuleName fullModuleName),
#else
ideclName :: Located ModuleName
ideclName = SrcSpanLess (Located ModuleName) -> Located ModuleName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (String -> ModuleName
mkModuleName String
fullModuleName),
#endif
ideclPkgQual :: Maybe StringLiteral
ideclPkgQual = Maybe StringLiteral
forall a. Maybe a
Nothing,
#if MIN_VERSION_ghc(9,0,0)
ideclSource = NotBoot,
#else
ideclSource :: Bool
ideclSource = Bool
False,
#endif
ideclSafe :: Bool
ideclSafe = Bool
True,
ideclImplicit :: Bool
ideclImplicit = Bool
False,
ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mQualifiedName then ImportDeclQualifiedStyle
QualifiedPre else ImportDeclQualifiedStyle
NotQualified,
#if MIN_VERSION_ghc(9,2,0)
ideclAs = Just (noLocA (mkModuleName fullModuleName)),
#else
ideclAs :: Maybe (Located ModuleName)
ideclAs = 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 (String -> Located ModuleName)
-> Maybe String -> Maybe (Located ModuleName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mQualifiedName,
#endif
ideclHiding :: Maybe (Bool, Located [LIE (GhcPass 'Parsed)])
ideclHiding = Maybe (Bool, Located [LIE (GhcPass 'Parsed)])
forall a. Maybe a
Nothing
}
unqualifiedModules :: [InteractiveImport]
unqualifiedModules = (String -> InteractiveImport) -> [String] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map (\String
modn -> ImportDecl (GhcPass 'Parsed) -> InteractiveImport
IIDecl (ImportDecl (GhcPass 'Parsed) -> InteractiveImport)
-> ImportDecl (GhcPass 'Parsed) -> InteractiveImport
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> ImportDecl (GhcPass 'Parsed)
safeImportDecl String
modn Maybe String
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"]
qualifiedModules :: [InteractiveImport]
qualifiedModules = ((String, String) -> InteractiveImport)
-> [(String, String)] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
modn, String
qualNam) -> ImportDecl (GhcPass 'Parsed) -> InteractiveImport
IIDecl (ImportDecl (GhcPass 'Parsed) -> InteractiveImport)
-> ImportDecl (GhcPass 'Parsed) -> InteractiveImport
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> ImportDecl (GhcPass 'Parsed)
safeImportDecl String
modn (String -> Maybe String
forall a. a -> Maybe a
Just 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 (GhcPass 'Parsed) -> InteractiveImport
IIDecl (ModuleName -> ImportDecl (GhcPass 'Parsed)
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
#if MIN_VERSION_ghc(9,2,0)
showType dflags ty = showSDocForUser dflags emptyUnitState alwaysQualify (pprTypeForUser ty)
#else
showType :: DynFlags -> Type -> String
showType DynFlags
dflags Type
ty = DynFlags -> PrintUnqualified -> SDoc -> String
showSDocForUser DynFlags
dflags PrintUnqualified
alwaysQualify (Type -> SDoc
pprTypeForUser Type
ty)
#endif
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
Type
funcType <- TcRnExprMode -> String -> Ghc Type
forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Type
GHC.exprType TcRnExprMode
TM_Inst (Text -> String
unpack Text
inp)
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
ShouldRetainCAFs -> IO ()
initObjLinker ShouldRetainCAFs
RetainCAFs
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