diff options
| -rw-r--r-- | cabal-helper.cabal | 68 | ||||
| -rw-r--r-- | lib/Distribution/Helper.hs | 365 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Compile.hs | 316 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Log.hs | 45 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Types.hs | 56 | ||||
| -rw-r--r-- | src/CabalHelper/Compiletime/Wrapper.hs | 227 | ||||
| -rw-r--r-- | src/CabalHelper/Shared/Sandbox.hs | 13 | ||||
| -rw-r--r-- | tests/CompileTest.hs | 23 |
8 files changed, 419 insertions, 694 deletions
diff --git a/cabal-helper.cabal b/cabal-helper.cabal index 1d6bbf3..b7b5f73 100644 --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -88,60 +88,24 @@ library hs-source-dirs: lib, src exposed-modules: Distribution.Helper other-modules: - CabalHelper.Shared.InterfaceTypes - CabalHelper.Shared.Sandbox - Paths_cabal_helper - autogen-modules: Paths_cabal_helper - - ghc-options: -Wall - - -- well actually this is a "runtime"-tool-depends :) - build-tool-depends: cabal-helper:cabal-helper-wrapper - - build-depends: base < 5 && >= 4.7 - build-depends: Cabal < 2.5 && >= 2.0 || < 1.26 && >= 1.14 - , cabal-plan < 0.5 && >= 0.3.0.0 - , containers < 1 && >= 0.5.5.1 - , directory < 1.4 && >= 1.2.1.0 - , filepath < 1.5 && >= 1.3.0.0 - , transformers < 0.6 && >= 0.3.0.0 - , mtl < 2.3 && >= 2.0 - , process < 1.7 && >= 1.1.0.1 - if !os(windows) - build-depends: unix < 2.8 && >= 2.5.1.1 - build-depends: unix-compat < 0.6 && >= 0.4.3.1 - , semigroupoids < 5.3 && >= 5.2 - - - -executable cabal-helper-wrapper - main-is: CabalHelper/Compiletime/Wrapper.hs - if flag(dev) - ghc-options: -Wall - scope: private - - -- Common c-h-wrapper-fields -- See [Note test dependencies] - default-language: Haskell2010 - default-extensions: NondecreasingIndentation - other-extensions: TemplateHaskell - hs-source-dirs: src - other-modules: CabalHelper.Compiletime.Compat.Environment CabalHelper.Compiletime.Compat.ProgramDb CabalHelper.Compiletime.Compat.Version CabalHelper.Compiletime.Compile CabalHelper.Compiletime.Data - CabalHelper.Compiletime.Log CabalHelper.Compiletime.Types CabalHelper.Shared.Common CabalHelper.Shared.InterfaceTypes CabalHelper.Shared.Sandbox Paths_cabal_helper - build-tool-depends: cabal-install:cabal + + autogen-modules: + Paths_cabal_helper + + ghc-options: -Wall + build-depends: base < 5 && >= 4.7 - if os(windows) - build-depends: base >= 4.7 - build-depends: Cabal < 2.5 && >= 2.0 || < 1.26 && >= 1.14 + build-depends: Cabal < 2.5 && >= 2.0 || < 1.26 && >= 1.14 , cabal-plan < 0.5 && >= 0.3.0.0 , containers < 1 && >= 0.5.5.1 , bytestring < 0.11 && >= 0.9.2.1 @@ -150,6 +114,7 @@ executable cabal-helper-wrapper , mtl < 2.3 && >= 2.0 , process < 1.7 && >= 1.1.0.1 , pretty-show < 1.9 && >= 1.8.1 + , semigroupoids < 5.3 && >= 5.2 , text < 1.3 && >= 1.0.0.0 , template-haskell < 2.14 && >= 2.7.0.0 , temporary < 1.3 && >= 1.2.1 @@ -158,7 +123,9 @@ executable cabal-helper-wrapper build-depends: unix < 2.8 && >= 2.5.1.1 build-depends: unix-compat < 0.6 && >= 0.4.3.1 , utf8-string < 1.1 && >= 1.0.1.1 + build-tools: cabal + build-tool-depends: cabal-install:cabal test-suite compile-test @@ -166,9 +133,8 @@ test-suite compile-test main-is: CompileTest.hs hs-source-dirs: tests ghc-options: -Wall - build-tools: cabal - -- Instantiate common c-h-wrapper-fields -- See [Note test dependencies] + -- Common c-h-wrapper-fields -- See [Note test dependencies] default-language: Haskell2010 default-extensions: NondecreasingIndentation other-extensions: TemplateHaskell @@ -179,13 +145,13 @@ test-suite compile-test CabalHelper.Compiletime.Compat.Version CabalHelper.Compiletime.Compile CabalHelper.Compiletime.Data - CabalHelper.Compiletime.Log CabalHelper.Compiletime.Types CabalHelper.Shared.Common CabalHelper.Shared.InterfaceTypes CabalHelper.Shared.Sandbox Paths_cabal_helper build-tool-depends: cabal-install:cabal + build-tools: cabal build-depends: base < 5 && >= 4.7 if os(windows) build-depends: base >= 4.7 @@ -206,7 +172,6 @@ test-suite compile-test build-depends: unix < 2.8 && >= 2.5.1.1 build-depends: unix-compat < 0.6 && >= 0.4.3.1 , utf8-string < 1.1 && >= 1.0.1.1 - build-tools: cabal test-suite ghc-session @@ -230,13 +195,13 @@ test-suite ghc-session CabalHelper.Compiletime.Compat.Version CabalHelper.Compiletime.Compile CabalHelper.Compiletime.Data - CabalHelper.Compiletime.Log CabalHelper.Compiletime.Types CabalHelper.Shared.Common CabalHelper.Shared.InterfaceTypes CabalHelper.Shared.Sandbox Paths_cabal_helper build-tool-depends: cabal-install:cabal + build-tools: cabal build-depends: base < 5 && >= 4.7 if os(windows) build-depends: base >= 4.7 @@ -257,7 +222,7 @@ test-suite ghc-session build-depends: unix < 2.8 && >= 2.5.1.1 build-depends: unix-compat < 0.6 && >= 0.4.3.1 , utf8-string < 1.1 && >= 1.0.1.1 - build-tools: cabal + executable cabal-helper-main @@ -269,9 +234,10 @@ executable cabal-helper-main CabalHelper.Shared.Common CabalHelper.Shared.InterfaceTypes CabalHelper.Shared.Sandbox + CabalHelper.Shared.Common - -- This component is usually built at runtime by cabal-helper-wrapper but - -- during development it's convinient to build it via cabal + -- This component is usually built at runtime but during development it's + -- convinient to build it via cabal if flag(dev) buildable: True else diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 1d93b84..622972a 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -14,10 +14,9 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds, +{-# LANGUAGE RecordWildCards, FlexibleContexts, ConstraintKinds, GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor, - NamedFieldPuns, OverloadedStrings - #-} + NamedFieldPuns, OverloadedStrings, ViewPatterns #-} {-| Module : Distribution.Helper @@ -80,7 +79,7 @@ module Distribution.Helper ( , NeedsBuildOutput(..) -- * General information - , buildPlatform + , Distribution.Helper.buildPlatform -- * Stuff that cabal-install really should export , Distribution.Helper.getSandboxPkgDb @@ -90,10 +89,6 @@ module Distribution.Helper ( , reconfigure , writeAutogenFiles - -- * $libexec related error handling - , LibexecNotFoundError(..) - , libexecNotFoundError - -- * Reexports , module Data.Functor.Apply ) where @@ -105,46 +100,40 @@ import Control.Monad.IO.Class import Control.Monad.State.Strict import Control.Monad.Reader import Control.Exception as E -import Data.Char import Data.List import Data.Maybe -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import Data.Version -import Data.Typeable +import qualified Data.Text as Text import Data.Function import Data.Functor.Apply -import Distribution.System (buildOS, OS(Windows)) import System.Environment import System.FilePath hiding ((<.>)) -import qualified System.FilePath as FP import System.Directory import System.Process -import System.IO.Unsafe import Text.Printf -import GHC.Generics +import Text.Show.Pretty import Prelude -import Paths_cabal_helper (getLibexecDir) + +import CabalHelper.Compiletime.Compile +import CabalHelper.Compiletime.Types import CabalHelper.Shared.InterfaceTypes import CabalHelper.Shared.Sandbox --- | Paths or names of various programs we need. -data Programs = Programs { - -- | The path to the @cabal@ program. - cabalProgram :: FilePath, - -- | The path to the @ghc@ program. - ghcProgram :: FilePath, +import Distribution.System (buildPlatform) +import Distribution.Text (display) +import Distribution.Verbosity (silent, deafening) +import Distribution.Package (packageName, packageVersion) +import Distribution.Simple.GHC as GHC (configure) + +import qualified CabalHelper.Compiletime.Compat.ProgramDb as ProgDb + ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram) +import CabalHelper.Compiletime.Compat.Version +import CabalHelper.Shared.Common - -- | The path to the @ghc-pkg@ program. If - -- not changed it will be derived from the path to 'ghcProgram'. - ghcPkgProgram :: FilePath - } deriving (Eq, Ord, Show, Read, Generic, Typeable) --- | Default all programs to their unqualified names, i.e. they will be searched --- for on @PATH@. -defaultPrograms :: Programs -defaultPrograms = Programs "cabal" "ghc" "ghc-pkg" -- | Environment for running a 'Query'. The real constructor is not exposed, -- the field accessors are however. See below. Use the 'mkQueryEnv' smart @@ -353,35 +342,41 @@ reconfigure readProc progs cabalOpts = do readHelper :: (MonadIO m, MonadQuery m) => [String] -> m [Maybe ChResponse] readHelper args = ask >>= \qe -> liftIO $ do - out <- either error id <$> invokeHelper qe args + out <- invokeHelper qe args let res = read out liftIO $ evaluate res `E.catch` \se@(SomeException _) -> do md <- lookupEnv' "CABAL_HELPER_DEBUG" let msg = "readHelper: exception: '" ++ show se ++ "'" - error $ msg ++ case md of + panicIO $ msg ++ case md of Nothing -> ", for more information set the environment variable CABAL_HELPER_DEBUG" Just _ -> ", output: '"++ out ++"'" -invokeHelper :: QueryEnv -> [String] -> IO (Either String String) -invokeHelper QueryEnv {..} args = do - let progArgs = [ "--with-ghc=" ++ ghcProgram qePrograms - , "--with-ghc-pkg=" ++ ghcPkgProgram qePrograms - , "--with-cabal=" ++ cabalProgram qePrograms - ] - exe <- findLibexecExe - let args' = progArgs ++ "v1-style":qeProjectDir:qeDistDir:args - out <- qeReadProcess exe args' "" - (Right <$> evaluate out) `E.catch` \(SomeException _) -> - return $ Left $ concat - ["invokeHelper", ": ", exe, " " - , intercalate " " (map show args') - , " failed" - ] - -getPackageId :: MonadQuery m => m (String, Version) -getPackageId = ask >>= \QueryEnv {..} -> do - [ Just (ChResponseVersion pkgName pkgVer) ] <- readHelper [ "package-id" ] - return (pkgName, pkgVer) +invokeHelper :: QueryEnv -> [String] -> IO String +invokeHelper QueryEnv {..} args0 = do + let opts = defaultCompileOptions + { oPrograms = qePrograms + , oCabalPkgDb = PackageDbDir <$> qeCabalPkgDb } + + opts' <- overrideVerbosityEnvVar =<< guessProgramPaths opts + + exe <- wrapperV1 opts' qeProjectDir qeDistDir + + let args1 = qeProjectDir : qeDistDir : args0 + + out <- qeReadProcess exe args1 "" + evaluate out `E.catch` \(SomeException _) -> + panicIO $ concat + ["invokeHelper", ": ", exe, " " + , intercalate " " (map show args1) + , " failed!" + ] + +getPackageId :: (MonadQuery m, MonadIO m) => m (String, Version) +getPackageId = ask >>= \QueryEnv {..} -> liftIO $ do + let v = silent + [cfile] <- filter isCabalFile <$> getDirectoryContents qeProjectDir + gpd <- readPackageDescription v (qeProjectDir </> cfile) + return $ (display (packageName gpd), toDataVersion (packageVersion gpd)) getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo getSomeConfigState = ask >>= \QueryEnv {..} -> do @@ -439,151 +434,129 @@ writeAutogenFiles qe = liftIO $ void $ invokeHelper qe ["write-autogen-files"] -- | Get the path to the sandbox package-db in a project -getSandboxPkgDb :: (FilePath -> [String] -> String -> IO String) - -> String - -- ^ Cabal build platform, i.e. @buildPlatform@ - -> Version - -- ^ GHC version (@cProjectVersion@ is your friend) - -> IO (Maybe FilePath) -getSandboxPkgDb readProc = - CabalHelper.Shared.Sandbox.getSandboxPkgDb $ unsafePerformIO $ buildPlatform readProc - -buildPlatform :: (FilePath -> [String] -> String -> IO String) -> IO String -buildPlatform readProc = do - exe <- findLibexecExe - CabalHelper.Shared.Sandbox.dropWhileEnd isSpace <$> readProc exe ["print-build-platform"] "" - --- | This exception is thrown by all 'runQuery' functions if the internal --- wrapper executable cannot be found. You may catch this and present the user --- an appropriate error message however the default is to print --- 'libexecNotFoundError'. -data LibexecNotFoundError = LibexecNotFoundError String FilePath - deriving (Typeable) -instance Exception LibexecNotFoundError -instance Show LibexecNotFoundError where - show (LibexecNotFoundError exe dir) = - libexecNotFoundError exe dir "https://github.com/DanielG/cabal-helper/issues" - -findLibexecExe :: IO FilePath -findLibexecExe = do - libexecdir <- getLibexecDir - let exeName = "cabal-helper-wrapper" - exe = libexecdir </> exeName FP.<.> exeExtension' - - exists <- doesFileExist exe - - if exists - then return exe - else do - mdir <- tryFindCabalHelperTreeDistDir - dir <- case mdir of - Nothing -> - throwIO $ LibexecNotFoundError exeName libexecdir - Just dir -> - return dir - - return $ dir </> "build" </> exeName </> exeName - -findPlanJson :: FilePath -> IO (Maybe FilePath) -findPlanJson base = - findFile (map (</> "cache") $ parents base) "plan.json" - -parents :: FilePath -> [FilePath] -parents path = takeWhile (not . (`elem` ["", "."]) . dropDrive) dirs - where dirs = iterate takeDirectory path - -data DistDir = DistDir { ddType :: DistDirType, unDistDir :: FilePath } - deriving (Eq, Ord, Read, Show) -data DistDirType = NewBuildDist | OldBuildDist - deriving (Eq, Ord, Read, Show) - -tryFindCabalHelperTreeDistDir :: IO (Maybe FilePath) -tryFindCabalHelperTreeDistDir = do - exe <- canonicalizePath =<< getExecutablePath' - mplan <- findPlanJson exe - let mdistdir = takeDirectory . takeDirectory <$> mplan - cwd <- getCurrentDirectory - - let candidates = sortBy (compare `on` ddType) $ concat - [ maybeToList $ DistDir NewBuildDist <$> mdistdir - , [ DistDir OldBuildDist $ (!!3) $ iterate takeDirectory exe ] - , if takeFileName exe == "ghc" -- we're probably in ghci; try CWD - then [ DistDir NewBuildDist $ cwd </> "dist-newstyle" - , DistDir NewBuildDist $ cwd </> "dist" - , DistDir OldBuildDist $ cwd </> "dist" - ] - else [] - ] - - distdirs - <- filterM isDistDir candidates - >>= mapM toOldBuildDistDir - - return $ fmap unDistDir $ join $ listToMaybe $ distdirs - -isCabalHelperSourceDir :: FilePath -> IO Bool -isCabalHelperSourceDir dir = - doesFileExist $ dir </> "cabal-helper.cabal" - -isDistDir :: DistDir -> IO Bool -isDistDir (DistDir NewBuildDist dir) = - doesFileExist (dir </> "cache" </> "plan.json") -isDistDir (DistDir OldBuildDist dir) = - doesFileExist (dir </> "setup-config") - -toOldBuildDistDir :: DistDir -> IO (Maybe DistDir) -toOldBuildDistDir (DistDir NewBuildDist dir) = do - PlanJson {pjUnits} <- decodePlanJson $ dir </> "cache" </> "plan.json" - let munit = find isCabalHelperUnit $ Map.elems pjUnits - return $ DistDir OldBuildDist <$> join ((\Unit { uDistDir = mdistdir } -> mdistdir) <$> munit) - where - isCabalHelperUnit - Unit { uPId = PkgId (PkgName n) _ - , uType = UnitTypeLocal - , uComps - } | n == "cabal-helper" && - Map.member (CompNameExe "cabal-helper-wrapper") uComps - = True - isCabalHelperUnit _ = False -toOldBuildDistDir x = return $ Just x - - - - -libexecNotFoundError :: String -- ^ Name of the executable we were trying to - -- find - -> FilePath -- ^ Path to @$libexecdir@ - -> String -- ^ URL the user will be directed towards to - -- report a bug. - -> String -libexecNotFoundError exe dir reportBug = printf - ( "Could not find $libexecdir/%s\n" - ++"\n" - ++"If you are a cabal-helper developer you can set the environment variable\n" - ++"`cabal_helper_libexecdir' to override $libexecdir[1]. The following will\n" - ++"work in the cabal-helper source tree:\n" - ++"\n" - ++" $ export cabal_helper_libexecdir=$PWD/dist/build/%s\n" - ++"\n" - ++"[1]: %s\n" - ++"\n" - ++"If you don't know what I'm talking about something went wrong with your\n" - ++"installation. Please report this problem here:\n" - ++"\n" - ++" %s") exe exe dir reportBug - -getExecutablePath' :: IO FilePath -getExecutablePath' = -#if MIN_VERSION_base(4,6,0) - getExecutablePath -#else - getProgName -#endif +getSandboxPkgDb + :: String + -- ^ Cabal build platform, i.e. @buildPlatform@ + -> Version + -- ^ GHC version (@cProjectVersion@ is your friend) + -> FilePath + -- ^ Path to the project directory, i.e. a directory containing a + -- @cabal.sandbox.config@ file + -> IO (Maybe FilePath) +getSandboxPkgDb buildPlat ghc_ver projdir = + CabalHelper.Shared.Sandbox.getSandboxPkgDb buildPlat ghc_ver projdir + +buildPlatform :: String +buildPlatform = display Distribution.System.buildPlatform lookupEnv' :: String -> IO (Maybe String) lookupEnv' k = lookup k <$> getEnvironment -exeExtension' :: FilePath -exeExtension' - | Windows <- buildOS = "exe" - | otherwise = "" + +guessProgramPaths :: CompileOptions -> IO CompileOptions +guessProgramPaths opts = do + let v | oVerbose opts = deafening + | otherwise = silent + + 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 + mGhcPath0 + mGhcPkgPath0 + ProgDb.defaultProgramDb + let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb + mghcPath1 = getProg ProgDb.ghcProgram + mghcPkgPath1 = getProg ProgDb.ghcPkgProgram + + progs' = progs + { ghcProgram = fromMaybe (ghcProgram progs) mghcPath1 + , ghcPkgProgram = fromMaybe (ghcProgram progs) mghcPkgPath1 + } + return opts { oPrograms = progs' } + where + same f o o' = f o == f o' + progs = oPrograms opts + dprogs = defaultPrograms + +overrideVerbosityEnvVar :: CompileOptions -> IO CompileOptions +overrideVerbosityEnvVar opts = do + x <- lookup "CABAL_HELPER_DEBUG" <$> getEnvironment + return $ case x of + Just _ -> opts { oVerbose = True } + Nothing -> opts + +wrapperV1 + :: CompileOptions + -> FilePath + -> FilePath + -> IO FilePath +wrapperV1 opts projdir distdir = do + cfgf <- canonicalizePath (distdir </> "setup-config") + mhdr <- getCabalConfigHeader cfgf + case (mhdr, oCabalVersion opts) of + (Nothing, _) -> panicIO $ printf "\ +\Could not read Cabal's persistent setup configuration header\n\ +\- Check first line of: %s\n\ +\- Maybe try: $ cabal configure" cfgf + (Just (hdrCabalVersion, _), Just ver) + | hdrCabalVersion /= ver -> panicIO $ printf "\ +\Cabal version %s was requested but setup configuration was\n\ +\written by version %s" (showVersion ver) (showVersion hdrCabalVersion) + (Just (hdrCabalVersion, _), _) -> do + compileHelper' opts hdrCabalVersion projdir Nothing distdir + +wrapperV2 + :: CompileOptions + -> FilePath + -> FilePath + -> UnitId + -> IO (FilePath, FilePath) +wrapperV2 opts projdir distdir unitid@(UnitId (Text.unpack -> unitid')) = do + let plan_path = distdir </> "cache" </> "plan.json" + plan@PlanJson {pjCabalLibVersion=Ver (makeDataVersion -> pjCabalLibVersion) } + <- decodePlanJson plan_path + case oCabalVersion opts of + Just ver | pjCabalLibVersion /= ver -> let + sver = showVersion ver + spjVer = showVersion pjCabalLibVersion + in panicIO $ printf "\ +\Cabal version %s was requested but plan.json was written by version %s" sver spjVer + _ -> case Map.lookup unitid $ pjUnits plan of + Just u@Unit {uType} | uType /= UnitTypeLocal -> do + panicIO $ "\ +\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u + Just Unit {uDistDir=Nothing} -> panicIO $ printf "\ +\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'" + Just Unit {uType=UnitTypeLocal, uDistDir=Just distdirv1} -> do + exe <- compileHelper' opts pjCabalLibVersion projdir (Just (plan, distdir)) distdirv1 + return (exe, distdirv1) + _ -> let + units = map (\(UnitId u) -> Text.unpack u) + $ Map.keys + $ Map.filter ((==UnitTypeLocal) . uType) + $ pjUnits plan + units_list = unlines $ map (" "++) units + in + panicIO $ "\ +\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list + + +compileHelper' + :: CompileOptions + -> Version + -> FilePath + -> Maybe (PlanJson, FilePath) + -> FilePath + -> IO FilePath +compileHelper' opts pjCabalLibVersion projdir mnewstyle distdirv1 = do + eexe <- compileHelper opts pjCabalLibVersion projdir mnewstyle distdirv1 + case eexe of + Left rv -> + panicIO $ "compileHelper': compiling helper failed! (exit code "++ show rv + Right exe -> + return exe diff --git a/src/CabalHelper/Compiletime/Compile.hs b/src/CabalHelper/Compiletime/Compile.hs index 8da426f..2b80b2f 100644 --- a/src/CabalHelper/Compiletime/Compile.hs +++ b/src/CabalHelper/Compiletime/Compile.hs @@ -14,7 +14,7 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. {-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns, DeriveFunctor, -GADTs #-} + GADTs, ImplicitParams, ConstraintKinds #-} {-| Module : CabalHelper.Compiletime.Compile @@ -58,7 +58,6 @@ import Distribution.Text (display) import Paths_cabal_helper (version) import CabalHelper.Compiletime.Data -import CabalHelper.Compiletime.Log import CabalHelper.Compiletime.Types import CabalHelper.Shared.Common import CabalHelper.Shared.Sandbox (getSandboxPkgDb) @@ -87,33 +86,41 @@ data CompPaths = CompPaths -- executable. data CompilationProductScope = CPSGlobal | CPSProject -compileHelper :: Options -> Version -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> IO (Either ExitCode FilePath) +compileHelper + :: CompileOptions + -> Version + -> FilePath + -> Maybe (PlanJson, FilePath) + -> FilePath + -> IO (Either ExitCode FilePath) compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do - ghcVer <- ghcVersion opts - Just (prepare, comp) <- runMaybeT $ msum $ - case oCabalPkgDb opts of - Nothing -> - [ compileCabalSource - , compileNewBuild ghcVer - , compileSandbox ghcVer - , compileGlobal - , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb - ] - Just db -> - [ return $ (return (), compileWithPkg (Just db) hdrCabalVersion CPSProject) - ] - - appdir <- appCacheDir - - let cp@CompPaths {compExePath} = compPaths appdir distdir comp - exists <- doesFileExist compExePath - if exists - then do - vLog opts $ "helper already compiled, using exe: "++compExePath - return (Right compExePath) - else do - vLog opts $ "helper exe does not exist, compiling "++compExePath - prepare >> compile comp cp opts + let ?opts = opts + + ghcVer <- ghcVersion + Just (prepare, comp) <- runMaybeT $ msum $ + case oCabalPkgDb opts of + Nothing -> + [ compileCabalSource + , compileNewBuild ghcVer + , compileSandbox ghcVer + , compileGlobal + , MaybeT $ Just <$> compileWithCabalInPrivatePkgDb + ] + Just db -> + [ return $ (return (), compileWithPkg (Just db) hdrCabalVersion CPSProject) + ] + + appdir <- appCacheDir + + let cp@CompPaths {compExePath} = compPaths appdir distdir comp + exists <- doesFileExist compExePath + if exists + then do + vLog $ "helper already compiled, using exe: "++compExePath + return (Right compExePath) + else do + vLog $ "helper exe does not exist, compiling "++compExePath + prepare >> compile comp cp where logMsg = "using helper compiled with Cabal from " @@ -121,24 +128,24 @@ compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do -- for relaxed deps: find (sameMajorVersionAs hdrCabalVersion) . reverse . sort -- | Check if this version is globally available - compileGlobal :: MaybeT IO (IO (), Compile) + compileGlobal :: Env => MaybeT IO (IO (), Compile) compileGlobal = do - cabal_versions <- listCabalVersions opts + cabal_versions <- listCabalVersions ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions - vLog opts $ logMsg ++ "user/global package-db" + vLog $ logMsg ++ "user/global package-db" return $ (return (), compileWithPkg Nothing ver CPSGlobal) -- | Check if this version is available in the project sandbox - compileSandbox :: Version -> MaybeT IO (IO (), Compile) + compileSandbox :: Env => Version -> MaybeT IO (IO (), Compile) compileSandbox ghcVer = do - let mdb_path = getSandboxPkgDb projdir (display buildPlatform) ghcVer + let mdb_path = getSandboxPkgDb (display buildPlatform) ghcVer projdir sandbox <- PackageDbDir <$> MaybeT mdb_path - cabal_versions <- listCabalVersions' opts (Just sandbox) + cabal_versions <- listCabalVersions' (Just sandbox) ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions - vLog opts $ logMsg ++ "sandbox package-db" + vLog $ logMsg ++ "sandbox package-db" return $ (return (), compileWithPkg (Just sandbox) ver CPSProject) - compileNewBuild :: Version -> MaybeT IO (IO (), Compile) + compileNewBuild :: Env => Version -> MaybeT IO (IO (), Compile) compileNewBuild ghcVer = do (PlanJson {pjUnits}, distdir_newstyle) <- maybe mzero pure mnewstyle let cabal_pkgid = @@ -150,28 +157,28 @@ compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do let inplace_db_path = distdir_newstyle </> "packagedb" </> ("ghc-" ++ showVersion ghcVer) inplace_db = PackageDbDir inplace_db_path - cabal_versions <- listCabalVersions' opts (Just inplace_db) + cabal_versions <- listCabalVersions' (Just inplace_db) ver <- MaybeT $ return $ find (== hdrCabalVersion) cabal_versions - vLog opts $ logMsg ++ "v2-build package-db " ++ inplace_db_path + vLog $ logMsg ++ "v2-build package-db " ++ inplace_db_path return $ (return (), compileWithPkg (Just inplace_db) ver CPSProject) -- | Compile the requested Cabal version into an isolated package-db if it's -- not there already - compileWithCabalInPrivatePkgDb :: IO (IO (), Compile) + compileWithCabalInPrivatePkgDb :: Env => IO (IO (), Compile) compileWithCabalInPrivatePkgDb = do db@(PackageDbDir db_path) - <- getPrivateCabalPkgDb opts (CabalVersion hdrCabalVersion) - vLog opts $ logMsg ++ "private package-db in " ++ db_path + <- getPrivateCabalPkgDb (CabalVersion hdrCabalVersion) + vLog $ logMsg ++ "private package-db in " ++ db_path return (prepare db, compileWithPkg (Just db) hdrCabalVersion CPSGlobal) where prepare db = do - db_exists <- liftIO $ cabalVersionExistsInPkgDb opts hdrCabalVersion db + db_exists <- liftIO $ cabalVersionExistsInPkgDb hdrCabalVersion db when (not db_exists) $ - void $ installCabal opts (Right hdrCabalVersion) `E.catch` + void $ installCabal (Right hdrCabalVersion) `E.catch` \(SomeException _) -> errorInstallCabal hdrCabalVersion distdir -- | See if we're in a cabal source tree - compileCabalSource :: MaybeT IO (IO (), Compile) + compileCabalSource :: Env => MaybeT IO (IO (), Compile) compileCabalSource = do let cabalFile = projdir </> "Cabal.cabal" cabalSrc <- liftIO $ doesFileExist cabalFile @@ -179,17 +186,17 @@ compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do case cabalSrc of False -> mzero True -> do - vLog opts $ "projdir looks like Cabal source tree (Cabal.cabal exists)" + vLog $ "projdir looks like Cabal source tree (Cabal.cabal exists)" cf <- liftIO $ readFile cabalFile let buildType = cabalFileBuildType cf ver = cabalFileVersion cf case buildType of "simple" -> do - vLog opts $ "Cabal source tree is build-type:simple, moving on" + vLog $ "Cabal source tree is build-type:simple, moving on" mzero "custom" -> do - vLog opts $ "compiling helper with local Cabal source tree" + vLog $ "compiling helper with local Cabal source tree" return $ (return (), compileWithCabalSource projdir' ver) _ -> error $ "compileCabalSource: unknown build-type: '"++buildType++"'" @@ -209,16 +216,16 @@ compileHelper opts hdrCabalVersion projdir mnewstyle distdir = do cabalPkgId v = "Cabal-" ++ showVersion v -compile :: Compile -> CompPaths -> Options -> IO (Either ExitCode FilePath) -compile comp paths@CompPaths {..} opts@Options {..} = do +compile :: Env => Compile -> CompPaths -> IO (Either ExitCode FilePath) +compile comp paths@CompPaths {..} = do createDirectoryIfMissing True compOutDir createHelperSources compSrcDir - vLog opts $ "compSrcDir: " ++ compSrcDir - vLog opts $ "compOutDir: " ++ compOutDir - vLog opts $ "compExePath: " ++ compExePath + vLog $ "compSrcDir: " ++ compSrcDir + vLog $ "compOutDir: " ++ compOutDir + vLog $ "compExePath: " ++ compExePath - invokeGhc opts $ compGhcInvocation comp paths + invokeGhc $ compGhcInvocation comp paths compPaths :: FilePath -> FilePath -> Compile -> CompPaths compPaths appdir distdir c = @@ -309,25 +316,27 @@ cabalMinVersionMacro (Version (mj1:mj2:mi:_) _) = cabalMinVersionMacro _ = error "cabalMinVersionMacro: Version must have at least 3 components" -invokeGhc :: Options -> GhcInvocation -> IO (Either ExitCode FilePath) -invokeGhc opts@Options {..} GhcInvocation {..} = do - rv <- callProcessStderr' opts Nothing oGhcProgram $ concat - [ [ "-outputdir", giOutDir - , "-o", giOutput +invokeGhc :: Env => GhcInvocation -> IO (Either ExitCode FilePath) +invokeGhc GhcInvocation {..} = do + rv <- callProcessStderr' Nothing oGhcProgram $ concat + [ [ "-outputdir", giOutDir + , "-o", giOutput + ] + , map ("-optP"++) giCPPOptions + , map ("-package-conf="++) $ unPackageDbDir <$> giPackageDBs + , map ("-i"++) $ nub $ "" : giIncludeDirs + , if giHideAllPackages then ["-hide-all-packages"] else [] + , concatMap (\p -> ["-package", p]) giPackages + , giWarningFlags + , ["--make"] + , giInputs ] - , map ("-optP"++) giCPPOptions - , map ("-package-conf="++) $ unPackageDbDir <$> giPackageDBs - , map ("-i"++) $ nub $ "" : giIncludeDirs - , if giHideAllPackages then ["-hide-all-packages"] else [] - , concatMap (\p -> ["-package", p]) giPackages - , giWarningFlags - , ["--make"] - , giInputs - ] - return $ - case rv of - ExitSuccess -> Right giOutput - e@(ExitFailure _) -> Left e + return $ + case rv of + ExitSuccess -> Right giOutput + e@(ExitFailure _) -> Left e + where + CompileOptions {..} = ?opts -- | Cabal library version we're compiling the helper exe against. @@ -347,26 +356,26 @@ exeName CabalVersion {cabalVersion} = intercalate "-" , "Cabal" ++ showVersion cabalVersion ] -readProcess' :: Options -> FilePath -> [String] -> String -> IO String -readProcess' opts@Options{..} exe args inp = do - vLog opts $ intercalate " " $ map formatProcessArg (oGhcPkgProgram:args) +readProcess' :: Env => FilePath -> [String] -> String -> IO String +readProcess' exe args inp = do + vLog $ intercalate " " $ map formatProcessArg (exe:args) outp <- readProcess exe args inp - vLog opts $ unlines $ map ("=> "++) $ lines outp + vLog $ unlines $ map ("=> "++) $ lines outp return outp callProcessStderr' - :: Options -> Maybe FilePath -> FilePath -> [String] -> IO ExitCode -callProcessStderr' opts mwd exe args = do + :: Env => Maybe FilePath -> FilePath -> [String] -> IO ExitCode +callProcessStderr' mwd exe args = do let cd = case mwd of Nothing -> []; Just wd -> [ "cd", formatProcessArg wd++";" ] - vLog opts $ intercalate " " $ cd ++ map formatProcessArg (exe:args) + vLog $ intercalate " " $ cd ++ map formatProcessArg (exe:args) (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr , cwd = mwd } waitForProcess h -callProcessStderr :: Options -> Maybe FilePath -> FilePath -> [String] -> IO () -callProcessStderr opts mwd exe args = do - rv <- callProcessStderr' opts mwd exe args +callProcessStderr :: Env => Maybe FilePath -> FilePath -> [String] -> IO () +callProcessStderr mwd exe args = do + rv <- callProcessStderr' mwd exe args case rv of ExitSuccess -> return () ExitFailure v -> processFailedException "callProcessStderr" exe args v @@ -387,8 +396,8 @@ formatProcessArg xs data HEAD = HEAD deriving (Eq, Show) -installCabal :: Options -> Either HEAD Version -> IO (PackageDbDir, CabalVersion) -installCabal opts ever = do +installCabal :: Env => Either HEAD Version -> IO (PackageDbDir, CabalVersion) +installCabal ever = do appdir <- appCacheDir let message ver = do let sver = showVersion ver @@ -409,16 +418,16 @@ installCabal opts ever = do withSystemTempDirectory "cabal-helper-Cabal-source" $ \tmpdir -> do (srcdir, cabalVer) <- case ever of Left HEAD -> do - second CabalHEAD <$> unpackCabalHEAD opts tmpdir + second CabalHEAD <$> unpackCabalHEAD tmpdir Right ver -> do message ver let patch = fromMaybe nopCabalPatchDescription $ find ((ver`elem`) . cpdVersions) patchyCabalVersions - (,) <$> unpackPatchedCabal opts ver tmpdir patch <*> pure (CabalVersion ver) + (,) <$> unpackPatchedCabal ver tmpdir patch <*> pure (CabalVersion ver) - db <- createPkgDb opts cabalVer + db <- createPkgDb cabalVer - runCabalInstall opts db srcdir ever + runCabalInstall db srcdir ever return (db, cabalVer) @@ -436,9 +445,9 @@ Otherwise we might be able to use the shipped Setup.hs -} runCabalInstall - :: Options -> PackageDbDir -> CabalSourceDir -> Either HEAD Version-> IO () -runCabalInstall opts (PackageDbDir db) (CabalSourceDir srcdir) ever = do - civ@CabalInstallVersion {..} <- cabalInstallVersion opts + :: Env => PackageDbDir -> CabalSourceDir -> Either HEAD Version-> IO () +runCabalInstall (PackageDbDir db) (CabalSourceDir srcdir) ever = do + civ@CabalInstallVersion {..} <- cabalInstallVersion cabal_opts <- return $ concat [ [ "--package-db=clear" @@ -446,45 +455,45 @@ runCabalInstall opts (PackageDbDir db) (CabalSourceDir srcdir) ever = do , "--package-db=" ++ db , "--prefix=" ++ db </> "prefix" ] - , withGHCProgramOptions opts + , withGHCProgramOptions , if cabalInstallVer >= Version [1,20,0,0] [] then ["--no-require-sandbox"] else [] , [ "install", srcdir ] - , if oVerbose opts + , if oVerbose ?opts then ["-v"] else [] , [ "--only-dependencies" ] ] - callProcessStderr opts (Just "/") (oCabalProgram opts) cabal_opts + callProcessStderr (Just "/") oCabalProgram cabal_opts - runSetupHs opts db srcdir ever civ + runSetupHs db srcdir ever civ hPutStrLn stderr "done" -withGHCProgramOptions :: Options -> [String] -withGHCProgramOptions opts = - concat [ [ "--with-ghc=" ++ oGhcProgram opts ] - , if oGhcPkgProgram opts /= oGhcPkgProgram defaultOptions - then [ "--with-ghc-pkg=" ++ oGhcPkgProgram opts ] +withGHCProgramOptions :: Env => [String] +withGHCProgramOptions = + concat [ [ "--with-ghc=" ++ oGhcProgram ] + , if oGhcProgram /= ghcPkgProgram defaultPrograms + then [ "--with-ghc-pkg=" ++ oGhcPkgProgram ] else [] ] runSetupHs - :: Options - -> FilePath + :: Env + => FilePath -> FilePath -> Either HEAD Version -> CabalInstallVersion -> IO () -runSetupHs opts@Options {..} db srcdir ever CabalInstallVersion {..} +runSetupHs db srcdir ever CabalInstallVersion {..} | cabalInstallVer >= parseVer "1.24" = do - go $ \args -> callProcessStderr opts (Just srcdir) oCabalProgram $ + go $ \args -> callProcessStderr (Just srcdir) oCabalProgram $ [ "act-as-setup", "--" ] ++ args | otherwise = do - SetupProgram {..} <- compileSetupHs opts db srcdir - go $ callProcessStderr opts (Just srcdir) setupProgram + SetupProgram {..} <- compileSetupHs db srcdir + go $ callProcessStderr (Just srcdir) setupProgram where parmake_opt :: Maybe Int -> [String] parmake_opt nproc' @@ -497,7 +506,7 @@ runSetupHs opts@Options {..} db srcdir ever CabalInstallVersion {..} go :: ([String] -> IO ()) -> IO () go run = do run $ [ "configure", "--package-db", db, "--prefix", db </> "prefix" ] - ++ withGHCProgramOptions opts + ++ withGHCProgramOptions mnproc <- join . fmap readMaybe <$> lookupEnv "NPROC" run $ [ "build" ] ++ parmake_opt mnproc run [ "copy" ] @@ -507,16 +516,16 @@ runSetupHs opts@Options {..} db srcdir ever CabalInstallVersion {..} newtype SetupProgram = SetupProgram { setupProgram :: FilePath } -compileSetupHs :: Options -> FilePath -> FilePath -> IO SetupProgram -compileSetupHs opts db srcdir = do - ver <- ghcVersion opts +compileSetupHs :: Env => FilePath -> FilePath -> IO SetupProgram +compileSetupHs db srcdir = do + ver <- ghcVersion let no_version_macros | ver >= Version [8] [] = [ "-fno-version-macros" ] | otherwise = [] file = srcdir </> "Setup" - callProcessStderr opts (Just srcdir) (oGhcProgram opts) $ concat + callProcessStderr (Just srcdir) oGhcProgram $ concat [ [ "--make" , "-package-conf", db ] @@ -588,35 +597,35 @@ patchyCabalVersions = [ renameFile versionFileTmp versionFile unpackPatchedCabal - :: Options - -> Version + :: Env + => Version -> FilePath -> CabalPatchDescription -> IO CabalSourceDir -unpackPatchedCabal opts cabalVer tmpdir (CabalPatchDescription _ variant patch) = do - res@(CabalSourceDir dir) <- unpackCabal opts cabalVer tmpdir variant +unpackPatchedCabal cabalVer tmpdir (CabalPatchDescription _ variant patch) = do + res@(CabalSourceDir dir) <- unpackCabal cabalVer tmpdir variant patch dir return res data UnpackCabalVariant = Pristine | LatestRevision newtype CabalSourceDir = CabalSourceDir { unCabalSourceDir :: FilePath } unpackCabal - :: Options -> Version -> FilePath -> UnpackCabalVariant -> IO CabalSourceDir -unpackCabal opts cabalVer tmpdir variant = do + :: Env => Version -> FilePath -> UnpackCabalVariant -> IO CabalSourceDir +unpackCabal cabalVer tmpdir variant = do let cabal = "Cabal-" ++ showVersion cabalVer dir = tmpdir </> cabal variant_opts = case variant of Pristine -> [ "--pristine" ]; _ -> [] args = [ "get", cabal ] ++ variant_opts - callProcessStderr opts (Just tmpdir) (oCabalProgram opts) args + callProcessStderr (Just tmpdir) oCabalProgram args return $ CabalSourceDir dir -unpackCabalHEAD :: Options -> FilePath -> IO (CabalSourceDir, CommitId) -unpackCabalHEAD opts tmpdir = do +unpackCabalHEAD :: Env => FilePath -> IO (CabalSourceDir, CommitId) +unpackCabalHEAD tmpdir = do let dir = tmpdir </> "cabal-head.git" url = "https://github.com/haskell/cabal.git" ExitSuccess <- rawSystem "git" [ "clone", "--depth=1", url, dir] commit <- - withDirectory_ dir $ trim <$> readProcess' opts "git" ["rev-parse", "HEAD"] "" + withDirectory_ dir $ trim <$> readProcess' "git" ["rev-parse", "HEAD"] "" return (CabalSourceDir $ dir </> "Cabal", CommitId commit) where withDirectory_ :: FilePath -> IO a -> IO a @@ -661,58 +670,60 @@ errorInstallCabal cabalVer _distdir = panicIO $ printf "\ where sver = showVersion cabalVer -listCabalVersions :: Options -> MaybeT IO [Version] -listCabalVersions opts = listCabalVersions' opts Nothing +listCabalVersions :: Env => MaybeT IO [Version] +listCabalVersions = listCabalVersions' Nothing -listCabalVersions' :: Options -> Maybe PackageDbDir -> MaybeT IO [Version] -listCabalVersions' opts@Options {..} mdb = do +listCabalVersions' :: Env => Maybe PackageDbDir -> MaybeT IO [Version] +listCabalVersions' mdb = do case mdb of Nothing -> mzero Just (PackageDbDir db_path) -> do exists <- liftIO $ doesDirectoryExist db_path case exists of False -> mzero - True -> MaybeT $ logIOError opts "listCabalVersions'" $ Just <$> do + True -> MaybeT $ logIOError "listCabalVersions'" $ Just <$> do let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb args = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt catMaybes . map (fmap snd . parsePkgId . fromString) . words - <$> readProcess' opts oGhcPkgProgram args "" + <$> readProcess' oGhcPkgProgram args "" -cabalVersionExistsInPkgDb :: Options -> Version -> PackageDbDir -> IO Bool -cabalVersionExistsInPkgDb opts cabalVer db@(PackageDbDir db_path) = do +cabalVersionExistsInPkgDb :: Env => Version -> PackageDbDir -> IO Bool +cabalVersionExistsInPkgDb cabalVer db@(PackageDbDir db_path) = do exists <- doesDirectoryExist db_path case exists of False -> return False True -> fromMaybe False <$> runMaybeT (do - vers <- listCabalVersions' opts (Just db) + vers <- listCabalVersions' (Just db) return $ cabalVer `elem` vers) -ghcVersion :: Options -> IO Version -ghcVersion opts@Options {..} = do - parseVer . trim <$> readProcess' opts oGhcProgram ["--numeric-version"] "" +ghcVersion :: Env => IO Version +ghcVersion = do + parseVer . trim <$> readProcess' oGhcProgram ["--numeric-version"] "" -ghcPkgVersion :: Options -> IO Version -ghcPkgVersion opts@Options {..} = do - parseVer . trim . dropWhile (not . isDigit) <$> readProcess' opts oGhcPkgProgram ["--version"] "" +ghcPkgVersion :: Env => IO Version +ghcPkgVersion = + parseVer . trim . dropWhile (not . isDigit) + <$> readProcess' oGhcPkgProgram ["--version"] "" newtype CabalInstallVersion = CabalInstallVersion { cabalInstallVer :: Version } -cabalInstallVersion :: Options -> IO CabalInstallVersion -cabalInstallVersion opts@Options {..} = do - CabalInstallVersion . parseVer . trim - <$> readProcess' opts oCabalProgram ["--numeric-version"] "" - -createPkgDb :: Options -> CabalVersion -> IO PackageDbDir -createPkgDb opts@Options {..} cabalVer = do - db@(PackageDbDir db_path) <- getPrivateCabalPkgDb opts cabalVer +cabalInstallVersion :: Env => IO CabalInstallVersion +cabalInstallVersion = do + CabalInstallVersion . parseVer . trim + <$> readProcess' oCabalProgram ["--numeric-version"] "" + +createPkgDb :: Env => CabalVersion -> IO PackageDbDir +createPkgDb cabalVer = do + db@(PackageDbDir db_path) <- getPrivateCabalPkgDb cabalVer exists <- doesDirectoryExist db_path - when (not exists) $ callProcessStderr opts Nothing oGhcPkgProgram ["init", db_path] + when (not exists) $ + callProcessStderr Nothing oGhcPkgProgram ["init", db_path] return db -getPrivateCabalPkgDb :: Options -> CabalVersion -> IO PackageDbDir -getPrivateCabalPkgDb opts cabalVer = do +getPrivateCabalPkgDb :: Env => CabalVersion -> IO PackageDbDir +getPrivateCabalPkgDb cabalVer = do appdir <- appCacheDir - ghcVer <- ghcVersion opts + ghcVer <- ghcVersion let db_path = appdir </> exeName cabalVer ++ "-ghc" ++ showVersion ghcVer ++ ".package-db" @@ -734,3 +745,14 @@ cabalFileTopField field cabalFile = value Just value = extract <$> find ((field++":") `isPrefixOf`) ls ls = map (map toLower) $ lines cabalFile extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace) + +vLog :: (Env, MonadIO m) => String -> m () +vLog msg | CompileOptions { oVerbose = True } <- ?opts = + liftIO $ hPutStrLn stderr msg +vLog _ = return () + +logIOError :: Env => String -> IO (Maybe a) -> IO (Maybe a) +logIOError label a = do + a `catchIOError` \ex -> do + vLog $ label ++ ": " ++ show ex + return Nothing diff --git a/src/CabalHelper/Compiletime/Log.hs b/src/CabalHelper/Compiletime/Log.hs deleted file mode 100644 index a329c54..0000000 --- a/src/CabalHelper/Compiletime/Log.hs +++ /dev/null @@ -1,45 +0,0 @@ --- cabal-helper: Simple interface to Cabal's configuration state --- Copyright (C) 2017-2018 Daniel Gröber <cabal-helper@dxld.at> --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see <http://www.gnu.org/licenses/>. - -{-# LANGUAGE ScopedTypeVariables #-} - -{-| -Module : CabalHelper.Compiletime.Log -Description : Basic logging facilities -License : GPL-3 --} - -module CabalHelper.Compiletime.Log where - -import Control.Monad -import Control.Monad.IO.Class -import Control.Exception as E -import Data.String -import System.IO -import Prelude - -import CabalHelper.Compiletime.Types - -vLog :: MonadIO m => Options -> String -> m () -vLog Options { oVerbose = True } msg = - liftIO $ hPutStrLn stderr msg -vLog _ _ = return () - -logIOError :: Options -> String -> IO (Maybe a) -> IO (Maybe a) -logIOError opts label a = do - a `E.catch` \(ex :: IOError) -> do - vLog opts $ label ++ ": " ++ show ex - return Nothing diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 77c3255..10fe916 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -14,7 +14,8 @@ -- You should have received a copy of the GNU General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures, + KindSignatures, ImplicitParams, ConstraintKinds #-} {-| Module : CabalHelper.Compiletime.Types @@ -25,18 +26,47 @@ License : GPL-3 module CabalHelper.Compiletime.Types where import Data.Version +import Data.Typeable +import GHC.Generics -data Options = Options { - oHelp :: Bool - , oVerbose :: Bool - , oGhcProgram :: FilePath - , oGhcPkgProgram :: FilePath - , oCabalProgram :: FilePath - , oCabalVersion :: Maybe Version - , oCabalPkgDb :: Maybe PackageDbDir -} +type Env = (?opts :: CompileOptions) -newtype PackageDbDir = PackageDbDir { unPackageDbDir :: FilePath } +-- | Paths or names of various programs we need. +data Programs = Programs { + -- | The path to the @cabal@ program. + cabalProgram :: FilePath, + + -- | The path to the @ghc@ program. + ghcProgram :: FilePath, + + -- | The path to the @ghc-pkg@ program. If + -- not changed it will be derived from the path to 'ghcProgram'. + ghcPkgProgram :: FilePath + } deriving (Eq, Ord, Show, Read, Generic, Typeable) + +-- | Default all programs to their unqualified names, i.e. they will be searched +-- for on @PATH@. +defaultPrograms :: Programs +defaultPrograms = Programs "cabal" "ghc" "ghc-pkg" + +data CompileOptions = CompileOptions + { oVerbose :: Bool + , oCabalPkgDb :: Maybe PackageDbDir + , oCabalVersion :: Maybe Version + , oPrograms :: Programs + } -defaultOptions :: Options -defaultOptions = Options False False "ghc" "ghc-pkg" "cabal" Nothing Nothing +oCabalProgram :: Env => FilePath +oCabalProgram = cabalProgram $ oPrograms ?opts + +oGhcProgram :: Env => FilePath +oGhcProgram = ghcProgram $ oPrograms ?opts + +oGhcPkgProgram :: Env => FilePath +oGhcPkgProgram = ghcPkgProgram $ oPrograms ?opts + +defaultCompileOptions :: CompileOptions +defaultCompileOptions = + CompileOptions False Nothing Nothing defaultPrograms + +newtype PackageDbDir = PackageDbDir { unPackageDbDir :: FilePath } diff --git a/src/CabalHelper/Compiletime/Wrapper.hs b/src/CabalHelper/Compiletime/Wrapper.hs deleted file mode 100644 index 461ef96..0000000 --- a/src/CabalHelper/Compiletime/Wrapper.hs +++ /dev/null @@ -1,227 +0,0 @@ --- cabal-helper: Simple interface to Cabal's configuration state --- Copyright (C) 2015-2018 Daniel Gröber <cabal-helper@dxld.at> --- --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program. If not, see <http://www.gnu.org/licenses/>. -{-# LANGUAGE RecordWildCards, NamedFieldPuns, FlexibleContexts, ViewPatterns #-} -module Main where - -import Cabal.Plan -import Control.Applicative -import Control.Monad -import Data.Char -import Data.List -import Data.Maybe -import Data.String -import Text.Printf -import Text.Show.Pretty -import System.Console.GetOpt -import System.Environment -import System.Directory -import System.FilePath -import System.Process -import System.Exit -import System.IO -import Prelude - -import qualified Data.Text as Text -import qualified Data.Map.Strict as Map - -import Distribution.System (buildPlatform) -import Distribution.Text (display) -import Distribution.Verbosity (silent, deafening) -import Distribution.Package (packageName, packageVersion) -import Distribution.Simple.GHC as GHC (configure) - -import Paths_cabal_helper (version) -import CabalHelper.Compiletime.Compat.ProgramDb - ( defaultProgramDb, programPath, lookupProgram, ghcProgram, ghcPkgProgram) -import CabalHelper.Compiletime.Compat.Version -import CabalHelper.Compiletime.Compile -import CabalHelper.Compiletime.Types -import CabalHelper.Shared.Common -import CabalHelper.Shared.InterfaceTypes - -usage :: IO () -usage = do - prog <- getProgName - hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg - where - usageMsg = "\ -\( print-appcachedir\n\ -\| print-build-platform\n\ -\| [--verbose]\n\ -\ [--with-ghc=GHC_PATH]\n\ -\ [--with-ghc-pkg=GHC_PKG_PATH]\n\ -\ [--with-cabal=CABAL_PATH]\n\ -\ [--with-cabal-version=VERSION]\n\ -\ [--with-cabal-pkg-db=PKG_DB]\n\ -\ v1-style PROJ_DIR DIST_DIR \n\ -\ ( print-exe | package-id | [CABAL_HELPER_ARGS...] )\n\ -\ v2-style PROJ_DIR DIST_NEWSTYLE_DIR DIST_DIR\n\ -\ ( print-exe | package-id | [CABAL_HELPER_ARGS...] )\n\ -\)\n" - -globalArgSpec :: [OptDescr (Options -> Options)] -globalArgSpec = - [ option "h" ["help"] "Display help message" $ - NoArg $ \o -> o { oHelp = True } - , option "" ["verbose"] "Be more verbose" $ - NoArg $ \o -> o { oVerbose = True } - - , option "" ["with-ghc"] "GHC executable to use" $ - reqArg "PROG" $ \p o -> o { oGhcProgram = p } - - , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ - reqArg "PROG" $ \p o -> o { oGhcPkgProgram = p } - - , option "" ["with-cabal"] "cabal-install executable to use" $ - reqArg "PROG" $ \p o -> o { oCabalProgram = p } - - , option "" ["with-cabal-version"] "Cabal library version to use" $ - reqArg "VERSION" $ \p o -> o { oCabalVersion = Just $ parseVer p } - - , option "" ["with-cabal-pkg-db"] "package database to look for Cabal library in" $ - reqArg "PKG_DB" $ \p o -> o { oCabalPkgDb = Just (PackageDbDir p) } - - ] - where - option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a - option s l udsc dsc = Option s l dsc udsc - - reqArg :: String -> (String -> a) -> ArgDescr a - reqArg udsc dsc = ReqArg dsc udsc - -parseCommandArgs :: Options -> [String] -> (Options, [String]) -parseCommandArgs opts argv - = case getOpt RequireOrder globalArgSpec argv of - (o,r,[]) -> (foldr id opts o, r) - (_,_,errs) -> - panic $ "Parsing command options failed:\n" ++ concat errs - -guessProgramPaths :: Options -> IO Options -guessProgramPaths opts = do - let v | oVerbose opts = deafening - | otherwise = silent - - mGhcPath0 | same oGhcProgram opts dopts = Nothing - | otherwise = Just $ oGhcProgram opts - mGhcPkgPath0 | same oGhcPkgProgram opts dopts = Nothing - | otherwise = Just $ oGhcPkgProgram opts - - (_compiler, _mplatform, progdb) - <- GHC.configure - v - mGhcPath0 - mGhcPkgPath0 - defaultProgramDb - - let mghcPath1 = programPath <$> lookupProgram ghcProgram progdb - mghcPkgPath1 = programPath <$> lookupProgram ghcPkgProgram progdb - - return $ opts { oGhcProgram = fromMaybe (oGhcProgram opts) mghcPath1 - , oGhcPkgProgram = fromMaybe (oGhcProgram opts) mghcPkgPath1 - } - where - same f o o' = f o == f o' - dopts = defaultOptions - -overrideVerbosityEnvVar :: Options -> IO Options -overrideVerbosityEnvVar opts = do - x <- lookup "CABAL_HELPER_DEBUG" <$> getEnvironment - return $ case x of - Just _ -> opts { oVerbose = True } - Nothing -> opts - -main :: IO () -main = handlePanic $ do - (opts', args) <- parseCommandArgs defaultOptions <$> getArgs - opts <- overrideVerbosityEnvVar =<< guessProgramPaths opts' - case args of - _ | oHelp opts -> usage - [] -> usage - "help":[] -> usage - "version":[] -> putStrLn $ showVersion version - "print-appdatadir":[] -> putStrLn =<< appCacheDir - "print-appcachedir":[] -> putStrLn =<< appCacheDir - "print-build-platform":[] -> putStrLn $ display buildPlatform - - _:projdir:_distdir:"package-id":[] -> do - let v | oVerbose opts = deafening - | otherwise = silent - -- ghc-mod will catch multiple cabal files existing before we get here - [cfile] <- filter isCabalFile <$> getDirectoryContents projdir - gpd <- readPackageDescription v (projdir </> cfile) - putStrLn $ show $ - [Just $ ChResponseVersion (display (packageName gpd)) (toDataVersion $ packageVersion gpd)] - - "v2-style":projdir:distdir_newstyle:unitid':args' -> do - let unitid = UnitId $ Text.pack unitid' - let plan_path = distdir_newstyle </> "cache" </> "plan.json" - plan@PlanJson {pjCabalLibVersion=Ver (makeDataVersion -> pjCabalLibVersion) } - <- decodePlanJson plan_path - case oCabalVersion opts of - Just ver | pjCabalLibVersion /= ver -> let - sver = showVersion ver - spjVer = showVersion pjCabalLibVersion - in panic $ printf "\ -\Cabal version %s was requested but plan.json was written by version %s" sver spjVer - _ -> case Map.lookup unitid $ pjUnits plan of - Just u@Unit {uType} | uType /= UnitTypeLocal -> do - panic $ "\ -\UnitId '"++ unitid' ++"' points to non-local unit: " ++ ppShow u - Just Unit {uDistDir=Nothing} -> panic $ printf "\ -\plan.json doesn't contain 'dist-dir' for UnitId '"++ unitid' ++"'" - Just Unit {uType=UnitTypeLocal, uDistDir=Just distdir} -> - runHelper opts projdir (Just (plan, distdir_newstyle)) distdir pjCabalLibVersion args' - _ -> let - units = map (\(UnitId u) -> Text.unpack u) - $ Map.keys - $ Map.filter ((==UnitTypeLocal) . uType) - $ pjUnits plan - - units_list = unlines $ map (" "++) units - in - panic $ "\ -\UnitId '"++ unitid' ++"' not found in plan.json, available local units:\n" ++ units_list - - "v1-style":projdir:distdir:args' -> do - cfgf <- canonicalizePath (distdir </> "setup-config") - mhdr <- getCabalConfigHeader cfgf - case (mhdr, oCabalVersion opts) of - (Nothing, _) -> panic $ printf "\ -\Could not read Cabal's persistent setup configuration header\n\ -\- Check first line of: %s\n\ -\- Maybe try: $ cabal configure" cfgf - (Just (hdrCabalVersion, _), Just ver) - | hdrCabalVersion /= ver -> panic $ printf "\ -\Cabal version %s was requested but setup configuration was\n\ -\written by version %s" (showVersion ver) (showVersion hdrCabalVersion) - (Just (hdrCabalVersion, _), _) -> - runHelper opts projdir Nothing distdir hdrCabalVersion args' - _ -> do - hPutStrLn stderr "Invalid command line!" - usage - exitWith $ ExitFailure 1 - -runHelper :: Options -> FilePath -> Maybe (PlanJson, FilePath) -> FilePath -> DataVersion -> [String] -> IO () -runHelper opts projdir mnewstyle distdir cabal_ver args' = do - eexe <- compileHelper opts cabal_ver projdir mnewstyle distdir - case eexe of - Left e -> exitWith e - Right exe -> do - case args' of - "print-exe":_ -> putStrLn exe - _ -> do - (_,_,_,h) <- createProcess $ proc exe $ projdir : distdir : args' - exitWith =<< waitForProcess h diff --git a/src/CabalHelper/Shared/Sandbox.hs b/src/CabalHelper/Shared/Sandbox.hs index 2f3774f..f7b7470 100644 --- a/src/CabalHelper/Shared/Sandbox.hs +++ b/src/CabalHelper/Shared/Sandbox.hs @@ -34,16 +34,17 @@ import Prelude import qualified Data.Traversable as T -- | Get the path to the sandbox package-db in a project -getSandboxPkgDb :: FilePath - -- ^ Path to the cabal package root directory (containing the - -- @cabal.sandbox.config@ file) - -> String +getSandboxPkgDb :: String -- ^ Cabal build platform, i.e. @buildPlatform@ -> Version -- ^ GHC version (@cProjectVersion@ is your friend) + -> FilePath + -- ^ Path to the cabal package root directory (containing the + -- @cabal.sandbox.config@ file) -> IO (Maybe FilePath) -getSandboxPkgDb d platform ghcVer = do - mConf <- T.traverse readFile =<< mightExist (d </> "cabal.sandbox.config") +getSandboxPkgDb platform ghcVer projdir = do + mConf <- + T.traverse readFile =<< mightExist (projdir </> "cabal.sandbox.config") return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf) where diff --git a/tests/CompileTest.hs b/tests/CompileTest.hs index 4c1f752..9eb6175 100644 --- a/tests/CompileTest.hs +++ b/tests/CompileTest.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, GADTs #-} +{-# LANGUAGE ScopedTypeVariables, GADTs, ImplicitParams #-} import System.Environment (getArgs) import System.Directory @@ -44,15 +44,19 @@ setupHOME = do main :: IO () main = do + let ?progs = defaultPrograms + let ?opts = defaultCompileOptions { oVerbose = True } + args <- getArgs case args of "list-versions":[] -> do - mapM_ print =<< (allCabalVersions <$> ghcVersion defaultOptions) + mapM_ print =<< (allCabalVersions <$> ghcVersion) "list-versions":ghc_ver_str:[] -> mapM_ print $ allCabalVersions (parseVer ghc_ver_str) _ -> test args +test :: Env => [String] -> IO () test args = do let action | null args = testAllCabalVersions @@ -135,13 +139,13 @@ allCabalVersions ghc_ver = let reverse $ filter (flip withinRange'CH constraint) cabal_versions -testAllCabalVersions :: IO () +testAllCabalVersions :: Env => IO () testAllCabalVersions = do - ghc_ver <- ghcVersion defaultOptions + ghc_ver <- ghcVersion let relevant_cabal_versions = allCabalVersions ghc_ver testCabalVersions $ map Right relevant_cabal_versions ++ [Left HEAD] -testCabalVersions :: [Either HEAD Version] -> IO () +testCabalVersions :: Env => [Either HEAD Version] -> IO () testCabalVersions versions = do rvs <- forM versions $ \ver -> do let sver = either show showVersion ver @@ -167,9 +171,10 @@ testCabalVersions versions = do isLeft' (Left _) = True isLeft' (Right _) = False -compilePrivatePkgDb :: Either HEAD Version -> IO (Either ExitCode FilePath) +compilePrivatePkgDb + :: Env => Either HEAD Version -> IO (Either ExitCode FilePath) compilePrivatePkgDb eCabalVer = do - res <- E.try $ installCabal defaultOptions { oVerbose = True } eCabalVer + res <- E.try $ installCabal eCabalVer case res of Right (db, cabalVer) -> compileWithPkg db cabalVer @@ -177,7 +182,8 @@ compilePrivatePkgDb eCabalVer = do print ioe return $ Left (ExitFailure 1) -compileWithPkg :: PackageDbDir +compileWithPkg :: Env + => PackageDbDir -> CabalVersion -> IO (Either ExitCode FilePath) compileWithPkg db cabalVer = do @@ -187,7 +193,6 @@ compileWithPkg db cabalVer = do compile comp (compPaths appdir (error "compile-test: distdir not available") comp) - defaultOptions { oVerbose = True } cabalPkgId :: CabalVersion -> String |