{-# language PackageImports, TemplateHaskell, BlockArguments #-}
module Language.PureScript.Ide.Rebuild
( rebuildFileSync
, rebuildFileAsync
, rebuildFile
) where
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)
rebuildFile
:: (Ide m, MonadLogger m, MonadError IdeError m)
=> FilePath
-> Maybe FilePath
-> Set P.CodegenTarget
-> (ReaderT IdeEnvironment (LoggingT IO) () -> m ())
-> m Success
rebuildFile file actualFile codegenTargets runOpenBuild = do
(fp, input) <- ideReadFile file
let fp' = fromMaybe fp actualFile
m <- case CST.parseFromFile fp' input of
Left parseError ->
throwError $ RebuildError $ CST.toMultipleErrors fp' parseError
Right m -> pure m
let moduleName = P.getModuleName m
externs <- logPerf (labelTimespec "Sorting externs") (sortExterns m =<< getExternFiles)
outputDirectory <- confOutputPath . ideConfiguration <$> ask
let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
foreigns <- P.inferForeignModules (M.singleton moduleName (Right file))
let makeEnv = P.buildMakeActions outputDirectory filePathMap foreigns False
(result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $
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
insertModule (fromMaybe file actualFile, m)
insertExterns newExterns
void populateVolatileState
_ <- updateCacheTimestamp
runOpenBuild (rebuildModuleOpen makeEnv externs m)
pure (RebuildSuccess warnings)
dayZero :: Time.UTCTime
dayZero = Time.UTCTime (Time.ModifiedJulianDay 0) 0
updateCacheDb
:: MonadIO m
=> MonadError P.MultipleErrors m
=> Set P.CodegenTarget
-> FilePath
-> FilePath
-> Maybe FilePath
-> P.ModuleName
-> 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)))
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
shushProgress :: Monad m => P.MakeActions m -> P.MakeActions m
shushProgress ma =
ma { P.progress = \_ -> pure () }
shushCodegen :: Monad m => P.MakeActions m -> P.MakeActions m
shushCodegen ma =
ma { P.codegen = \_ _ _ -> pure ()
, P.ffiCodegen = \_ -> pure ()
}
sortExterns
:: (Ide m, MonadError IdeError m)
=> P.Module
-> ModuleMap P.ExternsFile
-> m [P.ExternsFile]
sortExterns m ex = do
sorted' <- runExceptT
. P.sortModules 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
inOrderOf :: (Ord a) => [a] -> [a] -> [a]
inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
openModuleExports :: P.Module -> P.Module
openModuleExports (P.Module ss cs mn decls _) = P.Module ss cs mn decls Nothing