module Language.PureScript.Make
(
rebuildModule
, rebuildModule'
, make
, inferForeignModules
, module Monad
, module Actions
) where
import Prelude
import Control.Concurrent.Lifted as C
import Control.Exception.Base (onException)
import Control.Monad (foldM, unless, when)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Supply (evalSupplyT, runSupply, runSupplyT)
import Control.Monad.Trans.Control (MonadBaseControl(..), control)
import Control.Monad.Trans.State (runStateT)
import Control.Monad.Writer.Class (MonadWriter(..), censor)
import Control.Monad.Writer.Strict (runWriterT)
import Data.Function (on)
import Data.Foldable (fold, for_)
import Data.List (foldl', sortOn)
import Data.List.NonEmpty qualified as NEL
import Data.Maybe (fromMaybe)
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Language.PureScript.AST (ErrorMessageHint(..), Module(..), SourceSpan(..), getModuleName, getModuleSourceSpan, importPrim)
import Language.PureScript.Crash (internalError)
import Language.PureScript.CST qualified as CST
import Language.PureScript.Docs.Convert qualified as Docs
import Language.PureScript.Environment (initEnvironment)
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, defaultPPEOptions, errorMessage', errorMessage'', prettyPrintMultipleErrors)
import Language.PureScript.Externs (ExternsFile, applyExternsFileToEnvironment, moduleToExternsFile)
import Language.PureScript.Linter (Name(..), lint, lintImports)
import Language.PureScript.ModuleDependencies (DependencyDepth(..), moduleSignature, sortModules)
import Language.PureScript.Names (ModuleName, isBuiltinModuleName, runModuleName)
import Language.PureScript.Renamer (renameInModule)
import Language.PureScript.Sugar (Env, collapseBindingGroups, createBindingGroups, desugar, desugarCaseGuards, externsEnv, primEnv)
import Language.PureScript.TypeChecker (CheckState(..), emptyCheckState, typeCheckModule)
import Language.PureScript.Make.BuildPlan (BuildJobResult(..), BuildPlan(..), getResult)
import Language.PureScript.Make.BuildPlan qualified as BuildPlan
import Language.PureScript.Make.Cache qualified as Cache
import Language.PureScript.Make.Actions as Actions
import Language.PureScript.Make.Monad as Monad
import Language.PureScript.CoreFn qualified as CF
import System.Directory (doesFileExist)
import System.FilePath (replaceExtension)
rebuildModule
:: forall m
. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [ExternsFile]
-> Module
-> m ExternsFile
rebuildModule :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
MakeActions m -> [ExternsFile] -> Module -> m ExternsFile
rebuildModule MakeActions m
actions [ExternsFile]
externs Module
m = do
Env
env <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall (m :: * -> *).
(MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Env -> ExternsFile -> m Env
externsEnv Env
primEnv [ExternsFile]
externs
forall (m :: * -> *).
(MonadBaseControl IO m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
MakeActions m -> Env -> [ExternsFile] -> Module -> m ExternsFile
rebuildModule' MakeActions m
actions Env
env [ExternsFile]
externs Module
m
rebuildModule'
:: forall m
. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> Env
-> [ExternsFile]
-> Module
-> m ExternsFile
rebuildModule' :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
MakeActions m -> Env -> [ExternsFile] -> Module -> m ExternsFile
rebuildModule' MakeActions m
act Env
env [ExternsFile]
ext Module
mdl = forall (m :: * -> *).
(MonadBaseControl IO m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
MakeActions m
-> Env
-> [ExternsFile]
-> Module
-> Maybe (Int, Int)
-> m ExternsFile
rebuildModuleWithIndex MakeActions m
act Env
env [ExternsFile]
ext Module
mdl forall a. Maybe a
Nothing
rebuildModuleWithIndex
:: forall m
. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> Env
-> [ExternsFile]
-> Module
-> Maybe (Int, Int)
-> m ExternsFile
rebuildModuleWithIndex :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
MakeActions m
-> Env
-> [ExternsFile]
-> Module
-> Maybe (Int, Int)
-> m ExternsFile
rebuildModuleWithIndex MakeActions{m ()
m CacheDb
CacheDb -> m ()
ModuleName -> m (Maybe UTCTime)
ModuleName
-> m (Either RebuildPolicy (Map [Char] (UTCTime, m ContentHash)))
ModuleName -> m ([Char], Maybe ExternsFile)
Module Ann -> m ()
Module Ann -> Module -> ExternsFile -> SupplyT m ()
ProgressMessage -> m ()
outputPrimDocs :: forall (m :: * -> *). MakeActions m -> m ()
writePackageJson :: forall (m :: * -> *). MakeActions m -> m ()
writeCacheDb :: forall (m :: * -> *). MakeActions m -> CacheDb -> m ()
readCacheDb :: forall (m :: * -> *). MakeActions m -> m CacheDb
progress :: forall (m :: * -> *). MakeActions m -> ProgressMessage -> m ()
ffiCodegen :: forall (m :: * -> *). MakeActions m -> Module Ann -> m ()
codegen :: forall (m :: * -> *).
MakeActions m
-> Module Ann -> Module -> ExternsFile -> SupplyT m ()
readExterns :: forall (m :: * -> *).
MakeActions m -> ModuleName -> m ([Char], Maybe ExternsFile)
getOutputTimestamp :: forall (m :: * -> *).
MakeActions m -> ModuleName -> m (Maybe UTCTime)
getInputTimestampsAndHashes :: forall (m :: * -> *).
MakeActions m
-> ModuleName
-> m (Either RebuildPolicy (Map [Char] (UTCTime, m ContentHash)))
outputPrimDocs :: m ()
writePackageJson :: m ()
writeCacheDb :: CacheDb -> m ()
readCacheDb :: m CacheDb
progress :: ProgressMessage -> m ()
ffiCodegen :: Module Ann -> m ()
codegen :: Module Ann -> Module -> ExternsFile -> SupplyT m ()
readExterns :: ModuleName -> m ([Char], Maybe ExternsFile)
getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
getInputTimestampsAndHashes :: ModuleName
-> m (Either RebuildPolicy (Map [Char] (UTCTime, m ContentHash)))
..} Env
exEnv [ExternsFile]
externs m :: Module
m@(Module SourceSpan
_ [Comment]
_ ModuleName
moduleName [Declaration]
_ Maybe [DeclarationRef]
_) Maybe (Int, Int)
moduleIndex = do
ProgressMessage -> m ()
progress forall a b. (a -> b) -> a -> b
$ ModuleName -> Maybe (Int, Int) -> ProgressMessage
CompilingModule ModuleName
moduleName Maybe (Int, Int)
moduleIndex
let env :: Environment
env = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip ExternsFile -> Environment -> Environment
applyExternsFileToEnvironment) Environment
initEnvironment [ExternsFile]
externs
withPrim :: Module
withPrim = Module -> Module
importPrim Module
m
forall (m :: * -> *).
MonadWriter MultipleErrors m =>
Module -> m ()
lint Module
withPrim
((Module SourceSpan
ss [Comment]
coms ModuleName
_ [Declaration]
elaborated Maybe [DeclarationRef]
exps, Environment
env'), Integer
nextVar) <- forall (m :: * -> *) a. Integer -> SupplyT m a -> m (a, Integer)
runSupplyT Integer
0 forall a b. (a -> b) -> a -> b
$ do
(Module
desugared, (Env
exEnv', Map ModuleName [Qualified Name]
usedImports)) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m,
MonadState (Env, Map ModuleName [Qualified Name]) m) =>
[ExternsFile] -> Module -> m Module
desugar [ExternsFile]
externs Module
withPrim) (Env
exEnv, forall a. Monoid a => a
mempty)
let modulesExports :: Map ModuleName Exports
modulesExports = (\(SourceSpan
_, Imports
_, Exports
exports) -> Exports
exports) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env
exEnv'
(Module
checked, CheckState{Int
[(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))]
[ErrorMessageHint]
Maybe ModuleName
Set (ModuleName, Qualified (ProperName 'ConstructorName))
Environment
Substitution
checkConstructorImportsForCoercible :: CheckState
-> Set (ModuleName, Qualified (ProperName 'ConstructorName))
checkHints :: CheckState -> [ErrorMessageHint]
checkSubstitution :: CheckState -> Substitution
checkCurrentModuleImports :: CheckState
-> [(SourceAnn, ModuleName, ImportDeclarationType,
Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))]
checkCurrentModule :: CheckState -> Maybe ModuleName
checkNextSkolemScope :: CheckState -> Int
checkNextSkolem :: CheckState -> Int
checkNextType :: CheckState -> Int
checkEnv :: CheckState -> Environment
checkConstructorImportsForCoercible :: Set (ModuleName, Qualified (ProperName 'ConstructorName))
checkHints :: [ErrorMessageHint]
checkSubstitution :: Substitution
checkCurrentModuleImports :: [(SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName,
Map
(ProperName 'TypeName)
([ProperName 'ConstructorName], ExportSource))]
checkCurrentModule :: Maybe ModuleName
checkNextSkolemScope :: Int
checkNextSkolem :: Int
checkNextType :: Int
checkEnv :: Environment
..}) <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall (m :: * -> *).
(MonadSupply m, MonadState CheckState m,
MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Map ModuleName Exports -> Module -> m Module
typeCheckModule Map ModuleName Exports
modulesExports Module
desugared) forall a b. (a -> b) -> a -> b
$ Environment -> CheckState
emptyCheckState Environment
env
let usedImports' :: Map ModuleName [Qualified Name]
usedImports' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ \(ModuleName
fromModuleName, Qualified (ProperName 'ConstructorName)
newtypeCtorName) ->
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProperName 'ConstructorName -> Name
DctorName Qualified (ProperName 'ConstructorName)
newtypeCtorName forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold) ModuleName
fromModuleName) Map ModuleName [Qualified Name]
usedImports Set (ModuleName, Qualified (ProperName 'ConstructorName))
checkConstructorImportsForCoercible
forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor (ErrorMessageHint -> MultipleErrors -> MultipleErrors
addHint (ModuleName -> ErrorMessageHint
ErrorInModule ModuleName
moduleName)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadWriter MultipleErrors m =>
Module -> Env -> Map ModuleName [Qualified Name] -> m ()
lintImports Module
checked Env
exEnv' Map ModuleName [Qualified Name]
usedImports'
forall (m :: * -> *) a. Monad m => a -> m a
return (Module
checked, Environment
checkEnv)
([Declaration]
deguarded, Integer
nextVar') <- forall (m :: * -> *) a. Integer -> SupplyT m a -> m (a, Integer)
runSupplyT Integer
nextVar forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
(MonadSupply m, MonadError MultipleErrors m) =>
[Declaration] -> m [Declaration]
desugarCaseGuards [Declaration]
elaborated
[Declaration]
regrouped <- forall (m :: * -> *).
MonadError MultipleErrors m =>
ModuleName -> [Declaration] -> m [Declaration]
createBindingGroups ModuleName
moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Declaration] -> [Declaration]
collapseBindingGroups forall a b. (a -> b) -> a -> b
$ [Declaration]
deguarded
let mod' :: Module
mod' = SourceSpan
-> [Comment]
-> ModuleName
-> [Declaration]
-> Maybe [DeclarationRef]
-> Module
Module SourceSpan
ss [Comment]
coms ModuleName
moduleName [Declaration]
regrouped Maybe [DeclarationRef]
exps
corefn :: Module Ann
corefn = Environment -> Module -> Module Ann
CF.moduleToCoreFn Environment
env' Module
mod'
(Module Ann
optimized, Integer
nextVar'') = forall a. Integer -> Supply a -> (a, Integer)
runSupply Integer
nextVar' forall a b. (a -> b) -> a -> b
$ Module Ann -> Supply (Module Ann)
CF.optimizeCoreFn Module Ann
corefn
(Map Ident Ident
renamedIdents, Module Ann
renamed) = Module Ann -> (Map Ident Ident, Module Ann)
renameInModule Module Ann
optimized
exts :: ExternsFile
exts = Module -> Environment -> Map Ident Ident -> ExternsFile
moduleToExternsFile Module
mod' Environment
env' Map Ident Ident
renamedIdents
Module Ann -> m ()
ffiCodegen Module Ann
renamed
let docs :: Module
docs = case forall (m :: * -> *).
MonadError MultipleErrors m =>
[ExternsFile] -> Env -> Environment -> Module -> m Module
Docs.convertModule [ExternsFile]
externs Env
exEnv Environment
env' Module
m of
Left MultipleErrors
errs -> forall a. HasCallStack => [Char] -> a
internalError forall a b. (a -> b) -> a -> b
$
[Char]
"Failed to produce docs for " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (ModuleName -> Text
runModuleName ModuleName
moduleName)
forall a. [a] -> [a] -> [a]
++ [Char]
"; details:\n" forall a. [a] -> [a] -> [a]
++ PPEOptions -> MultipleErrors -> [Char]
prettyPrintMultipleErrors PPEOptions
defaultPPEOptions MultipleErrors
errs
Right Module
d -> Module
d
forall (m :: * -> *) a. Functor m => Integer -> SupplyT m a -> m a
evalSupplyT Integer
nextVar'' forall a b. (a -> b) -> a -> b
$ Module Ann -> Module -> ExternsFile -> SupplyT m ()
codegen Module Ann
renamed Module
docs ExternsFile
exts
forall (m :: * -> *) a. Monad m => a -> m a
return ExternsFile
exts
make :: forall m. (MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
-> [CST.PartialResult Module]
-> m [ExternsFile]
make :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
MakeActions m -> [PartialResult Module] -> m [ExternsFile]
make ma :: MakeActions m
ma@MakeActions{m ()
m CacheDb
CacheDb -> m ()
ModuleName -> m (Maybe UTCTime)
ModuleName
-> m (Either RebuildPolicy (Map [Char] (UTCTime, m ContentHash)))
ModuleName -> m ([Char], Maybe ExternsFile)
Module Ann -> m ()
Module Ann -> Module -> ExternsFile -> SupplyT m ()
ProgressMessage -> m ()
outputPrimDocs :: m ()
writePackageJson :: m ()
writeCacheDb :: CacheDb -> m ()
readCacheDb :: m CacheDb
progress :: ProgressMessage -> m ()
ffiCodegen :: Module Ann -> m ()
codegen :: Module Ann -> Module -> ExternsFile -> SupplyT m ()
readExterns :: ModuleName -> m ([Char], Maybe ExternsFile)
getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
getInputTimestampsAndHashes :: ModuleName
-> m (Either RebuildPolicy (Map [Char] (UTCTime, m ContentHash)))
outputPrimDocs :: forall (m :: * -> *). MakeActions m -> m ()
writePackageJson :: forall (m :: * -> *). MakeActions m -> m ()
writeCacheDb :: forall (m :: * -> *). MakeActions m -> CacheDb -> m ()
readCacheDb :: forall (m :: * -> *). MakeActions m -> m CacheDb
progress :: forall (m :: * -> *). MakeActions m -> ProgressMessage -> m ()
ffiCodegen :: forall (m :: * -> *). MakeActions m -> Module Ann -> m ()
codegen :: forall (m :: * -> *).
MakeActions m
-> Module Ann -> Module -> ExternsFile -> SupplyT m ()
readExterns :: forall (m :: * -> *).
MakeActions m -> ModuleName -> m ([Char], Maybe ExternsFile)
getOutputTimestamp :: forall (m :: * -> *).
MakeActions m -> ModuleName -> m (Maybe UTCTime)
getInputTimestampsAndHashes :: forall (m :: * -> *).
MakeActions m
-> ModuleName
-> m (Either RebuildPolicy (Map [Char] (UTCTime, m ContentHash)))
..} [PartialResult Module]
ms = do
m ()
checkModuleNames
CacheDb
cacheDb <- m CacheDb
readCacheDb
([PartialResult Module]
sorted, ModuleGraph
graph) <- forall (m :: * -> *) a.
MonadError MultipleErrors m =>
DependencyDepth
-> (a -> ModuleSignature) -> [a] -> m ([a], ModuleGraph)
sortModules DependencyDepth
Transitive (Module -> ModuleSignature
moduleSignature forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial) [PartialResult Module]
ms
(BuildPlan
buildPlan, CacheDb
newCacheDb) <- forall (m :: * -> *).
MonadBaseControl IO m =>
MakeActions m
-> CacheDb
-> ([PartialResult Module], ModuleGraph)
-> m (BuildPlan, CacheDb)
BuildPlan.construct MakeActions m
ma CacheDb
cacheDb ([PartialResult Module]
sorted, ModuleGraph
graph)
let toBeRebuilt :: [PartialResult Module]
toBeRebuilt = forall a. (a -> Bool) -> [a] -> [a]
filter (BuildPlan -> ModuleName -> Bool
BuildPlan.needsRebuild BuildPlan
buildPlan forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial) [PartialResult Module]
sorted
let totalModuleCount :: Int
totalModuleCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [PartialResult Module]
toBeRebuilt
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PartialResult Module]
toBeRebuilt forall a b. (a -> b) -> a -> b
$ \PartialResult Module
m -> forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork forall a b. (a -> b) -> a -> b
$ do
let moduleName :: ModuleName
moduleName = Module -> ModuleName
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial forall a b. (a -> b) -> a -> b
$ PartialResult Module
m
let deps :: [ModuleName]
deps = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
internalError [Char]
"make: module not found in dependency graph.") (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
moduleName ModuleGraph
graph)
BuildPlan
-> ModuleName
-> Int
-> [Char]
-> [ParserWarning]
-> Either (NonEmpty ParserError) Module
-> [ModuleName]
-> m ()
buildModule BuildPlan
buildPlan ModuleName
moduleName Int
totalModuleCount
(SourceSpan -> [Char]
spanName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> SourceSpan
getModuleSourceSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial forall a b. (a -> b) -> a -> b
$ PartialResult Module
m)
(forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a.
PartialResult a
-> ([ParserWarning], Either (NonEmpty ParserError) a)
CST.resFull PartialResult Module
m)
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> Module
importPrim forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a.
PartialResult a
-> ([ParserWarning], Either (NonEmpty ParserError) a)
CST.resFull PartialResult Module
m)
([ModuleName]
deps forall a. Ord a => [a] -> [a] -> [a]
`inOrderOf` forall a b. (a -> b) -> [a] -> [b]
map (Module -> ModuleName
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial) [PartialResult Module]
sorted)
forall a b. m a -> m b -> m a
`onExceptionLifted` forall (m :: * -> *).
MonadBaseControl IO m =>
BuildPlan -> ModuleName -> BuildJobResult -> m ()
BuildPlan.markComplete BuildPlan
buildPlan ModuleName
moduleName (MultipleErrors -> BuildJobResult
BuildJobFailed forall a. Monoid a => a
mempty)
(Map ModuleName MultipleErrors
failures, Map ModuleName ExternsFile
successes) <-
let
splitResults :: BuildJobResult -> Either MultipleErrors ExternsFile
splitResults = \case
BuildJobSucceeded MultipleErrors
_ ExternsFile
exts ->
forall a b. b -> Either a b
Right ExternsFile
exts
BuildJobFailed MultipleErrors
errs ->
forall a b. a -> Either a b
Left MultipleErrors
errs
BuildJobResult
BuildJobSkipped ->
forall a b. a -> Either a b
Left forall a. Monoid a => a
mempty
in
forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
M.mapEither BuildJobResult -> Either MultipleErrors ExternsFile
splitResults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadBaseControl IO m =>
BuildPlan -> m (Map ModuleName BuildJobResult)
BuildPlan.collectResults BuildPlan
buildPlan
CacheDb -> m ()
writeCacheDb forall a b. (a -> b) -> a -> b
$ Set ModuleName -> CacheDb -> CacheDb
Cache.removeModules (forall k a. Map k a -> Set k
M.keysSet Map ModuleName MultipleErrors
failures) CacheDb
newCacheDb
m ()
writePackageJson
m ()
outputPrimDocs
let errors :: [MultipleErrors]
errors = forall k a. Map k a -> [a]
M.elems Map ModuleName MultipleErrors
failures
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [MultipleErrors]
errors) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall a. Monoid a => [a] -> a
mconcat [MultipleErrors]
errors)
let lookupResult :: ModuleName -> ExternsFile
lookupResult ModuleName
mn =
forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
internalError [Char]
"make: module not found in results")
forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
mn Map ModuleName ExternsFile
successes
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> ExternsFile
lookupResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial) [PartialResult Module]
sorted)
where
checkModuleNames :: m ()
checkModuleNames :: m ()
checkModuleNames = m ()
checkNoPrim forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m ()
checkModuleNamesAreUnique
checkNoPrim :: m ()
checkNoPrim :: m ()
checkNoPrim =
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PartialResult Module]
ms forall a b. (a -> b) -> a -> b
$ \PartialResult Module
m ->
let mn :: ModuleName
mn = Module -> ModuleName
getModuleName forall a b. (a -> b) -> a -> b
$ forall a. PartialResult a -> a
CST.resPartial PartialResult Module
m
in forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ModuleName -> Bool
isBuiltinModuleName ModuleName
mn) forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (Module -> SourceSpan
getModuleSourceSpan forall a b. (a -> b) -> a -> b
$ forall a. PartialResult a -> a
CST.resPartial PartialResult Module
m)
forall a b. (a -> b) -> a -> b
$ ModuleName -> SimpleErrorMessage
CannotDefinePrimModules ModuleName
mn
checkModuleNamesAreUnique :: m ()
checkModuleNamesAreUnique :: m ()
checkModuleNamesAreUnique =
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall b a. Ord b => (a -> b) -> [a] -> Maybe [NonEmpty a]
findDuplicates (Module -> ModuleName
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial) [PartialResult Module]
ms) forall a b. (a -> b) -> a -> b
$ \[NonEmpty (PartialResult Module)]
mss ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [NonEmpty (PartialResult Module)]
mss forall a b. (a -> b) -> a -> b
$ \NonEmpty (PartialResult Module)
ms' ->
let mn :: ModuleName
mn = Module -> ModuleName
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NEL.head forall a b. (a -> b) -> a -> b
$ NonEmpty (PartialResult Module)
ms'
in NonEmpty SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage'' (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Module -> SourceSpan
getModuleSourceSpan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PartialResult a -> a
CST.resPartial) NonEmpty (PartialResult Module)
ms') forall a b. (a -> b) -> a -> b
$ ModuleName -> SimpleErrorMessage
DuplicateModule ModuleName
mn
findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a]
findDuplicates :: forall b a. Ord b => (a -> b) -> [a] -> Maybe [NonEmpty a]
findDuplicates a -> b
f [a]
xs =
case forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NEL.groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn a -> b
f forall a b. (a -> b) -> a -> b
$ [a]
xs of
[] -> forall a. Maybe a
Nothing
[NonEmpty a]
xss -> forall a. a -> Maybe a
Just [NonEmpty a]
xss
inOrderOf :: (Ord a) => [a] -> [a] -> [a]
inOrderOf :: forall a. Ord a => [a] -> [a] -> [a]
inOrderOf [a]
xs [a]
ys = let s :: Set a
s = forall a. Ord a => [a] -> Set a
S.fromList [a]
xs in forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
s) [a]
ys
buildModule :: BuildPlan -> ModuleName -> Int -> FilePath -> [CST.ParserWarning] -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
buildModule :: BuildPlan
-> ModuleName
-> Int
-> [Char]
-> [ParserWarning]
-> Either (NonEmpty ParserError) Module
-> [ModuleName]
-> m ()
buildModule BuildPlan
buildPlan ModuleName
moduleName Int
cnt [Char]
fp [ParserWarning]
pwarnings Either (NonEmpty ParserError) Module
mres [ModuleName]
deps = do
BuildJobResult
result <- forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultipleErrors -> BuildJobResult
BuildJobFailed) forall a b. (a -> b) -> a -> b
$ do
let pwarnings' :: MultipleErrors
pwarnings' = [Char] -> [ParserWarning] -> MultipleErrors
CST.toMultipleWarnings [Char]
fp [ParserWarning]
pwarnings
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell MultipleErrors
pwarnings'
Module
m <- forall (m :: * -> *) a.
MonadError MultipleErrors m =>
[Char] -> Either (NonEmpty ParserError) a -> m a
CST.unwrapParserError [Char]
fp Either (NonEmpty ParserError) Module
mres
Maybe ([MultipleErrors], [ExternsFile])
mexterns <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
MonadBaseControl IO m =>
BuildPlan -> ModuleName -> m (Maybe (MultipleErrors, ExternsFile))
getResult BuildPlan
buildPlan) [ModuleName]
deps
case Maybe ([MultipleErrors], [ExternsFile])
mexterns of
Just ([MultipleErrors]
_, [ExternsFile]
externs) -> do
forall (m :: * -> *) a.
MonadBaseControl IO m =>
MVar a -> (a -> m a) -> m ()
C.modifyMVar_ (BuildPlan -> MVar Env
bpEnv BuildPlan
buildPlan) forall a b. (a -> b) -> a -> b
$ \Env
env -> do
let
go :: Env -> ModuleName -> m Env
go :: Env -> ModuleName -> m Env
go Env
e ModuleName
dep = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ModuleName
dep (forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleName]
deps [ExternsFile]
externs) of
Just ExternsFile
exts
| Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member ModuleName
dep Env
e) -> forall (m :: * -> *).
(MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
Env -> ExternsFile -> m Env
externsEnv Env
e ExternsFile
exts
Maybe ExternsFile
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Env
e
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Env -> ModuleName -> m Env
go Env
env [ModuleName]
deps
Env
env <- forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
C.readMVar (BuildPlan -> MVar Env
bpEnv BuildPlan
buildPlan)
Int
idx <- forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
C.takeMVar (BuildPlan -> MVar Int
bpIndex BuildPlan
buildPlan)
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
C.putMVar (BuildPlan -> MVar Int
bpIndex BuildPlan
buildPlan) (Int
idx forall a. Num a => a -> a -> a
+ Int
1)
(ExternsFile
exts, MultipleErrors
warnings) <- forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadBaseControl IO m, MonadError MultipleErrors m,
MonadWriter MultipleErrors m) =>
MakeActions m
-> Env
-> [ExternsFile]
-> Module
-> Maybe (Int, Int)
-> m ExternsFile
rebuildModuleWithIndex MakeActions m
ma Env
env [ExternsFile]
externs Module
m (forall a. a -> Maybe a
Just (Int
idx, Int
cnt))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ MultipleErrors -> ExternsFile -> BuildJobResult
BuildJobSucceeded (MultipleErrors
pwarnings' forall a. Semigroup a => a -> a -> a
<> MultipleErrors
warnings) ExternsFile
exts
Maybe ([MultipleErrors], [ExternsFile])
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return BuildJobResult
BuildJobSkipped
forall (m :: * -> *).
MonadBaseControl IO m =>
BuildPlan -> ModuleName -> BuildJobResult -> m ()
BuildPlan.markComplete BuildPlan
buildPlan ModuleName
moduleName BuildJobResult
result
onExceptionLifted :: m a -> m b -> m a
onExceptionLifted :: forall a b. m a -> m b -> m a
onExceptionLifted m a
l m b
r = forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO -> RunInBase m IO
runInIO m a
l forall a b. IO a -> IO b -> IO a
`onException` RunInBase m IO
runInIO m b
r
inferForeignModules
:: forall m
. MonadIO m
=> M.Map ModuleName (Either RebuildPolicy FilePath)
-> m (M.Map ModuleName FilePath)
inferForeignModules :: forall (m :: * -> *).
MonadIO m =>
Map ModuleName (Either RebuildPolicy [Char])
-> m (Map ModuleName [Char])
inferForeignModules =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b k. (a -> Maybe b) -> Map k a -> Map k b
M.mapMaybe forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Either RebuildPolicy [Char] -> m (Maybe [Char])
inferForeignModule
where
inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)
inferForeignModule :: Either RebuildPolicy [Char] -> m (Maybe [Char])
inferForeignModule (Left RebuildPolicy
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
inferForeignModule (Right [Char]
path) = do
let jsFile :: [Char]
jsFile = [Char] -> [Char] -> [Char]
replaceExtension [Char]
path [Char]
"js"
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
jsFile
if Bool
exists
then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Char]
jsFile)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing