loadX.hs

{-# LANGUAGE GADTs #-}

import Control.Monad
import Control.Monad.IO.Class
import Data.Char
import Data.Foldable
import Data.List
import qualified DynFlags as GHC
import qualified GHC
import qualified GHCi.Message as GHC
import qualified GHCi.RemoteTypes as GHC
import qualified Hooks as GHC
import qualified HscTypes as GHC
import qualified Linker as GHC
import System.Environment.Blank
import System.Process

main :: IO ()
main = do
  ks <-
    filter (\k -> ("GHC_" `isPrefixOf` k) || "HASKELL_" `isPrefixOf` k)
      . map fst
      <$> getEnvironment
  for_ ks unsetEnv
  ghc_libdir <-
    reverse . dropWhile isSpace . reverse
      <$> readProcess
            "ghc"
            ["--print-libdir"]
            ""
  GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut
    $ GHC.runGhc (Just ghc_libdir)
    $ do
      dflags <- GHC.getSessionDynFlags
      _ <-
        GHC.setSessionDynFlags
          $ dflags
            { GHC.ghcLink = GHC.LinkInMemory,
              GHC.hooks =
                GHC.emptyHooks
                  { GHC.startIServHook = Just $ \dflags ->
                      pure GHC.IServ
                        { GHC.iservPipe = error "iservPipe",
                          GHC.iservProcess = error "iservProcess",
                          GHC.iservLookupSymbolCache =
                            error
                              "iservLookupSymbolCache",
                          GHC.iservPendingFrees = []
                          },
                    GHC.iservCallHook = Just $ \i msg -> do
                      putStrLn $ "[INFO] " <> show msg
                      case msg of
                        GHC.Shutdown -> pure ()
                        GHC.InitLinker -> pure ()
                        GHC.LoadDLL _ -> pure Nothing
                        GHC.LoadObj _ -> pure ()
                        GHC.AddLibrarySearchPath _ -> pure $ GHC.RemotePtr 0
                        GHC.RemoveLibrarySearchPath _ -> pure True
                        GHC.ResolveObjs -> pure True
                        GHC.FindSystemLibrary lib -> pure $ Just lib,
                    GHC.stopIServHook = Just $ \_ -> pure ()
                    }
              }
          `GHC.gopt_set` GHC.Opt_ExternalInterpreter
      GHC.setTargets
        [ GHC.Target
            { GHC.targetId = GHC.TargetModule $ GHC.mkModuleName "X",
              GHC.targetAllowObjCode = True,
              GHC.targetContents = Nothing
              }
          ]
      flag <- GHC.load GHC.LoadAllTargets
      unless (GHC.succeeded flag) $ fail "GHC.load returned failed"
      m <- GHC.findModule (GHC.mkModuleName "X") Nothing
      hsc_env <- GHC.getSession
      liftIO $ do
        putStrLn "[INFO] linkModule start"
        GHC.linkModule hsc_env m
        putStrLn "[INFO] linkModule done"