{-# 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 --hiding ((<>))
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

-- | 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 <- (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
    -- get nix packages dir, if available
    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 [
      --"./dist-newstyle/packagedb/ghc-" ++ ghcVersion, --rely on cabal 3's ghc.environment install: "cabal install --lib project-m36"
      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/", --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/*/*/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ghcVersion String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/pkgdb"
      --homeDir </> ".cabal/store/ghc-" ++ ghcVersion ++ "/package.db"
      ]

    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,
                           --verbosity = 3,
#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 = [] --[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"]
#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
  --liftIO $ traceShowM (showSDoc dflags' (ppr packages))
    [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 ->
      --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
       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
  --catch exception for SyntaxError
#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
  --liftIO $ putStrLn $ showType dflags expectedType ++ ":::" ++ showType dflags funcType
  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 | -- ^ 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 :: 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