X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcModule.lhs;h=8842be5d8a9eba35b52568c673f65eca016020de;hb=f9159272ae6a3f858a062c2b2d6f4a16a3318e4c;hp=ed05fb93437e57eed8465cf13fe4fcb26a7c9e36;hpb=18b24e64d6a9e3011a2437cec87ef09ad3e6f900;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index ed05fb9..8842be5 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -5,30 +5,32 @@ \begin{code} module TcModule ( - typecheckModule, typecheckIface, typecheckStmt, TcResults(..) + typecheckModule, typecheckIface, typecheckStmt, typecheckExpr, + TcResults(..) ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug ) +import CmdLineOpts ( DynFlag(..), DynFlags, dopt ) import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), - Stmt(..), InPat(..), HsMatchContext(..), + Stmt(..), InPat(..), HsMatchContext(..), RuleDecl(..), isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch ) -import HsTypes ( toHsType ) import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName, returnIOName, bindIOName, failIOName, itName ) import MkId ( unsafeCoerceId ) -import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt ) +import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt, + RenamedHsExpr ) import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, TypecheckedForeignDecl, TypecheckedRuleDecl, zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet, zonkExpr, zonkIdBndr ) - +import MkIface ( pprModDetails ) +import TcExpr ( tcMonoExpr ) import TcMonad import TcType ( newTyVarTy, zonkTcType, tcInstType ) import TcMatches ( tcStmtsAndThen ) @@ -37,39 +39,39 @@ import Inst ( emptyLIE, plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults, defaultDefaultTys ) -import TcEnv ( TcEnv, RecTcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe, +import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe, isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv, tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon, - TcTyThing(..), tcLookupId + TcTyThing(..), tcLookupId ) import TcRules ( tcIfaceRules, tcSourceRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcSimplify ( tcSimplifyTop ) +import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) import CoreUnfold ( unfoldingTemplate, hasUnfolding ) import TysWiredIn ( mkListTy, unitTy ) -import Type ( funResultTy, splitForAllTys, - liftedTypeKind, mkTyConApp, tidyType ) -import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass ) -import Id ( Id, idType, idName, isLocalId, idUnfolding ) +import Type +import ErrUtils ( printErrorsAndWarnings, errorsFound, + dumpIfSet_dyn, dumpIfSet_dyn_or, showPass ) +import Id ( Id, idType, idUnfolding ) import Module ( Module, moduleName ) -import Name ( Name, toRdrName, isGlobalName ) -import Name ( nameEnvElts, lookupNameEnv ) +import Name ( Name ) +import NameEnv ( nameEnvElts, lookupNameEnv ) import TyCon ( tyConGenInfo ) -import Util import BasicTypes ( EP(..), Fixity, RecFlag(..) ) import SrcLoc ( noSrcLoc ) import Outputable +import IO ( stdout ) import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, PackageTypeEnv, ModIface(..), + ModDetails(..), DFunId, TypeEnv, extendTypeEnvList, TyThing(..), implicitTyThingIds, mkTypeEnv ) -import Rules ( ruleBaseIds ) import VarSet \end{code} @@ -81,19 +83,23 @@ import VarSet %************************************************************************ \begin{code} -typecheckStmt :: DynFlags - -> PersistentCompilerState - -> HomeSymbolTable - -> TypeEnv -- The interactive context's type envt - -> PrintUnqualified -- For error printing - -> Module -- Is this really needed - -> [Name] -- Names bound by the Stmt (empty for expressions) - -> (SyntaxMap, - RenamedStmt, -- The stmt itself - [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files - -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, [Id])) - -- The returned [Name] is the same as the input except for - -- ExprStmt, in which case the returned [Name] is [itName] +typecheckStmt + :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> TypeEnv -- The interactive context's type envt + -> PrintUnqualified -- For error printing + -> Module -- Is this really needed + -> [Name] -- Names bound by the Stmt (empty for expressions) + -> (SyntaxMap, + RenamedStmt, -- The stmt itself + [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files + -> IO (Maybe (PersistentCompilerState, + TypecheckedHsExpr, + [Id], + Type)) + -- The returned [Id] is the same as the input except for + -- ExprStmt, in which case the returned [Name] is [itName] typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls) = typecheck dflags syn_map pcs hst unqual $ @@ -120,11 +126,11 @@ typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, i ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_` ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_` - returnTc (new_pcs, zonked_expr, zonked_ids) + returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type") where get_fixity :: Name -> Maybe Fixity - get_fixity n = pprPanic "typecheckExpr" (ppr n) + get_fixity n = pprPanic "typecheckStmt" (ppr n) \end{code} Here is the grand plan, implemented in tcUserStmt @@ -154,13 +160,18 @@ tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id]) tcUserStmt names (ExprStmt expr loc) = ASSERT( null names ) + tcGetUnique `thenNF_Tc` \ uniq -> + let + fresh_it = itName uniq + the_bind = FunMonoBind fresh_it False + [ mkSimpleMatch [] expr Nothing loc ] loc + in tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_` - tc_stmts [itName] [LetStmt (MonoBind the_bind [] NonRecursive), - ExprStmt (HsApp (HsVar printName) (HsVar itName)) loc]) + tc_stmts [fresh_it] [ + LetStmt (MonoBind the_bind [] NonRecursive), + ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) loc]) ( traceTc (text "tcs 1a") `thenNF_Tc_` - tc_stmts [itName] [BindStmt (VarPatIn itName) expr loc]) - where - the_bind = FunMonoBind itName False [mkSimpleMatch [] expr Nothing loc] loc + tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc]) tcUserStmt names stmt = tc_stmts names [stmt] @@ -189,7 +200,7 @@ tc_stmts names stmts -- Look up the names right in the middle, -- where they will all be in scope mapNF_Tc tcLookupId names `thenNF_Tc` \ ids -> - returnTc ((ids, [ExprStmt (mk_return ids) noSrcLoc]), emptyLIE) + returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE) ) `thenTc` \ ((ids, tc_stmts), lie) -> -- Simplify the context right here, so that we fail @@ -211,6 +222,72 @@ tc_stmts names stmts combine stmt (ids, stmts) = (ids, stmt:stmts) \end{code} +%************************************************************************ +%* * +\subsection{Typechecking an expression} +%* * +%************************************************************************ + +\begin{code} +typecheckExpr :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> TypeEnv -- The interactive context's type envt + -> PrintUnqualified -- For error printing + -> Module + -> (SyntaxMap, + RenamedHsExpr, -- The expression itself + [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files + -> IO (Maybe (PersistentCompilerState, + TypecheckedHsExpr, + [Id], -- always empty (matches typecheckStmt) + Type)) + +typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls) + = typecheck dflags syn_map pcs hst unqual $ + + -- use the default default settings, i.e. [Integer, Double] + tcSetDefaultTys defaultDefaultTys $ + + -- Typecheck the extra declarations + fixTc (\ ~(unf_env, _, _, _, _) -> + tcImports unf_env 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 ) + + -- Now typecheck the expression + tcSetEnv env $ + tcExtendGlobalTypeEnv ic_type_env $ + + newTyVarTy openTypeKind `thenTc` \ ty -> + tcMonoExpr expr ty `thenTc` \ (e', lie) -> + tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie + `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) -> + tcSimplifyTop lie_free `thenTc` \ const_binds -> + + let all_expr = mkHsLet const_binds $ + TyLam qtvs $ + DictLam dict_ids $ + mkHsLet dict_binds $ + e' + + all_expr_ty = mkForAllTys qtvs $ + mkFunTys (map idType dict_ids) $ + ty + in + + zonkExpr all_expr `thenNF_Tc` \ zonked_expr -> + zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty -> + ioToTc (dumpIfSet_dyn dflags + Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_` + returnTc (new_pcs, zonked_expr, [], zonked_ty) + + where + get_fixity :: Name -> Maybe Fixity + get_fixity n = pprPanic "typecheckExpr" (ppr n) + + smpl_doc = ptext SLIT("main expression") +\end{code} %************************************************************************ %* * @@ -234,16 +311,17 @@ data TcResults = TcResults { -- All these fields have info *just for this module* tc_env :: TypeEnv, -- The top level TypeEnv + tc_insts :: [DFunId], -- Instances + tc_rules :: [TypecheckedRuleDecl], -- Transformation rules tc_binds :: TypecheckedMonoBinds, -- Bindings - tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. - tc_rules :: [TypecheckedRuleDecl] -- Transformation rules + tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports. } typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $ tcModule pcs hst get_fixity this_mod decls - ; printTcDump dflags maybe_tc_result + ; printTcDump dflags unqual maybe_tc_result ; return maybe_tc_result } where this_mod = mi_module mod_iface @@ -262,7 +340,7 @@ tcModule :: PersistentCompilerState tcModule pcs hst get_fixity this_mod decls = fixTc (\ ~(unf_env, _, _) -> - -- Loop back the final environment, including the fully zonkec + -- Loop back the final environment, including the fully zonked -- versions of bindings from this module. In the presence of mutual -- recursion, interface type signatures may mention variables defined -- in this module, which is why the knot is so big @@ -296,12 +374,24 @@ tcModule pcs hst get_fixity this_mod decls tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) -> tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) -> + -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED + traceTc (text "Tc6") `thenNF_Tc_` + tcCheckMain this_mod `thenTc_` + -- Deal with constant or ambiguous InstIds. How could -- there be ambiguous ones? They can only arise if a -- top-level decl falls under the monomorphism -- restriction, and no subsequent decl instantiates its -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) + -- + -- Note that we must do this *after* tcCheckMain, because of the + -- following bizarre case: + -- main = return () + -- Here, we infer main :: forall a. m a, where m is a free + -- type variable. tcCheckMain will unify it with IO, and that + -- must happen before tcSimplifyTop, since the latter will report + -- m as ambiguous let lie_alldecls = lie_valdecls `plusLIE` lie_instdecls `plusLIE` @@ -309,11 +399,7 @@ tcModule pcs hst get_fixity this_mod decls lie_fodecls `plusLIE` lie_rules in - traceTc (text "Tc6") `thenNF_Tc_` - tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> - - -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED - tcCheckMain this_mod `thenTc_` + tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. @@ -355,6 +441,7 @@ tcModule pcs hst get_fixity this_mod decls returnTc (final_env, new_pcs, TcResults { tc_env = local_type_env, + tc_insts = map iDFunId local_insts, tc_binds = implicit_binds `AndMonoBinds` all_binds', tc_fords = foi_decls ++ foe_decls', tc_rules = all_local_rules @@ -382,12 +469,9 @@ typecheckIface -> HomeSymbolTable -> ModIface -- Iface for this module (just module & fixities) -> (SyntaxMap, [RenamedHsDecl]) - -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl])) + -> IO (Maybe (PersistentCompilerState, ModDetails)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module). - -- The TcResults returned contains only the environment - -- and rules. - typecheckIface dflags pcs hst mod_iface (syn_map, decls) = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $ @@ -408,15 +492,15 @@ typecheckIface dflags pcs hst mod_iface (syn_map, decls) deriv_binds, local_rules) -> ASSERT(nullBinds deriv_binds) let - local_things = filter (isLocalThing this_mod) - (nameEnvElts (getTcGEnv env)) - local_type_env :: TypeEnv - local_type_env = mkTypeEnv local_things - in - - -- throw away local_inst_info - returnTc (new_pcs, local_type_env, local_rules) + local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env)) + mod_details = ModDetails { md_types = mkTypeEnv local_things, + md_insts = map iDFunId local_inst_info, + md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules], + md_binds = [] } + -- All the rules from an interface are of the IfaceRuleOut form + in + returnTc (new_pcs, mod_details) tcImports :: RecTcEnv -> PersistentCompilerState @@ -428,9 +512,9 @@ tcImports :: RecTcEnv RenamedHsBinds, [TypecheckedRuleDecl]) -- tcImports is a slight mis-nomer. --- It deals with everythign that could be an import: +-- It deals with everything that could be an import: -- type and class decls --- interface signatures +-- interface signatures (checked lazily) -- instance decls -- rule decls -- These can occur in source code too, of course @@ -590,49 +674,37 @@ typecheck dflags syn_map pcs hst unqual thing_inside %************************************************************************ \begin{code} -printTcDump dflags Nothing = return () -printTcDump dflags (Just (_, results)) - = do dumpIfSet_dyn dflags Opt_D_dump_types - "Type signatures" (dump_sigs (tc_env results)) - dumpIfSet_dyn dflags Opt_D_dump_tc - "Typechecked" (dump_tc results) +printTcDump dflags unqual Nothing = return () +printTcDump dflags unqual (Just (_, results)) + = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then + printForUser stdout unqual (dump_tc_iface dflags results) + else return () -printIfaceDump dflags Nothing = return () -printIfaceDump dflags (Just (_, env, rules)) - = do dumpIfSet_dyn dflags Opt_D_dump_types - "Type signatures" (dump_sigs env) dumpIfSet_dyn dflags Opt_D_dump_tc - "Typechecked" (dump_iface env rules) + "Typechecked" (ppr (tc_binds results)) -dump_tc results - = vcat [ppr (tc_binds results), - pp_rules (tc_rules results), - ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)] - ] - -dump_iface env rules - = vcat [pp_rules rules, - ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env] - ] - -dump_sigs env -- Print type signatures - = -- Convert to HsType so that we get source-language style printing - -- And sort by RdrName - vcat $ map ppr_sig $ sortLt lt_sig $ - [ (toRdrName id, toHsType (idType id)) - | AnId id <- nameEnvElts env, - want_sig id + +printIfaceDump dflags Nothing = return () +printIfaceDump dflags (Just (_, details)) + = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc] + "Interface" (pprModDetails details) + +dump_tc_iface dflags results + = vcat [pprModDetails (ModDetails {md_types = tc_env results, + md_insts = tc_insts results, + md_rules = [], md_binds = []}) , + ppr_rules (tc_rules results), + + if dopt Opt_Generics dflags then + ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)] + else + empty ] - where - lt_sig (n1,_) (n2,_) = n1 < n2 - ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t - want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocalId id && isGlobalName (idName id) - -- isLocalId ignores data constructors, records selectors etc - -- The isGlobalName ignores local dictionary and method bindings - -- that the type checker has invented. User-defined things have - -- Global names. +ppr_rules [] = empty +ppr_rules rs = vcat [ptext SLIT("{-# RULES"), + nest 4 (vcat (map ppr rs)), + ptext SLIT("#-}")] ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"), vcat (map ppr_gen_tycon tcs), @@ -654,8 +726,4 @@ ppr_ep (EP from to) where (_,from_tau) = splitForAllTys (idType from) -pp_rules [] = empty -pp_rules rs = vcat [ptext SLIT("{-# RULES"), - nest 4 (vcat (map ppr rs)), - ptext SLIT("#-}")] \end{code}