Commit 41ef8f70 authored by Matthew Pickering's avatar Matthew Pickering

Make sure PatSyns only get added once to tcg_patsyns

Summary: Before, `PatSyn`s were getting added twice to `tcg_patsyns` so
when inspecting afterwards there were duplicates in the list.
This makes sure that only they only get added once.

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1597
parent f4f00c0f
......@@ -49,7 +49,6 @@ import NameSet
import NameEnv
import SrcLoc
import Bag
import PatSyn
import ListSetOps
import ErrUtils
import Digraph
......@@ -483,13 +482,12 @@ tc_single :: forall thing.
-> LHsBind Name -> TcM thing
-> TcM (LHsBinds TcId, thing)
tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
= do { (pat_syn, aux_binds, tcg_env) <- tc_pat_syn_decl
; let tything = AConLike (PatSynCon pat_syn)
; thing <- setGblEnv tcg_env $ tcExtendGlobalEnv [tything] thing_inside
= do { (aux_binds, tcg_env) <- tc_pat_syn_decl
; thing <- setGblEnv tcg_env thing_inside
; return (aux_binds, thing)
}
where
tc_pat_syn_decl :: TcM (PatSyn, LHsBinds TcId, TcGblEnv)
tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv)
tc_pat_syn_decl = case sig_fn name of
Nothing -> tcInferPatSynDecl psb
Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
......
......@@ -61,7 +61,7 @@ import Control.Monad (forM)
-}
tcInferPatSynDecl :: PatSynBind Name Name
-> TcM (PatSyn, LHsBinds Id, TcGblEnv)
-> TcM (LHsBinds Id, TcGblEnv)
tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
psb_def = lpat, psb_dir = dir }
= setSrcSpan loc $
......@@ -96,7 +96,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
tcCheckPatSynDecl :: PatSynBind Name Name
-> TcPatSynInfo
-> TcM (PatSyn, LHsBinds Id, TcGblEnv)
-> TcM (LHsBinds Id, TcGblEnv)
tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
psb_def = lpat, psb_dir = dir }
TPSI{ patsig_tau = tau,
......@@ -163,7 +163,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts)
wrapped_args
pat_ty rec_fields }
pat_ty rec_fields }
where
(arg_tys, pat_ty) = tcSplitFunTys tau
......@@ -199,7 +199,7 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name
-> TcType -- ^ Pattern type
-> [Name] -- ^ Selector names
-- ^ Whether fields, empty if not record PatSyn
-> TcM (PatSyn, LHsBinds Id, TcGblEnv)
-> TcM (LHsBinds Id, TcGblEnv)
tc_patsyn_finish lname dir is_infix lpat'
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
......@@ -262,7 +262,7 @@ tc_patsyn_finish lname dir is_infix lpat'
tcRecSelBinds
(ValBindsOut (zip (repeat NonRecursive) selector_binds) sigs)
; return (patSyn, matcher_bind, tcg_env) }
; return (matcher_bind, tcg_env) }
where
zonk_wrapped_arg :: (Var, HsWrapper) -> TcM (Var, HsWrapper)
......
......@@ -4,16 +4,15 @@ import Name ( Name )
import Id ( Id )
import HsSyn ( PatSynBind, LHsBinds )
import TcRnTypes ( TcM, TcPatSynInfo )
import PatSyn ( PatSyn )
import TcRnMonad ( TcGblEnv )
import TcRnMonad ( TcGblEnv)
import Outputable ( Outputable )
tcInferPatSynDecl :: PatSynBind Name Name
-> TcM (PatSyn, LHsBinds Id, TcGblEnv)
-> TcM (LHsBinds Id, TcGblEnv)
tcCheckPatSynDecl :: PatSynBind Name Name
-> TcPatSynInfo
-> TcM (PatSyn, LHsBinds Id, TcGblEnv)
-> TcM (LHsBinds Id, TcGblEnv)
tcPatSynBuilderBind :: PatSynBind Name Name
-> TcM (LHsBinds Id)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment