Introducing cabal-helper-wrapper
The idea here is to build cabal-helper with whatever version of Cabal the user happens to be using (which we find by looking at dist/setup-config) at runtime. This way we can support literally any version of Cabal as long as the actual cabal-helper still compiles. I tried to only use interfaces in Cabal that have been there since at least 1.16 so I'm hoping this shouldn't break too much.
This commit is contained in:
Daniel Gröber
parent
48563a435e
commit
52e3233f44
41
cabal-helper/Common.hs
Normal file
41
cabal-helper/Common.hs
Normal file
@ -0,0 +1,41 @@
|
||||
-- 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/>.
|
||||
|
||||
module Common where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import System.Environment
|
||||
import System.IO
|
||||
|
||||
errMsg :: String -> IO ()
|
||||
errMsg str = do
|
||||
prog <- getProgName
|
||||
hPutStrLn stderr $ prog ++ ": " ++ str
|
||||
|
||||
align :: String -> String -> String -> String
|
||||
align n an str = let
|
||||
h:rest = lines str
|
||||
[hm] = match n h
|
||||
rest' = [ move (hm - rm) r | r <- rest, rm <- match an r]
|
||||
in
|
||||
unlines (h:rest')
|
||||
where
|
||||
match p str' = maybeToList $
|
||||
fst <$> find ((p `isPrefixOf`) . snd) ([0..] `zip` tails str')
|
||||
move i str' | i > 0 = replicate i ' ' ++ str'
|
||||
move i str' = drop i str'
|
||||
345
cabal-helper/Main.hs
Normal file
345
cabal-helper/Main.hs
Normal file
@ -0,0 +1,345 @@
|
||||
-- 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, BangPatterns, RecordWildCards #-}
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
import Distribution.Simple.Utils (cabalVersion)
|
||||
import Distribution.Simple.Configure
|
||||
|
||||
import Distribution.Package (PackageIdentifier, InstalledPackageId, PackageId)
|
||||
import Distribution.PackageDescription (PackageDescription,
|
||||
FlagAssignment,
|
||||
Executable(..),
|
||||
Library(..),
|
||||
TestSuite(..),
|
||||
Benchmark(..),
|
||||
BuildInfo(..),
|
||||
TestSuiteInterface(..),
|
||||
BenchmarkInterface(..),
|
||||
withLib)
|
||||
import Distribution.PackageDescription.Parse (readPackageDescription)
|
||||
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
|
||||
|
||||
import Distribution.Simple.Configure (getPersistBuildConfig)
|
||||
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..),
|
||||
Component(..),
|
||||
ComponentName(..),
|
||||
ComponentLocalBuildInfo(..),
|
||||
componentBuildInfo,
|
||||
externalPackageDeps,
|
||||
withComponentsLBI,
|
||||
inplacePackageId)
|
||||
|
||||
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(..))
|
||||
|
||||
import Distribution.ModuleName (components)
|
||||
import qualified Distribution.ModuleName as C (ModuleName)
|
||||
import Distribution.Text (display)
|
||||
import Distribution.Verbosity (Verbosity, silent, deafening)
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad
|
||||
import Control.Exception (catch, PatternMatchFail(..))
|
||||
import Data.List
|
||||
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 Common
|
||||
|
||||
--- \ / These types MUST be in sync with the copies in lib:ghc-mod
|
||||
data GmComponentName = GmSetupHsName
|
||||
| GmLibName
|
||||
| GmExeName String
|
||||
| GmTestName String
|
||||
| GmBenchName String
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
data GmCabalHelperResponse
|
||||
= GmCabalHelperStrings [(GmComponentName, [String])]
|
||||
| GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [ModuleName])]
|
||||
| GmCabalHelperLbi String
|
||||
deriving (Read, Show)
|
||||
--- ^ These types MUST be in sync with the copies in ../Types.hs
|
||||
|
||||
|
||||
-- MUST be compatible to the one in GHC
|
||||
newtype ModuleName = ModuleName String
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
usage = do
|
||||
prog <- getProgName
|
||||
hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg)
|
||||
where
|
||||
usageMsg = ""
|
||||
++"DIST_DIR ( version\n"
|
||||
++" | print-lbi\n"
|
||||
++" | write-autogen-files\n"
|
||||
++" | ghc-options [--with-inplace]\n"
|
||||
++" | ghc-src-options [--with-inplace]\n"
|
||||
++" | ghc-pkg-options [--with-inplace]\n"
|
||||
++" | entrypoints\n"
|
||||
++" | source-dirs\n"
|
||||
++" ) ...\n"
|
||||
|
||||
commands :: [String]
|
||||
commands = [ "print-bli"
|
||||
, "write-autogen-files"
|
||||
, "component-from-file"
|
||||
, "ghc-options"
|
||||
, "ghc-src-options"
|
||||
, "ghc-pkg-options"
|
||||
, "entrypoints"
|
||||
, "source-dirs"]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
|
||||
distdir:args' <- case args of
|
||||
[] -> usage >> exitFailure
|
||||
_ -> return args
|
||||
|
||||
ddexists <- doesDirectoryExist distdir
|
||||
when (not ddexists) $ do
|
||||
errMsg $ "distdir '"++distdir++"' does not exist"
|
||||
exitFailure
|
||||
|
||||
v <- maybe silent (const deafening) <$> lookupEnv "GHC_MOD_DEBUG"
|
||||
lbi <- unsafeInterleaveIO $ getPersistBuildConfig distdir
|
||||
let pd = localPkgDescr lbi
|
||||
|
||||
let
|
||||
-- a =<< b $$ c == (a =<< b) $$ c
|
||||
-- a <$$> b $$ c == a <$$> (b $$ c)
|
||||
infixr 2 $$
|
||||
($$) = ($)
|
||||
infixr 1 <$$>
|
||||
(<$$>) = (<$>)
|
||||
|
||||
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
|
||||
"write-autogen-files":[] -> do
|
||||
let pd = localPkgDescr lbi
|
||||
-- calls writeAutogenFiles
|
||||
initialBuildSteps distdir pd lbi v
|
||||
return Nothing
|
||||
|
||||
"ghc-options":flags ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> let
|
||||
outdir = componentOutDir lbi c
|
||||
(clbi', adopts) = case flags of
|
||||
["--with-inplace"] -> (clbi, mempty)
|
||||
[] -> removeInplaceDeps pd clbi
|
||||
opts = componentGhcOptions v lbi bi clbi' outdir
|
||||
in
|
||||
renderGhcOptions (compiler lbi) $ opts `mappend` adopts
|
||||
|
||||
"ghc-src-options":flags ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> let
|
||||
outdir = componentOutDir lbi c
|
||||
(clbi', adopts) = case flags of
|
||||
["--with-inplace"] -> (clbi, mempty)
|
||||
[] -> removeInplaceDeps pd clbi
|
||||
opts = componentGhcOptions v lbi bi clbi' outdir
|
||||
comp = compiler lbi
|
||||
|
||||
opts' = mempty {
|
||||
-- Not really needed but "unexpected package db stack: []"
|
||||
ghcOptPackageDBs = [GlobalPackageDB],
|
||||
ghcOptCppOptions = ghcOptCppOptions opts,
|
||||
ghcOptCppIncludePath = ghcOptCppIncludePath opts,
|
||||
ghcOptCppIncludes = ghcOptCppIncludes opts,
|
||||
ghcOptFfiIncludes = ghcOptFfiIncludes opts,
|
||||
ghcOptSourcePathClear = ghcOptSourcePathClear opts,
|
||||
ghcOptSourcePath = ghcOptSourcePath opts
|
||||
}
|
||||
in
|
||||
renderGhcOptions comp $ opts `mappend` adopts
|
||||
|
||||
"ghc-pkg-options":flags ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> let
|
||||
comp = compiler lbi
|
||||
outdir = componentOutDir lbi c
|
||||
(clbi', adopts) = case flags of
|
||||
["--with-inplace"] -> (clbi, mempty)
|
||||
[] -> removeInplaceDeps pd clbi
|
||||
opts = componentGhcOptions v lbi bi clbi' outdir
|
||||
|
||||
opts' = mempty {
|
||||
ghcOptPackageDBs = ghcOptPackageDBs opts,
|
||||
ghcOptPackages = ghcOptPackages opts,
|
||||
ghcOptHideAllPackages = ghcOptHideAllPackages opts
|
||||
}
|
||||
in
|
||||
renderGhcOptions (compiler lbi) $ opts' `mappend` adopts
|
||||
|
||||
"entrypoints":[] -> do
|
||||
eps <- componentsMap lbi v distdir $ \c clbi bi ->
|
||||
componentEntrypoints c
|
||||
-- MUST append Setup component at the end otherwise CabalHelper gets
|
||||
-- confused
|
||||
let eps' = eps ++ [(GmSetupHsName, Right [ModuleName "Setup"])]
|
||||
return $ Just $ GmCabalHelperEntrypoints eps'
|
||||
|
||||
"source-dirs":[] ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> hsSourceDirs bi
|
||||
|
||||
"print-lbi":[] ->
|
||||
return $ Just $ GmCabalHelperLbi $ show lbi
|
||||
|
||||
cmd:_ | not (cmd `elem` commands) ->
|
||||
errMsg ("Unknown command: " ++ cmd) >> usage >> exitFailure
|
||||
_ ->
|
||||
errMsg "Invalid usage!" >> usage >> exitFailure
|
||||
|
||||
|
||||
getLibrary :: PackageDescription -> Library
|
||||
getLibrary pd = unsafePerformIO $ do
|
||||
lr <- newIORef (error "libraryMap: empty IORef")
|
||||
withLib pd (writeIORef lr)
|
||||
readIORef lr
|
||||
|
||||
componentsMap :: LocalBuildInfo
|
||||
-> Verbosity
|
||||
-> FilePath
|
||||
-> ( Component
|
||||
-> ComponentLocalBuildInfo
|
||||
-> BuildInfo
|
||||
-> a)
|
||||
-> IO [(GmComponentName, a)]
|
||||
componentsMap lbi v distdir f = do
|
||||
let pd = localPkgDescr lbi
|
||||
|
||||
lr <- newIORef []
|
||||
|
||||
withComponentsLBI pd lbi $ \c clbi -> do
|
||||
let bi = componentBuildInfo c
|
||||
name = componentNameFromComponent c
|
||||
|
||||
l' <- readIORef lr
|
||||
writeIORef lr $ (componentNameToGm name, f c clbi bi):l'
|
||||
reverse <$> readIORef lr
|
||||
|
||||
componentNameToGm CLibName = GmLibName
|
||||
componentNameToGm (CExeName n) = GmExeName n
|
||||
componentNameToGm (CTestName n) = GmTestName n
|
||||
componentNameToGm (CBenchName n) = GmBenchName n
|
||||
|
||||
componentNameFromComponent (CLib Library {}) = CLibName
|
||||
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 -> ModuleName
|
||||
gmModuleName = ModuleName . intercalate "." . components
|
||||
|
||||
componentEntrypoints :: Component -> Either FilePath [ModuleName]
|
||||
componentEntrypoints (CLib Library {..})
|
||||
= Right $ map gmModuleName exposedModules
|
||||
componentEntrypoints (CExe Executable {..})
|
||||
= Left modulePath
|
||||
componentEntrypoints (CTest TestSuite { testInterface = TestSuiteExeV10 _ fp })
|
||||
= Left fp
|
||||
componentEntrypoints (CTest TestSuite { testInterface = TestSuiteLibV09 _ mn })
|
||||
= Right [gmModuleName mn]
|
||||
componentEntrypoints (CTest TestSuite {})
|
||||
= Right []
|
||||
componentEntrypoints (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ fp})
|
||||
= Left fp
|
||||
componentEntrypoints (CBench Benchmark {})
|
||||
= Left []
|
||||
|
||||
exeOutDir :: LocalBuildInfo -> String -> FilePath
|
||||
exeOutDir lbi exeName =
|
||||
----- Copied from Distribution/Simple/GHC.hs:buildOrReplExe
|
||||
-- exeNameReal, the name that GHC really uses (with .exe on Windows)
|
||||
let exeNameReal = exeName <.>
|
||||
(if takeExtension exeName /= ('.':exeExtension)
|
||||
then exeExtension
|
||||
else "")
|
||||
|
||||
targetDir = (buildDir lbi) </> exeName
|
||||
in targetDir
|
||||
|
||||
|
||||
removeInplaceDeps :: PackageDescription
|
||||
-> ComponentLocalBuildInfo
|
||||
-> (ComponentLocalBuildInfo, GhcOptions)
|
||||
removeInplaceDeps pd clbi = let
|
||||
(ideps, deps) = partition isInplaceDep (componentPackageDeps clbi)
|
||||
hasIdeps = not $ null ideps
|
||||
clbi' = clbi { componentPackageDeps = deps }
|
||||
lib = getLibrary pd
|
||||
src_dirs = hsSourceDirs (libBuildInfo lib)
|
||||
adopts = mempty {
|
||||
ghcOptSourcePath =
|
||||
#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22
|
||||
toNubListR src_dirs
|
||||
#else
|
||||
src_dirs
|
||||
#endif
|
||||
|
||||
}
|
||||
|
||||
in (clbi', if hasIdeps then adopts else mempty)
|
||||
|
||||
where
|
||||
isInplaceDep :: (InstalledPackageId, PackageId) -> Bool
|
||||
isInplaceDep (ipid, pid) = inplacePackageId pid == ipid
|
||||
258
cabal-helper/Wrapper.hs
Normal file
258
cabal-helper/Wrapper.hs
Normal file
@ -0,0 +1,258 @@
|
||||
-- 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 TemplateHaskell, OverloadedStrings, RecordWildCards #-}
|
||||
module Main where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.String
|
||||
import Data.Version
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Char8 as BS8
|
||||
import Text.Printf
|
||||
import Text.ParserCombinators.ReadP
|
||||
import System.Environment
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
import System.Exit
|
||||
import System.IO
|
||||
|
||||
import Distribution.System (buildPlatform)
|
||||
import Distribution.Text (display)
|
||||
|
||||
import NotCPP.Declarations
|
||||
|
||||
import Paths_ghc_mod
|
||||
import Common
|
||||
import Utils
|
||||
|
||||
ifD [d| getExecutablePath = getProgName |]
|
||||
|
||||
usage :: IO ()
|
||||
usage = do
|
||||
prog <- getProgName
|
||||
hPutStr stderr $ align "(" "|" ("Usage: " ++ prog ++ " " ++ usageMsg)
|
||||
where
|
||||
usageMsg = "\
|
||||
\( print-appdatadir\n\
|
||||
\| print-build-platform\n\
|
||||
\| DIST_DIR [CABAL_HELPER_ARGS...]\n\
|
||||
\)\n"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
"print-appdatadir":[] -> putStrLn =<< appDataDir
|
||||
"print-build-platform":[] -> putStrLn $ display buildPlatform
|
||||
distdir:_ -> do
|
||||
cfgf <- canonicalizePath (distdir </> "setup-config")
|
||||
mhdr <- (parseHeader =<<) . listToMaybe . BS8.lines <$> BS.readFile cfgf
|
||||
case mhdr of
|
||||
Nothing -> error $ printf "\
|
||||
\Could not read Cabal's persistent setup configuration header\n\
|
||||
\- Check first line of: %s\n\
|
||||
\- Maybe try: $ cabal configure" cfgf
|
||||
|
||||
Just Header {..} -> do
|
||||
eexe <- compileHelper hdrCabalVersion
|
||||
case eexe of
|
||||
Left e -> exitWith e
|
||||
Right exe -> do
|
||||
(_,_,_,h) <- createProcess $ proc exe args
|
||||
exitWith =<< waitForProcess h
|
||||
|
||||
_ -> usage
|
||||
|
||||
appDataDir :: IO FilePath
|
||||
appDataDir = (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
|
||||
|
||||
tryFindSrcDirInGhcModTree :: IO (Maybe FilePath)
|
||||
tryFindSrcDirInGhcModTree = do
|
||||
dir <- (!!4) . iterate takeDirectory <$> getExecutablePath
|
||||
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
||||
src_exists <- doesFileExist $ dir </> "cabal-helper/Main.hs"
|
||||
if exists && src_exists
|
||||
then return $ Just (dir </> "cabal-helper")
|
||||
else return Nothing
|
||||
|
||||
tryFindRealSrcDir :: IO (Maybe FilePath)
|
||||
tryFindRealSrcDir = do
|
||||
datadir <- getDataDir
|
||||
exists <- doesFileExist $ datadir </> "cabal-helper/Main.hs"
|
||||
return $ if exists
|
||||
then Just $ datadir </> "cabal-helper"
|
||||
else Nothing
|
||||
|
||||
findCabalHelperSourceDir :: IO FilePath
|
||||
findCabalHelperSourceDir = do
|
||||
msrcdir <- runMaybeT $ MaybeT tryFindSrcDirInGhcModTree
|
||||
<|> MaybeT tryFindRealSrcDir
|
||||
case msrcdir of
|
||||
Nothing -> getDataDir >>= errorNoMain
|
||||
Just datadir -> return datadir
|
||||
|
||||
compileHelper :: Version -> IO (Either ExitCode FilePath)
|
||||
compileHelper cabalVer = do
|
||||
chdir <- findCabalHelperSourceDir
|
||||
mver <- find (sameMajorVersion cabalVer) <$> listCabalVersions
|
||||
couldBeSrcDir <- takeDirectory <$> getDataDir
|
||||
|
||||
case mver of
|
||||
Nothing -> do
|
||||
let cabalFile = couldBeSrcDir </> "Cabal.cabal"
|
||||
cabal <- doesFileExist cabalFile
|
||||
if cabal
|
||||
then do
|
||||
ver <- cabalFileVersion <$> readFile cabalFile
|
||||
compile $ Compile chdir (Just couldBeSrcDir) ver []
|
||||
else errorNoCabal cabalVer
|
||||
Just ver ->
|
||||
compile $ Compile chdir Nothing ver [cabalPkgId ver]
|
||||
where
|
||||
cabalPkgId v = "Cabal-" ++ showVersion v
|
||||
|
||||
errorNoCabal :: Version -> a
|
||||
errorNoCabal cabalVer = error $ printf "\
|
||||
\No appropriate Cabal package found, wanted version %s.\n\
|
||||
\- Check output of: $ ghc-pkg list Cabal\n\
|
||||
\- Maybe try: $ cabal install Cabal --constraint 'Cabal == %s.*'" sver mjver
|
||||
where
|
||||
sver = showVersion cabalVer
|
||||
mjver = showVersion $ majorVer cabalVer
|
||||
|
||||
errorNoMain :: FilePath -> a
|
||||
errorNoMain datadir = error $ printf "\
|
||||
\Could not find $datadir/cabal-helper/Main.hs!\n\
|
||||
\\n\
|
||||
\If you are a developer you can use the environment variable `ghc_mod_datadir'\n\
|
||||
\to override $datadir[1], `$ export ghc_mod_datadir=$PWD' will work in the\n\
|
||||
\ghc-mod tree.\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\
|
||||
\ https://github.com/kazu-yamamoto/ghc-mod/issues" datadir
|
||||
|
||||
data Compile = Compile {
|
||||
cabalHelperSourceDir :: FilePath,
|
||||
cabalSourceDir :: Maybe FilePath,
|
||||
cabalVersion :: Version,
|
||||
packageDeps :: [String]
|
||||
}
|
||||
|
||||
compile :: Compile -> IO (Either ExitCode FilePath)
|
||||
compile Compile {..} = do
|
||||
outdir <- appDataDir
|
||||
createDirectoryIfMissing True outdir
|
||||
|
||||
let exe = outdir </> "cabal-helper-" ++ showVersion (majorVer cabalVersion)
|
||||
|
||||
recompile <-
|
||||
case cabalSourceDir of
|
||||
Nothing -> do
|
||||
tsrcs <- timeHsFiles cabalHelperSourceDir
|
||||
texe <- timeMaybe exe
|
||||
return $ any ((texe <) . Just) tsrcs
|
||||
Just _ -> return True -- let ghc do the difficult recomp checking
|
||||
|
||||
let Version (mj:mi:_) _ = cabalVersion
|
||||
let ghc_opts =
|
||||
concat [
|
||||
[ "-outputdir", outdir
|
||||
, "-o", exe
|
||||
, "-optP-DCABAL_MAJOR=" ++ show mj
|
||||
, "-optP-DCABAL_MINOR=" ++ show mi
|
||||
],
|
||||
map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir,
|
||||
concatMap (\p -> ["-package", p]) packageDeps,
|
||||
[ "--make", cabalHelperSourceDir </> "Main.hs" ]
|
||||
]
|
||||
|
||||
if recompile
|
||||
then do
|
||||
(_, _, _, h) <- createProcess
|
||||
(proc "ghc" ghc_opts) { std_out = UseHandle stderr }
|
||||
rv <- waitForProcess h
|
||||
return $ case rv of
|
||||
ExitSuccess -> Right exe
|
||||
e@(ExitFailure _) -> Left e
|
||||
else return $ Right exe
|
||||
|
||||
timeHsFiles :: FilePath -> IO [TimedFile]
|
||||
timeHsFiles dir = do
|
||||
fs <- map (dir</>) <$> getDirectoryContents dir
|
||||
mapM timeFile =<< filterM isHsFile fs
|
||||
where
|
||||
isHsFile f = do
|
||||
exists <- doesFileExist f
|
||||
return $ exists && ".hs" `isSuffixOf` f
|
||||
|
||||
|
||||
|
||||
-- TODO: Include sandbox? Probably only relevant for build-type:custom projects.
|
||||
listCabalVersions :: IO [Version]
|
||||
listCabalVersions = do
|
||||
catMaybes . map (fmap snd . parsePkgId . fromString) . words
|
||||
<$> readProcess "ghc-pkg" ["list", "--simple-output", "Cabal"] ""
|
||||
|
||||
data Header = Header { hdrCabalVersion :: Version
|
||||
, hdrCompilerVersion :: Version
|
||||
}
|
||||
|
||||
-- | Find @version: XXX@ delcaration in a cabal file
|
||||
cabalFileVersion :: String -> Version
|
||||
cabalFileVersion cabalFile = do
|
||||
fromJust $ parseVer . extract <$> find ("version" `isPrefixOf`) ls
|
||||
where
|
||||
ls = map (map toLower) $ lines cabalFile
|
||||
extract = dropWhile (/=':') >>> dropWhile isSpace >>> takeWhile (not . isSpace)
|
||||
|
||||
parseHeader :: ByteString -> Maybe Header
|
||||
parseHeader header = case BS8.words header of
|
||||
["Saved", "package", "config", "for", _pkgId ,
|
||||
"written", "by", cabalId,
|
||||
"using", compId]
|
||||
-> liftM2 Header (ver cabalId) (ver compId)
|
||||
_ -> error "parsing setup-config header failed"
|
||||
where
|
||||
ver i = snd <$> parsePkgId i
|
||||
|
||||
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) []
|
||||
|
||||
sameMajorVersion :: Version -> Version -> Bool
|
||||
sameMajorVersion a b = majorVer a == majorVer b
|
||||
|
||||
runReadP :: ReadP t -> String -> t
|
||||
runReadP p i = let (a,""):[] = filter ((=="") . snd) $ readP_to_S p i in a
|
||||
@ -186,20 +186,25 @@ Executable ghc-modi
|
||||
, ghc
|
||||
, ghc-mod
|
||||
|
||||
Executable cabal-helper
|
||||
Executable cabal-helper-wrapper
|
||||
Default-Language: Haskell2010
|
||||
Main-Is: GHCModCabal.hs
|
||||
Other-Extensions: TemplateHaskell
|
||||
Main-Is: Wrapper.hs
|
||||
Other-Modules: Paths_ghc_mod
|
||||
GHC-Options: -Wall
|
||||
HS-Source-Dirs: src
|
||||
HS-Source-Dirs: cabal-helper, .
|
||||
X-Install-Target: $libexecdir
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
, bytestring
|
||||
, binary
|
||||
, containers
|
||||
, Cabal >= 1.16
|
||||
, directory
|
||||
if flag(cabal-122)
|
||||
Build-Depends: Cabal >= 1.22
|
||||
else
|
||||
Buildable: False
|
||||
, filepath
|
||||
, process
|
||||
, transformers
|
||||
, template-haskell
|
||||
, time
|
||||
|
||||
Test-Suite doctest
|
||||
Type: exitcode-stdio-1.0
|
||||
|
||||
@ -1,28 +0,0 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Main where
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
import Distribution.Simple.Utils (cabalVersion)
|
||||
import Distribution.Simple.Configure
|
||||
import Distribution.Text ( display )
|
||||
import System.Environment
|
||||
import System.Directory
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
"version":[] -> do
|
||||
putStrLn $ "using version " ++ display cabalVersion ++ " of the Cabal library"
|
||||
"print-setup-config":args' -> do
|
||||
mfile <- findFile ["dist"] "setup-config"
|
||||
|
||||
let file = case mfile of
|
||||
Just f -> f
|
||||
Nothing -> let !(f:[]) = args' in f
|
||||
|
||||
putStrLn =<< show <$> getConfigStateFile file
|
||||
|
||||
cmd:_ -> error $ "Unknown command: " ++ cmd
|
||||
[] -> error "No command given"
|
||||
Loading…
Reference in New Issue
Block a user