module Language.Scheme.FFI (evalfuncLoadFFI) where
import Language.Scheme.Types
import Language.Scheme.Variables
import Control.Monad.Error
import qualified GHC
import qualified GHC.Paths (libdir)
import qualified DynFlags
import qualified Unsafe.Coerce (unsafeCoerce)
evalfuncLoadFFI :: [LispVal] -> IOThrowsError LispVal
evalfuncLoadFFI [(Continuation env _ _ _ _), String targetSrcFile,
String moduleName,
String externalFuncName,
String internalFuncName] = do
result <- liftIO $ defaultRunGhc $ do
dynflags <- GHC.getSessionDynFlags
_ <- GHC.setSessionDynFlags dynflags
target <- GHC.guessTarget targetSrcFile Nothing
GHC.addTarget target
r <- GHC.load GHC.LoadAllTargets
case r of
GHC.Failed -> error "Compilation failed"
GHC.Succeeded -> do
m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing
#if __GLASGOW_HASKELL__ < 700
GHC.setContext [] [m]
#elif __GLASGOW_HASKELL__ == 702
GHC.setContext []
[ (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
{GHC.ideclQualified = True}
]
#elif __GLASGOW_HASKELL__ >= 704
GHC.setContext
[ GHC.IIDecl $
(GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
{GHC.ideclQualified = True}
]
#else
GHC.setContext [] [(m, Nothing)]
#endif
fetched <- GHC.compileExpr (moduleName ++ "." ++ externalFuncName)
return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)
defineVar env internalFuncName (IOFunc result)
evalfuncLoadFFI [(Continuation env _ _ _ _), String moduleName, String externalFuncName, String internalFuncName] = do
result <- liftIO $ defaultRunGhc $ do
dynflags <- GHC.getSessionDynFlags
_ <- GHC.setSessionDynFlags dynflags
m <- GHC.findModule (GHC.mkModuleName moduleName) Nothing
#if __GLASGOW_HASKELL__ < 700
GHC.setContext [] [m]
#elif __GLASGOW_HASKELL__ == 702
GHC.setContext []
[ (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
{GHC.ideclQualified = True}
]
#elif __GLASGOW_HASKELL__ >= 704
GHC.setContext
[ GHC.IIDecl $
(GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
{GHC.ideclQualified = True}
]
#else
GHC.setContext [] [(m, Nothing)]
#endif
fetched <- GHC.compileExpr $ moduleName ++ "." ++ externalFuncName
return (Unsafe.Coerce.unsafeCoerce fetched :: [LispVal] -> IOThrowsError LispVal)
defineVar env internalFuncName (IOFunc result)
evalfuncLoadFFI _ = throwError $ NumArgs 3 []
defaultRunGhc :: GHC.Ghc a -> IO a
defaultRunGhc =
#if __GLASGOW_HASKELL__ <= 700
GHC.defaultErrorHandler DynFlags.defaultDynFlags . GHC.runGhc (Just GHC.Paths.libdir)
#else
GHC.defaultErrorHandler DynFlags.defaultLogAction . GHC.runGhc (Just GHC.Paths.libdir)
#endif