%
+% (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,
#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}
-- 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') }
-------------------
-- 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
tc_lpat (L span pat) pat_ty pstate thing_inside
= setSrcSpan span $
maybeAddErrCtxt (patCtxt pat) $
- do { let (coercion, pat_ty') = refineType (pat_reft pstate) pat_ty
+ do { let mb_reft = refineType (pat_reft pstate) pat_ty
+ pat_ty' = case mb_reft of { Just (_, ty') -> ty'; Nothing -> pat_ty }
+
-- Make sure the result type reflects the current refinement
-- We must do this here, so that it correctly ``sees'' all
-- the refinements to the left. Example:
-- pattern had better see it.
; (pat', tvs, res) <- tc_pat pstate pat pat_ty' thing_inside
- ; return (mkCoPat coercion (L span pat') pat_ty, tvs, res) }
+ ; let final_pat = case mb_reft of
+ Nothing -> pat'
+ Just (co,_) -> CoPat (WpCo co) pat' pat_ty
+ ; return (L span final_pat, tvs, res) }
--------------------
tc_pat :: PatState
-> HsConDetails Name (LPat Name) -> (PatState -> TcM a)
-> TcM (Pat TcId, [TcTyVar], a)
tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
- = do { span <- getSrcSpanM -- Span for the whole pattern
- ; let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
- skol_info = PatSkol data_con span
+ = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
+ skol_info = PatSkol data_con
origin = SigOrigin skol_info
-- Instantiate the constructor type variables [a->ty]
; ctxt_res_tys <- boxySplitTyConAppWithFamily tycon pat_ty
- ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
+ ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad,
+ -- not from ex_tvs
; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
(ctxt_res_tys ++ mkTyVarTys ex_tvs')
eq_spec' = substEqSpec tenv eq_spec
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
; loc <- getInstLoc origin
; dicts <- newDictBndrs loc theta'
- ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req
+ ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate')
+ ex_tvs' dicts lie_req
- ; addDataConStupidTheta origin data_con ctxt_res_tys
+ ; addDataConStupidTheta data_con ctxt_res_tys
; return
(unwrapFamInstScrutinee tycon ctxt_res_tys $
ex_tvs' ++ inner_tvs, res)
}
where
- doc = ptext SLIT("existential context for") <+> quotes (ppr data_con)
-
-- Split against the family tycon if the pattern constructor belongs to a
-- representation tycon.
--
boxySplitTyConAppWithFamily tycon pat_ty =
+ traceTc traceMsg >>
case tyConFamInst_maybe tycon of
Nothing -> boxySplitTyConApp tycon pat_ty
Just (fam_tycon, instTys) ->
; 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.
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
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
\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
-- 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}
; res_tau <- zapToMonotype res_ty
; new_uniq <- newUnique
; let lit_nm = mkSystemVarName new_uniq FSLIT("lit")
- lit_inst = LitInst lit_nm lit res_tau loc
+ lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit,
+ tci_ty = res_tau, tci_loc = loc}
; extendLIE lit_inst
; return (HsVar (instToId lit_inst)) }
\end{code}