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

View File

@ -15,23 +15,28 @@
-- along with this program. If not, see <http://www.gnu.org/licenses/>. -- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.CabalHelper ( module Language.Haskell.GhcMod.CabalHelper
getComponents #ifndef SPEC
( getComponents
, getGhcMergedPkgOptions , getGhcMergedPkgOptions
) where , getPackageDbStack
)
#endif
where
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Data.Maybe
import Data.Monoid import Data.Monoid
import Data.Version import Data.Version
import Data.Serialize (Serialize) import Data.Serialize (Serialize)
import Data.Traversable
import Distribution.Helper import Distribution.Helper
import qualified Language.Haskell.GhcMod.Types as T import qualified Language.Haskell.GhcMod.Types as T
import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram, import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
cabalProgram) cabalProgram)
import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logging
import System.FilePath import System.FilePath
@ -50,13 +55,36 @@ getGhcMergedPkgOptions = chCached Cached {
return ([setupConfigPath], opts) return ([setupConfigPath], opts)
} }
helperProgs :: Options -> Programs parseCustomPackageDb :: String -> [GhcPkgDb]
helperProgs opts = Programs { parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src
cabalProgram = T.cabalProgram opts, where
ghcProgram = T.ghcProgram opts, parsePkgDb "global" = GlobalDb
ghcPkgProgram = T.ghcPkgProgram opts 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 -- | Primary interface to cabal-helper and intended single entrypoint to
-- constructing 'GmComponent's -- constructing 'GmComponent's
-- --
@ -66,23 +94,6 @@ getComponents :: (Applicative m, IOish m, GmEnv m, GmLog m)
=> m [GmComponent 'GMCRaw ChEntrypoint] => m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached cabalHelperCache 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 cabalHelperCache
:: (Functor m, Applicative m, MonadIO m) :: (Functor m, Applicative m, MonadIO m)
=> Cached m (Programs, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint] => 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 withCabal action = do
crdl <- cradle crdl <- cradle
opts <- options 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 withDirectory_ (cradleRootDir crdl) $ do
let pkgDbArgs = "--package-db=clear" : map pkgDbArg (cradlePkgDbStack crdl) let progOpts =
progOpts =
[ "--with-ghc=" ++ T.ghcProgram opts ] [ "--with-ghc=" ++ T.ghcProgram opts ]
-- Only pass ghc-pkg if it was actually set otherwise we -- Only pass ghc-pkg if it was actually set otherwise we
-- might break cabal's guessing logic -- might break cabal's guessing logic
++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ] then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
else [] else []
++ pkgDbArgs ++ map pkgDbArg cusPkgStack
gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) "" liftIO $ void $ readProcess (T.cabalProgram opts) ("configure":progOpts) ""
gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
liftIO $ writeAutogenFiles $ cradleRootDir crdl </> "dist" liftIO $ writeAutogenFiles $ cradleRootDir crdl </> "dist"
@ -137,3 +167,45 @@ pkgDbArg :: GhcPkgDb -> String
pkgDbArg GlobalDb = "--package-db=global" pkgDbArg GlobalDb = "--package-db=global"
pkgDbArg UserDb = "--package-db=user" pkgDbArg UserDb = "--package-db=user"
pkgDbArg (PackageDb p) = "--package-db=" ++ p 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

View File

@ -57,14 +57,11 @@ customCradle :: FilePath -> MaybeT IO Cradle
customCradle wdir = do customCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir cabalFile <- MaybeT $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile let cabalDir = takeDirectory cabalFile
cradleFile <- MaybeT $ findCradleFile cabalDir
pkgDbStack <- liftIO $ parseCradle cradleFile
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = cabalDir , cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir" , cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile , cradleCabalFile = Just cabalFile
, cradlePkgDbStack = pkgDbStack
} }
cabalCradle :: FilePath -> MaybeT IO Cradle cabalCradle :: FilePath -> MaybeT IO Cradle
@ -72,26 +69,22 @@ cabalCradle wdir = do
cabalFile <- MaybeT $ findCabalFile wdir cabalFile <- MaybeT $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile let cabalDir = takeDirectory cabalFile
pkgDbStack <- liftIO $ getPackageDbStack cabalDir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = cabalDir , cradleRootDir = cabalDir
, cradleTempDir = error "tmpDir" , cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile , cradleCabalFile = Just cabalFile
, cradlePkgDbStack = pkgDbStack
} }
sandboxCradle :: FilePath -> MaybeT IO Cradle sandboxCradle :: FilePath -> MaybeT IO Cradle
sandboxCradle wdir = do sandboxCradle wdir = do
sbDir <- MaybeT $ findCabalSandboxDir wdir sbDir <- MaybeT $ findCabalSandboxDir wdir
pkgDbStack <- liftIO $ getPackageDbStack sbDir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleCurrentDir = wdir
, cradleRootDir = sbDir , cradleRootDir = sbDir
, cradleTempDir = error "tmpDir" , cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePkgDbStack = pkgDbStack
} }
plainCradle :: FilePath -> MaybeT IO Cradle plainCradle :: FilePath -> MaybeT IO Cradle
@ -101,23 +94,4 @@ plainCradle wdir = do
, cradleRootDir = wdir , cradleRootDir = wdir
, cradleTempDir = error "tmpDir" , cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing , 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

View File

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

View File

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

View File

