= return () -- Short cut for case when there are no existentials
tcCheckExistentialPat pats ex_tvs pat_tys body_ty
- = addErrCtxtM (sigPatCtxt (collectPatsBinders pats) ex_tvs pat_tys body_ty) $
+ = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty) $
checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
data PatState = PS {
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
--
-- Nor should a lazy pattern bind any existential type variables
-- because they won't be in scope when we do the desugaring
+--
+-- Note [Hopping the LIE in lazy patterns]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- In a lazy pattern, we must *not* discharge constraints from the RHS
+-- from dictionaries bound in the pattern. E.g.
+-- f ~(C x) = 3
+-- We can't discharge the Num constraint from dictionaries bound by
+-- the pattern C!
+--
+-- So we have to make the constraints from thing_inside "hop around"
+-- the pattern. Hence the getLLE and extendLIEs later.
+
tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
- = do { (pat', pat_tvs, res) <- tc_lpat pat pat_ty pstate $ \ _ ->
- thing_inside pstate
- -- Ignore refined pstate',
- -- revert to pstate
+ = do { (pat', pat_tvs, (res,lie))
+ <- tc_lpat pat pat_ty pstate $ \ _ ->
+ getLIE (thing_inside pstate)
+ -- Ignore refined pstate', revert to pstate
+ ; extendLIEs lie
+ -- getLIE/extendLIEs: see Note [Hopping the LIE in lazy patterns]
+
-- Check no existentials
; if (null pat_tvs) then return ()
else lazyPatErr lpat pat_tvs
-> 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')
+ (ctxt_res_tys ++ mkTyVarTys ex_tvs')
eq_spec' = substEqSpec tenv eq_spec
theta' = substTheta tenv theta
arg_tys' = substTys tenv arg_tys
; 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 data_con 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.
--
= 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
; 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}
text "In the binding group for"])
4 (ppr pat)
-sigPatCtxt bound_ids bound_tvs pat_tys body_ty tidy_env
+sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
= do { pat_tys' <- mapM zonkTcType pat_tys
; body_ty' <- zonkTcType body_ty
; let (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
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
projects / ghc-hetmet.git / blobdiff