diff options
| author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2022-12-05 22:20:43 +0300 |
|---|---|---|
| committer | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2022-12-05 22:31:30 +0300 |
| commit | c0bd4ddea3d95b99354ff46b58be0eaa52ba5120 (patch) | |
| tree | c744e34c22401a76fd32de1a417af2f1b25013e1 | |
| parent | 18acf993486333c6378c5f732dfc046b761213f4 (diff) | |
| download | haskell-c0bd4ddea3d95b99354ff46b58be0eaa52ba5120.tar.gz | |
VDQ: reject nonlinear type variable bindings
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 20 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Pat.hs | 2 | ||||
| -rw-r--r-- | testsuite/tests/vdq-rta/should_fail/T22326_fail_nonlinear.stderr | 6 |
3 files changed, 26 insertions, 2 deletions
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 4c097d2111..5b9da4a671 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1136,6 +1136,8 @@ data CollectFlag p where CollNoDictBinders :: CollectFlag p -- | Collect evidence binders CollWithDictBinders :: CollectFlag GhcTc + -- | Collect variable and type variable binders + CollVarTyVarBinders :: CollectFlag GhcRn collect_lpat :: forall p. CollectPass p => CollectFlag p @@ -1166,12 +1168,28 @@ collect_pat flag pat bndrs = case pat of SigPat _ pat _ -> collect_lpat flag pat bndrs XPat ext -> collectXXPat @p flag ext bndrs SplicePat ext _ -> collectXSplicePat @p flag ext bndrs - EmbTyPat _ _ _ -> bndrs -- TODO (int-index): do I need to return the type variable binder? + EmbTyPat _ _ ltypat -> case flag of + CollNoDictBinders -> bndrs + CollWithDictBinders -> bndrs + CollVarTyVarBinders -> collect_ltypat (hswc_body ltypat) bndrs -- See Note [Dictionary binders in ConPatOut] ConPat {pat_args=ps} -> case flag of CollNoDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) ++ collectEvBinders (cpt_binds (pat_con_ext pat)) + CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) + +collect_ltypat :: LHsType GhcRn -> [Name] -> [Name] +collect_ltypat ltypat = collect_typat (unLoc ltypat) + +collect_typat :: HsType GhcRn -> [Name] -> [Name] +collect_typat typat bndrs = case typat of + HsTyVar _ _ (L _ name) + | isTyVarName name -> name : bndrs + | otherwise -> bndrs + HsParTy _ t -> collect_ltypat t bndrs + HsWildCardTy _ -> bndrs + _ -> panic "collect_typat: unsupported type pattern" collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs) = foldr add_ev_bndr [] bs diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index ecf5156224..891d39f246 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -425,7 +425,7 @@ rnPats ctxt pats thing_inside -- complain *twice* about duplicates e.g. f (x,x) = ... -- -- See Note [Don't report shadowing for pattern synonyms] - ; let bndrs = collectPatsBinders CollNoDictBinders (toList pats') + ; let bndrs = collectPatsBinders CollVarTyVarBinders (toList pats') ; addErrCtxt doc_pat $ if isPatSynCtxt ctxt then checkDupNames bndrs diff --git a/testsuite/tests/vdq-rta/should_fail/T22326_fail_nonlinear.stderr b/testsuite/tests/vdq-rta/should_fail/T22326_fail_nonlinear.stderr new file mode 100644 index 0000000000..15fffc5ef6 --- /dev/null +++ b/testsuite/tests/vdq-rta/should_fail/T22326_fail_nonlinear.stderr @@ -0,0 +1,6 @@ + +T22326_fail_nonlinear.hs:9:9: error: + • Conflicting definitions for ‘t’ + Bound at: T22326_fail_nonlinear.hs:9:9 + T22326_fail_nonlinear.hs:9:18 + • In an equation for ‘f’ |