{-# LANGUAGE CPP #-}

{- |
Module      : Language.Scheme.FFI
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

Maintainer  : github.com/justinethier
Stability   : experimental
Portability : non-portable (GHC API)

This module contains the foreign function interface.
-}
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)

-- |Load a Haskell function into husk using the GHC API.
evalfuncLoadFFI :: [LispVal] -> IOThrowsError LispVal

{-
 - |Load a Haskell function into husk using the foreign function inteface (FFI)
 -
 - Based on example code from:
 -
 - http://stackoverflow.com/questions/5521129/importing-a-known-function-from-an-already-compiled-binary-using-ghcs-api-or-hi
 - and
 - http://www.bluishcoder.co.nz/2008/11/dynamic-compilation-and-loading-of.html
 -
 -
 - TODO: pass a list of functions to import. Need to make sure this is done in an efficient way
 - (IE, result as a list that can be processed) 
 -}
evalfuncLoadFFI [(Continuation env _ _ _ _), String targetSrcFile,
                                                  String moduleName,
                                                  String externalFuncName,
                                                  String internalFuncName] = do
  result <- liftIO $ defaultRunGhc $ do
    dynflags <- GHC.getSessionDynFlags
    _ <- GHC.setSessionDynFlags dynflags
    -- let m = GHC.mkModule (GHC.thisPackage dynflags) (GHC.mkModuleName "Test")

--
{- TODO: migrate duplicate code into helper functions to drive everything
FUTURE: should be able to load multiple functions in one shot (?). -}
--
    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
    -- Fix from dflemstr:
    -- http://stackoverflow.com/questions/9198140/ghc-api-how-to-dynamically-load-haskell-code-from-a-compiled-module-using-ghc
           GHC.setContext [] 
             -- import qualified Module
             [ (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
               {GHC.ideclQualified = True}
             ]
#elif __GLASGOW_HASKELL__ >= 704
           GHC.setContext  
             -- import qualified Module
             [ 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) -- >>= continueEval env cont

-- Overload that loads code from a compiled module
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
    -- Fix from dflemstr:
    -- http://stackoverflow.com/questions/9198140/ghc-api-how-to-dynamically-load-haskell-code-from-a-compiled-module-using-ghc
    GHC.setContext [] 
      -- import qualified Module
      [ (GHC.simpleImportDecl . GHC.mkModuleName $ moduleName)
        {GHC.ideclQualified = True}
      ]
#elif __GLASGOW_HASKELL__ >= 704
    GHC.setContext  
      -- import qualified Module
      [ 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) -- >>= continueEval env cont

evalfuncLoadFFI _ = throwError $ NumArgs (Just 3) []

defaultRunGhc :: GHC.Ghc a -> IO a
defaultRunGhc =
#if __GLASGOW_HASKELL__ <= 700
  -- Old syntax for GHC 7.0.x and lower
  GHC.defaultErrorHandler DynFlags.defaultDynFlags . GHC.runGhc (Just GHC.Paths.libdir)
#elif __GLASGOW_HASKELL__ < 706 
  -- New syntax in GHC 7.2
  GHC.defaultErrorHandler DynFlags.defaultLogAction . GHC.runGhc (Just GHC.Paths.libdir)
#else
  -- New syntax in GHC 7.6
  GHC.defaultErrorHandler DynFlags.defaultFatalMessager DynFlags.defaultFlushOut . GHC.runGhc (Just GHC.Paths.libdir)
#endif