From 1fa56e872f5bafe7f175e6bbcaa8b568fba470ec Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Tue, 4 Feb 2020 09:33:36 +0100
Subject: [PATCH 01/11] generalizes and extracts CacheDb accessors from Make

This is so they can be used from within the IDE as well, which doesn't
run in Make
---
 src/Language/PureScript/Make/Actions.hs | 54 ++++++++++++++++++++-----
 src/Language/PureScript/Make/Monad.hs   | 22 +++++-----
 2 files changed, 55 insertions(+), 21 deletions(-)

diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index b3fe5ee0d7..fa639a60f6 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -4,6 +4,9 @@ module Language.PureScript.Make.Actions
   , ProgressMessage(..)
   , buildMakeActions
   , checkForeignDecls
+  , getInputTimestampsAndHashes'
+  , readCacheDb'
+  , writeCacheDb'
   ) where
 
 import           Prelude
@@ -105,6 +108,44 @@ data MakeActions m = MakeActions
   -- ^ If generating docs, output the documentation for the Prim modules
   }
 
+getInputTimestampsAndHashes'
+  :: (MonadIO m, MonadError MultipleErrors m)
+  => FilePath
+  -- ^ The filepath to the PureScript Module
+  -> Maybe FilePath
+  -- ^ The filepath to the module's potential FFI implementation
+  -> m (M.Map FilePath (UTCTime, m ContentHash))
+getInputTimestampsAndHashes' filePath foreignPath = do
+  let
+    inputPaths = filePath : maybeToList foreignPath
+    getInfo fp = do
+      ts <- getTimestamp fp
+      return (ts, hashFile fp)
+  pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
+  pure (M.fromList pathsWithInfo)
+
+-- | 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,12 +170,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
       Left policy ->
         return (Left policy)
       Right filePath -> do
-        let inputPaths = filePath : maybeToList (M.lookup mn foreigns)
-            getInfo fp = do
-              ts <- getTimestamp fp
-              return (ts, hashFile fp)
-        pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
-        return $ Right $ M.fromList pathsWithInfo
+        Right <$> getInputTimestampsAndHashes' filePath (M.lookup mn foreigns)
 
   outputFilename :: ModuleName -> String -> FilePath
   outputFilename mn fn =
@@ -246,12 +282,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/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

From dd62ae64aa90656dc14e930da7460e6243ababef Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Tue, 4 Feb 2020 20:17:44 +0100
Subject: [PATCH 02/11] overwrites ContentHashes and Timestamps for rebuilt
 modules

---
 src/Language/PureScript/Ide/Rebuild.hs | 48 ++++++++++++++++++++------
 src/Language/PureScript/Make/Cache.hs  |  2 +-
 2 files changed, 38 insertions(+), 12 deletions(-)

diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 9e38117de3..413c13b814 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,24 @@ 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 (CacheDb, CacheInfo(..))
 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)
+import           System.FilePath (makeRelative)
 
 -- | Given a filepath performs the following steps:
 --
@@ -55,6 +58,7 @@ 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'.
@@ -64,26 +68,48 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
 
   -- 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 filePathMap = M.singleton moduleName (Left P.RebuildAlways)
+  foreigns <- P.inferForeignModules (M.singleton moduleName (Right file))
 
   let makeEnv = MakeActionsEnv 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
+      let ma@P.MakeActions{..} = (buildMakeActions >>= shushProgress) makeEnv
+      P.rebuildModule ma externs m
   case result of
-    Left errors -> throwError (RebuildError errors)
+    Left errors ->
+      throwError (RebuildError errors)
     Right newExterns -> do
