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