{-# 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,6,0)
import Data.List.NonEmpty(NonEmpty(..))
#else
#endif
#if MIN_VERSION_ghc(9,6,0)
#else
#endif
#if MIN_VERSION_ghc(9,6,0)
import GHC.Core.TyCo.Compare (eqType)
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Core.Type (eqType)
#else
import Type (eqType)
#endif
#if MIN_VERSION_ghc(9,6,0)
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Unit.Types (IsBootInterface(NotBoot))
#else
#endif
#if MIN_VERSION_ghc(9,4,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.Driver.Ppr (showSDocForUser)
import GHC.Core.TyCo.Ppr (pprType)
import GHC.Utils.Encoding (zEncodeString)
import GHC.Unit.State (emptyUnitState)
import GHC.Types.PkgQual (RawPkgQual(NoRawPkgQual))
#elif MIN_VERSION_ghc(9,2,0)
-- GHC 9.2.2
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.Driver.Ppr (showSDocForUser)
import GHC.Types.TyThing.Ppr (pprTypeForUser)
import GHC.Utils.Encoding (zEncodeString)
import GHC.Unit.State (emptyUnitState)
#elif MIN_VERSION_ghc(9,0,0)
-- 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.Utils.Outputable (showSDocForUser)
import GHC.Utils.Encoding (zEncodeString)
import GHC.Core.Ppr.TyThing (pprTypeForUser)
#else
-- GHC 8.10.7
import BasicTypes (SourceText(NoSourceText))
import Outputable (showSDocForUser)
import PprTyThing (pprTypeForUser)
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
-- endif for SCRIPTING FLAG

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
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

-- | Configure a GHC environment/session which we will use for all script compilation.
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
    --for the sake of convenience, for developers' builds, include the local cabal sandbox package database and the cabal new-build package database
  Either () String
eHomeDir <- forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) IO String
getHomeDirectory
  let homeDir :: String
homeDir = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const String
"/") forall a. a -> a
id Either () String
eHomeDir
  let excHandler :: GhcException -> f (Either ScriptSessionError b)
excHandler GhcException
exc = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (GhcException -> ScriptSessionError
ScriptSessionLoadError GhcException
exc)
  forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException forall {f :: * -> *} {b}.
Applicative f =>
GhcException -> f (Either ScriptSessionError b)
excHandler forall a b. (a -> b) -> a -> b
$ forall a. Maybe String -> Ghc a -> IO a
runGhc (forall a. a -> Maybe a
Just String
libdir) forall a b. (a -> b) -> a -> b
$ do
    DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
    let ghcVersion :: String
ghcVersion = DynFlags -> String
projectVersion DynFlags
dflags
    -- get nix packages dir, if available
    Maybe String
mNixLibDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"NIX_GHC_LIBDIR"

    [String]
