Refactor PatSynBind so that we can pass around PSBs instead of several arguments

compiler/hsSyn/HsBinds.lhs

@@ -166,13 +166,7 @@ data HsBindLR idL idR
         abs_binds    :: LHsBinds idL   -- ^ Typechecked user bindings
     }
 
-  | PatSynBind {
-        patsyn_id   :: Located idL,                   -- ^ Name of the pattern synonym
-        bind_fvs    :: NameSet,                       -- ^ See Note [Bind free vars]
-        patsyn_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
-        patsyn_def  :: LPat idR,                      -- ^ Right-hand side
-        patsyn_dir  :: HsPatSynDir idR                -- ^ Directionality
-    }
+  | PatSynBind (PatSynBind idL idR)
 
   deriving (Data, Typeable)
         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
@@ -195,6 +189,14 @@ data ABExport id
         , abe_prags :: TcSpecPrags  -- ^ SPECIALISE pragmas
   } deriving (Data, Typeable)
 
+data PatSynBind idL idR
+  = PSB { psb_id   :: Located idL,                   -- ^ Name of the pattern synonym
+          psb_fvs  :: NameSet,                       -- ^ See Note [Bind free vars]
+          psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
+          psb_def  :: LPat idR,                      -- ^ Right-hand side
+          psb_dir  :: HsPatSynDir idR                -- ^ Directionality
+  } deriving (Data, Typeable)
+
 -- | Used for the NameSet in FunBind and PatBind prior to the renamer
 placeHolderNames :: NameSet
 placeHolderNames = panic "placeHolderNames"
@@ -437,23 +439,7 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
     $$  ifPprDebug (pprBndr LetBind (unLoc fun))
     $$  pprFunBind (unLoc fun) inf matches
     $$  ifPprDebug (ppr wrap)
-ppr_monobind (PatSynBind{ patsyn_id = L _ psyn, patsyn_args = details,
-                          patsyn_def = pat, patsyn_dir = dir })
-  = ppr_lhs <+> ppr_rhs
-      where
-        ppr_lhs = ptext (sLit "pattern") <+> ppr_details
-        ppr_simple syntax = syntax <+> ppr pat
-
-        (is_infix, ppr_details) = case details of
-            InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
-            PrefixPatSyn vs   -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
-
-        ppr_rhs = case dir of
-            Unidirectional           -> ppr_simple (ptext (sLit "<-"))
-            ImplicitBidirectional    -> ppr_simple equals
-            ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
-                                          (nest 2 $ pprFunBind psyn is_infix mg)
-
+ppr_monobind (PatSynBind psb) = ppr psb
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
                        , abs_exports = exports, abs_binds = val_binds
                        , abs_ev_binds = ev_binds })
@@ -470,6 +456,23 @@ instance (OutputableBndr id) => Outputable (ABExport id) where
     = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
            , nest 2 (pprTcSpecPrags prags)
            , nest 2 (ppr wrap)]
+
+instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
+  ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
+      = ppr_lhs <+> ppr_rhs
+    where
+      ppr_lhs = ptext (sLit "pattern") <+> ppr_details
+      ppr_simple syntax = syntax <+> ppr pat
+
+      (is_infix, ppr_details) = case details of
+          InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2])
+          PrefixPatSyn vs   -> (False, hsep (pprPrefixOcc psyn : map ppr vs))
+
+      ppr_rhs = case dir of
+          Unidirectional           -> ppr_simple (ptext (sLit "<-"))
+          ImplicitBidirectional    -> ppr_simple equals
+          ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
+                                      (nest 2 $ pprFunBind psyn is_infix mg)
 \end{code}
 
 

compiler/hsSyn/HsUtils.lhs

@@ -505,11 +505,13 @@ mkVarBind var rhs = L (getLoc rhs) $
 		    VarBind { var_id = var, var_rhs = rhs, var_inline = False }
 
 mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
-mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name
-                                               , patsyn_args = details
-                                               , patsyn_def = lpat
-                                               , patsyn_dir = dir
-                                               , bind_fvs = placeHolderNames }
+mkPatSynBind name details lpat dir = PatSynBind psb
+  where
+    psb = PSB{ psb_id = name
+             , psb_args = details
+             , psb_def = lpat
+             , psb_dir = dir
+             , psb_fvs = placeHolderNames }
 
 ------------
 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
@@ -577,7 +579,7 @@ collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
 	-- I don't think we want the binders from the nested binds
 	-- The only time we collect binders from a typechecked 
 	-- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind (PatSynBind { patsyn_id = L _ ps }) acc = ps : acc
+collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc
 
 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
 collectHsBindsBinders binds = collect_binds binds []

compiler/rename/RnBinds.lhs

@@ -433,12 +433,12 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) })
   = do { newname <- applyNameMaker name_maker name
        ; return (bind { fun_id = L nameLoc newname }) } 
 
-rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) })
+rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) })
   = do { unless (isTopRecNameMaker name_maker) $
            addErr localPatternSynonymErr
        ; addLocM checkConName rdrname
        ; name <- applyNameMaker name_maker rdrname
-       ; return (bind{ patsyn_id = L nameLoc name }) }
+       ; return (PatSynBind psb{ psb_id = L nameLoc name }) }
   where
     localPatternSynonymErr :: SDoc
     localPatternSynonymErr
@@ -515,10 +515,32 @@ rnBind sig_fn bind@(FunBind { fun_id = name
 		  [plain_name], rhs_fvs)
       }
 
-rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name
-                                , patsyn_args = details
-                                , patsyn_def = pat
-                                , patsyn_dir = dir })
+rnBind sig_fn (PatSynBind bind)
+  = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind
+        ; return (PatSynBind bind', name, fvs) }
+
+rnBind _ b = pprPanic "rnBind" (ppr b)
+
+{-
+Note [Free-variable space leak]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have
+    fvs' = trim fvs
+and we seq fvs' before turning it as part of a record.
+
+The reason is that trim is sometimes something like
+    \xs -> intersectNameSet (mkNameSet bound_names) xs
+and we don't want to retain the list bound_names. This showed up in
+trac ticket #1136.
+-}
+
+rnPatSynBind :: (Name -> [Name])		-- Signature tyvar function
+             -> PatSynBind Name RdrName
+             -> RnM (PatSynBind Name Name, [Name], Uses)
+rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name
+                               , psb_args = details
+                               , psb_def = pat
+                               , psb_dir = dir })
        -- invariant: no free vars here when it's a FunBind
   = do	{ pattern_synonym_ok <- xoptM Opt_PatternSynonyms
         ; unless pattern_synonym_ok (addErr patternSynonymErr)
@@ -553,10 +575,10 @@ rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name
 		-- As well as dependency analysis, we need these for the
 		-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
 
-        ; let bind' = bind{ patsyn_args = details'
-                          , patsyn_def = pat'
-                          , patsyn_dir = dir'
-                          , bind_fvs = fvs' }
+        ; let bind' = bind{ psb_args = details'
+                          , psb_def = pat'
+                          , psb_dir = dir'
+                          , psb_fvs = fvs' }
 
         ; fvs' `seq` -- See Note [Free-variable space leak]
           return (bind', [name], fvs1)
@@ -569,20 +591,8 @@ rnBind _sig_fn bind@(PatSynBind { patsyn_id = L _ name
       = hang (ptext (sLit "Illegal pattern synonym declaration"))
            2 (ptext (sLit "Use -XPatternSynonyms to enable this extension"))
 
-
-rnBind _ b = pprPanic "rnBind" (ppr b)
-
 {-
-Note [Free-variable space leak]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have
-    fvs' = trim fvs
-and we seq fvs' before turning it as part of a record.
 
-The reason is that trim is sometimes something like
-    \xs -> intersectNameSet (mkNameSet bound_names) xs
-and we don't want to retain the list bound_names. This showed up in
-trac ticket #1136.
 -}
 
 ---------------------

compiler/typecheck/TcBinds.lhs

@@ -318,27 +318,17 @@ tcValBinds top_lvl binds sigs thing_inside
         ; tcExtendIdEnv2 [(idName id, id) | id <- poly_ids] $ do
             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
                    { thing <- thing_inside
-                   ; patsyn_wrappers <- forM patsyns $ \(name, loc, args, lpat, dir) -> do
-                       { patsyn <- tcLookupPatSyn name
-                       ; case patSynWrapper patsyn of
-                           Nothing -> return emptyBag
-                           Just wrapper_id -> tcPatSynWrapper (L loc wrapper_id) lpat dir args }
+                   ; patsyn_wrappers <- mapM tcPatSynWrapper patsyns
                    ; let extra_binds = [ (NonRecursive, wrapper) | wrapper <- patsyn_wrappers ]
                    ; return (extra_binds, thing) }
              ; return (binds' ++ extra_binds', thing) }}
   where
-    patsyns = [ (name, loc, args, lpat, dir)
-              | (_, lbinds) <- binds
-              , L loc (PatSynBind{ patsyn_id = L _ name, patsyn_args = details, patsyn_def = lpat, patsyn_dir = dir }) <- bagToList lbinds
-              , let args = map unLoc $ case details of
-                        PrefixPatSyn args -> args
-                        InfixPatSyn arg1 arg2 -> [arg1, arg2]
-              ]
+    patsyns
+      = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]
     patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds]