-      whenM isEditorMode $ do
+      runExceptT do
+        cwd <- liftIO getCurrentDirectory
+        contentHash <- P.hashFile file
+        -- TODO(Christoph): Maybe we can avoid calling inferForeignmodule twice?
+        foreigns <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile)))
+        -- TODO(Christoph): Make ALL filepaths in the cachedb.json file normalized relative paths
+        let cacheInfo' = M.singleton (makeRelative cwd (fromMaybe file actualFile)) (dayZero, contentHash)
+        -- TODO(Christoph): This is a bit clunky? I think we could use Map.alter?
+        cacheInfo <- case M.lookup moduleName foreigns of
+          Nothing -> pure cacheInfo'
+          Just foreignPath -> do
+            foreignHash <- P.hashFile foreignPath
+            pure (M.insert (makeRelative cwd foreignPath) (dayZero, foreignHash) cacheInfo')
+        cacheDb <- P.readCacheDb' outputDirectory
+        P.writeCacheDb' outputDirectory (M.insert moduleName (CacheInfo cacheInfo) cacheDb)
+      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
+dayZero :: Time.UTCTime
+dayZero = Time.UTCTime (Time.ModifiedJulianDay 0) 0
+
 isEditorMode :: Ide m => m Bool
 isEditorMode = asks (confEditorMode . ideConfiguration)
 
diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs
index 47f7f0e94b..734e98f764 100644
--- a/src/Language/PureScript/Make/Cache.hs
+++ b/src/Language/PureScript/Make/Cache.hs
@@ -4,7 +4,7 @@ module Language.PureScript.Make.Cache
   ( ContentHash
   , hash
   , CacheDb
-  , CacheInfo
+  , CacheInfo(..)
   , checkChanged
   , removeModules
   ) where

From 178289dd90c472d1bed8ab0537671e696146b1e8 Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Sun, 9 Feb 2020 13:02:35 +0100
Subject: [PATCH 03/11] removes a whole lot of "Christoph didn't know what he
 was doing"

---
 src/Language/PureScript/Ide/Rebuild.hs | 45 +++++++-------------------
 1 file changed, 11 insertions(+), 34 deletions(-)

diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 413c13b814..4976cea797 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -71,13 +71,12 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
   let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
   foreigns <- P.inferForeignModules (M.singleton moduleName (Right file))
 
-  let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False
+  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 }) do
-      let ma@P.MakeActions{..} = (buildMakeActions >>= shushProgress) makeEnv
-      P.rebuildModule ma externs m
+    liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets })
+      (P.rebuildModule (shushProgress makeEnv) externs m)
   case result of
     Left errors ->
       throwError (RebuildError errors)
@@ -140,17 +139,13 @@ rebuildFileSync fp fp' ts = rebuildFile fp fp' ts syncRun
 -- 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")
@@ -159,32 +154,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 ()
      }

From b117019fb59a1441e82309619db24dae1658a2db Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Sun, 9 Feb 2020 13:03:05 +0100
Subject: [PATCH 04/11] reorganizes the cache info building

---
 src/Language/PureScript/Ide/Rebuild.hs | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 4976cea797..62234e796b 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -15,7 +15,7 @@ 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 (CacheDb, CacheInfo(..))
+import           Language.PureScript.Make.Cache (CacheInfo(..))
 import qualified Language.PureScript.CST         as CST
 import           Language.PureScript.Ide.Error
 import           Language.PureScript.Ide.Logging
@@ -81,19 +81,19 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
     Left errors ->
       throwError (RebuildError errors)
     Right newExterns -> do
+      -- TODO(Christoph): Make ALL filepaths in the cachedb.json file normalized relative paths
       runExceptT do
         cwd <- liftIO getCurrentDirectory
         contentHash <- P.hashFile file
+        let moduleCacheInfo = (makeRelative cwd (fromMaybe file actualFile), (dayZero, contentHash))
+
         -- TODO(Christoph): Maybe we can avoid calling inferForeignmodule twice?
         foreigns <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile)))
