module Language.PureScript.ModuleDependencies
( sortModules
, ModuleGraph
) where
import Prelude.Compat
import Control.Monad.Error.Class (MonadError(..))
import Data.Graph
import Data.List (nub)
import Data.Maybe (fromMaybe)
import Language.PureScript.AST
import Language.PureScript.Crash
import Language.PureScript.Errors
import Language.PureScript.Names
import Language.PureScript.Types
type ModuleGraph = [(ModuleName, [ModuleName])]
sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
sortModules ms = do
let verts = map goModule ms
ms' <- mapM toModule $ stronglyConnComp verts
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
goModule :: Module -> (Module, ModuleName, [ModuleName])
goModule m@(Module _ _ _ ds _) =
let ams = concatMap extractQualAs ds
in (m, getModuleName m, nub (concatMap (usedModules ams) ds))
extractQualAs :: Declaration -> [ModuleName]
extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d
extractQualAs (ImportDeclaration _ _ (Just am)) = [am]
extractQualAs _ = []
usedModules :: [ModuleName] -> Declaration -> [ModuleName]
usedModules ams d =
let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])
(g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)
in nub (f d ++ g d)
where
forDecls :: Declaration -> [ModuleName]
forDecls (ImportDeclaration mn _ _) =
[mn]
forDecls (FixityDeclaration fd)
| Just mn <- extractQualFixity fd, mn `notElem` ams = [mn]
forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _)
| mn `notElem` ams = [mn]
forDecls _ = []
forValues :: Expr -> [ModuleName]
forValues (Var (Qualified (Just mn) _))
| mn `notElem` ams = [mn]
forValues (Constructor (Qualified (Just mn) _))
| mn `notElem` ams = [mn]
forValues _ = []
forTypes :: Type -> [ModuleName]
forTypes (TypeConstructor (Qualified (Just mn) _))
| mn `notElem` ams = [mn]
forTypes _ = []
extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName
extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn
extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn
toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module
toModule (AcyclicSCC m) = return m
toModule (CyclicSCC [m]) = return m
toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)