hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Factor out cabal-helper into a package

Browse Source
This commit is contained in:
Daniel Gröber 2015-03-15 20:48:55 +01:00
parent a97e07065e
commit 90d9577f8d
13 changed files with 90 additions and 1082 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
CabalHelper/Common.hs
View File

@ -1,98 +0,0 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
module CabalHelper.Common where
import Control.Applicative
import Control.Exception as E
import Control.Monad
import Data.List
import Data.Maybe
import Data.Version
import Data.Typeable
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import System.Environment
import System.IO
import System.Exit
import 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 `E.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 = case filter ((=="") . snd) $ readP_to_S p i of
(a,""):[] -> a
_ -> error $ "Error parsing: " ++ show i

83
CabalHelper/GuessGhc.hs
View File

@ -1,83 +0,0 @@
module CabalHelper.GuessGhc (guessToolFromGhcPath) where
import Data.Maybe
import Data.Char
import Distribution.Simple.BuildPaths
import System.Directory
import System.FilePath
-- Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren,
-- Bjorn Bringert, Krasimir Angelov,
-- Malcolm Wallace, Ross Patterson, Ian Lynagh,
-- Duncan Coutts, Thomas Schilling,
-- Johan Tibell, Mikhail Glushenkov
-- All rights reserved.
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
-- * Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
-- * Redistributions in binary form must reproduce the above
-- copyright notice, this list of conditions and the following
-- disclaimer in the documentation and/or other materials provided
-- with the distribution.
-- * Neither the name of Isaac Jones nor the names of other
-- contributors may be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
guessToolFromGhcPath :: FilePath -- ^ Tool name
-> FilePath -- ^ GHC exe path
-> IO (Maybe FilePath)
guessToolFromGhcPath toolname ghcPath
= do let
path = ghcPath
dir = takeDirectory path
versionSuffix = takeVersionSuffix (dropExeExtension path)
guessNormal = dir </> toolname <.> exeExtension
guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)
<.> exeExtension
guessVersioned = dir </> (toolname ++ versionSuffix)
<.> exeExtension
guesses | null versionSuffix = [guessNormal]
| otherwise = [guessGhcVersioned,
guessVersioned,
guessNormal]
exists <- mapM doesFileExist guesses
return $ listToMaybe [ file | (file, True) <- zip guesses exists ]
where takeVersionSuffix :: FilePath -> String
takeVersionSuffix = takeWhileEndLE isSuffixChar
isSuffixChar :: Char -> Bool
isSuffixChar c = isDigit c || c == '.' || c == '-'
dropExeExtension :: FilePath -> FilePath
dropExeExtension filepath =
case splitExtension filepath of
(filepath', extension) | extension == exeExtension -> filepath'
| otherwise -> filepath
-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but
-- is usually faster (as well as being easier to read).
takeWhileEndLE :: (a -> Bool) -> [a] -> [a]
takeWhileEndLE p = fst . foldr go ([], False)
where
go x (rest, done)
| not done && p x = (x:rest, False)
| otherwise = (rest, True)

344
CabalHelper/Main.hs
View File

@ -1,344 +0,0 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, 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)
#if CABAL_MAJOR == 1 && CABAL_MINOR >= 22
import Distribution.Utils.NubList
#endif
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) . lookup "GHC_MOD_DEBUG" <$> getEnvironment
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 ++ (otherModules libBuildInfo)
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
View File

@ -1,18 +0,0 @@
{-# 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)

418
CabalHelper/Wrapper.hs
View File

@ -1,418 +0,0 @@
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE TemplateHaskell, RecordWildCards, FlexibleContexts #-}
module Main where
import Control.Applicative
import Control.Arrow
import Control.Exception as E
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Char
import Data.List
import Data.Maybe
import Data.String
import Data.Version
import Text.Printf
import System.Console.GetOpt
import System.Environment
import System.Directory
import System.FilePath
import System.Process
import System.Exit
import System.IO
import Distribution.System (buildPlatform)
import Distribution.Text (display)
import NotCPP.Declarations
import Paths_ghc_mod
import CabalHelper.Common
import CabalHelper.GuessGhc
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 ( print-exe | [CABAL_HELPER_ARGS...] ) )\n"
data Options = Options {
ghcProgram :: FilePath
, ghcPkgProgram :: FilePath
, cabalProgram :: FilePath
}
defaultOptions :: Options
defaultOptions = Options "ghc" "ghc-pkg" "cabal"
globalArgSpec :: [OptDescr (Options -> Options)]
globalArgSpec =
[ option "" ["with-ghc"] "GHC executable to use" $
reqArg "PROG" $ \p o -> o { ghcProgram = p }
, option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
reqArg "PROG" $ \p o -> o { ghcPkgProgram = p }
, option "" ["with-cabal"] "cabal-install executable to use" $
reqArg "PROG" $ \p o -> o { cabalProgram = p }
]
where
option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
option s l udsc dsc = Option s l dsc udsc
reqArg :: String -> (String -> a) -> ArgDescr a
reqArg udsc dsc = ReqArg dsc udsc
parseCommandArgs :: Options -> [String] -> (Options, [String])
parseCommandArgs opts argv
= case getOpt Permute globalArgSpec argv of
(o,r,[]) -> (foldr id opts o, r)
(_,_,errs) ->
panic $ "Parsing command options failed: " ++ concat errs
guessProgramPaths :: Options -> IO Options
guessProgramPaths opts = do
if not (same ghcProgram opts dopts) && same ghcPkgProgram opts dopts
then do
mghcPkg <- guessToolFromGhcPath "ghc-pkg" (ghcProgram opts)
return opts {
ghcPkgProgram = fromMaybe (ghcPkgProgram opts) mghcPkg
}
else return opts
where
same f o o' = f o == f o'
dopts = defaultOptions
main :: IO ()
main = handlePanic $ do
(opts', args) <- parseCommandArgs defaultOptions <$> getArgs
opts <- guessProgramPaths opts'
case args of
[] -> usage
"--help":[] -> usage
"print-appdatadir":[] -> putStrLn =<< appDataDir
"print-build-platform":[] -> putStrLn $ display buildPlatform
distdir:args' -> do
cfgf <- canonicalizePath (distdir </> "setup-config")
mhdr <- getCabalConfigHeader cfgf
case mhdr of
Nothing -> panic $ printf "\
\Could not read Cabal's persistent setup configuration header\n\
\- Check first line of: %s\n\
\- Maybe try: $ cabal configure" cfgf
Just (hdrCabalVersion, _hdrCompilerVersion) -> do
eexe <- compileHelper opts hdrCabalVersion
case eexe of
Left e -> exitWith e
Right exe ->
case args' of
"print-exe":_ -> putStrLn exe
_ -> do
(_,_,_,h) <- createProcess $ proc exe args
exitWith =<< waitForProcess h
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 :: Options -> Version -> IO (Either ExitCode FilePath)
compileHelper opts cabalVer = do
chdir <- findCabalHelperSourceDir
run [ Right <$> MaybeT (cachedExe cabalVer chdir)
, compileGlobal chdir
, cachedCabalPkg chdir
, compileCabalSource chdir
, MaybeT (Just <$> compileSandbox chdir)
]
where
run actions = fromJust <$> runMaybeT (msum actions)
-- | Check if this version is globally available
compileGlobal :: FilePath -> MaybeT IO (Either ExitCode FilePath)
compileGlobal chdir = do
_ <- MaybeT $ find (== cabalVer) <$> listCabalVersions opts
liftIO $ compileWithPkg chdir Nothing
-- | Check if we already compiled this version of cabal into a private
-- package-db
cachedCabalPkg :: FilePath -> MaybeT IO (Either ExitCode FilePath)
cachedCabalPkg chdir = do
db_exists <- liftIO $ cabalPkgDbExists opts cabalVer
case db_exists of
False -> mzero
True -> liftIO $ do
db <- cabalPkgDb opts cabalVer
compileWithPkg chdir (Just db)
-- | See if we're in a cabal source tree
compileCabalSource :: FilePath -> MaybeT IO (Either ExitCode FilePath)
compileCabalSource chdir = do
couldBeSrcDir <- liftIO $ takeDirectory <$> getDataDir
let cabalFile = couldBeSrcDir </> "Cabal.cabal"
cabal <- liftIO $ doesFileExist cabalFile
case cabal of
False -> mzero
True -> liftIO $ do
ver <- cabalFileVersion <$> readFile cabalFile
compileWithCabalTree chdir ver couldBeSrcDir
-- | Compile the requested cabal version into an isolated package-db
compileSandbox :: FilePath -> IO (Either ExitCode FilePath)
compileSandbox chdir = do
db <- installCabal opts cabalVer `E.catch`
\(SomeException _) -> errorInstallCabal cabalVer
compileWithPkg chdir (Just db)
compileWithCabalTree chdir ver srcDir =
compile opts $ Compile chdir (Just srcDir) Nothing ver []
compileWithPkg chdir mdb =
compile opts $ 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"
-- where
-- sver = showVersion cabalVer
errorInstallCabal :: Version -> a
errorInstallCabal cabalVer = panic $ printf "\
\Installing Cabal version %s failed.\n\
\n\
\You have two choices now:\n\
\- Either you install this version of Cabal in your globa/luser package-db\n\
\ somehow\n\
\n\
\- Or you can see if you can update your cabal-install to use a different\n\
\ version of the Cabal library that we can build with:\n\
\ $ cabal install cabal-install --constraint 'Cabal > %s'\n\
\n\
\To check the version cabal-install is currently using try:\n\
\ $ cabal --version\n" 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 :: Options -> Compile -> IO (Either ExitCode FilePath)
compile Options {..} Compile {..} = do
outdir <- appDataDir
createDirectoryIfMissing True outdir
exe <- exePath cabalVersion
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" ]
]
-- TODO: touch exe after, ghc doesn't do that if the input files didn't
-- actually change
rv <- callProcessStderr' Nothing ghcProgram ghc_opts
return $ case rv of
ExitSuccess -> Right exe
e@(ExitFailure _) -> Left e
exePath :: Version -> IO FilePath
exePath cabalVersion = do
outdir <- appDataDir
return $ outdir </> "cabal-helper-" ++ showVersion cabalVersion
cachedExe :: Version -> FilePath -> IO (Maybe FilePath)
cachedExe cabalVersion chdir = do
exe <- exePath cabalVersion
exists <- doesFileExist exe
case exists of
False -> return Nothing
True -> do
texe <- timeFile exe
tsrcs <- mapM timeFile srcFiles
return $ if any (texe <) tsrcs then Nothing else Just exe
where
srcFiles =
map ((chdir </> "CabalHelper") </>) ["Main.hs", "Common.hs", "Types.hs"]
callProcessStderr' :: Maybe FilePath -> FilePath -> [String] -> IO ExitCode
callProcessStderr' mwd exe args = do
(_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr
, cwd = mwd }
waitForProcess h
callProcessStderr :: Maybe FilePath -> FilePath -> [String] -> IO ()
callProcessStderr mwd exe args = do
rv <- callProcessStderr' mwd exe args
case rv of
ExitSuccess -> return ()
ExitFailure v -> processFailedException "callProcessStderr" exe args v
processFailedException :: String -> String -> [String] -> Int -> IO a
processFailedException fn exe args rv =
panic $ concat [fn, ": ", exe, " "
, intercalate " " (map show args)
, " (exit " ++ show rv ++ ")"]
installCabal :: Options -> Version -> IO FilePath
installCabal opts ver = do
appdir <- appDataDir
hPutStr stderr $ printf "\
\cabal-helper-wrapper: Installing a private copy of Cabal, this might take a\n\
\while but will only happen once per Cabal version.\n\
\\n\
\If anything goes horribly wrong just delete this directory and try again:\n\
\ %s\n\
\\n\
\If you want to avoid this automatic installation altogether install version\n\
\%s of Cabal manually (into your use or global package-db):\n\
\ $ cabal install Cabal-%s\n\
\..." appdir (showVersion ver) (showVersion ver)
db <- createPkgDb opts ver
callProcessStderr (Just "/") (cabalProgram opts) $ concat
[
[ "--package-db=clear"
, "--package-db=global"
, "--package-db=" ++ db
, "--prefix=" ++ db </> "prefix"
, "-v0"
, "--with-ghc=" ++ ghcProgram opts
]
, if ghcPkgProgram opts /= ghcPkgProgram defaultOptions
then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ]
else []
, [ "install", "Cabal-"++showVersion ver ]
]
hPutStrLn stderr "Done"
return db
ghcVersion :: Options -> IO Version
ghcVersion Options {..} = do
parseVer . trim <$> readProcess ghcProgram ["--numeric-version"] ""
ghcPkgVersion :: Options -> IO Version
ghcPkgVersion Options {..} = do
parseVer . trim <$> readProcess ghcPkgProgram ["--numeric-version"] ""
trim :: String -> String
trim = dropWhileEnd isSpace
createPkgDb :: Options -> Version -> IO FilePath
createPkgDb opts@Options {..} ver = do
db <- cabalPkgDb opts ver
exists <- doesDirectoryExist db
when (not exists) $ callProcessStderr Nothing ghcPkgProgram ["init", db]
return db
cabalPkgDb :: Options -> Version -> IO FilePath
cabalPkgDb opts ver = do
appdir <- appDataDir
ghcVer <- ghcVersion opts
return $ appdir </> "Cabal-" ++ showVersion ver ++ "-db-" ++ showVersion ghcVer
cabalPkgDbExists :: Options -> Version -> IO Bool
cabalPkgDbExists opts ver = do
db <- cabalPkgDb opts ver
dexists <- doesDirectoryExist db
case dexists of
False -> return False
True -> do
vers <- listCabalVersions' opts (Just db)
return $ ver `elem` vers
listCabalVersions :: Options -> IO [Version]
listCabalVersions opts = listCabalVersions' opts Nothing
-- TODO: Include sandbox? Probably only relevant for build-type:custom projects.
listCabalVersions' :: Options -> Maybe FilePath -> IO [Version]
listCabalVersions' Options {..} mdb = do
let mdbopt = ("--package-db="++) <$> mdb
opts = ["list", "--simple-output", "Cabal"] ++ maybeToList mdbopt
catMaybes . map (fmap snd . parsePkgId . fromString) . words
<$> readProcess ghcPkgProgram 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)

2
Language/Haskell/GhcMod.hs
View File

@ -58,6 +58,7 @@ module Language.Haskell.GhcMod (
import Language.Haskell.GhcMod.Boot
import Language.Haskell.GhcMod.Browse
import Language.Haskell.GhcMod.CaseSplit
import Language.Haskell.GhcMod.CabalHelper
import Language.Haskell.GhcMod.Check
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Debug
@ -72,3 +73,4 @@ import Language.Haskell.GhcMod.Modules
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.PkgDoc
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Target

108
Language/Haskell/GhcMod/CabalHelper.hs
View File

@ -15,21 +15,18 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.CabalHelper (
CabalHelper(..)
, getComponents
, getGhcOptions
getComponents
, getGhcPkgOptions
, cabalHelper
) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Data.Monoid
import Data.List
import Language.Haskell.GhcMod.Types
import Distribution.Helper
import qualified Language.Haskell.GhcMod.Types as T
import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
cabalProgram)
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error as E
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import Language.Haskell.GhcMod.PathsAndFiles
@ -37,26 +34,42 @@ import System.FilePath
-- | Only package related GHC options, sufficient for things that don't need to
-- access home modules
getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
getGhcPkgOptions = chGhcPkgOptions `liftM` cabalHelper
getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(ChComponentName, [GHCOption])]
getGhcPkgOptions = do
Cradle {..} <- cradle
let distdir = cradleRootDir </> "dist"
runQuery distdir ghcPkgOptions
getGhcOptions :: (MonadIO m, GmEnv m) => m [(GmComponentName, [GHCOption])]
getGhcOptions = chGhcOptions `liftM` cabalHelper
helperProgs :: Options -> Programs
helperProgs opts = Programs {
cabalProgram = T.cabalProgram opts,
ghcProgram = T.ghcProgram opts,
ghcPkgProgram = T.ghcPkgProgram opts
}
-- | Primary interface to cabal-helper and intended single entrypoint to
-- constructing 'GmComponent's
--
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
-- 'resolveGmComponents'.
getComponents :: (MonadIO m, GmEnv m)
=> m [GmComponent (Either FilePath [ModuleName])]
getComponents = cabalHelper >>= \CabalHelper {..} -> return $ let
([(scn, sep)], eps) = partition ((GmSetupHsName ==) . fst) chEntrypoints
sc = GmComponent scn [] [] sep sep ["."] mempty
cs = flip map (zip4 eps chGhcOptions chGhcSrcOptions chSourceDirs) $
\((cn, ep), (_, opts), (_, srcOpts), (_, srcDirs)) ->
getComponents :: (MonadIO m, GmEnv m) => m [GmComponent ChEntrypoint]
getComponents = withCabal $ do
Cradle {..} <- cradle
let distdir = cradleRootDir </> "dist"
opt <- options
runQuery' (helperProgs opt) distdir $ do
q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs
return $ flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) ->
GmComponent cn opts srcOpts ep ep srcDirs mempty
in sc:cs
where
join4 a b c = join' a . join' b . join' c
join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]
join' lb lc = [ (a, (b, c))
| (a, b) <- lb
, (a', c) <- lc
, a == a'
]
withCabal :: (MonadIO m, GmEnv m) => m a -> m a
withCabal action = do
@ -65,58 +78,11 @@ withCabal action = do
liftIO $ whenM (isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
withDirectory_ (cradleRootDir crdl) $ do
let progOpts =
[ "--with-ghc=" ++ ghcProgram opts ]
[ "--with-ghc=" ++ T.ghcProgram opts ]
-- Only pass ghc-pkg if it was actually set otherwise we
-- might break cabal's guessing logic
++ if ghcPkgProgram opts /= ghcPkgProgram defaultOptions
then [ "--with-ghc-pkg=" ++ ghcPkgProgram opts ]
++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
else []
void $ readProcess (cabalProgram opts) ("configure":progOpts) ""
void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
action
data CabalHelper = CabalHelper {
chEntrypoints :: [(GmComponentName, Either FilePath [ModuleName])],
chSourceDirs :: [(GmComponentName, [String])],
chGhcOptions :: [(GmComponentName, [String])],
chGhcSrcOptions :: [(GmComponentName, [String])],
chGhcPkgOptions :: [(GmComponentName, [String])]
} deriving (Show)
cabalHelper :: (MonadIO m, GmEnv m) => m CabalHelper
cabalHelper = withCabal $ do
Cradle {..} <- cradle
Options {..} <- options
let progArgs = [ "--with-ghc=" ++ ghcProgram
, "--with-ghc-pkg=" ++ ghcPkgProgram
, "--with-cabal=" ++ cabalProgram
]
let args = [ "entrypoints"
, "source-dirs"
, "ghc-options"
, "ghc-src-options"
, "ghc-pkg-options"
] ++ progArgs
distdir = cradleRootDir </> "dist"
res <- liftIO $ do
exe <- findLibexecExe "cabal-helper-wrapper"
hexe <- readProcess exe ([distdir, "print-exe"] ++ progArgs) ""
cached cradleRootDir (cabalHelperCache hexe args) $ do
out <- readProcess exe (distdir:args) ""
evaluate (read out) `E.catch`
\(SomeException _) -> error "cabalHelper: read failed"
let [ Just (GmCabalHelperEntrypoints eps),
Just (GmCabalHelperStrings srcDirs),
Just (GmCabalHelperStrings ghcOpts),
Just (GmCabalHelperStrings ghcSrcOpts),
Just (GmCabalHelperStrings ghcPkgOpts) ] = res
eps' = map (second $ fmap $ map md) eps
return $ CabalHelper eps' srcDirs ghcOpts ghcSrcOpts ghcPkgOpts
where
md (GmModuleName mn) = mkModuleName mn

3
Language/Haskell/GhcMod/Monad/Types.hs
View File

@ -103,6 +103,7 @@ import Data.Map (Map, empty)
import Data.Maybe
import Data.Monoid
import Data.IORef
import Distribution.Helper
import MonadUtils (MonadIO(..))
@ -128,7 +129,7 @@ data GmGhcSession = GmGhcSession {
data GhcModState = GhcModState {
gmGhcSession :: !(Maybe GmGhcSession)
, gmComponents :: !(Map GmComponentName (GmComponent (Set ModulePath)))
, gmComponents :: !(Map ChComponentName (GmComponent (Set ModulePath)))
, gmCompilerMode :: !CompilerMode
}

12
Language/Haskell/GhcMod/PathsAndFiles.hs
View File

@ -23,7 +23,9 @@ import Control.Monad.Trans.Maybe
import Data.List
import Data.Char
import Data.Maybe
import Data.Version
import Data.Traversable (traverse)
import Distribution.Helper
import System.Directory
import System.FilePath
import System.IO.Unsafe
@ -233,11 +235,11 @@ cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $
packageCache :: String
packageCache = "package.cache"
cabalHelperCache ::
FilePath -> [String] -> Cached [String] [Maybe GmCabalHelperResponse]
cabalHelperCache cabalHelperExe cmds = Cached {
inputFiles = [cabalHelperExe, setupConfigPath],
inputData = cmds,
cabalHelperCache :: Version -> [String]
-> Cached (Version, [String]) [GmComponent ChEntrypoint]
cabalHelperCache cabalHelperVer cmds = Cached {
inputFiles = [setupConfigPath],
inputData = (cabalHelperVer, cmds),
cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"
}

13
Language/Haskell/GhcMod/Pretty.hs
View File

@ -19,6 +19,7 @@ module Language.Haskell.GhcMod.Pretty where
import Control.Arrow hiding ((<+>))
import Data.Char
import Data.List
import Distribution.Helper
import Text.PrettyPrint
import Language.Haskell.GhcMod.Types
@ -29,12 +30,12 @@ docStyle = style { ribbonsPerLine = 1.2 }
gmRenderDoc :: Doc -> String
gmRenderDoc = renderStyle docStyle
gmComponentNameDoc :: GmComponentName -> Doc
gmComponentNameDoc GmSetupHsName = text $ "Setup.hs"
gmComponentNameDoc GmLibName = text $ "library"
gmComponentNameDoc (GmExeName n) = text $ "exe:" ++ n
gmComponentNameDoc (GmTestName n) = text $ "test:" ++ n
gmComponentNameDoc (GmBenchName n) = text $ "bench:" ++ n
gmComponentNameDoc :: ChComponentName -> Doc
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs"
gmComponentNameDoc ChLibName = text $ "library"
gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n
gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n
gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n
gmLogLevelDoc :: GmLogLevel -> Doc
gmLogLevelDoc GmPanic = text "PANIC"

37
Language/Haskell/GhcMod/Target.hs
View File

@ -46,6 +46,7 @@ import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Distribution.Helper
import System.Directory
import System.FilePath
@ -185,9 +186,9 @@ targetGhcOptions crdl sefnmn = do
let cn = pickComponent candidates
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
moduleComponents :: Map GmComponentName (GmComponent (Set ModulePath))
moduleComponents :: Map ChComponentName (GmComponent (Set ModulePath))
-> Either FilePath ModuleName
-> Set GmComponentName
-> Set ChComponentName
moduleComponents m efnmn =
foldr' Set.empty m $ \c s ->
let
@ -203,10 +204,9 @@ moduleComponents m efnmn =
foldr' b as f = Map.foldr f b as
pickComponent :: Set GmComponentName -> GmComponentName
pickComponent :: Set ChComponentName -> ChComponentName
pickComponent scn = Set.findMin scn
packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption]
packageGhcOptions = do
crdl <- cradle
@ -223,14 +223,16 @@ sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts
resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
=> Maybe [Either FilePath ModuleName] -- ^ Updated modules
-> GmComponent (Either FilePath [ModuleName])
-> GmComponent ChEntrypoint
-> m (GmComponent (Set ModulePath))
resolveGmComponent mums c@GmComponent {..} =
withLightHscEnv gmcGhcSrcOpts $ \env -> do
let srcDirs = gmcSourceDirs
mg = gmcHomeModuleGraph
let eps = either (return . Left) (map Right) gmcEntrypoints
Cradle { cradleRootDir } <- cradle
eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
simp <- liftIO $ resolveEntrypoints env srcDirs eps
sump <- liftIO $ case mums of
Nothing -> return simp
@ -263,11 +265,30 @@ resolveEntrypoints env srcDirs ms =
findFile' dirs file =
mconcat <$> mapM (mightExist . (</>file)) dirs
resolveChEntrypoints ::
FilePath -> ChEntrypoint -> IO [Either FilePath ModuleName]
resolveChEntrypoints _ (ChLibEntrypoint em om) =
return $ map (Right . chModToMod) (em ++ om)
resolveChEntrypoints _ (ChExeEntrypoint main om) =
return $ [Left main] ++ map (Right . chModToMod) om
resolveChEntrypoints srcDir ChSetupEntrypoint = do
shs <- doesFileExist (srcDir </> "Setup.hs")
slhs <- doesFileExist (srcDir </> "Setup.lhs")
return $ case (shs, slhs) of
(True, _) -> [Left "Setup.hs"]
(_, True) -> [Left "Setup.lhs"]
(False, False) -> []
chModToMod :: ChModuleName -> ModuleName
chModToMod (ChModuleName mn) = mkModuleName mn
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
=> Maybe [Either FilePath ModuleName]
-- ^ Updated modules
-> [GmComponent (Either FilePath [ModuleName])]
-> m (Map GmComponentName (GmComponent (Set ModulePath)))
-> [GmComponent ChEntrypoint]
-> m (Map ChComponentName (GmComponent (Set ModulePath)))
resolveGmComponents mumns cs = do
s <- gmsGet
m' <- foldrM' (gmComponents s) cs $ \c m -> do

12
Language/Haskell/GhcMod/Types.hs
View File

@ -2,7 +2,6 @@
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
module Language.Haskell.GhcMod.Types (
module Language.Haskell.GhcMod.Types
, module CabalHelper.Types
, ModuleName
, mkModuleName
, moduleNameString
@ -18,13 +17,12 @@ import Data.Set (Set)
import qualified Data.Set as Set
import Data.Monoid
import Data.Typeable (Typeable)
import Distribution.Helper
import Exception (ExceptionMonad)
import MonadUtils (MonadIO)
import GHC (ModuleName, moduleNameString, mkModuleName)
import PackageConfig (PackageConfig)
import CabalHelper.Types
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
-- 'GhcModT' somewhat cleaner.
--
@ -168,10 +166,10 @@ instance Monoid GmModuleGraph where
GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
data GmComponent eps = GmComponent {
gmcName :: GmComponentName,
gmcName :: ChComponentName,
gmcGhcOpts :: [GHCOption],
gmcGhcSrcOpts :: [GHCOption],
gmcRawEntrypoints :: Either FilePath [ModuleName],
gmcRawEntrypoints :: ChEntrypoint,
gmcEntrypoints :: eps,
gmcSourceDirs :: [FilePath],
gmcHomeModuleGraph :: GmModuleGraph
@ -204,10 +202,10 @@ data GhcModError
| GMECabalFlags GhcModError
-- ^ Retrieval of the cabal configuration flags failed.
| GMECabalComponent GmComponentName
| GMECabalComponent ChComponentName
-- ^ Cabal component could not be found
| GMECabalCompAssignment [(Either FilePath ModuleName, Set GmComponentName)]
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
-- ^ Could not find a consistent component assignment for modules
| GMEProcess String [String] (Either (String, String, Int) GhcModError)

24
ghc-mod.cabal
View File

@ -24,7 +24,6 @@ Cabal-Version: >= 1.16
Build-Type: Custom
Data-Files: elisp/Makefile
elisp/*.el
CabalHelper/*.hs
Extra-Source-Files: ChangeLog
SetupCompat.hs
@ -78,7 +77,6 @@ Library
Language.Haskell.GhcMod.Internal
Other-Modules: Paths_ghc_mod
Utils
CabalHelper.Types
Language.Haskell.GhcMod.Boot
Language.Haskell.GhcMod.Browse
Language.Haskell.GhcMod.CaseSplit
@ -116,6 +114,7 @@ Library
Build-Depends: base >= 4.0 && < 5
, bytestring
, containers
, cabal-helper >= 0.3
, deepseq
, directory
, filepath
@ -186,27 +185,6 @@ Executable ghc-modi
, ghc
, ghc-mod
Executable cabal-helper-wrapper
Default-Language: Haskell2010
Other-Extensions: TemplateHaskell
Main-Is: CabalHelper/Wrapper.hs
Other-Modules: Paths_ghc_mod
GHC-Options: -Wall
HS-Source-Dirs: .
X-Install-Target: $libexecdir
Build-Depends: base >= 4.0 && < 5
, bytestring
, binary
, containers
, Cabal >= 1.14
, directory
, filepath
, old-time
, process
, transformers
, template-haskell
, time
Test-Suite doctest
Type: exitcode-stdio-1.0
Default-Language: Haskell2010