X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=6cb177ed54044994ed4f878637eb83d368a7a582;hp=f165e2e2e02bd2060f5baa0cc12d441f71c1d94b;hb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;hpb=6791ad226806d7b4e7618c91516e9e20be882813 diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f165e2e..6cb177e 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcPat]{Typechecking patterns} + +TcPat: Typechecking patterns \begin{code} module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit, @@ -10,54 +12,34 @@ module TcPat ( tcLetPat, tcLamPat, tcLamPats, tcOverloadedLit, #include "HsVersions.h" import {-# SOURCE #-} TcExpr( tcSyntaxOp ) -import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), - HsOverLit(..), HsExpr(..), OutPat, ExprCoFn(..), - mkCoPat, idCoercion, - LHsBinds, emptyLHsBinds, isEmptyLHsBinds, - collectPatsBinders, nlHsLit ) -import TcHsSyn ( TcId, hsLitType ) + +import HsSyn +import TcHsSyn import TcRnMonad -import Inst ( InstOrigin(..), shortCutFracLit, shortCutIntLit, - newDictBndrs, instToId, instStupidTheta, isHsVar - ) -import Id ( Id, idType, mkLocalId ) -import CoreFVs ( idFreeTyVars ) -import Name ( Name, mkSystemVarName ) -import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns ) -import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2, - tcLookupClass, tcLookupDataCon, refineEnvironment, - tcLookupField, tcMetaTy ) -import TcMType ( newFlexiTyVarTy, arityErr, tcInstSkolTyVars, - newCoVars, zonkTcType, tcInstTyVars ) -import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, BoxyType, - SkolemInfo(PatSkol), - BoxySigmaType, BoxyRhoType, argTypeKind, typeKind, - pprSkolTvBinding, isRigidTy, tcTyVarsOfTypes, - zipTopTvSubst, isArgTypeKind, isUnboxedTupleType, - mkTyVarTys, mkClassPred, isOverloadedTy, substEqSpec, - mkFunTy, mkFunTys, tidyOpenType, tidyOpenTypes ) -import VarSet ( elemVarSet ) -import {- Kind parts of -} - Type ( liftedTypeKind ) -import TcUnify ( boxySplitTyConApp, boxySplitListTy, unBox, - zapToMonotype, boxyUnify, boxyUnifyList, - checkSigTyVarsWrt, unifyType ) -import TcHsType ( UserTypeCtxt(..), tcPatSig ) -import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) -import Type ( Type, mkTyConApp, substTys, substTheta ) -import StaticFlags ( opt_IrrefutableTuples ) -import TyCon ( TyCon, FieldLabel, tyConFamInst_maybe, - tyConFamilyCoercion_maybe, tyConTyVars ) -import DataCon ( DataCon, dataConTyCon, dataConFullSig, dataConName, - dataConFieldLabels, dataConSourceArity, - dataConStupidTheta, dataConUnivTyVars ) -import PrelNames ( integralClassName, fromIntegerName, integerTyConName, - fromRationalName, rationalTyConName ) -import BasicTypes ( isBoxed ) -import SrcLoc ( Located(..), SrcSpan, noLoc ) -import ErrUtils ( Message ) -import Util ( zipEqual ) -import Maybes ( MaybeErr(..) ) +import Inst +import Id +import Var +import CoreFVs +import Name +import TcSimplify +import TcEnv +import TcMType +import TcType +import VarSet +import TcUnify +import TcHsType +import TysWiredIn +import TcGadt +import Type +import StaticFlags +import TyCon +import DataCon +import PrelNames +import BasicTypes hiding (SuccessFlag(..)) +import SrcLoc +import ErrUtils +import Util +import Maybes import Outputable import FastString \end{code} @@ -187,18 +169,18 @@ tcPatBndr (PS { pat_ctxt = LamPat }) bndr_name pat_ty -- f t = case t of { MkT g -> ... } -- Here, the 'g' must get type (forall a. a->a) from the -- MkT context - ; return (mkLocalId bndr_name pat_ty') } + ; return (Id.mkLocalId bndr_name pat_ty') } tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty | Just mono_ty <- lookup_sig bndr_name = do { mono_name <- newLocalName bndr_name ; boxyUnify mono_ty pat_ty - ; return (mkLocalId mono_name mono_ty) } + ; return (Id.mkLocalId mono_name mono_ty) } | otherwise = do { pat_ty' <- unBoxPatBndrType pat_ty bndr_name ; mono_name <- newLocalName bndr_name - ; return (mkLocalId mono_name pat_ty') } + ; return (Id.mkLocalId mono_name pat_ty') } ------------------- @@ -227,7 +209,7 @@ unBoxArgType ty pp_this -- but they improve error messages, and allocate fewer tyvars ; if isUnboxedTupleType ty' then failWithTc msg - else if isArgTypeKind (typeKind ty') then + else if isSubArgTypeKind (typeKind ty') then return ty' else do -- OpenTypeKind, so constrain it { ty2 <- newFlexiTyVarTy argTypeKind @@ -559,7 +541,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside arg_tys' = substTys tenv arg_tys ; co_vars <- newCoVars eq_spec' -- Make coercion variables - ; pstate' <- refineAlt data_con pstate ex_tvs co_vars pat_ty + ; pstate' <- refineAlt data_con pstate ex_tvs' co_vars pat_ty ; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $ tcConArgs data_con arg_tys' arg_pats pstate' thing_inside @@ -568,7 +550,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; dicts <- newDictBndrs loc theta' ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req - ; addDataConStupidTheta origin data_con ctxt_res_tys + ; addDataConStupidTheta data_con ctxt_res_tys ; return (unwrapFamInstScrutinee tycon ctxt_res_tys $ @@ -586,6 +568,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside -- representation tycon. -- boxySplitTyConAppWithFamily tycon pat_ty = + traceTc traceMsg >> case tyConFamInst_maybe tycon of Nothing -> boxySplitTyConApp tycon pat_ty Just (fam_tycon, instTys) -> @@ -594,6 +577,12 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; boxyUnifyList (substTys subst instTys) scrutinee_arg_tys ; return freshTvs } + where + traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+> + ppr tycon <+> ppr pat_ty + , text " family instance:" <+> + ppr (tyConFamInst_maybe tycon) + ] -- Wraps the pattern (which must be a ConPatOut pattern) in a coercion -- pattern if the tycon is an instance of a family. @@ -601,10 +590,12 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside unwrapFamInstScrutinee :: TyCon -> [Type] -> Pat Id -> Pat Id unwrapFamInstScrutinee tycon args pat | Just co_con <- tyConFamilyCoercion_maybe tycon +-- , not (isNewTyCon tycon) -- newtypes are explicitly unwrapped by + -- the desugarer -- NB: We can use CoPat directly, rather than mkCoPat, as we know the -- coercion is not the identity; mkCoPat is inconvenient as it -- wants a located pattern. - = CoPat (ExprCoFn $ mkTyConApp co_con args) -- co fam ty to repr ty + = CoPat (WpCo $ mkTyConApp co_con args) -- co fam ty to repr ty (pat {pat_ty = mkTyConApp tycon args}) -- representation type pat_ty -- family inst type | otherwise @@ -635,15 +626,19 @@ tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside where con_arity = dataConSourceArity data_con +tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside + = pprPanic "tcConArgs" (ppr data_con) -- InfixCon always has two arguments + tcConArgs data_con arg_tys (RecCon rpats) pstate thing_inside = do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside ; return (RecCon rpats', tvs, res) } where - tc_field :: Checker (Located Name, LPat Name) (Located TcId, LPat TcId) - tc_field (field_lbl, pat) pstate thing_inside + -- doc comments are typechecked to Nothing here + tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId)) + tc_field (HsRecField field_lbl pat _) pstate thing_inside = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside - ; return ((sel_id, pat'), tvs, res) } + ; return (mkRecField sel_id pat', tvs, res) } find_field_ty :: FieldLabel -> TcM (Id, TcType) find_field_ty field_lbl @@ -682,13 +677,16 @@ tcConArg (arg_pat, arg_ty) pstate thing_inside \end{code} \begin{code} -addDataConStupidTheta :: InstOrigin -> DataCon -> [TcType] -> TcM () +addDataConStupidTheta :: DataCon -> [TcType] -> TcM () -- Instantiate the "stupid theta" of the data con, and throw -- the constraints into the constraint set -addDataConStupidTheta origin data_con inst_tys +addDataConStupidTheta data_con inst_tys | null stupid_theta = return () | otherwise = instStupidTheta origin inst_theta where + origin = OccurrenceOf (dataConName data_con) + -- The origin should always report "occurrence of C" + -- even when C occurs in a pattern stupid_theta = dataConStupidTheta data_con tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys inst_theta = substTheta tenv stupid_theta @@ -738,7 +736,10 @@ refineAlt con pstate ex_tvs co_vars pat_ty -- might be inside a lazy pattern. Instead, refine pstate where - trace_msg = text "refineAlt:match" <+> ppr con <+> ppr reft + trace_msg = text "refineAlt:match" <+> + vcat [ ppr con <+> ppr ex_tvs, + ppr [(v, tyVarKind v) | v <- co_vars], + ppr reft] } \end{code}