@@ -24,50 +24,56 @@ import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
26infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
26infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType)
27+infer interfaces modul =
27−infer interfaces modul = unsafePerformIO $ runErrorT $ do
28+ unsafePerformIO $ runErrorT $
28− (header, constraint) <- genConstraints interfaces modul
29+ do (header, constraint) <- genConstraints interfaces modul
30− state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
31+ state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
32− () <- case TS.sErrors state of
33+ () <- case TS.sErrors state of
33− errors@(_:_) -> throwError errors
34+ errors@(_:_) -> throwError errors
34− [] -> return ()
35+ [] -> return ()
36− () <- Check.portTypes (program (body modul))
37+ () <- Check.portTypes (program (body modul))
38− let header' = Map.delete "::" header
39+ let header' = Map.delete "::" header
39− types = Map.difference (TS.sSavedEnv state) header'
40+ types = Map.difference (TS.sSavedEnv state) header'
41− Check.mainType types
42+ Check.mainType types
44−genConstraints :: Interfaces -> CanonicalModule
47+ -> CanonicalModule
45− -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
48+ -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint)
46−genConstraints interfaces modul = do
49+genConstraints interfaces modul =
47− env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
50+ do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul)
49− ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
52+ ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do
50− (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
53+ (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name
51− return (name, (vars, foldr (T.==>) result args))
54+ return (name, (vars, foldr (T.==>) result args))
53− importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
56+ importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces)
55− let allTypes = concat (ctors : importedVars)
58+ let allTypes = concat (ctors : importedVars)
56− vars = concatMap (fst . snd) allTypes
59+ vars = concatMap (fst . snd) allTypes
57− header = Map.map snd (Map.fromList allTypes)
60+ header = Map.map snd (Map.fromList allTypes)
58− environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
61+ environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ]
60− fvar <- liftIO $ T.variable T.Flexible
63+ fvar <- liftIO $ T.variable T.Flexible
61− c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)
64+ c <- TcExpr.constrain env (program (body modul)) (T.varN fvar)
62− return (header, environ c)
65+ return (header, environ c)
65−canonicalizeValues :: Env.Environment -> (Module.Name, Interface)
70+ -> (Module.Name, Interface)
66− -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
71+ -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))]
67canonicalizeValues env (moduleName, iface) =
72canonicalizeValues env (moduleName, iface) =
68− forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do
73+ forM (Map.toList (iTypes iface)) $ \(name,tipe) ->
69− tipe' <- Env.instantiateType env tipe Map.empty
74+ do tipe' <- Env.instantiateType env tipe Map.empty
70− return (Module.nameToString moduleName ++ "." ++ name, tipe')
75+ return (Module.nameToString moduleName ++ "." ++ name, tipe')
72canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
78canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
73canonicalizeAdts interfaces modul =
79canonicalizeAdts interfaces modul =