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