sandboxPkgPaths <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
glob [
      --"./dist-newstyle/packagedb/ghc-" ++ ghcVersion, --rely on cabal 3's ghc.environment install: "cabal install --lib project-m36"
      String
".cabal-sandbox/*ghc-" forall a. [a] -> [a] -> [a]
++ String
ghcVersion forall a. [a] -> [a] -> [a]
++ String
"-packages.conf.d",
      String
".stack-work/install/*/*/" forall a. [a] -> [a] -> [a]
++ String
ghcVersion forall a. [a] -> [a] -> [a]
++ String
"/pkgdb",
      String
".stack-work/install/*/pkgdb/", --windows stack build
      String
"C:/sr/snapshots/b201cfe6/pkgdb", --windows stack build- ideally, we could run `stack path --snapshot-pkg-db, but this is sufficient to pass CI
      String
homeDir String -> ShowS
</> String
".stack/snapshots/*/*/" forall a. [a] -> [a] -> [a]
++ String
ghcVersion forall a. [a] -> [a] -> [a]
++ String
"/pkgdb"
      --homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"
      ]
#if MIN_VERSION_ghc(9,0,0)
    let pkgConf :: String -> PkgDbRef
pkgConf = String -> PkgDbRef
PkgDbPath
#else
    let pkgConf = PkgConfFile
#endif
    let localPkgPaths :: [PkgDbRef]
localPkgPaths = forall a b. (a -> b) -> [a] -> [b]
map String -> PkgDbRef
pkgConf ([String]
ghcPkgPaths forall a. [a] -> [a] -> [a]
++ [String]
sandboxPkgPaths forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe String
mNixLibDir)

    let dflags' :: DynFlags
dflags' = DynFlags -> DynFlags
applyGopts forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> DynFlags
applyXopts forall a b. (a -> b) -> a -> b
$ DynFlags
dflags {
#if MIN_VERSION_ghc(9,6,0)
                           backend = interpreterBackend,
#elif MIN_VERSION_ghc(9,2,0)
                           backend :: Backend
backend = Backend
Interpreter,
#else  
                           hscTarget = HscInterpreted ,
#endif
                           ghcLink :: GhcLink
ghcLink = GhcLink
LinkInMemory,
                           safeHaskell :: SafeHaskellMode
safeHaskell = SafeHaskellMode
Sf_Trustworthy,
                           safeInfer :: Bool
safeInfer = Bool
True,
                           safeInferred :: Bool
safeInferred = Bool
True,
                           --verbosity = 3,

                           trustFlags :: [TrustFlag]
trustFlags = forall a b. (a -> b) -> [a] -> [b]
map String -> TrustFlag
TrustPackage [String]
required_packages,
                           packageFlags :: [PackageFlag]
packageFlags = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags forall a. [a] -> [a] -> [a]
++ [PackageFlag]
packages,
                           packageDBFlags :: [PackageDBFlag]
packageDBFlags = forall a b. (a -> b) -> [a] -> [b]
map PkgDbRef -> PackageDBFlag
PackageDB [PkgDbRef]
localPkgPaths

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

        applyGopts :: DynFlags -> DynFlags
applyGopts DynFlags
flags = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
flags forall {a}. [a]
gopts
        applyXopts :: DynFlags -> DynFlags
applyXopts DynFlags
flags = 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 = [] --[Opt_DistrustAllPackages, Opt_PackageTrust]
        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 = forall a b. (a -> b) -> [a] -> [b]
map (\String
m -> String -> PackageArg -> ModRenaming -> PackageFlag
ExposePackage (String
"-package " forall a. [a] -> [a] -> [a]
++ String
m) (String -> PackageArg
PackageArg String
m) (Bool -> [(ModuleName, ModuleName)] -> ModRenaming
ModRenaming Bool
True [])) [String]
required_packages
  --liftIO $ traceShowM (showSDoc dflags' (ppr packages))
    ()
_ <- forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
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 {
#if MIN_VERSION_ghc(9,6,0)
#else
          ideclSourceSrc :: SourceText
ideclSourceSrc = SourceText
NoSourceText,
#endif
#if MIN_VERSION_ghc(9,6,0)
          ideclImportList = Nothing,
#endif
#if MIN_VERSION_ghc(9,10,0)
          ideclExt = XImportDeclPass
            { ideclAnn = noAnn
            , ideclSourceText = NoSourceText
            , ideclImplicit = False
            },
#elif MIN_VERSION_ghc(9,6,0)
          ideclExt = XImportDeclPass
            { ideclAnn = EpAnnNotUsed
            , ideclSourceText = NoSourceText
            , ideclImplicit = False
            },
#elif MIN_VERSION_ghc(9,2,0)
          ideclExt :: XCImportDecl (GhcPass 'Parsed)
ideclExt = forall a. EpAnn a
noAnn,
          ideclImplicit :: Bool
ideclImplicit  = Bool
False,
#else
          ideclExt = noExtField,
          ideclImplicit  = False,
#endif
#if MIN_VERSION_ghc(9,2,0)
          --GenLocated SrcSpanAnnA ModuleName
          ideclName :: XRec (GhcPass 'Parsed) ModuleName
ideclName      = forall a an. a -> LocatedAn an a
noLocA (String -> ModuleName
mkModuleName String
fullModuleName),
#else
          ideclName      = noLoc (mkModuleName fullModuleName),
#endif
#if MIN_VERSION_ghc(9,4,0)
          ideclPkgQual   = NoRawPkgQual,
#else
          ideclPkgQual :: Maybe StringLiteral
ideclPkgQual   = forall a. Maybe a
Nothing,
#endif
#if MIN_VERSION_ghc(9,0,0)
          ideclSource :: IsBootInterface
ideclSource    = IsBootInterface
NotBoot,
#else
          ideclSource    = False,
#endif
          ideclQualified :: ImportDeclQualifiedStyle
ideclQualified = if forall a. Maybe a -> Bool
isJust Maybe String
_mQualifiedName then ImportDeclQualifiedStyle
QualifiedPre else ImportDeclQualifiedStyle
NotQualified,
#if MIN_VERSION_ghc(9,6,0)
          ideclAs        = Nothing,
#elif MIN_VERSION_ghc(9,2,0)
          ideclAs :: Maybe (XRec (GhcPass 'Parsed) ModuleName)
ideclAs        = forall a. a -> Maybe a
Just (forall a an. a -> LocatedAn an a
noLocA (String -> ModuleName
mkModuleName String
fullModuleName)),
#else
          ideclAs        = noLoc . mkModuleName <$> _mQualifiedName,
#endif
#if MIN_VERSION_ghc(9,6,0)
#else
          ideclHiding :: Maybe (Bool, XRec (GhcPass 'Parsed) [LIE (GhcPass 'Parsed)])
ideclHiding    = forall a. Maybe a
Nothing,
#endif
          ideclSafe :: Bool
ideclSafe      = Bool
True
          }
        unqualifiedModules :: [InteractiveImport]
unqualifiedModules = forall a b. (a -> b) -> [a] -> [b]
map (\String
modn -> ImportDecl (GhcPass 'Parsed) -> InteractiveImport
IIDecl forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> ImportDecl (GhcPass 'Parsed)
safeImportDecl String
modn 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 = forall a b. (a -> b) -> [a] -> [b]
map (\(String
modn, String
qualNam) -> ImportDecl (GhcPass 'Parsed) -> InteractiveImport
IIDecl forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> ImportDecl (GhcPass 'Parsed)
safeImportDecl String
modn (forall a. a -> Maybe a
Just String
qualNam)) [
          (String
"Data.Text", String
"T")
          ]
    forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext ([InteractiveImport]
unqualifiedModules forall a. [a] -> [a] -> [a]
++ [InteractiveImport]
qualifiedModules)
    HscEnv
env <- forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
    Type
atomFuncType <- String -> Ghc Type
mkTypeForName String
"AtomFunctionBodyType"
    Type
dbcFuncType <- String -> Ghc Type
mkTypeForName String
"DatabaseContextFunctionBodyType"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 <- forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
getContext
  forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
setContext (ImportDecl (GhcPass 'Parsed) -> InteractiveImport
IIDecl (ModuleName -> ImportDecl (GhcPass 'Parsed)
simpleImportDecl (String -> ModuleName
mkModuleName String
moduleNam)) forall a. a -> [a] -> [a]
: [InteractiveImport]
ctx)

showType :: DynFlags -> Type -> String
#if MIN_VERSION_ghc(9,4,0)
showType dflags ty = showSDocForUser dflags emptyUnitState alwaysQualify (pprType ty)  
#elif MIN_VERSION_ghc(9,2,0)
showType :: DynFlags -> Type -> String
showType DynFlags
dflags Type
ty = DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String
showSDocForUser DynFlags
dflags UnitState
emptyUnitState PrintUnqualified
alwaysQualify (Type -> SDoc
pprTypeForUser Type
ty)
#else
showType dflags ty = showSDocForUser dflags alwaysQualify (pprTypeForUser ty)
#endif

mkTypeForName :: String -> Ghc Type
mkTypeForName :: String -> Ghc Type
mkTypeForName String
name = do
  [Name]
lBodyName <- forall (m :: * -> *). GhcMonad m => String -> m [Name]
parseName String
name
  case [Name]
lBodyName of
#if MIN_VERSION_ghc(9,6,0)
    _ :| (_:_) -> error "too many name matches"
    bodyName :| _ -> do
#else
    [] -> forall a. HasCallStack => String -> a
error (String
"failed to parse " forall a. [a] -> [a] -> [a]
++ String
name)
    Name
_:Name
_:[Name]
_ -> forall a. HasCallStack => String -> a
error String
"too many name matches"
    [Name
bodyName] -> do
#endif
      Maybe TyThing
mThing <- forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
lookupName Name
bodyName
      case Maybe TyThing
mThing of
        Maybe TyThing
Nothing -> forall a. HasCallStack => String -> a
error (String
"failed to find " forall a. [a] -> [a] -> [a]
++ String
name)
        Just (ATyCon TyCon
tyCon) -> case TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tyCon of
          Just Type
typ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
typ
          Maybe Type
Nothing -> forall a. HasCallStack => String -> a
error (String
name forall a. [a] -> [a] -> [a]
++ String
" is not a type synonym")
        Just TyThing
_ -> forall a. HasCallStack => String -> a
error (String
"failed to find type synonym " forall a. [a] -> [a] -> [a]
++ String
name)

compileScript :: Type -> Text -> Ghc (Either ScriptCompilationError a)
compileScript :: forall a. 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left ScriptCompilationError
err)
    Maybe ScriptCompilationError
Nothing ->
      --catch exception here
      --we could potentially wrap the script with Atom pattern matching so that the script doesn't have to do it, but the change to an Atom ADT should make it easier. Still, it would be nice if the script didn't have to handle a list of arguments, for example.
      -- we can't use dynCompileExpr here because
       forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b
unsafeCoerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  --catch exception for SyntaxError
  Type
funcType <- forall (m :: * -> *).
GhcMonad m =>
TcRnExprMode -> String -> m Type
GHC.exprType TcRnExprMode
TM_Inst (Text -> String
unpack Text
inp)
  --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType
  if Type -> Type -> Bool
eqType Type
funcType Type
expectedType then
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    else
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall a. [a] -> [a] -> [a]
++
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
p -> ShowS
zEncodeString String
p forall a. [a] -> [a] -> [a]
++ String
"_") Maybe String
pkg forall a. [a] -> [a] -> [a]
++
      ShowS
zEncodeString String
module' forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ ShowS
zEncodeString String
valsym forall a. [a] -> [a] -> [a]
++ String
"_closure"

data ObjectLoadMode = LoadObjectFile | -- ^ load .o files only
                      LoadDLLFile | -- ^ load .so .dynlib .dll files only
                      LoadAutoObjectFile -- ^ determine which object mode to use based on the file name's extension

-- | Load either a .o or dynamic library based on the file name's extension.


-- | Load a function from an relocatable object file (.o or .so)
--   If a modulesDir is specified, only load a path relative to the modulesDir (no ..)

type ModuleDirectory = FilePath

loadFunctionFromDirectory :: ObjectLoadMode -> ModName -> FuncName -> FilePath -> FilePath -> IO (Either LoadSymbolError a)
loadFunctionFromDirectory :: forall a.
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 forall a. Eq a => a -> a -> Bool
/= String
objPath then
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left LoadSymbolError
SecurityLoadSymbolError)
  else
    let fullObjPath :: String
fullObjPath = String
modDir String -> ShowS
</> String
objPath in
      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 :: forall a.
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 <- forall a. String -> IO (Maybe (Ptr a))
lookupSymbol (Maybe String -> String -> ShowS
mangleSymbol forall a. Maybe a
Nothing String
modName String
funcName)
        case Maybe (Ptr Any)
ptr of
          Maybe (Ptr Any)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left LoadSymbolError
LoadSymbolError)
          Just (Ptr Addr#
addr) -> case forall a. Addr# -> (# a #)
addrToAny# Addr#
addr of
            (# b
hval #) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right b
hval)
  case ObjectLoadMode
loadMode of
    ObjectLoadMode
LoadAutoObjectFile ->
      if ShowS
takeExtension String
objPath forall a. Eq a => a -> a -> Bool
== String
".o" then
          forall a.
ObjectLoadMode
-> String -> String -> String -> IO (Either LoadSymbolError a)
loadFunction ObjectLoadMode
LoadObjectFile String
modName String
funcName String
objPath
        else
          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
      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
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left LoadSymbolError
LoadSymbolError)
        Maybe String
Nothing -> 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