diff --git a/CabalHelper/Common.hs b/CabalHelper/Common.hs deleted file mode 100644 index 884c486..0000000 --- a/CabalHelper/Common.hs +++ /dev/null @@ -1,98 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- 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 . - -{-# 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 diff --git a/CabalHelper/GuessGhc.hs b/CabalHelper/GuessGhc.hs deleted file mode 100644 index 0827456..0000000 --- a/CabalHelper/GuessGhc.hs +++ /dev/null @@ -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) diff --git a/CabalHelper/Main.hs b/CabalHelper/Main.hs deleted file mode 100644 index ee1ae38..0000000 --- a/CabalHelper/Main.hs +++ /dev/null @@ -1,344 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- 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 . - -{-# 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 diff --git a/CabalHelper/Types.hs b/CabalHelper/Types.hs deleted file mode 100644 index 273df7d..0000000 --- a/CabalHelper/Types.hs +++ /dev/null @@ -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) diff --git a/CabalHelper/Wrapper.hs b/CabalHelper/Wrapper.hs deleted file mode 100644 index 34f5f9c..0000000 --- a/CabalHelper/Wrapper.hs +++ /dev/null @@ -1,418 +0,0 @@ --- ghc-mod: Making Haskell development *more* fun --- Copyright (C) 2015 Daniel Gröber --- --- 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 . - -{-# 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) diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 68d26f9..8264376 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -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 diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index f674157..53a8e8f 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -15,21 +15,18 @@ -- along with this program. If not, see . 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 diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 9d7f979..8de1a8d 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -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 } diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index efbb98f..ac41f71 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -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" } diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs index a6a8e0e..57e39a8 100644 --- a/Language/Haskell/GhcMod/Pretty.hs +++ b/Language/Haskell/GhcMod/Pretty.hs @@ -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" diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 994c687..498b41b 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 352b658..5e43d80 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -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) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 2d7221e..8f51037 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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