git.iko.soy/rowtype-yoga/purescript-native
on fca3655 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/ModuleDependencies.hs
100 lines 3.8 kB history raw
1-- |
2-- Provides the ability to sort modules based on module dependencies
3--
4module Language.PureScript.ModuleDependencies
5 ( sortModules
6 , ModuleGraph
7 ) where
9import Prelude.Compat
11import Control.Monad.Error.Class (MonadError(..))
13import Data.Graph
14import Data.List (nub)
15import Data.Maybe (fromMaybe)
17import Language.PureScript.AST
18import Language.PureScript.Crash
19import Language.PureScript.Errors
20import Language.PureScript.Names
21import Language.PureScript.Types
23-- | A list of modules with their transitive dependencies
24type ModuleGraph = [(ModuleName, [ModuleName])]
26-- | Sort a collection of modules based on module dependencies.
27--
28-- Reports an error if the module graph contains a cycle.
29--
30sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
31sortModules ms = do
32 let verts = map goModule ms
33 ms' <- mapM toModule $ stronglyConnComp verts
34 let (graph, fromVertex, toVertex) = graphFromEdges verts
35 moduleGraph = do (_, mn, _) <- verts
36 let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)
37 deps = reachable graph v
38 toKey i = case fromVertex i of (_, key, _) -> key
39 return (mn, filter (/= mn) (map toKey deps))
40 return (ms', moduleGraph)
41 where
42 goModule :: Module -> (Module, ModuleName, [ModuleName])
43 goModule m@(Module _ _ _ ds _) =
44 let ams = concatMap extractQualAs ds
45 in (m, getModuleName m, nub (concatMap (usedModules ams) ds))
47 -- Extract module names that have been brought into scope by an `as` import.
48 extractQualAs :: Declaration -> [ModuleName]
49 extractQualAs (PositionedDeclaration _ _ d) = extractQualAs d
50 extractQualAs (ImportDeclaration _ _ (Just am)) = [am]
51 extractQualAs _ = []
53-- |
54-- Calculate a list of used modules based on explicit imports and qualified
55-- names. `ams` is a list of `ModuleNames` that refer to names brought into
56-- scope by importing with `as` - this ensures that when building the list we
57-- don't inadvertantly assume a dependency on an actual module, if there is a
58-- module that has the same name as the qualified import.
59--
60usedModules :: [ModuleName] -> Declaration -> [ModuleName]
61usedModules ams d =
62 let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const [])
63 (g, _, _, _, _) = accumTypes (everythingOnTypes (++) forTypes)
64 in nub (f d ++ g d)
65 where
67 forDecls :: Declaration -> [ModuleName]
68 forDecls (ImportDeclaration mn _ _) =
69 -- Regardless of whether an imported module is qualified we still need to
70 -- take into account its import to build an accurate list of dependencies.
71 [mn]
72 forDecls (FixityDeclaration fd)
73 | Just mn <- extractQualFixity fd, mn `notElem` ams = [mn]
74 forDecls (TypeInstanceDeclaration _ _ (Qualified (Just mn) _) _ _)
75 | mn `notElem` ams = [mn]
76 forDecls _ = []
78 forValues :: Expr -> [ModuleName]
79 forValues (Var (Qualified (Just mn) _))
80 | mn `notElem` ams = [mn]
81 forValues (Constructor (Qualified (Just mn) _))
82 | mn `notElem` ams = [mn]
83 forValues _ = []
85 forTypes :: Type -> [ModuleName]
86 forTypes (TypeConstructor (Qualified (Just mn) _))
87 | mn `notElem` ams = [mn]
88 forTypes _ = []
90 extractQualFixity :: Either ValueFixity TypeFixity -> Maybe ModuleName
91 extractQualFixity (Left (ValueFixity _ (Qualified mn _) _)) = mn
92 extractQualFixity (Right (TypeFixity _ (Qualified mn _) _)) = mn
94-- |
95-- Convert a strongly connected component of the module graph to a module
96--
97toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module
98toModule (AcyclicSCC m) = return m
99toModule (CyclicSCC [m]) = return m
100toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)