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

Let Cabal determine the package-db stack

This commit is contained in:
Daniel Gröber 2015-08-07 06:47:34 +02:00
parent f85327a1b6
commit 8439f12cb0
21 changed files with 247 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,23 +15,28 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.CabalHelper (
getComponents
module Language.Haskell.GhcMod.CabalHelper
#ifndef SPEC
( getComponents
, getGhcMergedPkgOptions
) where
, getPackageDbStack
)
#endif
where
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Monoid
import Data.Version
import Data.Serialize (Serialize)
import Data.Traversable
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.Utils
import Language.Haskell.GhcMod.World
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Logging
import System.FilePath
@ -50,12 +55,35 @@ getGhcMergedPkgOptions = chCached Cached {
return ([setupConfigPath], opts)
}
helperProgs :: Options -> Programs
helperProgs opts = Programs {
cabalProgram = T.cabalProgram opts,
ghcProgram = T.ghcProgram opts,
ghcPkgProgram = T.ghcPkgProgram opts
}
parseCustomPackageDb :: String -> [GhcPkgDb]
parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src
where
parsePkgDb "global" = GlobalDb
parsePkgDb "user" = UserDb
parsePkgDb s = PackageDb s
getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb])
getCustomPkgDbStack = do
mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle
return $ parseCustomPackageDb <$> mCusPkgDbFile
getPackageDbStack :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb]
getPackageDbStack = do
mCusPkgStack <- getCustomPkgDbStack
flip fromMaybe mCusPkgStack <$> getPackageDbStack'
getPackageDbStack' :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb]
getPackageDbStack' = chCached Cached {
cacheFile = pkgDbStackCacheFile,
cachedAction = \ _tcf (progs, root, _) _ma -> do
dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs root packageDbStack
return ([setupConfigPath, sandboConfigFile], dbs)
}
chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb
chPkgToGhcPkg ChPkgGlobal = GlobalDb
chPkgToGhcPkg ChPkgUser = UserDb
chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
-- | Primary interface to cabal-helper and intended single entrypoint to
-- constructing 'GmComponent's
@ -66,23 +94,6 @@ getComponents :: (Applicative m, IOish m, GmEnv m, GmLog m)
=> m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached cabalHelperCache
chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a)
=> Cached m (Programs, FilePath, (Version, [Char])) a -> m a
chCached c = do
root <- cradleRootDir <$> cradle
d <- cacheInputData root
withCabal $ cached root c d
where
cacheInputData root = do
opt <- options
return $ ( helperProgs opt
, root </> "dist"
, (gmVer, chVer)
)
gmVer = GhcMod.version
chVer = VERSION_cabal_helper
cabalHelperCache
:: (Functor m, Applicative m, MonadIO m)
=> Cached m (Programs, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint]
@ -116,18 +127,37 @@ withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a
withCabal action = do
crdl <- cradle
opts <- options
whenM (liftIO $ isSetupConfigOutOfDate <$> getCurrentWorld crdl) $
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mCusPkgDbStack <- getCustomPkgDbStack
pkgDbStackOutOfSync <-
case mCusPkgDbStack of
Just cusPkgDbStack -> do
pkgDb <- runQuery' (helperProgs opts) (cradleRootDir crdl </> "dist") $
map chPkgToGhcPkg <$> packageDbStack
return $ pkgDb /= cusPkgDbStack
Nothing -> return False
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $
gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
when pkgDbStackOutOfSync $
gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project."
when (isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync) $
withDirectory_ (cradleRootDir crdl) $ do
let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl)
progOpts =
let progOpts =
[ "--with-ghc=" ++ T.ghcProgram opts ]
-- Only pass ghc-pkg if it was actually set otherwise we
-- might break cabal's guessing logic
++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
else []
++ pkgDbArgs
gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
++ map pkgDbArg cusPkgStack
liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
liftIO $ writeAutogenFiles $ cradleRootDir crdl </> "dist"
@ -137,3 +167,45 @@ pkgDbArg :: GhcPkgDb -> String
pkgDbArg GlobalDb = "--package-db=global"
pkgDbArg UserDb = "--package-db=user"
pkgDbArg (PackageDb p) = "--package-db=" ++ p
-- * Neither file exists -> should return False:
-- @Nothing < Nothing = False@
-- (since we don't need to @cabal configure@ when no cabal file exists.)
--
-- * Cabal file doesn't exist (unlikely case) -> should return False
-- @Just cc < Nothing = False@
-- TODO: should we delete dist/setup-config?
--
-- * dist/setup-config doesn't exist yet -> should return True:
-- @Nothing < Just cf = True@
--
-- * Both files exist
-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@
isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool
isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do
worldCabalConfig < worldCabalFile
helperProgs :: Options -> Programs
helperProgs opts = Programs {
cabalProgram = T.cabalProgram opts,
ghcProgram = T.ghcProgram opts,
ghcPkgProgram = T.ghcPkgProgram opts
}
chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a)
=> Cached m (Programs, FilePath, (Version, [Char])) a -> m a
chCached c = do
root <- cradleRootDir <$> cradle
d <- cacheInputData root
withCabal $ cached root c d
where
cacheInputData root = do
opt <- options
return $ ( helperProgs opt
, root </> "dist"
, (gmVer, chVer)
)
gmVer = GhcMod.version
chVer = VERSION_cabal_helper

