- :: UniqSupply
- -> RnNameSupply
- -> InterfaceDetails
- -> RenamedHsModule
- -> IO (Maybe TcResults)
-
-typecheckModule us rn_name_supply iface_det mod
- = initTc us initEnv (tcModule rn_name_supply (getIfaceFixities iface_det) mod)
- >>= \ (maybe_result, warns, errs) ->
-
- print_errs warns >>
- print_errs errs >>
-
- -- write the thin-air Id map
- (case maybe_result of
- Just (_, _, _, _, _, _, thin_air_ids) -> setThinAirIds thin_air_ids
- Nothing -> return ()
- ) >>
-
- dumpIfSet opt_D_dump_tc "Typechecked"
- (case maybe_result of
- Just (binds, _, _, _, _, _, _) -> ppr binds
- Nothing -> text "Typecheck failed") >>
-
- return (if isEmptyBag errs then
- maybe_result
- else
- Nothing)
-
-print_errs errs
- | isEmptyBag errs = return ()
- | otherwise = printErrs (pprBagOfErrors errs)
+ :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> ModIface -- Iface for this module
+ -> PrintUnqualified -- For error printing
+ -> [RenamedHsDecl]
+ -> IO (Maybe (PersistentCompilerState, TcResults))
+ -- The new PCS is Augmented with imported information,
+ -- (but not stuff from this module)
+
+
+typecheckModule dflags pcs hst mod_iface unqual decls
+ = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
+ tcModule pcs hst get_fixity this_mod decls
+ ; printTcDump dflags maybe_tc_result
+ ; return maybe_tc_result }
+ where
+ this_mod = mi_module mod_iface
+ fixity_env = mi_fixities mod_iface
+
+ get_fixity :: Name -> Maybe Fixity
+ get_fixity nm = lookupNameEnv fixity_env nm
+
+---------------
+typecheckExpr :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> PrintUnqualified -- For error printing
+ -> Module
+ -> (RenamedHsExpr, -- The expression itself
+ [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
+ -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
+
+typecheckExpr dflags pcs hst unqual this_mod (expr, decls)
+ = typecheck dflags pcs hst unqual $
+
+ -- use the default default settings, i.e. [Integer, Double]
+ tcSetDefaultTys defaultDefaultTys $
+ tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+ ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
+
+ tcSetEnv env $
+ newTyVarTy openTypeKind `thenTc` \ ty ->
+ tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
+ tcSimplifyTop lie `thenTc` \ binds ->
+ let all_expr = mkHsLet binds expr' in
+ zonkExpr all_expr `thenNF_Tc` \ zonked_expr ->
+ zonkTcType ty `thenNF_Tc` \ zonked_ty ->
+ returnTc (new_pcs, zonked_expr, zonked_ty)
+ where
+ get_fixity :: Name -> Maybe Fixity
+ get_fixity n = pprPanic "typecheckExpr" (ppr n)
+
+---------------
+typecheck :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> PrintUnqualified -- For error printing
+ -> TcM r
+ -> IO (Maybe r)
+
+typecheck dflags pcs hst unqual thing_inside
+ = do { showPass dflags "Typechecker";
+ ; env <- initTcEnv hst (pcs_PTE pcs)
+
+ ; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside
+
+ ; printErrorsAndWarnings unqual (errs,warns)
+
+ ; if isEmptyBag errs then
+ return maybe_tc_result
+ else
+ return Nothing
+ }