-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
might_fail_pat (LazyPat _) = False -- Always succeeds
-might_fail_pat _ = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat
+might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat, TypePat
--------------
might_fail_lpat :: LPat Id -> Bool
tidy_pat :: Pat Id -> Pat Id
tidy_pat pat@(WildPat _) = pat
tidy_pat (VarPat id) = WildPat (idType id)
-tidy_pat (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings
tidy_pat (ParPat p) = tidy_pat (unLoc p)
tidy_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaustiveness checking
-- purposes, a ~pat is like a wildcard
= go pat
where
go (VarPat var) = var : bndrs
- go (VarPatOut var bs) = var : collectEvBinders bs
- ++ bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collectl pat bndrs
go (BangPat pat) = collectl pat bndrs
tidy1 v (VarPat var)
= return (wrapBind var v, WildPat (idType var))
-tidy1 v (VarPatOut var binds)
- = do { ds_ev_binds <- dsTcEvBinds binds
- ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds,
- WildPat (idType var)) }
-
-- case v of { x@p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
tidy1 v (AsPat (L _ var) pat)
tidy1 v (BangPat (L _ (LazyPat p))) = tidy1 v (BangPat p)
tidy1 v (BangPat (L _ (ParPat p))) = tidy1 v (BangPat p)
tidy1 _ p@(BangPat (L _(VarPat _))) = return (idDsWrapper, p)
-tidy1 _ p@(BangPat (L _(VarPatOut _ _))) = return (idDsWrapper, p)
tidy1 _ p@(BangPat (L _ (WildPat _))) = return (idDsWrapper, p)
tidy1 _ p@(BangPat (L _ (CoPat _ _ _))) = return (idDsWrapper, p)
tidy1 _ p@(BangPat (L _ (SigPatIn _ _))) = return (idDsWrapper, p)
-- support hsPatType :: Pat Id -> Type
| VarPat id -- Variable
- | VarPatOut id TcEvBinds -- Used only for overloaded Ids; the
- -- bindings give its overloaded instances
| LazyPat (LPat id) -- Lazy pattern
| AsPat (Located id) (LPat id) -- As pattern
| ParPat (LPat id) -- Parenthesised pattern
pprPat :: (OutputableBndr name) => Pat name -> SDoc
pprPat (VarPat var) = pprPatBndr var
-pprPat (VarPatOut var bs) = pprPatBndr var <+> braces (ppr bs)
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
pprPat (BangPat pat) = char '!' <> pprParendLPat pat
go1 (WildPat {}) = True
go1 (VarPat {}) = True
- go1 (VarPatOut {}) = True
go1 (LazyPat {}) = True
go1 (BangPat pat) = go pat
go1 (CoPat _ pat _) = go1 pat
hsPatNeedsParens :: Pat a -> Bool
hsPatNeedsParens (WildPat {}) = False
hsPatNeedsParens (VarPat {}) = False
-hsPatNeedsParens (VarPatOut {}) = True
hsPatNeedsParens (LazyPat {}) = False
hsPatNeedsParens (BangPat {}) = False
hsPatNeedsParens (CoPat {}) = True
= go pat
where
go (VarPat var) = var : bndrs
- go (VarPatOut var _) = var : bndrs
- -- See Note [Dictionary binders in ConPatOut]
go (WildPat _) = bndrs
go (LazyPat pat) = collect_lpat pat bndrs
go (BangPat pat) = collect_lpat pat bndrs
hsPatType (ParPat pat) = hsLPatType pat
hsPatType (WildPat ty) = ty
hsPatType (VarPat var) = idType var
-hsPatType (VarPatOut var _) = idType var
hsPatType (BangPat pat) = hsLPatType pat
hsPatType (LazyPat pat) = hsLPatType pat
hsPatType (LitPat lit) = hsLitType lit
= do { v' <- zonkIdBndr env v
; return (extendZonkEnv1 env v', VarPat v') }
-zonk_pat env (VarPatOut v binds)
- = do { v' <- zonkIdBndr env v
- ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds
- ; returnM (env', VarPatOut v' binds') }
-
zonk_pat env (LazyPat pat)
= do { (env', pat') <- zonkPat env pat
; return (env', LazyPat pat') }
; res <- tcExtendIdEnv1 name id thing_inside
; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) }
-{- Need this if we re-add Method constraints
- ; (res, binds) <- bindInstsOfPatId id $
- tcExtendIdEnv1 name id $
- (traceTc (text "binding" <+> ppr name <+> ppr (idType id))
- >> thing_inside)
- ; let pat' | isEmptyTcEvBinds binds = VarPat id
- | otherwise = VarPatOut id binds
- ; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
--}
-
tc_pat penv (ParPat pat) pat_ty thing_inside
= do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
; return (ParPat pat', res) }
; res <- tcExtendIdEnv1 name bndr_id thing_inside
; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
-tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut, VarPatOut
+tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut
----------------
unifyPatType :: TcType -> TcType -> TcM CoercionI