Add in-memory caching otherwise everything is slow
This commit is contained in:
		
							parent
							
								
									05360e0660
								
							
						
					
					
						commit
						11243e5304
					
				| @ -26,9 +26,9 @@ module Language.Haskell.GhcMod.CabalHelper | |||||||
| 
 | 
 | ||||||
| import Control.Applicative | import Control.Applicative | ||||||
| import Control.Monad | import Control.Monad | ||||||
|  | import Control.Category ((.)) | ||||||
| import Data.Maybe | import Data.Maybe | ||||||
| import Data.Monoid | import Data.Monoid | ||||||
| import Data.Version |  | ||||||
| import Data.Serialize (Serialize) | import Data.Serialize (Serialize) | ||||||
| import Data.Traversable | import Data.Traversable | ||||||
| import Distribution.Helper | import Distribution.Helper | ||||||
| @ -40,15 +40,16 @@ import Language.Haskell.GhcMod.Utils | |||||||
| import Language.Haskell.GhcMod.PathsAndFiles | import Language.Haskell.GhcMod.PathsAndFiles | ||||||
| import Language.Haskell.GhcMod.Logging | import Language.Haskell.GhcMod.Logging | ||||||
| import System.FilePath | import System.FilePath | ||||||
| import Prelude | import Prelude hiding ((.)) | ||||||
| 
 | 
 | ||||||
