git.iko.soy/elk
on master help sign in
Start using Data.Graph to work out dependency problems and other minor tweaks
9592d28Evan Czaplicki
compiler/Initialize.hs+27−19
compare with master
unifiedsplit
@@ -5,10 +5,11 @@ import Control.Monad.Error
5import Data.List (nub)
5import Data.List (nub)
6import qualified Data.Map as Map
6import qualified Data.Map as Map
7import Data.Data
7import Data.Data
8−import Data.List (intercalate,partition)
8+import qualified Data.Graph as Graph
9+import qualified Data.List as List
9import System.Exit
10import System.Exit
10import System.FilePath as FP
11import System.FilePath as FP
11−import Text.PrettyPrint (Doc)
12+import Text.PrettyPrint as P
12
13
13import SourceSyntax.Everything
14import SourceSyntax.Everything
14import SourceSyntax.Declaration (Assoc)
15import SourceSyntax.Declaration (Assoc)
@@ -22,21 +23,24 @@ import qualified Type.Inference as TI
22import qualified Type.Constrain.Declaration as TcDecl
23import qualified Type.Constrain.Declaration as TcDecl
23import qualified Type.Type as T
24import qualified Type.Type as T
24
25
26+import System.IO.Unsafe
25
27
28+
26−buildFromSource :: (Data t, Data v) => Bool -> String -> Either [Doc] (MetadataModule t v)
29+buildFromSource :: (Data t, Data v) => Bool -> String -> Either [P.Doc] (MetadataModule t v)
27buildFromSource noPrelude src =
30buildFromSource noPrelude src =
28 do modul <- Parse.program src
31 do modul <- Parse.program src
29
32
30 -- check for structural errors
33 -- check for structural errors
31 Module names exs ims decls <- checkMistakes modul
34 Module names exs ims decls <- checkMistakes modul
32
35
33− -- reorder AST into strongly connected components
36+
34 let metaModule = MetadataModule {
37 let metaModule = MetadataModule {
35 names = names,
38 names = names,
36 path = FP.joinPath names,
39 path = FP.joinPath names,
37 exports = exs,
40 exports = exs,
38 imports = ims,
41 imports = ims,
42+ -- reorder AST into strongly connected components
39− defs = fst . SD.flattenLets [] . SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
43+ program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
40 types = Map.empty,
44 types = Map.empty,
41 datatypes = [ (name, vars, ctors) | Datatype name vars ctors <- decls ],
45 datatypes = [ (name, vars, ctors) | Datatype name vars ctors <- decls ],
42 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
46 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
@@ -46,7 +50,12 @@ buildFromSource noPrelude src =
46 }
50 }
47
51
48 types <- TI.infer metaModule
52 types <- TI.infer metaModule
53+
54+ let env = forM (Map.toList types) $ \(n,t) -> do
55+ pt <- T.extraPretty t
56+ print $ P.text n <+> P.text ":" <+> pt
57+
49− return $ metaModule { types = types }
58+ return $ unsafePerformIO env `seq` metaModule { types = types }
50
59
51 where
60 where
52 checkMistakes modul@(Module _ _ _ decls) =
61 checkMistakes modul@(Module _ _ _ decls) =
@@ -62,17 +71,16 @@ getSortedModuleNames root =
62type Deps = (String, [String])
71type Deps = (String, [String])
63
72
64sortDeps :: [Deps] -> IO [String]
73sortDeps :: [Deps] -> IO [String]
65−sortDeps deps = go [] (nub deps)
74+sortDeps depends =
75+ if null mistakes
76+ then return (concat sccs)
77+ else print (msg ++ show mistakes) >> exitFailure
66− where
78+ where
79+ graph = map (\(name, deps) -> (toFilePath name, name, deps)) depends
80+ sccs = map Graph.flattenSCC $ Graph.stronglyConnComp graph
81+
82+ mistakes = filter (\scc -> length scc > 1) sccs
67− msg = "A cyclical or missing module dependency or was detected in: "
83+ msg = "A cyclical module dependency or was detected in: "
68−
69− go :: [String] -> [Deps] -> IO [String]
70− go sorted [] = return (map toFilePath sorted)
71− go sorted unsorted =
72− case partition (all (`elem` sorted) . snd) unsorted of
73− ([],m:ms) -> do putStrLn (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
74− exitFailure
75− (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
76
84
77readDeps :: [FilePath] -> FilePath -> IO [Deps]
85readDeps :: [FilePath] -> FilePath -> IO [Deps]
78readDeps seen root = do
86readDeps seen root = do
@@ -86,12 +94,12 @@ readDeps seen root = do
86 return ((name, realDeps) : concat rest)
94 return ((name, realDeps) : concat rest)
87 where
95 where
88 realDeps = filter (`notElem` builtIns) deps
96 realDeps = filter (`notElem` builtIns) deps
89− newDeps = filter (\d -> d `notElem` seen && not (isNative d)) realDeps
97+ newDeps = filter (\d -> not (d `elem` seen || isNative d)) realDeps
90 seen' = root : seen ++ newDeps
98 seen' = root : seen ++ newDeps
91 builtIns = Map.keys Libs.libraries
99 builtIns = Map.keys Libs.libraries
92
100
93
101
94−isNative name = takeWhile (/='.') name == "Native"
102+isNative name = List.isPrefixOf "Native." name
95
103
96toFilePath :: String -> FilePath
104toFilePath :: String -> FilePath
97toFilePath name = map swapDots name ++ ext
105toFilePath name = map swapDots name ++ ext