git.iko.soy/elk
on master help sign in
First draft of cross-module type checking
c140d69Evan Czaplicki
compiler/Initialize.hs+7−7
compare with master
unifiedsplit
@@ -1,4 +1,4 @@
1−module Initialize (buildFromSource, getSortedModuleNames, TypeLibrary) where
1+module Initialize (buildFromSource, getSortedModuleNames, Interfaces) where
2
2
3import qualified Data.Map as Map
3import qualified Data.Map as Map
4import Data.Data
4import Data.Data
@@ -17,15 +17,14 @@ import qualified Transform.SortDefinitions as SD
17import qualified Type.Inference as TI
17import qualified Type.Inference as TI
18import qualified Type.Constrain.Declaration as TcDecl
18import qualified Type.Constrain.Declaration as TcDecl
19
19
20−
20+import System.IO.Unsafe
21−type TypeLibrary = Map.Map String ModuleInterface
22
21
23buildFromSource ::
22buildFromSource ::
24 (Data t, Data v) =>
23 (Data t, Data v) =>
25− TypeLibrary ->
24+ Interfaces ->
26 String ->
25 String ->
27 Either [Doc] (MetadataModule t v)
26 Either [Doc] (MetadataModule t v)
28−buildFromSource typeLibrary source =
27+buildFromSource interfaces source =
29 do modul@(Module _ _ _ decls') <- Parse.program source
28 do modul@(Module _ _ _ decls') <- Parse.program source
30
29
31 -- check for structural errors
30 -- check for structural errors
@@ -42,14 +41,15 @@ buildFromSource typeLibrary source =
42 -- reorder AST into strongly connected components
41 -- reorder AST into strongly connected components
43 program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
42 program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
44 types = Map.empty,
43 types = Map.empty,
45− datatypes = [ (name, vars, ctors) | Datatype name vars ctors <- decls ],
44+ datatypes = [ (name, vars, ctors) | Datatype name vars ctors <- decls ] ++
45+ concatMap iAdts (Map.elems interfaces),
46 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
46 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
47 aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
47 aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
48 foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
48 foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
49 foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
49 foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
50 }
50 }
51
51
52− types <- TI.infer metaModule
52+ types <- TI.infer interfaces metaModule
53
53
54 return $ metaModule { types = types }
54 return $ metaModule { types = types }
55
55
compiler/SourceSyntax/Module.hs+3−1
@@ -37,9 +37,11 @@ data MetadataModule t v = MetadataModule {
37 foreignExports :: [(String, String, Type)]
37 foreignExports :: [(String, String, Type)]
38}
38}
39
39
40+type Interfaces = Map.Map String ModuleInterface
41+
40data ModuleInterface = ModuleInterface {
42data ModuleInterface = ModuleInterface {
41 iTypes :: Map.Map String Type,
43 iTypes :: Map.Map String Type,
42− iAdts :: Map.Map String (Int, [String])
44+ iAdts :: [(String, [String], [(String,[Type])])]
43} deriving Show
45} deriving Show
44
46
45instance Binary ModuleInterface where
47instance Binary ModuleInterface where
compiler/Type/Environment.hs+5−2
@@ -22,11 +22,12 @@ initialEnvironment datatypes = do
22 types <- makeTypes datatypes
22 types <- makeTypes datatypes
23
23
24 return $ Environment {
24 return $ Environment {
25− constructor = makeConstructors types datatypes,
25+ constructor = makeConstructors types,
26 types = types,
26 types = types,
27 value = Map.empty
27 value = Map.empty
28 }
28 }
29
29
30+makeTypes :: [(String, [String], [(String, [Src.Type])])] -> IO (Map.Map String Type)
30makeTypes datatypes =
31makeTypes datatypes =
31 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
32 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
32 where
33 where
@@ -46,7 +47,9 @@ makeTypes datatypes =
46 , kind 0 ["Int","Float","Char","Bool","Element"]
47 , kind 0 ["Int","Float","Char","Bool","Element"]
47 ]
48 ]
48
49
50+
51+makeConstructors :: Map.Map String Type -> Map.Map String (IO (Int, [Variable], Type))
49−makeConstructors types datatypes = Map.fromList builtins
52+makeConstructors types = Map.fromList builtins
50 where
53 where
51 list t = (types ! "_List") <| t
54 list t = (types ! "_List") <| t
52 maybe t = (types ! "Maybe") <| t
55 maybe t = (types ! "Maybe") <| t
compiler/Type/Inference.hs+10−4
@@ -21,18 +21,24 @@ import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
21 -- the IO monad. Not sure if that'd be worthwhile.
21 -- the IO monad. Not sure if that'd be worthwhile.
22
22
23
23
24−infer :: MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
24+infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
25−infer modul = unsafePerformIO $ do
25+infer interfaces modul = unsafePerformIO $ do
26 env <- Env.initialEnvironment (datatypes modul)
26 env <- Env.initialEnvironment (datatypes modul)
27 var <- T.flexibleVar
27 var <- T.flexibleVar
28 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
28 ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
29 do (_, vars, tipe) <- Env.freshDataScheme env name
29 do (_, vars, tipe) <- Env.freshDataScheme env name
30 return (name, (vars, tipe))
30 return (name, (vars, tipe))
31
31
32+ importedVars <-
33+ forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
34+ (,) name `fmap` Env.instantiateTypeWithContext env tipe Map.empty
35+
36+ let allTypes = ctors ++ importedVars
32− let vars = concatMap (fst . snd) ctors
37+ vars = concatMap (fst . snd) allTypes
33− header = Map.map snd (Map.fromList ctors)
38+ header = Map.map snd (Map.fromList allTypes)
34 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
39 environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
35 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)
40 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)
41+-- print =<< T.extraPretty constraint
36 state <- execStateT (Solve.solve constraint) TS.initialState
42 state <- execStateT (Solve.solve constraint) TS.initialState
37 let errors = TS.sErrors state
43 let errors = TS.sErrors state
38 if null errors
44 if null errors