hasufell
/
ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Implement better caching for target options

This commit is contained in:
Daniel Gröber 2015-03-28 02:30:51 +01:00
parent 90d9577f8d
commit 7019cbcfa1
7 changed files with 261 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
Language/Haskell/GhcMod/CabalHelper.hs
View File

@ -22,6 +22,7 @@ module Language.Haskell.GhcMod.CabalHelper (
import Control.Applicative
import Control.Monad
import Data.Monoid
import Data.Version
import Distribution.Helper
import qualified Language.Haskell.GhcMod.Types as T
import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
@ -52,16 +53,31 @@ helperProgs opts = Programs {
--
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
-- 'resolveGmComponents'.
getComponents :: (MonadIO m, GmEnv m) => m [GmComponent ChEntrypoint]
getComponents = withCabal $ do
Cradle {..} <- cradle
let distdir = cradleRootDir </> "dist"
opt <- options
getComponents :: (MonadIO m, GmEnv m, GmLog m)
=> m [GmComponent GMCRaw ChEntrypoint]
getComponents = do
opt <- options
Cradle {..} <- cradle
let gmVer = GhcMod.version
chVer = VERSION_cabal_helper
d = (helperProgs opt
, cradleRootDir </> "dist"
, (gmVer, chVer)
)
withCabal $ cached cradleRootDir cabalHelperCache d
runQuery' (helperProgs opt) distdir $ do
q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs
return $ flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) ->
GmComponent cn opts srcOpts ep ep srcDirs mempty
cabalHelperCache :: MonadIO m => Cached m
(Programs, FilePath, (Version, String))
[GmComponent GMCRaw ChEntrypoint]
cabalHelperCache = Cached {
cacheFile = cabalHelperCacheFile,
cachedAction = \ _ (progs, root, _) ->
runQuery' progs root $ do
q <- liftM4 join4 ghcOptions ghcSrcOptions entrypoints sourceDirs
let cs = flip map q $ \(cn, (opts, (srcOpts, (ep, srcDirs)))) ->
GmComponent cn opts srcOpts ep ep srcDirs mempty
return ([setupConfigPath], cs)
}
where
join4 a b c = join' a . join' b . join' c
join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]

83
Language/Haskell/GhcMod/Caching.hs Normal file
View File