| import Paths_ghc_mod as GhcMod | 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 | ||||||
| getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmLog m) | getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m) | ||||||
|                  => m [GHCOption] |   => m [GHCOption] | ||||||
| getGhcMergedPkgOptions = chCached Cached { | getGhcMergedPkgOptions = chCached Cached { | ||||||
|  |   cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), | ||||||
|   cacheFile = mergedPkgOptsCacheFile, |   cacheFile = mergedPkgOptsCacheFile, | ||||||
|   cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do |   cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do | ||||||
|     opts <- withCabal $ runQuery' progs rootdir distdir $ ghcMergedPkgOptions |     opts <- withCabal $ runQuery' progs rootdir distdir $ ghcMergedPkgOptions | ||||||
| @ -67,13 +68,14 @@ getCustomPkgDbStack = do | |||||||
|     mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle |     mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle | ||||||
|     return $ parseCustomPackageDb <$> mCusPkgDbFile |     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 | getPackageDbStack = do | ||||||
|     mCusPkgStack <- getCustomPkgDbStack |     mCusPkgStack <- getCustomPkgDbStack | ||||||
|     flip fromMaybe mCusPkgStack <$> getPackageDbStack' |     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 { | getPackageDbStack' = chCached Cached { | ||||||
|  |   cacheLens = Just (lGmcPackageDbStack . lGmCaches), | ||||||
|   cacheFile = pkgDbStackCacheFile, |   cacheFile = pkgDbStackCacheFile, | ||||||
|   cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do |   cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do | ||||||
|     dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery' progs rootdir distdir packageDbStack |     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 | -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by | ||||||
| -- 'resolveGmComponents'. | -- '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] |               => m [GmComponent 'GMCRaw ChEntrypoint] | ||||||
| getComponents = chCached cabalHelperCache | getComponents = chCached Cached { | ||||||
| 
 |     cacheLens = Just (lGmcComponents . lGmCaches), | ||||||
| cabalHelperCache |  | ||||||
|   :: (Functor m, Applicative m, MonadIO m) |  | ||||||
|   => Cached m (Programs, FilePath, FilePath, (Version, String)) [GmComponent 'GMCRaw ChEntrypoint] |  | ||||||
| cabalHelperCache = Cached { |  | ||||||
|     cacheFile = cabalHelperCacheFile, |     cacheFile = cabalHelperCacheFile, | ||||||
|     cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> |     cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> | ||||||
|       runQuery' progs rootdir distdir $ do |       runQuery' progs rootdir distdir $ do | ||||||
| @ -144,6 +142,8 @@ withCabal action = do | |||||||
| 
 | 
 | ||||||
|     cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack |     cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack | ||||||
| 
 | 
 | ||||||
|  |     --TODO: also invalidate when sandboxConfig file changed | ||||||
|  | 
 | ||||||
|     when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ |     when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ | ||||||
|       gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." |       gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." | ||||||
|     when pkgDbStackOutOfSync $ |     when pkgDbStackOutOfSync $ | ||||||
| @ -194,8 +194,8 @@ helperProgs opts = Programs { | |||||||
|                             ghcPkgProgram = T.ghcPkgProgram opts |                             ghcPkgProgram = T.ghcPkgProgram opts | ||||||
|                           } |                           } | ||||||
| 
 | 
 | ||||||
| chCached :: (Applicative m, IOish m, GmEnv m, GmLog m, Serialize a) | chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a) | ||||||
|          => Cached m (Programs, FilePath, FilePath, (Version, [Char])) a -> m a |   => Cached m GhcModState ChCacheData a -> m a | ||||||
| chCached c = do | chCached c = do | ||||||
|   root <- cradleRootDir <$> cradle |   root <- cradleRootDir <$> cradle | ||||||
|   d <- cacheInputData root |   d <- cacheInputData root | ||||||
|  | |||||||
| @ -1,11 +1,16 @@ | |||||||
| {-# LANGUAGE OverloadedStrings #-} | {-# 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.Arrow (first) | ||||||
|  | import Control.Monad | ||||||
| import Control.Monad.Trans.Maybe | import Control.Monad.Trans.Maybe | ||||||
| import Data.Maybe | import Data.Maybe | ||||||
| import Data.Serialize | import Data.Serialize (Serialize, encode, decode) | ||||||
| import Data.Version | import Data.Version | ||||||
|  | import Data.Label | ||||||
| import qualified Data.ByteString as BS | import qualified Data.ByteString as BS | ||||||
| import qualified Data.ByteString.Char8 as BS8 | import qualified Data.ByteString.Char8 as BS8 | ||||||
| import System.FilePath | import System.FilePath | ||||||
| @ -13,54 +18,13 @@ import Utils (TimedFile(..), timeMaybe, mightExist) | |||||||
| import Paths_ghc_mod (version) | import Paths_ghc_mod (version) | ||||||
| 
 | 
 | ||||||
| import Language.Haskell.GhcMod.Monad.Types | import Language.Haskell.GhcMod.Monad.Types | ||||||
|  | import Language.Haskell.GhcMod.Caching.Types | ||||||
| import Language.Haskell.GhcMod.Logging | 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. | -- | 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' |        => FilePath -- ^ Directory to prepend to 'cacheFile' | ||||||
|        -> Cached m d a -- ^ Cache descriptor |        -> Cached m GhcModState d a -- ^ Cache descriptor | ||||||
|        -> d |        -> d | ||||||
|        -> m a |        -> m a | ||||||
| cached dir cd d = do | cached dir cd d = do | ||||||
| @ -86,23 +50,42 @@ cached dir cd d = do | |||||||
|      (ifs', a) <- (cachedAction cd) tcf d ma |      (ifs', a) <- (cachedAction cd) tcf d ma | ||||||
|      gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) |      gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) | ||||||
|                                                     <+> parens (text cause) |                                                     <+> 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) $ |      liftIO $ BS.writeFile (dir </> cacheFile cd) $ | ||||||
|          BS.append cacheHeader $ encode (ifs', d, a) |          BS.append cacheHeader $ encode (ifs', d, a) | ||||||
|      return a |      return a | ||||||
| 
 | 
 | ||||||
|  |    setLabel l x = do | ||||||
|  |      s <- gmsGet | ||||||
|  |      gmsPut $ set l x s | ||||||
|  | 
 | ||||||
|    readCache :: m (Maybe ([FilePath], d, a)) |    readCache :: m (Maybe ([FilePath], d, a)) | ||||||
|    readCache = runMaybeT $ do |    readCache = runMaybeT $ do | ||||||
|        f <- MaybeT $ liftIO $ mightExist $ cacheFile cd |        case cacheLens cd of | ||||||
|        MaybeT $ readCache' f |          Just label -> do | ||||||
|     where |              c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile | ||||||
|        readCache' f = do |              setLabel label $ Just c | ||||||
|          gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) |              return c | ||||||
|          cc <- liftIO $ BS.readFile f |          Nothing -> | ||||||
|          case first BS8.words $ BS8.span (/='\n') cc of |              readCacheFromFile | ||||||
|            (["Written", "by", "ghc-mod", ver], rest) | 
 | ||||||
