X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcPat.lhs;h=e1155b0b2aabd0172e7a8c18552a6d5f849cd41a;hb=2c8f04b5b883db74f449dfc8c224929fe28b027d;hp=bb9f71e23f58146b04cefecf890167f33fdbacdf;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index bb9f71e..e1155b0 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -4,46 +4,42 @@ \section[TcPat]{Typechecking patterns} \begin{code} -#include "HsVersions.h" - module TcPat ( tcPat ) where -import Ubiq{-uitous-} +#include "HsVersions.h" -import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), - Match, HsBinds, Qual, PolyType, - ArithSeqInfo, Stmt, Fake ) -import RnHsSyn ( RenamedPat(..) ) -import TcHsSyn ( TcPat(..), TcIdOcc(..) ) +import HsSyn ( InPat(..), OutPat(..), HsLit(..), HsExpr(..) ) +import RnHsSyn ( RenamedPat ) +import TcHsSyn ( TcPat ) -import TcMonad hiding ( rnMtoTcM ) +import TcMonad import Inst ( Inst, OverloadedLit(..), InstOrigin(..), - emptyLIE, plusLIE, plusLIEs, LIE(..), + emptyLIE, plusLIE, plusLIEs, LIE, newMethod, newOverloadedLit ) -import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcLookupLocalValueOK ) -import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId ) +import Name ( Name {- instance Outputable -} ) +import TcEnv ( TcIdOcc(..), tcLookupGlobalValue, tcLookupGlobalValueByKey, + tcLookupLocalValueOK, tcInstId + ) +import TcType ( TcType, TcMaybe, newTyVarTy, newTyVarTys ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) +import Maybes ( maybeToBool ) import Bag ( Bag ) import CmdLineOpts ( opt_IrrefutableTuples ) -import Id ( GenId, idType ) +import Id ( GenId, idType, Id ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -import Maybes ( maybeToBool ) -import PprType ( GenType, GenTyVar ) -import PrelInfo ( charPrimTy, intPrimTy, floatPrimTy, - doublePrimTy, charTy, stringTy, mkListTy, - mkTupleTy, addrTy, addrPrimTy ) -import Pretty -import RnHsSyn ( RnName{-instance Outputable-} ) -import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys, - getFunTy_maybe, maybeAppDataTyCon, - Type(..), GenType +import Type ( splitFunTys, splitRhoTy, + splitFunTy_maybe, splitAlgTyConApp_maybe, + Type ) -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 ) +import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) +import Util ( assertPanic, panic ) +import Outputable \end{code} \begin{code} @@ -58,7 +54,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) @@ -171,7 +167,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) -> @@ -197,10 +193,10 @@ tcPat pat_in@(RecPatIn name rpats) -- Ignore the con_theta; overloaded constructors only -- behave differently when called, not when used for -- matching. - (_, record_ty) = splitFunTy con_tau + (_, record_ty) = splitFunTys con_tau in -- Con is syntactically constrained to be a data constructor - ASSERT( maybeToBool (maybeAppDataTyCon record_ty) ) + ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty) ) mapAndUnzipTc (do_bind record_ty) rpats `thenTc` \ (rpats', lies) -> @@ -215,10 +211,10 @@ tcPat pat_in@(RecPatIn name rpats) -- Record selectors all have type -- forall a1..an. T a1 .. an -> tau - ASSERT( maybeToBool (getFunTy_maybe tau) ) + ASSERT( maybeToBool (splitFunTy_maybe tau) ) let -- Selector must have type RecordType -> FieldType - Just (record_ty, field_ty) = getFunTy_maybe tau + Just (record_ty, field_ty) = splitFunTy_maybe tau in tcAddErrCtxt (recordLabel field_label) ( unifyTauTy expected_record_ty record_ty @@ -271,13 +267,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 @@ -286,13 +282,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 @@ -300,6 +296,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} %************************************************************************ @@ -324,7 +344,7 @@ tcPats (pat:pats) unifies the actual args against the expected ones. \begin{code} -matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s) +matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s) matchConArgTys con arg_tys = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> @@ -333,14 +353,14 @@ matchConArgTys con arg_tys -- behave differently when called, not when used for -- matching. let - (con_args, con_result) = splitFunTy con_tau + (con_args, con_result) = splitFunTys 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_` + unifyTauTyLists con_args arg_tys `thenTc_` returnTc (con_id, con_result) \end{code} @@ -350,13 +370,14 @@ matchConArgTys con arg_tys Errors and contexts ~~~~~~~~~~~~~~~~~~~ \begin{code} -patCtxt pat sty = ppHang (ppStr "In the pattern:") 4 (ppr sty pat) +patCtxt pat = hang (ptext SLIT("In the pattern:")) + 4 (ppr pat) -recordLabel field_label sty - = ppHang (ppBesides [ppStr "When matching record field", ppr sty field_label]) - 4 (ppBesides [ppStr "with its immediately enclosing constructor"]) +recordLabel field_label + = hang (hcat [ptext SLIT("When matching record field"), ppr 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]) +recordRhs field_label pat + = hang (ptext SLIT("In the record field pattern")) + 4 (sep [ppr field_label, char '=', ppr pat]) \end{code}