-       = [ (name, placeholder_patsyn_tything)
-         | (name, _, _, _, _) <- patsyns ]
+      = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ]
     placeholder_patsyn_tything
-       = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
+      = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
 
 ------------------------
 tcBindGroups :: TopLevelFlag -> TcSigFun -> PragFun
@@ -427,9 +417,8 @@ tc_single :: forall thing.
             TopLevelFlag -> TcSigFun -> PragFun
           -> LHsBind Name -> TcM thing
           -> TcM (LHsBinds TcId, thing)
-tc_single _top_lvl _sig_fn _prag_fn (L _ ps@PatSynBind{}) thing_inside
-  = do { (pat_syn, aux_binds) <-
-              tcPatSynDecl (patsyn_id ps) (patsyn_args ps) (patsyn_def ps) (patsyn_dir ps)
+tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside
+  = do { (pat_syn, aux_binds) <- tcPatSynDecl psb
 
        ; let tything = AConLike (PatSynCon pat_syn)
              implicit_ids = (patSynMatcher pat_syn) :
@@ -471,7 +460,7 @@ mkEdges sig_fn binds
 bindersOfHsBind :: HsBind Name -> [Name]
 bindersOfHsBind (PatBind { pat_lhs = pat })           = collectPatBinders pat
 bindersOfHsBind (FunBind { fun_id = L _ f })          = [f]
-bindersOfHsBind (PatSynBind { patsyn_id = L _ psyn }) = [psyn]
+bindersOfHsBind (PatSynBind PSB{ psb_id = L _ psyn }) = [psyn]
 bindersOfHsBind (AbsBinds {})                         = panic "bindersOfHsBind AbsBinds"
 bindersOfHsBind (VarBind {})                          = panic "bindersOfHsBind VarBind"
 

compiler/typecheck/TcHsSyn.lhs

@@ -468,18 +468,19 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
                         , abe_mono = zonkIdOcc env mono_id
                         , abe_prags = new_prags })
 
