module Language.PureScript.Make
  (
  -- * Make API
  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)

-- | Rebuild a single module.
--
-- This function is used for fast-rebuild workflows (PSCi and psc-ide are examples).
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
    -- Imports cannot be linted before type checking because we need to
    -- known which newtype constructors are used to solve Coercible
    -- constraints in order to not report them as unused.
    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)

  -- desugar case declarations *after* type- and exhaustiveness checking
  -- since pattern guards introduces cases which the exhaustiveness checker
  -- reports as not-exhaustive.
  ([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

  -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
  -- but I have not done so for two reasons:
  -- 1. This should never fail; any genuine errors in the code should have been
  -- caught earlier in this function. Therefore if we do fail here it indicates
  -- a bug in the compiler, which should be reported as such.
  -- 2. We do not want to perform any extra work generating docs unless the
  -- user has asked for docs to be generated.
  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

-- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file.
--
-- If timestamps or hashes have not changed, existing externs files can be used to provide upstream modules' types without
-- having to typecheck those modules again.
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)

      -- Prevent hanging on other modules when there is an internal error
      -- (the exception is thrown, but other threads waiting on MVars are released)
      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)

  -- Wait for all threads to complete, and collect results (and errors).
  (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

  -- Write the updated build cache database to disk
  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

  -- If generating docs, also generate them for the Prim modules
  m ()
outputPrimDocs

  -- All threads have completed, rethrow any caught errors.
  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)

  -- Here we return all the ExternsFile in the ordering of the topological sort,
  -- so they can be folded into an Environment. This result is used in the tests
  -- and in PSCI.
  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

  -- Find all groups of duplicate values in a list based on a projection.
  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

  -- Sort a list so its elements appear in the same order as in another list.
  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
      -- We need to wait for dependencies to be built, before checking if the current
      -- module should be rebuilt, so the first thing to do is to wait on the
      -- MVars for the module's dependencies.
      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
          -- We need to ensure that all dependencies have been included in Env
          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

-- | Infer the module name for a module by looking for the same filename with
-- a .js extension.
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