diff options
| -rw-r--r-- | lib/Distribution/Helper.hs | 84 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Compile.hs | 35 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Program/Stack.hs | 7 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 42 | ||||
| -rw-r--r-- | tests/CompileTest.hs | 1 |
5 files changed, 82 insertions, 87 deletions
diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 0190129..452bb91 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -54,6 +54,7 @@ module Distribution.Helper ( , mkQueryEnv , qeReadProcess , qePrograms + , qeCompPrograms , qeProjLoc , qeDistDir @@ -82,7 +83,6 @@ module Distribution.Helper ( -- * Managing @dist/@ , prepare - , reconfigure , writeAutogenFiles -- * Reexports @@ -177,10 +177,11 @@ mkQueryEnv projloc distdir = do return $ QueryEnv { qeReadProcess = \mcwd exe args stdin -> readCreateProcess (proc exe args){ cwd = mcwd } stdin - , qePrograms = defaultPrograms - , qeDistDir = distdir - , qeCacheRef = cr + , qePrograms = defaultPrograms + , qeCompPrograms = defaultCompPrograms , qeProjLoc = projloc + , qeDistDir = distdir + , qeCacheRef = cr } -- | Construct paths to project configuration files. @@ -244,25 +245,6 @@ unitQuery u = Query $ \qe -> getUnitInfo qe u allUnits :: (UnitInfo -> a) -> Query pt [a] allUnits f = map f <$> (mapM unitQuery =<< projectUnits) --- | Run @cabal configure@ -reconfigure :: MonadIO m - => (FilePath -> [String] -> String -> IO String) - -> Programs -- ^ Program paths - -> [String] -- ^ Command line arguments to be passed to @cabal@ - -> m () -reconfigure readProc progs cabalOpts = do - let progOpts = - [ "--with-ghc=" ++ ghcProgram progs ] - -- Only pass ghc-pkg if it was actually set otherwise we - -- might break cabal's guessing logic - ++ if ghcPkgProgram progs /= "ghc-pkg" - then [ "--with-ghc-pkg=" ++ ghcPkgProgram progs ] - else [] - ++ cabalOpts - _ <- liftIO $ readProc (cabalProgram progs) ("configure":progOpts) "" - return () - - getProjInfo :: QueryEnv pt -> IO (ProjInfo pt) getProjInfo qe@QueryEnv{..} = do cache@QueryCache{qcProjInfo, qcUnitInfos} <- readIORef qeCacheRef @@ -321,7 +303,7 @@ checkUpdateUnitInfo qe proj_info unit munit_info = do where reconf = do reconfigureUnit qe unit - helper <- wrapper proj_info qe + helper <- getHelperExe proj_info qe readUnitInfo qe helper unit -- | Restrict 'UnitInfo' cache to units that are still active @@ -386,7 +368,7 @@ getFileModTime f = do readProjInfo :: QueryEnvI c pt -> ProjConf pt -> ProjConfModTimes -> IO (ProjInfo pt) -readProjInfo qe pc pcm = join $ withVerbosity $ do +readProjInfo qe pc pcm = withVerbosity $ do case (qeProjLoc qe, qeDistDir qe, pc) of ((,,) projloc @@ -432,7 +414,12 @@ readProjInfo qe pc pcm = join $ withVerbosity $ do cabal_files <- Stack.listPackageCabalFiles qe units <- mapM (Stack.getUnit qe) cabal_files proj_paths <- Stack.projPaths qe + cprogs <- + guessCompProgramPaths $ + Stack.patchCompPrograms proj_paths $ + qeCompPrograms qe Just (cabalVer:_) <- runMaybeT $ + let ?cprogs = cprogs in let ?progs = qePrograms qe in listCabalVersions' (Just (sppGlobalPkgDb proj_paths)) -- ^ See [Note Stack Cabal Version] @@ -541,14 +528,14 @@ invokeHelper prepare :: QueryEnv pt -> IO () prepare qe = do proj_info <- getProjInfo qe - void $ wrapper proj_info qe + void $ getHelperExe proj_info qe -- | Create @cabal_macros.h@ and @Paths_\<pkg\>@ possibly other generated files -- in the usual place. See 'Distribution.Simple.Build.initialBuildSteps'. writeAutogenFiles :: Unit -> Query pt () writeAutogenFiles Unit{uCabalFile, uDistDir} = Query $ \qe -> do proj_info <- getProjInfo qe - exe <- wrapper proj_info qe + exe <- getHelperExe proj_info qe void $ invokeHelper qe exe uCabalFile uDistDir ["write-autogen-files"] -- | Get the path to the sandbox package-db in a project @@ -570,16 +557,15 @@ buildPlatform = display Distribution.System.buildPlatform lookupEnv' :: String -> IO (Maybe String) lookupEnv' k = lookup k <$> getEnvironment -guessProgramPaths :: (Verbose, Progs) => (Progs => IO a) -> IO a -guessProgramPaths act = do +-- | Determine ghc-pkg path from ghc path +guessCompProgramPaths :: Verbose => CompPrograms -> IO CompPrograms +guessCompProgramPaths progs = do let v | ?verbose = deafening | otherwise = silent - - mGhcPath0 | same ghcProgram ?progs dprogs = Nothing - | otherwise = Just $ ghcProgram ?progs - mGhcPkgPath0 | same ghcPkgProgram ?progs dprogs = Nothing - | otherwise = Just $ ghcPkgProgram ?progs - + mGhcPath0 | same ghcProgram progs dprogs = Nothing + | otherwise = Just $ ghcProgram progs + mGhcPkgPath0 | same ghcPkgProgram progs dprogs = Nothing + | otherwise = Just $ ghcPkgProgram progs (_compiler, _mplatform, progdb) <- GHC.configure v @@ -589,31 +575,31 @@ guessProgramPaths act = do let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb mghcPath1 = getProg ProgDb.ghcProgram mghcPkgPath1 = getProg ProgDb.ghcPkgProgram + return progs + { ghcProgram = fromMaybe (ghcProgram progs) mghcPath1 + , ghcPkgProgram = fromMaybe (ghcProgram progs) mghcPkgPath1 + } - let ?progs = ?progs - { ghcProgram = fromMaybe (ghcProgram ?progs) mghcPath1 - , ghcPkgProgram = fromMaybe (ghcProgram ?progs) mghcPkgPath1 - } - act - where + where same f o o' = f o == f o' - dprogs = defaultPrograms + dprogs = defaultCompPrograms -withVerbosity :: (Verbose => a) -> IO a -withVerbosity a = do +withVerbosity :: (Verbose => IO a) -> IO a +withVerbosity act = do x <- lookup "CABAL_HELPER_DEBUG" <$> getEnvironment let ?verbose = case x of Just xs | not (null xs) -> True _ -> False - return a + act -wrapper +getHelperExe :: ProjInfo pt -> QueryEnvI c pt -> IO FilePath -wrapper proj_info QueryEnv{..} = do - join $ withVerbosity $ do - let ?progs = qePrograms +getHelperExe proj_info QueryEnv{..} = do + withVerbosity $ do let comp = wrapper' qeProjLoc qeDistDir proj_info + let ?progs = qePrograms + ?cprogs = qeCompPrograms eexe <- compileHelper comp case eexe of Left rv -> diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs index 3f8a771..431043b 100644 --- a/src/CabalHelper/Compiletime/Compile.hs +++ b/src/CabalHelper/Compiletime/Compile.hs @@ -326,9 +326,10 @@ cabalMinVersionMacro (Version (mj1:mj2:mi:_) _) = cabalMinVersionMacro _ = error "cabalMinVersionMacro: Version must have at least 3 components" -invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath) +invokeGhc + :: (Verbose, CProgs) => GhcInvocation -> IO (Either ExitCode FilePath) invokeGhc GhcInvocation {..} = do - rv <- callProcessStderr' Nothing (ghcProgram ?progs) $ concat + rv <- callProcessStderr' Nothing (ghcProgram ?cprogs) $ concat [ [ "-outputdir", giOutDir , "-o", giOutput ] @@ -364,7 +365,7 @@ exeName CabalVersion {cabalVersion} = intercalate "-" , "Cabal" ++ showVersion cabalVersion ] -readProcess' :: Env => FilePath -> [String] -> String -> IO String +readProcess' :: Verbose => FilePath -> [String] -> String -> IO String readProcess' exe args inp = do vLog $ intercalate " " $ map formatProcessArg (exe:args) outp <- readProcess exe args inp @@ -372,7 +373,7 @@ readProcess' exe args inp = do return outp callProcessStderr' - :: Env => Maybe FilePath -> FilePath -> [String] -> IO ExitCode + :: Verbose => Maybe FilePath -> FilePath -> [String] -> IO ExitCode callProcessStderr' mwd exe args = do let cd = case mwd of Nothing -> []; Just wd -> [ "cd", formatProcessArg wd++";" ] @@ -381,7 +382,7 @@ callProcessStderr' mwd exe args = do , cwd = mwd } waitForProcess h -callProcessStderr :: Env => Maybe FilePath -> FilePath -> [String] -> IO () +callProcessStderr :: Verbose => Maybe FilePath -> FilePath -> [String] -> IO () callProcessStderr mwd exe args = do rv <- callProcessStderr' mwd exe args case rv of @@ -482,9 +483,9 @@ runCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do withGHCProgramOptions :: Env => [String] withGHCProgramOptions = - concat [ [ "--with-ghc=" ++ oGhcProgram ] - , if oGhcProgram /= ghcPkgProgram defaultPrograms - then [ "--with-ghc-pkg=" ++ oGhcPkgProgram ] + concat [ [ "--with-ghc=" ++ ghcProgram ?cprogs ] + , if ghcProgram ?cprogs /= ghcPkgProgram defaultCompPrograms + then [ "--with-ghc-pkg=" ++ ghcPkgProgram ?cprogs ] else [] ] @@ -533,7 +534,7 @@ compileSetupHs db srcdir = do file = srcdir </> "Setup" - callProcessStderr (Just srcdir) oGhcProgram $ concat + callProcessStderr (Just srcdir) (ghcProgram ?cprogs) $ concat [ [ "--make" , "-package-conf", db ] @@ -691,7 +692,7 @@ listCabalVersions' mdb = do args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess' oGhcPkgProgram args "" + <$> readProcess' (ghcProgram ?cprogs) args "" cabalVersionExistsInPkgDb :: Env => Version -> PackageDbDir -> IO Bool cabalVersionExistsInPkgDb cabalVer db@(PackageDbDir db_path) = do @@ -702,14 +703,14 @@ cabalVersionExistsInPkgDb cabalVer db@(PackageDbDir db_path) = do vers <- listCabalVersions' (Just db) return $ cabalVer `elem` vers) -ghcVersion :: Env => IO Version +ghcVersion :: (Verbose, CProgs) => IO Version ghcVersion = do - parseVer . trim <$> readProcess' oGhcProgram ["--numeric-version"] "" + parseVer . trim <$> readProcess' (ghcProgram ?cprogs) ["--numeric-version"] "" -ghcPkgVersion :: Env => IO Version +ghcPkgVersion :: (Verbose, CProgs) => IO Version ghcPkgVersion = parseVer . trim . dropWhile (not . isDigit) - <$> readProcess' oGhcPkgProgram ["--version"] "" + <$> readProcess' (ghcPkgProgram ?cprogs) ["--version"] "" newtype CabalInstallVersion = CabalInstallVersion { cabalInstallVer :: Version } cabalInstallVersion :: Env => IO CabalInstallVersion @@ -717,15 +718,15 @@ cabalInstallVersion = do CabalInstallVersion . parseVer . trim <$> readProcess' oCabalProgram ["--numeric-version"] "" -createPkgDb :: Env => CabalVersion -> IO PackageDbDir +createPkgDb :: (Verbose, CProgs) => CabalVersion -> IO PackageDbDir createPkgDb cabalVer = do db@(PackageDbDir db_path) <- getPrivateCabalPkgDb cabalVer exists <- doesDirectoryExist db_path when (not exists) $ - callProcessStderr Nothing oGhcPkgProgram ["init", db_path] + callProcessStderr Nothing (ghcPkgProgram ?cprogs) ["init", db_path] return db -getPrivateCabalPkgDb :: Env => CabalVersion -> IO PackageDbDir +getPrivateCabalPkgDb :: (Verbose, CProgs) => CabalVersion -> IO PackageDbDir getPrivateCabalPkgDb cabalVer = do appdir <- appCacheDir ghcVer <- ghcVersion diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs index e7f280d..322ccaf 100644 --- a/src/CabalHelper/Compiletime/Program/Stack.hs +++ b/src/CabalHelper/Compiletime/Program/Stack.hs @@ -20,7 +20,7 @@ Description : Stack program interface License : GPL-3 -} -{-# LANGUAGE GADTs, DataKinds #-} +{-# LANGUAGE NamedFieldPuns, GADTs, DataKinds #-} module CabalHelper.Compiletime.Program.Stack where @@ -64,6 +64,7 @@ projPaths qe@QueryEnv {qeProjLoc=ProjLocStackDir projdir} = do { sppGlobalPkgDb = PackageDbDir $ look "global-pkg-db:" , sppSnapPkgDb = PackageDbDir $ look "snapshot-pkg-db:" , sppLocalPkgDb = PackageDbDir $ look "local-pkg-db:" + , sppCompExe = look "compiler-exe:" } paths :: QueryEnvI c 'Stack @@ -85,3 +86,7 @@ listPackageCabalFiles qe@QueryEnv{qeProjLoc=ProjLocStackDir projdir} = do workdirArg :: QueryEnvI c 'Stack -> [String] workdirArg QueryEnv{qeDistDir=DistDirStack mworkdir} = maybeToList $ ("--work-dir="++) . unRelativePath <$> mworkdir + +patchCompPrograms :: StackProjPaths -> CompPrograms -> CompPrograms +patchCompPrograms StackProjPaths{sppCompExe} cprogs = + cprogs { ghcProgram = sppCompExe } diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index cc8561f..5ae712a 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -101,7 +101,10 @@ data QueryEnvI cache (proj_type :: ProjType) = QueryEnv -- processes. Useful if you need to, for example, redirect standard error -- output away from the user\'s terminal. - , qePrograms :: Programs + , qePrograms :: !Programs + -- ^ Field accessor for 'QueryEnv'. + + , qeCompPrograms :: !CompPrograms -- ^ Field accessor for 'QueryEnv'. , qeProjLoc :: !(ProjLoc proj_type) @@ -232,15 +235,16 @@ data StackProjPaths = StackProjPaths { sppGlobalPkgDb :: !PackageDbDir , sppSnapPkgDb :: !PackageDbDir , sppLocalPkgDb :: !PackageDbDir + , sppCompExe :: !FilePath } + +-- Beware: GHC 8.0.2 doesn't like these being recursively defined for some +-- reason so just keep them unrolled. type Verbose = (?verbose :: Bool) -type Progs = (?progs :: Programs) --- TODO: rname to `CompEnv` or something -type Env = - ( ?verbose :: Bool - , ?progs :: Programs - ) +type Env = (?cprogs :: CompPrograms, ?progs :: Programs, ?verbose :: Bool) +type Progs = (?cprogs :: CompPrograms, ?progs :: Programs) +type CProgs = (?cprogs :: CompPrograms) -- | Configurable paths to various programs we use. data Programs = Programs { @@ -248,21 +252,25 @@ data Programs = Programs { cabalProgram :: FilePath, -- | The path to the @stack@ program. - stackProgram :: FilePath, + stackProgram :: FilePath + } deriving (Eq, Ord, Show, Read, Generic, Typeable) - -- | The path to the @ghc@ program. - ghcProgram :: FilePath, +data CompPrograms = CompPrograms + { ghcProgram :: FilePath + -- ^ The path to the @ghc@ program. - -- | The path to the @ghc-pkg@ program. If - -- not changed it will be derived from the path to 'ghcProgram'. - ghcPkgProgram :: FilePath + , ghcPkgProgram :: FilePath + -- ^ The path to the @ghc-pkg@ program. If not changed it will be derived + -- from the path to 'ghcProgram'. } deriving (Eq, Ord, Show, Read, Generic, Typeable) -- | By default all programs use their unqualified names, i.e. they will be -- searched for on @PATH@. defaultPrograms :: Programs -defaultPrograms = Programs "cabal" "stack" "ghc" "ghc-pkg" +defaultPrograms = Programs "cabal" "stack" +defaultCompPrograms :: CompPrograms +defaultCompPrograms = CompPrograms "ghc" "ghc-pkg" data CompileOptions = CompileOptions { oVerbose :: Bool @@ -274,12 +282,6 @@ data CompileOptions = CompileOptions oCabalProgram :: Env => FilePath oCabalProgram = cabalProgram ?progs -oGhcProgram :: Env => FilePath -oGhcProgram = ghcProgram ?progs - -oGhcPkgProgram :: Env => FilePath -oGhcPkgProgram = ghcPkgProgram ?progs - defaultCompileOptions :: CompileOptions defaultCompileOptions = CompileOptions False Nothing Nothing defaultPrograms diff --git a/tests/CompileTest.hs b/tests/CompileTest.hs index ef43734..26ec0e3 100644 --- a/tests/CompileTest.hs +++ b/tests/CompileTest.hs @@ -45,6 +45,7 @@ setupHOME = do main :: IO () main = do let ?progs = defaultPrograms + let ?cprogs = defaultCompPrograms let ?opts = defaultCompileOptions { oVerbose = True } let ?verbose = True |