module Language.PureScript.Ide.Rebuild
( rebuildFile
) where
import Protolude
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 Language.PureScript as P
import Language.PureScript.Errors.JSON
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import System.IO.UTF8 (readUTF8File)
rebuildFile
:: (Ide m, MonadLogger m, MonadError PscIdeError m)
=> FilePath
-> m Success
rebuildFile path = do
input <- liftIO (readUTF8File path)
m <- case snd <$> P.parseModuleFromFile identity (path, input) of
Left parseError -> throwError
. RebuildError
. toJSONErrors False P.Error
$ P.MultipleErrors [P.toPositionedError parseError]
Right m -> pure m
externs <- sortExterns m =<< getExternFiles
outputDirectory <- confOutputPath . ideConfiguration <$> ask
let filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)
foreigns <- P.inferForeignModules (M.singleton (P.getModuleName m) (Right path))
let makeEnv = MakeActionsEnv outputDirectory filePathMap foreigns False
(result, warnings) <- liftIO
. P.runMake P.defaultOptions
. P.rebuildModule (buildMakeActions
>>= shushProgress $ makeEnv) externs $ m
case result of
Left errors -> throwError (RebuildError (toJSONErrors False P.Error errors))
Right _ -> do
rebuildModuleOpen makeEnv externs m
pure (RebuildSuccess (toJSONErrors False P.Warning warnings))
rebuildModuleOpen
:: (Ide m, MonadLogger m, MonadError PscIdeError m)
=> MakeActionsEnv
-> [P.ExternsFile]
-> P.Module
-> m ()
rebuildModuleOpen makeEnv externs m = do
(openResult, _) <- liftIO
. P.runMake P.defaultOptions
. P.rebuildModule (buildMakeActions
>>= 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: " <> runModuleNameT (P.efModuleName result))
cacheRebuild result
data MakeActionsEnv =
MakeActionsEnv
{ maeOutputDirectory :: FilePath
, maeFilePathMap :: Map P.ModuleName (Either P.RebuildPolicy FilePath)
, maeForeignPathMap :: Map P.ModuleName FilePath
, maePrefixComment :: Bool
}
buildMakeActions :: MakeActionsEnv -> P.MakeActions P.Make
buildMakeActions MakeActionsEnv{..} =
P.buildMakeActions
maeOutputDirectory
maeFilePathMap
maeForeignPathMap
maePrefixComment
shushProgress :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make
shushProgress ma _ =
ma { P.progress = \_ -> pure () }
shushCodegen :: P.MakeActions P.Make -> MakeActionsEnv -> P.MakeActions P.Make
shushCodegen ma MakeActionsEnv{..} =
ma { P.codegen = \_ _ _ -> pure () }
sortExterns
:: (Ide m, MonadError PscIdeError m)
=> P.Module
-> Map P.ModuleName P.ExternsFile
-> m [P.ExternsFile]
sortExterns m ex = do
sorted' <- runExceptT
. P.sortModules
. (:) m
. map mkShallowModule
. M.elems
. M.delete (P.getModuleName m) $ ex
case sorted' of
Left err ->
throwError (RebuildError (toJSONErrors False P.Error 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 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