X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=becc2d6104aa9ac3c62e22eb13a0aec928c245e2;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=52e9f05e9426e46e10d077368ec714dfa3fe5aa9;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 52e9f05..becc2d6 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -8,37 +8,44 @@ module TcPat ( tcPat ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, Qual, PolyType, + Match, HsBinds, Qualifier, PolyType, ArithSeqInfo, Stmt, Fake ) -import RnHsSyn ( RenamedPat(..) ) -import TcHsSyn ( TcPat(..), TcIdOcc(..) ) - -import TcMonad -import Inst ( Inst, OverloadedLit(..), InstOrigin(..), LIE(..), - emptyLIE, plusLIE, newMethod, newOverloadedLit ) +import RnHsSyn ( SYN_IE(RenamedPat), RnName{-instance Outputable-} ) +import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) ) + +import TcMonad hiding ( rnMtoTcM ) +import Inst ( Inst, OverloadedLit(..), InstOrigin(..), + emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE), + newMethod, newOverloadedLit + ) import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupLocalValueOK ) -import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys ) +import SpecEnv ( SpecEnv ) +import TcType ( SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) -import ErrUtils ( arityErr ) import Id ( GenId, idType ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -import Name ( Name ) +import Maybes ( maybeToBool ) import PprType ( GenType, GenTyVar ) -import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, charTy, stringTy, mkListTy, - mkTupleTy, addrTy, addrPrimTy ) +--import PprStyle--ToDo:rm import Pretty -import Type ( Type(..), GenType, splitFunTy, splitSigmaTy ) +import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys, + getFunTy_maybe, maybeAppDataTyCon, + SYN_IE(Type), GenType + ) import TyVar ( GenTyVar ) +import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, + doublePrimTy, addrPrimTy + ) +import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy ) import Unique ( Unique, eqClassOpKey ) - +import Util ( assertPanic, panic ) \end{code} \begin{code} @@ -53,7 +60,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) \begin{code} tcPat (VarPatIn name) - = tcLookupLocalValueOK "tcPat1" name `thenNF_Tc` \ id -> + = tcLookupLocalValueOK ("tcPat1:"{-++ppShow 80 (ppr PprDebug name)-}) name `thenNF_Tc` \ id -> returnTc (VarPat (TcId id), emptyLIE, idType id) tcPat (LazyPatIn pat) @@ -67,9 +74,19 @@ tcPat pat_in@(AsPatIn name pat) unifyTauTy (idType id) ty `thenTc_` returnTc (AsPat (TcId id) pat', lie, ty) -tcPat (WildPatIn) +tcPat WildPatIn = newTyVarTy mkTypeKind `thenNF_Tc` \ tyvar_ty -> returnTc (WildPat tyvar_ty, emptyLIE, tyvar_ty) + +tcPat (NegPatIn pat) + = tcPat (negate_lit pat) + where + negate_lit (LitPatIn (HsInt i)) = LitPatIn (HsInt (-i)) + negate_lit (LitPatIn (HsFrac f)) = LitPatIn (HsFrac (-f)) + negate_lit _ = panic "TcPat:negate_pat" + +tcPat (ParPatIn parend_pat) + = tcPat parend_pat \end{code} %************************************************************************ @@ -147,25 +164,21 @@ efficient? \begin{code} tcPat pat_in@(ConPatIn name pats) - = tcLookupGlobalValue name `thenNF_Tc` \ con_id -> - - tcPats pats `thenTc` \ (pats', lie, tys) -> + = tcPats pats `thenTc` \ (pats', lie, tys) -> tcAddErrCtxt (patCtxt pat_in) $ - matchConArgTys con_id tys `thenTc` \ data_ty -> + matchConArgTys name tys `thenTc` \ (con_id, data_ty) -> returnTc (ConPat con_id data_ty pats', lie, data_ty) -tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... - = tcLookupGlobalValue op `thenNF_Tc` \ con_id -> - - tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> +tcPat pat_in@(ConOpPatIn pat1 op pat2) -- in binary-op form... + = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> tcPat pat2 `thenTc` \ (pat2', lie2, ty2) -> tcAddErrCtxt (patCtxt pat_in) $ - matchConArgTys con_id [ty1,ty2] `thenTc` \ data_ty -> + matchConArgTys op [ty1,ty2] `thenTc` \ (con_id, data_ty) -> returnTc (ConOpPat pat1' con_id pat2' data_ty, lie1 `plusLIE` lie2, @@ -174,6 +187,53 @@ tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... %************************************************************************ %* * +\subsection{Records} +%* * +%************************************************************************ + +\begin{code} +tcPat pat_in@(RecPatIn name rpats) + = tcLookupGlobalValue name `thenNF_Tc` \ con_id -> + tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> + let + -- Ignore the con_theta; overloaded constructors only + -- behave differently when called, not when used for + -- matching. + (_, record_ty) = splitFunTy con_tau + in + -- Con is syntactically constrained to be a data constructor + ASSERT( maybeToBool (maybeAppDataTyCon record_ty) ) + + mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) -> + + returnTc (RecPat con_id record_ty rpats', + plusLIEs lies, + record_ty) + + where + do_bind expected_record_ty (field_label, rhs_pat, pun_flag) + = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id -> + tcInstId sel_id `thenNF_Tc` \ (_, _, tau) -> + + -- Record selectors all have type + -- forall a1..an. T a1 .. an -> tau + ASSERT( maybeToBool (getFunTy_maybe tau) ) + let + -- Selector must have type RecordType -> FieldType + Just (record_ty, field_ty) = getFunTy_maybe tau + in + tcAddErrCtxt (recordLabel field_label) ( + unifyTauTy expected_record_ty record_ty + ) `thenTc_` + tcPat rhs_pat `thenTc` \ (rhs_pat', lie, rhs_ty) -> + tcAddErrCtxt (recordRhs field_label rhs_pat) ( + unifyTauTy field_ty rhs_ty + ) `thenTc_` + returnTc ((sel_id, rhs_pat', pun_flag), lie) +\end{code} + +%************************************************************************ +%* * \subsection{Non-overloaded literals} %* * %************************************************************************ @@ -266,24 +326,24 @@ tcPats (pat:pats) unifies the actual args against the expected ones. \begin{code} -matchConArgTys :: Id -> [TcType s] -> TcM s (TcType s) +matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s) -matchConArgTys con_id arg_tys - = tcInstType [] (idType con_id) `thenNF_Tc` \ con_ty -> - let - no_of_args = length arg_tys - (con_tyvars, con_theta, con_tau) = splitSigmaTy con_ty - -- Ignore the sig_theta; overloaded constructors only +matchConArgTys con arg_tys + = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> + tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> + -- Ignore the con_theta; overloaded constructors only -- behave differently when called, not when used for -- matching. + let (con_args, con_result) = splitFunTy con_tau con_arity = length con_args + no_of_args = length arg_tys in checkTc (con_arity == no_of_args) (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_` - unifyTauTyLists arg_tys con_args `thenTc_` - returnTc con_result + unifyTauTyLists con_args arg_tys `thenTc_` + returnTc (con_id, con_result) \end{code} @@ -293,4 +353,12 @@ Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat) + +recordLabel field_label sty + = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label]) + 4 (ppBesides [ppStr "with its immediately enclosing constructor"]) + +recordRhs field_label pat sty + = ppHang (ppStr "In the record field pattern") + 4 (ppSep [ppr sty field_label, ppStr "=", ppr sty pat]) \end{code}