@ -71,6 +71,33 @@ findCabalFile dir = do
appendDir :: DirPath -> [FileName] -> [FilePath] appendDir :: DirPath -> [FileName] -> [FilePath]
appendDir d fs = (d </>) `map` fs 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" -- >>> isCabalFile "/home/user/.cabal"
-- False -- False
@ -117,7 +144,7 @@ findCabalSandboxDir dir = do
_ -> Nothing _ -> Nothing
where where
isSandboxConfig = (=="cabal.sandbox.config") isSandboxConfig = (==sandboConfigFile)
zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as 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 :: Cradle -> FilePath
setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
sandboConfigFile :: FilePath
sandboConfigFile = "cabal.sandbox.config"
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
setupConfigPath :: FilePath setupConfigPath :: FilePath
setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref
@ -211,9 +216,12 @@ cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components"
mergedPkgOptsCacheFile :: String mergedPkgOptsCacheFile :: String
mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options" 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@ -- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@
findCradleFile :: FilePath -> IO (Maybe FilePath) findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)
findCradleFile directory = do findCustomPackageDbFile directory = do
let path = directory </> "ghc-mod.cradle" let path = directory </> "ghc-mod.package-db-stack"
mightExist path mightExist path

View File

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

View File

@ -37,7 +37,7 @@ import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils as U
import Data.Maybe import Data.Maybe
@ -289,13 +289,21 @@ packageGhcOptions = do
Just _ -> getGhcMergedPkgOptions Just _ -> getGhcMergedPkgOptions
Nothing -> sandboxOpts crdl Nothing -> sandboxOpts crdl
sandboxOpts :: Monad m => Cradle -> m [String] sandboxOpts :: MonadIO m => Cradle -> m [String]
sandboxOpts crdl = sandboxOpts crdl = do
pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl
let pkgOpts = ghcDbStackOpts pkgDbStack
return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"] return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]
where where
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl
(wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir 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) resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
=> Maybe [CompilationUnit] -- ^ Updated modules => Maybe [CompilationUnit] -- ^ Updated modules
-> GmComponent 'GMCRaw (Set ModulePath) -> GmComponent 'GMCRaw (Set ModulePath)

View File

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

View File

@ -3,6 +3,7 @@ module Language.Haskell.GhcMod.World where
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Control.Applicative import Control.Applicative
@ -20,18 +21,19 @@ data World = World {
, worldSymbolCache :: Maybe TimedFile , worldSymbolCache :: Maybe TimedFile
} deriving (Eq, Show) } deriving (Eq, Show)
timedPackageCaches :: Cradle -> IO [TimedFile] timedPackageCaches :: IOish m => GhcModT m [TimedFile]
timedPackageCaches crdl = do timedPackageCaches = do
fs <- mapM mightExist . map (</> packageCache) fs <- mapM (liftIO . mightExist) . map (</> packageCache)
=<< getPackageCachePaths libdir crdl =<< getPackageCachePaths libdir
timeFile `mapM` catMaybes fs (liftIO . timeFile) `mapM` catMaybes fs
getCurrentWorld :: Cradle -> IO World getCurrentWorld :: IOish m => GhcModT m World
getCurrentWorld crdl = do getCurrentWorld = do
pkgCaches <- timedPackageCaches crdl crdl <- cradle
mCabalFile <- timeFile `traverse` cradleCabalFile crdl pkgCaches <- timedPackageCaches
mCabalConfig <- timeMaybe (setupConfigFile crdl) mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mSymbolCache <- timeMaybe (symbolCache crdl) mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
return World { return World {
worldPackageCaches = pkgCaches worldPackageCaches = pkgCaches
@ -40,26 +42,9 @@ getCurrentWorld crdl = do
, worldSymbolCache = mSymbolCache , worldSymbolCache = mSymbolCache
} }
didWorldChange :: World -> Cradle -> IO Bool didWorldChange :: IOish m => World -> GhcModT m Bool
didWorldChange world crdl = do didWorldChange world = do
(world /=) <$> getCurrentWorld crdl (world /=) <$> getCurrentWorld
-- * 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
isYoungerThanSetupConfig :: FilePath -> World -> IO Bool isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
isYoungerThanSetupConfig file World {..} = do isYoungerThanSetupConfig file World {..} = do

View File

@ -73,6 +73,11 @@ Extra-Source-Files: ChangeLog
test/data/template-haskell/*.hs test/data/template-haskell/*.hs
test/data/target/*.hs test/data/target/*.hs
test/data/check-missing-warnings/*.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 Library
Default-Language: Haskell2010 Default-Language: Haskell2010
@ -123,7 +128,7 @@ Library
, bytestring , bytestring
, cereal >= 0.4 , cereal >= 0.4
, containers , containers
, cabal-helper >= 0.3.7.0 , cabal-helper == 0.3.* && >= 0.3.8.0
, deepseq , deepseq
, directory , directory
, filepath , filepath

View File

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

View File

@ -9,7 +9,7 @@ import Language.Haskell.GhcMod.Error
import Test.Hspec import Test.Hspec
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.Process (readProcess) import System.Process (readProcess, system)
import Dir import Dir
import TestUtils import TestUtils
@ -51,8 +51,6 @@ spec = do
-- comment in cabal-helper -- comment in cabal-helper
opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents
print opts
if ghcVersion < 706 if ghcVersion < 706
then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir]) 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]) 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 let ghcOpts = head opts
pkgs = pkgOptions ghcOpts pkgs = pkgOptions ghcOpts
pkgs `shouldBe` ["Cabal","base"] 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

View File

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

View File

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

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

View File

@ -1 +0,0 @@
dummy

View File

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

View File

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