Fix caching for getGhcPkgOptions

This commit is contained in:
Daniel Gröber 2015-05-05 14:44:42 +02:00
parent 8b8f947b5e
commit c45a7f4b52
4 changed files with 24 additions and 19 deletions

View File

@ -38,11 +38,9 @@ import Paths_ghc_mod as GhcMod
-- | Only package related GHC options, sufficient for things that don't need to -- | Only package related GHC options, sufficient for things that don't need to
-- access home modules -- access home modules
getGhcPkgOptions :: (MonadIO m, GmEnv m) => m [(ChComponentName, [GHCOption])] getGhcPkgOptions :: (MonadIO m, GmEnv m, GmLog m)
getGhcPkgOptions = do => m [(ChComponentName, [GHCOption])]
Cradle {..} <- cradle getGhcPkgOptions = map (\c -> (gmcName c, gmcGhcPkgOpts c)) `liftM` getComponents
let distdir = cradleRootDir </> "dist"
runQuery distdir ghcPkgOptions
helperProgs :: Options -> Programs helperProgs :: Options -> Programs
helperProgs opts = Programs { helperProgs opts = Programs {
@ -76,25 +74,31 @@ cabalHelperCache = Cached {
cacheFile = cabalHelperCacheFile, cacheFile = cabalHelperCacheFile,
cachedAction = \ _ (progs, root, _) _ -> cachedAction = \ _ (progs, root, _) _ ->
runQuery' progs root $ do runQuery' progs root $ do
q <- liftM5 join5 q <- liftM7 join7
ghcOptions ghcOptions
ghcPkgOptions
ghcSrcOptions ghcSrcOptions
ghcLangOptions ghcLangOptions
entrypoints entrypoints
entrypoints
sourceDirs sourceDirs
let cs = flip map q $ \(cn, (opts, (srcOpts, (langOpts, (ep, srcDirs))))) -> let cs = flip map q $ curry8 (GmComponent mempty)
GmComponent cn opts srcOpts langOpts ep ep srcDirs mempty
return ([setupConfigPath], cs) return ([setupConfigPath], cs)
} }
where where
join5 a b c d = join' a . join' b . join' c . join' d curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h
liftM7 fn ma mb mc md me mf mg = do
a <- ma; b <- mb; c <- mc; d <- md; e <- me; f <- mf; g <- mg
return (fn a b c d e f g)
join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f
join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]
join' lb lc = [ (a, (b, c)) join' lb lc = [ (a, (b, c))
| (a, b) <- lb | (a, b) <- lb
, (a', c) <- lc , (a', c) <- lc
, a == a' , a == a'
] ]
withCabal :: (MonadIO m, GmEnv m) => m a -> m a withCabal :: (MonadIO m, GmEnv m) => m a -> m a
withCabal action = do withCabal action = do

View File

@ -14,7 +14,7 @@ import qualified GHC as G
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Listing installed modules. -- | Listing installed modules.
modules :: (IOish m, GmEnv m) => m String modules :: (IOish m, GmEnv m, GmLog m) => m String
modules = do modules = do
Options { detailed } <- options Options { detailed } <- options
df <- runGmPkgGhc G.getSessionDynFlags df <- runGmPkgGhc G.getSessionDynFlags

View File

@ -82,7 +82,7 @@ runLightGhc env action = do
renv <- newIORef env renv <- newIORef env
flip runReaderT renv $ unLightGhc action flip runReaderT renv $ unLightGhc action
runGmPkgGhc :: (IOish m, GmEnv m) => LightGhc a -> m a runGmPkgGhc :: (IOish m, GmEnv m, GmLog m) => LightGhc a -> m a
runGmPkgGhc action = do runGmPkgGhc action = do
pkgOpts <- packageGhcOptions pkgOpts <- packageGhcOptions
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
@ -258,7 +258,7 @@ findCandidates scns = foldl1 Set.intersection scns
pickComponent :: Set ChComponentName -> ChComponentName pickComponent :: Set ChComponentName -> ChComponentName
pickComponent scn = Set.findMin scn pickComponent scn = Set.findMin scn
packageGhcOptions :: (MonadIO m, GmEnv m) => m [GHCOption] packageGhcOptions :: (MonadIO m, GmEnv m, GmLog m) => m [GHCOption]
packageGhcOptions = do packageGhcOptions = do
crdl <- cradle crdl <- cradle
case cradleCabalFile crdl of case cradleCabalFile crdl of

View File

@ -210,14 +210,15 @@ instance Monoid GmModuleGraph where
data GmComponentType = GMCRaw data GmComponentType = GMCRaw
| GMCResolved | GMCResolved
data GmComponent (t :: GmComponentType) eps = GmComponent { data GmComponent (t :: GmComponentType) eps = GmComponent {
gmcHomeModuleGraph :: GmModuleGraph,
gmcName :: ChComponentName, gmcName :: ChComponentName,
gmcGhcOpts :: [GHCOption], gmcGhcOpts :: [GHCOption],
gmcGhcPkgOpts :: [GHCOption],
gmcGhcSrcOpts :: [GHCOption], gmcGhcSrcOpts :: [GHCOption],
gmcGhcLangOpts :: [GHCOption], gmcGhcLangOpts :: [GHCOption],
gmcRawEntrypoints :: ChEntrypoint, gmcRawEntrypoints :: ChEntrypoint,
gmcEntrypoints :: eps, gmcEntrypoints :: eps,
gmcSourceDirs :: [FilePath], gmcSourceDirs :: [FilePath]
gmcHomeModuleGraph :: GmModuleGraph
} deriving (Eq, Ord, Show, Read, Generic, Functor) } deriving (Eq, Ord, Show, Read, Generic, Functor)
instance Serialize eps => Serialize (GmComponent t eps) instance Serialize eps => Serialize (GmComponent t eps)