From 7019cbcfa1e16df1e0a9b8312cd3a7df29d2924e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Sat, 28 Mar 2015 02:30:51 +0100 Subject: [PATCH] Implement better caching for target options --- Language/Haskell/GhcMod/CabalHelper.hs | 34 ++++-- Language/Haskell/GhcMod/Caching.hs | 83 +++++++++++++++ Language/Haskell/GhcMod/Monad/Types.hs | 2 +- Language/Haskell/GhcMod/PathsAndFiles.hs | 67 ++---------- Language/Haskell/GhcMod/Target.hs | 127 +++++++++++++++-------- Language/Haskell/GhcMod/Types.hs | 61 ++++++++++- Utils.hs | 7 +- 7 files changed, 261 insertions(+), 120 deletions(-) create mode 100644 Language/Haskell/GhcMod/Caching.hs diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index 53a8e8f..74ad106 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -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))] diff --git a/Language/Haskell/GhcMod/Caching.hs b/Language/Haskell/GhcMod/Caching.hs new file mode 100644 index 0000000..db07af4 --- /dev/null +++ b/Language/Haskell/GhcMod/Caching.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index 8de1a8d..b6ee787 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -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 } diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index ac41f71..b1dcda3 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -14,27 +14,26 @@ -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -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" diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 498b41b..3a7c78d 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 5e43d80..dd2370d 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -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 diff --git a/Utils.hs b/Utils.hs index 8c1d057..7bfd18e 100644 --- a/Utils.hs +++ b/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