Change the way cabal-helper is built a bit
This commit is contained in:
Daniel Gröber
96
CabalHelper/Common.hs
Normal file
96
CabalHelper/Common.hs
Normal file
@@ -0,0 +1,96 @@
|
||||
-- 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 DeriveDataTypeable, OverloadedStrings #-}
|
||||
module CabalHelper.Common where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception
|
||||
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 Text.ParserCombinators.ReadP
|
||||
|
||||
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 `catch` \(Panic msg) -> errMsg msg >> exitFailure
|
||||
|
||||
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'
|
||||
|
||||
|
||||
-- | @getCabalConfigHeader "dist/setup-config"@ returns the cabal version and
|
||||
-- compiler version
|
||||
getCabalConfigHeader :: FilePath -> IO (Maybe (Version, Version))
|
||||
getCabalConfigHeader file = bracket (openFile file ReadMode) hClose $ \h -> do
|
||||
parseHeader <$> BS.hGetLine h
|
||||
|
||||
parseHeader :: ByteString -> Maybe (Version, Version)
|
||||
parseHeader header = case BS8.words header of
|
||||
["Saved", "package", "config", "for", _pkgId ,
|
||||
"written", "by", cabalId,
|
||||
"using", compId]
|
||||
-> liftM2 (,) (ver cabalId) (ver compId)
|
||||
_ -> Nothing
|
||||
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
|
||||
340
CabalHelper/Main.hs
Normal file
340
CabalHelper/Main.hs
Normal file
@@ -0,0 +1,340 @@
|
||||
-- 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.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,
|
||||
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 CabalHelper.Common
|
||||
import CabalHelper.Types
|
||||
|
||||
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' lbi v $ 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' lbi v $ 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' lbi v $ opts' `mappend` adopts
|
||||
|
||||
"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 ++ [(GmSetupHsName, Right [GmModuleName "Setup"])]
|
||||
return $ Just $ GmCabalHelperEntrypoints eps'
|
||||
|
||||
"source-dirs":[] ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> return $ 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
|
||||
-> IO 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
|
||||
r <- f c clbi bi
|
||||
writeIORef lr $ (componentNameToGm name, r):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 -> GmModuleName
|
||||
gmModuleName = GmModuleName . intercalate "." . components
|
||||
|
||||
componentEntrypoints :: Component -> Either FilePath [GmModuleName]
|
||||
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
|
||||
|
||||
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
|
||||
#else
|
||||
return $ renderGhcOptions (compiler lbi) opts
|
||||
#endif
|
||||
18
CabalHelper/Types.hs
Normal file
18
CabalHelper/Types.hs
Normal file
@@ -0,0 +1,18 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module CabalHelper.Types where
|
||||
|
||||
newtype GmModuleName = GmModuleName String
|
||||
deriving (Read, Show)
|
||||
|
||||
data GmComponentName = GmSetupHsName
|
||||
| GmLibName
|
||||
| GmExeName String
|
||||
| GmTestName String
|
||||
| GmBenchName String
|
||||
deriving (Eq, Ord, Read, Show)
|
||||
|
||||
data GmCabalHelperResponse
|
||||
= GmCabalHelperStrings [(GmComponentName, [String])]
|
||||
| GmCabalHelperEntrypoints [(GmComponentName, Either FilePath [GmModuleName])]
|
||||
| GmCabalHelperLbi String
|
||||
deriving (Read, Show)
|
||||
296
CabalHelper/Wrapper.hs
Normal file
296
CabalHelper/Wrapper.hs
Normal file
@@ -0,0 +1,296 @@
|
||||
-- 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, 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 Text.Printf
|
||||
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 CabalHelper.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 = handlePanic $ do
|
||||
args <- getArgs
|
||||
case args of
|
||||
"print-appdatadir":[] -> putStrLn =<< appDataDir
|
||||
"print-build-platform":[] -> putStrLn $ display buildPlatform
|
||||
distdir:_ -> 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, _hdrCompilerVersion) -> 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 </> "CabalHelper/Main.hs"
|
||||
if exists && src_exists
|
||||
then return $ Just dir
|
||||
else return Nothing
|
||||
|
||||
tryFindRealSrcDir :: IO (Maybe FilePath)
|
||||
tryFindRealSrcDir = do
|
||||
datadir <- getDataDir
|
||||
exists <- doesFileExist $ datadir </> "CabalHelper/Main.hs"
|
||||
return $ if exists
|
||||
then Just datadir
|
||||
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
|
||||
|
||||
-- First check if we already compiled this version of cabal
|
||||
db_exists <- cabalPkgDbExists cabalVer
|
||||
case db_exists of
|
||||
True -> compileWithPkg chdir . Just =<< cabalPkgDb cabalVer
|
||||
False -> do
|
||||
-- Next check if this version is globally available
|
||||
mver <- find (== cabalVer) <$> listCabalVersions
|
||||
couldBeSrcDir <- takeDirectory <$> getDataDir
|
||||
case mver of
|
||||
Nothing -> do
|
||||
-- If not see if we're in a cabal source tree
|
||||
let cabalFile = couldBeSrcDir </> "Cabal.cabal"
|
||||
cabal <- doesFileExist cabalFile
|
||||
if cabal
|
||||
then do
|
||||
ver <- cabalFileVersion <$> readFile cabalFile
|
||||
compileWithCabalTree chdir ver couldBeSrcDir
|
||||
else do
|
||||
-- otherwise compile the requested cabal version into an isolated
|
||||
-- package-db
|
||||
db <- installCabal cabalVer
|
||||
compileWithPkg chdir (Just db)
|
||||
Just _ ->
|
||||
compileWithPkg chdir Nothing
|
||||
|
||||
where
|
||||
compileWithCabalTree chdir ver srcDir =
|
||||
compile $ Compile chdir (Just srcDir) Nothing ver []
|
||||
|
||||
compileWithPkg chdir mdb =
|
||||
compile $ Compile chdir Nothing mdb cabalVer [cabalPkgId cabalVer]
|
||||
|
||||
cabalPkgId v = "Cabal-" ++ showVersion v
|
||||
|
||||
-- errorNoCabal :: Version -> a
|
||||
-- errorNoCabal cabalVer = panic $ 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 sver
|
||||
-- where
|
||||
-- sver = showVersion cabalVer
|
||||
|
||||
errorNoMain :: FilePath -> a
|
||||
errorNoMain datadir = panic $ printf "\
|
||||
\Could not find $datadir/CabalHelper/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,
|
||||
packageDb :: 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 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_HELPER=1"
|
||||
, "-optP-DCABAL_MAJOR=" ++ show mj
|
||||
, "-optP-DCABAL_MINOR=" ++ show mi
|
||||
],
|
||||
maybeToList $ ("-package-db="++) <$> packageDb,
|
||||
map ("-i"++) $ cabalHelperSourceDir:maybeToList cabalSourceDir,
|
||||
concatMap (\p -> ["-package", p]) packageDeps,
|
||||
[ "--make", cabalHelperSourceDir </> "CabalHelper/Main.hs" ]
|
||||
]
|
||||
|
||||
if recompile
|
||||
then do
|
||||
rv <- callProcessStderr' Nothing "ghc" ghc_opts
|
||||
return $ case rv of
|
||||
ExitSuccess -> Right exe
|
||||
e@(ExitFailure _) -> Left e
|
||||
else return $ Right exe
|
||||
|
||||
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 ++ ")"]
|
||||
|
||||
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
|
||||
|
||||
installCabal :: Version -> IO FilePath
|
||||
installCabal ver = do
|
||||
db <- createPkgDb ver
|
||||
callProcessStderr (Just "/") "cabal" [ "--package-db=clear"
|
||||
, "--package-db=global"
|
||||
, "--package-db=" ++ db
|
||||
, "-j1"
|
||||
, "install", "Cabal-"++showVersion ver
|
||||
]
|
||||
return db
|
||||
|
||||
createPkgDb :: Version -> IO FilePath
|
||||
createPkgDb ver = do
|
||||
db <- cabalPkgDb ver
|
||||
exists <- doesDirectoryExist db
|
||||
when (not exists) $ callProcessStderr Nothing "ghc-pkg" ["init", db]
|
||||
return db
|
||||
|
||||
cabalPkgDb :: Version -> IO FilePath
|
||||
cabalPkgDb ver = do
|
||||
appdir <- appDataDir
|
||||
return $ appdir </> "cabal-" ++ showVersion ver ++ "-db"
|
||||
|
||||
cabalPkgDbExists :: Version -> IO Bool
|
||||
cabalPkgDbExists ver = do
|
||||
db <- cabalPkgDb ver
|
||||
dexists <- doesDirectoryExist db
|
||||
case dexists of
|
||||
False -> return False
|
||||
True -> do
|
||||
vers <- listCabalVersions' (Just db)
|
||||
return $ ver `elem` vers
|
||||
|
||||
listCabalVersions :: IO [Version]
|
||||
listCabalVersions = listCabalVersions' Nothing
|
||||
|
||||
-- TODO: Include sandbox? Probably only relevant for build-type:custom projects.
|
||||
listCabalVersions' :: Maybe FilePath -> IO [Version]
|
||||
listCabalVersions' mdb = do
|
||||
let mdbopt = ("--package-db="++) <$> mdb
|
||||
opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
|
||||
|
||||
catMaybes . map (fmap snd . parsePkgId . fromString) . words
|
||||
<$> readProcess "ghc-pkg" opts ""
|
||||
|
||||
-- | 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)
|
||||
Reference in New Issue
Block a user