module Language.PureScript.Ide.Rebuild
( rebuildFile
) where
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import "monad-logger" Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Except
import qualified Data.Map.Lazy as M
import Data.Maybe (fromJust, mapMaybe)
import Data.Monoid ((<>))
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 Prelude.Compat
import System.IO.UTF8 (readUTF8File)
rebuildFile
:: (PscIde m, MonadLogger m, MonadError PscIdeError m)
=> FilePath
-> m Success
rebuildFile path = do
input <- liftIO (readUTF8File path)
m <- case snd <$> P.parseModuleFromFile id (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 . envConfiguration <$> 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
:: (PscIde 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))
setCachedRebuild result
data MakeActionsEnv =
MakeActionsEnv
{ maeOutputDirectory :: FilePath
, maeFilePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
, maeForeignPathMap :: M.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
:: (PscIde m, MonadError PscIdeError m)
=> P.Module
-> M.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 _ -> throwError (GeneralError "There was a cycle in the dependencies")
Right (sorted, graph) -> do
let deps = fromJust (lookup (P.getModuleName m) graph)
pure $ mapMaybe getExtern (deps `inOrderOf` map P.getModuleName sorted)
where
mkShallowModule P.ExternsFile{..} =
P.Module undefined [] 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