diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs index 8f1474e..2ab3024 100644 --- a/Language/Haskell/GhcMod/CabalConfig.hs +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -6,17 +6,15 @@ module Language.Haskell.GhcMod.CabalConfig ( CabalConfig , cabalConfigDependencies , cabalConfigFlags - , setupConfigFile - , World - , getCurrentWorld - , isWorldChanged ) where import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Read import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.World import qualified Language.Haskell.GhcMod.Cabal16 as C16 import qualified Language.Haskell.GhcMod.Cabal18 as C18 @@ -27,32 +25,19 @@ import qualified Language.Haskell.GhcMod.Cabal21 as C21 #endif import Control.Applicative ((<$>)) -import Control.Monad (unless, void, mplus) +import Control.Monad (void, mplus, when) #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except () #else import Control.Monad.Error () #endif -import Data.Maybe () -import Data.Set () import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) import Distribution.Package (InstalledPackageId(..) , PackageIdentifier(..) , PackageName(..)) import Distribution.PackageDescription (FlagAssignment) -import Distribution.Simple.BuildPaths (defaultDistPref) -import Distribution.Simple.Configure (localBuildInfoFile) import Distribution.Simple.LocalBuildInfo (ComponentName) -import Data.Traversable (traverse) import MonadUtils (liftIO) -import System.Directory (doesFileExist, getModificationTime) -import System.FilePath (()) - -#if __GLASGOW_HASKELL__ <= 704 -import System.Time (ClockTime) -#else -import Data.Time (UTCTime) -#endif ---------------------------------------------------------------- @@ -66,9 +51,8 @@ getConfig :: (IOish m, MonadError GhcModError m) => Cradle -> m CabalConfig getConfig cradle = do - world <- liftIO $ getCurrentWorld cradle - let valid = isSetupConfigValid world - unless valid configure + outOfDate <- liftIO $ isSetupConfigOutOfDate cradle + when outOfDate configure liftIO (readFile file) `tryFix` \_ -> configure `modifyError'` GMECabalConfigure where @@ -78,14 +62,6 @@ getConfig cradle = do configure :: (IOish m, MonadError GhcModError m) => m () configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"] - -setupConfigFile :: Cradle -> FilePath -setupConfigFile crdl = cradleRootDir crdl setupConfigPath - --- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ -setupConfigPath :: FilePath -setupConfigPath = localBuildInfoFile defaultDistPref - -- | Get list of 'Package's needed by all components of the current package cabalConfigDependencies :: (IOish m, MonadError GhcModError m) => Cradle @@ -193,57 +169,3 @@ extractField config field = case extractParens <$> find (field `isPrefixOf`) (tails config) of Just f -> Right f Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config) - ----------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ <= 704 -type ModTime = ClockTime -#else -type ModTime = UTCTime -#endif - -data World = World { - worldCabalFile :: Maybe FilePath - , worldCabalFileModificationTime :: Maybe ModTime - , worldPackageCache :: FilePath - , worldPackageCacheModificationTime :: ModTime - , worldSetupConfig :: FilePath - , worldSetupConfigModificationTime :: Maybe ModTime - } deriving (Show, Eq) - -getCurrentWorld :: Cradle -> IO World -getCurrentWorld crdl = do - cachePath <- getPackageCachePath crdl - let mCabalFile = cradleCabalFile crdl - pkgCache = cachePath packageCache - setupFile = setupConfigFile crdl - mCabalFileMTime <- getModificationTime `traverse` mCabalFile - pkgCacheMTime <- getModificationTime pkgCache - exist <- doesFileExist setupFile - mSeetupMTime <- if exist then - Just <$> getModificationTime setupFile - else - return Nothing - return $ World { - worldCabalFile = mCabalFile - , worldCabalFileModificationTime = mCabalFileMTime - , worldPackageCache = pkgCache - , worldPackageCacheModificationTime = pkgCacheMTime - , worldSetupConfig = setupFile - , worldSetupConfigModificationTime = mSeetupMTime - } - -isWorldChanged :: World -> Cradle -> IO Bool -isWorldChanged world crdl = do - world' <- getCurrentWorld crdl - return (world /= world') - -isSetupConfigValid :: World -> Bool -isSetupConfigValid World{ worldSetupConfigModificationTime = Nothing, ..} = False -isSetupConfigValid World{ worldSetupConfigModificationTime = Just mt, ..} = - cond1 && cond2 - where - cond1 = case worldCabalFileModificationTime of - Nothing -> True - Just mtime -> mtime <= mt - cond2 = worldPackageCacheModificationTime <= mt diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index a42fac6..aa919c8 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -5,16 +5,14 @@ module Language.Haskell.GhcMod.Cradle ( , cleanupCradle ) where -import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Types -import Control.Applicative ((<$>)) -import qualified Control.Exception as E import Control.Exception.IOChoice ((||>)) -import Control.Monad (filterM) -import Data.List (isSuffixOf) -import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive) -import System.FilePath ((),takeDirectory,pathSeparators,splitDrive) +import System.Directory (getCurrentDirectory, removeDirectoryRecursive, + getTemporaryDirectory) +import System.FilePath (takeDirectory,pathSeparators,splitDrive) import System.IO.Temp @@ -44,25 +42,26 @@ cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl cabalCradle :: FilePath -> IO Cradle cabalCradle wdir = do - (rdir,cfile) <- cabalDir wdir - pkgDbStack <- getPackageDbStack rdir - tmpDir <- newTempDir rdir + Just cabalFile <- findCabalFiles wdir + let cabalDir = takeDirectory cabalFile + pkgDbStack <- getPackageDbStack cabalDir + tmpDir <- newTempDir cabalDir return Cradle { cradleCurrentDir = wdir - , cradleRootDir = rdir + , cradleRootDir = cabalDir , cradleTempDir = tmpDir - , cradleCabalFile = Just cfile + , cradleCabalFile = Just cabalFile , cradlePkgDbStack = pkgDbStack } sandboxCradle :: FilePath -> IO Cradle sandboxCradle wdir = do - rdir <- getSandboxDir wdir - pkgDbStack <- getPackageDbStack rdir - tmpDir <- newTempDir rdir + Just sbDir <- getSandboxDb wdir + pkgDbStack <- getPackageDbStack sbDir + tmpDir <- newTempDir sbDir return Cradle { cradleCurrentDir = wdir - , cradleRootDir = rdir + , cradleRootDir = sbDir , cradleTempDir = tmpDir , cradleCabalFile = Nothing , cradlePkgDbStack = pkgDbStack @@ -84,48 +83,3 @@ findCradleWithoutSandbox :: IO Cradle findCradleWithoutSandbox = do cradle <- findCradle return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME - ----------------------------------------------------------------- - -cabalSuffix :: String -cabalSuffix = ".cabal" - -cabalSuffixLength :: Int -cabalSuffixLength = length cabalSuffix - --- Finding a Cabal file up to the root directory --- Input: a directly to investigate --- Output: (the path to the directory containing a Cabal file --- ,the path to the Cabal file) -cabalDir :: FilePath -> IO (FilePath,FilePath) -cabalDir dir = do - cnts <- getCabalFiles dir - case cnts of - [] | dir' == dir -> E.throwIO $ userError "cabal files not found" - | otherwise -> cabalDir dir' - cfile:_ -> return (dir,dir cfile) - where - dir' = takeDirectory dir - -getCabalFiles :: FilePath -> IO [FilePath] -getCabalFiles dir = getFiles >>= filterM doesCabalFileExist - where - isCabal name = cabalSuffix `isSuffixOf` name - && length name > cabalSuffixLength - getFiles = filter isCabal <$> getDirectoryContents dir - doesCabalFileExist file = doesFileExist $ dir file - ----------------------------------------------------------------- - -getSandboxDir :: FilePath -> IO FilePath -getSandboxDir dir = do - exist <- doesFileExist sfile - if exist then - return dir - else if dir == dir' then - E.throwIO $ userError "sandbox not found" - else - getSandboxDir dir' - where - sfile = dir "cabal.sandbox.config" - dir' = takeDirectory dir diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index 1936eb1..7f7cdc7 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -29,6 +29,9 @@ data GhcModError = GMENoMsg | GMEProcess [String] GhcModError -- ^ Launching an operating system process failed. The first -- field is the command. + | GMENoCabalFile + | GMETooManyCabalFiles [FilePath] + -- ^ No or too many cabal files found. deriving (Eq,Show,Typeable) instance Exception GhcModError @@ -52,6 +55,11 @@ gmeDoc e = case e of GMEProcess cmd msg -> text ("launching operating system process `"++unwords cmd++"` failed: ") <> gmeDoc msg + GMENoCabalFile -> + text "No cabal file found." + GMETooManyCabalFiles cfs -> + text $ "Multiple cabal files found. Possible cabal files: \"" + ++ intercalate "\", \"" cfs ++"\"." modifyError :: MonadError e m => (e -> e) -> m a -> m a modifyError f action = action `catchError` \e -> throwError $ f e diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 5967128..37ba7fe 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -22,10 +22,10 @@ import Data.List (groupBy, sort) import Data.Maybe (fromMaybe) import qualified GHC as G import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.PathsAndFiles import Name (getOccString) import System.Directory (doesFileExist, getModificationTime) import System.FilePath ((), takeDirectory) @@ -89,7 +89,7 @@ lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do ghcMod <- liftIO ghcModExecutable - tmpdir <- liftIO . getPackageCachePath =<< cradle + tmpdir <- cradleTempDir <$> cradle file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir] !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) return $ SymbolDb { diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index a0c9bff..969acda 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -6,63 +6,34 @@ module Language.Haskell.GhcMod.GhcPkg ( , ghcDbOpt , fromInstalledPackageId , fromInstalledPackageId' - , getSandboxDb , getPackageDbStack - , getPackageCachePath - , packageCache - , packageConfDir + , getPackageCachePaths ) where import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) import Control.Applicative ((<$>)) -import Control.Exception (SomeException(..)) -import Control.Monad -import qualified Control.Exception as E -import Data.Char (isSpace) -import Data.List (isPrefixOf, intercalate) +import Data.List (intercalate) import Data.List.Split (splitOn) import Data.Maybe import Distribution.Package (InstalledPackageId(..)) import Exception (handleIO) +import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Utils import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.FilePath (()) -import qualified Data.Traversable as T ghcVersion :: Int ghcVersion = read cProjectVersionInt --- | Get path to sandbox package db -getSandboxDb :: FilePath -- ^ Path to the cabal package root directory - -- (containing the @cabal.sandbox.config@ file) - -> IO FilePath -getSandboxDb cdir = getSandboxDbDir (cdir "cabal.sandbox.config") - --- | Extract the sandbox package db directory from the cabal.sandbox.config file. --- Exception is thrown if the sandbox config file is broken. -getSandboxDbDir :: FilePath -- ^ Path to the @cabal.sandbox.config@ file - -> IO FilePath -getSandboxDbDir sconf = do - -- Be strict to ensure that an error can be caught. - !path <- extractValue . parse <$> readFile sconf - return path - where - key = "package-db:" - keyLen = length key - - parse = head . filter (key `isPrefixOf`) . lines - extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen - ----------------------------------------------------------------- - getPackageDbStack :: FilePath -- ^ Project Directory (where the -- cabal.sandbox.config file would be if it -- exists) -> IO [GhcPkgDb] -getPackageDbStack cdir = - (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db]) - `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb] +getPackageDbStack cdir = do + mSDir <- getSandboxDb cdir + return $ [GlobalDb] ++ case mSDir of + Nothing -> [UserDb] + Just db -> [PackageDb db] ---------------------------------------------------------------- @@ -114,30 +85,22 @@ ghcDbOpt (PackageDb pkgDb) ---------------------------------------------------------------- -packageCache :: String -packageCache = "package.cache" -packageConfDir :: String -packageConfDir = "package.conf.d" +getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath] +getPackageCachePaths sysPkgCfg crdl = + catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl -getPackageCachePath :: Cradle -> IO FilePath -getPackageCachePath crdl = do - let mu = listToMaybe $ filter (/= GlobalDb) $ cradlePkgDbStack crdl - mdb <- join <$> resolvePath `T.traverse` mu - let dir = case mdb of - Just db -> db - Nothing -> cradleTempDir crdl - return dir +-- TODO: use PkgConfRef --- Copied from ghc module `Packages' unfortunately it's not exported :/ -resolvePath :: GhcPkgDb -> IO (Maybe FilePath) -resolvePath (PackageDb name) = return $ Just name -resolvePath UserDb = handleIO (\_ -> return Nothing) $ do - appdir <- getAppUserDataDirectory "ghc" - let dir = appdir (target_arch ++ '-':target_os ++ '-':cProjectVersion) - pkgconf = dir packageConfDir - exist <- doesDirectoryExist pkgconf - return $ if exist then Just pkgconf else Nothing - where +resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath) +resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg +resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do + appdir <- getAppUserDataDirectory "ghc" + let dir = appdir (target_arch ++ '-':target_os ++ '-':cProjectVersion) + pkgconf = dir "package.conf.d" + exist <- doesDirectoryExist pkgconf + return $ if exist then Just pkgconf else Nothing + where [target_arch,_,target_os] = splitOn "-" cTargetPlatformString -resolvePath _ = error "GlobalDb cannot be used in resolvePath" +resolvePackageConfig _ (PackageDb name) = return $ Just name diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index a75c00d..d79378c 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -52,13 +52,12 @@ module Language.Haskell.GhcMod.Internal ( -- * World , World , getCurrentWorld - , isWorldChanged + , didWorldChange ) where import GHC.Paths (libdir) import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.CabalConfig import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.GHCChoice @@ -67,6 +66,7 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.World -- | Obtaining the directory for ghc system libraries. ghcLibDir :: FilePath diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs new file mode 100644 index 0000000..08bff0d --- /dev/null +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE BangPatterns, TupleSections #-} +module Language.Haskell.GhcMod.PathsAndFiles where + +import Control.Applicative +import Control.Monad +import Data.List +import Data.Char +import Data.Maybe +import Data.Traversable (traverse) +import Language.Haskell.GhcMod.Types +import System.Directory +import System.FilePath + +import Language.Haskell.GhcMod.Error +import qualified Language.Haskell.GhcMod.Utils as U + +import Distribution.Simple.BuildPaths (defaultDistPref) +import Distribution.Simple.Configure (localBuildInfoFile) + +-- | Guaranteed to be a path to a directory with no trailing slash. +type DirPath = FilePath + +-- | Guaranteed to be the name of a file only (no slashes). +type FileName = String + +-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent +-- directories. The first parent directory containing more than one cabal file +-- is assumed to be the project directory. If only one cabal file exists in this +-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' +-- or 'GMETooManyCabalFiles' +findCabalFiles :: FilePath -> IO (Maybe FilePath) +findCabalFiles directory = do + -- Look for cabal files in all parent directories of @dir@ + dcs <- getCabalFiles `zipMapM` parents directory + -- Extract first non-empty list, which represents a directory with cabal + -- files. + case find (not . null) $ uncurry makeAbsolute `map` dcs of + Just [] -> throw $ GMENoCabalFile + Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs + a -> return $ head <$> a + +-- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@. +getCabalFiles :: DirPath -> IO [FileName] +getCabalFiles dir = + filter ((==) ".cabal" . takeExtension) <$> getDirectoryContents dir + +makeAbsolute :: DirPath -> [FileName] -> [FilePath] +makeAbsolute dir fs = (dir ) `map` fs + +zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] +zipMapM f as = mapM (\a -> liftM (a,) $ f a) as + +-- | @parents dir@. Returns all parent directories of @dir@ including @dir@. +-- +-- Examples +-- +-- >>> parents "foo" +-- ["foo"] +-- +-- >>> parents "/foo" +-- ["/foo","/"] +-- +-- >>> parents "/foo/bar" +-- ["/foo/bar","/foo","/"] +-- +-- >>> parents "foo/bar" +-- ["foo/bar","foo"] +parents :: FilePath -> [FilePath] +parents "" = [] +parents dir' = + let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir' + in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir + where + parents' :: [String] -> [FilePath] + parents' [] | isAbsolute dir' = "":[] + parents' [] = [] + parents' dir = [joinPath dir] ++ parents' (init dir) + +---------------------------------------------------------------- + +-- | Get path to sandbox config file +getSandboxDb :: FilePath -- ^ Path to the cabal package root directory + -- (containing the @cabal.sandbox.config@ file) + -> IO (Maybe FilePath) +getSandboxDb d = do + mConf <- traverse readFile =<< U.mightExist (d "cabal.sandbox.config") + return $ extractSandboxDbDir =<< mConf + +-- | 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 + +-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ +setupConfigPath :: FilePath +setupConfigPath = localBuildInfoFile defaultDistPref + +packageCache :: String +packageCache = "package.cache" diff --git a/Language/Haskell/GhcMod/Utils.hs b/Language/Haskell/GhcMod/Utils.hs index 428aed8..58e45ee 100644 --- a/Language/Haskell/GhcMod/Utils.hs +++ b/Language/Haskell/GhcMod/Utils.hs @@ -3,7 +3,7 @@ module Language.Haskell.GhcMod.Utils where import Language.Haskell.GhcMod.Error import MonadUtils (MonadIO, liftIO) -import System.Directory (getCurrentDirectory, setCurrentDirectory) +import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist) import System.Exit (ExitCode(..)) import System.Process (readProcessWithExitCode) #ifndef SPEC @@ -48,6 +48,11 @@ withDirectory_ dir action = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) (\_ -> liftIO (setCurrentDirectory dir) >> action) +mightExist :: FilePath -> IO (Maybe FilePath) +mightExist f = do + exists <- doesFileExist f + return $ if exists then (Just f) else (Nothing) + -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 -- this is a guess but >=7.6 uses 'getExecutablePath'. ghcModExecutable :: IO FilePath diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs new file mode 100644 index 0000000..83b874f --- /dev/null +++ b/Language/Haskell/GhcMod/World.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP #-} +module Language.Haskell.GhcMod.World where +{-( + , World + , getCurrentWorld + , isWorldChanged + ) where +-} + +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles +import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils + +import Control.Applicative (pure,(<$>),(<*>)) +import Data.Maybe +import Data.Traversable (traverse) +import System.Directory (getModificationTime) +import System.FilePath (()) + +import GHC.Paths (libdir) + +#if __GLASGOW_HASKELL__ <= 704 +import System.Time (ClockTime) +#else +import Data.Time (UTCTime) +#endif + + +#if __GLASGOW_HASKELL__ <= 704 +type ModTime = ClockTime +#else +type ModTime = UTCTime +#endif + +data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show) + +instance Ord TimedFile where + compare (TimedFile _ a) (TimedFile _ b) = compare a b + +timeFile :: FilePath -> IO TimedFile +timeFile f = TimedFile <$> pure f <*> getModificationTime f + +data World = World { + worldPackageCaches :: [TimedFile] + , worldCabalFile :: Maybe TimedFile + , worldCabalConfig :: Maybe TimedFile + } deriving (Eq, Show) + +timedPackageCache :: Cradle -> IO [TimedFile] +timedPackageCache crdl = do + fs <- mapM mightExist . map ( packageCache) + =<< getPackageCachePaths libdir crdl + timeFile `mapM` catMaybes fs + +getCurrentWorld :: Cradle -> IO World +getCurrentWorld crdl = do + pkgCaches <- timedPackageCache crdl + mCabalFile <- timeFile `traverse` cradleCabalFile crdl + mSetupConfig <- mightExist (setupConfigFile crdl) + mCabalConfig <- timeFile `traverse` mSetupConfig + + return World { + worldPackageCaches = pkgCaches + , worldCabalFile = mCabalFile + , worldCabalConfig = mCabalConfig + } + +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 :: Cradle -> IO Bool +isSetupConfigOutOfDate crdl = do + world <- getCurrentWorld crdl + return $ worldCabalConfig world < worldCabalFile world diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 968a0dc..e167607 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -88,12 +88,14 @@ Library Language.Haskell.GhcMod.Logger Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Monad + Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils Language.Haskell.GhcMod.Target Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils + Language.Haskell.GhcMod.World Build-Depends: base >= 4.0 && < 5 , containers , deepseq @@ -187,18 +189,18 @@ Test-Suite spec Hs-Source-Dirs: test, . Ghc-Options: -Wall Type: exitcode-stdio-1.0 - Other-Modules: Dir - Spec - BrowseSpec + Other-Modules: BrowseSpec CabalApiSpec CheckSpec + Dir FlagSpec InfoSpec LangSpec LintSpec ListSpec MonadSpec - GhcPkgSpec + PathsAndFilesSpec + Spec TestUtils Build-Depends: base >= 4.0 && < 5 , containers diff --git a/src/GHCMod.hs b/src/GHCMod.hs index a91bb65..b0c8307 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -442,7 +442,7 @@ legacyInteractiveLoop symdbreq ref world = do -- after blocking, we need to see if the world has changed. - changed <- liftIO . isWorldChanged world =<< cradle + changed <- liftIO . didWorldChange world =<< cradle when changed $ do liftIO $ ungetCommand ref cmdArg throw Restart diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 4b8601b..c9e958c 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -134,7 +134,7 @@ loop symdbreq ref world = do cmdArg <- liftIO $ getCommand ref -- after blocking, we need to see if the world has changed. crdl <- cradle - changed <- liftIO $ isWorldChanged world crdl + changed <- liftIO $ didWorldChange world crdl when changed $ do liftIO $ ungetCommand ref cmdArg E.throw Restart diff --git a/test/GhcPkgSpec.hs b/test/PathsAndFilesSpec.hs similarity index 69% rename from test/GhcPkgSpec.hs rename to test/PathsAndFilesSpec.hs index 991da50..aa46f12 100644 --- a/test/GhcPkgSpec.hs +++ b/test/PathsAndFilesSpec.hs @@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} -module GhcPkgSpec where +module PathsAndFilesSpec where -import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.PathsAndFiles #if __GLASGOW_HASKELL__ <= 706 import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.GhcPkg #endif import System.Directory @@ -23,7 +24,7 @@ spec = do it "can parse a config file and extract the sandbox package-db" $ do cwd <- getCurrentDirectory pkgDb <- getSandboxDb "test/data/" - pkgDb `shouldBe` (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") + pkgDb `shouldBe` Just (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") - it "throws an error if the sandbox config file is broken" $ do - getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException + it "returns Nothing if the sandbox config file is broken" $ do + getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing