Change the way cabal-helper is built a bit
This commit is contained in:
Daniel Gröber
parent
82bb0090c0
commit
bc71877dcf
|
|
@ -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
|
||||
|
|
@ -33,6 +33,8 @@ import Distribution.PackageDescription (PackageDescription,
|
|||
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(..),
|
||||
|
|
@ -70,26 +72,9 @@ 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)
|
||||
import CabalHelper.Common
|
||||
import CabalHelper.Types
|
||||
|
||||
usage = do
|
||||
prog <- getProgName
|
||||
|
|
@ -177,7 +162,7 @@ main = do
|
|||
[] -> removeInplaceDeps pd clbi
|
||||
opts = componentGhcOptions v lbi bi clbi' outdir
|
||||
in
|
||||
renderGhcOptions (compiler lbi) $ opts `mappend` adopts
|
||||
renderGhcOptions' lbi v $ opts `mappend` adopts
|
||||
|
||||
"ghc-src-options":flags ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
|
|
@ -200,7 +185,7 @@ main = do
|
|||
ghcOptSourcePath = ghcOptSourcePath opts
|
||||
}
|
||||
in
|
||||
renderGhcOptions comp $ opts `mappend` adopts
|
||||
renderGhcOptions' lbi v $ opts `mappend` adopts
|
||||
|
||||
"ghc-pkg-options":flags ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
|
|
@ -218,19 +203,19 @@ main = do
|
|||
ghcOptHideAllPackages = ghcOptHideAllPackages opts
|
||||
}
|
||||
in
|
||||
renderGhcOptions (compiler lbi) $ opts' `mappend` adopts
|
||||
renderGhcOptions' lbi v $ opts' `mappend` adopts
|
||||
|
||||
"entrypoints":[] -> do
|
||||
eps <- componentsMap lbi v distdir $ \c clbi bi ->
|
||||
componentEntrypoints c
|
||||
return $ componentEntrypoints c
|
||||
-- MUST append Setup component at the end otherwise CabalHelper gets
|
||||
-- confused
|
||||
let eps' = eps ++ [(GmSetupHsName, Right [ModuleName "Setup"])]
|
||||
let eps' = eps ++ [(GmSetupHsName, Right [GmModuleName "Setup"])]
|
||||
return $ Just $ GmCabalHelperEntrypoints eps'
|
||||
|
||||
"source-dirs":[] ->
|
||||
Just . GmCabalHelperStrings <$$> componentsMap lbi v distdir $$
|
||||
\c clbi bi -> hsSourceDirs bi
|
||||
\c clbi bi -> return $ hsSourceDirs bi
|
||||
|
||||
"print-lbi":[] ->
|
||||
return $ Just $ GmCabalHelperLbi $ show lbi
|
||||
|
|
@ -253,7 +238,7 @@ componentsMap :: LocalBuildInfo
|
|||
-> ( Component
|
||||
-> ComponentLocalBuildInfo
|
||||
-> BuildInfo
|
||||
-> a)
|
||||
-> IO a)
|
||||
-> IO [(GmComponentName, a)]
|
||||
componentsMap lbi v distdir f = do
|
||||
let pd = localPkgDescr lbi
|
||||
|
|
@ -265,7 +250,8 @@ componentsMap lbi v distdir f = do
|
|||
name = componentNameFromComponent c
|
||||
|
||||
l' <- readIORef lr
|
||||
writeIORef lr $ (componentNameToGm name, f c clbi bi):l'
|
||||
r <- f c clbi bi
|
||||
writeIORef lr $ (componentNameToGm name, r):l'
|
||||
reverse <$> readIORef lr
|
||||
|
||||
componentNameToGm CLibName = GmLibName
|
||||
|
|
@ -287,10 +273,10 @@ componentOutDir lbi (CTest TestSuite { testInterface = TestSuiteLibV09 _ _, ..})
|
|||
componentOutDir lbi (CBench Benchmark { benchmarkInterface = BenchmarkExeV10 _ _, ..})=
|
||||
exeOutDir lbi benchmarkName
|
||||
|
||||
gmModuleName :: C.ModuleName -> ModuleName
|
||||
gmModuleName = ModuleName . intercalate "." . components
|
||||
gmModuleName :: C.ModuleName -> GmModuleName
|
||||
gmModuleName = GmModuleName . intercalate "." . components
|
||||
|
||||
componentEntrypoints :: Component -> Either FilePath [ModuleName]
|
||||
componentEntrypoints :: Component -> Either FilePath [GmModuleName]
|
||||
componentEntrypoints (CLib Library {..})
|
||||
= Right $ map gmModuleName exposedModules
|
||||
componentEntrypoints (CExe Executable {..})
|
||||
|
|
@ -343,3 +329,12 @@ removeInplaceDeps pd clbi = let
|
|||
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
|
||||
|
|
@ -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)
|
||||
|
|
@ -14,7 +14,7 @@
|
|||
-- 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 #-}
|
||||
{-# LANGUAGE TemplateHaskell, RecordWildCards #-}
|
||||
module Main where
|
||||
|
||||
import Control.Applicative
|
||||
|
|
@ -26,11 +26,7 @@ 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
|
||||
|
|
@ -44,7 +40,7 @@ import Distribution.Text (display)
|
|||
import NotCPP.Declarations
|
||||
|
||||
import Paths_ghc_mod
|
||||
import Common
|
||||
import CabalHelper.Common
|
||||
import Utils
|
||||
|
||||
ifD [d| getExecutablePath = getProgName |]
|
||||
|
|
@ -61,21 +57,21 @@ usage = do
|
|||
\)\n"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
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 <- (parseHeader =<<) . listToMaybe . BS8.lines <$> BS.readFile cfgf
|
||||
mhdr <- getCabalConfigHeader cfgf
|
||||
case mhdr of
|
||||
Nothing -> error $ printf "\
|
||||
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 Header {..} -> do
|
||||
Just (hdrCabalVersion, _hdrCompilerVersion) -> do
|
||||
eexe <- compileHelper hdrCabalVersion
|
||||
case eexe of
|
||||
Left e -> exitWith e
|
||||
|
|
@ -92,17 +88,17 @@ 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"
|
||||
src_exists <- doesFileExist $ dir </> "CabalHelper/Main.hs"
|
||||
if exists && src_exists
|
||||
then return $ Just (dir </> "cabal-helper")
|
||||
then return $ Just dir
|
||||
else return Nothing
|
||||
|
||||
tryFindRealSrcDir :: IO (Maybe FilePath)
|
||||
tryFindRealSrcDir = do
|
||||
datadir <- getDataDir
|
||||
exists <- doesFileExist $ datadir </> "cabal-helper/Main.hs"
|
||||
exists <- doesFileExist $ datadir </> "CabalHelper/Main.hs"
|
||||
return $ if exists
|
||||
then Just $ datadir </> "cabal-helper"
|
||||
then Just datadir
|
||||
else Nothing
|
||||
|
||||
findCabalHelperSourceDir :: IO FilePath
|
||||
|
|
@ -116,35 +112,52 @@ findCabalHelperSourceDir = do
|
|||
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]
|
||||
-- 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 = 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
|
||||
-- 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 = error $ printf "\
|
||||
\Could not find $datadir/cabal-helper/Main.hs!\n\
|
||||
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\
|
||||
|
|
@ -158,6 +171,7 @@ errorNoMain datadir = error $ printf "\
|
|||
data Compile = Compile {
|
||||
cabalHelperSourceDir :: FilePath,
|
||||
cabalSourceDir :: Maybe FilePath,
|
||||
packageDb :: Maybe FilePath,
|
||||
cabalVersion :: Version,
|
||||
packageDeps :: [String]
|
||||
}
|
||||
|
|
@ -167,7 +181,7 @@ compile Compile {..} = do
|
|||
outdir <- appDataDir
|
||||
createDirectoryIfMissing True outdir
|
||||
|
||||
let exe = outdir </> "cabal-helper-" ++ showVersion (majorVer cabalVersion)
|
||||
let exe = outdir </> "cabal-helper-" ++ showVersion cabalVersion
|
||||
|
||||
recompile <-
|
||||
case cabalSourceDir of
|
||||
|
|
@ -182,24 +196,43 @@ compile Compile {..} = do
|
|||
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 </> "Main.hs" ]
|
||||
[ "--make", cabalHelperSourceDir </> "CabalHelper/Main.hs" ]
|
||||
]
|
||||
|
||||
if recompile
|
||||
then do
|
||||
(_, _, _, h) <- createProcess
|
||||
(proc "ghc" ghc_opts) { std_out = UseHandle stderr }
|
||||
rv <- waitForProcess h
|
||||
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
|
||||
|
|
@ -209,17 +242,50 @@ timeHsFiles dir = 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 :: IO [Version]
|
||||
listCabalVersions = do
|
||||
catMaybes . map (fmap snd . parsePkgId . fromString) . words
|
||||
<$> readProcess "ghc-pkg" ["list", "--simple-output", "Cabal"] ""
|
||||
listCabalVersions' :: Maybe FilePath -> IO [Version]
|
||||
listCabalVersions' mdb = do
|
||||
let mdbopt = ("--package-db="++) <$> mdb
|
||||
opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
|
||||
|
||||
data Header = Header { hdrCabalVersion :: Version
|
||||
, hdrCompilerVersion :: Version
|
||||
}
|
||||
catMaybes . map (fmap snd . parsePkgId . fromString) . words
|
||||
<$> readProcess "ghc-pkg" opts ""
|
||||
|
||||
-- | Find @version: XXX@ delcaration in a cabal file
|
||||
cabalFileVersion :: String -> Version
|
||||
|
|
@ -228,31 +294,3 @@ cabalFileVersion cabalFile = do
|
|||
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
|
||||
|
|
@ -23,6 +23,7 @@ module Language.Haskell.GhcMod.CabalHelper (
|
|||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow
|
||||
import Control.Monad
|
||||
import Data.Monoid
|
||||
import Data.List
|
||||
|
|
@ -100,5 +101,9 @@ cabalHelper = withCabal $ do
|
|||
Just (GmCabalHelperStrings ghcOpts),
|
||||
Just (GmCabalHelperStrings ghcSrcOpts),
|
||||
Just (GmCabalHelperStrings ghcPkgOpts) ] = res
|
||||
eps' = map (second $ fmap $ map md) eps
|
||||
|
||||
return $ CabalHelper eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
|
||||
return $ CabalHelper eps' srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
|
||||
|
||||
where
|
||||
md (GmModuleName mn) = mkModuleName mn
|
||||
|
|
|
|||
|
|
@ -24,7 +24,6 @@ import Data.List
|
|||
import Data.Char
|
||||
import Data.Maybe
|
||||
import Data.Traversable (traverse)
|
||||
import Types
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.IO.Unsafe
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Language.Haskell.GhcMod.Types (
|
||||
module Language.Haskell.GhcMod.Types
|
||||
, module Types
|
||||
, module CabalHelper.Types
|
||||
, ModuleName
|
||||
, mkModuleName
|
||||
, moduleNameString
|
||||
|
|
@ -11,6 +11,7 @@ module Language.Haskell.GhcMod.Types (
|
|||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
import Control.Monad.Error (Error(..))
|
||||
import Control.Exception (Exception)
|
||||
import Data.List (intercalate)
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
|
|
@ -22,7 +23,7 @@ import MonadUtils (MonadIO)
|
|||
import GHC (ModuleName, moduleNameString, mkModuleName)
|
||||
import PackageConfig (PackageConfig)
|
||||
|
||||
import Types
|
||||
import CabalHelper.Types
|
||||
|
||||
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
|
||||
-- 'GhcModT' somewhat cleaner.
|
||||
|
|
@ -95,6 +96,52 @@ data Cradle = Cradle {
|
|||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | GHC package database flags.
|
||||
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
|
||||
|
||||
-- | A single GHC command line option.
|
||||
type GHCOption = String
|
||||
|
||||
-- | An include directory for modules.
|
||||
type IncludeDir = FilePath
|
||||
|
||||
-- | A package name.
|
||||
type PackageBaseName = String
|
||||
|
||||
-- | A package version.
|
||||
type PackageVersion = String
|
||||
|
||||
-- | A package id.
|
||||
type PackageId = String
|
||||
|
||||
-- | A package's name, verson and id.
|
||||
type Package = (PackageBaseName, PackageVersion, PackageId)
|
||||
|
||||
pkgName :: Package -> PackageBaseName
|
||||
pkgName (n,_,_) = n
|
||||
|
||||
pkgVer :: Package -> PackageVersion
|
||||
pkgVer (_,v,_) = v
|
||||
|
||||
pkgId :: Package -> PackageId
|
||||
pkgId (_,_,i) = i
|
||||
|
||||
showPkg :: Package -> String
|
||||
showPkg (n,v,_) = intercalate "-" [n,v]
|
||||
|
||||
showPkgId :: Package -> String
|
||||
showPkgId (n,v,i) = intercalate "-" [n,v,i]
|
||||
|
||||
-- | Haskell expression.
|
||||
type Expression = String
|
||||
|
||||
-- | Module name.
|
||||
type ModuleString = String
|
||||
|
||||
-- | A Module
|
||||
type Module = [String]
|
||||
|
||||
|
||||
data GmLogLevel = GmPanic
|
||||
| GmException
|
||||
| GmError
|
||||
|
|
@ -140,21 +187,6 @@ instance Read ModuleName where
|
|||
(m,t) <- readsPrec (app_prec+1) s]) r
|
||||
where app_prec = 10
|
||||
|
||||
|
||||
--- \ / These types MUST be in sync with the copies in cabal-helper/Main.hs
|
||||
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 cabal-helper/Main.hs
|
||||
|
||||
data GhcModError
|
||||
= GMENoMsg
|
||||
-- ^ Unknown error
|
||||
|
|
|
|||
|
|
@ -1,41 +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/>.
|
||||
|
||||
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'
|
||||
|
|
@ -23,7 +23,7 @@ Cabal-Version: >= 1.16
|
|||
Build-Type: Custom
|
||||
Data-Files: elisp/Makefile
|
||||
elisp/*.el
|
||||
cabal-helper/*.hs
|
||||
CabalHelper/*.hs
|
||||
|
||||
Extra-Source-Files: ChangeLog
|
||||
SetupCompat.hs
|
||||
|
|
@ -65,8 +65,8 @@ Library
|
|||
Exposed-Modules: Language.Haskell.GhcMod
|
||||
Language.Haskell.GhcMod.Internal
|
||||
Other-Modules: Paths_ghc_mod
|
||||
Types
|
||||
Utils
|
||||
CabalHelper.Types
|
||||
Language.Haskell.GhcMod.Boot
|
||||
Language.Haskell.GhcMod.Browse
|
||||
Language.Haskell.GhcMod.CaseSplit
|
||||
|
|
@ -177,10 +177,10 @@ Executable ghc-modi
|
|||
Executable cabal-helper-wrapper
|
||||
Default-Language: Haskell2010
|
||||
Other-Extensions: TemplateHaskell
|
||||
Main-Is: Wrapper.hs
|
||||
Main-Is: CabalHelper/Wrapper.hs
|
||||
Other-Modules: Paths_ghc_mod
|
||||
GHC-Options: -Wall
|
||||
HS-Source-Dirs: cabal-helper, .
|
||||
HS-Source-Dirs: .
|
||||
X-Install-Target: $libexecdir
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
, bytestring
|
||||
|
|
@ -207,14 +207,13 @@ Test-Suite doctest
|
|||
Test-Suite spec
|
||||
Default-Language: Haskell2010
|
||||
Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
|
||||
ConstraintKinds, FlexibleContexts, OverloadedStrings
|
||||
ConstraintKinds, FlexibleContexts
|
||||
Main-Is: Main.hs
|
||||
Hs-Source-Dirs: test, .
|
||||
Ghc-Options: -Wall -fno-warn-deprecations
|
||||
CPP-Options: -DSPEC=1
|
||||
Type: exitcode-stdio-1.0
|
||||
Other-Modules: Paths_ghc_mod
|
||||
Types
|
||||
Dir
|
||||
Spec
|
||||
TestUtils
|
||||
|
|
|
|||
Loading…
Reference in New Issue