diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs --- a/CabalHelper/Common.hs +++ b/CabalHelper/Common.hs @@ -31,6 +31,7 @@ import System.IO import System.Exit import Text.ParserCombinators.ReadP +import Prelude data Panic = Panic String deriving (Typeable, Show) instance Exception Panic diff --git a/CabalHelper/Data.hs b/CabalHelper/Data.hs --- a/CabalHelper/Data.hs +++ b/CabalHelper/Data.hs @@ -32,7 +32,8 @@ withHelperSources action = withSystemTempDirectory "cabal-helper" $ \dir -> do let chdir = dir "CabalHelper" createDirectory chdir - forM_ sourceFiles $ \(fn, src) -> writeFile (chdir fn) src + forM_ sourceFiles $ \(fn, src) -> + BS.writeFile (chdir fn) $ UTF8.fromString src action dir sourceFiles :: [(FilePath, String)] diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs --- a/CabalHelper/Main.hs +++ b/CabalHelper/Main.hs @@ -96,6 +96,7 @@ ++" | ghc-pkg-options [--with-inplace]\n" ++" | ghc-merged-pkg-options [--with-inplace]\n" ++" | ghc-lang-options [--with-inplace]\n" + ++" | package-db-stack\n" ++" | entrypoints\n" ++" | source-dirs\n" ++" ) ...\n" @@ -108,6 +109,7 @@ , "ghc-src-options" , "ghc-pkg-options" , "ghc-lang-options" + , "package-db-stack" , "entrypoints" , "source-dirs"] @@ -220,6 +222,15 @@ ghcOptExtensionMap = ghcOptExtensionMap opts } return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])]) + + "package-db-stack":[] -> do + let + pkgDb GlobalPackageDB = ChPkgGlobal + pkgDb UserPackageDB = ChPkgUser + pkgDb (SpecificPackageDB s) = ChPkgSpecific s + + -- TODO: Setup.hs has access to the sandbox as well: ghc-mod#478 + return $ Just $ ChResponsePkgDbs $ map pkgDb $ withPackageDB lbi "entrypoints":[] -> do eps <- componentsMap lbi v distdir $ \c clbi bi -> diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs --- a/CabalHelper/Types.hs +++ b/CabalHelper/Types.hs @@ -34,6 +34,7 @@ = ChResponseCompList [(ChComponentName, [String])] | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)] | ChResponseList [String] + | ChResponsePkgDbs [ChPkgDb] | ChResponseLbi String | ChResponseVersion String Version deriving (Eq, Ord, Read, Show, Generic) @@ -49,3 +50,8 @@ | ChExeEntrypoint { chMainIs :: FilePath , chOtherModules :: [ChModuleName] } deriving (Eq, Ord, Read, Show, Generic) + +data ChPkgDb = ChPkgGlobal + | ChPkgUser + | ChPkgSpecific FilePath + deriving (Eq, Ord, Read, Show, Generic) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs --- a/CabalHelper/Wrapper.hs +++ b/CabalHelper/Wrapper.hs @@ -23,6 +23,7 @@ import Control.Monad import Control.Monad.Trans.Maybe import Control.Monad.IO.Class +import Data.Traversable import Data.Char import Data.List import Data.Maybe @@ -36,6 +37,7 @@ import System.Process import System.Exit import System.IO +import Prelude import Distribution.System (buildPlatform) import Distribution.Text (display) @@ -53,20 +55,28 @@ usageMsg = "\ \( print-appdatadir\n\ \| print-build-platform\n\ -\| DIST_DIR ( print-exe | [CABAL_HELPER_ARGS...] ) )\n" +\| [--verbose]\n\ +\ [--with-ghc=GHC_PATH]\n\ +\ [--with-ghc-pkg=GHC_PKG_PATH]\n\ +\ [--with-cabal=CABAL_PATH]\n\ +\ DIST_DIR ( print-exe | [CABAL_HELPER_ARGS...] ) )\n" data Options = Options { - ghcProgram :: FilePath + verbose :: Bool + , ghcProgram :: FilePath , ghcPkgProgram :: FilePath , cabalProgram :: FilePath } defaultOptions :: Options -defaultOptions = Options "ghc" "ghc-pkg" "cabal" +defaultOptions = Options False "ghc" "ghc-pkg" "cabal" globalArgSpec :: [OptDescr (Options -> Options)] globalArgSpec = - [ option "" ["with-ghc"] "GHC executable to use" $ + [ option "" ["verbose"] "Be more verbose" $ + NoArg $ \o -> o { verbose = True } + + , option "" ["with-ghc"] "GHC executable to use" $ reqArg "PROG" $ \p o -> o { ghcProgram = p } , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ @@ -84,10 +94,10 @@ parseCommandArgs :: Options -> [String] -> (Options, [String]) parseCommandArgs opts argv - = case getOpt Permute globalArgSpec argv of + = case getOpt RequireOrder globalArgSpec argv of (o,r,[]) -> (foldr id opts o, r) (_,_,errs) -> - panic $ "Parsing command options failed: " ++ concat errs + panic $ "Parsing command options failed:\n" ++ concat errs guessProgramPaths :: Options -> IO Options guessProgramPaths opts = do @@ -108,7 +118,8 @@ opts <- guessProgramPaths opts' case args of [] -> usage - "--help":[] -> usage + "help":[] -> usage + "version":[] -> putStrLn $ showVersion version "print-appdatadir":[] -> putStrLn =<< appDataDir "print-build-platform":[] -> putStrLn $ display buildPlatform distdir:args' -> do @@ -135,24 +146,35 @@ compileHelper :: Options -> Version -> FilePath -> IO (Either ExitCode FilePath) compileHelper opts cabalVer distdir = withHelperSources $ \chdir -> do - run [ Right <$> MaybeT (cachedExe cabalVer) + run [ compileCabalSource chdir -- TODO: here ghc's caching fails and it always + -- recompiles, probably because we write the + -- sources to a tempdir and they always look + -- newer than the Cabal sources, not sure if we + -- can fix this + , Right <$> MaybeT (cachedExe cabalVer) , compileGlobal chdir , cachedCabalPkg chdir - , compileCabalSource chdir , MaybeT (Just <$> compileSandbox chdir) ] where run actions = fromJust <$> runMaybeT (msum actions) + logMsg = "compiling helper with Cabal from " + + +-- for relaxed deps: find (sameMajorVersionAs cabalVer) . reverse . sort + -- | Check if this version is globally available compileGlobal :: FilePath -> MaybeT IO (Either ExitCode FilePath) compileGlobal chdir = do -- TODO: add option to let user specify custom package-db, relevant when -- using a Cabal compiled from git! - _ <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts - liftIO $ compileWithPkg chdir Nothing + ver <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts + vLog opts $ logMsg ++ "user/global package-db" + liftIO $ compileWithPkg chdir Nothing ver + -- | Check if we already compiled this version of cabal into a private -- package-db cachedCabalPkg :: FilePath -> MaybeT IO (Either ExitCode FilePath) @@ -160,20 +182,30 @@ db_exists <- liftIO $ cabalPkgDbExists opts cabalVer case db_exists of False -> mzero - True -> liftIO $ do - db <- cabalPkgDb opts cabalVer - compileWithPkg chdir (Just db) + True -> do + db <- liftIO $ cabalPkgDb opts cabalVer + vLog opts $ logMsg ++ "private package-db in " ++ db + liftIO $ compileWithPkg chdir (Just db) cabalVer -- | See if we're in a cabal source tree compileCabalSource :: FilePath -> MaybeT IO (Either ExitCode FilePath) compileCabalSource chdir = do let couldBeSrcDir = takeDirectory distdir cabalFile = couldBeSrcDir "Cabal.cabal" - cabal <- liftIO $ doesFileExist cabalFile - case cabal of + isCabalMagicVer = cabalVer == Version [1,9999] [] + cabalSrc <- liftIO $ doesFileExist cabalFile + + when isCabalMagicVer $ + vLog opts $ "cabal magic version (1.9999) found" + + when cabalSrc $ + vLog opts $ "directory above distdir looks like cabal source tree (Cabal.cabal exists)" + + case isCabalMagicVer || cabalSrc of False -> mzero True -> liftIO $ do ver <- cabalFileVersion <$> readFile cabalFile + vLog opts $ "compiling helper with local Cabal source tree" compileWithCabalTree chdir ver couldBeSrcDir -- | Compile the requested cabal version into an isolated package-db @@ -181,13 +213,13 @@ compileSandbox chdir = do db <- installCabal opts cabalVer `E.catch` \(SomeException _) -> errorInstallCabal cabalVer distdir - compileWithPkg chdir (Just db) + compileWithPkg chdir (Just db) cabalVer compileWithCabalTree chdir ver srcDir = - compile opts $ Compile chdir (Just srcDir) Nothing ver [] + compile distdir opts $ Compile chdir (Just srcDir) Nothing ver [] - compileWithPkg chdir mdb = - compile opts $ Compile chdir Nothing mdb cabalVer [cabalPkgId cabalVer] + compileWithPkg chdir mdb ver = + compile distdir opts $ Compile chdir Nothing mdb ver [cabalPkgId ver] cabalPkgId v = "Cabal-" ++ showVersion v @@ -211,7 +243,8 @@ \ having it linked to a version of Cabal that's available in you\n\ \ package-dbs or can be built automatically:\n\ \ $ ghc-pkg list | grep Cabal # find an available Cabal version\n\ -\ $ cabal install cabal-install --constraint 'Cabal == $the_found_version'\n\ +\ Cabal-W.X.Y.Z\n\ +\ $ cabal install cabal-install --constraint 'Cabal == W.X.*'\n\ \ Afterwards you'll have to reconfigure your project:\n\ \ $ cabal clean && cabal configure\n\ \\n\ @@ -225,6 +258,7 @@ where sver = showVersion cabalVer + data Compile = Compile { cabalHelperSourceDir :: FilePath, cabalSourceDir :: Maybe FilePath, @@ -233,12 +267,23 @@ packageDeps :: [String] } -compile :: Options -> Compile -> IO (Either ExitCode FilePath) -compile Options {..} Compile {..} = do - outdir <- appDataDir - createDirectoryIfMissing True outdir - exe <- exePath cabalVersion +compile :: FilePath -> Options -> Compile -> IO (Either ExitCode FilePath) +compile distdir opts@Options {..} Compile {..} = do + cCabalSourceDir <- canonicalizePath `traverse` cabalSourceDir + appdir <- appDataDir + let outdir' = maybe appdir (const $ distdir "cabal-helper") cCabalSourceDir + createDirectoryIfMissing True outdir' + outdir <- canonicalizePath outdir' + + let exedir' = maybe outdir (const distdir) cCabalSourceDir + createDirectoryIfMissing True exedir' + exedir <- canonicalizePath exedir' + exe <- exePath' cabalVersion <$> canonicalizePath exedir + + vLog opts $ "outdir: " ++ outdir + vLog opts $ "exedir: " ++ exedir + let Version (mj:mi:_) _ = cabalVersion let ghc_opts = concat [ @@ -249,11 +294,25 @@ , "-optP-DCABAL_MINOR=" ++ show mi ], maybeToList $ ("-package-conf="++) <$> packageDb, - map ("-i"++) $ ".":maybeToList cabalSourceDir, + map ("-i"++) $ nub $ ".":maybeToList cCabalSourceDir, + + if isNothing cCabalSourceDir + then [ "-hide-all-packages" + , "-package", "base" + , "-package", "directory" + , "-package", "filepath" + , "-package", "process" + , "-package", "bytestring" + , "-package", "ghc-prim" + ] + else [], + concatMap (\p -> ["-package", p]) packageDeps, [ "--make", "CabalHelper/Main.hs" ] ] + vLog opts $ intercalate " " $ map (("\""++) . (++"\"")) $ ghcProgram:ghc_opts + -- TODO: touch exe after, ghc doesn't do that if the input files didn't -- actually change rv <- callProcessStderr' (Just cabalHelperSourceDir) ghcProgram ghc_opts @@ -263,10 +322,13 @@ exePath :: Version -> IO FilePath exePath cabalVersion = do - outdir <- appDataDir - return $ outdir "cabal-helper-" ++ showVersion version -- our ver - ++ "-Cabal-" ++ showVersion cabalVersion + exePath' cabalVersion <$> appDataDir +exePath' :: Version-> FilePath -> FilePath +exePath' cabalVersion outdir = + outdir "cabal-helper-" ++ showVersion version -- our ver + ++ "-Cabal-" ++ showVersion cabalVersion + cachedExe :: Version -> IO (Maybe FilePath) cachedExe cabalVersion = do exe <- exePath cabalVersion @@ -306,25 +368,29 @@ \\n\ \If you want to avoid this automatic installation altogether install\n\ \version %s of Cabal manually (into your user or global package-db):\n\ -\ $ cabal install Cabal-%s\n\ +\ $ cabal install Cabal --constraint \"Cabal == %s\"\n\ \\n\ -\Building Cabal-%s..." appdir sver sver sver +\Building Cabal %s ...\n" appdir sver sver sver db <- createPkgDb opts ver - callProcessStderr (Just "/") (cabalProgram opts) $ concat + cabal_opts <- return $ concat [ [ "--package-db=clear" , "--package-db=global" , "--package-db=" ++ db , "--prefix=" ++ db "prefix" - , "-v0" , "--with-ghc=" ++ ghcProgram opts ] , if ghcPkgProgram opts /= ghcPkgProgram defaultOptions then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ] else [] - , [ "install", "Cabal-"++showVersion ver ] + , [ "install", "Cabal", "--constraint" + , "Cabal == " ++ showVersion ver ] ] + + vLog opts $ intercalate " " $ map (("\""++) . (++"\"")) $ cabalProgram opts:cabal_opts + + callProcessStderr (Just "/") (cabalProgram opts) cabal_opts hPutStrLn stderr "done" return db @@ -334,7 +400,7 @@ ghcPkgVersion :: Options -> IO Version ghcPkgVersion Options {..} = do - parseVer . trim <$> readProcess ghcPkgProgram ["--numeric-version"] "" + parseVer . trim . dropWhile (not . isDigit) <$> readProcess ghcPkgProgram ["--version"] "" trim :: String -> String trim = dropWhileEnd isSpace @@ -376,8 +442,13 @@ -- | Find @version: XXX@ delcaration in a cabal file cabalFileVersion :: String -> Version -cabalFileVersion cabalFile = do - fromJust $ parseVer . extract <$> find ("version" `isPrefixOf`) ls +cabalFileVersion cabalFile = + fromJust $ parseVer . extract <$> find ("version:" `isPrefixOf`) ls where ls = map (map toLower) $ lines cabalFile - extract = dropWhile (/=':') >>> dropWhile isSpace >>> takeWhile (not . isSpace) + extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace) + +vLog :: MonadIO m => Options -> String -> m () +vLog Options { verbose = True } msg = + liftIO $ hPutStrLn stderr msg +vLog _ _ = return () diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs --- a/Distribution/Helper.hs +++ b/Distribution/Helper.hs @@ -27,6 +27,7 @@ -- * Queries against Cabal\'s on disk state + , packageDbStack , entrypoints , sourceDirs , ghcOptions @@ -38,6 +39,7 @@ -- * Result types , ChModuleName(..) , ChComponentName(..) + , ChPkgDb(..) , ChEntrypoint(..) -- * General information @@ -86,6 +88,7 @@ def = Programs "cabal" "ghc" "ghc-pkg" data SomeLocalBuildInfo = SomeLocalBuildInfo { + slbiPackageDbStack :: [ChPkgDb], slbiEntrypoints :: [(ChComponentName, ChEntrypoint)], slbiSourceDirs :: [(ChComponentName, [String])], slbiGhcOptions :: [(ChComponentName, [String])], @@ -133,6 +136,9 @@ return slbi Just slbi -> return slbi +-- | List of package databases to use. +packageDbStack :: MonadIO m => Query m [ChPkgDb] + -- | Modules or files Cabal would have the compiler build directly. Can be used -- to compute the home module closure for a component. entrypoints :: MonadIO m => Query m [(ChComponentName, ChEntrypoint)] @@ -157,6 +163,7 @@ -- | Only language related options, i.e. @-XSomeExtension@ ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])] +packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi entrypoints = Query $ slbiEntrypoints `liftM` getSlbi sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi ghcOptions = Query $ slbiGhcOptions `liftM` getSlbi @@ -189,7 +196,8 @@ , "--with-cabal=" ++ cabalProgram progs ] - let args = [ "entrypoints" + let args = [ "package-db-stack" + , "entrypoints" , "source-dirs" , "ghc-options" , "ghc-src-options" @@ -206,7 +214,8 @@ , intercalate " " (map show $ distdir:args) , " (read failed)"] - let [ Just (ChResponseEntrypoints eps), + let [ Just (ChResponsePkgDbs pkgDbs), + Just (ChResponseEntrypoints eps), Just (ChResponseCompList srcDirs), Just (ChResponseCompList ghcOpts), Just (ChResponseCompList ghcSrcOpts), @@ -215,7 +224,7 @@ Just (ChResponseCompList ghcLangOpts) ] = res return $ SomeLocalBuildInfo - eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts + pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts -- | Create @cabal_macros.h@ and @Paths_\@ possibly other generated files -- in the usual place. diff --git a/cabal-helper.cabal b/cabal-helper.cabal --- a/cabal-helper.cabal +++ b/cabal-helper.cabal @@ -1,5 +1,5 @@ name: cabal-helper -version: 0.3.7.0 +version: 0.3.8.0 synopsis: Simple interface to some of Cabal's configuration state used by ghc-mod description: @cabal-helper@ provides a library which wraps the internal use of executables