-- | Provides the ability to sort modules based on module dependencies

{-# LANGUAGE FlexibleContexts #-}

module Language.PureScript.ModuleDependencies (

sortModules,

ModuleGraph

) where

import Control.Monad.Error.Class (MonadError(..))

import Data.Graph

import Data.List (nub)

import Data.Maybe (fromMaybe)

import Language.PureScript.Crash

import Language.PureScript.AST

import Language.PureScript.Names

import Language.PureScript.Types

import Language.PureScript.Errors

-- | A list of modules with their transitive dependencies

type ModuleGraph = [(ModuleName, [ModuleName])]

-- | Sort a collection of modules based on module dependencies.

sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)

sortModules ms = do

let verts = map (\m@(Module _ _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) 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)

-- |

usedModules :: Declaration -> [ModuleName]

usedModules 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 _ _ (Just (Left (Qualified (Just mn) _)))) = [mn]

forDecls (FixityDeclaration _ _ (Just (Right (Qualified (Just mn) _)))) = [mn]

forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _) = [mn]

forDecls _ = []

forValues :: Expr -> [ModuleName]

forValues (Var (Qualified (Just mn) _)) = [mn]

forValues (Constructor (Qualified (Just mn) _)) = [mn]

forValues _ = []

forTypes :: Type -> [ModuleName]

forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

forTypes _ = []

-- |

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)