Note [Nesting]
~~~~~~~~~~~~~~
-tcPat takes a "thing inside" over which the patter scopes. This is partly
+tcPat takes a "thing inside" over which the pattern scopes. This is partly
so that tcPat can extend the environment for the thing_inside, but also
so that constraints arising in the thing_inside can be discharged by the
pattern.
-> 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 { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
+ = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
skol_info = PatSkol data_con
origin = SigOrigin skol_info
; 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')
+ (ctxt_res_tys ++ mkTyVarTys ex_tvs')
eq_spec' = substEqSpec tenv eq_spec
theta' = substTheta tenv theta
arg_tys' = substTys tenv arg_tys
ex_tvs' ++ inner_tvs, res)
}
where
- -- Split against the family tycon if the pattern constructor belongs to a
- -- representation tycon.
- --
+ -- Split against the family tycon if the pattern constructor
+ -- belongs to a family instance tycon.
boxySplitTyConAppWithFamily tycon pat_ty =
traceTc traceMsg >>
case tyConFamInst_maybe tycon of
= do { expr <- newLitInst orig lit res_ty
; return (HsFractional r expr) }
+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)))) }
+
+ | Just expr <- shortCutStringLit s res_ty
+ = return (HsIsString s expr)
+
+ | otherwise
+ = do { expr <- newLitInst orig lit res_ty
+ ; return (HsIsString s expr) }
+
newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
newLitInst orig lit res_ty -- Make a LitInst
= do { loc <- getInstLoc orig
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,
- ppr pats
+ ptext SLIT("The body has type:") <+> ppr tidy_body_ty
]) }
where
bound_ids = collectPatsBinders pats
show_ids = filter is_interesting bound_ids
- is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
+ is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs
ppr_id id ty = ppr id <+> dcolon <+> ppr ty
-- Don't zonk the types so we get the separate, un-unified versions