@ -0,0 +1,83 @@
module Language.Haskell.GhcMod.Caching where
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Serialize
import qualified Data.ByteString as BS
import System.FilePath
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Logging
import Utils
data Cached m d a =
Cached { cacheFile :: FilePath,
cachedAction :: TimedCacheFiles -> d -> m ([FilePath], a)
-- ^ The cached action, will only run if
-- * The cache doesn\'t exist yet
-- * The cache exists and 'inputData' changed
-- * any files in 'inputFiles' are older than 'cacheFile'.
}
data TimedCacheFiles =
TimedCacheFiles { tcCacheFile :: Maybe TimedFile,
tcFiles :: [TimedFile]
}
-- | Cache a MonadIO action with proper invalidation.
cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d)
=> FilePath -- ^ Directory to prepend to 'cacheFile'
-> Cached m d a -- ^ Cache descriptor
-> d
-> m a
cached dir cd d = do
mcc <- readCache
tcfile <- liftIO $ timeMaybe (cacheFile cd)
let defTcf = TimedCacheFiles tcfile []
case mcc of
Nothing -> writeCache defTcf "cache missing"
Just (ifs, d', _) | d /= d' -> do
tcf <- timeCacheInput dir (cacheFile cd) ifs
writeCache tcf "input data changed"
Just (ifs, _, a) -> do
tcf <- timeCacheInput dir (cacheFile cd) ifs
let invifs = invalidatingInputFiles tcf
case invifs of
Nothing -> writeCache tcf "cache missing, existed a sec ago WTF?"
Just [] -> return a
Just _ -> writeCache tcf "input files changed"
where
writeCache tcf cause = do
(ifs', a) <- (cachedAction cd) tcf d
gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)
<+> parens (text cause)
liftIO $ BS.writeFile (dir </> cacheFile cd) $ encode (ifs', d, a)
return a
readCache :: m (Maybe ([FilePath], d, a))
readCache = runMaybeT $ do
f <- MaybeT $ liftIO $ mightExist $ cacheFile cd
MaybeT $ readCache' f
where
readCache' f = do
gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd)
cc <- liftIO $ BS.readFile f
return $ either (const Nothing) Just $ decode cc
timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles
timeCacheInput dir cfile ifs = liftIO $ do
-- TODO: is checking the times this way around race free?
ins <- (timeMaybe . (dir </>)) `mapM` ifs
mtcfile <- timeMaybe cfile
return $ TimedCacheFiles mtcfile (catMaybes ins)
invalidatingInputFiles :: TimedCacheFiles -> Maybe [FilePath]
invalidatingInputFiles tcf =
case tcCacheFile tcf of
Nothing -> Nothing
Just tcfile -> Just $ map tfPath $
-- get input files older than tcfile
filter (tcfile<) $ tcFiles tcf

2
Language/Haskell/GhcMod/Monad/Types.hs
View File

@ -129,7 +129,7 @@ data GmGhcSession = GmGhcSession {
data GhcModState = GhcModState {
gmGhcSession :: !(Maybe GmGhcSession)
, gmComponents :: !(Map ChComponentName (GmComponent (Set ModulePath)))
, gmComponents :: !(Map ChComponentName (GmComponent GMCResolved (Set ModulePath)))
, gmCompilerMode :: !CompilerMode
}

67
Language/Haskell/GhcMod/PathsAndFiles.hs
View File

@ -14,27 +14,26 @@
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.PathsAndFiles where
module Language.Haskell.GhcMod.PathsAndFiles (
module Language.Haskell.GhcMod.PathsAndFiles
, module Language.Haskell.GhcMod.Caching
) where
import Config (cProjectVersion)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.List
import Data.Char
import Data.Maybe
import Data.Version
import Data.Traversable (traverse)
import Distribution.Helper
import System.Directory
import System.FilePath
import System.IO.Unsafe
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Read
import Language.Haskell.GhcMod.Utils hiding (dropWhileEnd)
import Language.Haskell.GhcMod.Caching
import qualified Language.Haskell.GhcMod.Utils as U
-- | Guaranteed to be a path to a directory with no trailing slash.
@ -43,12 +42,6 @@ type DirPath = FilePath
-- | Guaranteed to be the name of a file only (no slashes).
type FileName = String
data Cached d a = Cached {
inputFiles :: [FilePath],
inputData :: d,
cacheFile :: FilePath
}
newtype UnString = UnString { unString :: String }
instance Show UnString where
@ -57,43 +50,6 @@ instance Show UnString where
instance Read UnString where
readsPrec _ = \str -> [(UnString str, "")]
-- |
--
-- >>> any (Just 3 <) [Just 1, Nothing, Just 2]
-- False
--
-- >>> any (Just 0 <) [Just 1, Nothing, Just 2]
-- True
--
-- >>> any (Just 0 <) [Nothing]
-- False
--
-- >>> any (Just 0 <) []
-- False
cached :: forall a d. (Read a, Show a, Eq d, Read d, Show d)
=> DirPath -> Cached d a -> IO a -> IO a
cached dir Cached {..} ma = do
ins <- (maybeTimeFile . (dir </>)) `mapM` inputFiles
c <- maybeTimeFile (dir </> cacheFile)
if any (c<) ins || isNothing c
then writeCache
else maybe ma return =<< readCache
where
maybeTimeFile :: FilePath -> IO (Maybe TimedFile)
maybeTimeFile f = traverse timeFile =<< mightExist f
writeCache = do
a <- ma
writeFile (dir </> cacheFile) $ unlines [show inputData, show a]
return a
readCache :: IO (Maybe a)
readCache = runMaybeT $ do
hdr:c:_ <- lines <$> liftIO (readFile $ dir </> cacheFile)
if inputData /= read hdr
then liftIO $ writeCache
else MaybeT $ return $ readMaybe c
-- | @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
@ -235,13 +191,6 @@ cabalBuildPlatform = dropWhileEnd isSpace $ unsafePerformIO $
packageCache :: String
packageCache = "package.cache"
cabalHelperCache :: Version -> [String]
-> Cached (Version, [String]) [GmComponent ChEntrypoint]
cabalHelperCache cabalHelperVer cmds = Cached {
inputFiles = [setupConfigPath],
inputData = (cabalHelperVer, cmds),
cacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"
}
-- | Filename of the symbol table cache file.
symbolCache :: Cradle -> FilePath
@ -249,3 +198,9 @@ symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
symbolCacheFile :: String
symbolCacheFile = "ghc-mod.symbol-cache"
resolvedComponentsCacheFile :: String
resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components"
cabalHelperCacheFile :: String
cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-helper"

127
Language/Haskell/GhcMod/Target.hs
View File

@ -32,6 +32,7 @@ import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.CabalHelper
import Language.Haskell.GhcMod.HomeModuleGraph
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Logging
@ -154,7 +155,7 @@ runGmlTWith efnmns' mdf wrapper action = do
loadTargets (map moduleNameString mns ++ rfns)
action
targetGhcOptions :: IOish m
targetGhcOptions :: forall m. IOish m
=> Cradle
-> Set (Either FilePath ModuleName)
-> GhcModT m [GHCOption]
@ -162,12 +163,15 @@ targetGhcOptions crdl sefnmn = do
when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
case cradleCabalFile crdl of
Just _ -> cabalOpts
Just _ -> cabalOpts crdl
Nothing -> sandboxOpts crdl
where
zipMap f l = l `zip` (f `map` l)
cabalOpts = do
mcs <- resolveGmComponents Nothing =<< getComponents
cabalOpts :: Cradle -> GhcModT m [String]
cabalOpts Cradle{..} = do
comps <- mapM (resolveEntrypoint crdl) =<< getComponents
mcs <- cached cradleRootDir resolvedComponentsCache comps
let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
candidates = Set.unions $ map snd mdlcs
@ -186,7 +190,36 @@ targetGhcOptions crdl sefnmn = do
let cn = pickComponent candidates
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
moduleComponents :: Map ChComponentName (GmComponent (Set ModulePath))
resolvedComponentsCache :: IOish m => Cached (GhcModT m)
[GmComponent GMCRaw(Set.Set ModulePath)]
(Map.Map ChComponentName (GmComponent GMCResolved (Set.Set ModulePath)))
resolvedComponentsCache = Cached {
cacheFile = resolvedComponentsCacheFile,
cachedAction = \tcfs comps -> do
Cradle {..} <- cradle
let changedFiles =
filter (/= cradleRootDir </> setupConfigPath) $ map tfPath $ tcFiles tcfs
mums = if null changedFiles
then Nothing
else Just $ map Left changedFiles
mcs <- resolveGmComponents mums comps
return (setupConfigPath:flatten mcs , mcs)
}
where
flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath))
-> [FilePath]
flatten = Map.elems
>>> map (gmcHomeModuleGraph >>> gmgGraph
>>> Map.elems
>>> map (Set.map mpPath)
>>> Set.unions
)
>>> Set.unions
>>> Set.toList
moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath))
-> Either FilePath ModuleName
-> Set ChComponentName
moduleComponents m efnmn =
@ -216,52 +249,57 @@ packageGhcOptions = do
Nothing -> sandboxOpts crdl
sandboxOpts :: Monad m => Cradle -> m [String]
sandboxOpts crdl = return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts
sandboxOpts crdl =
return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]
where
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack crdl
(wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
=> Maybe [Either FilePath ModuleName] -- ^ Updated modules
-> GmComponent ChEntrypoint
-> m (GmComponent (Set ModulePath))
resolveGmComponent mums c@GmComponent {..} =
-> GmComponent GMCRaw (Set ModulePath)
-> m (GmComponent GMCResolved (Set ModulePath))
resolveGmComponent mums c@GmComponent {..} = do
withLightHscEnv gmcGhcSrcOpts $ \env -> do
let srcDirs = gmcSourceDirs
mg = gmcHomeModuleGraph
Cradle { cradleRootDir } <- cradle
eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
simp <- liftIO $ resolveEntrypoints env srcDirs eps
sump <- liftIO $ case mums of
let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
let mg = gmcHomeModuleGraph
let simp = gmcEntrypoints
sump <- case mums of
Nothing -> return simp
Just ums -> resolveEntrypoints env srcDirs ums
Just ums -> Set.fromList . catMaybes <$> mapM (resolveModule env srcDirs) ums
mg' <- updateHomeModuleGraph env mg simp sump
return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }
resolveEntrypoints :: MonadIO m
=> HscEnv -> [FilePath] -> [Either FilePath ModuleName] -> m (Set ModulePath)
resolveEntrypoints env srcDirs ms =
liftIO $ Set.fromList . catMaybes <$> resolve `mapM` ms
resolveEntrypoint :: IOish m
=> Cradle
-> GmComponent GMCRaw ChEntrypoint
-> m (GmComponent GMCRaw (Set ModulePath))
resolveEntrypoint Cradle {..} c@GmComponent {..} =
withLightHscEnv gmcGhcSrcOpts $ \env -> do
let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
rms <- resolveModule env srcDirs `mapM` eps
return c { gmcEntrypoints = Set.fromList $ catMaybes rms }
resolveModule :: MonadIO m =>
HscEnv -> [FilePath] -> Either FilePath ModuleName -> m (Maybe ModulePath)
resolveModule env _srcDirs (Right mn) = liftIO $ findModulePath env mn
resolveModule env srcDirs (Left fn') = liftIO $ do
mfn <- findFile' srcDirs fn'
case mfn of
Nothing -> return Nothing
Just fn'' -> do
let fn = normalise fn''
emn <- fileModuleName env fn
return $ case emn of
Left _ -> Nothing
Right mmn -> Just $
case mmn of
Nothing -> mkMainModulePath fn
Just mn -> ModulePath mn fn
where
resolve :: Either FilePath ModuleName -> IO (Maybe ModulePath)
resolve (Right mn) = findModulePath env mn
resolve (Left fn') = do
mfn <- findFile' srcDirs fn'
case mfn of
Nothing -> return Nothing
Just fn'' -> do
let fn = normalise fn''
emn <- fileModuleName env fn
return $ case emn of
Left _ -> Nothing
Right mmn -> Just $
case mmn of
Nothing -> mkMainModulePath fn
Just mn -> ModulePath mn fn
findFile' dirs file =
mconcat <$> mapM (mightExist . (</>file)) dirs
@ -284,11 +322,11 @@ resolveChEntrypoints srcDir ChSetupEntrypoint = do
chModToMod :: ChModuleName -> ModuleName
chModToMod (ChModuleName mn) = mkModuleName mn
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
=> Maybe [Either FilePath ModuleName]
-- ^ Updated modules
-> [GmComponent ChEntrypoint]
-> m (Map ChComponentName (GmComponent (Set ModulePath)))
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m) =>
Maybe [Either FilePath ModuleName]
-- ^ Updated modules
-> [GmComponent GMCRaw (Set ModulePath)]
-> m (Map ChComponentName (GmComponent GMCResolved (Set ModulePath)))
resolveGmComponents mumns cs = do
s <- gmsGet
m' <- foldrM' (gmComponents s) cs $ \c m -> do
@ -307,11 +345,10 @@ resolveGmComponents mumns cs = do
return $ Map.insert (gmcName rc) rc m
same :: Eq b
=> (forall a. GmComponent a -> b)
-> GmComponent c -> GmComponent d -> Bool
=> (forall t a. GmComponent t a -> b)
-> GmComponent u c -> GmComponent v d -> Bool
same f a b = (f a) == (f b)
-- | Set the files as targets and load them.
loadTargets :: IOish m => [String] -> GmlT m ()
loadTargets filesOrModules = do

61
Language/Haskell/GhcMod/Types.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable, GADTs, StandaloneDeriving, DataKinds #-}
{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, StandaloneDeriving,
DefaultSignatures #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
module Language.Haskell.GhcMod.Types (
module Language.Haskell.GhcMod.Types
@ -10,18 +11,24 @@ module Language.Haskell.GhcMod.Types (
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Error (Error(..))
import Control.Exception (Exception)
import Control.Applicative
import Control.Arrow
import Data.Serialize
import Data.Version
import Data.List (intercalate)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Monoid
import Data.Maybe
import Data.Typeable (Typeable)
import Distribution.Helper
import Exception (ExceptionMonad)
import MonadUtils (MonadIO)
import GHC (ModuleName, moduleNameString, mkModuleName)
import PackageConfig (PackageConfig)
import GHC.Generics
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
-- 'GhcModT' somewhat cleaner.
@ -158,14 +165,42 @@ data GmModuleGraph = GmModuleGraph {
gmgFileMap :: Map FilePath ModulePath,
gmgModuleMap :: Map ModuleName ModulePath,
gmgGraph :: Map ModulePath (Set ModulePath)
} deriving (Eq, Ord, Show, Read, Typeable)
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize GmModuleGraph where
put GmModuleGraph {..} = let
mpim :: Map ModulePath Integer
graph :: Map Integer (Set Integer)
mpim = Map.fromList $
(Map.keys gmgGraph) `zip` [0..]
mpToInt :: ModulePath -> Integer
mpToInt mp = fromJust $ Map.lookup mp mpim
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
in put (mpim, graph)
get = do
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
let
swapMap = Map.fromList . map swap . Map.toList
swap (a,b) = (b,a)
impm = swapMap mpim
intToMp i = fromJust $ Map.lookup i impm
mpGraph :: Map ModulePath (Set ModulePath)
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
mpFm = Map.fromList $ map (mpPath &&& id) $ Map.keys mpim
mpMn = Map.fromList $ map (mpModule &&& id) $ Map.keys mpim
return $ GmModuleGraph mpFm mpMn mpGraph
instance Monoid GmModuleGraph where
mempty = GmModuleGraph mempty mempty mempty
mappend (GmModuleGraph a b c) (GmModuleGraph a' b' c') =
GmModuleGraph (a <> a') (b <> b') (Map.unionWith Set.union c c')
data GmComponent eps = GmComponent {
data GmComponentType = GMCRaw
| GMCResolved
data GmComponent (t :: GmComponentType) eps = GmComponent {
gmcName :: ChComponentName,
gmcGhcOpts :: [GHCOption],
gmcGhcSrcOpts :: [GHCOption],
@ -173,10 +208,17 @@ data GmComponent eps = GmComponent {
gmcEntrypoints :: eps,
gmcSourceDirs :: [FilePath],
gmcHomeModuleGraph :: GmModuleGraph
} deriving (Eq, Ord, Show, Read, Typeable)
} deriving (Eq, Ord, Show, Read, Generic, Typeable, Functor)
instance Serialize eps => Serialize (GmComponent t eps)
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
deriving (Eq, Ord, Show, Read, Typeable)
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize ModulePath
instance Serialize ModuleName where
get = mkModuleName <$> get
put mn = put (moduleNameString mn)
instance Show ModuleName where
show mn = "ModuleName " ++ show (moduleNameString mn)
@ -235,3 +277,12 @@ data GMConfigStateFileError
| GMConfigStateFileMissing
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
deriving (Eq, Show, Read, Typeable)
deriving instance Generic Version
instance Serialize Version
instance Serialize Programs
instance Serialize ChModuleName
instance Serialize ChComponentName
instance Serialize ChEntrypoint

7
Utils.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE CPP #-}
module Utils where
import Control.Monad
import Control.Applicative
import Data.Traversable
import System.Directory
@ -18,7 +17,8 @@ type ModTime = UTCTime
type ModTime = ClockTime
#endif
data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show)
data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime }
deriving (Eq, Show)
instance Ord TimedFile where
compare (TimedFile _ a) (TimedFile _ b) = compare a b
@ -32,5 +32,4 @@ mightExist f = do
return $ if exists then (Just f) else (Nothing)
timeMaybe :: FilePath -> IO (Maybe TimedFile)
timeMaybe f = do
join $ (timeFile `traverse`) <$> mightExist f
timeMaybe f = traverse timeFile =<< mightExist f