First draft of cross-module type checking
Currently, all top-level types are imported. No alias resolution happens so you need to use "import open M" atm.
This commit is contained in:
parent
4bcde7e799
commit
c140d690fc
4 changed files with 25 additions and 14 deletions
|
@ -1,4 +1,4 @@
|
|||
module Initialize (buildFromSource, getSortedModuleNames, TypeLibrary) where
|
||||
module Initialize (buildFromSource, getSortedModuleNames, Interfaces) where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import Data.Data
|
||||
|
@ -17,15 +17,14 @@ import qualified Transform.SortDefinitions as SD
|
|||
import qualified Type.Inference as TI
|
||||
import qualified Type.Constrain.Declaration as TcDecl
|
||||
|
||||
|
||||
type TypeLibrary = Map.Map String ModuleInterface
|
||||
import System.IO.Unsafe
|
||||
|
||||
buildFromSource ::
|
||||
(Data t, Data v) =>
|
||||
TypeLibrary ->
|
||||
Interfaces ->
|
||||
String ->
|
||||
Either [Doc] (MetadataModule t v)
|
||||
buildFromSource typeLibrary source =
|
||||
buildFromSource interfaces source =
|
||||
do modul@(Module _ _ _ decls') <- Parse.program source
|
||||
|
||||
-- check for structural errors
|
||||
|
@ -42,14 +41,15 @@ buildFromSource typeLibrary source =
|
|||
-- reorder AST into strongly connected components
|
||||
program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
|
||||
types = Map.empty,
|
||||
datatypes = [ (name, vars, ctors) | Datatype name vars ctors <- decls ],
|
||||
datatypes = [ (name, vars, ctors) | Datatype name vars ctors <- decls ] ++
|
||||
concatMap iAdts (Map.elems interfaces),
|
||||
fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
|
||||
aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
|
||||
foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
|
||||
foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
|
||||
}
|
||||
|
||||
types <- TI.infer metaModule
|
||||
types <- TI.infer interfaces metaModule
|
||||
|
||||
return $ metaModule { types = types }
|
||||
|
||||
|
|
|
@ -37,9 +37,11 @@ data MetadataModule t v = MetadataModule {
|
|||
foreignExports :: [(String, String, Type)]
|
||||
}
|
||||
|
||||
type Interfaces = Map.Map String ModuleInterface
|
||||
|
||||
data ModuleInterface = ModuleInterface {
|
||||
iTypes :: Map.Map String Type,
|
||||
iAdts :: Map.Map String (Int, [String])
|
||||
iAdts :: [(String, [String], [(String,[Type])])]
|
||||
} deriving Show
|
||||
|
||||
instance Binary ModuleInterface where
|
||||
|
|
|
@ -22,11 +22,12 @@ initialEnvironment datatypes = do
|
|||
types <- makeTypes datatypes
|
||||
|
||||
return $ Environment {
|
||||
constructor = makeConstructors types datatypes,
|
||||
constructor = makeConstructors types,
|
||||
types = types,
|
||||
value = Map.empty
|
||||
}
|
||||
|
||||
makeTypes :: [(String, [String], [(String, [Src.Type])])] -> IO (Map.Map String Type)
|
||||
makeTypes datatypes =
|
||||
Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
|
||||
where
|
||||
|
@ -46,7 +47,9 @@ makeTypes datatypes =
|
|||
, kind 0 ["Int","Float","Char","Bool","Element"]
|
||||
]
|
||||
|
||||
makeConstructors types datatypes = Map.fromList builtins
|
||||
|
||||
makeConstructors :: Map.Map String Type -> Map.Map String (IO (Int, [Variable], Type))
|
||||
makeConstructors types = Map.fromList builtins
|
||||
where
|
||||
list t = (types ! "_List") <| t
|
||||
maybe t = (types ! "Maybe") <| t
|
||||
|
|
|
@ -21,18 +21,24 @@ import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
|
|||
-- the IO monad. Not sure if that'd be worthwhile.
|
||||
|
||||
|
||||
infer :: MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
|
||||
infer modul = unsafePerformIO $ do
|
||||
infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String T.Variable)
|
||||
infer interfaces modul = unsafePerformIO $ do
|
||||
env <- Env.initialEnvironment (datatypes modul)
|
||||
var <- T.flexibleVar
|
||||
ctors <- forM (Map.keys (Env.constructor env)) $ \name ->
|
||||
do (_, vars, tipe) <- Env.freshDataScheme env name
|
||||
return (name, (vars, tipe))
|
||||
|
||||
let vars = concatMap (fst . snd) ctors
|
||||
header = Map.map snd (Map.fromList ctors)
|
||||
importedVars <-
|
||||
forM (concatMap (Map.toList . iTypes) $ Map.elems interfaces) $ \(name,tipe) ->
|
||||
(,) name `fmap` Env.instantiateTypeWithContext env tipe Map.empty
|
||||
|
||||
let allTypes = ctors ++ importedVars
|
||||
vars = concatMap (fst . snd) allTypes
|
||||
header = Map.map snd (Map.fromList allTypes)
|
||||
environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
|
||||
constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN var)
|
||||
-- print =<< T.extraPretty constraint
|
||||
state <- execStateT (Solve.solve constraint) TS.initialState
|
||||
let errors = TS.sErrors state
|
||||
if null errors
|
||||
|
|
Loading…
Reference in a new issue