52e3233f44
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.
259 lines
8.3 KiB
Haskell
259 lines
8.3 KiB
Haskell
-- 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
|