diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 2f51ebb..9c0ad95 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -15,23 +15,28 @@ -- along with this program. If not, see . {-# 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 diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index d409ce7..4a23fab 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 11228f5..1275656 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -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] diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index 3114916..4418830 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -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 :/ diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 90b88ff..527eb21 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -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 diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index a83141f..ddc4a06 100644 --- a/Language/Haskell/GhcMod/PkgDoc.hs +++ b/Language/Haskell/GhcMod/PkgDoc.hs @@ -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") diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 93afccc..36ed391 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -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) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 1fb7230..f7e0799 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -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 diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs index c9d6b49..e887990 100644 --- a/Language/Haskell/GhcMod/World.hs +++ b/Language/Haskell/GhcMod/World.hs @@ -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 diff --git a/ghc-mod.cabal b/ghc-mod.cabal index ace73ba..9245a83 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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 diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 43a2e8a..0c8d53d 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -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 diff --git a/test/CabalHelperSpec.hs b/test/CabalHelperSpec.hs index 6acdde3..ec6d35e 100644 --- a/test/CabalHelperSpec.hs +++ b/test/CabalHelperSpec.hs @@ -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 diff --git a/test/CradleSpec.hs b/test/CradleSpec.hs index 97fc81d..360b7e0 100644 --- a/test/CradleSpec.hs +++ b/test/CradleSpec.hs @@ -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"] diff --git a/test/Main.hs b/test/Main.hs index 4422d5a..18aa1eb 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/data/custom-cradle/custom-cradle.cabal b/test/data/custom-cradle/custom-cradle.cabal new file mode 100644 index 0000000..f157254 --- /dev/null +++ b/test/data/custom-cradle/custom-cradle.cabal @@ -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 \ No newline at end of file diff --git a/test/data/custom-cradle/dummy.cabal b/test/data/custom-cradle/dummy.cabal deleted file mode 100644 index 421376d..0000000 --- a/test/data/custom-cradle/dummy.cabal +++ /dev/null @@ -1 +0,0 @@ -dummy diff --git a/test/data/custom-cradle/ghc-mod.cradle b/test/data/custom-cradle/ghc-mod.cradle deleted file mode 100644 index 38259f1..0000000 --- a/test/data/custom-cradle/ghc-mod.cradle +++ /dev/null @@ -1,5 +0,0 @@ -a/packages -global -b/packages -user -c/packages diff --git a/test/data/custom-cradle/ghc-mod.package-db-stack b/test/data/custom-cradle/ghc-mod.package-db-stack new file mode 100644 index 0000000..ce2d741 --- /dev/null +++ b/test/data/custom-cradle/ghc-mod.package-db-stack @@ -0,0 +1,5 @@ +global +user +package-db-a +package-db-b +package-db-c diff --git a/test/data/custom-cradle/package-db-a/.gitkeep b/test/data/custom-cradle/package-db-a/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/test/data/custom-cradle/package-db-b/.gitkeep b/test/data/custom-cradle/package-db-b/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/test/data/custom-cradle/package-db-c/.gitkeep b/test/data/custom-cradle/package-db-c/.gitkeep new file mode 100644 index 0000000..e69de29