module Scion.Configure where
import Scion.Types
import Scion.Session
import GHC hiding ( load )
import DynFlags ( dopt_set )
import GHC.Paths ( ghc, ghc_pkg )
import Exception
import Data.Typeable
import Outputable
import System.Directory
import System.FilePath
import System.IO ( openTempFile, hPutStr, hClose )
import Control.Monad
import Control.Exception ( IOException )
import Distribution.Simple.Configure
import Distribution.PackageDescription.Parse ( readPackageDescription )
import qualified Distribution.Verbosity as V ( normal, deafening )
import Distribution.Simple.Program ( defaultProgramConfiguration, userSpecifyPaths )
import Distribution.Simple.Setup ( defaultConfigFlags, ConfigFlags(..), Flag(..) )
openOrConfigureCabalProject ::
FilePath
-> FilePath
-> [String]
-> ScionM ()
openOrConfigureCabalProject root_dir dist_dir extra_args =
openCabalProject root_dir dist_dir
`gcatch` (\(_ :: CannotOpenCabalProject) ->
configureCabalProject root_dir dist_dir extra_args)
configureCabalProject ::
FilePath
-> FilePath
-> [String]
-> ScionM ()
configureCabalProject root_dir dist_dir _extra_args = do
cabal_file <- find_cabal_file
gen_pkg_descr <- liftIO $ readPackageDescription V.normal cabal_file
let prog_conf =
userSpecifyPaths [("ghc", ghc), ("ghc-pkg", ghc_pkg)]
defaultProgramConfiguration
let config_flags =
(defaultConfigFlags prog_conf)
{ configDistPref = Flag dist_dir
, configVerbosity = Flag V.deafening
, configUserInstall = Flag True
}
setWorkingDir root_dir
ghandle (\(_ :: IOError) ->
liftIO $ throwIO $
CannotOpenCabalProject "Failed to configure") $ do
lbi <- liftIO $ configure (Left gen_pkg_descr, (Nothing, [])) config_flags
liftIO $ writePersistBuildConfig dist_dir lbi
openCabalProject root_dir dist_dir
where
find_cabal_file = do
fs <- liftIO $ getDirectoryContents root_dir
case [ f | f <- fs, takeExtension f == ".cabal" ] of
[f] -> return $ root_dir </> f
[] -> liftIO $ throwIO $ CannotOpenCabalProject "no .cabal file"
_ -> liftIO $ throwIO $ CannotOpenCabalProject "Too many .cabal files"
data ConfigException = ConfigException deriving (Show, Typeable)
instance Exception ConfigException
cabalSetupWithArgs ::
FilePath
-> [String]
-> ScionM Bool
cabalSetupWithArgs cabal_file args =
ghandle (\(_ :: ConfigException) -> return False) $ do
ensureCabalFileExists
let dir = dropFileName cabal_file
(setup, delete_when_done) <- findSetup dir
liftIO $ putStrLn $ "Using setup file: " ++ setup
_mainfun <- compileMain setup
when (delete_when_done) $
liftIO (removeFile setup)
return True
where
ensureCabalFileExists = do
ok <- liftIO (doesFileExist cabal_file)
unless ok (liftIO $ throwIO ConfigException)
findSetup dir = do
let candidates = map ((dir </> "Setup.")++) ["lhs", "hs"]
existing <- mapM (liftIO . doesFileExist) candidates
case [ f | (f,ok) <- zip candidates existing, ok ] of
f:_ -> return (f, False)
[] -> liftIO $ do
ghandle (\(_ :: IOException) -> throwIO $ ConfigException) $ do
tmp_dir <- getTemporaryDirectory
(fp, hdl) <- openTempFile tmp_dir "Setup.hs"
hPutStr hdl (unlines default_cabal_setup)
hClose hdl
return (fp, True)
default_cabal_setup =
["#!/usr/bin/env runhaskell",
"import Distribution.Simple",
"main :: IO ()",
"main = defaultMain"]
compileMain file = do
resetSessionState
dflags <- getSessionDynFlags
setSessionDynFlags $
dopt_set (dflags { hscTarget = HscInterpreted
, ghcLink = LinkInMemory
})
Opt_ForceRecomp
t <- guessTarget file Nothing
liftIO $ putStrLn $ "target: " ++ (showSDoc $ ppr t)
setTargets [t]
load LoadAllTargets
m <- findModule (mkModuleName "Main") Nothing
env <- findModule (mkModuleName "System.Environment") Nothing
GHC.setContext [m] [env]
mainfun <- runStmt ("System.Environment.withArgs "
++ show args
++ "(main)")
RunToCompletion
return mainfun