-zonk_bind env _sig_warn bind@(PatSynBind { patsyn_id = L loc id
-                                         , patsyn_args = details
-                                         , patsyn_def = lpat
-                                         , patsyn_dir = dir })
+zonk_bind env _sig_warn (PatSynBind bind@(PSB { psb_id = L loc id
+                                              , psb_args = details
+                                              , psb_def = lpat
+                                              , psb_dir = dir }))
   = do { id' <- zonkIdBndr env id
        ; details' <- zonkPatSynDetails env details
        ;(env1, lpat') <- zonkPat env lpat
        ; (_env2, dir') <- zonkPatSynDir env1 dir
-       ; return (bind { patsyn_id = L loc id'
-                      , patsyn_args = details'
-                      , patsyn_def = lpat'
-                      , patsyn_dir = dir' }) }
+       ; return $ PatSynBind $
+                  bind { psb_id = L loc id'
+                       , psb_args = details'
+                       , psb_def = lpat'
+                       , psb_dir = dir' } }
 
 zonkPatSynDetails :: ZonkEnv
                   -> HsPatSynDetails (Located TcId)

compiler/typecheck/TcPatSyn.lhs

@@ -40,12 +40,10 @@ import TypeRep
 \end{code}
 
 \begin{code}
-tcPatSynDecl :: Located Name
-             -> HsPatSynDetails (Located Name)
-             -> LPat Name
-             -> HsPatSynDir Name
+tcPatSynDecl :: PatSynBind Name Name
              -> TcM (PatSyn, LHsBinds Id)
-tcPatSynDecl lname@(L _ name) details lpat dir
+tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
+                  psb_def = lpat, psb_dir = dir }
   = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
        ; tcCheckPatSynPat lpat
        ; pat_ty <- newFlexiTyVarTy openTypeKind
@@ -194,31 +192,41 @@ isBidirectional Unidirectional = False
 isBidirectional ImplicitBidirectional = True
 isBidirectional ExplicitBidirectional{} = True
 
-tcPatSynWrapper :: Located Id
-                -> LPat Name
-                -> HsPatSynDir Name
-                -> [Name]
+tcPatSynWrapper :: PatSynBind Name Name
                 -> TcM (LHsBinds Id)
 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
-tcPatSynWrapper _ _ Unidirectional _
-  = panic "tcPatSynWrapper"
-tcPatSynWrapper (L _ wrapper_id) lpat ImplicitBidirectional args
-  = do { lexpr <- case tcPatToExpr (mkNameSet args) lpat of
-              Nothing -> cannotInvertPatSynErr lpat
-              Just lexpr -> return lexpr
-       ; let wrapper_args = map (noLoc . VarPat) args
-             wrapper_lname = L (getLoc lpat) (idName wrapper_id)
-             wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
-             wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
-       ; mkPatSynWrapper wrapper_id wrapper_bind }
-tcPatSynWrapper (L loc wrapper_id) _ (ExplicitBidirectional mg) _
-  = mkPatSynWrapper wrapper_id $
-    FunBind{ fun_id = L loc (idName wrapper_id)
-           , fun_infix = False
-           , fun_matches = mg
-           , fun_co_fn = idHsWrapper
-           , bind_fvs = placeHolderNames
-           , fun_tick = Nothing }
+tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_args = details }
+  = case dir of
+    Unidirectional -> return emptyBag
+    ImplicitBidirectional ->
+        do { wrapper_id <- tcLookupPatSynWrapper name
+           ; lexpr <- case tcPatToExpr (mkNameSet args) lpat of
+                  Nothing -> cannotInvertPatSynErr lpat
+                  Just lexpr -> return lexpr
+           ; let wrapper_args = map (noLoc . VarPat) args
+                 wrapper_lname = L (getLoc lpat) (idName wrapper_id)
+                 wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
+                 wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
+           ; mkPatSynWrapper wrapper_id wrapper_bind }
+    ExplicitBidirectional mg ->
+        do { wrapper_id <- tcLookupPatSynWrapper name
+           ; mkPatSynWrapper wrapper_id $
+               FunBind{ fun_id = L loc (idName wrapper_id)
+                      , fun_infix = False
+                      , fun_matches = mg
+                      , fun_co_fn = idHsWrapper
+                      , bind_fvs = placeHolderNames
+                      , fun_tick = Nothing }}
+  where
+    args = map unLoc $ case details of
+        PrefixPatSyn args -> args
+        InfixPatSyn arg1 arg2 -> [arg1, arg2]
+
+    tcLookupPatSynWrapper name
+      = do { patsyn <- tcLookupPatSyn name
+           ; case patSynWrapper patsyn of
+               Nothing -> panic "tcLookupPatSynWrapper"
+               Just wrapper_id -> return wrapper_id }
 
 mkPatSynWrapperId :: Located Name
                   -> [Var] -> [TyVar] -> [TyVar] -> ThetaType -> Type

compiler/typecheck/TcPatSyn.lhs-boot

@@ -3,20 +3,13 @@ module TcPatSyn where
 
 import Name      ( Name )
 import Id        ( Id )
-import HsSyn     ( LPat, HsPatSynDetails, HsPatSynDir, LHsBinds )
+import HsSyn     ( PatSynBind, LHsBinds )
 import TcRnTypes ( TcM )
-import SrcLoc    ( Located )
 import PatSyn    ( PatSyn )
 
-tcPatSynDecl :: Located Name
-             -> HsPatSynDetails (Located Name)
-             -> LPat Name
-             -> HsPatSynDir Name
+tcPatSynDecl :: PatSynBind Name Name
              -> TcM (PatSyn, LHsBinds Id)
 
-tcPatSynWrapper :: Located Id
-                -> LPat Name
-                -> HsPatSynDir Name
-                -> [Name]
+tcPatSynWrapper :: PatSynBind Name Name
                 -> TcM (LHsBinds Id)
 \end{code}

utils/ghctags/Main.hs

@@ -282,7 +282,7 @@ boundThings modname lbinding =
     PatBind { pat_lhs = lhs } -> patThings lhs []
     VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)]
     AbsBinds { } -> [] -- nothing interesting in a type abstraction
-    PatSynBind { patsyn_id = id } -> [thing id]
+    PatSynBind PSB{ psb_id = id } -> [thing id]
   where thing = foundOfLName modname
         patThings lpat tl =
           let loc = startOfLocated lpat