git.iko.soy/elk
on master help sign in
Rewrite `readDeps` so that modules are never read more than once
39f2a87Evan Czaplicki
compiler/Initialize.hs+22−16
compare with master
unifiedsplit
@@ -1,9 +1,11 @@
1module Initialize (buildFromSource, getSortedModuleNames, Interfaces) where
1module Initialize (buildFromSource, getSortedModuleNames, Interfaces) where
2
2
3−import qualified Data.Map as Map
4import Data.Data
3import Data.Data
4+import Control.Monad.State
5import qualified Data.Graph as Graph
5import qualified Data.Graph as Graph
6import qualified Data.List as List
6import qualified Data.List as List
7+import qualified Data.Map as Map
8+import qualified Data.Set as Set
7import System.Exit
9import System.Exit
8import System.FilePath as FP
10import System.FilePath as FP
9import Text.PrettyPrint (Doc)
11import Text.PrettyPrint (Doc)
@@ -52,7 +54,7 @@ buildFromSource interfaces source =
52
54
53getSortedModuleNames :: FilePath -> IO [String]
55getSortedModuleNames :: FilePath -> IO [String]
54getSortedModuleNames root =
56getSortedModuleNames root =
55− sortDeps =<< readDeps [] root
57+ sortDeps =<< readDeps root
56
58
57type Deps = (String, [String])
59type Deps = (String, [String])
58
60
@@ -68,21 +70,25 @@ sortDeps depends =
68 mistakes = filter (\scc -> length scc > 1) sccs
70 mistakes = filter (\scc -> length scc > 1) sccs
69 msg = "A cyclical module dependency or was detected in: "
71 msg = "A cyclical module dependency or was detected in: "
70
72
71−readDeps :: [FilePath] -> FilePath -> IO [Deps]
73+readDeps :: FilePath -> IO [Deps]
74+readDeps root = evalStateT (go root) Set.empty
75+ where
76+ builtIns = Set.fromList (Map.keys Prelude.interfaces)
77+
78+ go :: FilePath -> StateT (Set.Set String) IO [Deps]
72−readDeps seen root = do
79+ go root = do
73− txt <- readFile root
80+ txt <- liftIO $ readFile root
74− case Parse.dependencies txt of
81+ case Parse.dependencies txt of
75− Left err -> putStrLn msg >> print err >> exitFailure
82+ Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
76− where msg = "Error resolving dependencies in " ++ root ++ ":"
83+ where msg = "Error resolving dependencies in " ++ root ++ ":"
77
84
78− Right (name,deps) ->
85+ Right (name,deps) ->
86+ do seen <- get
87+ let realDeps = Set.difference (Set.fromList deps) builtIns
88+ newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
89+ put (Set.insert name (Set.union newDeps seen))
79− do rest <- mapM (readDeps seen' . toFilePath) newDeps
90+ rest <- mapM (go . toFilePath) (Set.toList newDeps)
80− return ((name, realDeps) : concat rest)
91+ return ((name, Set.toList realDeps) : concat rest)
81− where
82− realDeps = filter (`notElem` builtIns) deps
83− newDeps = filter (\d -> not (d `elem` seen || isNative d)) realDeps
84− seen' = root : seen ++ newDeps
85− builtIns = Map.keys Prelude.interfaces
86
92
87
93
88isNative name = List.isPrefixOf "Native." name
94isNative name = List.isPrefixOf "Native." name