|                | BS8.unpack ver == showVersion version -> |    readCacheFromFile = do | ||||||
|                 return $ either (const Nothing) Just $ decode $ BS.drop 1 rest |          f <- MaybeT $ liftIO $ mightExist $ cacheFile cd | ||||||
|            _ -> return Nothing |          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 :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles | ||||||
| timeCacheInput dir cfile ifs = liftIO $ do | timeCacheInput dir cfile ifs = liftIO $ do | ||||||
|  | |||||||
							
								
								
									
										52
									
								
								Language/Haskell/GhcMod/Caching/Types.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										52
									
								
								Language/Haskell/GhcMod/Caching/Types.hs
									
									
									
									
									
										Normal 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])) | ||||||
| @ -14,7 +14,7 @@ import qualified GHC as G | |||||||
| ---------------------------------------------------------------- | ---------------------------------------------------------------- | ||||||
| 
 | 
 | ||||||
| -- | Listing installed modules. | -- | 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 | modules = do | ||||||
|   Options { detailed } <- options |   Options { detailed } <- options | ||||||
|   df <- runGmPkgGhc G.getSessionDynFlags |   df <- runGmPkgGhc G.getSessionDynFlags | ||||||
|  | |||||||
| @ -30,6 +30,7 @@ module Language.Haskell.GhcMod.Monad.Types ( | |||||||
|   -- * Environment, state and logging |   -- * Environment, state and logging | ||||||
|   , GhcModEnv(..) |   , GhcModEnv(..) | ||||||
|   , GhcModState(..) |   , GhcModState(..) | ||||||
|  |   , GhcModCaches(..) | ||||||
|   , defaultGhcModState |   , defaultGhcModState | ||||||
|   , GmGhcSession(..) |   , GmGhcSession(..) | ||||||
|   , GmComponent(..) |   , GmComponent(..) | ||||||
| @ -78,7 +79,7 @@ import Control.Monad.Reader (ReaderT(..)) | |||||||
| import Control.Monad.Error (ErrorT(..), MonadError(..)) | import Control.Monad.Error (ErrorT(..), MonadError(..)) | ||||||
| import Control.Monad.State.Strict (StateT(..)) | import Control.Monad.State.Strict (StateT(..)) | ||||||
| import Control.Monad.Trans.Journal (JournalT) | 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.Base (MonadBase(..), liftBase) | ||||||
| import Control.Monad.Trans.Control | import Control.Monad.Trans.Control | ||||||
| @ -95,51 +96,13 @@ import qualified Control.Monad.IO.Class as MTL | |||||||
| import Data.Monoid (Monoid) | import Data.Monoid (Monoid) | ||||||
| #endif | #endif | ||||||
| 
 | 
 | ||||||
| import Data.Set (Set) |  | ||||||
| import Data.Map as Map (Map, empty) |  | ||||||
| import Data.Maybe | import Data.Maybe | ||||||
| import Data.Monoid | import Data.Monoid | ||||||
| import Data.IORef | import Data.IORef | ||||||
| import Distribution.Helper |  | ||||||
| import Text.PrettyPrint (Doc) |  | ||||||
| import Prelude | import Prelude | ||||||
| 
 | 
 | ||||||
| import qualified MonadUtils as GHC (MonadIO(..)) | 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' | -- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT' | ||||||
| -- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that | -- 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' | -- 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 |     gmsPut = GhcModT . put | ||||||
|     gmsState = GhcModT . state |     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 | class Monad m => GmLog m where | ||||||
|     gmlJournal :: GhcModLog -> m () |     gmlJournal :: GhcModLog -> m () | ||||||
|     gmlHistory :: m GhcModLog |     gmlHistory :: m GhcModLog | ||||||
|  | |||||||
| @ -19,6 +19,7 @@ module Language.Haskell.GhcMod.Target where | |||||||
| 
 | 
 | ||||||
| import Control.Arrow | import Control.Arrow | ||||||
| import Control.Applicative | import Control.Applicative | ||||||
|  | import Control.Category ((.)) | ||||||
| import Control.Monad.Reader (runReaderT) | import Control.Monad.Reader (runReaderT) | ||||||
| import GHC | import GHC | ||||||
| import GHC.Paths (libdir) | import GHC.Paths (libdir) | ||||||
| @ -53,7 +54,7 @@ import qualified Data.Map  as Map | |||||||
| import Data.Set (Set) | import Data.Set (Set) | ||||||
| import qualified Data.Set as Set | import qualified Data.Set as Set | ||||||
| import Distribution.Helper | import Distribution.Helper | ||||||
| import Prelude | import Prelude hiding ((.)) | ||||||
| 
 | 
 | ||||||
| import System.Directory | import System.Directory | ||||||
| import System.FilePath | import System.FilePath | ||||||
| @ -86,7 +87,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, GmLog m) => LightGhc a -> m a | runGmPkgGhc :: (IOish m, GmEnv m, GmState 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 | ||||||
| @ -203,10 +204,11 @@ targetGhcOptions crdl sefnmn = do | |||||||
|             let cn = pickComponent candidates |             let cn = pickComponent candidates | ||||||
|             return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs |             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)] |     [GmComponent 'GMCRaw (Set.Set ModulePath)] | ||||||
|     (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) |     (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) | ||||||
| resolvedComponentsCache = Cached { | resolvedComponentsCache = Cached { | ||||||
|  |     cacheLens = Just (lGmcResolvedComponents . lGmCaches), | ||||||
|     cacheFile  = resolvedComponentsCacheFile, |     cacheFile  = resolvedComponentsCacheFile, | ||||||
|     cachedAction = \tcfs comps ma -> do |     cachedAction = \tcfs comps ma -> do | ||||||
|         Cradle {..} <- cradle |         Cradle {..} <- cradle | ||||||
| @ -282,7 +284,8 @@ 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 :: (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 | packageGhcOptions = do | ||||||
|     crdl <- cradle |     crdl <- cradle | ||||||
|     case cradleCabalFile crdl of |     case cradleCabalFile crdl of | ||||||
|  | |||||||
| @ -1,5 +1,5 @@ | |||||||
| {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, | {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, | ||||||
|   StandaloneDeriving, DefaultSignatures, FlexibleInstances #-} |   StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-} | ||||||
| {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} | {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} | ||||||
| module Language.Haskell.GhcMod.Types ( | module Language.Haskell.GhcMod.Types ( | ||||||
|     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 qualified Control.Monad.IO.Class as MTL | ||||||
| import Control.Exception (Exception) | import Control.Exception (Exception) | ||||||
| import Control.Applicative | import Control.Applicative | ||||||
|  | import Control.Monad | ||||||
| import Data.Serialize | import Data.Serialize | ||||||
| import Data.Version | import Data.Version | ||||||
| import Data.List (intercalate) | import Data.List (intercalate) | ||||||
| @ -23,16 +24,22 @@ import qualified Data.Set as Set | |||||||
| import Data.Monoid | import Data.Monoid | ||||||
| import Data.Maybe | import Data.Maybe | ||||||
| import Data.Typeable (Typeable) | import Data.Typeable (Typeable) | ||||||
|  | import Data.IORef | ||||||
|  | import Data.Label.Derive | ||||||
| import Distribution.Helper | import Distribution.Helper | ||||||
| import Exception (ExceptionMonad) | import Exception (ExceptionMonad) | ||||||
| #if __GLASGOW_HASKELL__ < 708 | #if __GLASGOW_HASKELL__ < 708 | ||||||
| import qualified MonadUtils as GHC (MonadIO(..)) | import qualified MonadUtils as GHC (MonadIO(..)) | ||||||
| #endif | #endif | ||||||
| import GHC (ModuleName, moduleNameString, mkModuleName) | import GHC (ModuleName, moduleNameString, mkModuleName) | ||||||
|  | import HscTypes (HscEnv) | ||||||
| import PackageConfig (PackageConfig) | import PackageConfig (PackageConfig) | ||||||
| import GHC.Generics | import GHC.Generics | ||||||
|  | import Text.PrettyPrint (Doc) | ||||||
| import Prelude | import Prelude | ||||||
| 
 | 
 | ||||||
|  | import Language.Haskell.GhcMod.Caching.Types | ||||||
|  | 
 | ||||||
| -- | A constraint alias (-XConstraintKinds) to make functions dealing with | -- | A constraint alias (-XConstraintKinds) to make functions dealing with | ||||||
| -- 'GhcModT' somewhat cleaner. | -- 'GhcModT' somewhat cleaner. | ||||||
| -- | -- | ||||||
| @ -114,6 +121,50 @@ data Cradle = Cradle { | |||||||
|   , cradleCabalFile  :: Maybe FilePath |   , cradleCabalFile  :: Maybe FilePath | ||||||
|   } deriving (Eq, Show) |   } 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. | -- | GHC package database flags. | ||||||
| @ -303,3 +354,6 @@ instance Serialize Programs | |||||||
| instance Serialize ChModuleName | instance Serialize ChModuleName | ||||||
| instance Serialize ChComponentName | instance Serialize ChComponentName | ||||||
| instance Serialize ChEntrypoint | instance Serialize ChEntrypoint | ||||||
|  | 
 | ||||||
|  | mkLabel ''GhcModCaches | ||||||
|  | mkLabel ''GhcModState | ||||||
|  | |||||||
| @ -87,7 +87,7 @@ Library | |||||||
|   GHC-Options:          -Wall -fno-warn-deprecations |   GHC-Options:          -Wall -fno-warn-deprecations | ||||||
|   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns, |   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns, | ||||||
|                         ConstraintKinds, FlexibleContexts, |                         ConstraintKinds, FlexibleContexts, | ||||||
|                         DataKinds, KindSignatures |                         DataKinds, KindSignatures, TypeOperators | ||||||
|   Exposed-Modules:      Language.Haskell.GhcMod |   Exposed-Modules:      Language.Haskell.GhcMod | ||||||
|                         Language.Haskell.GhcMod.Internal |                         Language.Haskell.GhcMod.Internal | ||||||
|   Other-Modules:        Paths_ghc_mod |   Other-Modules:        Paths_ghc_mod | ||||||
| @ -96,6 +96,7 @@ Library | |||||||
|                         Language.Haskell.GhcMod.Browse |                         Language.Haskell.GhcMod.Browse | ||||||
|                         Language.Haskell.GhcMod.CabalHelper |                         Language.Haskell.GhcMod.CabalHelper | ||||||
|                         Language.Haskell.GhcMod.Caching |                         Language.Haskell.GhcMod.Caching | ||||||
|  |                         Language.Haskell.GhcMod.Caching.Types | ||||||
|                         Language.Haskell.GhcMod.CaseSplit |                         Language.Haskell.GhcMod.CaseSplit | ||||||
|                         Language.Haskell.GhcMod.Check |                         Language.Haskell.GhcMod.Check | ||||||
|                         Language.Haskell.GhcMod.Convert |                         Language.Haskell.GhcMod.Convert | ||||||
| @ -154,6 +155,7 @@ Library | |||||||
|                       , haskell-src-exts |                       , haskell-src-exts | ||||||
|                       , text |                       , text | ||||||
|                       , djinn-ghc >= 0.0.2.2 |                       , djinn-ghc >= 0.0.2.2 | ||||||
|  |                       , fclabels | ||||||
|   if impl(ghc < 7.8) |   if impl(ghc < 7.8) | ||||||
|     Build-Depends:      convertible |     Build-Depends:      convertible | ||||||
|   if impl(ghc < 7.5) |   if impl(ghc < 7.5) | ||||||
| @ -213,7 +215,7 @@ Test-Suite spec | |||||||
|   Default-Language:     Haskell2010 |   Default-Language:     Haskell2010 | ||||||
|   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns, |   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns, | ||||||
|                         ConstraintKinds, FlexibleContexts, |                         ConstraintKinds, FlexibleContexts, | ||||||
|                         DataKinds, KindSignatures |                         DataKinds, KindSignatures, TypeOperators | ||||||
|   Main-Is:              Main.hs |   Main-Is:              Main.hs | ||||||
|   Hs-Source-Dirs:       test, . |   Hs-Source-Dirs:       test, . | ||||||
|   Ghc-Options:          -Wall -fno-warn-deprecations |   Ghc-Options:          -Wall -fno-warn-deprecations | ||||||
|  | |||||||
| @ -9,7 +9,7 @@ main = doctest | |||||||
|   , "-package", "transformers-" ++ VERSION_transformers |   , "-package", "transformers-" ++ VERSION_transformers | ||||||
|   , "-package", "mtl-" ++ VERSION_mtl |   , "-package", "mtl-" ++ VERSION_mtl | ||||||
|   , "-package", "directory-" ++ VERSION_directory |   , "-package", "directory-" ++ VERSION_directory | ||||||
|   , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures" |   , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators" | ||||||
|   , "-idist/build/autogen/" |   , "-idist/build/autogen/" | ||||||
|   , "-optP-include" |   , "-optP-include" | ||||||
|   , "-optPdist/build/autogen/cabal_macros.h" |   , "-optPdist/build/autogen/cabal_macros.h" | ||||||
|  | |||||||
		Loading…
	
		Reference in New Issue
	
	Block a user
	 Daniel Gröber
						Daniel Gröber