-        -- TODO(Christoph): Make ALL filepaths in the cachedb.json file normalized relative paths
-        let cacheInfo' = M.singleton (makeRelative cwd (fromMaybe file actualFile)) (dayZero, contentHash)
-        -- TODO(Christoph): This is a bit clunky? I think we could use Map.alter?
-        cacheInfo <- case M.lookup moduleName foreigns of
-          Nothing -> pure cacheInfo'
-          Just foreignPath -> do
-            foreignHash <- P.hashFile foreignPath
-            pure (M.insert (makeRelative cwd foreignPath) (dayZero, foreignHash) cacheInfo')
+        foreignCacheInfo <- for (M.lookup moduleName foreigns) \foreignPath -> do
+          foreignHash <- P.hashFile foreignPath
+          pure (makeRelative cwd foreignPath, (dayZero, foreignHash))
+
+        let cacheInfo = M.fromList (moduleCacheInfo : maybeToList foreignCacheInfo)
         cacheDb <- P.readCacheDb' outputDirectory
         P.writeCacheDb' outputDirectory (M.insert moduleName (CacheInfo cacheInfo) cacheDb)
       whenM isEditorMode do

From b01a7151ec59e6fd59e2ac739a9c2565b7eff21e Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Sun, 9 Feb 2020 16:18:52 +0100
Subject: [PATCH 05/11] normalises filepaths before inserting them into the
 Cache

---
 src/Language/PureScript/Make/Actions.hs   |  3 ++-
 src/Language/PureScript/Make/BuildPlan.hs |  5 ++++-
 src/Language/PureScript/Make/Cache.hs     | 26 +++++++++++++++++++++--
 3 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index fa639a60f6..0fd1da1f6a 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -116,8 +116,9 @@ getInputTimestampsAndHashes'
   -- ^ The filepath to the module's potential FFI implementation
   -> m (M.Map FilePath (UTCTime, m ContentHash))
 getInputTimestampsAndHashes' filePath foreignPath = do
+  cwd <- liftIO getCurrentDirectory
   let
-    inputPaths = filePath : maybeToList foreignPath
+    inputPaths = map (normaliseForCache cwd) (filePath : maybeToList foreignPath)
     getInfo fp = do
       ts <- getTimestamp fp
       return (ts, hashFile fp)
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 734e98f764..ea470a099a 100644
--- a/src/Language/PureScript/Make/Cache.hs
+++ b/src/Language/PureScript/Make/Cache.hs
@@ -7,6 +7,7 @@ module Language.PureScript.Make.Cache
   , 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;
@@ -123,8 +127,26 @@ checkChanged cacheDb mn currentInfo = do
             pure (Map.singleton fp (newTimestamp, newHash), All (dbHash == newHash))
 
   pure (CacheInfo newInfo, getAll isUpToDate)
+  where
 
 -- | Remove any modules from the given set from the cache database; used when
 -- 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

From 19e2383c27942ff87e181e2aa5d4ffad89a9e05f Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Sun, 9 Feb 2020 16:27:01 +0100
Subject: [PATCH 06/11] normalise file paths when rebuilding from the IDE

---
 src/Language/PureScript/Ide/Rebuild.hs | 8 +++-----
 1 file changed, 3 insertions(+), 5 deletions(-)

diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 62234e796b..e3c4b5dead 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -15,7 +15,7 @@ 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(..))
+import           Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache)
 import qualified Language.PureScript.CST         as CST
 import           Language.PureScript.Ide.Error
 import           Language.PureScript.Ide.Logging
@@ -23,7 +23,6 @@ import           Language.PureScript.Ide.State
 import           Language.PureScript.Ide.Types
 import           Language.PureScript.Ide.Util
 import           System.Directory (getCurrentDirectory)
-import           System.FilePath (makeRelative)
 
 -- | Given a filepath performs the following steps:
 --
@@ -85,13 +84,13 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
       runExceptT do
         cwd <- liftIO getCurrentDirectory
         contentHash <- P.hashFile file
-        let moduleCacheInfo = (makeRelative cwd (fromMaybe file actualFile), (dayZero, contentHash))
+        let moduleCacheInfo = (normaliseForCache cwd (fromMaybe file actualFile), (dayZero, contentHash))
 
         -- TODO(Christoph): Maybe we can avoid calling inferForeignmodule twice?
         foreigns <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile)))
         foreignCacheInfo <- for (M.lookup moduleName foreigns) \foreignPath -> do
           foreignHash <- P.hashFile foreignPath
