cabal-helper 0.7.3.0 → 0.8.0.0
raw patch · 51 files changed
+3671/−2366 lines, 51 filesdep +containersdep +exceptionsdep +ghcdep −extradep ~Cabaldep ~basedep ~bytestringsetup-changednew-component:exe:cabal-helper-mainPVP ok
version bump matches the API change (PVP)
Dependencies added: containers, exceptions, ghc, ghc-paths, semigroupoids, unix-compat
Dependencies removed: extra
Dependency ranges changed: Cabal, base, bytestring, directory, filepath, process, template-haskell, unix
API changes (from Hackage documentation)
- Distribution.Helper: defaultQueryEnv :: FilePath -> FilePath -> QueryEnv
- Distribution.Helper: flags :: MonadIO m => Query m [(String, Bool)]
- Distribution.Helper: pkgLicenses :: MonadIO m => Query m [(String, [(String, Version)])]
- Distribution.Helper: prepare' :: MonadIO m => QueryEnv -> m ()
- Distribution.Helper: writeAutogenFiles' :: MonadIO m => QueryEnv -> m ()
+ Distribution.Helper: ChFLibName :: String -> ChComponentName
+ Distribution.Helper: ChSubLibName :: String -> ChComponentName
+ Distribution.Helper: NoBuildOutput :: NeedsBuildOutput
+ Distribution.Helper: ProduceBuildOutput :: NeedsBuildOutput
+ Distribution.Helper: [chSignatures] :: ChEntrypoint -> [ChModuleName]
+ Distribution.Helper: components :: Monad m => ComponentQuery m (ChComponentName -> b) -> Query m [b]
+ Distribution.Helper: data ComponentQuery m a
+ Distribution.Helper: data NeedsBuildOutput
+ Distribution.Helper: instance (GHC.Base.Functor m, GHC.Base.Monad m) => Data.Functor.Bind.Class.Apply (Distribution.Helper.ComponentQuery m)
+ Distribution.Helper: instance GHC.Base.Functor m => GHC.Base.Functor (Distribution.Helper.ComponentQuery m)
+ Distribution.Helper: mkQueryEnv :: FilePath -> FilePath -> QueryEnv
+ Distribution.Helper: needsBuildOutput :: MonadIO m => ComponentQuery m NeedsBuildOutput
+ Distribution.Helper: packageFlags :: MonadIO m => Query m [(String, Bool)]
- Distribution.Helper: ChLibEntrypoint :: [ChModuleName] -> [ChModuleName] -> ChEntrypoint
+ Distribution.Helper: ChLibEntrypoint :: [ChModuleName] -> [ChModuleName] -> [ChModuleName] -> ChEntrypoint
- Distribution.Helper: ChLibName :: String -> ChComponentName
+ Distribution.Helper: ChLibName :: ChComponentName
- Distribution.Helper: entrypoints :: MonadIO m => Query m [(ChComponentName, ChEntrypoint)]
+ Distribution.Helper: entrypoints :: MonadIO m => ComponentQuery m ChEntrypoint
- Distribution.Helper: ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])]
+ Distribution.Helper: ghcLangOptions :: MonadIO m => ComponentQuery m [String]
- Distribution.Helper: ghcOptions :: MonadIO m => Query m [(ChComponentName, [String])]
+ Distribution.Helper: ghcOptions :: MonadIO m => ComponentQuery m [String]
- Distribution.Helper: ghcPkgOptions :: MonadIO m => Query m [(ChComponentName, [String])]
+ Distribution.Helper: ghcPkgOptions :: MonadIO m => ComponentQuery m [String]
- Distribution.Helper: ghcSrcOptions :: MonadIO m => Query m [(ChComponentName, [String])]
+ Distribution.Helper: ghcSrcOptions :: MonadIO m => ComponentQuery m [String]
- Distribution.Helper: prepare :: MonadIO m => (FilePath -> [String] -> String -> IO String) -> FilePath -> FilePath -> m ()
+ Distribution.Helper: prepare :: MonadIO m => QueryEnv -> m ()
- Distribution.Helper: sourceDirs :: MonadIO m => Query m [(ChComponentName, [FilePath])]
+ Distribution.Helper: sourceDirs :: MonadIO m => ComponentQuery m [FilePath]
- Distribution.Helper: writeAutogenFiles :: MonadIO m => (FilePath -> [String] -> String -> IO String) -> FilePath -> FilePath -> m ()
+ Distribution.Helper: writeAutogenFiles :: MonadIO m => QueryEnv -> m ()
Files
- CabalHelper/Common.hs +0/−106
- CabalHelper/Compile.hs +0/−479
- CabalHelper/Data.hs +0/−46
- CabalHelper/GuessGhc.hs +0/−86
- CabalHelper/Licenses.hs +0/−119
- CabalHelper/Log.hs +0/−21
- CabalHelper/Main.hs +0/−483
- CabalHelper/Sandbox.hs +0/−56
- CabalHelper/Types.hs +0/−71
- CabalHelper/Wrapper.hs +0/−154
- Distribution/Helper.hs +0/−480
- README.md +17/−21
- Setup.hs +22/−15
- cabal-helper.cabal +233/−102
- lib/Distribution/Helper.hs +528/−0
- src/CabalHelper/Compiletime/Compat/Environment.hs +19/−0
- src/CabalHelper/Compiletime/Compat/Version.hs +25/−0
- src/CabalHelper/Compiletime/Compile.hs +691/−0
- src/CabalHelper/Compiletime/Data.hs +80/−0
- src/CabalHelper/Compiletime/GuessGhc.hs +92/−0
- src/CabalHelper/Compiletime/Log.hs +44/−0
- src/CabalHelper/Compiletime/Types.hs +40/−0
- src/CabalHelper/Compiletime/Wrapper.hs +164/−0
- src/CabalHelper/Runtime/Main.hs +828/−0
- src/CabalHelper/Shared/Common.hs +132/−0
- src/CabalHelper/Shared/InterfaceTypes.hs +80/−0
- src/CabalHelper/Shared/Sandbox.hs +77/−0
- tests/CompileTest.hs +184/−0
- tests/GhcSession.hs +177/−0
- tests/Spec.hs +0/−127
- tests/bkpregex/Setup.hs +2/−0
- tests/bkpregex/bkpregex.cabal +29/−0
- tests/bkpregex/regex-example/Main.hs +12/−0
- tests/bkpregex/regex-indef/Regex.hs +14/−0
- tests/bkpregex/regex-indef/Str.hsig +9/−0
- tests/bkpregex/regex-types/Regex/Types.hs +7/−0
- tests/bkpregex/str-impls/Str/ByteString.hs +17/−0
- tests/bkpregex/str-impls/Str/String.hs +21/−0
- tests/exeintlib/Exe.hs +5/−0
- tests/exeintlib/Setup.hs +2/−0
- tests/exeintlib/exeintlib.cabal +31/−0
- tests/exeintlib/intlib/IntLib.hs +7/−0
- tests/exeintlib/lib/Lib.hs +8/−0
- tests/exelib/Exe.hs +5/−0
- tests/exelib/Setup.hs +2/−0
- tests/exelib/exelib.cabal +25/−0
- tests/exelib/lib/Lib.hs +8/−0
- tests/fliblib/FLib.hs +5/−0
- tests/fliblib/Setup.hs +2/−0
- tests/fliblib/fliblib.cabal +19/−0
- tests/fliblib/lib/Lib.hs +8/−0
− CabalHelper/Common.hs
@@ -1,106 +0,0 @@--- cabal-helper: Simple interface to Cabal's configuration state--- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero 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 Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}-module CabalHelper.Common where--import Control.Applicative-import Control.Exception as E-import Control.Monad-import Data.List-import Data.Maybe-import Data.Version-import Data.Typeable-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import System.Environment-import System.IO-import System.Exit-import System.Directory-import System.FilePath-import Text.ParserCombinators.ReadP-import Prelude--data Panic = Panic String deriving (Typeable, Show)-instance Exception Panic--panic :: String -> a-panic msg = throw $ Panic msg--handlePanic :: IO a -> IO a-handlePanic action =- action `E.catch` \(Panic msg) -> errMsg msg >> exitFailure--errMsg :: String -> IO ()-errMsg str = do- prog <- getProgName- hPutStrLn stderr $ prog ++ ": " ++ str---- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and--- compiler version-getCabalConfigHeader :: FilePath -> IO (Maybe (Version, (ByteString, Version)))-getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do- parseHeader <$> BS.hGetLine h--parseHeader :: ByteString -> Maybe (Version, (ByteString, Version))-parseHeader header = case BS8.words header of- ["Saved", "package", "config", "for", _pkgId ,- "written", "by", cabalId,- "using", compId]- -> liftM2 (,) (snd <$> parsePkgId cabalId) (parsePkgId compId)- _ -> Nothing--parsePkgId :: ByteString -> Maybe (ByteString, Version)-parsePkgId bs =- case BS8.split '-' bs of- [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers)- _ -> Nothing--parseVer :: String -> Version-parseVer vers = runReadP parseVersion vers--majorVer :: Version -> Version-majorVer (Version b _) = Version (take 2 b) []--sameMajorVersionAs :: Version -> Version -> Bool-sameMajorVersionAs a b = majorVer a == majorVer b--runReadP :: ReadP t -> String -> t-runReadP p i = case filter ((=="") . snd) $ readP_to_S p i of- (a,""):[] -> a- _ -> error $ "Error parsing: " ++ show i--appDataDir :: IO FilePath-appDataDir = (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"--isCabalFile :: FilePath -> Bool-isCabalFile f = takeExtension' f == ".cabal"--takeExtension' :: FilePath -> String-takeExtension' p =- if takeFileName p == takeExtension p- then "" -- just ".cabal" is not a valid cabal file- else takeExtension p--replace :: String -> String -> String -> String-replace n r hs' = go "" hs'- where- go acc h- | take (length n) h == n =- reverse acc ++ r ++ drop (length n) h- go acc (h:hs) = go (h:acc) hs- go acc [] = reverse acc
− CabalHelper/Compile.hs
@@ -1,479 +0,0 @@--- cabal-helper: Simple interface to Cabal's configuration state--- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero 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 Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.-{-# LANGUAGE RecordWildCards, FlexibleContexts #-}-module CabalHelper.Compile where--import Control.Applicative-import Control.Arrow-import Control.Exception as E-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-import Data.String-import Data.Version-import Text.Printf-import System.Directory-import System.FilePath-import System.Process-import System.Exit-import System.IO-import System.IO.Temp-import Prelude--import Distribution.System (buildPlatform)-import Distribution.Text (display)--import Paths_cabal_helper (version)-import CabalHelper.Data-import CabalHelper.Common-import CabalHelper.Sandbox (getSandboxPkgDb)-import CabalHelper.Types-import CabalHelper.Log--data Compile = Compile {- compCabalHelperSourceDir :: FilePath,- compCabalSourceDir :: Maybe FilePath,- compPackageDb :: Maybe FilePath,- compCabalVersion :: Either String Version,- compPackageDeps :: [String]- }--compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath)-compileHelper opts cabalVer projdir distdir = withHelperSources $ \chdir -> do- case cabalPkgDb opts of- Nothing ->- run [- -- 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- compileCabalSource chdir- , Right <$> MaybeT (cachedExe cabalVer)- , compileSandbox chdir- , compileGlobal chdir- , cachedCabalPkg chdir- , MaybeT (Just <$> compilePrivatePkgDb chdir)- ]- mdb ->- run [ Right <$> MaybeT (cachedExe cabalVer)- , liftIO $ compileWithPkg chdir mdb cabalVer- ]-- 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- ver <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts- vLog opts $ logMsg ++ "user/global package-db"- liftIO $ compileWithPkg chdir Nothing ver-- -- | Check if this version is available in the project sandbox- compileSandbox :: FilePath -> MaybeT IO (Either ExitCode FilePath)- compileSandbox chdir = do- sandbox <- MaybeT $ getSandboxPkgDb projdir (display buildPlatform) =<< ghcVersion opts- ver <- MaybeT $ logSomeError opts "compileSandbox" $- find (== cabalVer) <$> listCabalVersions' opts (Just sandbox)- vLog opts $ logMsg ++ "sandbox package-db"- liftIO $ compileWithPkg chdir (Just sandbox) ver--- -- | Check if we already compiled this version of cabal into a private- -- package-db- cachedCabalPkg :: FilePath -> MaybeT IO (Either ExitCode FilePath)- cachedCabalPkg chdir = do- db_exists <- liftIO $ cabalPkgDbExists opts cabalVer- case db_exists of- False -> mzero- True -> do- db <- liftIO $ getPrivateCabalPkgDb opts (showVersion 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 cabalFile = projdir </> "Cabal.cabal"- 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 projdir-- -- | Compile the requested cabal version into an isolated package-db- compilePrivatePkgDb :: FilePath -> IO (Either ExitCode FilePath)- compilePrivatePkgDb chdir = do- db <- installCabal opts cabalVer `E.catch`- \(SomeException _) -> errorInstallCabal cabalVer distdir- compileWithPkg chdir (Just db) cabalVer-- compileWithCabalTree chdir ver srcDir =- compile distdir opts $ Compile chdir (Just srcDir) Nothing (Right ver) []-- compileWithPkg chdir mdb ver =- compile distdir opts $ Compile chdir Nothing mdb (Right ver) [cabalPkgId ver]-- cabalPkgId v = "Cabal-" ++ showVersion v--compile :: FilePath -> Options -> Compile -> IO (Either ExitCode FilePath)-compile distdir opts@Options {..} Compile {..} = do- cCabalSourceDir <- canonicalizePath `traverse` compCabalSourceDir- 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' compCabalVersion <$> canonicalizePath exedir-- vLog opts $ "outdir: " ++ outdir- vLog opts $ "exedir: " ++ exedir-- let (mj:mi:_) = case compCabalVersion of- Left _commitid -> [1, 10000]- Right (Version vs _) -> vs- let ghc_opts =- concat [- [ "-outputdir", outdir- , "-o", exe- , "-optP-DCABAL_HELPER=1"- , "-optP-DCABAL_MAJOR=" ++ show mj- , "-optP-DCABAL_MINOR=" ++ show mi- ],- maybeToList $ ("-package-conf="++) <$> compPackageDb,- map ("-i"++) $ nub $ ".":maybeToList cCabalSourceDir,-- if isNothing cCabalSourceDir- then [ "-hide-all-packages"- , "-package", "base"- , "-package", "containers"- , "-package", "directory"- , "-package", "filepath"- , "-package", "process"- , "-package", "bytestring"- , "-package", "ghc-prim"- ]- else [],-- concatMap (\p -> ["-package", p]) compPackageDeps,- [ "--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 compCabalHelperSourceDir) ghcProgram ghc_opts- return $ case rv of- ExitSuccess -> Right exe- e@(ExitFailure _) -> Left e--exePath :: Either String Version -> IO FilePath-exePath compCabalVersion = do- exePath' compCabalVersion <$> appDataDir--exePath' :: Either String Version -> FilePath -> FilePath-exePath' (Left commitid) outdir =- outdir </> "cabal-helper-" ++ showVersion version -- our ver- ++ "-Cabal-HEAD-" ++ commitid-exePath' (Right compCabalVersion) outdir =- outdir </> "cabal-helper-" ++ showVersion version -- our ver- ++ "-Cabal-" ++ showVersion compCabalVersion--callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode-callProcessStderr' mwd exe args = do- (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr- , cwd = mwd }- waitForProcess h--callProcessStderr :: 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--processFailedException :: String -> String -> [String] -> Int -> IO a-processFailedException fn exe args rv =- panic $ concat [fn, ": ", exe, " "- , intercalate " " (map show args)- , " (exit " ++ show rv ++ ")"]--installCabal :: Options -> Version -> IO FilePath-installCabal opts ver = do- appdir <- appDataDir- let sver = showVersion ver- hPutStr stderr $ printf "\-\cabal-helper-wrapper: Installing a private copy of Cabal because we couldn't\n\-\find the right version in your global/user package-db, this might take a\n\-\while but will only happen once per Cabal version you're using.\n\-\\n\-\If anything goes horribly wrong just delete this directory and try again:\n\-\ %s\n\-\\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 --constraint \"Cabal == %s\"\n\-\\n\-\Installing Cabal %s ...\n" appdir sver sver sver-- withSystemTempDirectory "cabal-helper" $ \tmpdir -> do- let- mpatch :: Maybe (FilePath -> IO ())- mpatch = snd <$> find ((ver`elem`) . fst) patchyCabalVersions- msrcdir <- sequenceA $ unpackPatchedCabal opts ver tmpdir <$> mpatch- db <- createPkgDb opts (showVersion ver)- cabalInstall opts db (maybe (Right ver) Left msrcdir)- return db--installCabalHEAD :: Options -> IO (FilePath, String)-installCabalHEAD opts = do- withSystemTempDirectory "cabal-helper" $ \tmpdir -> do- (srcdir, commit) <- unpackCabalHEAD tmpdir- db <- createPkgDb opts commit- cabalInstall opts db (Left srcdir)- return (db, commit)--cabalInstall :: Options -> FilePath -> Either FilePath Version -> IO ()-cabalInstall opts db e_ver_msrcdir = do- cabalInstallVer <- cabalInstallVersion opts- cabal_opts <- return $ concat- [- [ "--package-db=clear"- , "--package-db=global"- , "--package-db=" ++ db- , "--prefix=" ++ db </> "prefix"- , "--with-ghc=" ++ ghcProgram opts- ]- , if cabalInstallVer >= Version [1,20,0,0] []- then ["--no-require-sandbox"]- else []- , if ghcPkgProgram opts /= ghcPkgProgram defaultOptions- then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ]- else []- ,- case e_ver_msrcdir of- Right ver ->- [ "install", "Cabal"- , "--constraint", "Cabal == " ++ showVersion ver- ]- Left srcdir ->- [ "install", srcdir ]- ]-- vLog opts $ intercalate " "- $ map (("\""++) . (++"\""))- $ cabalProgram opts:cabal_opts-- callProcessStderr (Just "/") (cabalProgram opts) cabal_opts- hPutStrLn stderr "done"--patchyCabalVersions :: [([Version], FilePath -> IO ())]-patchyCabalVersions = [- ( [ Version [1,18,1] [] ]- , fixArrayConstraint- ),--- ( [ Version [1,18,0] [] ]- , \dir -> do- fixArrayConstraint dir- fixOrphanInstance dir- ),-- -- just want the pristine version- ( [ Version [1,24,1,0] [] ]- , \_ -> return ()- )- ]- where- fixArrayConstraint dir = do- let cabalFile = dir </> "Cabal.cabal"- cabalFileTmp = cabalFile ++ ".tmp"-- cf <- readFile cabalFile- writeFile cabalFileTmp $ replace "&& < 0.5" "&& < 0.6" cf- renameFile cabalFileTmp cabalFile-- fixOrphanInstance dir = do- let versionFile = dir </> "Distribution/Version.hs"- versionFileTmp = versionFile ++ ".tmp"-- let languagePragma =- "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}"- languagePragmaCPP =- "{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving #-}"-- derivingDataVersion =- "deriving instance Data Version"- derivingDataVersionCPP = unlines [- "#if __GLASGOW_HASKELL__ < 707",- derivingDataVersion,- "#endif"- ]-- vf <- readFile versionFile- writeFile versionFileTmp- $ replace derivingDataVersion derivingDataVersionCPP- $ replace languagePragma languagePragmaCPP vf-- renameFile versionFileTmp versionFile--unpackPatchedCabal ::- Options -> Version -> FilePath -> (FilePath -> IO ()) -> IO FilePath-unpackPatchedCabal opts cabalVer tmpdir patch = do- dir <- unpackCabal opts cabalVer tmpdir- patch dir- return dir--unpackCabal ::- Options -> Version -> FilePath -> IO FilePath-unpackCabal opts cabalVer tmpdir = do- let cabal = "Cabal-" ++ showVersion cabalVer- dir = tmpdir </> cabal- callProcessStderr (Just tmpdir) (cabalProgram opts)- [ "get", "--pristine", cabal ]- return dir--unpackCabalHEAD :: FilePath -> IO (FilePath, String)-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 <- trim <$> readProcess "git" ["-C", dir, "rev-parse", "HEAD"] ""- return (dir </> "Cabal", commit)--errorInstallCabal :: Version -> FilePath -> a-errorInstallCabal cabalVer _distdir = panic $ printf "\-\Installing Cabal version %s failed.\n\-\\n\-\You have the following choices to fix this:\n\-\\n\-\- The easiest way to try and fix this is just reconfigure the project and try\n\-\ again:\n\-\ $ cabal clean && cabal configure\n\-\\n\-\- If that fails you can try to install the version of Cabal mentioned above\n\-\ into your global/user package-db somehow, you'll probably have to fix\n\-\ something otherwise it wouldn't have failed above:\n\-\ $ cabal install Cabal --constraint 'Cabal == %s'\n\-\\n\-\- If you're using `Build-Type: Simple`:\n\-\ - You can see if you can reinstall your cabal-install executable while\n\-\ 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-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\-\- If you're using `Build-Type: Custom`:\n\-\ - Have cabal-install rebuild your Setup.hs executable with a version of the\n\-\ Cabal library that you have available in your global/user package-db:\n\-\ $ cabal clean && cabal configure\n\-\ You might also have to install some version of the Cabal to do this:\n\-\ $ cabal install Cabal\n\-\\n" sver sver- where- sver = showVersion cabalVer--cachedExe :: Version -> IO (Maybe FilePath)-cachedExe compCabalVersion = do- exe <- exePath (Right compCabalVersion)- exists <- doesFileExist exe- return $ if exists then Just exe else Nothing--listCabalVersions :: Options -> IO [Version]-listCabalVersions opts = listCabalVersions' opts Nothing---- TODO: Include sandbox? Probably only relevant for build-type:custom projects.-listCabalVersions' :: Options -> Maybe FilePath -> IO [Version]-listCabalVersions' Options {..} mdb = do- let mdbopt = ("--package-conf="++) <$> mdb- opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt-- catMaybes . map (fmap snd . parsePkgId . fromString) . words- <$> readProcess ghcPkgProgram opts ""--cabalPkgDbExists :: Options -> Version -> IO Bool-cabalPkgDbExists opts ver = do- db <- getPrivateCabalPkgDb opts (showVersion ver)- dexists <- doesDirectoryExist db- case dexists of- False -> return False- True -> do- vers <- listCabalVersions' opts (Just db)- return $ ver `elem` vers---ghcVersion :: Options -> IO Version-ghcVersion Options {..} = do- parseVer . trim <$> readProcess ghcProgram ["--numeric-version"] ""--ghcPkgVersion :: Options -> IO Version-ghcPkgVersion Options {..} = do- parseVer . trim . dropWhile (not . isDigit) <$> readProcess ghcPkgProgram ["--version"] ""--cabalInstallVersion :: Options -> IO Version-cabalInstallVersion Options {..} = do- parseVer . trim <$> readProcess cabalProgram ["--numeric-version"] ""--trim :: String -> String-trim = dropWhileEnd isSpace--createPkgDb :: Options -> String -> IO FilePath-createPkgDb opts@Options {..} ver = do- db <- getPrivateCabalPkgDb opts ver- exists <- doesDirectoryExist db- when (not exists) $ callProcessStderr Nothing ghcPkgProgram ["init", db]- return db--getPrivateCabalPkgDb :: Options -> String -> IO FilePath-getPrivateCabalPkgDb opts ver = do- appdir <- appDataDir- ghcVer <- ghcVersion opts- return $ appdir </> "Cabal-" ++ ver ++ "-db-" ++ showVersion ghcVer---- | Find @version: XXX@ delcaration in a cabal file-cabalFileVersion :: String -> Version-cabalFileVersion cabalFile =- fromJust $ parseVer . extract <$> find ("version:" `isPrefixOf`) ls- where- ls = map (map toLower) $ lines cabalFile- extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace)
− CabalHelper/Data.hs
@@ -1,46 +0,0 @@--- cabal-helper: Simple interface to Cabal's configuration state--- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero 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 Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fforce-recomp #-}-module CabalHelper.Data where--import Control.Monad-import Data.Functor-import qualified Data.ByteString as BS-import qualified Data.ByteString.UTF8 as UTF8-import Language.Haskell.TH-import System.FilePath-import System.Directory-import System.IO.Temp-import Prelude--withHelperSources :: (FilePath -> IO a) -> IO a-withHelperSources action = withSystemTempDirectory "cabal-helper" $ \dir -> do- let chdir = dir </> "CabalHelper"- createDirectory chdir- forM_ sourceFiles $ \(fn, src) ->- BS.writeFile (chdir </> fn) $ UTF8.fromString src- action dir--sourceFiles :: [(FilePath, String)]-sourceFiles =- [ ("Main.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Main.hs")))- , ("Common.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Common.hs")))- , ("Sandbox.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Sandbox.hs")))- , ("Licenses.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Licenses.hs")))- , ("Types.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "CabalHelper/Types.hs")))- ]
− CabalHelper/GuessGhc.hs
@@ -1,86 +0,0 @@-module CabalHelper.GuessGhc (guessToolFromGhcPath) where--import Data.Maybe-import Data.Char-import Distribution.Simple.BuildPaths-import System.Directory-import System.FilePath---- Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren,--- Bjorn Bringert, Krasimir Angelov,--- Malcolm Wallace, Ross Patterson, Ian Lynagh,--- Duncan Coutts, Thomas Schilling,--- Johan Tibell, Mikhail Glushenkov--- All rights reserved.---- Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:---- * Redistributions of source code must retain the above copyright--- notice, this list of conditions and the following disclaimer.---- * Redistributions in binary form must reproduce the above--- copyright notice, this list of conditions and the following--- disclaimer in the documentation and/or other materials provided--- with the distribution.---- * Neither the name of Isaac Jones nor the names of other--- contributors may be used to endorse or promote products derived--- from this software without specific prior written permission.---- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS--- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT--- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR--- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT--- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,--- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT--- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,--- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY--- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT--- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE--- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--guessToolFromGhcPath :: FilePath -- ^ Tool name- -> FilePath -- ^ GHC exe path- -> IO (Maybe FilePath)-guessToolFromGhcPath toolname ghcPath- = do let- path = ghcPath- dir = takeDirectory path- versionSuffix = takeVersionSuffix (dropExeExtension path)- guessNormal = dir </> toolname <.> exeExtension'- guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)- <.> exeExtension'- guessVersioned = dir </> (toolname ++ versionSuffix)- <.> exeExtension'- guesses | null versionSuffix = [guessNormal]- | otherwise = [guessGhcVersioned,- guessVersioned,- guessNormal]- exists <- mapM doesFileExist guesses- return $ listToMaybe [ file | (file, True) <- zip guesses exists ]-- where takeVersionSuffix :: FilePath -> String- takeVersionSuffix = takeWhileEndLE isSuffixChar-- isSuffixChar :: Char -> Bool- isSuffixChar c = isDigit c || c == '.' || c == '-'-- dropExeExtension :: FilePath -> FilePath- dropExeExtension filepath =- case splitExtension filepath of- (filepath', extension) | extension == exeExtension' -> filepath'- | otherwise -> filepath---- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but--- is usually faster (as well as being easier to read).-takeWhileEndLE :: (a -> Bool) -> [a] -> [a]-takeWhileEndLE p = fst . foldr go ([], False)- where- go x (rest, done)- | not done && p x = (x:rest, False)- | otherwise = (rest, True)--exeExtension' :: FilePath-exeExtension' = Distribution.Simple.BuildPaths.exeExtension
− CabalHelper/Licenses.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE CPP #-}-module CabalHelper.Licenses (- displayDependencyLicenseList- , groupByLicense- , getDependencyInstalledPackageInfos- ) where---- Copyright (c) 2014, Jasper Van der Jeugt <m@jaspervdj.be>-----------------------------------------------------------------------------------import Control.Arrow ((***), (&&&))-import Control.Monad (forM_, unless)-import Data.List (foldl', sort)-import Data.Maybe (catMaybes)-import Data.Version (Version)-import Data.Set (Set)-import qualified Data.Set as Set-import System.Directory (getDirectoryContents)-import System.Exit (exitFailure)-import System.FilePath (takeExtension)-import System.IO (hPutStrLn, stderr)--import Distribution.InstalledPackageInfo-import Distribution.License-import Distribution.Package-import Distribution.Simple.Configure-import Distribution.Simple.LocalBuildInfo-import Distribution.Simple.PackageIndex-import Distribution.Text-import Distribution.ModuleName-------------------------------------------------------------------------------------#if CABAL_MAJOR == 1 && CABAL_MINOR > 22-type CPackageIndex a = PackageIndex (InstalledPackageInfo)-#elif CABAL_MAJOR == 1 && CABAL_MINOR >= 22-type CPackageIndex a = PackageIndex (InstalledPackageInfo_ a)-#else-type CPackageIndex a = PackageIndex-#endif--#if CABAL_MAJOR == 1 && CABAL_MINOR >= 23-type CInstalledPackageId = UnitId-lookupInstalledPackageId' :: PackageIndex a -> UnitId -> Maybe a-lookupInstalledPackageId' = lookupUnitId-#elif CABAL_MAJOR == 1 && CABAL_MINOR > 22-type CInstalledPackageId = ComponentId-lookupInstalledPackageId' = lookupComponentId-#else-type CInstalledPackageId = InstalledPackageId-lookupInstalledPackageId' = lookupInstalledPackageId-#endif--findTransitiveDependencies- :: CPackageIndex Distribution.ModuleName.ModuleName- -> Set CInstalledPackageId- -> Set CInstalledPackageId-findTransitiveDependencies pkgIdx set0 = go Set.empty (Set.toList set0)- where- go set [] = set- go set (q : queue)- | q `Set.member` set = go set queue- | otherwise =- case lookupInstalledPackageId' pkgIdx q of- Nothing ->- -- Not found can mean that the package still needs to be- -- installed (e.g. a component of the target cabal package).- -- We can ignore those.- go set queue- Just ipi ->- go (Set.insert q set) (Distribution.InstalledPackageInfo.depends ipi ++ queue)------------------------------------------------------------------------------------getDependencyInstalledPackageIds- :: LocalBuildInfo -> Set CInstalledPackageId-getDependencyInstalledPackageIds lbi =- findTransitiveDependencies (installedPkgs lbi) $- Set.fromList $ map fst $ externalPackageDeps lbi-----------------------------------------------------------------------------------getDependencyInstalledPackageInfos- :: LocalBuildInfo -> [InstalledPackageInfo]-getDependencyInstalledPackageInfos lbi = catMaybes $- map (lookupInstalledPackageId' pkgIdx) $- Set.toList (getDependencyInstalledPackageIds lbi)- where- pkgIdx = installedPkgs lbi------------------------------------------------------------------------------------groupByLicense- :: [InstalledPackageInfo]- -> [(License, [InstalledPackageInfo])]-groupByLicense = foldl'- (\assoc ipi -> insertAList (license ipi) ipi assoc) []- where- -- 'Cabal.License' doesn't have an 'Ord' instance so we need to use an- -- association list instead of 'Map'. The number of licenses probably won't- -- exceed 100 so I think we're alright.- insertAList :: Eq k => k -> v -> [(k, [v])] -> [(k, [v])]- insertAList k v [] = [(k, [v])]- insertAList k v ((k', vs) : kvs)- | k == k' = (k, v : vs) : kvs- | otherwise = (k', vs) : insertAList k v kvs------------------------------------------------------------------------------------displayDependencyLicenseList- :: [(License, [InstalledPackageInfo])]- -> [(String, [(String, Version)])]-displayDependencyLicenseList =- map (display *** map (getName &&& getVersion))- where- getName =- display . pkgName . sourcePackageId- getVersion =- pkgVersion . sourcePackageId
− CabalHelper/Log.hs
@@ -1,21 +0,0 @@-module CabalHelper.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.Types--vLog :: MonadIO m => Options -> String -> m ()-vLog Options { verbose = True } msg =- liftIO $ hPutStrLn stderr msg-vLog _ _ = return ()--logSomeError :: Options -> String -> IO (Maybe a) -> IO (Maybe a)-logSomeError opts label a = do- a `E.catch` \se@(SomeException _) -> do- vLog opts $ label ++ ": " ++ show se- return Nothing
− CabalHelper/Main.hs
@@ -1,483 +0,0 @@--- cabal-helper: Simple interface to Cabal's configuration state--- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero 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 Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE CPP, BangPatterns, RecordWildCards, RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-deprecations #-}-import Distribution.Simple.Utils (cabalVersion)-import Distribution.Simple.Configure--import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId,- packageName, packageVersion)-import Distribution.PackageDescription (PackageDescription,- GenericPackageDescription(..),- Flag(..),- FlagName(..),- FlagAssignment,- Executable(..),- Library(..),- TestSuite(..),- Benchmark(..),- BuildInfo(..),- TestSuiteInterface(..),- BenchmarkInterface(..),- withLib)-import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.PackageDescription.Configuration (flattenPackageDescription)--import Distribution.Simple.Program (requireProgram, ghcProgram)-import Distribution.Simple.Program.Types (ConfiguredProgram(..))-import Distribution.Simple.Configure (getPersistBuildConfig)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),- Component(..),- ComponentName(..),- ComponentLocalBuildInfo(..),- componentBuildInfo,- externalPackageDeps,- withComponentsLBI,- withLibLBI)-#if CABAL_MAJOR == 1 && CABAL_MINOR >= 23-import Distribution.Simple.LocalBuildInfo (localUnitId)-#elif CABAL_MAJOR == 1 && CABAL_MINOR <= 22-import Distribution.Simple.LocalBuildInfo (inplacePackageId)-#endif--import Distribution.Simple.GHC (componentGhcOptions)-import Distribution.Simple.Program.GHC (GhcOptions(..), renderGhcOptions)--import Distribution.Simple.Setup (ConfigFlags(..),Flag(..))-import Distribution.Simple.Build (initialBuildSteps)-import Distribution.Simple.BuildPaths (autogenModuleName, cppHeaderName, exeExtension)-import Distribution.Simple.Compiler (PackageDB(..), compilerId)--import Distribution.Compiler (CompilerId(..))-import Distribution.ModuleName (components)-import qualified Distribution.ModuleName as C (ModuleName)-import Distribution.Text (display)-import Distribution.Verbosity (Verbosity, silent, deafening, normal)--#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22-import Distribution.Utils.NubList-#endif--import Control.Applicative ((<$>))-import Control.Arrow (first, (&&&))-import Control.Monad-import Control.Exception (catch, PatternMatchFail(..))-import Data.List-import qualified Data.Map as Map-import Data.Maybe-import Data.Monoid-import Data.IORef-import System.Environment-import System.Directory-import System.FilePath-import System.Exit-import System.IO-import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)-import Text.Printf--import CabalHelper.Licenses-import CabalHelper.Sandbox-import CabalHelper.Common-import CabalHelper.Types hiding (Options(..))--usage = do- prog <- getProgName- hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg- where- usageMsg = ""- ++"PROJ_DIR DIST_DIR [--with-* ...] (\n"- ++" version\n"- ++" | print-lbi [--human]\n"- ++" | package-id\n"- ++" | flags\n"- ++" | config-flags\n"- ++" | non-default-config-flags\n"- ++" | write-autogen-files\n"- ++" | compiler-version\n"- ++" | ghc-options [--with-inplace]\n"- ++" | ghc-src-options [--with-inplace]\n"- ++" | 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"- ++" | licenses\n"- ++" ) ...\n"--commands :: [String]-commands = [ "print-lbi"- , "package-id"- , "flags"- , "config-flags"- , "non-default-config-flags"- , "write-autogen-files"- , "compiler-version"- , "ghc-options"- , "ghc-src-options"- , "ghc-pkg-options"- , "ghc-lang-options"- , "package-db-stack"- , "entrypoints"- , "source-dirs"- , "licenses"]--main :: IO ()-main = do- args <- getArgs-- projdir:distdir:args' <- case args of- [] -> usage >> exitFailure- _ -> return args-- ddexists <- doesDirectoryExist distdir- when (not ddexists) $ do- errMsg $ "distdir '"++distdir++"' does not exist"- exitFailure-- [cfile] <- filter isCabalFile <$> getDirectoryContents projdir-- v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment- lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir- gpd <- unsafeInterleaveIO $ readPackageDescription v (projdir </> cfile)- let pd = localPkgDescr lbi- let lvd = (lbi, v, distdir)-- let- -- a =<< b $$ c == (a =<< b) $$ c- infixr 2 $$- ($$) = ($)-- collectCmdOptions :: [String] -> [[String]]- collectCmdOptions =- reverse . map reverse . foldl f [] . dropWhile isOpt- where- isOpt = ("--" `isPrefixOf`)- f [] x = [[x]]- f (a:as) x- | isOpt x = (x:a):as- | otherwise = [x]:(a:as)-- let cmds = collectCmdOptions args'-- if any (["version"] `isPrefixOf`) cmds- then do- putStrLn $- printf "using version %s of the Cabal library" (display cabalVersion)- exitSuccess- else return ()-- print =<< flip mapM cmds $$ \cmd -> do- case cmd of- "flags":[] -> do- return $ Just $ ChResponseFlags $ sort $- map (flagName' &&& flagDefault) $ genPackageFlags gpd-- "config-flags":[] -> do- return $ Just $ ChResponseFlags $ sort $- map (first unFlagName') $ configConfigurationsFlags $ configFlags lbi-- "non-default-config-flags":[] -> do- let flagDefinitons = genPackageFlags gpd- flagAssgnments = configConfigurationsFlags $ configFlags lbi- nonDefaultFlags =- [ (fn, v)- | MkFlag {flagName=FlagName fn, flagDefault=dv} <- flagDefinitons- , (FlagName fn', v) <- flagAssgnments- , fn == fn'- , v /= dv- ]- return $ Just $ ChResponseFlags $ sort nonDefaultFlags-- "write-autogen-files":[] -> do- initialBuildStepsForAllComponents distdir pd lbi v- return Nothing-- "compiler-version":[] -> do- let CompilerId comp ver = compilerId $ compiler lbi- return $ Just $ ChResponseVersion (show comp) ver-- "ghc-options":flags -> do- res <- componentOptions lvd True flags id- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])-- "ghc-src-options":flags -> do- res <- componentOptions lvd False flags $ \opts -> mempty {- -- Not really needed but "unexpected package db stack: []"- ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB],-- ghcOptCppOptions = ghcOptCppOptions opts,- ghcOptCppIncludePath = ghcOptCppIncludePath opts,- ghcOptCppIncludes = ghcOptCppIncludes opts,- ghcOptFfiIncludes = ghcOptFfiIncludes opts,- ghcOptSourcePathClear = ghcOptSourcePathClear opts,- ghcOptSourcePath = ghcOptSourcePath opts- }- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])-- "ghc-pkg-options":flags -> do- res <- componentOptions lvd True flags $ \opts -> mempty {- ghcOptPackageDBs = ghcOptPackageDBs opts,- ghcOptPackages = ghcOptPackages opts,- ghcOptHideAllPackages = ghcOptHideAllPackages opts- }- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])-- "ghc-merged-pkg-options":flags -> do- let pd = localPkgDescr lbi- res <- mconcat . map snd <$> (componentOptions' lvd True flags (\_ _ o -> return o) $ \opts -> mempty {- ghcOptPackageDBs = [],- ghcOptHideAllPackages = NoFlag,- ghcOptPackages = ghcOptPackages opts- })-- let res' = nubPackageFlags $ res { ghcOptPackageDBs = withPackageDB lbi- , ghcOptHideAllPackages = Flag True- }-- Just . ChResponseList <$> renderGhcOptions' lbi v res'-- "ghc-lang-options":flags -> do- res <- componentOptions lvd False flags $ \opts -> mempty {- ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB],-- ghcOptLanguage = ghcOptLanguage opts,- ghcOptExtensions = ghcOptExtensions opts,- 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 ->- return $ componentEntrypoints c- -- MUST append Setup component at the end otherwise CabalHelper gets- -- confused- let eps' = eps ++ [(ChSetupHsName, ChSetupEntrypoint)]- return $ Just $ ChResponseEntrypoints eps'-- "source-dirs":[] -> do- res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi- return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])-- "licenses":[] -> do- return $ Just $ ChResponseLicenses $- displayDependencyLicenseList $ groupByLicense $ getDependencyInstalledPackageInfos lbi-- "print-lbi":flags ->- case flags of- ["--human"] -> print lbi >> return Nothing- [] -> return $ Just $ ChResponseLbi $ show lbi-- cmd:_ | not (cmd `elem` commands) ->- errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure- _ ->- errMsg "Invalid usage!" >> usage >> exitFailure--flagName' = unFlagName' . flagName-unFlagName' (FlagName n) = n--getLibrary :: PackageDescription -> Library-getLibrary pd = unsafePerformIO $ do- lr <- newIORef (error "libraryMap: empty IORef")- withLib pd (writeIORef lr)- readIORef lr--getLibraryClbi pd lbi = unsafePerformIO $ do- lr <- newIORef Nothing-- withLibLBI pd lbi $ \ lib clbi ->- writeIORef lr $ Just (lib,clbi)-- readIORef lr---componentsMap :: LocalBuildInfo- -> Verbosity- -> FilePath- -> ( Component- -> ComponentLocalBuildInfo- -> BuildInfo- -> IO a)- -> IO [(ChComponentName, a)]-componentsMap lbi v distdir f = do- let pd = localPkgDescr lbi-- lr <- newIORef []-- -- withComponentsLBI is deprecated but also exists in very old versions- -- it's equivalent to withAllComponentsInBuildOrder in newer versions- withComponentsLBI pd lbi $ \c clbi -> do- let bi = componentBuildInfo c- name = componentNameFromComponent c-- l' <- readIORef lr- r <- f c clbi bi- writeIORef lr $ (componentNameToCh name, r):l'-- reverse <$> readIORef lr--componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do- let pd = localPkgDescr lbi- componentsMap lbi v distdir $ \c clbi bi -> let- outdir = componentOutDir lbi c- (clbi', adopts) = case flags of- _ | not inplaceFlag -> (clbi, mempty)- ["--with-inplace"] -> (clbi, mempty)- [] -> removeInplaceDeps v lbi pd clbi- opts = componentGhcOptions normal lbi bi clbi' outdir- opts' = f opts-- in rf lbi v $ nubPackageFlags $ opts' `mappend` adopts--componentOptions (lbi, v, distdir) inplaceFlag flags f =- componentOptions' (lbi, v, distdir) inplaceFlag flags renderGhcOptions' f--#if CABAL_MAJOR == 1 && CABAL_MINOR < 25-componentNameToCh CLibName = ChLibName ""-#elif CABAL_MAJOR == 1 && CABAL_MINOR >= 25-componentNameToCh (CLibName n) = ChLibName n-#endif-componentNameToCh (CExeName n) = ChExeName n-componentNameToCh (CTestName n) = ChTestName n-componentNameToCh (CBenchName n) = ChBenchName n--#if CABAL_MAJOR == 1 && CABAL_MINOR < 25-componentNameFromComponent (CLib Library {}) = CLibName-#elif CABAL_MAJOR == 1 && CABAL_MINOR >= 25-componentNameFromComponent (CLib Library {..}) = CLibName libName-#endif-componentNameFromComponent (CExe Executable {..}) = CExeName exeName-componentNameFromComponent (CTest TestSuite {..}) = CTestName testName-componentNameFromComponent (CBench Benchmark {..}) = CBenchName benchmarkName--componentOutDir lbi (CLib Library {..})= buildDir lbi-componentOutDir lbi (CExe Executable {..})= exeOutDir lbi exeName-componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteExeV10 _ _, ..}) =- exeOutDir lbi testName-componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) =- exeOutDir lbi (testName ++ "Stub")-componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})=- exeOutDir lbi benchmarkName--gmModuleName :: C.ModuleName -> ChModuleName-gmModuleName = ChModuleName . intercalate "." . components--componentEntrypoints :: Component -> ChEntrypoint-componentEntrypoints (CLib Library {..})- = ChLibEntrypoint- (map gmModuleName exposedModules)- (map gmModuleName $ otherModules libBuildInfo)-componentEntrypoints (CExe Executable {..})- = ChExeEntrypoint modulePath (map gmModuleName $ otherModules buildInfo)-componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp, ..})- = ChExeEntrypoint fp (map gmModuleName $ otherModules testBuildInfo)-componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn, ..})- = ChLibEntrypoint [gmModuleName mn] (map gmModuleName $ otherModules testBuildInfo)-componentEntrypoints (CTest TestSuite {})- = ChLibEntrypoint [] []-componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ fp, ..})- = ChExeEntrypoint fp (map gmModuleName $ otherModules benchmarkBuildInfo)-componentEntrypoints (CBench Benchmark {})- = ChLibEntrypoint [] []--exeOutDir :: LocalBuildInfo -> String -> FilePath-exeOutDir lbi exeName' =- ----- Copied from Distribution/Simple/GHC.hs:buildOrReplExe- let targetDir = (buildDir lbi) </> exeName'- exeDir = targetDir </> (exeName' ++ "-tmp")- in exeDir---removeInplaceDeps :: Verbosity- -> LocalBuildInfo- -> PackageDescription- -> ComponentLocalBuildInfo- -> (ComponentLocalBuildInfo, GhcOptions)-removeInplaceDeps v lbi pd clbi = let- (ideps, deps) = partition isInplaceDep (componentPackageDeps clbi)- hasIdeps = not $ null ideps- libopts =- case getLibraryClbi pd lbi of- Just (lib, libclbi) | hasIdeps ->- let- libbi = libBuildInfo lib- liboutdir = componentOutDir lbi (CLib lib)- in- (componentGhcOptions normal lbi libbi libclbi liboutdir) {- ghcOptPackageDBs = []-#if CABAL_MAJOR == 1 && CABAL_MINOR > 22 && CABAL_MINOR < 23- , ghcOptComponentId = NoFlag-#endif-- }- _ -> mempty- clbi' = clbi { componentPackageDeps = deps }-- in (clbi', libopts)-- where- isInplaceDep :: (InstalledPackageId, PackageId) -> Bool-#if CABAL_MAJOR == 1 && CABAL_MINOR >= 23- isInplaceDep (ipid, pid) = localUnitId lbi == ipid-#elif CABAL_MAJOR == 1 && CABAL_MINOR <= 22- isInplaceDep (ipid, pid) = inplacePackageId pid == ipid--#endif---#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22--- >= 1.22 uses NubListR-nubPackageFlags opts = opts-#else-nubPackageFlags opts = opts { ghcOptPackages = nub $ ghcOptPackages opts }-#endif--renderGhcOptions' :: LocalBuildInfo- -> Verbosity- -> GhcOptions- -> IO [String]-renderGhcOptions' lbi v opts = do-#if CABAL_MAJOR == 1 && CABAL_MINOR < 20- (ghcProg, _) <- requireProgram v ghcProgram (withPrograms lbi)- let Just ghcVer = programVersion ghcProg- return $ renderGhcOptions ghcVer opts-#elif CABAL_MAJOR == 1 && CABAL_MINOR >= 20 && CABAL_MINOR < 24--- && CABAL_MINOR < 24- return $ renderGhcOptions (compiler lbi) opts-#elif CABAL_MAJOR == 1 && CABAL_MINOR >= 24--- CABAL_MAJOR == 1 && CABAL_MINOR >= 24- return $ renderGhcOptions (compiler lbi) (hostPlatform lbi) opts-#endif---#if CABAL_MAJOR == 1 && CABAL_MINOR < 25-initialBuildStepsForAllComponents distdir pd lbi v =- initialBuildSteps distdir pd lbi v-#elif CABAL_MAJOR == 1 && CABAL_MINOR >= 25-initialBuildStepsForAllComponents distdir pd lbi v =- withComponentsLBI pd lbi $ \_c clbi ->- initialBuildSteps distdir pd lbi clbi v-#endif
− CabalHelper/Sandbox.hs
@@ -1,56 +0,0 @@-module CabalHelper.Sandbox where--import Control.Applicative-import Data.Char-import Data.Maybe-import Data.List-import Data.Version-import System.FilePath-import System.Directory-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- -- ^ Cabal build platform, i.e. @buildPlatform@- -> Version- -- ^ GHC version (@cProjectVersion@ is your friend)- -> IO (Maybe FilePath)-getSandboxPkgDb d platform ghcVer = do- mConf <- T.traverse readFile =<< mightExist (d </> "cabal.sandbox.config")- return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)-- where- fixPkgDbVer dir =- case takeFileName dir == ghcSandboxPkgDbDir platform ghcVer of- True -> dir- False -> takeDirectory dir </> ghcSandboxPkgDbDir platform ghcVer--ghcSandboxPkgDbDir :: String -> Version -> String-ghcSandboxPkgDbDir platform ghcVer =- platform ++ "-ghc-" ++ showVersion ghcVer ++ "-packages.conf.d"---- | Extract the sandbox package db directory from the cabal.sandbox.config--- file. Exception is thrown if the sandbox config file is broken.-extractSandboxDbDir :: String -> Maybe FilePath-extractSandboxDbDir conf = extractValue <$> parse conf- where- key = "package-db:"- keyLen = length key-- parse = listToMaybe . filter (key `isPrefixOf`) . lines- extractValue = CabalHelper.Sandbox.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen---mightExist :: FilePath -> IO (Maybe FilePath)-mightExist f = do- exists <- doesFileExist f- return $ if exists then (Just f) else (Nothing)---- dropWhileEnd is not provided prior to base 4.5.0.0.-dropWhileEnd :: (a -> Bool) -> [a] -> [a]-dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
− CabalHelper/Types.hs
@@ -1,71 +0,0 @@--- cabal-helper: Simple interface to Cabal's configuration state--- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero 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 Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures #-}-module CabalHelper.Types where--import GHC.Generics-import Data.Version--newtype ChModuleName = ChModuleName String- deriving (Eq, Ord, Read, Show, Generic)--data ChComponentName = ChSetupHsName- | ChLibName String- | ChExeName String- | ChTestName String- | ChBenchName String- deriving (Eq, Ord, Read, Show, Generic)--data ChResponse- = ChResponseCompList [(ChComponentName, [String])]- | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)]- | ChResponseList [String]- | ChResponsePkgDbs [ChPkgDb]- | ChResponseLbi String- | ChResponseVersion String Version- | ChResponseLicenses [(String, [(String, Version)])]- | ChResponseFlags [(String, Bool)]- deriving (Eq, Ord, Read, Show, Generic)--data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but- -- @main-is@ could either be @"Setup.hs"@- -- or @"Setup.lhs"@. Since we don't know- -- where the source directory is you have- -- to find these files.- | ChLibEntrypoint { chExposedModules :: [ChModuleName]- , chOtherModules :: [ChModuleName]- }- | ChExeEntrypoint { chMainIs :: FilePath- , chOtherModules :: [ChModuleName]- } deriving (Eq, Ord, Read, Show, Generic)--data ChPkgDb = ChPkgGlobal- | ChPkgUser- | ChPkgSpecific FilePath- deriving (Eq, Ord, Read, Show, Generic)--data Options = Options {- verbose :: Bool- , ghcProgram :: FilePath- , ghcPkgProgram :: FilePath- , cabalProgram :: FilePath- , cabalVersion :: Maybe Version- , cabalPkgDb :: Maybe FilePath-}--defaultOptions :: Options-defaultOptions = Options False "ghc" "ghc-pkg" "cabal" Nothing Nothing
− CabalHelper/Wrapper.hs
@@ -1,154 +0,0 @@--- cabal-helper: Simple interface to Cabal's configuration state--- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero 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 Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.-{-# LANGUAGE RecordWildCards, FlexibleContexts #-}-module Main where--import Control.Applicative-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-import Data.String-import Data.Version-import Text.Printf-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 Distribution.System (buildPlatform)-import Distribution.Text (display)-import Distribution.Verbosity (silent, deafening)-import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.Package (packageName, packageVersion)--import Paths_cabal_helper (version)-import CabalHelper.Common-import CabalHelper.GuessGhc-import CabalHelper.Compile-import CabalHelper.Types--usage :: IO ()-usage = do- prog <- getProgName- hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg- where- usageMsg = "\-\( print-appdatadir\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\-\ PROJ_DIR DIST_DIR ( print-exe | package-id | [CABAL_HELPER_ARGS...] ) )\n"--globalArgSpec :: [OptDescr (Options -> Options)]-globalArgSpec =- [ 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)" $- reqArg "PROG" $ \p o -> o { ghcPkgProgram = p }-- , option "" ["with-cabal"] "cabal-install executable to use" $- reqArg "PROG" $ \p o -> o { cabalProgram = p }-- , option "" ["with-cabal-version"] "Cabal library version to use" $- reqArg "VERSION" $ \p o -> o { cabalVersion = Just $ parseVer p }-- , option "" ["with-cabal-pkg-db"] "package database to look for Cabal library in" $- reqArg "PKG_DB" $ \p o -> o { cabalPkgDb = Just 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- if not (same ghcProgram opts dopts) && same ghcPkgProgram opts dopts- then do- mghcPkg <- guessToolFromGhcPath "ghc-pkg" (ghcProgram opts)- return opts {- ghcPkgProgram = fromMaybe (ghcPkgProgram opts) mghcPkg- }- else return opts- where- same f o o' = f o == f o'- dopts = defaultOptions--main :: IO ()-main = handlePanic $ do- (opts', args) <- parseCommandArgs defaultOptions <$> getArgs- opts <- guessProgramPaths opts'- case args of- [] -> usage- "help":[] -> usage- "version":[] -> putStrLn $ showVersion version- "print-appdatadir":[] -> putStrLn =<< appDataDir- "print-build-platform":[] -> putStrLn $ display buildPlatform-- projdir:_distdir:"package-id":[] -> do- v <- maybe silent (const deafening) . lookup "GHC_MOD_DEBUG" <$> getEnvironment- -- 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)) (packageVersion gpd)]-- projdir:distdir:args' -> do- cfgf <- canonicalizePath (distdir </> "setup-config")- mhdr <- getCabalConfigHeader cfgf- case mhdr 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, _) -> do- case cabalVersion opts of- Just ver | hdrCabalVersion /= ver -> panic $ printf "\-\Cabal version %s was requested setup configuration was\n\-\written by version %s" (showVersion ver) (showVersion hdrCabalVersion)- _ -> do- eexe <- compileHelper opts hdrCabalVersion projdir distdir- case eexe of- Left e -> exitWith e- Right exe ->- case args' of- "print-exe":_ -> putStrLn exe- _ -> do- (_,_,_,h) <- createProcess $ proc exe args- exitWith =<< waitForProcess h- _ -> error "invalid command line"
− Distribution/Helper.hs
@@ -1,480 +0,0 @@--- ghc-mod: Making Haskell development *more* fun--- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>------ This program is free software: you can redistribute it and/or modify--- it under the terms of the GNU Affero 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 Affero General Public License for more details.------ You should have received a copy of the GNU Affero General Public License--- along with this program. If not, see <http://www.gnu.org/licenses/>.--{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric #-}--module Distribution.Helper (- Programs(..)- , defaultPrograms- , QueryEnv- , qeReadProcess- , qePrograms- , qeProjectDir- , qeDistDir- , qeCabalPkgDb- , qeCabalVer- , defaultQueryEnv-- -- * Running Queries- , Query- , runQuery-- -- * Queries against Cabal\'s on disk state-- , packageDbStack- , entrypoints- , sourceDirs- , ghcOptions- , ghcSrcOptions- , ghcPkgOptions- , ghcMergedPkgOptions- , ghcLangOptions- , pkgLicenses- , flags- , configFlags- , nonDefaultConfigFlags- , packageId- , compilerVersion-- -- * Result types- , ChModuleName(..)- , ChComponentName(..)- , ChPkgDb(..)- , ChEntrypoint(..)-- -- * General information- , buildPlatform-- -- * Stuff that cabal-install really should export- , Distribution.Helper.getSandboxPkgDb-- -- * Managing @dist/@- , prepare- , prepare'- , reconfigure- , writeAutogenFiles- , writeAutogenFiles'-- -- * $libexec related error handling- , LibexecNotFoundError(..)- , libexecNotFoundError- ) where--import Control.Applicative-import Control.Monad-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 Data.Version-import Data.Typeable-import Distribution.Simple.BuildPaths (exeExtension)-import System.Environment-import System.FilePath-import System.Directory-import System.Process-import System.IO.Unsafe-import Text.Printf-import GHC.Generics-import Prelude--import Paths_cabal_helper (getLibexecDir, version)-import CabalHelper.Types hiding (Options(..))-import CabalHelper.Sandbox---- | Paths or names of various programs we need.-data Programs = Programs {- cabalProgram :: FilePath,- ghcProgram :: FilePath,- ghcPkgProgram :: FilePath- } deriving (Eq, Ord, Show, Read, Generic, Typeable)--defaultPrograms :: Programs-defaultPrograms = Programs "cabal" "ghc" "ghc-pkg"--data QueryEnv = QueryEnv {- -- | How to start the cabal-helper process. Useful if you need to- -- capture stderr output from the helper.- qeReadProcess :: FilePath -> [String] -> String -> IO String,-- qePrograms :: Programs,-- -- | Path to project directory, i.e. the one containing the- -- @project.cabal@ file- qeProjectDir :: FilePath,-- -- | Path to the @dist/@ directory- qeDistDir :: FilePath,-- -- | Where to look for the Cabal library when linking the helper- qeCabalPkgDb :: Maybe FilePath,-- -- | If @dist/setup-config@ wasn\'t written by this version of Cabal throw- -- an error- qeCabalVer :: Maybe Version- }--defaultQueryEnv :: FilePath- -- ^ Path to project directory, i.e. the one containing the- -- @project.cabal@ file- -> FilePath- -- ^ Path to the @dist/@ directory- -> QueryEnv-defaultQueryEnv projdir distdir = QueryEnv {- qeReadProcess = readProcess- , qePrograms = defaultPrograms- , qeProjectDir = projdir- , qeDistDir = distdir- , qeCabalPkgDb = Nothing- , qeCabalVer = Nothing- }--data SomeLocalBuildInfo = SomeLocalBuildInfo {- slbiPackageDbStack :: [ChPkgDb],- slbiEntrypoints :: [(ChComponentName, ChEntrypoint)],- slbiSourceDirs :: [(ChComponentName, [String])],- slbiGhcOptions :: [(ChComponentName, [String])],- slbiGhcSrcOptions :: [(ChComponentName, [String])],- slbiGhcPkgOptions :: [(ChComponentName, [String])],- slbiGhcMergedPkgOptions :: [String],- slbiGhcLangOptions :: [(ChComponentName, [String])],- slbiPkgLicenses :: [(String, [(String, Version)])],- slbiFlags :: [(String, Bool)],- slbiConfigFlags :: [(String, Bool)],- slbiNonDefaultConfigFlags :: [(String, Bool)],- slbiCompilerVersion :: (String, Version)- } deriving (Eq, Ord, Read, Show)---- | Caches helper executable result so it doesn't have to be run more than once--- as reading in Cabal's @LocalBuildInfo@ datatype from disk is very slow but--- running all possible queries against it at once is cheap.-newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo)- (ReaderT QueryEnv m) a }- deriving (Functor, Applicative, Monad, MonadIO)--instance MonadTrans Query where- lift = Query . lift . lift--type MonadQuery m = ( MonadIO m- , MonadState (Maybe SomeLocalBuildInfo) m- , MonadReader QueryEnv m)--run :: Monad m => QueryEnv -> Maybe SomeLocalBuildInfo -> Query m a -> m a-run e s action = flip runReaderT e (flip evalStateT s (unQuery action))---- | @runQuery query distdir@. Run a 'Query'. @distdir@ is where Cabal's--- @setup-config@ file is located.-runQuery :: Monad m- => QueryEnv- -> Query m a- -> m a-runQuery qe action = run qe Nothing action--getSlbi :: MonadQuery m => m SomeLocalBuildInfo-getSlbi = do- s <- get- case s of- Nothing -> do- slbi <- getSomeConfigState- put (Just slbi)- 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)]---- | A component's @source-dirs@ field, beware as if this is empty implicit--- behaviour in GHC kicks in.-sourceDirs :: MonadIO m => Query m [(ChComponentName, [FilePath])]---- | All options cabal would pass to GHC.-ghcOptions :: MonadIO m => Query m [(ChComponentName, [String])]---- | Only search path related GHC options.-ghcSrcOptions :: MonadIO m => Query m [(ChComponentName, [String])]---- | Only package related GHC options, sufficient for things don't need to--- access any home modules.-ghcPkgOptions :: MonadIO m => Query m [(ChComponentName, [String])]---- | Like @ghcPkgOptions@ but for the whole package not just one component-ghcMergedPkgOptions :: MonadIO m => Query m [String]---- | Only language related options, i.e. @-XSomeExtension@-ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])]---- | Get the licenses of the packages the current project is linking against.-pkgLicenses :: MonadIO m => Query m [(String, [(String, Version)])]---- | Flag definitions from cabal file-flags :: MonadIO m => Query m [(String, Bool)]---- | Flag assignments from setup-config-configFlags :: MonadIO m => Query m [(String, Bool)]---- | Flag assignments from setup-config which differ from the default--- setting. This can also include flags which cabal decided to modify,--- i.e. don't rely on these being the flags set by the user directly.-nonDefaultConfigFlags :: MonadIO m => Query m [(String, Bool)]---- | The version of GHC the project is configured to use-compilerVersion :: MonadIO m => Query m (String, Version)---- | Package identifier, i.e. package name and version-packageId :: MonadIO m => Query m (String, Version)---packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi-entrypoints = Query $ slbiEntrypoints `liftM` getSlbi-sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi-ghcOptions = Query $ slbiGhcOptions `liftM` getSlbi-ghcSrcOptions = Query $ slbiGhcSrcOptions `liftM` getSlbi-ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi-ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi-ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi-pkgLicenses = Query $ slbiPkgLicenses `liftM` getSlbi-flags = Query $ slbiFlags `liftM` getSlbi-configFlags = Query $ slbiConfigFlags `liftM` getSlbi-nonDefaultConfigFlags = Query $ slbiNonDefaultConfigFlags `liftM` getSlbi-compilerVersion = Query $ slbiCompilerVersion `liftM` getSlbi-packageId = Query $ getPackageId---- | 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 ()--readHelper :: (MonadIO m, MonadQuery m) => [String] -> m [Maybe ChResponse]-readHelper args = ask >>= \qe -> liftIO $ do- out <- either error id <$> 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- 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 ++ 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)---getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo-getSomeConfigState = ask >>= \QueryEnv {..} -> do- res <- readHelper- [ "package-db-stack"- , "entrypoints"- , "source-dirs"- , "ghc-options"- , "ghc-src-options"- , "ghc-pkg-options"- , "ghc-merged-pkg-options"- , "ghc-lang-options"- , "licenses"- , "flags"- , "config-flags"- , "non-default-config-flags"- , "compiler-version"- ]- let [ Just (ChResponsePkgDbs pkgDbs),- Just (ChResponseEntrypoints eps),- Just (ChResponseCompList srcDirs),- Just (ChResponseCompList ghcOpts),- Just (ChResponseCompList ghcSrcOpts),- Just (ChResponseCompList ghcPkgOpts),- Just (ChResponseList ghcMergedPkgOpts),- Just (ChResponseCompList ghcLangOpts),- Just (ChResponseLicenses pkgLics),- Just (ChResponseFlags fls),- Just (ChResponseFlags cfls),- Just (ChResponseFlags ndcfls),- Just (ChResponseVersion comp compVer)- ] = res-- return $ SomeLocalBuildInfo- pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts pkgLics fls cfls ndcfls (comp, compVer)--prepare :: MonadIO m- => (FilePath -> [String] -> String -> IO String)- -> FilePath- -> FilePath- -> m ()-prepare readProc projdir distdir = liftIO $ do- exe <- findLibexecExe- void $ readProc exe [projdir, distdir] ""--{-# DEPRECATED prepare- "Will be replaced by prepare' in the next major release" #-}---- | Make sure the appropriate helper executable for the given project is--- installed and ready to run queries.-prepare' :: MonadIO m => QueryEnv -> m ()-prepare' qe =- liftIO $ void $ invokeHelper qe []--writeAutogenFiles :: MonadIO m- => (FilePath -> [String] -> String -> IO String)- -> FilePath- -- ^ Path to project directory, i.e. the one containing the- -- @project.cabal@ file- -> FilePath- -- ^ Path to the @dist/@ directory- -> m ()-writeAutogenFiles readProc projdir distdir = liftIO $ do- exe <- findLibexecExe- void $ readProc exe [projdir, distdir, "write-autogen-files"] ""--{-# DEPRECATED writeAutogenFiles- "Will be replaced by writeAutogenFiles' in the next major release" #-}---- | Create @cabal_macros.h@ and @Paths_\<pkg\>@ possibly other generated files--- in the usual place.-writeAutogenFiles' :: MonadIO m => QueryEnv -> m ()-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)- -> FilePath- -- ^ Cabal build platform, i.e. @buildPlatform@- -> Version- -- ^ GHC version (@cProjectVersion@ is your friend)- -> IO (Maybe FilePath)-getSandboxPkgDb readProc =- CabalHelper.Sandbox.getSandboxPkgDb $ unsafePerformIO $ buildPlatform readProc--buildPlatform :: (FilePath -> [String] -> String -> IO String) -> IO String-buildPlatform readProc = do- exe <- findLibexecExe- CabalHelper.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 <.> exeExtension'-- exists <- doesFileExist exe-- if exists- then return exe- else do- mdir <- tryFindCabalHelperTreeLibexecDir- case mdir of- Nothing ->- error $ throw $ LibexecNotFoundError exeName libexecdir- Just dir ->- return $ dir </> "dist" </> "build" </> exeName </> exeName--tryFindCabalHelperTreeLibexecDir :: IO (Maybe FilePath)-tryFindCabalHelperTreeLibexecDir = do- exe <- getExecutablePath'- dir <- case takeFileName exe of- "ghc" -> do -- we're probably in ghci; try CWD- getCurrentDirectory- _ ->- return $ (!!4) $ iterate takeDirectory exe- exists <- doesFileExist $ dir </> "cabal-helper.cabal"- return $ if exists- then Just dir- else Nothing--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 developer 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--lookupEnv' :: String -> IO (Maybe String)-lookupEnv' k = lookup k <$> getEnvironment--exeExtension' :: FilePath-exeExtension' = Distribution.Simple.BuildPaths.exeExtension
README.md view
@@ -1,29 +1,25 @@ # cabal-helper--`cabal-helper` provides a library which wraps the internal use of-anexecutable to lift the restrictions imposed by linking against versions of-GHC before `7.10`. This has the pleasant side effect of isolating the user-from having to deal with Cabal version changes manually as `cabal-helper`-can simply recompile it's helper program automatically as needed.+[](https://gitlab.com/dxld/cabal-helper/commits/master) -`cabal-helper` uses a wrapper executable to compile the actual cabal-helper-executable at runtime while linking against an arbitrary version of-Cabal. This runtime-compiled helper executable is then used to extract-various bits and peices from Cabal's on disk state (dist/setup-config)-written by it's configure command.+Cabal's little helper provides access to build information gathered by `cabal`+when configuring a project. Specifically we're interested in retrieving enough+information to bring up a compiler session, using the GHC API, which is similar+to running `cabal repl` in a project. -In addition to this the wrapper executable also supports installing any-version of Cabal from hackage in case it cannot be found in any available-package database. The wrapper installs these instances of the Cabal library-into a private package database so as to not interfere with the user's-packages.+While simple in principle this is complicated by the fact that the information+Cabal writes to disk is in an unstable format and only really accessible through+the Cabal API itself. -Furthermore the wrapper supports one special case namely reading a state-file for Cabal itself. This is needed as Cabal compiles it's Setup.hs using-itself and not using any version of Cabal installed in any package database.+Since we do not want to bind the user of a development tool which utilises this+library to a specific version of Cabal we compile the code which interfaces with+the Cabal library's API on the user's machine, at runtime, against whichever+version of Cabal was used to write the on disk information for a given project. -`cabal-helper` can compile with `Cabal >= 1.14` but requires `Cabal >= 1.16`-at runtime.+If this version of Cabal is not available on the users machine anymore, which is+fairly likely since cabal-install is usually linked statically, we have support+for compiling the Cabal library also. In this case the library is installed into+a private, isolated, package database in `$XDG_CACHE_HOME/cabal-helper` so as to+not interfere with the user's package database. ## IRC
Setup.hs view
@@ -1,6 +1,18 @@-#!/usr/bin/env runhaskell-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}++#ifndef MIN_VERSION_Cabal+#define MIN_VERSION_Cabal(x,y,z) 0+#endif++#if MIN_VERSION_Cabal(2,0,0)++-- https://github.com/haskell/cabal/pull/4501 is upstream in 2.0, yey import Distribution.Simple+main = defaultMain++#else++import Distribution.Simple import Distribution.Simple.Utils import Distribution.Simple.Setup import Distribution.Simple.Install@@ -11,18 +23,10 @@ import Distribution.Simple.Program import Distribution.PackageDescription -import qualified Data.Map as M-import Data.Map (Map)--import Control.Arrow-import Control.Applicative+import Control.Applicative -- for GHC<7.10 import Control.Monad import Data.List import Data.Maybe-import Data.Version-import Data.Monoid-import System.Process-import System.Exit import System.FilePath import System.Directory (renameFile) @@ -70,7 +74,7 @@ -> (PackageDescription -> LocalBuildInfo -> IO ()) -> IO () xInstallTarget pd lbi cf fn = do- let (extended, regular) = partition isInternal (executables pd)+ let (extended, regular) = partition isExeScopePrivate (executables pd) let pd_regular = pd { executables = regular } @@ -96,13 +100,16 @@ fn pd_regular lbi +isExeScopePrivate :: Executable -> Bool+isExeScopePrivate exe =+ fromMaybe False $ (=="private") <$> lookup "x-scope" fields where- isInternal :: Executable -> Bool- isInternal exe =- fromMaybe False $ (=="True") <$> lookup "x-internal" (customFieldsBI $ buildInfo exe)+ fields = customFieldsBI $ buildInfo exe onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription onlyExePackageDesc exes pd = emptyPackageDescription { package = package pd , executables = exes }++#endif
cabal-helper.cabal view
@@ -1,156 +1,287 @@ name: cabal-helper-version: 0.7.3.0-synopsis: Simple interface to some of Cabal's configuration state used by ghc-mod+version: 0.8.0.0+synopsis:+ Simple interface to some of Cabal's configuration state, mainly used by ghc-mod description:- @cabal-helper@ provides a library which wraps the internal use of an- executable to lift the restrictions imposed by linking against versions of- GHC before @7.10@. This has the pleasant side effect of isolating the user- from having to deal with Cabal version changes manually as @cabal-helper@- can simply recompile it's helper program automatically as needed.- .- @cabal-helper@ uses a wrapper executable to compile the actual cabal-helper- executable at runtime while linking against an arbitrary version of- Cabal. This runtime-compiled helper executable is then used to extract- various bits and peices from Cabal\'s on disk state (dist/setup-config)- written by it's configure command.+ Cabal's little helper provides access to build information gathered by+ @cabal@ when configuring a project. Specifically we're interested in+ retrieving enough information to bring up a compiler session, using the GHC+ API, which is similar to running @cabal repl@ in a project. .- In addition to this the wrapper executable also supports installing any- version of Cabal from hackage in case it cannot be found in any available- package database. The wrapper installs these instances of the Cabal library- into a private package database so as to not interfere with the user's- packages.+ While simple in principle this is complicated by the fact that the+ information Cabal writes to disk is in an unstable format and only really+ accessible through the Cabal API itself. .- Furthermore the wrapper supports one special case namely reading a state- file for Cabal itself. This is needed as Cabal compiles it's Setup.hs using- itself and not using any version of Cabal installed in any package database.+ Since we do not want to bind the user of a development tool which utilises+ this library to a specific version of Cabal we compile the code which+ interfaces with the Cabal library's API on the user's machine, at runtime,+ against whichever version of Cabal was used to write the on disk information+ for a given project. .- @cabal-helper@ can compile with @Cabal >= 1.14@ but requires @Cabal >= 1.16@- at runtime.-+ If this version of Cabal is not available on the users machine anymore,+ which is fairly likely since cabal-install is usually linked statically, we+ have support for compiling the Cabal library also. In this case the library+ is installed into a private, isolated, package database in+ @$XDG_CACHE_HOME/cabal-helper@ so as to not interfere with the user's+ package database. license: AGPL-3 license-file: LICENSE+license-files: LICENSE author: Daniel Gröber <dxld@darkboxed.org> maintainer: dxld@darkboxed.org category: Distribution build-type: Custom-cabal-version: >=1.10+cabal-version: >=1.14 extra-source-files: README.md- CabalHelper/Main.hs- CabalHelper/Licenses.hs+ src/CabalHelper/Runtime/*.hs + tests/*.hs++ tests/exelib/*.hs+ tests/exelib/*.cabal+ tests/exelib/lib/*.hs++ tests/exeintlib/*.hs+ tests/exeintlib/*.cabal+ tests/exeintlib/lib/*.hs+ tests/exeintlib/intlib/*.hs++ tests/fliblib/*.hs+ tests/fliblib/*.cabal+ tests/fliblib/lib/*.hs++ tests/bkpregex/*.cabal+ tests/bkpregex/*.hs+ tests/bkpregex/regex-example/*.hs+ tests/bkpregex/regex-indef/*.hs+ tests/bkpregex/regex-indef/*.hsig+ tests/bkpregex/regex-types/Regex/*.hs+ tests/bkpregex/str-impls/Str/*.hs+ source-repository head type: git location: https://github.com/DanielG/cabal-helper.git -Custom-Setup- Setup-Depends: base- , Cabal >= 1.14 && < 1.25- , containers- , filepath- , directory- , process- , template-haskell- , transformers+custom-setup+ setup-depends: base+ , Cabal < 2.1 && >= 2.0 || < 1.25 && >= 1.14+ , filepath < 1.5+ , directory < 1.4 +flag dev+ description: Build development components+ default: False+ manual: True+++-- [Note test dependencies] Vaious tests need access to modules used in other+-- components, unfortunately we can't use Cabal 2.0's new internal libraries for+-- this because we'd like to support ancient Cabal versions. Instead we just+-- copy 'hs-source-dirs', 'build-depends' and 'other-modules' fields as+-- appropriate.+--+-- The following awk command will copy paragraphs starting with:+-- -- Common some-name+-- to following paragraphs starting with:+-- -- Instantiate common some-name+--+-- $ gawk -i inplace -f scripts/update-cabal-common-section-instantiations.awk cabal-helper.cabal+ library- exposed-modules: Distribution.Helper- other-modules: Paths_cabal_helper- , CabalHelper.Types- , CabalHelper.Sandbox default-language: Haskell2010+ default-extensions: NondecreasingIndentation+ hs-source-dirs: lib, src+ exposed-modules: Distribution.Helper+ other-modules:+ CabalHelper.Shared.InterfaceTypes+ CabalHelper.Shared.Sandbox+ Paths_cabal_helper ghc-options: -Wall+ build-depends: base < 5 && >= 4.5- , Cabal < 1.25 && >= 1.14+ if os(windows)+ build-depends: base >= 4.7+ build-depends: Cabal < 2.1 && >= 2.0 || < 1.26 && >= 1.14 , directory < 1.4 && >= 1.1.0.2 , filepath < 1.5 && >= 1.3.0.0 , transformers < 0.6 && >= 0.3.0.0 , mtl < 2.3 && >= 2.0- , process < 1.5 && >= 1.1.0.1+ , 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 , ghc-prim +-- [Note ghc-prim]+-- Exports GHC.Generics in GHC-7.4++ executable cabal-helper-wrapper+ main-is: CabalHelper/Compiletime/Wrapper.hs+ if flag(dev)+ ghc-options: -Wall+ scope: private+ x-scope: private++ -- Common c-h-wrapper-fields -- See [Note test dependencies] default-language: Haskell2010+ default-extensions: NondecreasingIndentation other-extensions: TemplateHaskell- main-is: CabalHelper/Wrapper.hs- other-modules: Paths_cabal_helper- CabalHelper.Types- CabalHelper.Common- CabalHelper.GuessGhc- CabalHelper.Data- CabalHelper.Compile- CabalHelper.Log- CabalHelper.Sandbox- ghc-options: -Wall- x-internal: True+ hs-source-dirs: src+ other-modules:+ CabalHelper.Compiletime.Compat.Environment+ CabalHelper.Compiletime.Compat.Version+ CabalHelper.Compiletime.Compile+ CabalHelper.Compiletime.Data+ CabalHelper.Compiletime.GuessGhc+ 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-depends: base < 5 && >= 4.5- , Cabal < 1.25 && >= 1.14+ if os(windows)+ build-depends: base >= 4.7+ build-depends: Cabal < 2.1 && >= 2.0 || < 1.26 && >= 1.14 , bytestring < 0.11 && >= 0.9.2.1 , directory < 1.4 && >= 1.1.0.2+ , exceptions < 0.9 && >= 0.8.3 , filepath < 1.5 && >= 1.3.0.0- , transformers < 0.6 && >= 0.3.0.0 , mtl < 2.3 && >= 2.0- , process < 1.5 && >= 1.1.0.1+ , process < 1.7 && >= 1.1.0.1+ , template-haskell < 2.13 && >= 2.7.0.0 , temporary < 1.3 && >= 1.2.0.4+ , transformers < 0.6 && >= 0.3.0.0+ if !os(windows)+ 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-- , template-haskell , ghc-prim+ build-tools: cabal -test-suite spec- default-language: Haskell2010++test-suite compile-test type: exitcode-stdio-1.0- main-is: Spec.hs- other-modules: CabalHelper.Common- CabalHelper.Compile- CabalHelper.Data- CabalHelper.Log- CabalHelper.Sandbox- CabalHelper.Types- Distribution.Helper- Paths_cabal_helper- hs-source-dirs: tests, .+ main-is: CompileTest.hs+ hs-source-dirs: tests ghc-options: -Wall build-tools: cabal++ -- Instantiate 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.Version+ CabalHelper.Compiletime.Compile+ CabalHelper.Compiletime.Data+ CabalHelper.Compiletime.GuessGhc+ 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-depends: base < 5 && >= 4.5- , Cabal < 1.26 && >= 1.14+ if os(windows)+ build-depends: base >= 4.7+ build-depends: Cabal < 2.1 && >= 2.0 || < 1.26 && >= 1.14 , bytestring < 0.11 && >= 0.9.2.1 , directory < 1.4 && >= 1.1.0.2+ , exceptions < 0.9 && >= 0.8.3 , filepath < 1.5 && >= 1.3.0.0- , transformers < 0.6 && >= 0.3.0.0 , mtl < 2.3 && >= 2.0- , process < 1.5 && >= 1.1.0.1+ , process < 1.7 && >= 1.1.0.1+ , template-haskell < 2.13 && >= 2.7.0.0 , temporary < 1.3 && >= 1.2.0.4+ , transformers < 0.6 && >= 0.3.0.0+ if !os(windows)+ 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+ , ghc-prim+ build-tools: cabal - -- additional test deps- , extra < 1.5 && >= 1.4.10- , unix < 2.8 && >= 2.5.1.0 - , template-haskell- , ghc-prim+test-suite ghc-session+ type: exitcode-stdio-1.0+ main-is: GhcSession.hs+ hs-source-dirs: tests+ ghc-options: -Wall+ build-depends: base < 5 && >= 4.5+ , ghc < 8.3 && >= 7.4+ , ghc-paths < 0.2 && >= 0.1.0.9 , cabal-helper --- TODO: Use cabal_macros.h to replace -D flags by including it in--- CabalHelper.Data------ executable cabal-helper-main--- if flag(dev)--- buildable: True--- else--- buildable: False--- default-language: Haskell2010--- default-extensions: NondecreasingIndentation--- main-is: CabalHelper/Main.hs--- other-modules:--- ghc-options: -Wall -fno-warn-unused-imports -optP-DCABAL_MAJOR=1 -optP-DCABAL_MINOR=25 -optP-DCABAL_HELPER=1 -optP-DCABAL_HELPER_DEV=1--- build-depends: base--- , Cabal--- , containers--- , bytestring--- , filepath--- , directory------ flag dev--- description: Build development components--- default: False--- manual: True+ -- Instantiate 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.Version+ CabalHelper.Compiletime.Compile+ CabalHelper.Compiletime.Data+ CabalHelper.Compiletime.GuessGhc+ 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-depends: base < 5 && >= 4.5+ if os(windows)+ build-depends: base >= 4.7+ build-depends: Cabal < 2.1 && >= 2.0 || < 1.26 && >= 1.14+ , bytestring < 0.11 && >= 0.9.2.1+ , directory < 1.4 && >= 1.1.0.2+ , exceptions < 0.9 && >= 0.8.3+ , filepath < 1.5 && >= 1.3.0.0+ , mtl < 2.3 && >= 2.0+ , process < 1.7 && >= 1.1.0.1+ , template-haskell < 2.13 && >= 2.7.0.0+ , temporary < 1.3 && >= 1.2.0.4+ , transformers < 0.6 && >= 0.3.0.0+ if !os(windows)+ 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+ , ghc-prim+ build-tools: cabal+++executable cabal-helper-main+ default-language: Haskell2010+ default-extensions: NondecreasingIndentation+ main-is: CabalHelper/Runtime/Main.hs+ hs-source-dirs: src+ other-modules:+ CabalHelper.Shared.Common+ CabalHelper.Shared.InterfaceTypes+ CabalHelper.Shared.Sandbox++ -- GHC 7.4 ships Cabal-1.14 which we can't compile with and since cabal can't+ -- solve the component dependencies seperately in our case (because of too-old+ -- cabal-install and build-type:custom) we can't build this on GHC 7.4+ if flag(dev) && impl(ghc >= 7.6)+ buildable: True+ else+ buildable: False++ -- Common c-h-main-fields -- See [Note test dependencies]+ ghc-options: -Wall -fno-warn-unused-imports+ build-depends: base < 5 && >= 4.5+ , Cabal+ , containers+ , bytestring+ , filepath+ , directory+ , ghc-prim
+ lib/Distribution/Helper.hs view
@@ -0,0 +1,528 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2017 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds,+ GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor+ #-}++{-|+Module : Distribution.Helper+License : AGPL-3+Maintainer : dxld@darkboxed.org+Portability : POSIX+-}++module Distribution.Helper (+ -- * Running Queries+ Query+ , runQuery++ -- * Queries against Cabal\'s on disk state++ -- ** Package queries+ , packageId+ , packageDbStack+ , packageFlags+ , compilerVersion++ , ghcMergedPkgOptions++ -- ** cabal-install queries+ , configFlags+ , nonDefaultConfigFlags+++ -- ** Component queries+ , ComponentQuery+ , components++ , ghcSrcOptions+ , ghcPkgOptions+ , ghcLangOptions+ , ghcOptions+ , sourceDirs+ , entrypoints+ , needsBuildOutput++ -- * Query environment+ , QueryEnv+ , mkQueryEnv+ , qeReadProcess+ , qePrograms+ , qeProjectDir+ , qeDistDir+ , qeCabalPkgDb+ , qeCabalVer++ , Programs(..)+ , defaultPrograms+++ -- * Result types+ , ChModuleName(..)+ , ChComponentName(..)+ , ChPkgDb(..)+ , ChEntrypoint(..)+ , NeedsBuildOutput(..)++ -- * General information+ , buildPlatform++ -- * Stuff that cabal-install really should export+ , Distribution.Helper.getSandboxPkgDb++ -- * Managing @dist/@+ , prepare+ , reconfigure+ , writeAutogenFiles++ -- * $libexec related error handling+ , LibexecNotFoundError(..)+ , libexecNotFoundError++ -- * Reexports+ , module Data.Functor.Apply+ ) where++import Control.Applicative+import Control.Monad+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 Data.Version+import Data.Typeable+import Data.Functor.Apply+import Distribution.Simple.BuildPaths (exeExtension)+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 Prelude++import Paths_cabal_helper (getLibexecDir)+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,++ -- | 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+-- constructor to construct one.+data QueryEnv = QueryEnv {+ -- | Field accessor for 'QueryEnv'. Defines how to start the cabal-helper+ -- process. Useful if you need to capture stderr output from the helper.+ qeReadProcess :: FilePath -> [String] -> String -> IO String,++ -- | Field accessor for 'QueryEnv'.+ qePrograms :: Programs,++ -- | Field accessor for 'QueryEnv'. Defines path to the project directory,+ -- i.e. a directory containing a @project.cabal@ file+ qeProjectDir :: FilePath,+++ -- | Field accessor for 'QueryEnv'. Defines path to the @dist/@ directory,+ -- /builddir/ in Cabal terminology.+ qeDistDir :: FilePath,++ -- | Field accessor for 'QueryEnv'. Defines where to look for the Cabal+ -- library when linking the helper.+ qeCabalPkgDb :: Maybe FilePath,++ -- | Field accessor for 'QueryEnv'. If @dist/setup-config@ wasn\'t written+ -- by this version of Cabal an error is thrown when running the query.+ qeCabalVer :: Maybe Version+ }++-- | @mkQueryEnv projdir distdir@. Smart constructor for 'QueryEnv'.+-- Sets fields 'qeProjectDir' and 'qeDistDir' to @projdir@ and @distdir@+-- respectively and provides sensible defaults for the other fields.+mkQueryEnv :: FilePath+ -- ^ Path to the project directory, i.e. the directory containing a+ -- @project.cabal@ file+ -> FilePath+ -- ^ Path to the @dist/@ directory, called /builddir/ in Cabal+ -- terminology.+ -> QueryEnv+mkQueryEnv projdir distdir = QueryEnv {+ qeReadProcess = readProcess+ , qePrograms = defaultPrograms+ , qeProjectDir = projdir+ , qeDistDir = distdir+ , qeCabalPkgDb = Nothing+ , qeCabalVer = Nothing+ }++data SomeLocalBuildInfo = SomeLocalBuildInfo {+ slbiPackageDbStack :: [ChPkgDb],+ slbiPackageFlags :: [(String, Bool)],+ slbiCompilerVersion :: (String, Version),++ slbiGhcMergedPkgOptions :: [String],++ slbiConfigFlags :: [(String, Bool)],+ slbiNonDefaultConfigFlags :: [(String, Bool)],++ slbiGhcSrcOptions :: [(ChComponentName, [String])],+ slbiGhcPkgOptions :: [(ChComponentName, [String])],+ slbiGhcLangOptions :: [(ChComponentName, [String])],+ slbiGhcOptions :: [(ChComponentName, [String])],++ slbiSourceDirs :: [(ChComponentName, [String])],+ slbiEntrypoints :: [(ChComponentName, ChEntrypoint)],+ slbiNeedsBuildOutput :: [(ChComponentName, NeedsBuildOutput)]+ } deriving (Eq, Ord, Read, Show)++-- | A lazy, cached, query against a package's Cabal configuration. Use+-- 'runQuery' to execute it.+newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo)+ (ReaderT QueryEnv m) a }+ deriving (Functor, Applicative, Monad, MonadIO)++instance MonadTrans Query where+ lift = Query . lift . lift++type MonadQuery m = ( MonadIO m+ , MonadState (Maybe SomeLocalBuildInfo) m+ , MonadReader QueryEnv m)++-- | A 'Query' to run on all components of a package. Use 'components' to get a+-- regular 'Query'.+newtype ComponentQuery m a = ComponentQuery (Query m [(ChComponentName, a)])+ deriving (Functor)++instance (Functor m, Monad m) => Apply (ComponentQuery m) where+ ComponentQuery flab <.> ComponentQuery fla =+ ComponentQuery $ liftM2 go flab fla+ where+ go :: [(ChComponentName, a -> b)]+ -> [(ChComponentName, a)]+ -> [(ChComponentName, b)]+ go lab la =+ [ (cn, ab a)+ | (cn, ab) <- lab+ , (cn', a) <- la+ , cn == cn'+ ]++run :: Monad m => QueryEnv -> Maybe SomeLocalBuildInfo -> Query m a -> m a+run e s action = flip runReaderT e (flip evalStateT s (unQuery action))++-- | @runQuery env query@. Run a 'Query' under a given 'QueryEnv'.+runQuery :: Monad m+ => QueryEnv+ -> Query m a+ -> m a+runQuery qe action = run qe Nothing action++getSlbi :: MonadQuery m => m SomeLocalBuildInfo+getSlbi = do+ s <- get+ case s of+ Nothing -> do+ slbi <- getSomeConfigState+ put (Just slbi)+ return slbi+ Just slbi -> return slbi++-- | List of package databases to use.+packageDbStack :: MonadIO m => Query m [ChPkgDb]++-- | Like @ghcPkgOptions@ but for the whole package not just one component+ghcMergedPkgOptions :: MonadIO m => Query m [String]++-- | Flag definitions from cabal file+packageFlags :: MonadIO m => Query m [(String, Bool)]++-- | Flag assignments from setup-config+configFlags :: MonadIO m => Query m [(String, Bool)]++-- | Flag assignments from setup-config which differ from the default+-- setting. This can also include flags which cabal decided to modify,+-- i.e. don't rely on these being the flags set by the user directly.+nonDefaultConfigFlags :: MonadIO m => Query m [(String, Bool)]++-- | The version of GHC the project is configured to use+compilerVersion :: MonadIO m => Query m (String, Version)++-- | Package identifier, i.e. package name and version+packageId :: MonadIO m => Query m (String, Version)++-- | Run a ComponentQuery on all components of the package.+components :: Monad m => ComponentQuery m (ChComponentName -> b) -> Query m [b]+components (ComponentQuery sc) = map (\(cn, f) -> f cn) `liftM` sc++-- | 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 => ComponentQuery m ChEntrypoint++-- | The component has a non-default module renaming, so needs build output ().+needsBuildOutput :: MonadIO m => ComponentQuery m NeedsBuildOutput++-- | A component's @source-dirs@ field, beware since if this is empty implicit+-- behaviour in GHC kicks in.+sourceDirs :: MonadIO m => ComponentQuery m [FilePath]++-- | All options Cabal would pass to GHC.+ghcOptions :: MonadIO m => ComponentQuery m [String]++-- | Only search path related GHC options.+ghcSrcOptions :: MonadIO m => ComponentQuery m [String]++-- | Only package related GHC options, sufficient for things don't need to+-- access any home modules.+ghcPkgOptions :: MonadIO m => ComponentQuery m [String]++-- | Only language related options, i.e. @-XSomeExtension@+ghcLangOptions :: MonadIO m => ComponentQuery m [String]++packageId = Query $ getPackageId+packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi+packageFlags = Query $ slbiPackageFlags `liftM` getSlbi+compilerVersion = Query $ slbiCompilerVersion `liftM` getSlbi+ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi+configFlags = Query $ slbiConfigFlags `liftM` getSlbi+nonDefaultConfigFlags = Query $ slbiNonDefaultConfigFlags `liftM` getSlbi++ghcSrcOptions = ComponentQuery $ Query $ slbiGhcSrcOptions `liftM` getSlbi+ghcPkgOptions = ComponentQuery $ Query $ slbiGhcPkgOptions `liftM` getSlbi+ghcOptions = ComponentQuery $ Query $ slbiGhcOptions `liftM` getSlbi+ghcLangOptions = ComponentQuery $ Query $ slbiGhcLangOptions `liftM` getSlbi+sourceDirs = ComponentQuery $ Query $ slbiSourceDirs `liftM` getSlbi+entrypoints = ComponentQuery $ Query $ slbiEntrypoints `liftM` getSlbi+needsBuildOutput = ComponentQuery $ Query $ slbiNeedsBuildOutput `liftM` getSlbi++-- | 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 ()++readHelper :: (MonadIO m, MonadQuery m) => [String] -> m [Maybe ChResponse]+readHelper args = ask >>= \qe -> liftIO $ do+ out <- either error id <$> 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+ 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 ++ 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)++getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo+getSomeConfigState = ask >>= \QueryEnv {..} -> do+ res <- readHelper+ [ "package-db-stack"+ , "flags"+ , "compiler-version"++ , "ghc-merged-pkg-options"++ , "config-flags"+ , "non-default-config-flags"++ , "ghc-src-options"+ , "ghc-pkg-options"+ , "ghc-lang-options"+ , "ghc-options"++ , "source-dirs"+ , "entrypoints"+ , "needs-build-output"+ ]+ let [ Just (ChResponsePkgDbs slbiPackageDbStack),+ Just (ChResponseFlags slbiPackageFlags),+ Just (ChResponseVersion comp compVer),++ Just (ChResponseList slbiGhcMergedPkgOptions),++ Just (ChResponseFlags slbiConfigFlags),+ Just (ChResponseFlags slbiNonDefaultConfigFlags),++ Just (ChResponseCompList slbiGhcSrcOptions),+ Just (ChResponseCompList slbiGhcPkgOptions),+ Just (ChResponseCompList slbiGhcLangOptions),+ Just (ChResponseCompList slbiGhcOptions),++ Just (ChResponseCompList slbiSourceDirs),+ Just (ChResponseEntrypoints slbiEntrypoints),+ Just (ChResponseNeedsBuild slbiNeedsBuildOutput)+ ] = res+ slbiCompilerVersion = (comp, compVer)+ return $ SomeLocalBuildInfo {..}+++-- | Make sure the appropriate helper executable for the given project is+-- installed and ready to run queries.+prepare :: MonadIO m => QueryEnv -> m ()+prepare qe =+ liftIO $ void $ invokeHelper qe []++-- | Create @cabal_macros.h@ and @Paths_\<pkg\>@ possibly other generated files+-- in the usual place.+writeAutogenFiles :: MonadIO m => QueryEnv -> m ()+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)+ -> FilePath+ -- ^ 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 <- tryFindCabalHelperTreeLibexecDir+ case mdir of+ Nothing ->+ error $ throw $ LibexecNotFoundError exeName libexecdir+ Just dir ->+ return $ dir </> "dist" </> "build" </> exeName </> exeName++tryFindCabalHelperTreeLibexecDir :: IO (Maybe FilePath)+tryFindCabalHelperTreeLibexecDir = do+ exe <- getExecutablePath'+ dir <- case takeFileName exe of+ "ghc" -> do -- we're probably in ghci; try CWD+ getCurrentDirectory+ _ ->+ return $ (!!4) $ iterate takeDirectory exe+ exists <- doesFileExist $ dir </> "cabal-helper.cabal"+ return $ if exists+ then Just dir+ else Nothing++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++lookupEnv' :: String -> IO (Maybe String)+lookupEnv' k = lookup k <$> getEnvironment++exeExtension' :: FilePath+exeExtension' = Distribution.Simple.BuildPaths.exeExtension
+ src/CabalHelper/Compiletime/Compat/Environment.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE CPP #-}+module CabalHelper.Compiletime.Compat.Environment where++import qualified System.Environment+#ifndef mingw32_HOST_OS+import qualified System.Posix.Env (setEnv)+#endif++lookupEnv :: String -> IO (Maybe String)+lookupEnv var =+ do env <- System.Environment.getEnvironment+ return (lookup var env)++setEnv :: String -> String -> IO ()+#ifdef mingw32_HOST_OS+setEnv = System.Environment.setEnv+#else+setEnv k v = System.Posix.Env.setEnv k v True+#endif
+ src/CabalHelper/Compiletime/Compat/Version.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+module CabalHelper.Compiletime.Compat.Version+ ( DataVersion+ , toDataVersion+ , fromDataVersion+ , Data.Version.showVersion+ ) where++import qualified Data.Version+import qualified Distribution.Version (Version)+#if MIN_VERSION_Cabal(2,0,0)+import qualified Distribution.Version (versionNumbers, mkVersion)+#endif++type DataVersion = Data.Version.Version++toDataVersion :: Distribution.Version.Version -> Data.Version.Version+fromDataVersion :: Data.Version.Version -> Distribution.Version.Version+#if MIN_VERSION_Cabal(2,0,0)+toDataVersion v = Data.Version.Version (Distribution.Version.versionNumbers v) []+fromDataVersion (Data.Version.Version vs _) = Distribution.Version.mkVersion vs+#else+toDataVersion = id+fromDataVersion = id+#endif
+ src/CabalHelper/Compiletime/Compile.hs view
@@ -0,0 +1,691 @@+-- Copyright (C) 2015,2017 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE RecordWildCards, FlexibleContexts, NamedFieldPuns, DeriveFunctor,+GADTs #-}++{-|+Module : CabalHelper.Compiletime.Compile+Description : Runtime compilation machinery+License : AGPL-3+-}++module CabalHelper.Compiletime.Compile where++import Control.Applicative+import Control.Arrow+import Control.Exception as E+import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.IO.Class+import Data.Char+import Data.List+import Data.Maybe+import Data.String+import Data.Version+import GHC.IO.Exception (IOErrorType(OtherError))+import Text.Printf+import System.Directory+import System.FilePath+import System.Process+import System.Exit+import System.IO+import System.IO.Error+import System.IO.Temp+import Prelude++import Distribution.System (buildPlatform)+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)++data Compile+ = CompileWithCabalSource+ { compCabalSourceDir :: CabalSourceDir+ , compCabalSourceVersion :: Version+ }+ | CompileWithCabalPackage+ { compPackageDb :: Maybe PackageDbDir+ , compCabalVersion :: CabalVersion+ , compPackageDeps :: [String]+ , compProductTarget :: CompilationProductScope+ }++data CompPaths = CompPaths+ { compSrcDir :: FilePath+ , compOutDir :: FilePath+ , compExePath :: FilePath+ }++-- | The Helper executable we produce as a compilation product can either be+-- placed in a per-project location, or a per-user/global location in the user's+-- home directory. This type controls where the compilation process places the+-- executable.+data CompilationProductScope = CPSGlobal | CPSProject++compileHelper :: Options -> Version -> FilePath -> FilePath -> IO (Either ExitCode FilePath)+compileHelper opts hdrCabalVersion projdir distdir = do+ Just (prepare, comp) <- runMaybeT $ msum $+ case oCabalPkgDb opts of+ Nothing ->+ [ compileCabalSource+ , compileSandbox+ , 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++ where+ logMsg = "using helper compiled with Cabal from "++-- for relaxed deps: find (sameMajorVersionAs hdrCabalVersion) . reverse . sort++ -- | Check if this version is globally available+ compileGlobal :: MaybeT IO (IO (), Compile)+ compileGlobal = do+ ver <- MaybeT $ find (== hdrCabalVersion) <$> listCabalVersions opts+ vLog opts $ logMsg ++ "user/global package-db"+ return $ (return (), compileWithPkg Nothing ver CPSGlobal)++ -- | Check if this version is available in the project sandbox+ compileSandbox :: MaybeT IO (IO (), Compile)+ compileSandbox = do+ let ghcVer = ghcVersion opts+ mdb_path = getSandboxPkgDb projdir (display buildPlatform) =<< ghcVer+ sandbox <- PackageDbDir <$> MaybeT mdb_path+ ver <- MaybeT $ logIOError opts "compileSandbox" $+ find (== hdrCabalVersion) <$> listCabalVersions' opts (Just sandbox)+ vLog opts $ logMsg ++ "sandbox package-db"+ return $ (return (), compileWithPkg (Just sandbox) ver CPSProject)++ -- | Compile the requested Cabal version into an isolated package-db if it's+ -- not there already+ compileWithCabalInPrivatePkgDb :: IO (IO (), Compile)+ compileWithCabalInPrivatePkgDb = do+ db@(PackageDbDir db_path)+ <- getPrivateCabalPkgDb opts (CabalVersion hdrCabalVersion)+ vLog opts $ 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+ when (not db_exists) $+ void $ installCabal opts (Right hdrCabalVersion) `E.catch`+ \(SomeException _) -> errorInstallCabal hdrCabalVersion distdir++ -- | See if we're in a cabal source tree+ compileCabalSource :: MaybeT IO (IO (), Compile)+ compileCabalSource = do+ let cabalFile = projdir </> "Cabal.cabal"+ cabalSrc <- liftIO $ doesFileExist cabalFile+ let projdir' = CabalSourceDir projdir+ case cabalSrc of+ False -> mzero+ True -> do+ vLog opts $ "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"+ mzero+ "custom" -> do+ vLog opts $ "compiling helper with local Cabal source tree"+ return $ (return (), compileWithCabalSource projdir' ver)+ _ -> error $ "compileCabalSource: unknown build-type: '"++buildType++"'"++ compileWithCabalSource srcDir ver =+ CompileWithCabalSource+ { compCabalSourceDir = srcDir+ , compCabalSourceVersion = ver+ }++ compileWithPkg mdb ver target =+ CompileWithCabalPackage+ { compPackageDb = mdb+ , compCabalVersion = CabalVersion ver+ , compPackageDeps = [cabalPkgId ver]+ , compProductTarget = target+ }++ cabalPkgId v = "Cabal-" ++ showVersion v++compile :: Compile -> CompPaths -> Options -> IO (Either ExitCode FilePath)+compile comp paths@CompPaths {..} opts@Options {..} = do+ createDirectoryIfMissing True compOutDir+ createHelperSources compSrcDir++ vLog opts $ "compSrcDir: " ++ compSrcDir+ vLog opts $ "compOutDir: " ++ compOutDir+ vLog opts $ "compExePath: " ++ compExePath++ invokeGhc opts $ compGhcInvocation comp paths++compPaths :: FilePath -> FilePath -> Compile -> CompPaths+compPaths appdir distdir c =+ case c of+ CompileWithCabalPackage {compProductTarget=CPSGlobal,..} -> CompPaths {..}+ where+ compSrcDir = appdir </> exeName compCabalVersion <.> "build"+ compOutDir = compSrcDir+ compExePath = appdir </> exeName compCabalVersion++ CompileWithCabalPackage {compProductTarget=CPSProject,..} -> distdirPaths+ CompileWithCabalSource {..} -> distdirPaths+ where+ distdirPaths = CompPaths {..}+ where+ compSrcDir = distdir </> "cabal-helper"+ compOutDir = compSrcDir+ compExePath = compOutDir </> "cabal-helper"++data GhcInvocation = GhcInvocation+ { giOutDir :: FilePath+ , giOutput :: FilePath+ , giCPPOptions :: [String]+ , giPackageDBs :: [PackageDbDir]+ , giIncludeDirs :: [FilePath]+ , giHideAllPackages :: Bool+ , giPackages :: [String]+ , giWarningFlags :: [String]+ , giInputs :: [String]+ }++compGhcInvocation :: Compile -> CompPaths -> GhcInvocation+compGhcInvocation comp CompPaths {..} =+ case comp of+ CompileWithCabalSource {..} ->+ GhcInvocation+ { giIncludeDirs = [compSrcDir, unCabalSourceDir compCabalSourceDir]+ , giPackageDBs = []+ , giHideAllPackages = False+ , giPackages = []+ , giCPPOptions = cppOptions compCabalSourceVersion+ ++ [cabalVersionMacro compCabalSourceVersion]+ , ..+ }+ CompileWithCabalPackage {..} ->+ GhcInvocation+ { giIncludeDirs = [compSrcDir]+ , giPackageDBs = maybeToList compPackageDb+ , giHideAllPackages = True+ , giPackages =+ [ "base"+ , "containers"+ , "directory"+ , "filepath"+ , "process"+ , "bytestring"+ , "ghc-prim"+ ] ++ compPackageDeps+ , giCPPOptions = cppOptions (unCabalVersion compCabalVersion)+ , ..+ }+ where++ unCabalVersion (CabalVersion ver) = ver+ unCabalVersion (CabalHEAD _) = Version [10000000, 0, 0] []++ cppOptions cabalVer =+ [ "-DCABAL_HELPER=1"+ , cabalMinVersionMacro cabalVer+ ]++ giOutDir = compOutDir+ giOutput = compExePath+ giWarningFlags = [ "-w" ] -- no point in bothering end users with warnings+ giInputs = [compSrcDir</>"CabalHelper"</>"Runtime"</>"Main.hs"]++cabalVersionMacro :: Version -> String+cabalVersionMacro (Version vs _) =+ "-DCABAL_VERSION="++intercalate "," (map show vs)++cabalMinVersionMacro :: Version -> String+cabalMinVersionMacro (Version (mj1:mj2:mi:_) _) =+ "-DCH_MIN_VERSION_Cabal(major1,major2,minor)=\+ \( (major1) < "++show mj1++" \+ \|| (major1) == "++show mj1++" && (major2) < "++show mj2++" \+ \|| (major1) == "++show mj1++" && (major2) == "++show mj2++" && (minor) <= "++show 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+ ]+ , 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+++-- | Cabal library version we're compiling the helper exe against.+data CabalVersion+ = CabalHEAD { cvCommitId :: CommitId }+ | CabalVersion { cabalVersion :: Version }++newtype CommitId = CommitId { unCommitId :: String }++exeName :: CabalVersion -> String+exeName (CabalHEAD commitid) = intercalate "-"+ [ "cabal-helper" ++ showVersion version+ , "CabalHEAD" ++ unCommitId commitid+ ]+exeName CabalVersion {cabalVersion} = intercalate "-"+ [ "cabal-helper" ++ showVersion version+ , "Cabal" ++ showVersion cabalVersion+ ]++callProcessStderr'+ :: Options -> Maybe FilePath -> FilePath -> [String] -> IO ExitCode+callProcessStderr' opts mwd exe args = do+ let cd = case mwd of+ Nothing -> []; Just wd -> [ "cd", formatProcessArg wd++";" ]+ vLog opts $ 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+ case rv of+ ExitSuccess -> return ()+ ExitFailure v -> processFailedException "callProcessStderr" exe args v++processFailedException :: String -> String -> [String] -> Int -> IO a+processFailedException fn exe args rv =+ ioError $ mkIOError OtherError msg Nothing Nothing+ where+ msg = concat [ fn, ": ", exe, " "+ , intercalate " " (map formatProcessArg args)+ , " (exit " ++ show rv ++ ")"+ ]++formatProcessArg :: String -> String+formatProcessArg xs+ | any isSpace xs = "'"++ xs ++"'"+ | otherwise = xs++data HEAD = HEAD deriving (Eq, Show)++installCabal :: Options -> Either HEAD Version -> IO (PackageDbDir, CabalVersion)+installCabal opts ever = do+ appdir <- appCacheDir+ let message ver = do+ let sver = showVersion ver+ hPutStr stderr $ printf "\+\cabal-helper-wrapper: Installing a private copy of Cabal because we couldn't\n\+\find the right version in your global/user package-db, this might take a\n\+\while but will only happen once per Cabal version you're using.\n\+\\n\+\If anything goes horribly wrong just delete this directory and try again:\n\+\ %s\n\+\\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 --constraint \"Cabal == %s\"\n\+\\n\+\Installing Cabal %s ...\n" appdir sver sver sver++ withSystemTempDirectory "cabal-helper-Cabal-source" $ \tmpdir -> do+ (srcdir, cabalVer) <- case ever of+ Left HEAD -> do+ 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)++ db <- createPkgDb opts cabalVer++ runCabalInstall opts db srcdir ever++ return (db, cabalVer)++{-+TODO: If the Cabal version we want to install is less than or equal to one we+have available, either through act-as-setup or in a package-db we should be able+to use act-as-setup or build a default Setup.hs exe and patch the Cabal source+to say build-type:simple. This will sidestep bugs in c-i>=1.24++See conversation in+https://github.com/haskell/cabal/commit/e2bf243300957321497353a2f85517e464f764ab++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+ cabal_opts <- return $ concat+ [+ [ "--package-db=clear"+ , "--package-db=global"+ , "--package-db=" ++ db+ , "--prefix=" ++ db </> "prefix"+ ]+ , withGHCProgramOptions opts+ , if cabalInstallVer >= Version [1,20,0,0] []+ then ["--no-require-sandbox"]+ else []+ , [ "install", srcdir ]+ , if oVerbose opts+ then ["-v"]+ else []+ , [ "--only-dependencies" ]+ ]++ callProcessStderr opts (Just "/") (oCabalProgram opts) cabal_opts++ runSetupHs opts 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 ]+ else []+ ]++runSetupHs+ :: Options+ -> FilePath+ -> FilePath+ -> Either HEAD Version+ -> CabalInstallVersion+ -> IO ()+runSetupHs opts@Options {..} db srcdir ever CabalInstallVersion {..}+ | cabalInstallVer >= parseVer "1.24" = do+ go $ \args -> callProcessStderr opts (Just srcdir) oCabalProgram $+ [ "act-as-setup", "--" ] ++ args+ | otherwise = do+ SetupProgram {..} <- compileSetupHs opts db srcdir+ go $ callProcessStderr opts (Just srcdir) setupProgram+ where+ parmake_opt+ | Right ver <- ever, ver >= Version [1,20] [] = ["-j"]+ | otherwise = []++ go :: ([String] -> IO ()) -> IO ()+ go run = do+ run $ [ "configure", "--package-db", db, "--prefix", db </> "prefix" ]+ ++ withGHCProgramOptions opts+ run $ [ "build" ] ++ parmake_opt+ run [ "copy" ]+ run [ "register" ]+++++newtype SetupProgram = SetupProgram { setupProgram :: FilePath }+compileSetupHs :: Options -> FilePath -> FilePath -> IO SetupProgram+compileSetupHs opts db srcdir = do+ ver <- ghcVersion opts+ let no_version_macros+ | ver >= Version [8] [] = [ "-fno-version-macros" ]+ | otherwise = []++ file = srcdir </> "Setup"++ callProcessStderr opts (Just srcdir) (oGhcProgram opts) $ concat+ [ [ "--make"+ , "-package-conf", db+ ]+ , no_version_macros+ , [ file <.> "hs"+ , "-o", file+ ]+ ]+ return $ SetupProgram file++data CabalPatchDescription = CabalPatchDescription {+ cpdVersions :: [Version],+ cpdUnpackVariant :: UnpackCabalVariant,+ cpdPatchFn :: FilePath -> IO ()+ }+nopCabalPatchDescription :: CabalPatchDescription+nopCabalPatchDescription = CabalPatchDescription [] LatestRevision (const (return ()))++patchyCabalVersions :: [CabalPatchDescription]+patchyCabalVersions = [+ let versions = [ Version [1,18,1] [] ]+ variant = Pristine+ patch = fixArrayConstraint+ in CabalPatchDescription versions variant patch,++ let versions = [ Version [1,18,0] [] ]+ variant = Pristine+ patch dir = do+ fixArrayConstraint dir+ fixOrphanInstance dir+ in CabalPatchDescription versions variant patch,++ let versions = [ Version [1,24,1,0] [] ]+ variant = Pristine+ patch _ = return ()+ in CabalPatchDescription versions variant patch+ ]+ where+ fixArrayConstraint dir = do+ let cabalFile = dir </> "Cabal.cabal"+ cabalFileTmp = cabalFile ++ ".tmp"++ cf <- readFile cabalFile+ writeFile cabalFileTmp $ replace "&& < 0.5" "&& < 0.6" cf+ renameFile cabalFileTmp cabalFile++ fixOrphanInstance dir = do+ let versionFile = dir </> "Distribution/Version.hs"+ versionFileTmp = versionFile ++ ".tmp"++ let languagePragma =+ "{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}"+ languagePragmaCPP =+ "{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving #-}"++ derivingDataVersion =+ "deriving instance Data Version"+ derivingDataVersionCPP = unlines [+ "#if __GLASGOW_HASKELL__ < 707",+ derivingDataVersion,+ "#endif"+ ]++ vf <- readFile versionFile+ writeFile versionFileTmp+ $ replace derivingDataVersion derivingDataVersionCPP+ $ replace languagePragma languagePragmaCPP vf++ renameFile versionFileTmp versionFile++unpackPatchedCabal+ :: Options+ -> Version+ -> FilePath+ -> CabalPatchDescription+ -> IO CabalSourceDir+unpackPatchedCabal opts cabalVer tmpdir (CabalPatchDescription _ variant patch) = do+ res@(CabalSourceDir dir) <- unpackCabal opts 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+ 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+ return $ CabalSourceDir dir++unpackCabalHEAD :: 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 "git" ["rev-parse", "HEAD"] ""+ return (CabalSourceDir $ dir </> "Cabal", CommitId commit)+ where+ withDirectory_ :: FilePath -> IO a -> IO a+ withDirectory_ dir action =+ bracket+ (liftIO getCurrentDirectory)+ (liftIO . setCurrentDirectory)+ (\_ -> liftIO (setCurrentDirectory dir) >> action)++errorInstallCabal :: Version -> FilePath -> IO a+errorInstallCabal cabalVer _distdir = panicIO $ printf "\+\Installing Cabal version %s failed.\n\+\\n\+\You have the following choices to fix this:\n\+\\n\+\- The easiest way to try and fix this is just reconfigure the project and try\n\+\ again:\n\+\ $ cabal clean && cabal configure\n\+\\n\+\- If that fails you can try to install the version of Cabal mentioned above\n\+\ into your global/user package-db somehow, you'll probably have to fix\n\+\ something otherwise it wouldn't have failed above:\n\+\ $ cabal install Cabal --constraint 'Cabal == %s'\n\+\\n\+\- If you're using `Build-Type: Simple`:\n\+\ - You can see if you can reinstall your cabal-install executable while\n\+\ 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-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\+\- If you're using `Build-Type: Custom`:\n\+\ - Have cabal-install rebuild your Setup.hs executable with a version of the\n\+\ Cabal library that you have available in your global/user package-db:\n\+\ $ cabal clean && cabal configure\n\+\ You might also have to install some version of the Cabal to do this:\n\+\ $ cabal install Cabal\n\+\\n" sver sver+ where+ sver = showVersion cabalVer++listCabalVersions :: Options -> IO [Version]+listCabalVersions opts = listCabalVersions' opts Nothing++-- TODO: Include sandbox? Probably only relevant for build-type:custom projects.+listCabalVersions' :: Options -> Maybe PackageDbDir -> IO [Version]+listCabalVersions' Options {..} mdb = do+ let mdbopt = ("--package-conf="++) <$> unPackageDbDir <$> mdb+ opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt++ catMaybes . map (fmap snd . parsePkgId . fromString) . words+ <$> readProcess oGhcPkgProgram opts ""++cabalVersionExistsInPkgDb :: Options -> Version -> PackageDbDir -> IO Bool+cabalVersionExistsInPkgDb opts cabalVer db@(PackageDbDir db_path) = do+ exists <- doesDirectoryExist db_path+ case exists of+ False -> return False+ True -> do+ vers <- listCabalVersions' opts (Just db)+ return $ cabalVer `elem` vers++ghcVersion :: Options -> IO Version+ghcVersion Options {..} = do+ parseVer . trim <$> readProcess oGhcProgram ["--numeric-version"] ""++ghcPkgVersion :: Options -> IO Version+ghcPkgVersion Options {..} = do+ parseVer . trim . dropWhile (not . isDigit) <$> readProcess oGhcPkgProgram ["--version"] ""++newtype CabalInstallVersion = CabalInstallVersion { cabalInstallVer :: Version }+cabalInstallVersion :: Options -> IO CabalInstallVersion+cabalInstallVersion Options {..} = do+ CabalInstallVersion . parseVer . trim+ <$> readProcess oCabalProgram ["--numeric-version"] ""++createPkgDb :: Options -> CabalVersion -> IO PackageDbDir+createPkgDb opts@Options {..} cabalVer = do+ db@(PackageDbDir db_path) <- getPrivateCabalPkgDb opts cabalVer+ exists <- doesDirectoryExist db_path+ when (not exists) $ callProcessStderr opts Nothing oGhcPkgProgram ["init", db_path]+ return db++getPrivateCabalPkgDb :: Options -> CabalVersion -> IO PackageDbDir+getPrivateCabalPkgDb opts cabalVer = do+ appdir <- appCacheDir+ ghcVer <- ghcVersion opts+ let db_path = appdir </> exeName cabalVer+ ++ "-ghc" ++ showVersion ghcVer+ ++ ".package-db"+ return $ PackageDbDir db_path++-- "Cabal" ++ ver ++ "-ghc" ++ showVersion ghcVer++-- | Find @version: XXX@ delcaration in a cabal file+cabalFileVersion :: String -> Version+cabalFileVersion = parseVer . cabalFileTopField "version"++-- | Find @build-type: XXX@ delcaration in a cabal file+cabalFileBuildType :: String -> String+cabalFileBuildType = cabalFileTopField "build-type"++cabalFileTopField :: String -> String -> String+cabalFileTopField field cabalFile = value+ where+ Just value = extract <$> find ((field++":") `isPrefixOf`) ls+ ls = map (map toLower) $ lines cabalFile+ extract = dropWhile (/=':') >>> drop 1 >>> dropWhile isSpace >>> takeWhile (not . isSpace)
+ src/CabalHelper/Compiletime/Data.hs view
@@ -0,0 +1,80 @@+-- Copyright (C) 2015,2017 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# OPTIONS_GHC -fforce-recomp #-}++{-|+Module : CabalHelper.Compiletime.Data+Description : Embeds source code for runtime component using TH+License : AGPL-3+-}++module CabalHelper.Compiletime.Data where++import Control.Monad+import Control.Monad.IO.Class+import Data.Functor+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as UTF8+import Language.Haskell.TH+import System.Directory+import System.FilePath+import System.IO.Temp+import System.PosixCompat.Files+import System.PosixCompat.Time+import System.PosixCompat.Types+import Prelude++import CabalHelper.Compiletime.Compat.Environment++withSystemTempDirectoryEnv :: String -> (FilePath -> IO b) -> IO b+withSystemTempDirectoryEnv tpl f = do+ m <- liftIO $ lookupEnv "CABAL_HELPER_KEEP_SOURCEDIR"+ case m of+ Nothing -> withSystemTempDirectory tpl f+ Just _ -> do+ tmpdir <- getCanonicalTemporaryDirectory+ f =<< createTempDirectory tmpdir tpl++createHelperSources :: FilePath -> IO ()+createHelperSources dir = do+ let chdir = dir </> "CabalHelper"+ liftIO $ do+ createDirectoryIfMissing True $ chdir </> "Runtime"+ createDirectoryIfMissing True $ chdir </> "Shared"++ let modtime :: EpochTime+ modtime = fromIntegral $ (read :: String -> Integer)+ -- See https://reproducible-builds.org/specs/source-date-epoch/+ $(runIO $ do+ msde :: Maybe Integer+ <- fmap read <$> lookupEnv "SOURCE_DATE_EPOCH"+ (current_time :: Integer) <- round . toRational <$> epochTime+ return $ LitE . StringL $ show $ maybe current_time id msde)++ liftIO $ forM_ sourceFiles $ \(fn, src) -> do+ let path = chdir </> fn+ BS.writeFile path $ UTF8.fromString src+ setFileTimes path modtime modtime+++sourceFiles :: [(FilePath, String)]+sourceFiles =+ [ ("Runtime/Main.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "src/CabalHelper/Runtime/Main.hs")))+ , ("Shared/Common.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "src/CabalHelper/Shared/Common.hs")))+ , ("Shared/Sandbox.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "src/CabalHelper/Shared/Sandbox.hs")))+ , ("Shared/InterfaceTypes.hs", $(LitE . StringL <$> runIO (UTF8.toString <$> BS.readFile "src/CabalHelper/Shared/InterfaceTypes.hs")))+ ]
+ src/CabalHelper/Compiletime/GuessGhc.hs view
@@ -0,0 +1,92 @@+-- Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren,+-- Bjorn Bringert, Krasimir Angelov,+-- Malcolm Wallace, Ross Patterson, Ian Lynagh,+-- Duncan Coutts, Thomas Schilling,+-- Johan Tibell, Mikhail Glushenkov+-- All rights reserved.++-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:++-- * Redistributions of source code must retain the above copyright+-- notice, this list of conditions and the following disclaimer.++-- * Redistributions in binary form must reproduce the above+-- copyright notice, this list of conditions and the following+-- disclaimer in the documentation and/or other materials provided+-- with the distribution.++-- * Neither the name of Isaac Jones nor the names of other+-- contributors may be used to endorse or promote products derived+-- from this software without specific prior written permission.++-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++{-|+Module : CabalHelper.Compiletime.GuessGhc+Description : Logic for finding @ghc-pkg@ based on path to @ghc@+License : BSD3+-}++module CabalHelper.Compiletime.GuessGhc (guessToolFromGhcPath) where++import Data.Maybe+import Data.Char+import Distribution.Simple.BuildPaths+import System.Directory+import System.FilePath++guessToolFromGhcPath :: FilePath -- ^ Tool name+ -> FilePath -- ^ GHC exe path+ -> IO (Maybe FilePath)+guessToolFromGhcPath toolname ghcPath+ = do let+ path = ghcPath+ dir = takeDirectory path+ versionSuffix = takeVersionSuffix (dropExeExtension path)+ guessNormal = dir </> toolname <.> exeExtension'+ guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)+ <.> exeExtension'+ guessVersioned = dir </> (toolname ++ versionSuffix)+ <.> exeExtension'+ guesses | null versionSuffix = [guessNormal]+ | otherwise = [guessGhcVersioned,+ guessVersioned,+ guessNormal]+ exists <- mapM doesFileExist guesses+ return $ listToMaybe [ file | (file, True) <- zip guesses exists ]++ where takeVersionSuffix :: FilePath -> String+ takeVersionSuffix = takeWhileEndLE isSuffixChar++ isSuffixChar :: Char -> Bool+ isSuffixChar c = isDigit c || c == '.' || c == '-'++ dropExeExtension :: FilePath -> FilePath+ dropExeExtension filepath =+ case splitExtension filepath of+ (filepath', extension) | extension == exeExtension' -> filepath'+ | otherwise -> filepath++-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but+-- is usually faster (as well as being easier to read).+takeWhileEndLE :: (a -> Bool) -> [a] -> [a]+takeWhileEndLE p = fst . foldr go ([], False)+ where+ go x (rest, done)+ | not done && p x = (x:rest, False)+ | otherwise = (rest, True)++exeExtension' :: FilePath+exeExtension' = Distribution.Simple.BuildPaths.exeExtension
+ src/CabalHelper/Compiletime/Log.hs view
@@ -0,0 +1,44 @@+-- Copyright (C) 2017 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero 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 : AGPL-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
+ src/CabalHelper/Compiletime/Types.hs view
@@ -0,0 +1,40 @@+-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures #-}++{-|+Module : CabalHelper.Compiletime.Types+Description : Types used throughout+License : AGPL-3+-}++module CabalHelper.Compiletime.Types where++import Data.Version++data Options = Options {+ oVerbose :: Bool+ , oGhcProgram :: FilePath+ , oGhcPkgProgram :: FilePath+ , oCabalProgram :: FilePath+ , oCabalVersion :: Maybe Version+ , oCabalPkgDb :: Maybe PackageDbDir+}++newtype PackageDbDir = PackageDbDir { unPackageDbDir :: FilePath }++defaultOptions :: Options+defaultOptions = Options False "ghc" "ghc-pkg" "cabal" Nothing Nothing
+ src/CabalHelper/Compiletime/Wrapper.hs view
@@ -0,0 +1,164 @@+-- cabal-helper: Simple interface to Cabal's configuration state+-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE RecordWildCards, FlexibleContexts #-}+module Main where++import Control.Applicative+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Data.String+import Text.Printf+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 Distribution.System (buildPlatform)+import Distribution.Text (display)+import Distribution.Verbosity (silent, deafening)+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Package (packageName, packageVersion)++import Paths_cabal_helper (version)+import CabalHelper.Compiletime.Compat.Version+import CabalHelper.Compiletime.Compile+import CabalHelper.Compiletime.GuessGhc+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\+\ PROJ_DIR DIST_DIR ( print-exe | package-id | [CABAL_HELPER_ARGS...] ) )\n"++globalArgSpec :: [OptDescr (Options -> Options)]+globalArgSpec =+ [ 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+ if not (same oGhcProgram opts dopts) && same oGhcPkgProgram opts dopts+ then do+ mghcPkg <- guessToolFromGhcPath "ghc-pkg" (oGhcProgram opts)+ return opts {+ oGhcPkgProgram = fromMaybe (oGhcPkgProgram opts) mghcPkg+ }+ else return opts+ 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+ [] -> 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)]++ projdir:distdir:args' -> do+ cfgf <- canonicalizePath (distdir </> "setup-config")+ mhdr <- getCabalConfigHeader cfgf+ case mhdr 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, _) -> do+ case oCabalVersion opts of+ Just ver | hdrCabalVersion /= ver -> panic $ printf "\+\Cabal version %s was requested but setup configuration was\n\+\written by version %s" (showVersion ver) (showVersion hdrCabalVersion)+ _ -> do+ eexe <- compileHelper opts hdrCabalVersion projdir distdir+ case eexe of+ Left e -> exitWith e+ Right exe ->+ case args' of+ "print-exe":_ -> putStrLn exe+ _ -> do+ (_,_,_,h) <- createProcess $ proc exe args+ exitWith =<< waitForProcess h+ _ -> error "invalid command line"
+ src/CabalHelper/Runtime/Main.hs view
@@ -0,0 +1,828 @@+-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, BangPatterns, RecordWildCards, RankNTypes, ViewPatterns #-}++#ifdef MIN_VERSION_Cabal+#undef CH_MIN_VERSION_Cabal+#define CH_MIN_VERSION_Cabal MIN_VERSION_Cabal+#endif++import Distribution.Simple.Utils (cabalVersion)+import Distribution.Simple.Configure+import Distribution.Package+ ( PackageIdentifier+ , InstalledPackageId+ , PackageId+ , packageName+ , packageVersion+ )+import Distribution.PackageDescription+ ( PackageDescription+ , GenericPackageDescription(..)+ , Flag(..)+ , FlagName(..)+ , FlagAssignment+ , Executable(..)+ , Library(..)+ , TestSuite(..)+ , Benchmark(..)+ , BuildInfo(..)+ , TestSuiteInterface(..)+ , BenchmarkInterface(..)+ , withLib+ )+import Distribution.PackageDescription.Parse+ ( readPackageDescription+ )+import Distribution.PackageDescription.Configuration+ ( flattenPackageDescription+ )+import Distribution.Simple.Program+ ( requireProgram+ , ghcProgram+ )+import Distribution.Simple.Program.Types+ ( ConfiguredProgram(..)+ )+import Distribution.Simple.Configure+ ( getPersistBuildConfig+ )+import Distribution.Simple.LocalBuildInfo+ ( LocalBuildInfo(..)+ , Component(..)+ , ComponentName(..)+ , ComponentLocalBuildInfo(..)+ , componentBuildInfo+ , externalPackageDeps+ , withComponentsLBI+ , withLibLBI+ , withExeLBI+ )+import Distribution.Simple.GHC+ ( componentGhcOptions+ )+import Distribution.Simple.Program.GHC+ ( GhcOptions(..)+ , renderGhcOptions+ )+import Distribution.Simple.Setup+ ( ConfigFlags(..)+ , Flag(..)+ , fromFlagOrDefault+ )+import Distribution.Simple.Build+ ( initialBuildSteps+ )+import Distribution.Simple.BuildPaths+ ( autogenModuleName+ , cppHeaderName+ , exeExtension+ )+import Distribution.Simple.Compiler+ ( PackageDB(..)+ , compilerId+ )+import Distribution.Compiler+ ( CompilerId(..)+ )+import Distribution.ModuleName+ ( components+ )+import qualified Distribution.ModuleName as C+ ( ModuleName+ )+import Distribution.Text+ ( display+ )+import Distribution.Verbosity+ ( Verbosity+ , silent+ , deafening+ , normal+ )+import Distribution.Version+ ( Version+ )++#if CH_MIN_VERSION_Cabal(1,22,0)+-- CPP >= 1.22+import Distribution.Utils.NubList+#endif++#if CH_MIN_VERSION_Cabal(1,23,0)+-- >= 1.23+import Distribution.Simple.LocalBuildInfo+ ( localUnitId+ )+#else+-- <= 1.22+import Distribution.Simple.LocalBuildInfo+ ( inplacePackageId+ )+#endif++#if CH_MIN_VERSION_Cabal(1,25,0)+-- >=1.25+import Distribution.PackageDescription+ ( unFlagName+ -- , mkFlagName+ )+import Distribution.Types.ForeignLib+ ( ForeignLib(..)+ )+import Distribution.Types.UnqualComponentName+ ( unUnqualComponentName+ )+#endif++#if CH_MIN_VERSION_Cabal(2,0,0)+-- CPP >= 2.0+import Distribution.Simple.LocalBuildInfo+ ( allLibModules+ , componentBuildDir+ )+import Distribution.Simple.Register+ ( internalPackageDBPath+ )+import Distribution.Backpack+ ( OpenUnitId(..),+ OpenModule(..)+ )+import Distribution.ModuleName+ ( ModuleName+ )+import Distribution.Types.ComponentId+ ( unComponentId+ )+import Distribution.Types.ComponentLocalBuildInfo+ ( maybeComponentInstantiatedWith+ )+import Distribution.Types.ModuleRenaming+ ( ModuleRenaming(..),+ isDefaultRenaming+ )+import Distribution.Types.MungedPackageId+ ( MungedPackageId+ )+import Distribution.Types.UnitId+ ( UnitId+ , unDefUnitId+ , unUnitId+ )+import Distribution.Types.UnitId+ ( DefUnitId+ )+import Distribution.Utils.NubList+ ( toNubListR+ )+import Distribution.Version+ ( versionNumbers+ , mkVersion+ )+import qualified Distribution.InstalledPackageInfo as Installed+#endif++import Control.Applicative ((<$>))+import Control.Arrow (first, second, (&&&))+import Control.Monad+import Control.Exception (catch, PatternMatchFail(..))+import Data.List+import qualified Data.Map as Map+import Data.Maybe+import Data.Monoid+import Data.IORef+import qualified Data.Version as DataVersion+import System.Environment+import System.Directory+import System.FilePath+import System.Exit+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)+import Text.Printf++import CabalHelper.Shared.Sandbox+import CabalHelper.Shared.Common+import CabalHelper.Shared.InterfaceTypes++usage :: IO ()+usage = do+ prog <- getProgName+ hPutStr stderr $ "Usage: " ++ prog ++ " " ++ usageMsg+ where+ usageMsg = ""+ ++"PROJ_DIR DIST_DIR [--with-* ...] (\n"+ ++" version\n"+ ++" | print-lbi [--human]\n"+ ++" | package-id\n"+ ++" | flags\n"+ ++" | config-flags\n"+ ++" | non-default-config-flags\n"+ ++" | write-autogen-files\n"+ ++" | compiler-version\n"+ ++" | ghc-options [--with-inplace]\n"+ ++" | ghc-src-options [--with-inplace]\n"+ ++" | 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"+ ++" | needs-build-output\n"+ ++" | source-dirs\n"+ ++" ) ...\n"++commands :: [String]+commands = [ "print-lbi"+ , "package-id"+ , "flags"+ , "config-flags"+ , "non-default-config-flags"+ , "write-autogen-files"+ , "compiler-version"+ , "ghc-options"+ , "ghc-src-options"+ , "ghc-pkg-options"+ , "ghc-lang-options"+ , "package-db-stack"+ , "entrypoints"+ , "needs-build-output"+ , "source-dirs"+ ]++main :: IO ()+main = do+ args <- getArgs++ projdir:distdir:args' <- case args of+ [] -> usage >> exitFailure+ _ -> return args++ ddexists <- doesDirectoryExist distdir+ when (not ddexists) $ do+ errMsg $ "distdir '"++distdir++"' does not exist"+ exitFailure++ [cfile] <- filter isCabalFile <$> getDirectoryContents projdir++ v <- maybe silent (const deafening) . lookup "CABAL_HELPER_DEBUG" <$> getEnvironment+ lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir+ gpd <- unsafeInterleaveIO $ readPackageDescription v (projdir </> cfile)+ let pd = localPkgDescr lbi+ let lvd = (lbi, v, distdir)++ let+ -- a =<< b $$ c == (a =<< b) $$ c+ infixr 2 $$+ ($$) = ($)++ collectCmdOptions :: [String] -> [[String]]+ collectCmdOptions =+ reverse . map reverse . foldl f [] . dropWhile isOpt+ where+ isOpt = ("--" `isPrefixOf`)+ f [] x = [[x]]+ f (a:as) x+ | isOpt x = (x:a):as+ | otherwise = [x]:(a:as)++ let cmds = collectCmdOptions args'++ if any (["version"] `isPrefixOf`) cmds+ then do+ putStrLn $+ printf "using version %s of the Cabal library" (display cabalVersion)+ exitSuccess+ else return ()++ print =<< flip mapM cmds $$ \x -> do+ case x of+ "flags":[] -> do+ return $ Just $ ChResponseFlags $ sort $+ map (flagName' &&& flagDefault) $ genPackageFlags gpd++ "config-flags":[] -> do+ return $ Just $ ChResponseFlags $ sort $+ map (first unFlagName) $ configConfigurationsFlags $ configFlags lbi++ "non-default-config-flags":[] -> do+ let flagDefinitons = genPackageFlags gpd+ flagAssgnments = configConfigurationsFlags $ configFlags lbi+ nonDefaultFlags =+ [ (flag_name, val)+ | MkFlag {flagName=(unFlagName -> flag_name'), flagDefault=def_val} <- flagDefinitons+ , (unFlagName -> flag_name, val) <- flagAssgnments+ , flag_name == flag_name'+ , val /= def_val+ ]+ return $ Just $ ChResponseFlags $ sort nonDefaultFlags++ "write-autogen-files":[] -> do+ initialBuildStepsForAllComponents distdir pd lbi v+ return Nothing++ "compiler-version":[] -> do+ let CompilerId comp ver = compilerId $ compiler lbi+ return $ Just $ ChResponseVersion (show comp) (toDataVersion ver)++ "ghc-options":flags -> do+ res <- componentOptions lvd True flags id+ return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])++ "ghc-src-options":flags -> do+ res <- componentOptions lvd False flags $ \opts -> mempty {+ -- Not really needed but "unexpected package db stack: []"+ ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB],++ ghcOptCppOptions = ghcOptCppOptions opts,+ ghcOptCppIncludePath = ghcOptCppIncludePath opts,+ ghcOptCppIncludes = ghcOptCppIncludes opts,+ ghcOptFfiIncludes = ghcOptFfiIncludes opts,+ ghcOptSourcePathClear = ghcOptSourcePathClear opts,+ ghcOptSourcePath = ghcOptSourcePath opts+ }+ return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])++ "ghc-pkg-options":flags -> do+ res <- componentOptions lvd True flags $ \opts -> mempty {+ ghcOptPackageDBs = ghcOptPackageDBs opts,+ ghcOptPackages = ghcOptPackages opts,+ ghcOptHideAllPackages = ghcOptHideAllPackages opts+ }+ return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])++ "ghc-merged-pkg-options":flags -> do+ res <- mconcat . map snd <$> (componentOptions' lvd True flags (\_ _ o -> return o) $ \opts -> mempty {+ ghcOptPackageDBs = [],+ ghcOptHideAllPackages = NoFlag,+ ghcOptPackages = ghcOptPackages opts+ })++ let res' = nubPackageFlags $ res { ghcOptPackageDBs = withPackageDB lbi+ , ghcOptHideAllPackages = Flag True+ }++ Just . ChResponseList <$> renderGhcOptions' lbi v res'++ "ghc-lang-options":flags -> do+ res <- componentOptions lvd False flags $ \opts -> mempty {+ ghcOptPackageDBs = [GlobalPackageDB, UserPackageDB],++ ghcOptLanguage = ghcOptLanguage opts,+ ghcOptExtensions = ghcOptExtensions opts,+ 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+#if CH_MIN_VERSION_Cabal(2,0,0)+ includeDirMap <- recursiveDepInfo lbi v distdir+ eps <- componentsMap lbi v distdir $ \c clbi _bi -> do+ case needsBuildOutput includeDirMap (componentUnitId clbi) of+ ProduceBuildOutput -> return $ componentEntrypoints c+ NoBuildOutput -> return seps+ where (_,_,seps) = recursiveIncludeDirs includeDirMap (componentUnitId clbi)+#else+ eps <- componentsMap lbi v distdir $ \c _clbi _bi ->+ return $ componentEntrypoints c+#endif+ -- MUST append Setup component at the end otherwise CabalHelper gets+ -- confused+ let eps' = eps ++ [(ChSetupHsName, ChSetupEntrypoint)]+ return $ Just $ ChResponseEntrypoints eps'++ "needs-build-output":[] -> do+#if CH_MIN_VERSION_Cabal(2,0,0)+ includeDirMap <- recursiveDepInfo lbi v distdir+ nbs <- componentsMap lbi v distdir $ \c clbi _bi ->+ return $ needsBuildOutput includeDirMap (componentUnitId clbi)+#else+ nbs <- componentsMap lbi v distdir $ \c _clbi _bi ->+ return $ NoBuildOutput+#endif+ return $ Just $ ChResponseNeedsBuild nbs++ "source-dirs":[] -> do+ res <- componentsMap lbi v distdir $$ \_ _ bi -> return $ hsSourceDirs bi+ return $ Just $ ChResponseCompList (res ++ [(ChSetupHsName, [])])++ "print-lbi":flags ->+ case flags of+ ["--human"] -> print lbi >> return Nothing+ [] -> return $ Just $ ChResponseLbi $ show lbi++ cmd:_ | not (cmd `elem` commands) ->+ errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure+ _ ->+ errMsg "Invalid usage!" >> usage >> exitFailure++flagName' = unFlagName . flagName++-- getLibrary :: PackageDescription -> Library+-- getLibrary pd = unsafePerformIO $ do+-- lr <- newIORef (error "libraryMap: empty IORef")+-- withLib pd (writeIORef lr)+-- readIORef lr++getLibraryClbi pd lbi = unsafePerformIO $ do+ lr <- newIORef Nothing++ withLibLBI pd lbi $ \ lib clbi ->+ writeIORef lr $ Just (lib,clbi)++ readIORef lr+++getExeClbi pd lbi = unsafePerformIO $ do+ lr <- newIORef Nothing++ withExeLBI pd lbi $ \ exe clbi ->+ writeIORef lr $ Just (exe,clbi)++ readIORef lr+++componentsMap :: LocalBuildInfo+ -> Verbosity+ -> FilePath+ -> ( Component+ -> ComponentLocalBuildInfo+ -> BuildInfo+ -> IO a)+ -> IO [(ChComponentName, a)]+componentsMap lbi _v _distdir f = do+ let pd = localPkgDescr lbi++ lr <- newIORef []++ -- withComponentsLBI is deprecated but also exists in very old versions+ -- it's equivalent to withAllComponentsInBuildOrder in newer versions+ withComponentsLBI pd lbi $ \c clbi -> do+ let bi = componentBuildInfo c+ name = componentNameFromComponent c++ l' <- readIORef lr+ r <- f c clbi bi+#if CH_MIN_VERSION_Cabal(2,0,0)+ writeIORef lr $ (componentNameToCh (unUnitId $ componentUnitId clbi) name, r):l'+#else+ writeIORef lr $ (componentNameToCh "" name, r):l'+#endif++ reverse <$> readIORef lr++componentOptions' (lbi, v, distdir) inplaceFlag flags rf f = do+ let pd = localPkgDescr lbi+#if CH_MIN_VERSION_Cabal(2,0,0)+ includeDirMap <- recursiveDepInfo lbi v distdir+#endif++ componentsMap lbi v distdir $ \c clbi bi ->+ let+#if CH_MIN_VERSION_Cabal(2,0,0)+ outdir = componentBuildDir lbi clbi+#else+ outdir = componentOutDir lbi c+#endif+ (clbi', adopts) = case flags of+ _ | not inplaceFlag -> (clbi, mempty)+ ["--with-inplace"] -> (clbi, mempty)+#if CH_MIN_VERSION_Cabal(2,0,0)+ [] -> removeInplaceDeps v lbi pd clbi includeDirMap+#else+ [] -> removeInplaceDeps v lbi pd clbi+#endif+ opts = componentGhcOptions normal lbi bi clbi' outdir+ opts' = f opts++ in rf lbi v $ nubPackageFlags $ opts' `mappend` adopts++componentOptions (lbi, v, distdir) inplaceFlag flags f =+ componentOptions' (lbi, v, distdir) inplaceFlag flags renderGhcOptions' f++gmModuleName :: C.ModuleName -> ChModuleName+gmModuleName = ChModuleName . intercalate "." . components++#if CH_MIN_VERSION_Cabal(2,0,0)+removeInplaceDeps :: Verbosity+ -> LocalBuildInfo+ -> PackageDescription+ -> ComponentLocalBuildInfo+ -> Map.Map UnitId SubDeps+ -> (ComponentLocalBuildInfo, GhcOptions)+removeInplaceDeps _v lbi pd clbi includeDirs = let+ removeInplace c =+ let+ (ideps, incs) = partition (isInplaceCompInc c) (componentIncludes c)+ hasIdeps' = not $ null ideps+ c' = c { componentPackageDeps = error "using deprecated field:componentPackageDeps"+ , componentInternalDeps = []+ , componentIncludes = incs }+ in (hasIdeps',c')++ needsBuild = needsBuildOutput includeDirs (componentUnitId clbi)++ cleanRecursiveOpts :: Component+ -> BuildInfo -> ComponentLocalBuildInfo -> GhcOptions+ cleanRecursiveOpts comp libbi libclbi =+ let+ liboutdir = componentOutDir lbi comp+ (_,libclbi') = removeInplace libclbi+ (extraIncludes,extraDeps',_ems) = recursiveIncludeDirs includeDirs (componentUnitId libclbi)+ (_,extraDeps) = partition (isInplaceCompInc libclbi) extraDeps'+ opts = (componentGhcOptions normal lbi libbi libclbi' liboutdir) {+ ghcOptPackageDBs = []+ }++ in+ opts { ghcOptSourcePath = ghcOptSourcePath opts <> toNubListR extraIncludes+ , ghcOptPackages = ghcOptPackages opts <> toNubListR extraDeps }++ libopts =+ case (getLibraryClbi pd lbi,getExeClbi pd lbi) of+ (Just (lib, libclbi),_) | hasIdeps ->+ let+ libbi = libBuildInfo lib+ opts = cleanRecursiveOpts (CLib lib) libbi libclbi+ in+ opts { ghcOptInputModules = ghcOptInputModules opts <> (toNubListR $ allLibModules lib libclbi) }+ (_,Just (exe,execlbi)) | hasIdeps ->+ let+ exebi = buildInfo exe+ in+ cleanRecursiveOpts (CExe exe) exebi execlbi+ _ -> mempty++ distDir = fromFlagOrDefault ("." </> "dist") (configDistPref $ configFlags lbi)+ packageDbDir = internalPackageDBPath lbi distDir+ (hasIdeps,clbi') = case needsBuild of+ NoBuildOutput -> removeInplace clbi+ ProduceBuildOutput -> (False, clbi)+ libopts' = case needsBuild of+ NoBuildOutput -> libopts+ ProduceBuildOutput -> mempty { ghcOptPackageDBs = [SpecificPackageDB packageDbDir] }+ in (clbi', libopts')+#else+removeInplaceDeps :: Verbosity+ -> LocalBuildInfo+ -> PackageDescription+ -> ComponentLocalBuildInfo+ -> (ComponentLocalBuildInfo, GhcOptions)+removeInplaceDeps _v lbi pd clbi = let+ (ideps, deps) = partition (isInplaceDep lbi) (componentPackageDeps clbi)+ hasIdeps = not $ null ideps+ libopts =+ case getLibraryClbi pd lbi of+ Just (lib, libclbi) | hasIdeps ->+ let+ libbi = libBuildInfo lib+ liboutdir = componentOutDir lbi (CLib lib)+ in+ (componentGhcOptions normal lbi libbi libclbi liboutdir) {+ ghcOptPackageDBs = []+ }+ _ -> mempty+ clbi' = clbi { componentPackageDeps = deps }+ in (clbi', libopts)+#endif+++#if CH_MIN_VERSION_Cabal(2,0,0)+recursiveDepInfo lbi v distdir = do+ includeDirs <- componentsMap lbi v distdir $ \c clbi bi -> do+ return (componentUnitId clbi+ , ( SubDeps+ { sdComponentInternalDeps = componentInternalDeps clbi+ , sdHsSourceDirs = hsSourceDirs bi+ , sdComponentIncludes = componentIncludes clbi+ , sdComponentEntryPoints = componentEntrypoints c}) )+ return $ Map.fromList $ map snd includeDirs++data SubDeps = SubDeps+ { sdComponentInternalDeps :: [UnitId]+ , sdHsSourceDirs :: [FilePath]+ , sdComponentIncludes :: [(OpenUnitId, ModuleRenaming)]+ , sdComponentEntryPoints :: ChEntrypoint+ }++recursiveIncludeDirs :: Map.Map UnitId SubDeps+ -> UnitId -> ([FilePath], [(OpenUnitId, ModuleRenaming)]+ , ChEntrypoint)+recursiveIncludeDirs includeDirs unit = go ([],[],Nothing) [unit]+ where+ go (afp,aci,Nothing ) [] = (afp,aci,error "recursiveIncludeDirs:no ChEntrypoint")+ go (afp,aci,Just amep) [] = (afp,aci,amep)+ go acc@(afp,aci,amep) (u:us) = case Map.lookup u includeDirs of+ Nothing -> go acc us+ Just (SubDeps us' sfp sci sep) -> go (afp++sfp,aci++sci,combineEp amep sep) (us++us')++needsBuildOutput :: Map.Map UnitId SubDeps -> UnitId -> NeedsBuildOutput+needsBuildOutput includeDirs unit = go [unit]+ where+ isIndef (IndefFullUnitId _ _) = True+ isIndef _ = False+ go [] = NoBuildOutput+ go (u:us) = case Map.lookup u includeDirs of+ Nothing -> go us+ Just (SubDeps us' sfp sci sep) ->+ if any (isIndef . fst) sci+ then ProduceBuildOutput+ else go (us++us')++combineEp Nothing e = Just e+combineEp (Just ChSetupEntrypoint) e = Just e+combineEp (Just (ChLibEntrypoint es1 os1 ss1)) (ChLibEntrypoint es2 os2 ss2) = Just (ChLibEntrypoint (nub $ es2++es1) (nub $ os2++os1) (nub $ ss2++ss1))+combineEp (Just (ChLibEntrypoint es1 os1 ss1)) (ChExeEntrypoint mi os2) = Just (ChExeEntrypoint mi (nub $ os2++es1++os1++ss1))+combineEp (Just (ChExeEntrypoint _ os1)) (ChLibEntrypoint es2 os2 ss2) = Just (ChLibEntrypoint es2 (nub $ os2++os1) ss2)+combineEp (Just (ChExeEntrypoint _ os1)) (ChExeEntrypoint mi os2) = Just (ChExeEntrypoint mi (nub $ os2++os1))++instantiatedGhcPackage :: (ModuleName,OpenModule) -> [(OpenUnitId, ModuleRenaming)]+instantiatedGhcPackage (_,OpenModule oui@(DefiniteUnitId _) _) = [(oui,DefaultRenaming)]+instantiatedGhcPackage (_, _) = []+#endif++initialBuildStepsForAllComponents distdir pd lbi v =+ initialBuildSteps distdir pd lbi v+++++++#if !CH_MIN_VERSION_Cabal(1,25,0)+-- CPP < 1.25+unFlagName (FlagName n) = n+-- mkFlagName n = FlagName n+#endif++toDataVersion :: Version -> DataVersion.Version+--fromDataVersion :: DataVersion.Version -> Version+#if CH_MIN_VERSION_Cabal(2,0,0)+toDataVersion v = DataVersion.Version (versionNumbers v) []+--fromDataVersion (DataVersion.Version vs _) = mkVersion vs+#else+toDataVersion = id+--fromDataVersion = id+#endif++componentNameToCh _uid CLibName = ChLibName+#if CH_MIN_VERSION_Cabal(1,25,0)+-- CPP >= 1.25+#if CH_MIN_VERSION_Cabal(2,0,0)+componentNameToCh uid (CSubLibName n) = ChSubLibName uid+#else+componentNameToCh _uid (CSubLibName n) = ChSubLibName (unUnqualComponentName' n)+#endif+componentNameToCh uid (CFLibName n) = ChFLibName (unUnqualComponentName' n)+#endif+componentNameToCh _uid (CExeName n) = ChExeName (unUnqualComponentName' n)+componentNameToCh _uid (CTestName n) = ChTestName (unUnqualComponentName' n)+componentNameToCh _uid (CBenchName n) = ChBenchName (unUnqualComponentName' n)++#if CH_MIN_VERSION_Cabal(1,25,0)+-- CPP >= 1.25+unUnqualComponentName' = unUnqualComponentName+#else+unUnqualComponentName' = id+#endif++#if !CH_MIN_VERSION_Cabal(1,25,0)+-- CPP < 1.25+componentNameFromComponent (CLib Library {}) = CLibName+#elif CH_MIN_VERSION_Cabal(1,25,0)+-- CPP >= 1.25 (redundant)+componentNameFromComponent (CLib Library { libName = Nothing }) = CLibName+componentNameFromComponent (CLib Library { libName = Just n }) = CSubLibName n+componentNameFromComponent (CFLib ForeignLib {..}) = CFLibName foreignLibName+#endif+componentNameFromComponent (CExe Executable {..}) = CExeName exeName+componentNameFromComponent (CTest TestSuite {..}) = CTestName testName+componentNameFromComponent (CBench Benchmark {..}) = CBenchName benchmarkName++componentOutDir lbi (CLib Library {..})=+ buildDir lbi+#if CH_MIN_VERSION_Cabal(2,0,0)+componentOutDir lbi (CFLib ForeignLib {..}) =+ componentOutDir' lbi (unUnqualComponentName foreignLibName)+#endif+componentOutDir lbi (CExe Executable {..}) =+ componentOutDir' lbi (unUnqualComponentName' exeName)+componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteExeV10 _ _, ..}) =+ componentOutDir' lbi (unUnqualComponentName' testName)+componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..}) =+ componentOutDir' lbi (unUnqualComponentName' testName ++ "Stub")+componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})=+ componentOutDir' lbi (unUnqualComponentName' benchmarkName)++componentOutDir' :: LocalBuildInfo -> String -> FilePath+componentOutDir' lbi compName' =+ ----- Copied from Distribution/Simple/GHC.hs:buildOrReplExe+ let targetDir = (buildDir lbi) </> compName'+ compDir = targetDir </> (compName' ++ "-tmp")+ in compDir++componentEntrypoints :: Component -> ChEntrypoint+componentEntrypoints (CLib Library {..})+ = ChLibEntrypoint+ (map gmModuleName exposedModules)+ (map gmModuleName $ otherModules libBuildInfo)+#if CH_MIN_VERSION_Cabal(2,0,0)+ (map gmModuleName signatures)+#else+ [] -- no signatures prior to Cabal 2.0+#endif+#if CH_MIN_VERSION_Cabal(2,0,0)+componentEntrypoints (CFLib (ForeignLib{..}))+ = ChLibEntrypoint+ []+ (map gmModuleName $ otherModules foreignLibBuildInfo)+ []+#endif+componentEntrypoints (CExe Executable {..})+ = ChExeEntrypoint+#if CH_MIN_VERSION_Cabal(2,0,0)+ --+ ( head ((hsSourceDirs buildInfo) ++ ["."]) </> modulePath)+ -- modulePath+#else+ modulePath+#endif+ (map gmModuleName $ otherModules buildInfo)+componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp, ..})+ = ChExeEntrypoint fp (map gmModuleName $ otherModules testBuildInfo)+componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn, ..})+ = ChLibEntrypoint [gmModuleName mn] (map gmModuleName $ otherModules testBuildInfo) []+componentEntrypoints (CTest TestSuite {})+ = ChLibEntrypoint [] [] []+componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ fp, ..})+ = ChExeEntrypoint fp (map gmModuleName $ otherModules benchmarkBuildInfo)+componentEntrypoints (CBench Benchmark {})+ = ChLibEntrypoint [] [] []++#if CH_MIN_VERSION_Cabal(2,0,0)+isInplaceCompInc :: ComponentLocalBuildInfo -> (OpenUnitId, ModuleRenaming) -> Bool+isInplaceCompInc clbi (DefiniteUnitId uid, _mr) = unDefUnitId uid `elem` componentInternalDeps clbi+isInplaceCompInc clbi (IndefFullUnitId uid _, _mmr) = False+#endif++#if CH_MIN_VERSION_Cabal(2,0,0)+isInplaceDep :: LocalBuildInfo -> ComponentLocalBuildInfo -> (UnitId, MungedPackageId) -> Bool+isInplaceDep lbi clbi (uid, _mpid) = uid `elem` componentInternalDeps clbi+#else+isInplaceDep :: LocalBuildInfo -> (InstalledPackageId, PackageId) -> Bool+# if CH_MIN_VERSION_Cabal(1,23,0)+-- CPP >= 1.23+isInplaceDep lbi (ipid, _pid) = localUnitId lbi == ipid+# else+-- CPP <= 1.22+isInplaceDep _lbi (ipid, pid) = inplacePackageId pid == ipid+# endif+#endif++#if CH_MIN_VERSION_Cabal(1,22,0)+-- CPP >= 1.22+-- >= 1.22 uses NubListR+nubPackageFlags opts = opts+#else+nubPackageFlags opts = opts { ghcOptPackages = nub $ ghcOptPackages opts }+#endif++renderGhcOptions' :: LocalBuildInfo+ -> Verbosity+ -> GhcOptions+ -> IO [String]+#if !CH_MIN_VERSION_Cabal(1,20,0)+renderGhcOptions' lbi v opts = do+-- CPP < 1.20+ (ghcProg, _) <- requireProgram v ghcProgram (withPrograms lbi)+ let Just ghcVer = programVersion ghcProg+ return $ renderGhcOptions ghcVer opts+#elif CH_MIN_VERSION_Cabal(1,20,0) && !CH_MIN_VERSION_Cabal(1,24,0)+renderGhcOptions' lbi _v opts = do+-- CPP >= 1.20 && < 1.24+ return $ renderGhcOptions (compiler lbi) opts+#else+renderGhcOptions' lbi _v opts = do+-- CPP >= 1.24+ return $ renderGhcOptions (compiler lbi) (hostPlatform lbi) opts+#endif
@@ -0,0 +1,132 @@+-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-|+Module : CabalHelper.Shared.Common+Description : Shared utility functions+License : AGPL-3+-}++{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+module CabalHelper.Shared.Common where++import Control.Applicative+import Control.Exception as E+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Data.Version+import Data.Typeable+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import System.Environment+import System.IO+import qualified System.Info+import System.Exit+import System.Directory+import System.FilePath+import Text.ParserCombinators.ReadP+import Prelude++data Panic = Panic String deriving (Typeable, Show)+instance Exception Panic++panic :: String -> a+panic msg = throw $ Panic msg++panicIO :: String -> IO a+panicIO msg = throwIO $ Panic msg++handlePanic :: IO a -> IO a+handlePanic action =+ action `E.catch` \(Panic msg) -> errMsg msg >> exitFailure++errMsg :: String -> IO ()+errMsg str = do+ prog <- getProgName+ hPutStrLn stderr $ prog ++ ": " ++ str++-- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and+-- compiler version+getCabalConfigHeader :: FilePath -> IO (Maybe (Version, (ByteString, Version)))+getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do+ parseHeader <$> BS.hGetLine h++parseHeader :: ByteString -> Maybe (Version, (ByteString, Version))+parseHeader header = case BS8.words header of+ ["Saved", "package", "config", "for", _pkgId ,+ "written", "by", cabalId,+ "using", compId]+ -> liftM2 (,) (snd <$> parsePkgId cabalId) (parsePkgId compId)+ _ -> Nothing++parsePkgId :: ByteString -> Maybe (ByteString, Version)+parsePkgId bs =+ case BS8.split '-' bs of+ [pkg, vers] -> Just (pkg, parseVer $ BS8.unpack vers)+ _ -> Nothing++parseVer :: String -> Version+parseVer vers = runReadP parseVersion vers++trim :: String -> String+trim = dropWhileEnd isSpace++majorVer :: Version -> Version+majorVer (Version b _) = Version (take 2 b) []++sameMajorVersionAs :: Version -> Version -> Bool+sameMajorVersionAs a b = majorVer a == majorVer b++runReadP :: ReadP t -> String -> t+runReadP p i = case filter ((=="") . snd) $ readP_to_S p i of+ (a,""):[] -> a+ _ -> error $ "Error parsing: " ++ show i++appCacheDir :: IO FilePath+appCacheDir =+ (</> "cabal-helper") <$> getEnvDefault "XDG_CACHE_HOME" (homeRel cache)+ where+ -- for GHC 7.4+ lookupEnv' var = do env <- getEnvironment; return (lookup var env)+ getEnvDefault var def = lookupEnv' var >>= \m -> case m of Nothing -> def; Just x -> return x+ homeRel path = (</> path) <$> getHomeDirectory+ cache =+ case System.Info.os of+ "mingw32" -> windowsCache+ _ -> unixCache++ windowsCache = "Local Settings" </> "Cache"+ unixCache = ".cache"++isCabalFile :: FilePath -> Bool+isCabalFile f = takeExtension' f == ".cabal"++takeExtension' :: FilePath -> String+takeExtension' p =+ if takeFileName p == takeExtension p+ then "" -- just ".cabal" is not a valid cabal file+ else takeExtension p++replace :: String -> String -> String -> String+replace n r hs' = go "" hs'+ where+ go acc h+ | take (length n) h == n =+ reverse acc ++ r ++ drop (length n) h+ go acc (h:hs) = go (h:acc) hs+ go acc [] = reverse acc
@@ -0,0 +1,80 @@+-- Copyright (C) 2015,2017 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, DefaultSignatures #-}++{-|+Module : CabalHelper.Shared.InterfaceTypes+Description : Types which are used by c-h library and executable to communicate+License : AGPL-3++These types are used to communicate between the cabal-helper library and main+executable, using Show/Read. If any types in this module change the major+version must be bumped since this will be exposed in the @Distribution.Helper@+module.++The cached executables in @$XDG_CACHE_HOME/cabal-helper@ use the cabal-helper+version (among other things) as a cache key so we don't need to worry about+talking to an old executable.+-}+module CabalHelper.Shared.InterfaceTypes where++import GHC.Generics+import Data.Version++data ChResponse+ = ChResponseCompList [(ChComponentName, [String])]+ | ChResponseEntrypoints [(ChComponentName, ChEntrypoint)]+ | ChResponseNeedsBuild [(ChComponentName, NeedsBuildOutput)]+ | ChResponseList [String]+ | ChResponsePkgDbs [ChPkgDb]+ | ChResponseLbi String+ | ChResponseVersion String Version+ | ChResponseLicenses [(String, [(String, Version)])]+ | ChResponseFlags [(String, Bool)]+ deriving (Eq, Ord, Read, Show, Generic)++data ChComponentName = ChSetupHsName+ | ChLibName+ | ChSubLibName String+ | ChFLibName String+ | ChExeName String+ | ChTestName String+ | ChBenchName String+ deriving (Eq, Ord, Read, Show, Generic)++newtype ChModuleName = ChModuleName String+ deriving (Eq, Ord, Read, Show, Generic)++data ChEntrypoint = ChSetupEntrypoint -- ^ Almost like 'ChExeEntrypoint' but+ -- @main-is@ could either be @"Setup.hs"@+ -- or @"Setup.lhs"@. Since we don't know+ -- where the source directory is you have+ -- to find these files.+ | ChLibEntrypoint { chExposedModules :: [ChModuleName]+ , chOtherModules :: [ChModuleName]+ , chSignatures :: [ChModuleName] -- backpack only+ }+ | ChExeEntrypoint { chMainIs :: FilePath+ , chOtherModules :: [ChModuleName]+ } deriving (Eq, Ord, Read, Show, Generic)++data ChPkgDb = ChPkgGlobal+ | ChPkgUser+ | ChPkgSpecific FilePath+ deriving (Eq, Ord, Read, Show, Generic)++data NeedsBuildOutput = ProduceBuildOutput | NoBuildOutput+ deriving (Eq, Ord, Read, Show, Generic)
@@ -0,0 +1,77 @@+-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero 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 Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-|+Module : CabalHelper.Shared.Sandbox+Description : Extracting information from @cabal.sandbox.config@ files+License : AGPL-3+-}++module CabalHelper.Shared.Sandbox where++import Control.Applicative+import Data.Char+import Data.Maybe+import Data.List+import Data.Version+import System.FilePath+import System.Directory+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+ -- ^ Cabal build platform, i.e. @buildPlatform@+ -> Version+ -- ^ GHC version (@cProjectVersion@ is your friend)+ -> IO (Maybe FilePath)+getSandboxPkgDb d platform ghcVer = do+ mConf <- T.traverse readFile =<< mightExist (d </> "cabal.sandbox.config")+ return $ fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)++ where+ fixPkgDbVer dir =+ case takeFileName dir == ghcSandboxPkgDbDir platform ghcVer of+ True -> dir+ False -> takeDirectory dir </> ghcSandboxPkgDbDir platform ghcVer++ghcSandboxPkgDbDir :: String -> Version -> String+ghcSandboxPkgDbDir platform ghcVer =+ platform ++ "-ghc-" ++ showVersion ghcVer ++ "-packages.conf.d"++-- | Extract the sandbox package db directory from the cabal.sandbox.config+-- file. Exception is thrown if the sandbox config file is broken.+extractSandboxDbDir :: String -> Maybe FilePath+extractSandboxDbDir conf = extractValue <$> parse conf+ where+ key = "package-db:"+ keyLen = length key++ parse = listToMaybe . filter (key `isPrefixOf`) . lines+ extractValue = CabalHelper.Shared.Sandbox.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen+++mightExist :: FilePath -> IO (Maybe FilePath)+mightExist f = do+ exists <- doesFileExist f+ return $ if exists then (Just f) else (Nothing)++-- dropWhileEnd is not provided prior to base 4.5.0.0.+dropWhileEnd :: (a -> Bool) -> [a] -> [a]+dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
+ tests/CompileTest.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE ScopedTypeVariables, GADTs #-}++import System.Environment (getArgs)+import System.Directory+import System.FilePath+import System.Process+import System.Exit+import System.IO+import Control.Exception as E+import Data.List+import Data.Maybe+import Data.Version+import Data.Functor+import Data.Function+import qualified Distribution.Compat.ReadP as Dist+import Distribution.Version (VersionRange, withinRange)+import Distribution.Text+import Control.Arrow+import Control.Monad+import Prelude++import CabalHelper.Compiletime.Compat.Environment+import CabalHelper.Compiletime.Compat.Version+import CabalHelper.Compiletime.Compile+import CabalHelper.Compiletime.Types+import CabalHelper.Shared.Common++runReadP'Dist :: Dist.ReadP t t -> String -> t+runReadP'Dist p i = case filter ((=="") . snd) $ Dist.readP_to_S p i of+ (a,""):[] -> a+ _ -> error $ "Error parsing: " ++ show i++withinRange'CH :: Either HEAD Version -> VersionRange -> Bool+withinRange'CH v r =+ withinRange (fromDataVersion v') r+ where+ v' = either (const $ parseVer "1000000000") id v++setupHOME :: IO ()+setupHOME = do+ tmp <- fromMaybe "/tmp" <$> lookupEnv "TMPDIR"+ let home = tmp </> "compile-test-home"+ _ <- rawSystem "rm" ["-r", home]+ createDirectory home+ setEnv "HOME" home++main :: IO ()+main = do+ args <- getArgs++ let action+ | null args = testAllCabalVersions+ | otherwise = testCabalVersions $ map parseVer' args++ setupHOME++ _ <- rawSystem "cabal" ["update"]++ action++parseVer' :: String -> Either HEAD Version+parseVer' "HEAD" = Left HEAD+parseVer' v = Right $ parseVer v++testAllCabalVersions :: IO ()+testAllCabalVersions = do+ let cabal_versions :: [Either HEAD Version]+ cabal_versions = map parseVer'+ -- "1.14.0" -- not supported at runtime+ [ "1.16.0"+ , "1.16.0.1"+ , "1.16.0.2"+ , "1.16.0.3"+ , "1.18.0"+ , "1.18.1"+ , "1.18.1.1"+ , "1.18.1.2"+ , "1.18.1.3"+ , "1.18.1.4"+ , "1.18.1.5"+ , "1.18.1.6"+ , "1.18.1.7"+ , "1.20.0.0"+ , "1.20.0.1"+ , "1.20.0.2"+ , "1.20.0.3"+ , "1.20.0.4"+ , "1.22.0.0"+ , "1.22.1.0"+ , "1.22.1.1"+ , "1.22.2.0"+ , "1.22.3.0"+ , "1.22.4.0"+ , "1.22.5.0"+ , "1.22.6.0"+ , "1.22.7.0"+ , "1.22.8.0"+ , "1.24.0.0"+ , "1.24.1.0"+ , "1.24.2.0"+ , "2.0.0.2"+ , "2.0.1.0"+ , "2.0.1.1"+ , "HEAD"+ ]++ ghc_ver <- ghcVersion defaultOptions++ let constraint :: VersionRange+ constraint =+ fromMaybe (snd $ last constraint_table) $+ fmap snd $+ find (and . (zipWith (==) `on` versionBranch) ghc_ver . fst) $+ constraint_table++ constraint_table =+ map (parseVer *** runReadP'Dist parse) $+ [ ("7.4" , ">= 1.14 && < 2")+ , ("7.6" , ">= 1.16 && < 2")+ , ("7.8" , ">= 1.18 && < 2")+ , ("7.10" , ">= 1.22.2 && < 2")+ , ("8.0.1", ">= 1.24 ")+ , ("8.0.2", ">= 1.24.2 ")+ , ("8.2.1", ">= 2.0.0.2 ")+ , ("8.2.2", ">= 2.0.0.2 ")+ ]++ relevant_cabal_versions =+ reverse $ filter (flip withinRange'CH constraint) cabal_versions++ testCabalVersions relevant_cabal_versions++testCabalVersions :: [Either HEAD Version] -> IO ()+testCabalVersions versions = do+ rvs <- forM versions $ \ver -> do+ let sver = either show showVersion ver+ hPutStrLn stderr $ "\n\n\n\n\n\n====== Compiling with Cabal-" ++ sver+ compilePrivatePkgDb ver++ let printStatus (cv, rv) = putStrLn $ "- Cabal "++ver++" "++status+ where ver = case cv of Left _ -> "HEAD"; Right v -> showVersion v+ status = case rv of+ Right _ ->+ "succeeded"+ Left rvc ->+ "failed (exit code "++show rvc++")"++ let drvs = versions `zip` rvs++ mapM_ printStatus drvs+ if any isLeft' $ map snd $ filter ((/=Left HEAD) . fst) drvs+ then exitFailure+ else exitSuccess++ where+ isLeft' (Left _) = True+ isLeft' (Right _) = False++compilePrivatePkgDb :: Either HEAD Version -> IO (Either ExitCode FilePath)+compilePrivatePkgDb eCabalVer = do+ res <- E.try $ installCabal defaultOptions { oVerbose = True } eCabalVer+ case res of+ Right (db, cabalVer) ->+ compileWithPkg db cabalVer+ Left (ioe :: IOException) -> do+ print ioe+ return $ Left (ExitFailure 1)++compileWithPkg :: PackageDbDir+ -> CabalVersion+ -> IO (Either ExitCode FilePath)+compileWithPkg db cabalVer = do+ appdir <- appCacheDir+ let comp =+ CompileWithCabalPackage (Just db) cabalVer [cabalPkgId cabalVer] CPSGlobal+ compile+ comp+ (compPaths appdir (error "compile-test: distdir not available") comp)+ defaultOptions { oVerbose = True }+++cabalPkgId :: CabalVersion -> String+cabalPkgId (CabalHEAD _commitid) = "Cabal"+cabalPkgId (CabalVersion v) = "Cabal-" ++ showVersion v
+ tests/GhcSession.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE TupleSections, ScopedTypeVariables, CPP #-}+module Main where++import GHC+#if __GLASGOW_HASKELL__ <= 706+import GhcMonad+#endif+import GHC.Paths (libdir)+import DynFlags++import qualified Control.Exception as E+import Control.Monad+import Control.Monad.IO.Class+import Data.List+import Data.Version+import System.Environment (getArgs)+import System.Exit+import System.FilePath ((</>))+import System.Directory+import System.IO+import System.IO.Temp+import System.Process (readProcess)++import Distribution.Helper++import CabalHelper.Shared.Common+++main :: IO ()+main = do+ args <- getArgs+ topdir <- getCurrentDirectory+ res <- mapM (setup topdir test) $ case args of+ [] -> [ ("tests/exelib" , parseVer "1.10")+ , ("tests/exeintlib", parseVer "2.0")+ , ("tests/fliblib" , parseVer "2.0")+ , ("tests/bkpregex" , parseVer "2.0")+ ]+ xs -> map (,parseVer "0") xs++ if any (==False) $ concat res+ then exitFailure+ else exitSuccess++cabalInstallVersion :: IO Version+cabalInstallVersion =+ parseVer . trim <$> readProcess "cabal" ["--numeric-version"] ""++cabalInstallBuiltinCabalVersion :: IO Version+cabalInstallBuiltinCabalVersion =+ parseVer . trim <$> readProcess "cabal"+ ["act-as-setup", "--", "--numeric-version"] ""++setup :: FilePath -> (FilePath -> IO [Bool]) -> (FilePath, Version) -> IO [Bool]+setup topdir act (srcdir, min_cabal_ver) = do+ ci_ver <- cabalInstallVersion+ c_ver <- cabalInstallBuiltinCabalVersion+ let mreason+ | (ci_ver < parseVer "1.24") =+ Just $ "cabal-install-" ++ showVersion ci_ver ++ " is too old"+ | c_ver < min_cabal_ver =+ Just $ "Cabal-" ++ showVersion c_ver+ ++ " < " ++ showVersion min_cabal_ver+ | otherwise =+ Nothing++ case mreason of+ Just reason -> do+ putStrLn $ "Skipping test '" ++ srcdir ++ "' because " ++ reason ++ "."+ return []+ Nothing -> do+ putStrLn $ "Running test '" ++ srcdir ++ "' ------------------------------"+ withSystemTempDirectory "cabal-helper.ghc-session.test" $ \dir -> do+ setCurrentDirectory $ topdir </> srcdir+ run "cabal" [ "sdist", "--output-dir", dir ]++ setCurrentDirectory dir+ run "cabal" [ "configure" ]++ act dir++run :: String -> [String] -> IO ()+run x xs = do+ print $ x:xs+ o <- readProcess x xs ""+ putStrLn o+ return ()++test :: FilePath -> IO [Bool]+test dir = do+ let qe = mkQueryEnv dir (dir </> "dist")+ cs <- runQuery qe $ components $ (,,,) <$> entrypoints <.> ghcOptions <.> needsBuildOutput+ forM cs $ \(ep, opts, nb, cn) -> do++ putStrLn $ "\n" ++ show cn ++ ":::: " ++ show nb++ when (nb == ProduceBuildOutput) $ do+ run "cabal" [ "build" ]++ let opts' = "-Werror" : opts++ let sopts = intercalate " " $ map formatArg $ "\nghc" : opts'+ putStrLn $ "\n" ++ show cn ++ ": " ++ sopts+ hFlush stdout+ compileModule nb ep opts'+ where+ formatArg x+ | "-" `isPrefixOf` x = "\n "++x+ | otherwise = x+++compileModule :: NeedsBuildOutput -> ChEntrypoint -> [String] -> IO Bool+compileModule nb ep opts = do++ putStrLn $ "compiling:" ++ show ep ++ " (" ++ show nb ++ ")"++ E.handle (\(ec :: ExitCode) -> print ec >> return False) $ do++#if __GLASGOW_HASKELL__ <= 704+ defaultErrorHandler defaultLogAction $ do+#else+ defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+#endif++ runGhc (Just libdir) $ do++ handleSourceError (\e -> GHC.printException e >> return False) $ do++ let target = case nb of+ ProduceBuildOutput -> HscNothing -- AZ: what should this be?+ NoBuildOutput -> HscInterpreted++ dflags0 <- getSessionDynFlags+ let dflags1 = dflags0 {+ ghcMode = CompManager+ , ghcLink = LinkInMemory+ , hscTarget = target+ , optLevel = 0+ }++ (dflags2, _, _) <- parseDynamicFlags dflags1 (map noLoc opts)+ _ <- setSessionDynFlags dflags2++ ts <- mapM (\t -> guessTarget t Nothing) $+ case ep of+ ChLibEntrypoint ms ms' ss -> map unChModuleName $ ms ++ ms' ++ ss+ ChExeEntrypoint m ms -> [m] ++ map unChModuleName ms+ ChSetupEntrypoint -> ["Setup.hs"]+ let ts' = case nb of+ NoBuildOutput -> map (\t -> t { targetAllowObjCode = False }) ts+ ProduceBuildOutput -> ts++ setTargets ts'+ _ <- load LoadAllTargets++#if __GLASGOW_HASKELL__ >= 706+ when (nb == NoBuildOutput) $ do+ setContext $ case ep 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"]+#endif++ liftIO'CH $ print ExitSuccess+ return True++unChModuleName :: ChModuleName -> String+unChModuleName (ChModuleName mn) = mn++#if __GLASGOW_HASKELL__ <= 706+liftIO'CH = GhcMonad.liftIO+#else+liftIO'CH = liftIO+#endif
− tests/Spec.hs
@@ -1,127 +0,0 @@-import Distribution.Helper-import System.Environment.Extra (lookupEnv)-import System.Posix.Env (setEnv)-import System.Process-import System.Exit-import Data.Maybe-import Data.Version-import Data.Functor-import Control.Exception as E-import Control.Arrow-import Prelude--import CabalHelper.Common-import CabalHelper.Compile-import CabalHelper.Types---main :: IO ()-main = do- flip (setEnv "HOME") True =<< fromMaybe "/tmp" <$> lookupEnv "TMPDIR"- _ <- rawSystem "cabal" ["update"]-- writeAutogenFiles' $ defaultQueryEnv "." "./dist"-- let parseVer' "HEAD" = Left HEAD- parseVer' v = Right $ parseVer v-- let vers :: [(Version, [Either HEAD Version])]- vers = map (parseVer *** map parseVer') [- ("7.4", [ -- "1.14.0" -- not supported at runtime- ]),-- ("7.6", [ "1.16.0"- , "1.16.0.1"- , "1.16.0.2"- , "1.16.0.3"- ]),-- ("7.8", [- "1.18.0"- , "1.18.1"- , "1.18.1.1"- , "1.18.1.2"- , "1.18.1.3"- , "1.18.1.4"- , "1.18.1.5"- , "1.18.1.6"- , "1.18.1.7"-- , "1.20.0.0"- , "1.20.0.1"- , "1.20.0.2"- , "1.20.0.3"- , "1.20.0.4"- , "1.22.0.0"- , "1.22.1.0"- , "1.22.1.1"- ]),-- ("7.10", [- "1.22.2.0"- , "1.22.3.0"- , "1.22.4.0"- , "1.22.5.0"- , "1.22.6.0"- , "1.22.7.0"- , "1.22.8.0"- ]),- ("8.0", [- "1.24.0.0"- , "1.24.1.0"- , "1.24.2.0"--- , "HEAD"- ])- ]-- ghcVer <- majorVer <$> ghcVersion defaultOptions-- let cabalVers = reverse $ concat $ map snd $ dropWhile ((<ghcVer) . fst) vers-- rvs <- mapM compilePrivatePkgDb cabalVers-- let printStatus (cv, rv) = putStrLn $ "- Cabal "++show cv++" "++status- where status = case rv of- Right _ ->- "suceeded"- Left rvc ->- "failed (exit code "++show rvc++")"-- let drvs = cabalVers `zip` rvs-- mapM_ printStatus (cabalVers `zip` rvs)- if any isLeft' $ map snd $ filter ((/=Left HEAD) . fst) drvs- then exitFailure- else exitSuccess-- where- isLeft' (Left _) = True- isLeft' (Right _) = False--data HEAD = HEAD deriving (Eq, Show)--compilePrivatePkgDb :: Either HEAD Version -> IO (Either ExitCode FilePath)-compilePrivatePkgDb (Left HEAD) = do- _ <- rawSystem "rm" [ "-r", "/tmp/.ghc-mod" ]- (db, commit) <- installCabalHEAD defaultOptions { verbose = True } `E.catch`- \(SomeException ex) ->- error $ "Installing cabal HEAD failed: " ++ show ex- compileWithPkg "." (Just db) (Left commit)-compilePrivatePkgDb (Right cabalVer) = do- _ <- rawSystem "rm" [ "-r", "/tmp/.ghc-mod" ]- db <- installCabal defaultOptions { verbose = True } cabalVer `E.catch`- \(SomeException _) ->- errorInstallCabal cabalVer "dist"- compileWithPkg "." (Just db) (Right cabalVer)--compileWithPkg :: FilePath- -> Maybe FilePath- -> Either String Version- -> IO (Either ExitCode FilePath)-compileWithPkg chdir mdb ver =- compile "dist" defaultOptions { verbose = True } $- Compile chdir Nothing mdb ver [cabalPkgId ver]--cabalPkgId :: Either String Version -> String-cabalPkgId (Left _commitid) = "Cabal"-cabalPkgId (Right v) = "Cabal-" ++ showVersion v
+ tests/bkpregex/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/bkpregex/bkpregex.cabal view
@@ -0,0 +1,29 @@+name: bkpregex+version: 0.1.0.0+build-type: Simple+cabal-version: >=2.0++library str-impls+ build-depends: base, bytestring+ exposed-modules: Str.String, Str.ByteString+ hs-source-dirs: str-impls++library regex-types+ build-depends: base+ exposed-modules: Regex.Types+ hs-source-dirs: regex-types++library regex-indef+ build-depends: base, regex-types+ signatures: Str+ exposed-modules: Regex+ hs-source-dirs: regex-indef++executable regex-example+ main-is: Main.hs+ build-depends: base, regex-indef, regex-types, str-impls+ mixins: regex-indef (Regex as Regex.String)+ requires (Str as Str.String),+ regex-indef (Regex as Regex.ByteString)+ requires (Str as Str.ByteString)+ hs-source-dirs: regex-example
+ tests/bkpregex/regex-example/Main.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Regex.Types+import qualified Regex.String+import qualified Regex.ByteString++nocs = Rep (Alt (Sym 'a') (Sym 'b'))+onec = Seq nocs (Sym 'c')+evencs = Seq (Rep (Seq onec onec)) nocs+main = print (Regex.String.accept evencs "acc") >>+ print (Regex.ByteString.accept evencs "acc")
+ tests/bkpregex/regex-indef/Regex.hs view
@@ -0,0 +1,14 @@+module Regex where++import Prelude hiding (null)+import Str+import Regex.Types++accept :: Reg -> Str -> Bool+accept Eps u = null u+accept (Sym c) u = u == singleton c+accept (Alt p q) u = accept p u || accept q u+accept (Seq p q) u =+ or [accept p u1 && accept q u2 | (u1, u2) <- splits u]+accept (Rep r) u =+ or [and [accept r ui | ui <- ps] | ps <- parts u]
+ tests/bkpregex/regex-indef/Str.hsig view
@@ -0,0 +1,9 @@+signature Str where++data Str+instance Eq Str++null :: Str -> Bool+singleton :: Char -> Str+splits :: Str -> [(Str, Str)]+parts :: Str -> [[Str]]
+ tests/bkpregex/regex-types/Regex/Types.hs view
@@ -0,0 +1,7 @@+module Regex.Types where++data Reg = Eps+ | Sym Char+ | Alt Reg Reg+ | Seq Reg Reg+ | Rep Reg
+ tests/bkpregex/str-impls/Str/ByteString.hs view
@@ -0,0 +1,17 @@+module Str.ByteString(module Data.ByteString.Char8, module Str.ByteString) where++import Prelude hiding (length, null, splitAt)+import Data.ByteString.Char8+import Data.ByteString++type Str = ByteString++splits :: Str -> [(Str, Str)]+splits s = fmap (\n -> splitAt n s) [0..length s]++parts :: Str -> [[Str]]+parts s | null s = [[]]+ | otherwise = do+ n <- [1..length s]+ let (l, r) = splitAt n s+ fmap (l:) (parts r)
+ tests/bkpregex/str-impls/Str/String.hs view
@@ -0,0 +1,21 @@+module Str.String where++import Prelude hiding (null)+import qualified Prelude as P++type Str = String++null :: Str -> Bool+null = P.null++singleton :: Char -> Str+singleton c = [c]++splits :: Str -> [(Str, Str)]+splits [] = [([], [])]+splits (c:cs) = ([], c:cs):[(c:s1,s2) | (s1,s2) <- splits cs]++parts :: Str -> [[Str]]+parts [] = [[]]+parts [c] = [[[c]]]+parts (c:cs) = concat [[(c:p):ps, [c]:p:ps] | p:ps <- parts cs]
+ tests/exeintlib/Exe.hs view
@@ -0,0 +1,5 @@+module Main where++import Lib++main = print lib
+ tests/exeintlib/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/exeintlib/exeintlib.cabal view
@@ -0,0 +1,31 @@+name: exeintlib+version: 0+build-type: Simple+cabal-version: >=2.0++library+ exposed-modules: Lib+ hs-source-dirs: lib+ build-depends: base, filepath, intlib+ default-language: Haskell2010++library intlib+ exposed-modules: IntLib+ hs-source-dirs: intlib+ build-depends: base, directory+ default-language: Haskell2010++executable exe+ main-is: Exe.hs+ build-depends: base, exeintlib+ default-language: Haskell2010++test-suite exe-test+ type: exitcode-stdio-1.0+ main-is: Exe.hs+ build-depends: base, exeintlib++benchmark exe-bench+ type: exitcode-stdio-1.0+ main-is: Exe.hs+ build-depends: base, exeintlib
+ tests/exeintlib/intlib/IntLib.hs view
@@ -0,0 +1,7 @@+module IntLib where++import System.Directory++directory = doesFileExist "Exe.hs"++intlib = 1
+ tests/exeintlib/lib/Lib.hs view
@@ -0,0 +1,8 @@+module Lib where++import System.FilePath+import IntLib++filepath = "a" </> "b"++lib = 1 + intlib
+ tests/exelib/Exe.hs view
@@ -0,0 +1,5 @@+module Main where++import Lib++main = print foo
+ tests/exelib/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/exelib/exelib.cabal view
@@ -0,0 +1,25 @@+name: exelib+version: 0+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Lib+ hs-source-dirs: lib+ build-depends: base, filepath, directory+ default-language: Haskell2010++executable exelib+ main-is: Exe.hs+ build-depends: base, exelib+ default-language: Haskell2010++test-suite exe-test+ type: exitcode-stdio-1.0+ main-is: Exe.hs+ build-depends: base, exelib++benchmark exe-bench+ type: exitcode-stdio-1.0+ main-is: Exe.hs+ build-depends: base, exelib
+ tests/exelib/lib/Lib.hs view
@@ -0,0 +1,8 @@+module Lib where++import System.Directory+import System.FilePath++filepath = "a" </> "b"+directory = doesFileExist "Exe.hs"+foo = 1
+ tests/fliblib/FLib.hs view
@@ -0,0 +1,5 @@+module FLib where++import Lib++flib = print foo
+ tests/fliblib/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ tests/fliblib/fliblib.cabal view
@@ -0,0 +1,19 @@+name: fliblib+version: 0+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules: Lib+ hs-source-dirs: lib+ build-depends: base, filepath, directory+ default-language: Haskell2010++foreign-library flib+ other-modules: FLib+ build-depends: base, fliblib+ hs-source-dirs: .+ type: native-shared+ if os(Windows)+ options: standalone+ default-language: Haskell2010
+ tests/fliblib/lib/Lib.hs view
@@ -0,0 +1,8 @@+module Lib where++import System.Directory+import System.FilePath++filepath = "a" </> "b"+directory = doesFileExist "Exe.hs"+foo = 1