import {-# SOURCE #-} TcExpr( tcSyntaxOp )
import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..),
- HsOverLit(..), HsExpr(..), OutPat, ExprCoFn(..),
- mkCoPat, idCoercion,
+ HsOverLit(..), HsExpr(..), HsWrapper(..),
+ mkCoPat,
LHsBinds, emptyLHsBinds, isEmptyLHsBinds,
collectPatsBinders, nlHsLit )
import TcHsSyn ( TcId, hsLitType )
newDictBndrs, instToId, instStupidTheta, isHsVar
)
import Id ( Id, idType, mkLocalId )
+import Var ( CoVar, tyVarKind )
import CoreFVs ( idFreeTyVars )
import Name ( Name, mkSystemVarName )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
tcLookupClass, tcLookupDataCon, refineEnvironment,
tcLookupField, tcMetaTy )
import TcMType ( newFlexiTyVarTy, arityErr, tcInstSkolTyVars,
- newCoVars, zonkTcType, tcInstTyVars )
+ newCoVars, zonkTcType, tcInstTyVars, newBoxyTyVar )
import TcType ( TcType, TcTyVar, TcSigmaType, TcRhoType, BoxyType,
SkolemInfo(PatSkol),
BoxySigmaType, BoxyRhoType, argTypeKind, typeKind,
pprSkolTvBinding, isRigidTy, tcTyVarsOfTypes,
- zipTopTvSubst, isArgTypeKind, isUnboxedTupleType,
+ zipTopTvSubst, isSubArgTypeKind, isUnboxedTupleType,
mkTyVarTys, mkClassPred, isOverloadedTy, substEqSpec,
- mkFunTy, mkFunTys, tidyOpenType, tidyOpenTypes )
+ mkFunTy, mkFunTys, tidyOpenType, tidyOpenTypes,
+ mkTyVarTy )
import VarSet ( elemVarSet )
import {- Kind parts of -}
Type ( liftedTypeKind )
checkSigTyVarsWrt, unifyType )
import TcHsType ( UserTypeCtxt(..), tcPatSig )
import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
+import TcGadt ( Refinement, emptyRefinement, gadtRefine, refineType )
import Type ( Type, mkTyConApp, substTys, substTheta )
import StaticFlags ( opt_IrrefutableTuples )
import TyCon ( TyCon, FieldLabel, tyConFamInst_maybe,
- tyConFamilyCoercion_maybe, tyConTyVars, isNewTyCon )
+ tyConFamilyCoercion_maybe, tyConTyVars )
import DataCon ( DataCon, dataConTyCon, dataConFullSig, dataConName,
dataConFieldLabels, dataConSourceArity,
dataConStupidTheta, dataConUnivTyVars )
-- 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
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
; 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 $
-- 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) }
\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}