cabal-helper-0.8.2.0: tests/MultiGhcSession.hs

{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Distribution.Helper
import Data.Foldable
    ( toList )
import System.Process
    ( system )
import System.Environment
    ( getArgs )
import System.Exit
    ( ExitCode(ExitSuccess) )
import System.IO
    ( hPutStrLn, stderr )
import System.Console.GetOpt
    ( OptDescr(Option), ArgDescr(NoArg), ArgOrder(RequireOrder), getOpt
    , usageInfo )

import System.Directory
import Text.Printf

import Control.Concurrent
import Control.Concurrent.QSemN
import Control.Monad
import Control.Monad.IO.Class

import GHC
import GHC.Paths (libdir)
import Outputable
import DynFlags


main :: IO ()
main = do
  [dir] <- getArgs
  setCurrentDirectory dir
  _ <- systemV "sh -c pwd"
  _ <- systemV "cabal new-build --builddir=dist-newstyle"
  qe <- mkQueryEnv (ProjLocV2Dir ".") (DistDirV2 "dist-newstyle/")

  components :: [ChComponentInfo]
      <- concat <$> runQuery (allUnits (toList . uiComponents)) qe

  sem <- newQSemN 0

  _threads <- forM components $ \comp -> forkIO $ compile sem comp

  waitQSemN sem $ length components

  return ()

compile sem ci@ChComponentInfo{..} =
  defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
  runGhc (Just libdir) $ do
  handleSourceError (\e -> GHC.printException e) $ do

  dflags0 <- getSessionDynFlags
  let dflags1 = dflags0 {
      ghcMode   = CompManager
    , ghcLink   = LinkInMemory
    , hscTarget = HscNothing
    , optLevel  = 0
    }

  (dflags2, _, _) <- parseDynamicFlags dflags1 (map noLoc ciGhcOptions)
  _ <- setSessionDynFlags dflags2

  ts <- mapM (\t -> guessTarget t Nothing) =<<
       case ciEntrypoints of
         ChLibEntrypoint ms ms' ss -> return $
           map unChModuleName $ ms ++ ms' ++ ss
         ChExeEntrypoint m  ms -> do
           m1 <- liftIO $ findFile ciSourceDirs m
           case m1 of
             Just m2 -> return $ [m2] ++ map unChModuleName ms
             Nothing -> error $ printf
               "Couldn't find source file for Main module (%s), search path:\n\
               \%s\n" m (show ciSourceDirs)
         ChSetupEntrypoint         -> return $
           ["Setup.hs"]

  setTargets $ map (\t -> t { targetAllowObjCode = False }) ts
  _ <- load LoadAllTargets

  setContext $ case ciEntrypoints of
    ChLibEntrypoint ms ms' ss ->
        map (IIModule . mkModuleName . unChModuleName) $ ms ++ ms' ++ ss
    ChExeEntrypoint _  ms  ->
        map (IIModule . mkModuleName . unChModuleName) $ ChModuleName "Main" : ms
    ChSetupEntrypoint      ->
        map (IIModule . mkModuleName) ["Main"]

  _ <- execStmt "print foo" execOptions

  liftIO $ print ci
  liftIO $ signalQSemN sem 1
  liftIO $ forever $ threadDelay 100000

-- | Run shell command and
systemV :: String -> IO ()
systemV shell_cmd = do
  hPutStrLn stderr $ "$ " ++ shell_cmd
  ExitSuccess <- system shell_cmd
  return ()