X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=b5ddb0cee98b1bacc1140f076d90a7fda4791c10;hb=ab8b931625e6594506dfc894cfdb521a96ad4fa1;hp=dfd92d11060486ff05e6879393aacddd0de049b4;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index dfd92d1..b5ddb0c 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -8,42 +8,48 @@ module TcPat ( tcPat ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, Qual, PolyType, - ArithSeqInfo, Stmt, Fake ) -import RnHsSyn ( RenamedPat(..) ) -import TcHsSyn ( TcPat(..), TcIdOcc(..) ) + Match, HsBinds, HsType, Fixity, + ArithSeqInfo, Stmt, DoOrListComp, Fake ) +import RnHsSyn ( SYN_IE(RenamedPat) ) +import TcHsSyn ( SYN_IE(TcPat) ) import TcMonad import Inst ( Inst, OverloadedLit(..), InstOrigin(..), - emptyLIE, plusLIE, plusLIEs, LIE(..), + emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE), newMethod, newOverloadedLit ) +import Name ( Name {- instance Outputable -} ) import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcLookupLocalValueOK, tcGlobalOcc ) -import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys ) + tcLookupLocalValueOK ) +import SpecEnv ( SpecEnv ) +import TcType ( TcIdOcc(..), SYN_IE(TcType), TcMaybe, newTyVarTy, newTyVarTys, tcInstId ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) -import Id ( GenId, idType ) +import Id ( GenId, idType, SYN_IE(Id) ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) import Maybes ( maybeToBool ) -import Name ( Name ) import PprType ( GenType, GenTyVar ) -import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, charTy, stringTy, mkListTy, - mkTupleTy, addrTy, addrPrimTy ) import Pretty import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys, getFunTy_maybe, maybeAppDataTyCon, - Type(..), GenType + SYN_IE(Type), GenType ) import TyVar ( GenTyVar ) -import Unique ( Unique, eqClassOpKey ) -import Util ( assertPanic, panic{-ToDo:rm-} ) +import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, + doublePrimTy, addrPrimTy + ) +import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, addrTy ) +import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) +import Util ( assertPanic, panic ) + +#if __GLASGOW_HASKELL__ >= 202 +import Outputable +#endif \end{code} \begin{code} @@ -58,7 +64,7 @@ tcPat :: RenamedPat -> TcM s (TcPat s, LIE s, TcType s) \begin{code} tcPat (VarPatIn name) - = tcLookupLocalValueOK "tcPat1" name `thenNF_Tc` \ id -> + = tcLookupLocalValueOK "tcPat1:" name `thenNF_Tc` \ id -> returnTc (VarPat (TcId id), emptyLIE, idType id) tcPat (LazyPatIn pat) @@ -72,9 +78,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} %************************************************************************ @@ -161,7 +177,7 @@ tcPat pat_in@(ConPatIn name pats) lie, data_ty) -tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... +tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form... = tcPat pat1 `thenTc` \ (pat1', lie1, ty1) -> tcPat pat2 `thenTc` \ (pat2', lie2, ty2) -> @@ -181,26 +197,27 @@ tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... \begin{code} tcPat pat_in@(RecPatIn name rpats) - = tcGlobalOcc name `thenNF_Tc` \ (con_id, _, con_rho) -> + = tcLookupGlobalValue name `thenNF_Tc` \ con_id -> + tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> let - (_, con_tau) = splitRhoTy con_rho -- 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 ) ) + ASSERT( maybeToBool (maybeAppDataTyCon record_ty) ) mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) -> - returnTc (panic "tcPat:RecPatIn:avoid type errors"{-RecPat con_id record_ty rpats', + returnTc (RecPat con_id record_ty rpats', plusLIEs lies, - record_ty-}) + record_ty) where do_bind expected_record_ty (field_label, rhs_pat, pun_flag) - = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) -> + = 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 @@ -260,13 +277,13 @@ tcPat (LitPatIn lit@(HsDoublePrim _)) tcPat (LitPatIn lit@(HsInt i)) = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty -> newOverloadedLit origin - (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) -> + (OverloadedIntegral i) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) -> returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id) - (HsVar over_lit_id)), + over_lit_expr), lie1 `plusLIE` lie2, tyvar_ty) where @@ -275,13 +292,13 @@ tcPat (LitPatIn lit@(HsInt i)) tcPat (LitPatIn lit@(HsFrac f)) = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ tyvar_ty -> newOverloadedLit origin - (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (lie1, over_lit_id) -> + (OverloadedFractional f) tyvar_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> tcLookupGlobalValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> newMethod origin (RealId eq_sel_id) [tyvar_ty] `thenNF_Tc` \ (lie2, eq_id) -> returnTc (NPat lit tyvar_ty (HsApp (HsVar eq_id) - (HsVar over_lit_id)), + over_lit_expr), lie1 `plusLIE` lie2, tyvar_ty) where @@ -289,6 +306,30 @@ tcPat (LitPatIn lit@(HsFrac f)) tcPat (LitPatIn lit@(HsLitLit s)) = error "tcPat: can't handle ``literal-literal'' patterns" + +tcPat (NPlusKPatIn name lit@(HsInt i)) + = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local -> + let + local_ty = idType local + in + tcLookupGlobalValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id -> + tcLookupGlobalValueByKey minusClassOpKey `thenNF_Tc` \ minus_sel_id -> + + newOverloadedLit origin + (OverloadedIntegral i) local_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> + + newMethod origin (RealId ge_sel_id) [local_ty] `thenNF_Tc` \ (lie2, ge_id) -> + newMethod origin (RealId minus_sel_id) [local_ty] `thenNF_Tc` \ (lie3, minus_id) -> + + returnTc (NPlusKPat (TcId local) lit local_ty + (SectionR (HsVar ge_id) over_lit_expr) + (SectionR (HsVar minus_id) over_lit_expr), + lie1 `plusLIE` lie2 `plusLIE` lie3, + local_ty) + where + origin = LiteralOrigin lit -- Not very good! + +tcPat (NPlusKPatIn pat other) = panic "TcPat:NPlusKPat: not an HsInt literal" \end{code} %************************************************************************ @@ -316,13 +357,12 @@ unifies the actual args against the expected ones. matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s) matchConArgTys con arg_tys - = tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) -> - let - (con_theta, con_tau) = splitRhoTy con_rho + = 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 @@ -330,7 +370,7 @@ matchConArgTys con arg_tys checkTc (con_arity == no_of_args) (arityErr "Constructor" con_id con_arity no_of_args) `thenTc_` - unifyTauTyLists arg_tys con_args `thenTc_` + unifyTauTyLists con_args arg_tys `thenTc_` returnTc (con_id, con_result) \end{code} @@ -340,13 +380,13 @@ matchConArgTys con arg_tys Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat) +patCtxt pat sty = hang (ptext SLIT("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"]) + = hang (hcat [ptext SLIT("When matching record field"), ppr sty field_label]) + 4 (hcat [ptext SLIT("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]) + = hang (ptext SLIT("In the record field pattern")) + 4 (sep [ppr sty field_label, char '=', ppr sty pat]) \end{code}