Implement better caching for target options
This commit is contained in:
parent
90d9577f8d
commit
7019cbcfa1
@ -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
83
Language/Haskell/GhcMod/Caching.hs
Normal 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
|
@ -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
|
||||
}
|
||||
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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
7
Utils.hs
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user