X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=da3bb707063fcf985f3b456827e1a0c99bb6ae57;hb=74a395c2cd036a82a17b3a6f3d33477ebadb66c2;hp=a9a89e416218b2d2b754d9feed2b4632900a8584;hpb=bca9dd54c2b39638cb4638aaccf6015a104a1df5;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index a9a89e4..da3bb70 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -21,15 +21,17 @@ module TcHsSyn ( TypecheckedMatch, TypecheckedHsModule, TypecheckedGRHSs, TypecheckedGRHS, TypecheckedRecordBinds, TypecheckedDictBinds, + TypecheckedMatchContext, mkHsTyApp, mkHsDictApp, mkHsConApp, mkHsTyLam, mkHsDictLam, mkHsLet, - idsToMonoBinds, + + collectTypedPatBinders, outPatType, -- re-exported from TcEnv - TcId, tcInstId, + TcId, - zonkTopBinds, zonkId, zonkIdOcc, + zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr, zonkForeignExports, zonkRules ) where @@ -39,19 +41,16 @@ module TcHsSyn ( import HsSyn -- oodles of it -- others: -import Id ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id ) +import Id ( idName, idType, setIdType, Id ) import DataCon ( dataConWrapId ) -import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, - TcEnv, TcId, tcInstId - ) +import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId ) import TcMonad -import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars - ) -import Name ( isLocallyDefined ) -import CoreSyn ( Expr ) -import CoreUnfold( unfoldingTemplate ) -import BasicTypes ( RecFlag(..) ) +import Type ( Type ) +import TcMType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars ) +import TysWiredIn ( mkListTy, mkTupleTy, unitTy ) +import CoreSyn ( Expr ) +import BasicTypes ( RecFlag(..), Boxity(..) ) import Bag import Outputable import HscTypes ( TyThing(..) ) @@ -94,6 +93,7 @@ type TypecheckedHsExpr = HsExpr Id TypecheckedPat type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat type TypecheckedStmt = Stmt Id TypecheckedPat type TypecheckedMatch = Match Id TypecheckedPat +type TypecheckedMatchContext = HsMatchContext Id type TypecheckedGRHSs = GRHSs Id TypecheckedPat type TypecheckedGRHS = GRHS Id TypecheckedPat type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat @@ -119,14 +119,62 @@ mkHsLet EmptyMonoBinds expr = expr mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args +\end{code} + + +%************************************************************************ +%* * +\subsection[mkFailurePair]{Code for pattern-matching and other failures} +%* * +%************************************************************************ -idsToMonoBinds :: [Id] -> TcMonoBinds -idsToMonoBinds ids - = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id)) - | id <- ids - ] +Note: If @outPatType@ doesn't bear a strong resemblance to @exprType@, +then something is wrong. +\begin{code} +outPatType :: TypecheckedPat -> Type + +outPatType (WildPat ty) = ty +outPatType (VarPat var) = idType var +outPatType (LazyPat pat) = outPatType pat +outPatType (AsPat var pat) = idType var +outPatType (ConPat _ ty _ _ _) = ty +outPatType (ListPat ty _) = mkListTy ty +outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats) +outPatType (RecPat _ ty _ _ _) = ty +outPatType (LitPat lit ty) = ty +outPatType (NPat lit ty _) = ty +outPatType (NPlusKPat _ _ ty _ _) = ty +outPatType (DictPat ds ms) = case (length ds_ms) of + 0 -> unitTy + 1 -> idType (head ds_ms) + n -> mkTupleTy Boxed n (map idType ds_ms) + where + ds_ms = ds ++ ms \end{code} + +Nota bene: @DsBinds@ relies on the fact that at least for simple +tuple patterns @collectTypedPatBinders@ returns the binders in +the same order as they appear in the tuple. + +@collectTypedBinders@ and @collectedTypedPatBinders@ are the exportees. + +\begin{code} +collectTypedPatBinders :: TypecheckedPat -> [Id] +collectTypedPatBinders (VarPat var) = [var] +collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat +collectTypedPatBinders (AsPat a pat) = a : collectTypedPatBinders pat +collectTypedPatBinders (ConPat _ _ _ _ pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (TuplePat pats _) = concat (map collectTypedPatBinders pats) +collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) + fields) +collectTypedPatBinders (DictPat ds ms) = ds ++ ms +collectTypedPatBinders (NPlusKPat var _ _ _ _) = [var] +collectTypedPatBinders any_other_pat = [ {-no binders-} ] +\end{code} + + %************************************************************************ %* * \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} @@ -165,18 +213,20 @@ zonkIdBndr id zonkIdOcc :: TcId -> NF_TcM Id zonkIdOcc id - | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id - -- The omitIfaceSigForId thing may look wierd but it's quite - -- sensible really. We're avoiding looking up superclass selectors - -- and constructors; zonking them is a no-op anyway, and the - -- superclass selectors aren't in the environment anyway. - = returnNF_Tc id - | otherwise = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' -> + -- We're even look up up superclass selectors and constructors; + -- even though zonking them is a no-op anyway, and the + -- superclass selectors aren't in the environment anyway. + -- But we don't want to call isLocalId to find out whether + -- it's a superclass selector (for example) because that looks + -- at the IdInfo field, which in turn be in a knot because of + -- the big knot in typecheckModule let new_id = case maybe_id' of Just (AnId id') -> id' - other -> pprTrace "zonkIdOcc: " (ppr id) id + other -> id -- WARN( isLocalId id, ppr id ) id + -- Oops: the warning can give a black hole + -- because it looks at the idinfo in returnNF_Tc new_id \end{code} @@ -303,7 +353,7 @@ zonkMatch (Match _ pats _ grhss) zonkGRHSs :: TcGRHSs -> NF_TcM TypecheckedGRHSs -zonkGRHSs (GRHSs grhss binds (Just ty)) +zonkGRHSs (GRHSs grhss binds ty) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> tcSetEnv new_env $ let @@ -313,7 +363,7 @@ zonkGRHSs (GRHSs grhss binds (Just ty)) in mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss -> zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> - returnNF_Tc (GRHSs new_grhss new_binds (Just new_ty)) + returnNF_Tc (GRHSs new_grhss new_binds new_ty) \end{code} %************************************************************************ @@ -414,12 +464,10 @@ zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc) returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id new_ty src_loc) -zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList" - -zonkExpr (ExplicitListOut ty exprs) +zonkExpr (ExplicitList ty exprs) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> - returnNF_Tc (ExplicitListOut new_ty new_exprs) + returnNF_Tc (ExplicitList new_ty new_exprs) zonkExpr (ExplicitTuple exprs boxed) = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs -> @@ -432,12 +480,13 @@ zonkExpr (RecordConOut data_con con_expr rbinds) zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd" -zonkExpr (RecordUpdOut expr ty dicts rbinds) +zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds) = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty -> + zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty -> mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts -> zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> - returnNF_Tc (RecordUpdOut new_expr new_ty new_dicts new_rbinds) + returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds) zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" @@ -519,19 +568,16 @@ zonkStmts (ParStmtOut bndrstmtss : stmts) returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) where (bndrss, stmtss) = unzip bndrstmtss -zonkStmts [ReturnStmt expr] - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc [ReturnStmt new_expr] - -zonkStmts (ExprStmt expr locn : stmts) +zonkStmts (ResultStmt expr locn : stmts) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (ExprStmt new_expr locn : new_stmts) + returnNF_Tc (ResultStmt new_expr locn : new_stmts) -zonkStmts (GuardStmt expr locn : stmts) +zonkStmts (ExprStmt expr ty locn : stmts) = zonkExpr expr `thenNF_Tc` \ new_expr -> + zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (GuardStmt new_expr locn : new_stmts) + returnNF_Tc (ExprStmt new_expr new_ty locn : new_stmts) zonkStmts (LetStmt binds : stmts) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> @@ -661,9 +707,9 @@ zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] zonkForeignExports ls = mapNF_Tc zonkForeignExport ls zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) -zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = +zonkForeignExport (ForeignExport i hs_ty spec src_loc) = zonkIdOcc i `thenNF_Tc` \ i' -> - returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc) + returnNF_Tc (ForeignExport i' undefined spec src_loc) \end{code} \begin{code}