26
Language/Haskell/GhcMod/Cradle.hs
View File

@ -57,14 +57,11 @@ customCradle :: FilePath -> MaybeT IO Cradle
customCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
cradleFile <- MaybeT $ findCradleFile cabalDir
pkgDbStack <- liftIO $ parseCradle cradleFile
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile
, cradlePkgDbStack = pkgDbStack
}
cabalCradle :: FilePath -> MaybeT IO Cradle
@ -72,26 +69,22 @@ cabalCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
pkgDbStack <- liftIO $ getPackageDbStack cabalDir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile
, cradlePkgDbStack = pkgDbStack
}
sandboxCradle :: FilePath -> MaybeT IO Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ findCabalSandboxDir wdir
pkgDbStack <- liftIO $ getPackageDbStack sbDir
return Cradle {
cradleCurrentDir = wdir
, cradleRootDir = sbDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
, cradlePkgDbStack = pkgDbStack
}
plainCradle :: FilePath -> MaybeT IO Cradle
@ -101,23 +94,4 @@ plainCradle wdir = do
, cradleRootDir = wdir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
, cradlePkgDbStack = [GlobalDb, UserDb]
}
getPackageDbStack :: FilePath -- ^ Project Directory (where the
-- cabal.sandbox.config file would be if it
-- exists)
-> IO [GhcPkgDb]
getPackageDbStack cdir =
([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
parseCradle :: FilePath -> IO [GhcPkgDb]
parseCradle path = do
source <- readFile path
return $ parseCradle' source
where
parseCradle' source = map parsePkgDb $ filter (not . null) $ lines source
parsePkgDb "global" = GlobalDb
parsePkgDb "user" = UserDb
parsePkgDb s = PackageDb s

9
Language/Haskell/GhcMod/Find.hs
View File

@ -15,7 +15,7 @@ module Language.Haskell.GhcMod.Find
where
import Control.Applicative
import Control.Monad (when, void, (<=<))
import Control.Monad (when, void)
import Data.Function (on)
import Data.List (groupBy, sort)
import qualified GHC as G
@ -46,9 +46,9 @@ data SymbolDb = SymbolDb
, symbolDbCachePath :: FilePath
} deriving (Show)
isOutdated :: (GmEnv m, IOish m) => SymbolDb -> m Bool
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
isOutdated db =
liftIO . (isOlderThan (symbolDbCachePath db) <=< timedPackageCaches) =<< cradle
(liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
----------------------------------------------------------------
@ -94,9 +94,8 @@ loadSymbolDb = do
dumpSymbol :: IOish m => FilePath -> GhcModT m String
dumpSymbol dir = do
crdl <- cradle
create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
runGmPkgGhc $ do
create <- liftIO $ isOlderThan cache =<< timedPackageCaches crdl
when create $
liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
return $ unlines [cache]

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

@ -12,11 +12,14 @@ import Control.Applicative
import Data.List.Split (splitOn)
import Data.Maybe
import Exception (handleIO)
import Language.Haskell.GhcMod.Types
import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
import System.FilePath ((</>))
import Prelude
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.CabalHelper
ghcVersion :: Int
ghcVersion = read cProjectVersionInt
@ -54,9 +57,10 @@ ghcDbOpt (PackageDb pkgDb)
----------------------------------------------------------------
getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath]
getPackageCachePaths sysPkgCfg crdl =
catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl
getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
getPackageCachePaths sysPkgCfg = do
pkgDbStack <- getPackageDbStack
catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack
-- TODO: use PkgConfRef
--- Copied from ghc module `Packages' unfortunately it's not exported :/

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

@ -71,6 +71,33 @@ findCabalFile dir = do
appendDir :: DirPath -> [FileName] -> [FilePath]
appendDir d fs = (d </>) `map` fs
-- | Get path to sandbox config file
getSandboxDb :: FilePath
-- ^ Path to the cabal package root directory (containing the
-- @cabal.sandbox.config@ file)
-> IO (Maybe GhcPkgDb)
getSandboxDb d = do
mConf <- traverse readFile =<< mightExist (d </> "cabal.sandbox.config")
return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
where
fixPkgDbVer dir =
case takeFileName dir == ghcSandboxPkgDbDir of
True -> dir
False -> takeDirectory dir </> ghcSandboxPkgDbDir
-- | Extract the sandbox package db directory from the cabal.sandbox.config
-- file. Exception is thrown if the sandbox config file is broken.
extractSandboxDbDir :: String -> Maybe FilePath
extractSandboxDbDir conf = extractValue <$> parse conf
where
key = "package-db:"
keyLen = length key
parse = listToMaybe . filter (key `isPrefixOf`) . lines
extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
-- |
-- >>> isCabalFile "/home/user/.cabal"
-- False
@ -117,7 +144,7 @@ findCabalSandboxDir dir = do
_ -> Nothing
where
isSandboxConfig = (=="cabal.sandbox.config")
isSandboxConfig = (==sandboConfigFile)
zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
@ -150,34 +177,12 @@ parents dir' =
----------------------------------------------------------------
-- | Get path to sandbox config file
getSandboxDb :: FilePath -- ^ Path to the cabal package root directory
-- (containing the @cabal.sandbox.config@ file)
-> IO (Maybe GhcPkgDb)
getSandboxDb d = do
mConf <- traverse readFile =<< U.mightExist (d </> "cabal.sandbox.config")
return $ PackageDb . fixPkgDbVer <$> (extractSandboxDbDir =<< mConf)
where
fixPkgDbVer dir =
case takeFileName dir == ghcSandboxPkgDbDir of
True -> dir
False -> takeDirectory dir </> ghcSandboxPkgDbDir
-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
-- Exception is thrown if the sandbox config file is broken.
extractSandboxDbDir :: String -> Maybe FilePath
extractSandboxDbDir conf = extractValue <$> parse conf
where
key = "package-db:"
keyLen = length key
parse = listToMaybe . filter (key `isPrefixOf`) . lines
extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
setupConfigFile :: Cradle -> FilePath
setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
sandboConfigFile :: FilePath
sandboConfigFile = "cabal.sandbox.config"
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
setupConfigPath :: FilePath
setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref
@ -211,9 +216,12 @@ cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components"
mergedPkgOptsCacheFile :: String
mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options"
-- | @findCradleFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.
pkgDbStackCacheFile :: String
pkgDbStackCacheFile = setupConfigPath <.> "ghc-mod.package-db-stack"
-- | @findCustomPackageDbFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.
-- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@
findCradleFile :: FilePath -> IO (Maybe FilePath)
findCradleFile directory = do
let path = directory </> "ghc-mod.cradle"
findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)
findCustomPackageDbFile directory = do
let path = directory </> "ghc-mod.package-db-stack"
mightExist path

15
Language/Haskell/GhcMod/PkgDoc.hs
View File

@ -4,6 +4,7 @@ import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.CabalHelper
import Control.Applicative
import Prelude
@ -11,17 +12,17 @@ import Prelude
-- | Obtaining the package name and the doc path of a module.
pkgDoc :: IOish m => String -> GhcModT m String
pkgDoc mdl = do
c <- cradle
pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts c) ""
pkgDbStack <- getPackageDbStack
pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) ""
if pkg == "" then
return "\n"
else do
htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg c) ""
htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) ""
let ret = pkg ++ " " ++ drop 14 htmlpath
return ret
where
toModuleOpts c = ["find-module", mdl, "--simple-output"]
++ ghcPkgDbStackOpts (cradlePkgDbStack c)
toDocDirOpts pkg c = ["field", pkg, "haddock-html"]
++ ghcPkgDbStackOpts (cradlePkgDbStack c)
toModuleOpts dbs = ["find-module", mdl, "--simple-output"]
++ ghcPkgDbStackOpts dbs
toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]
++ ghcPkgDbStackOpts dbs
trim = takeWhile (`notElem` " \n")

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

@ -37,7 +37,7 @@ import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.Utils as U
import Data.Maybe
@ -289,13 +289,21 @@ packageGhcOptions = do
Just _ -> getGhcMergedPkgOptions
Nothing -> sandboxOpts crdl
sandboxOpts :: Monad m => Cradle -> m [String]
sandboxOpts crdl =
sandboxOpts :: MonadIO m => Cradle -> m [String]
sandboxOpts crdl = do
pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl
let pkgOpts = ghcDbStackOpts pkgDbStack
return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]
where
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl
(wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
getSandboxPackageDbStack :: FilePath
-- ^ Project Directory (where the cabal.sandbox.config
-- file would be if it exists)
-> IO [GhcPkgDb]
getSandboxPackageDbStack cdir =
([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
=> Maybe [CompilationUnit] -- ^ Updated modules
-> GmComponent 'GMCRaw (Set ModulePath)

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

@ -112,14 +112,17 @@ data Cradle = Cradle {
, cradleTempDir :: FilePath
-- | The file name of the found cabal file.
, cradleCabalFile :: Maybe FilePath
-- | Package database stack
, cradlePkgDbStack :: [GhcPkgDb]
} deriving (Eq, Show)
----------------------------------------------------------------
-- | GHC package database flags.
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
data GhcPkgDb = GlobalDb
| UserDb
| PackageDb String
deriving (Eq, Show, Generic)
instance Serialize GhcPkgDb
-- | A single GHC command line option.
type GHCOption = String

47
Language/Haskell/GhcMod/World.hs
View File

@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.World where
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils
import Control.Applicative
@ -20,18 +21,19 @@ data World = World {
, worldSymbolCache :: Maybe TimedFile
} deriving (Eq, Show)
timedPackageCaches :: Cradle -> IO [TimedFile]
timedPackageCaches crdl = do
fs <- mapM mightExist . map (</> packageCache)
=<< getPackageCachePaths libdir crdl
timeFile `mapM` catMaybes fs
timedPackageCaches :: IOish m => GhcModT m [TimedFile]
timedPackageCaches = do
fs <- mapM (liftIO . mightExist) . map (</> packageCache)
=<< getPackageCachePaths libdir
(liftIO . timeFile) `mapM` catMaybes fs
getCurrentWorld :: Cradle -> IO World
getCurrentWorld crdl = do
pkgCaches <- timedPackageCaches crdl
mCabalFile <- timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- timeMaybe (setupConfigFile crdl)
mSymbolCache <- timeMaybe (symbolCache crdl)
getCurrentWorld :: IOish m => GhcModT m World
getCurrentWorld = do
crdl <- cradle
pkgCaches <- timedPackageCaches
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
return World {
worldPackageCaches = pkgCaches
@ -40,26 +42,9 @@ getCurrentWorld crdl = do
, worldSymbolCache = mSymbolCache
}
didWorldChange :: World -> Cradle -> IO Bool
didWorldChange world crdl = do
(world /=) <$> getCurrentWorld crdl
-- * Neither file exists -> should return False:
-- @Nothing < Nothing = False@
-- (since we don't need to @cabal configure@ when no cabal file exists.)
--
-- * Cabal file doesn't exist (unlikely case) -> should return False
-- @Just cc < Nothing = False@
-- TODO: should we delete dist/setup-config?
--
-- * dist/setup-config doesn't exist yet -> should return True:
-- @Nothing < Just cf = True@
--
-- * Both files exist
-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@
isSetupConfigOutOfDate :: World -> Bool
isSetupConfigOutOfDate World {..} = do
worldCabalConfig < worldCabalFile
didWorldChange :: IOish m => World -> GhcModT m Bool
didWorldChange world = do
(world /=) <$> getCurrentWorld
isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
isYoungerThanSetupConfig file World {..} = do

7
ghc-mod.cabal
View File

@ -73,6 +73,11 @@ Extra-Source-Files: ChangeLog
test/data/template-haskell/*.hs
test/data/target/*.hs
test/data/check-missing-warnings/*.hs
test/data/custom-cradle/custom-cradle.cabal
test/data/custom-cradle/ghc-mod.package-db-stack
test/data/custom-cradle/package-db-a/.gitkeep
test/data/custom-cradle/package-db-b/.gitkeep
test/data/custom-cradle/package-db-c/.gitkeep
Library
Default-Language: Haskell2010
@ -123,7 +128,7 @@ Library
, bytestring
, cereal >= 0.4
, containers
, cabal-helper >= 0.3.7.0
, cabal-helper == 0.3.* && >= 0.3.8.0
, deepseq
, directory
, filepath

4
src/GHCMod.hs
View File

@ -344,7 +344,7 @@ legacyInteractive :: IOish m => GhcModT m ()
legacyInteractive = do
opt <- options
symdbreq <- liftIO $ newSymDbReq opt
world <- liftIO . getCurrentWorld =<< cradle
world <- getCurrentWorld
legacyInteractiveLoop symdbreq world
bug :: String -> IO ()
@ -371,7 +371,7 @@ legacyInteractiveLoop symdbreq world = do
-- after blocking, we need to see if the world has changed.
changed <- liftIO . didWorldChange world =<< cradle
changed <- didWorldChange world
when changed $ do
dropSession

26
test/CabalHelperSpec.hs
View File

@ -9,7 +9,7 @@ import Language.Haskell.GhcMod.Error
import Test.Hspec
import System.Directory
import System.FilePath
import System.Process (readProcess)
import System.Process (readProcess, system)
import Dir
import TestUtils
@ -51,8 +51,6 @@ spec = do
-- comment in cabal-helper
opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents
print opts
if ghcVersion < 706
then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir])
else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir])
@ -73,3 +71,25 @@ spec = do
let ghcOpts = head opts
pkgs = pkgOptions ghcOpts
pkgs `shouldBe` ["Cabal","base"]
describe "getCustomPkgDbStack" $ do
it "works" $ do
let tdir = "test/data/custom-cradle"
Just stack <- runD' tdir $ getCustomPkgDbStack
stack `shouldBe` [ GlobalDb
, UserDb
, PackageDb "package-db-a"
, PackageDb "package-db-b"
, PackageDb "package-db-c"
]
describe "getPackageDbStack'" $ do
it "fixes out of sync custom pkg-db stack" $ do
withDirectory_ "test/data/custom-cradle" $ do
_ <- system "cabal configure"
(s, s') <- runD $ do
Just stack <- getCustomPkgDbStack
withCabal $ do
stack' <- getPackageDbStack'
return (stack, stack')
s' `shouldBe` s

17
test/CradleSpec.hs
View File

@ -9,7 +9,6 @@ import System.FilePath (pathSeparator)
import Test.Hspec
import Dir
import TestUtils
clean_ :: IO Cradle -> IO Cradle
clean_ f = do
@ -40,10 +39,8 @@ spec = do
cradleCurrentDir res `shouldBe` curDir
cradleRootDir res `shouldBe` curDir
cradleCabalFile res `shouldBe` Nothing
cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb]
it "finds a cabal file and a sandbox" $ do
cwd <- getCurrentDirectory
withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> clean_ findCradle
@ -55,10 +52,6 @@ spec = do
cradleCabalFile res `shouldBe`
Just ("test/data/cabal-project/cabalapi.cabal")
let [GlobalDb, sb] = cradlePkgDbStack res
sb `shouldSatisfy`
isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
it "works even if a sandbox config file is broken" $ do
withDirectory "test/data/broken-sandbox" $ \dir -> do
res <- relativeCradle dir <$> clean_ findCradle
@ -70,13 +63,3 @@ spec = do
cradleCabalFile res `shouldBe`
Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]
it "uses the custom cradle file if present" $ do
withDirectory "test/data/custom-cradle" $ \dir -> do
res <- relativeCradle dir <$> findCradle
cradleCurrentDir res `shouldBe` "test" </> "data" </> "custom-cradle"
cradleRootDir res `shouldBe` "test" </> "data" </> "custom-cradle"
cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "custom-cradle" </> "dummy.cabal")
cradlePkgDbStack res `shouldBe` [PackageDb "a/packages", GlobalDb, PackageDb "b/packages", UserDb, PackageDb "c/packages"]

3
test/Main.hs
View File

@ -30,7 +30,10 @@ main = do
let caches = [ "setup-config"
, "setup-config.ghc-mod.cabal-helper"
, "setup-config.ghc-mod.cabal-components"
, "setup-config.ghc-mod.resolved-components"
, "setup-config.ghc-mod.package-options"
, "setup-config.ghc-mod.package-db-stack"
, "ghc-mod.cache"
]
cachesFindExp :: String

12
test/data/custom-cradle/custom-cradle.cabal Normal file
View File

@ -0,0 +1,12 @@
name: custom-cradle
version: 0.1.0.0
homepage: asd
license-file: LICENSE
author: asd
maintainer: asd
build-type: Simple
cabal-version: >=1.10
library
build-depends: base >=4.7 && <4.8
default-language: Haskell2010

1
test/data/custom-cradle/dummy.cabal
View File

@ -1 +0,0 @@
dummy

5
test/data/custom-cradle/ghc-mod.cradle
View File

@ -1,5 +0,0 @@
a/packages
global
b/packages
user
c/packages

5
test/data/custom-cradle/ghc-mod.package-db-stack Normal file
View File

@ -0,0 +1,5 @@
global
user
package-db-a
package-db-b
package-db-c

0
test/data/custom-cradle/package-db-a/.gitkeep Normal file
View File

0
test/data/custom-cradle/package-db-b/.gitkeep Normal file
View File

0
test/data/custom-cradle/package-db-c/.gitkeep Normal file
View File