diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs index 9e38117de3..14ab0f3578 100644 --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} +{-# language PackageImports, TemplateHaskell, BlockArguments #-} module Language.PureScript.Ide.Rebuild ( rebuildFileSync @@ -7,20 +6,23 @@ module Language.PureScript.Ide.Rebuild , rebuildFile ) where -import Protolude +import Protolude hiding (moduleName) import "monad-logger" Control.Monad.Logger import qualified Data.List as List import qualified Data.Map.Lazy as M import Data.Maybe (fromJust) import qualified Data.Set as S +import qualified Data.Time as Time import qualified Language.PureScript as P +import Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache) import qualified Language.PureScript.CST as CST import Language.PureScript.Ide.Error import Language.PureScript.Ide.Logging import Language.PureScript.Ide.State import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util +import System.Directory (getCurrentDirectory) -- | Given a filepath performs the following steps: -- @@ -55,35 +57,72 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do Left parseError -> throwError $ RebuildError $ CST.toMultipleErrors fp' parseError Right m -> pure m - + let moduleName = P.getModuleName m -- Externs files must be sorted ahead of time, so that they get applied -- in the right order (bottom up) to the 'Environment'. externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles) - outputDirectory <- confOutputPath . ideConfiguration <$> ask - -- For rebuilding, we want to 'RebuildAlways', but for inferring foreign -- modules using their file paths, we need to specify the path in the 'Map'. - let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways) - foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right file)) - - let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False + let filePathMap = M.singleton moduleName (Left P.RebuildAlways) + foreigns <- P.inferForeignModules (M.singleton moduleName (Right file)) + let makeEnv = P.buildMakeActions outputDirectory filePathMap foreigns False -- Rebuild the single module using the cached externs (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $ - liftIO - . P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) - . P.rebuildModule (buildMakeActions - >>= shushProgress $ makeEnv) externs $ m + liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) do + newExterns <- P.rebuildModule (shushProgress makeEnv) externs m + updateCacheDb codegenTargets outputDirectory file actualFile moduleName + pure newExterns case result of - Left errors -> throwError (RebuildError errors) + Left errors -> + throwError (RebuildError errors) Right newExterns -> do - whenM isEditorMode $ do + whenM isEditorMode do insertModule (fromMaybe file actualFile, m) insertExterns newExterns void populateVolatileState runOpenBuild (rebuildModuleOpen makeEnv externs m) pure (RebuildSuccess warnings) +-- | When adjusting the cache db file after a rebuild we always pick a +-- non-sensical timestamp ("1858-11-17T00:00:00Z"), and rely on the +-- content hash to tell whether the module needs rebuilding. This is +-- because IDE rebuilds may be triggered on temporary files to not +-- force editors to save the actual source file to get at diagnostics +dayZero :: Time.UTCTime +dayZero = Time.UTCTime (Time.ModifiedJulianDay 0) 0 + +updateCacheDb + :: MonadIO m + => MonadError P.MultipleErrors m + => Set P.CodegenTarget + -> FilePath + -- ^ The output directory + -> FilePath + -- ^ The file to read the content hash from + -> Maybe FilePath + -- ^ The file name to update in the cache + -> P.ModuleName + -- ^ The module name to update in the cache + -> m () +updateCacheDb codegenTargets outputDirectory file actualFile moduleName = do + cwd <- liftIO getCurrentDirectory + contentHash <- P.hashFile file + let moduleCacheInfo = (normaliseForCache cwd (fromMaybe file actualFile), (dayZero, contentHash)) + + foreignCacheInfo <- + if S.member P.JS codegenTargets then do + foreigns' <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile))) + for (M.lookup moduleName foreigns') \foreignPath -> do + foreignHash <- P.hashFile foreignPath + pure (normaliseForCache cwd foreignPath, (dayZero, foreignHash)) + else + pure Nothing + + let cacheInfo = M.fromList (moduleCacheInfo : maybeToList foreignCacheInfo) + cacheDb <- P.readCacheDb' outputDirectory + P.writeCacheDb' outputDirectory (M.insert moduleName (CacheInfo cacheInfo) cacheDb) + isEditorMode :: Ide m => m Bool isEditorMode = asks (confEditorMode . ideConfiguration) @@ -109,22 +148,17 @@ rebuildFileSync fp fp' ts = rebuildFile fp fp' ts syncRun let ll = confLogLevel (ideConfiguration env) void (liftIO (runLogger ll (runReaderT action env))) - -- | Rebuilds a module but opens up its export list first and stores the result -- inside the rebuild cache rebuildModuleOpen :: (Ide m, MonadLogger m) - => MakeActionsEnv + => P.MakeActions P.Make -> [P.ExternsFile] -> P.Module -> m () -rebuildModuleOpen makeEnv externs m = void $ runExceptT $ do - (openResult, _) <- liftIO - . P.runMake P.defaultOptions - . P.rebuildModule (buildMakeActions - >>= shushProgress - >>= shushCodegen - $ makeEnv) externs $ openModuleExports m +rebuildModuleOpen makeEnv externs m = void $ runExceptT do + (openResult, _) <- liftIO $ P.runMake P.defaultOptions $ + P.rebuildModule (shushProgress (shushCodegen makeEnv)) externs (openModuleExports m) case openResult of Left _ -> throwError (GeneralError "Failed when rebuilding with open exports") @@ -133,32 +167,14 @@ rebuildModuleOpen makeEnv externs m = void $ runExceptT $ do ("Setting Rebuild cache: " <> P.runModuleName (P.efModuleName result)) cacheRebuild result --- | Parameters we can access while building our @MakeActions@ -data MakeActionsEnv = - MakeActionsEnv - { maeOutputDirectory :: FilePath - , maeFilePathMap :: ModuleMap (Either P.RebuildPolicy FilePath) - , maeForeignPathMap :: ModuleMap FilePath - , maePrefixComment :: Bool - } - --- | Builds the default @MakeActions@ from a @MakeActionsEnv@ -buildMakeActions :: MakeActionsEnv -> P.MakeActions P.Make -buildMakeActions MakeActionsEnv{..} = - P.buildMakeActions - maeOutputDirectory - maeFilePathMap - maeForeignPathMap - maePrefixComment - -- | Shuts the compiler up about progress messages -shushProgress :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make -shushProgress ma _ = +shushProgress :: Monad m => P.MakeActions m -> P.MakeActions m +shushProgress ma = ma { P.progress = \_ -> pure () } -- | Stops any kind of codegen -shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make -shushCodegen ma MakeActionsEnv{..} = +shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m +shushCodegen ma = ma { P.codegen = \_ _ _ -> pure () , P.ffiCodegen = \_ -> pure () } diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs index b3fe5ee0d7..d2a1774f45 100644 --- a/src/Language/PureScript/Make/Actions.hs +++ b/src/Language/PureScript/Make/Actions.hs @@ -4,6 +4,8 @@ module Language.PureScript.Make.Actions , ProgressMessage(..) , buildMakeActions , checkForeignDecls + , readCacheDb' + , writeCacheDb' ) where import Prelude @@ -105,6 +107,28 @@ data MakeActions m = MakeActions -- ^ If generating docs, output the documentation for the Prim modules } +-- | Given the output directory, determines the location for the +-- CacheDb file +cacheDbFile :: FilePath -> FilePath +cacheDbFile = ( "cache-db.json") + +readCacheDb' + :: (MonadIO m, MonadError MultipleErrors m) + => FilePath + -- ^ The path to the output directory + -> m CacheDb +readCacheDb' outputDir = + fromMaybe mempty <$> readJSONFile (cacheDbFile outputDir) + +writeCacheDb' + :: (MonadIO m, MonadError MultipleErrors m) + => FilePath + -- ^ The path to the output directory + -> CacheDb + -- ^ The CacheDb to be written + -> m () +writeCacheDb' = writeJSONFile . cacheDbFile + -- | A set of make actions that read and write modules from the given directory. buildMakeActions :: FilePath @@ -129,7 +153,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = Left policy -> return (Left policy) Right filePath -> do - let inputPaths = filePath : maybeToList (M.lookup mn foreigns) + cwd <- makeIO "Getting the current directory" getCurrentDirectory + let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns)) getInfo fp = do ts <- getTimestamp fp return (ts, hashFile fp) @@ -246,12 +271,10 @@ buildMakeActions outputDir filePathMap foreigns usePrefix = progress = liftIO . putStrLn . renderProgressMessage readCacheDb :: Make CacheDb - readCacheDb = fmap (fromMaybe mempty) $ readJSONFile cacheDbFile + readCacheDb = readCacheDb' outputDir writeCacheDb :: CacheDb -> Make () - writeCacheDb = writeJSONFile cacheDbFile - - cacheDbFile = outputDir "cache-db.json" + writeCacheDb = writeCacheDb' outputDir -- | Check that the declarations in a given PureScript module match with those -- in its corresponding foreign module. diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs index 8d409f6699..a8b0bfbab8 100644 --- a/src/Language/PureScript/Make/BuildPlan.hs +++ b/src/Language/PureScript/Make/BuildPlan.hs @@ -14,6 +14,7 @@ import Prelude import Control.Concurrent.Async.Lifted as A import Control.Concurrent.Lifted as C +import Control.Monad.Base (liftBase) import Control.Monad hiding (sequence) import Control.Monad.Trans.Control (MonadBaseControl(..)) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) @@ -30,6 +31,7 @@ import Language.PureScript.Make.Actions as Actions import Language.PureScript.Make.Cache import Language.PureScript.Names (ModuleName) import Language.PureScript.Sugar.Names.Env +import System.Directory (getCurrentDirectory) -- | The BuildPlan tracks information about our build progress, and holds all -- prebuilt modules for incremental builds. @@ -176,7 +178,8 @@ construct MakeActions{..} cacheDb (sorted, graph) = do , statusNewCacheInfo = Nothing }) Right cacheInfo -> do - (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cacheInfo + cwd <- liftBase getCurrentDirectory + (newCacheInfo, isUpToDate) <- checkChanged cacheDb moduleName cwd cacheInfo prebuilt <- if isUpToDate then findExistingExtern moduleName diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs index 47f7f0e94b..bfc3e4c7f8 100644 --- a/src/Language/PureScript/Make/Cache.hs +++ b/src/Language/PureScript/Make/Cache.hs @@ -4,9 +4,10 @@ module Language.PureScript.Make.Cache ( ContentHash , hash , CacheDb - , CacheInfo + , CacheInfo(..) , checkChanged , removeModules + , normaliseForCache ) where import Prelude @@ -29,6 +30,7 @@ import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.These (These(..)) import Data.Time.Clock (UTCTime) import Data.Traversable (for) +import qualified System.FilePath as FilePath import Language.PureScript.Names (ModuleName) @@ -93,13 +95,15 @@ checkChanged :: Monad m => CacheDb -> ModuleName + -> FilePath -> Map FilePath (UTCTime, m ContentHash) -> m (CacheInfo, Bool) -checkChanged cacheDb mn currentInfo = do +checkChanged cacheDb mn basePath currentInfo = do + let dbInfo = unCacheInfo $ fromMaybe mempty (Map.lookup mn cacheDb) (newInfo, isUpToDate) <- fmap mconcat $ - for (Map.toList (align dbInfo currentInfo)) $ \(fp, aligned) -> do + for (Map.toList (align dbInfo currentInfo)) $ \(normaliseForCache basePath -> fp, aligned) -> do case aligned of This _ -> do -- One of the input files listed in the cache no longer exists; @@ -128,3 +132,20 @@ checkChanged cacheDb mn currentInfo = do -- they failed to build. removeModules :: Set ModuleName -> CacheDb -> CacheDb removeModules moduleNames = flip Map.withoutKeys moduleNames + +-- | 1. Any path that is beneath our current working directory will be +-- stored as a normalised relative path +-- 2. Any path that isn't will be stored as an absolute path +normaliseForCache :: FilePath -> FilePath -> FilePath +normaliseForCache basePath fp = + if FilePath.isRelative fp then + FilePath.normalise fp + else + let relativePath = FilePath.makeRelative basePath fp in + if FilePath.isRelative relativePath then + FilePath.normalise relativePath + else + -- If the path is still absolute after trying to make it + -- relative to the base that means it is not underneath + -- the base path + FilePath.normalise fp diff --git a/src/Language/PureScript/Make/Monad.hs b/src/Language/PureScript/Make/Monad.hs index ed2a2dc4d4..289ecbbe7b 100644 --- a/src/Language/PureScript/Make/Monad.hs +++ b/src/Language/PureScript/Make/Monad.hs @@ -64,26 +64,26 @@ runMake opts = runLogger' . runExceptT . flip runReaderT opts . unMake -- | Run an 'IO' action in the 'Make' monad. The 'String' argument should -- describe what we were trying to do; it is used for rendering errors in the -- case that an IOException is thrown. -makeIO :: Text -> IO a -> Make a +makeIO :: (MonadIO m, MonadError MultipleErrors m) => Text -> IO a -> m a makeIO description io = do - e <- liftIO $ tryIOError io - either (throwError . singleError . ErrorMessage [] . FileIOError description) return e + res <- liftIO (tryIOError io) + either (throwError . singleError . ErrorMessage [] . FileIOError description) pure res -- | Get a file's modification time in the 'Make' monad, capturing any errors -- using the 'MonadError' instance. -getTimestamp :: FilePath -> Make UTCTime +getTimestamp :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m UTCTime getTimestamp path = makeIO ("get a timestamp for file: " <> Text.pack path) $ getModificationTime path -- | Get a file's modification time in the 'Make' monad, returning Nothing if -- the file does not exist. -getTimestampMaybe :: FilePath -> Make (Maybe UTCTime) +getTimestampMaybe :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m (Maybe UTCTime) getTimestampMaybe path = makeIO ("get a timestamp for file: " <> Text.pack path) $ catchDoesNotExist $ getModificationTime path -- | Read a text file strictly in the 'Make' monad, capturing any errors using -- the 'MonadError' instance. -readTextFile :: FilePath -> Make Text +readTextFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m Text readTextFile path = makeIO ("read file: " <> Text.pack path) $ readUTF8FileT path @@ -91,7 +91,7 @@ readTextFile path = -- | Read a JSON file in the 'Make' monad, returning 'Nothing' if the file does -- not exist or could not be parsed. Errors are captured using the 'MonadError' -- instance. -readJSONFile :: Aeson.FromJSON a => FilePath -> Make (Maybe a) +readJSONFile :: (MonadIO m, MonadError MultipleErrors m) => Aeson.FromJSON a => FilePath -> m (Maybe a) readJSONFile path = makeIO ("read JSON file: " <> Text.pack path) $ do r <- catchDoesNotExist $ Aeson.decodeFileStrict' path @@ -100,7 +100,7 @@ readJSONFile path = -- | Read an externs file, returning 'Nothing' if the file does not exist, -- could not be parsed, or was generated by a different version of the -- compiler. -readExternsFile :: FilePath -> Make (Maybe ExternsFile) +readExternsFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m (Maybe ExternsFile) readExternsFile path = do mexterns <- readJSONFile path return $ do @@ -108,7 +108,7 @@ readExternsFile path = do guard $ externsIsCurrentVersion externs return externs -hashFile :: FilePath -> Make ContentHash +hashFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> m ContentHash hashFile path = do makeIO ("hash file: " <> Text.pack path) (hash <$> B.readFile path) @@ -133,14 +133,14 @@ writeTextFile path text = makeIO ("write file: " <> Text.pack path) $ do -- | Write a JSON file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance. -writeJSONFile :: Aeson.ToJSON a => FilePath -> a -> Make () +writeJSONFile :: (MonadIO m, MonadError MultipleErrors m) => Aeson.ToJSON a => FilePath -> a -> m () writeJSONFile path value = makeIO ("write JSON file: " <> Text.pack path) $ do createParentDirectory path Aeson.encodeFile path value -- | Copy a file in the 'Make' monad, capturing any errors using the -- 'MonadError' instance. -copyFile :: FilePath -> FilePath -> Make () +copyFile :: (MonadIO m, MonadError MultipleErrors m) => FilePath -> FilePath -> m () copyFile src dest = makeIO ("copy file: " <> Text.pack src <> " -> " <> Text.pack dest) $ do createParentDirectory dest