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

Add in-memory caching otherwise everything is slow

Browse Source
This commit is contained in:
Daniel Gröber 2015-08-11 06:35:14 +02:00
parent 05360e0660
commit 11243e5304
9 changed files with 182 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -26,9 +26,9 @@ module Language.Haskell.GhcMod.CabalHelper
import Control.Applicative
import Control.Monad
import Control.Category ((.))
import Data.Maybe
import Data.Monoid
import Data.Version
import Data.Serialize (Serialize)
import Data.Traversable
import Distribution.Helper
@ -40,15 +40,16 @@ import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Logging
import System.FilePath
import Prelude
import Prelude hiding ((.))
import Paths_ghc_mod as GhcMod
-- | Only package related GHC options, sufficient for things that don't need to
-- access home modules
getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmLog m)
=> m [GHCOption]
getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
=> m [GHCOption]
getGhcMergedPkgOptions = chCached Cached {
cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),
cacheFile = mergedPkgOptsCacheFile,
cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do
opts <- withCabal $ runQuery' progs rootdir distdir $ ghcMergedPkgOptions
@ -67,13 +68,14 @@ getCustomPkgDbStack = do
mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle
return $ parseCustomPackageDb <$> mCusPkgDbFile
getPackageDbStack :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb]
getPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb]
getPackageDbStack = do
mCusPkgStack <- getCustomPkgDbStack
flip fromMaybe mCusPkgStack <$> getPackageDbStack'
getPackageDbStack' :: (IOish m, GmEnv m, GmLog m) => m [GhcPkgDb]
getPackageDbStack' :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb]
getPackageDbStack' = chCached Cached {
cacheLens = Just (lGmcPackageDbStack . lGmCaches),
cacheFile = pkgDbStackCacheFile,
cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do
dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs rootdir distdir packageDbStack
@ -90,14 +92,10 @@ chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f
--
-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by
-- 'resolveGmComponents'.
getComponents :: (Applicative m, IOish m, GmEnv m, GmLog m)
getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
=> m [GmComponent 'GMCRaw ChEntrypoint]
getComponents = chCached cabalHelperCache
cabalHelperCache
:: (Functor m, Applicative m, MonadIO m)
=> Cached m (Programs, FilePath, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint]
cabalHelperCache = Cached {
getComponents = chCached Cached {
cacheLens = Just (lGmcComponents . lGmCaches),
cacheFile = cabalHelperCacheFile,
cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma ->
runQuery' progs rootdir distdir $ do
@ -144,6 +142,8 @@ withCabal action = do
cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
--TODO: also invalidate when sandboxConfig file changed
when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $
gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."
when pkgDbStackOutOfSync $
@ -194,8 +194,8 @@ helperProgs opts = Programs {
ghcPkgProgram = T.ghcPkgProgram opts
}
chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a)
=> Cached m (Programs, FilePath, FilePath, (Version, [Char])) a -> m a
chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a)
=> Cached m GhcModState ChCacheData a -> m a
chCached c = do
root <- cradleRootDir <$> cradle
d <- cacheInputData root

97
Language/Haskell/GhcMod/Caching.hs
View File

@ -1,11 +1,16 @@
{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.GhcMod.Caching where
module Language.Haskell.GhcMod.Caching (
module Language.Haskell.GhcMod.Caching
, module Language.Haskell.GhcMod.Caching.Types
) where
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Maybe
import Data.Serialize
import Data.Serialize (Serialize, encode, decode)
import Data.Version
import Data.Label
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import System.FilePath
@ -13,54 +18,13 @@ import Utils (TimedFile(..), timeMaybe, mightExist)
import Paths_ghc_mod (version)
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Caching.Types
import Language.Haskell.GhcMod.Logging
data Cached m d a = Cached {
cacheFile :: FilePath,
cachedAction :: TimedCacheFiles
-> d
-> Maybe a
-> m ([FilePath], a)
-- ^ @cachedAction tcf data ma@
--
-- * @tcf@: Input file timestamps. Not technically necessary, just an
-- optimizazion when knowing which input files changed can make updating the
-- cache faster
--
-- * @data@: Arbitrary static input data to cache action. Can be used to
-- invalidate the cache using something other than file timestamps
-- i.e. environment tool version numbers
--
-- * @ma@: Cached data if it existed
--
-- Returns:
--
-- * @fst@: Input files used in generating the cache
--
-- * @snd@: Cache data, will be stored alongside the static input data in the
-- 'cacheFile'
--
-- The cached action, will only run if one of the following is true:
--
-- * 'cacheFile' doesn\'t exist yet
-- * 'cacheFile' exists and 'inputData' changed
-- * any files returned by the cached action changed
}
data TimedCacheFiles = TimedCacheFiles {
tcCacheFile :: Maybe TimedFile,
-- ^ 'cacheFile' timestamp
tcFiles :: [TimedFile]
-- ^ Timestamped files returned by the cached action
}
-- | Cache a MonadIO action with proper invalidation.
cached :: forall m a d. (MonadIO m, GmLog m, Serialize a, Eq d, Serialize d, Show d)
cached :: forall m a d. (MonadIO m, GmLog m, GmState m, Serialize a, Eq d, Serialize d, Show d)
=> FilePath -- ^ Directory to prepend to 'cacheFile'
-> Cached m d a -- ^ Cache descriptor
-> Cached m GhcModState d a -- ^ Cache descriptor
-> d
-> m a
cached dir cd d = do
@ -86,23 +50,42 @@ cached dir cd d = do
(ifs', a) <- (cachedAction cd) tcf d ma
gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)
<+> parens (text cause)
case cacheLens cd of
Nothing -> return ()
Just label -> do
gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd)
setLabel label $ Just (ifs', d, a)
liftIO $ BS.writeFile (dir </> cacheFile cd) $
BS.append cacheHeader $ encode (ifs', d, a)
return a
setLabel l x = do
s <- gmsGet
gmsPut $ set l x s
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
case first BS8.words $ BS8.span (/='\n') cc of
(["Written", "by", "ghc-mod", ver], rest)
| BS8.unpack ver == showVersion version ->
return $ either (const Nothing) Just $ decode $ BS.drop 1 rest
_ -> return Nothing
case cacheLens cd of
Just label -> do
c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile
setLabel label $ Just c
return c
Nothing ->
readCacheFromFile
readCacheFromFile = do
f <- MaybeT $ liftIO $ mightExist $ cacheFile cd
readCacheFromFile' f
readCacheFromFile' f = MaybeT $ do
gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd)
cc <- liftIO $ BS.readFile f
case first BS8.words $ BS8.span (/='\n') cc of
(["Written", "by", "ghc-mod", ver], rest)
| BS8.unpack ver == showVersion version ->
return $ either (const Nothing) Just $ decode $ BS.drop 1 rest
_ -> return Nothing
timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles
timeCacheInput dir cfile ifs = liftIO $ do

52
Language/Haskell/GhcMod/Caching/Types.hs Normal file
View File

@ -0,0 +1,52 @@
module Language.Haskell.GhcMod.Caching.Types where
import Utils
import Data.Label
import Data.Version
import Distribution.Helper
type CacheContents d a = Maybe ([FilePath], d, a)
type CacheLens s d a = s :-> CacheContents d a
data Cached m s d a = Cached {
cacheFile :: FilePath,
cacheLens :: Maybe (CacheLens s d a),
cachedAction :: TimedCacheFiles
-> d
-> Maybe a
-> m ([FilePath], a)
-- ^ @cachedAction tcf data ma@
--
-- * @tcf@: Input file timestamps. Not technically necessary, just an
-- optimizazion when knowing which input files changed can make updating the
-- cache faster
--
-- * @data@: Arbitrary static input data to cache action. Can be used to
-- invalidate the cache using something other than file timestamps
-- i.e. environment tool version numbers
--
-- * @ma@: Cached data if it existed
--
-- Returns:
--
-- * @fst@: Input files used in generating the cache
--
-- * @snd@: Cache data, will be stored alongside the static input data in the
-- 'cacheFile'
--
-- The cached action, will only run if one of the following is true:
--
-- * 'cacheFile' doesn\'t exist yet
-- * 'cacheFile' exists and 'inputData' changed
-- * any files returned by the cached action changed
}
data TimedCacheFiles = TimedCacheFiles {
tcCacheFile :: Maybe TimedFile,
-- ^ 'cacheFile' timestamp
tcFiles :: [TimedFile]
-- ^ Timestamped files returned by the cached action
}
type ChCacheData = (Programs, FilePath, FilePath, (Version, [Char]))

2
Language/Haskell/GhcMod/Modules.hs
View File

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

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

@ -30,6 +30,7 @@ module Language.Haskell.GhcMod.Monad.Types (
-- * Environment, state and logging
, GhcModEnv(..)
, GhcModState(..)
, GhcModCaches(..)
, defaultGhcModState
, GmGhcSession(..)
, GmComponent(..)
@ -78,7 +79,7 @@ import Control.Monad.Reader (ReaderT(..))
import Control.Monad.Error (ErrorT(..), MonadError(..))
import Control.Monad.State.Strict (StateT(..))
import Control.Monad.Trans.Journal (JournalT)
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Base (MonadBase(..), liftBase)
import Control.Monad.Trans.Control
@ -95,51 +96,13 @@ import qualified Control.Monad.IO.Class as MTL
import Data.Monoid (Monoid)
#endif
import Data.Set (Set)
import Data.Map as Map (Map, empty)
import Data.Maybe
import Data.Monoid
import Data.IORef
import Distribution.Helper
import Text.PrettyPrint (Doc)
import Prelude
import qualified MonadUtils as GHC (MonadIO(..))
data GhcModEnv = GhcModEnv {
gmOptions :: Options
, gmCradle :: Cradle
}
data GhcModLog = GhcModLog {
gmLogLevel :: Maybe GmLogLevel,
gmLogVomitDump :: Last Bool,
gmLogMessages :: [(GmLogLevel, String, Doc)]
} deriving (Show)
instance Monoid GhcModLog where
mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
data GmGhcSession = GmGhcSession {
gmgsOptions :: ![GHCOption],
gmgsSession :: !(IORef HscEnv)
}
data GhcModState = GhcModState {
gmGhcSession :: !(Maybe GmGhcSession)
, gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
, gmCompilerMode :: !CompilerMode
}
defaultGhcModState :: GhcModState
defaultGhcModState = GhcModState Nothing Map.empty Simple
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
----------------------------------------------------------------
-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'
-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that
-- means you can run (almost) all functions from the GHC API on top of 'GhcModT'
@ -270,6 +233,11 @@ instance Monad m => GmState (GhcModT m) where
gmsPut = GhcModT . put
gmsState = GhcModT . state
instance GmState m => GmState (MaybeT m) where
gmsGet = MaybeT $ Just `liftM` gmsGet
gmsPut = MaybeT . (Just `liftM`) . gmsPut
gmsState = MaybeT . (Just `liftM`) . gmsState
class Monad m => GmLog m where
gmlJournal :: GhcModLog -> m ()
gmlHistory :: m GhcModLog

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

@ -19,6 +19,7 @@ module Language.Haskell.GhcMod.Target where
import Control.Arrow
import Control.Applicative
import Control.Category ((.))
import Control.Monad.Reader (runReaderT)
import GHC
import GHC.Paths (libdir)
@ -53,7 +54,7 @@ import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Distribution.Helper
import Prelude
import Prelude hiding ((.))
import System.Directory
import System.FilePath
@ -86,7 +87,7 @@ runLightGhc env action = do
renv <- newIORef env
flip runReaderT renv $ unLightGhc action
runGmPkgGhc :: (IOish m, GmEnv m, GmLog m) => LightGhc a -> m a
runGmPkgGhc :: (IOish m, GmEnv m, GmState m, GmLog m) => LightGhc a -> m a
runGmPkgGhc action = do
pkgOpts <- packageGhcOptions
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
@ -203,10 +204,11 @@ targetGhcOptions crdl sefnmn = do
let cn = pickComponent candidates
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
resolvedComponentsCache :: IOish m => Cached (GhcModT m)
resolvedComponentsCache :: IOish m => Cached (GhcModT m) GhcModState
[GmComponent 'GMCRaw (Set.Set ModulePath)]
(Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
resolvedComponentsCache = Cached {
cacheLens = Just (lGmcResolvedComponents . lGmCaches),
cacheFile = resolvedComponentsCacheFile,
cachedAction = \tcfs comps ma -> do
Cradle {..} <- cradle
@ -282,7 +284,8 @@ findCandidates scns = foldl1 Set.intersection scns
pickComponent :: Set ChComponentName -> ChComponentName
pickComponent scn = Set.findMin scn
packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmLog m) => m [GHCOption]
packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
=> m [GHCOption]
packageGhcOptions = do
crdl <- cradle
case cradleCabalFile crdl of

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

@ -1,5 +1,5 @@
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric,
StandaloneDeriving, DefaultSignatures, FlexibleInstances #-}
StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
module Language.Haskell.GhcMod.Types (
module Language.Haskell.GhcMod.Types
@ -13,6 +13,7 @@ import Control.Monad.Error (Error(..))
import qualified Control.Monad.IO.Class as MTL
import Control.Exception (Exception)
import Control.Applicative
import Control.Monad
import Data.Serialize
import Data.Version
import Data.List (intercalate)
@ -23,16 +24,22 @@ import qualified Data.Set as Set
import Data.Monoid
import Data.Maybe
import Data.Typeable (Typeable)
import Data.IORef
import Data.Label.Derive
import Distribution.Helper
import Exception (ExceptionMonad)
#if __GLASGOW_HASKELL__ < 708
import qualified MonadUtils as GHC (MonadIO(..))
#endif
import GHC (ModuleName, moduleNameString, mkModuleName)
import HscTypes (HscEnv)
import PackageConfig (PackageConfig)
import GHC.Generics
import Text.PrettyPrint (Doc)
import Prelude
import Language.Haskell.GhcMod.Caching.Types
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
-- 'GhcModT' somewhat cleaner.
--
@ -114,6 +121,50 @@ data Cradle = Cradle {
, cradleCabalFile :: Maybe FilePath
} deriving (Eq, Show)
data GhcModEnv = GhcModEnv {
gmOptions :: Options
, gmCradle :: Cradle
}
data GhcModLog = GhcModLog {
gmLogLevel :: Maybe GmLogLevel,
gmLogVomitDump :: Last Bool,
gmLogMessages :: [(GmLogLevel, String, Doc)]
} deriving (Show)
instance Monoid GhcModLog where
mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
data GmGhcSession = GmGhcSession {
gmgsOptions :: ![GHCOption],
gmgsSession :: !(IORef HscEnv)
}
data GhcModCaches = GhcModCaches {
gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb]
, gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]
, gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]
, gmcResolvedComponents :: CacheContents
[GmComponent 'GMCRaw (Set.Set ModulePath)]
(Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
}
data GhcModState = GhcModState {
gmGhcSession :: !(Maybe GmGhcSession)
, gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
, gmCompilerMode :: !CompilerMode
, gmCaches :: !GhcModCaches
}
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
defaultGhcModState :: GhcModState
defaultGhcModState =
GhcModState n Map.empty Simple (GhcModCaches n n n n)
where n = Nothing
----------------------------------------------------------------
-- | GHC package database flags.
@ -303,3 +354,6 @@ instance Serialize Programs
instance Serialize ChModuleName
instance Serialize ChComponentName
instance Serialize ChEntrypoint
mkLabel ''GhcModCaches
mkLabel ''GhcModState

6
ghc-mod.cabal
View File

@ -87,7 +87,7 @@ Library
GHC-Options: -Wall -fno-warn-deprecations
Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
ConstraintKinds, FlexibleContexts,
DataKinds, KindSignatures
DataKinds, KindSignatures, TypeOperators
Exposed-Modules: Language.Haskell.GhcMod
Language.Haskell.GhcMod.Internal
Other-Modules: Paths_ghc_mod
@ -96,6 +96,7 @@ Library
Language.Haskell.GhcMod.Browse
Language.Haskell.GhcMod.CabalHelper
Language.Haskell.GhcMod.Caching
Language.Haskell.GhcMod.Caching.Types
Language.Haskell.GhcMod.CaseSplit
Language.Haskell.GhcMod.Check
Language.Haskell.GhcMod.Convert
@ -154,6 +155,7 @@ Library
, haskell-src-exts
, text
, djinn-ghc >= 0.0.2.2
, fclabels
if impl(ghc < 7.8)
Build-Depends: convertible
if impl(ghc < 7.5)
@ -213,7 +215,7 @@ Test-Suite spec
Default-Language: Haskell2010
Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
ConstraintKinds, FlexibleContexts,
DataKinds, KindSignatures
DataKinds, KindSignatures, TypeOperators
Main-Is: Main.hs
Hs-Source-Dirs: test, .
Ghc-Options: -Wall -fno-warn-deprecations

2
test/doctests.hs
View File

@ -9,7 +9,7 @@ main = doctest
, "-package", "transformers-" ++ VERSION_transformers
, "-package", "mtl-" ++ VERSION_mtl
, "-package", "directory-" ++ VERSION_directory
, "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures"
, "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators"
, "-idist/build/autogen/"
, "-optP-include"
, "-optPdist/build/autogen/cabal_macros.h"