Rebuild.hs

{-# language PackageImports, TemplateHaskell, BlockArguments #-}

module Language.PureScript.Ide.Rebuild
  ( rebuildFileSync
  , rebuildFileAsync
  , rebuildFile
  ) where

import Protolude hiding (moduleName)

import "monad-logger" Control.Monad.Logger (LoggingT, MonadLogger, logDebug)
import Data.List qualified as List
import Data.Map.Lazy qualified as M
import Data.Maybe (fromJust)
import Data.Set qualified as S
import Data.Time qualified as Time
import Data.Text qualified as Text
import Language.PureScript qualified as P
import Language.PureScript.Make (ffiCodegen')
import Language.PureScript.Make.Cache (CacheInfo(..), normaliseForCache)
import Language.PureScript.CST qualified as CST

import Language.PureScript.Ide.Error (IdeError(..))
import Language.PureScript.Ide.Logging (labelTimespec, logPerf, runLogger)
import Language.PureScript.Ide.State (cacheRebuild, getExternFiles, insertExterns, insertModule, populateVolatileState, updateCacheTimestamp)
import Language.PureScript.Ide.Types (Ide, IdeConfiguration(..), IdeEnvironment(..), ModuleMap, Success(..))
import Language.PureScript.Ide.Util (ideReadFile)
import System.Directory (getCurrentDirectory)

-- | Given a filepath performs the following steps:
--
-- * Reads and parses a PureScript module from the filepath.
--
-- * Builds a dependency graph for the parsed module from the already loaded
-- ExternsFiles.
--
-- * Attempts to find an FFI definition file for the module by looking
-- for a file with the same filepath except for a .js extension.
--
-- * Passes all the created artifacts to @rebuildModule@.
--
-- * If the rebuilding succeeds, returns a @RebuildSuccess@ with the generated
-- warnings, and if rebuilding fails, returns a @RebuildError@ with the
-- generated errors.
rebuildFile
  :: (Ide m, MonadLogger m, MonadError IdeError m)
  => FilePath
  -- ^ The file to rebuild
  -> Maybe FilePath
  -- ^ The file to use as the location for parsing and errors
  -> Set P.CodegenTarget
  -- ^ The targets to codegen
  -> (ReaderT IdeEnvironment (LoggingT IO) () -> m ())
  -- ^ A runner for the second build with open exports
  -> m Success
rebuildFile file actualFile codegenTargets runOpenBuild = do
  (fp, input) <-
    case List.stripPrefix "data:" file of
      Just source -> pure ("", Text.pack source)
      _ -> ideReadFile file
  let fp' = fromMaybe fp actualFile
  (pwarnings, m) <- case sequence $ CST.parseFromFile fp' input of
    Left parseError ->
      throwError $ RebuildError [(fp', input)] $ 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)
  let pureRebuild = fp == ""
  let modulePath = if pureRebuild then fp' else file
  foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
  let makeEnv = P.buildMakeActions outputDirectory filePathMap foreigns False
        & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
        & shushProgress
  -- Rebuild the single module using the cached externs
  (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $
    liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) do
      newExterns <- P.rebuildModule makeEnv externs m
      unless pureRebuild
        $ updateCacheDb codegenTargets outputDirectory file actualFile moduleName
      pure newExterns
  case result of
    Left errors ->
      throwError (RebuildError [(fp', input)] errors)
    Right newExterns -> do
      insertModule (fromMaybe file actualFile, m)
      insertExterns newExterns
      void populateVolatileState
      _ <- updateCacheTimestamp
      runOpenBuild (rebuildModuleOpen makeEnv externs m)
      pure (RebuildSuccess (CST.toMultipleWarnings fp pwarnings <> 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)

rebuildFileAsync
  :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)
  => FilePath -> Maybe FilePath -> Set P.CodegenTarget -> m Success
rebuildFileAsync fp fp' ts = rebuildFile fp fp' ts asyncRun
  where
    asyncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m ()
    asyncRun action = do
        env <- ask
        let ll = confLogLevel (ideConfiguration env)
        void (liftIO (async (runLogger ll (runReaderT action env))))

rebuildFileSync
  :: forall m. (Ide m, MonadLogger m, MonadError IdeError m)
  => FilePath -> Maybe FilePath -> Set P.CodegenTarget -> m Success
rebuildFileSync fp fp' ts = rebuildFile fp fp' ts syncRun
  where
    syncRun :: ReaderT IdeEnvironment (LoggingT IO) () -> m ()
    syncRun action = do
        env <- ask
        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)
  => P.MakeActions P.Make
  -> [P.ExternsFile]
  -> P.Module
  -> 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")
    Right result -> do
      $(logDebug)
        ("Setting Rebuild cache: " <> P.runModuleName (P.efModuleName result))
      cacheRebuild result

-- | Shuts the compiler up about progress messages
shushProgress :: Monad m => P.MakeActions m -> P.MakeActions m
shushProgress ma =
  ma { P.progress = \_ -> pure () }

-- | Stops any kind of codegen
shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
shushCodegen ma =
  ma { P.codegen = \_ _ _ -> pure ()
     , P.ffiCodegen = \_ -> pure ()
     }

-- | Enables foreign module check without actual codegen.
enableForeignCheck
  :: M.Map P.ModuleName FilePath
  -> S.Set P.CodegenTarget
  -> P.MakeActions P.Make
  -> P.MakeActions P.Make
enableForeignCheck foreigns codegenTargets ma =
  ma { P.ffiCodegen = ffiCodegen' foreigns codegenTargets Nothing
     }

-- | Returns a topologically sorted list of dependent ExternsFiles for the given
-- module. Throws an error if there is a cyclic dependency within the
-- ExternsFiles
sortExterns
  :: (Ide m, MonadError IdeError m)
  => P.Module
  -> ModuleMap P.ExternsFile
  -> m [P.ExternsFile]
sortExterns m ex = do
  sorted' <- runExceptT
           . P.sortModules P.Transitive P.moduleSignature
           . (:) m
           . map mkShallowModule
           . M.elems
           . M.delete (P.getModuleName m) $ ex
  case sorted' of
    Left err ->
      throwError (RebuildError [] err)
    Right (sorted, graph) -> do
      let deps = fromJust (List.lookup (P.getModuleName m) graph)
      pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
  where
    mkShallowModule P.ExternsFile{..} =
      P.Module (P.internalModuleSourceSpan "<rebuild>") [] efModuleName (map mkImport efImports) Nothing
    mkImport (P.ExternsImport mn it iq) =
      P.ImportDeclaration (P.internalModuleSourceSpan "<rebuild>", []) mn it iq
    getExtern mn = M.lookup mn ex
    -- Sort a list so its elements appear in the same order as in another list.
    inOrderOf :: (Ord a) => [a] -> [a] -> [a]
    inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys

-- | Removes a modules export list.
openModuleExports :: P.Module -> P.Module
openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing