purescript · kritzcreek · Feb 24, 2020 · Feb 4, 2020 · Feb 4, 2020 · Feb 9, 2020
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
@@ -1,26 +1,28 @@
-{-# LANGUAGE PackageImports        #-}
-{-# LANGUAGE TemplateHaskell       #-}
+{-# language PackageImports, TemplateHaskell, BlockArguments #-}
 
 module Language.PureScript.Ide.Rebuild
   ( rebuildFileSync
   , rebuildFileAsync
   , 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
@@ -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
@@ -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
@@ -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