Let Cabal determine the package-db stack
This commit is contained in:
parent
f85327a1b6
commit
8439f12cb0
@ -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
|
||||
|
@ -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
|
||||
|
@ -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,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 :/
|
||||
|
@ -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
|
||||
|
@ -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")
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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"]
|
||||
|
@ -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
12
test/data/custom-cradle/custom-cradle.cabal
Normal 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 +0,0 @@
|
||||
dummy
|
@ -1,5 +0,0 @@
|
||||
a/packages
|
||||
global
|
||||
b/packages
|
||||
user
|
||||
c/packages
|
5
test/data/custom-cradle/ghc-mod.package-db-stack
Normal file
5
test/data/custom-cradle/ghc-mod.package-db-stack
Normal 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
0
test/data/custom-cradle/package-db-a/.gitkeep
Normal file
0
test/data/custom-cradle/package-db-b/.gitkeep
Normal file
0
test/data/custom-cradle/package-db-b/.gitkeep
Normal file
0
test/data/custom-cradle/package-db-c/.gitkeep
Normal file
0
test/data/custom-cradle/package-db-c/.gitkeep
Normal file
Loading…
Reference in New Issue
Block a user