-          pure (makeRelative cwd foreignPath, (dayZero, foreignHash))
+          pure (normaliseForCache cwd foreignPath, (dayZero, foreignHash))
 
         let cacheInfo = M.fromList (moduleCacheInfo : maybeToList foreignCacheInfo)
         cacheDb <- P.readCacheDb' outputDirectory
@@ -134,7 +133,6 @@ 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

From b7c2d6cb6d91bb544e5522bc0ebe50f4916fe5d3 Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Thu, 13 Feb 2020 16:49:39 +0100
Subject: [PATCH 07/11] extracts the logic that updates the Cache

---
 src/Language/PureScript/Ide/Rebuild.hs | 54 ++++++++++++++++----------
 1 file changed, 34 insertions(+), 20 deletions(-)

diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index e3c4b5dead..3884e95b22 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -58,20 +58,15 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
       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 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 })
@@ -80,21 +75,9 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
     Left errors ->
       throwError (RebuildError errors)
     Right newExterns -> do
-      -- TODO(Christoph): Make ALL filepaths in the cachedb.json file normalized relative paths
-      runExceptT do
-        cwd <- liftIO getCurrentDirectory
-        contentHash <- P.hashFile file
-        let moduleCacheInfo = (normaliseForCache cwd (fromMaybe file actualFile), (dayZero, contentHash))
-
-        -- TODO(Christoph): Maybe we can avoid calling inferForeignmodule twice?
-        foreigns <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile)))
-        foreignCacheInfo <- for (M.lookup moduleName foreigns) \foreignPath -> do
-          foreignHash <- P.hashFile foreignPath
-          pure (normaliseForCache cwd foreignPath, (dayZero, foreignHash))
-
-        let cacheInfo = M.fromList (moduleCacheInfo : maybeToList foreignCacheInfo)
-        cacheDb <- P.readCacheDb' outputDirectory
-        P.writeCacheDb' outputDirectory (M.insert moduleName (CacheInfo cacheInfo) cacheDb)
+      runExceptT (updateCacheDb codegenTargets outputDirectory file actualFile moduleName) >>= \case
+        Right _ -> pure ()
+        Left errs -> throwError (RebuildError errs)
       whenM isEditorMode do
         insertModule (fromMaybe file actualFile, m)
         insertExterns newExterns
@@ -108,6 +91,37 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
 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)
 

From 710ac22798daa9a84cc5f2f2150e0116329030e1 Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Thu, 13 Feb 2020 16:55:35 +0100
Subject: [PATCH 08/11] inlines function that I didn't up using in the IDE code

---
 src/Language/PureScript/Make/Actions.hs | 26 +++++++------------------
 1 file changed, 7 insertions(+), 19 deletions(-)

diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 0fd1da1f6a..869352b321 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -4,7 +4,6 @@ module Language.PureScript.Make.Actions
   , ProgressMessage(..)
   , buildMakeActions
   , checkForeignDecls
-  , getInputTimestampsAndHashes'
   , readCacheDb'
   , writeCacheDb'
   ) where
@@ -108,23 +107,6 @@ data MakeActions m = MakeActions
   -- ^ If generating docs, output the documentation for the Prim modules
   }
 
-getInputTimestampsAndHashes'
-  :: (MonadIO m, MonadError MultipleErrors m)
-  => FilePath
-  -- ^ The filepath to the PureScript Module
-  -> Maybe FilePath
-  -- ^ The filepath to the module's potential FFI implementation
-  -> m (M.Map FilePath (UTCTime, m ContentHash))
-getInputTimestampsAndHashes' filePath foreignPath = do
-  cwd <- liftIO getCurrentDirectory
-  let
-    inputPaths = map (normaliseForCache cwd) (filePath : maybeToList foreignPath)
-    getInfo fp = do
-      ts <- getTimestamp fp
-      return (ts, hashFile fp)
-  pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
-  pure (M.fromList pathsWithInfo)
-
 -- | Given the output directory, determines the location for the
 -- CacheDb file
 cacheDbFile :: FilePath -> FilePath
