tc_lam_pats ctxt pat_ty_prs res_ty thing_inside
= do { let init_state = PS { pat_ctxt = ctxt, pat_eqs = False }
- ; (pats', ex_tvs, res) <- tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
- if (pat_eqs pstate' && (not $ isRigidTy res_ty))
- then failWithTc (nonRigidResult res_ty)
- else thing_inside res_ty
+ ; (pats', ex_tvs, res) <- do { traceTc (text "tc_lam_pats" <+> (ppr pat_ty_prs $$ ppr res_ty))
+ ; tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
+ if (pat_eqs pstate' && (not $ isRigidTy res_ty))
+ then nonRigidResult res_ty
+ else thing_inside res_ty }
; let tys = map snd pat_ty_prs
; tcCheckExistentialPat pats' ex_tvs tys res_ty
data PatState = PS {
pat_ctxt :: PatCtxt,
- pat_eqs :: Bool -- <=> there are GADT equational constraints
- -- for refinement
+ pat_eqs :: Bool -- <=> there are any equational constraints
+ -- Used at the end to say whether the result
+ -- type must be rigid
}
data PatCtxt
; return (res, binds) }
-------------------
-unBoxPatBndrType ty name = unBoxArgType ty (ptext SLIT("The variable") <+> quotes (ppr name))
-unBoxWildCardType ty = unBoxArgType ty (ptext SLIT("A wild-card pattern"))
-unBoxViewPatType ty pat = unBoxArgType ty (ptext SLIT("The view pattern") <+> ppr pat)
+unBoxPatBndrType ty name = unBoxArgType ty (ptext (sLit "The variable") <+> quotes (ppr name))
+unBoxWildCardType ty = unBoxArgType ty (ptext (sLit "A wild-card pattern"))
+unBoxViewPatType ty pat = unBoxArgType ty (ptext (sLit "The view pattern") <+> ppr pat)
unBoxArgType :: BoxyType -> SDoc -> TcM TcType
-- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind;
; unifyType ty' ty2
; return ty' }}
where
- msg = pp_this <+> ptext SLIT("cannot be bound to an unboxed tuple")
+ msg = pp_this <+> ptext (sLit "cannot be bound to an unboxed tuple")
\end{code}
else do -- The general case, with existential, and local equality
-- constraints
- { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
- theta' = substTheta tenv (eq_preds ++ full_theta)
- -- order is *important* as we generate the list of
- -- dictionary binders from theta'
- ctxt = pat_ctxt pstate
- ; checkTc (case ctxt of { ProcPat -> False; other -> True })
+ { checkTc (case pat_ctxt pstate of { ProcPat -> False; other -> True })
(existentialProcPat data_con)
-- Need to test for rigidity if *any* constraints in theta as class
-- FIXME: AT THE MOMENT WE CHEAT! We only perform the rigidity test
-- if we explicit or implicit (by a GADT def) have equality
-- constraints.
- ; unless (all (not . isEqPred) theta') $
- checkTc (isRigidTy pat_ty) (nonRigidMatch data_con)
+ ; let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
+ theta' = substTheta tenv (eq_preds ++ full_theta)
+ -- order is *important* as we generate the list of
+ -- dictionary binders from theta'
+ no_equalities = not (any isEqPred theta')
+ pstate' | no_equalities = pstate
+ | otherwise = pstate { pat_eqs = True }
+
+ ; unless no_equalities (checkTc (isRigidTy pat_ty)
+ (nonRigidMatch data_con))
; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
- tcConArgs data_con arg_tys' arg_pats pstate thing_inside
+ tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
; loc <- getInstLoc origin
; dicts <- newDictBndrs loc theta'
-- 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 (WpCo $ mkTyConApp co_con args) -- co fam ty to repr ty
+ = CoPat (WpCast $ mkTyConApp co_con args) -- co fam ty to repr ty
(pat {pat_ty = mkTyConApp tycon args}) -- representation type
pat_ty -- family inst type
| otherwise
-> HsOverLit Name
-> BoxyRhoType
-> TcM (HsOverLit TcId)
-tcOverloadedLit orig lit@(HsIntegral i fi _) res_ty
- | not (fi `isHsVar` fromIntegerName) -- Do not generate a LitInst for rebindable syntax.
+tcOverloadedLit orig lit@(OverLit { ol_val = val, ol_rebindable = rebindable
+ , ol_witness = meth_name }) res_ty
+ | rebindable
+ -- Do not generate a LitInst for rebindable syntax.
-- Reason: If we do, tcSimplify will call lookupInst, which
-- will call tcSyntaxName, which does unification,
-- which tcSimplify doesn't like
-- ToDo: noLoc sadness
- = do { integer_ty <- tcMetaTy integerTyConName
- ; fi' <- tcSyntaxOp orig fi (mkFunTy integer_ty res_ty)
- ; return (HsIntegral i (HsApp (noLoc fi') (nlHsLit (HsInteger i integer_ty))) res_ty) }
-
- | Just expr <- shortCutIntLit i res_ty
- = return (HsIntegral i expr res_ty)
-
- | otherwise
- = do { expr <- newLitInst orig lit res_ty
- ; return (HsIntegral i expr res_ty) }
-
-tcOverloadedLit orig lit@(HsFractional r fr _) res_ty
- | not (fr `isHsVar` fromRationalName) -- c.f. HsIntegral case
- = do { rat_ty <- tcMetaTy rationalTyConName
- ; fr' <- tcSyntaxOp orig fr (mkFunTy rat_ty res_ty)
+ = do { hs_lit <- mkOverLit val
+ ; let lit_ty = hsLitType hs_lit
+ ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
-- Overloaded literals must have liftedTypeKind, because
-- we're instantiating an overloaded function here,
-- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
-- However this'll be picked up by tcSyntaxOp if necessary
- ; return (HsFractional r (HsApp (noLoc fr') (nlHsLit (HsRat r rat_ty))) res_ty) }
-
- | Just expr <- shortCutFracLit r res_ty
- = return (HsFractional r expr res_ty)
+ ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
+ ; return (lit { ol_witness = witness, ol_type = res_ty }) }
- | otherwise
- = do { expr <- newLitInst orig lit res_ty
- ; return (HsFractional r expr res_ty) }
-
-tcOverloadedLit orig lit@(HsIsString s fr _) res_ty
- | not (fr `isHsVar` fromStringName) -- c.f. HsIntegral case
- = do { str_ty <- tcMetaTy stringTyConName
- ; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty)
- ; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s))) res_ty) }
-
- | Just expr <- shortCutStringLit s res_ty
- = return (HsIsString s expr res_ty)
+ | Just expr <- shortCutLit val res_ty
+ = return (lit { ol_witness = expr, ol_type = res_ty })
| otherwise
- = do { expr <- newLitInst orig lit res_ty
- ; return (HsIsString s expr res_ty) }
-
-newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
-newLitInst orig lit res_ty -- Make a LitInst
= do { loc <- getInstLoc orig
; res_tau <- zapToMonotype res_ty
; new_uniq <- newUnique
- ; let lit_nm = mkSystemVarName new_uniq FSLIT("lit")
+ ; let lit_nm = mkSystemVarName new_uniq (fsLit "lit")
lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit,
tci_ty = res_tau, tci_loc = loc}
+ witness = HsVar (instToId lit_inst)
; extendLIE lit_inst
- ; return (HsVar (instToId lit_inst)) }
+ ; return (lit { ol_witness = witness, ol_type = res_ty }) }
\end{code}
patCtxt (VarPat _) = Nothing
patCtxt (ParPat _) = Nothing
patCtxt (AsPat _ _) = Nothing
-patCtxt pat = Just (hang (ptext SLIT("In the pattern:"))
+patCtxt pat = Just (hang (ptext (sLit "In the pattern:"))
4 (ppr pat))
-----------------------------------------------
(env2, tidy_pat_tys) = tidyOpenTypes env1 pat_tys'
(env3, tidy_body_ty) = tidyOpenType env2 body_ty'
; return (env3,
- sep [ptext SLIT("When checking an existential match that binds"),
+ sep [ptext (sLit "When checking an existential match that binds"),
nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
- ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
- ptext SLIT("The body has type:") <+> ppr tidy_body_ty
+ ptext (sLit "The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
+ ptext (sLit "The body has type:") <+> ppr tidy_body_ty
]) }
where
bound_ids = collectPatsBinders pats
badFieldCon :: DataCon -> Name -> SDoc
badFieldCon con field
- = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
- ptext SLIT("does not have field"), quotes (ppr field)]
+ = hsep [ptext (sLit "Constructor") <+> quotes (ppr con),
+ ptext (sLit "does not have field"), quotes (ppr field)]
polyPatSig :: TcType -> SDoc
polyPatSig sig_ty
- = hang (ptext SLIT("Illegal polymorphic type signature in pattern:"))
+ = hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
-badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
+badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
existentialProcPat :: DataCon -> SDoc
existentialProcPat con
- = hang (ptext SLIT("Illegal constructor") <+> quotes (ppr con) <+> ptext SLIT("in a 'proc' pattern"))
- 2 (ptext SLIT("Proc patterns cannot use existentials or GADTs"))
+ = hang (ptext (sLit "Illegal constructor") <+> quotes (ppr con) <+> ptext (sLit "in a 'proc' pattern"))
+ 2 (ptext (sLit "Proc patterns cannot use existentials or GADTs"))
lazyPatErr pat tvs
= failWithTc $
- hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))
+ hang (ptext (sLit "A lazy (~) pattern cannot bind existential type variables"))
2 (vcat (map pprSkolTvBinding tvs))
nonRigidMatch con
- = hang (ptext SLIT("GADT pattern match in non-rigid context for") <+> quotes (ppr con))
- 2 (ptext SLIT("Solution: add a type signature"))
+ = hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))
+ 2 (ptext (sLit "Solution: add a type signature"))
nonRigidResult res_ty
- = hang (ptext SLIT("GADT pattern match with non-rigid result type") <+> quotes (ppr res_ty))
- 2 (ptext SLIT("Solution: add a type signature"))
+ = do { env0 <- tcInitTidyEnv
+ ; let (env1, res_ty') = tidyOpenType env0 res_ty
+ msg = hang (ptext (sLit "GADT pattern match with non-rigid result type")
+ <+> quotes (ppr res_ty'))
+ 2 (ptext (sLit "Solution: add a type signature"))
+ ; failWithTcM (env1, msg) }
inaccessibleAlt msg
- = hang (ptext SLIT("Inaccessible case alternative:")) 2 msg
+ = hang (ptext (sLit "Inaccessible case alternative:")) 2 msg
\end{code}
projects / ghc-hetmet.git / blobdiff