module Language.PureScript.ModuleDependencies
( sortModules
, ModuleGraph
) where
import Protolude hiding (head)
import Data.Graph
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Set as S
import Language.PureScript.AST
import qualified Language.PureScript.Constants as C
import Language.PureScript.Crash
import Language.PureScript.Errors
import Language.PureScript.Names
type ModuleGraph = [(ModuleName, [ModuleName])]
sortModules
:: forall m
. MonadError MultipleErrors m
=> [Module]
-> m ([Module], ModuleGraph)
sortModules ms = do
let mns = S.fromList $ map getModuleName ms
verts <- parU ms (toGraphNode mns)
ms' <- parU (stronglyConnComp verts) toModule
let (graph, fromVertex, toVertex) = graphFromEdges verts
moduleGraph = do (_, mn, _) <- verts
let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)
deps = reachable graph v
toKey i = case fromVertex i of (_, key, _) -> key
return (mn, filter (/= mn) (map toKey deps))
return (ms', moduleGraph)
where
toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName])
toGraphNode mns m@(Module _ _ mn ds _) = do
let deps = ordNub (mapMaybe usedModules ds)
void . parU deps $ \(dep, pos) ->
when (dep `notElem` C.primModules && S.notMember dep mns) .
throwError
. addHint (ErrorInModule mn)
. errorMessage' pos
$ ModuleNotFound dep
pure (m, getModuleName m, map fst deps)
usedModules :: Declaration -> Maybe (ModuleName, SourceSpan)
usedModules (ImportDeclaration (ss, _) mn _ _) = pure (mn, ss)
usedModules _ = Nothing
toModule :: MonadError MultipleErrors m => SCC Module -> m Module
toModule (AcyclicSCC m) = return m
toModule (CyclicSCC []) = internalError "toModule: empty CyclicSCC"
toModule (CyclicSCC [m]) = return m
toModule (CyclicSCC (m : ms)) =
throwError
. errorMessage'' (fmap getModuleSourceSpan (m :| ms))
$ CycleInModules (map getModuleName ms)