@@ -171,7 +153,13 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
       Left policy ->
         return (Left policy)
       Right filePath -> do
-        Right <$> getInputTimestampsAndHashes' filePath (M.lookup mn foreigns)
+        cwd <- makeIO "Getting the current directory" getCurrentDirectory
+        let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList foreignPath)
+            getInfo fp = do
+              ts <- getTimestamp fp
+              return (ts, hashFile fp)
+        pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
+        pure $ Right $ M.fromList pathsWithInfo
 
   outputFilename :: ModuleName -> String -> FilePath
   outputFilename mn fn =

From 811dc7110799c7d1eb486c96a2a81b065302b4b3 Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Thu, 13 Feb 2020 16:57:32 +0100
Subject: [PATCH 09/11] cleaner diff

---
 src/Language/PureScript/Make/Actions.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 869352b321..89ac4e64c2 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -159,7 +159,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
               ts <- getTimestamp fp
               return (ts, hashFile fp)
         pathsWithInfo <- traverse (\fp -> (fp,) <$> getInfo fp) inputPaths
-        pure $ Right $ M.fromList pathsWithInfo
+        return $ Right $ M.fromList pathsWithInfo
 
   outputFilename :: ModuleName -> String -> FilePath
   outputFilename mn fn =

From b3b27211d002946094316083eff34a7874a808ad Mon Sep 17 00:00:00 2001
From: kritzcreek <christoph.hegemann1337@gmail.com>
Date: Thu, 13 Feb 2020 17:14:54 +0100
Subject: [PATCH 10/11] more simplifications

---
 src/Language/PureScript/Ide/Rebuild.hs  | 13 +++++++------
 src/Language/PureScript/Make/Actions.hs |  2 +-
 2 files changed, 8 insertions(+), 7 deletions(-)

diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 3884e95b22..14ab0f3578 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -69,15 +69,14 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
   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 (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)
     Right newExterns -> do
-      runExceptT (updateCacheDb codegenTargets outputDirectory file actualFile moduleName) >>= \case
-        Right _ -> pure ()
-        Left errs -> throwError (RebuildError errs)
       whenM isEditorMode do
         insertModule (fromMaybe file actualFile, m)
         insertExterns newExterns
@@ -87,7 +86,9 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
 
 -- | 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
+-- 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
 
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index 89ac4e64c2..d2a1774f45 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -154,7 +154,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
         return (Left policy)
       Right filePath -> do
         cwd <- makeIO "Getting the current directory" getCurrentDirectory
-        let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList foreignPath)
+        let inputPaths = map (normaliseForCache cwd) (filePath : maybeToList (M.lookup mn foreigns))
             getInfo fp = do
               ts <- getTimestamp fp
               return (ts, hashFile fp)

From 57eb45e7679dd6d7ff9dab751894374fafe73689 Mon Sep 17 00:00:00 2001
From: Christoph Hegemann <6189397+kritzcreek@users.noreply.github.com>
Date: Sun, 23 Feb 2020 11:47:38 +0100
Subject: [PATCH 11/11] Update src/Language/PureScript/Make/Cache.hs

---
 src/Language/PureScript/Make/Cache.hs | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/Language/PureScript/Make/Cache.hs b/src/Language/PureScript/Make/Cache.hs
index ea470a099a..bfc3e4c7f8 100644
--- a/src/Language/PureScript/Make/Cache.hs
+++ b/src/Language/PureScript/Make/Cache.hs
@@ -127,7 +127,6 @@ checkChanged cacheDb mn basePath currentInfo = do
             pure (Map.singleton fp (newTimestamp, newHash), All (dbHash == newHash))
 
   pure (CacheInfo newInfo, getAll isUpToDate)
-  where
 
 -- | Remove any modules from the given set from the cache database; used when
 -- they failed to build.