Simplify HsPatSynDetails

This is a pure refactoring.  Use HsConDetails to implement
HsPatSynDetails, instead of defining a whole new data type.
Less code, fewer types, all good.

(cherry picked from commit 584cbd4a)

compiler/deSugar/DsMeta.hs

@@ -1500,10 +1500,10 @@ rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
     -- API. Whereas inside GHC, record pattern synonym selectors and
     -- their pattern-only bound right hand sides have different names,
     -- we want to treat them the same in TH. This is the reason why we
-    -- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below.
-    mkGenArgSyms (PrefixPatSyn args)     = mkGenSyms (map unLoc args)
-    mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
-    mkGenArgSyms (RecordPatSyn fields)
+    -- need an adjusted mkGenArgSyms in the `RecCon` case below.
+    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)
+    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
+    mkGenArgSyms (RecCon fields)
       = do { let pats = map (unLoc . recordPatSynPatVar) fields
                  sels = map (unLoc . recordPatSynSelectorId) fields
            ; ss <- mkGenSyms sels
@@ -1515,8 +1515,8 @@ rep_bind (L loc (PatSynBind (PSB { psb_id   = syn
 
     wrapGenArgSyms :: HsPatSynDetails (Located Name)
                    -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
-    wrapGenArgSyms (RecordPatSyn _) _  dec = return dec
-    wrapGenArgSyms _                ss dec = wrapGenSyms ss dec
+    wrapGenArgSyms (RecCon _) _  dec = return dec
+    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
 
 repPatSynD :: Core TH.Name
            -> Core TH.PatSynArgsQ
@@ -1527,14 +1527,14 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
   = rep2 patSynDName [syn, args, dir, pat]
 
 repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
-repPatSynArgs (PrefixPatSyn args)
+repPatSynArgs (PrefixCon args)
   = do { args' <- repList nameTyConName lookupLOcc args
        ; repPrefixPatSynArgs args' }
-repPatSynArgs (InfixPatSyn arg1 arg2)
+repPatSynArgs (InfixCon arg1 arg2)
   = do { arg1' <- lookupLOcc arg1
        ; arg2' <- lookupLOcc arg2
        ; repInfixPatSynArgs arg1' arg2' }
-repPatSynArgs (RecordPatSyn fields)
+repPatSynArgs (RecCon fields)
   = do { sels' <- repList nameTyConName lookupLOcc sels
        ; repRecordPatSynArgs sels' }
   where sels = map recordPatSynSelectorId fields

compiler/hsSyn/Convert.hs

@@ -367,12 +367,12 @@ cvtDec (TH.PatSynD nm args dir pat)
        ; returnJustL $ Hs.ValD $ PatSynBind $
            PSB nm' placeHolderType args' pat' dir' }
   where
-    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
-    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
     cvtArgs (TH.RecordPatSyn sels)
       = do { sels' <- mapM vNameL sels
            ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
-           ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
+           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
 
     cvtDir _ Unidir          = return Unidirectional
     cvtDir _ ImplBidir       = return ImplicitBidirectional

compiler/hsSyn/HsBinds.hs

@@ -716,11 +716,10 @@ instance (SourceTextX idR,
       ppr_simple syntax = syntax <+> ppr pat
 
       ppr_details = case details of
-          InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
-          PrefixPatSyn vs   -> hsep (pprPrefixOcc psyn : map ppr vs)
-          RecordPatSyn vs   ->
-            pprPrefixOcc psyn
-                      <> braces (sep (punctuate comma (map ppr vs)))
+          InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
+          PrefixCon vs   -> hsep (pprPrefixOcc psyn : map ppr vs)
+          RecCon vs      -> pprPrefixOcc psyn
+                            <> braces (sep (punctuate comma (map ppr vs)))
 
       ppr_rhs = case dir of
           Unidirectional           -> ppr_simple (text "<-")
@@ -1137,12 +1136,7 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
 -}
 
 -- | Haskell Pattern Synonym Details
-data HsPatSynDetails a
-  = InfixPatSyn a a                    -- ^ Infix Pattern Synonym
-  | PrefixPatSyn [a]                   -- ^ Prefix Pattern Synonym
-  | RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym
-  deriving Data
-
+type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]
 
 -- See Note [Record PatSyn Fields]
 -- | Record Pattern Synonym Field
@@ -1199,43 +1193,6 @@ instance Traversable RecordPatSynField where
           <$> f visible <*> f hidden
 
 
-instance Functor HsPatSynDetails where
-    fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
-    fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
-    fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)
-
-instance Foldable HsPatSynDetails where
-    foldMap f (InfixPatSyn left right) = f left `mappend` f right
-    foldMap f (PrefixPatSyn args) = foldMap f args
-    foldMap f (RecordPatSyn args) = foldMap (foldMap f) args
-
-    foldl1 f (InfixPatSyn left right) = left `f` right
-    foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
-    foldl1 f (RecordPatSyn args) =
-      Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)
-
-    foldr1 f (InfixPatSyn left right) = left `f` right
-    foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
-    foldr1 f (RecordPatSyn args) =
-      Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)
-
-    length (InfixPatSyn _ _) = 2
-    length (PrefixPatSyn args) = Data.List.length args
-    length (RecordPatSyn args) = Data.List.length args
-
-    null (InfixPatSyn _ _) = False
-    null (PrefixPatSyn args) = Data.List.null args
-    null (RecordPatSyn args) = Data.List.null args
-
-    toList (InfixPatSyn left right) = [left, right]
-    toList (PrefixPatSyn args) = args
-    toList (RecordPatSyn args) = foldMap toList args
-
-instance Traversable HsPatSynDetails where
-    traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
-    traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
-    traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args
-
 -- | Haskell Pattern Synonym Direction
 data HsPatSynDir id
   = Unidirectional

compiler/hsSyn/HsUtils.hs

@@ -1127,7 +1127,7 @@ hsPatSynSelectors (ValBindsOut binds _)
 
 addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
 addPatSynSelector bind sels
-  | L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
+  | L _ (PatSynBind (PSB { psb_args = RecCon as })) <- bind
   = map (unLoc . recordPatSynSelectorId) as ++ sels
   | otherwise = sels
 

compiler/parser/Parser.y

@@ -1375,9 +1375,9 @@ pattern_synonym_decl :: { LHsDecl GhcPs }
                    }}
 
 pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }
-        : con vars0 { ($1, PrefixPatSyn $2, []) }
-        | varid conop varid { ($2, InfixPatSyn $1 $3, []) }
-        | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) }
+        : con vars0 { ($1, PrefixCon $2, []) }
+        | varid conop varid { ($2, InfixCon $1 $3, []) }
+        | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }
 
 vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }

compiler/rename/RnBinds.hs

@@ -660,19 +660,19 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
          -- so that the binding locations are reported
          -- from the left-hand side
             case details of
-               PrefixPatSyn vars ->
+               PrefixCon vars ->
                    do { checkDupRdrNames vars
                       ; names <- mapM lookupPatSynBndr vars
-                      ; return ( (pat', PrefixPatSyn names)
+                      ; return ( (pat', PrefixCon names)
                                , mkFVs (map unLoc names)) }
-               InfixPatSyn var1 var2 ->
+               InfixCon var1 var2 ->
                    do { checkDupRdrNames [var1, var2]
                       ; name1 <- lookupPatSynBndr var1
                       ; name2 <- lookupPatSynBndr var2
                       -- ; checkPrecMatch -- TODO
-                      ; return ( (pat', InfixPatSyn name1 name2)
+                      ; return ( (pat', InfixCon name1 name2)
                                , mkFVs (map unLoc [name1, name2])) }
-               RecordPatSyn vars ->
+               RecCon vars ->
                    do { checkDupRdrNames (map recordPatSynSelectorId vars)
                       ; let rnRecordPatSynField
                               (RecordPatSynField { recordPatSynSelectorId = visible
@@ -682,7 +682,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
                                    ; return $ RecordPatSynField { recordPatSynSelectorId = visible'
                                                                 , recordPatSynPatVar = hidden' } }
                       ; names <- mapM rnRecordPatSynField  vars
-                      ; return ( (pat', RecordPatSyn names)
+                      ; return ( (pat', RecCon names)
                                , mkFVs (map (unLoc . recordPatSynPatVar) names)) }
 
         ; (dir', fvs2) <- case dir of
@@ -706,7 +706,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
                           , psb_dir = dir'
                           , psb_fvs = fvs' }
               selector_names = case details' of
-                                 RecordPatSyn names ->
+                                 RecCon names ->
                                   map (unLoc . recordPatSynSelectorId) names
                                  _ -> []
 

compiler/rename/RnSource.hs

@@ -1967,7 +1967,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
             -> TcM [(Name, [FieldLabel])]
     new_ps' bind names
       | L bind_loc (PatSynBind (PSB { psb_id = L _ n
-                                    , psb_args = RecordPatSyn as })) <- bind
+                                    , psb_args = RecCon as })) <- bind
       = do
           bnd_name <- newTopSrcBinder (L bind_loc n)
           let rnames = map recordPatSynSelectorId as

compiler/typecheck/TcHsSyn.hs

@@ -268,6 +268,9 @@ zonkEnvIds (ZonkEnv _ _ id_env) =
   -- It's OK to use nonDetEltsUFM here because we forget the ordering
   -- immediately by creating a TypeEnv
 
+zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
+zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id)
+
 zonkIdOcc :: ZonkEnv -> TcId -> Id
 -- Ids defined in this module should be in the envt;
 -- ignore others.  (Actually, data constructors are also
@@ -509,8 +512,8 @@ zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
                                     , psb_def = lpat
                                     , psb_dir = dir }))
   = do { id' <- zonkIdBndr env id
-       ; details' <- zonkPatSynDetails env details
        ; (env1, lpat') <- zonkPat env lpat
+       ; let details' = zonkPatSynDetails env1 details
        ; (_env2, dir') <- zonkPatSynDir env1 dir
        ; return $ PatSynBind $
                   bind { psb_id = L loc id'
@@ -520,12 +523,17 @@ zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
 
 zonkPatSynDetails :: ZonkEnv
                   -> HsPatSynDetails (Located TcId)
-                  -> TcM (HsPatSynDetails (Located Id))
-zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env)
+                  -> HsPatSynDetails (Located Id)
+zonkPatSynDetails env (PrefixCon as)
+  = PrefixCon (map (zonkLIdOcc env) as)
+zonkPatSynDetails env (InfixCon a1 a2)
+  = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
+zonkPatSynDetails env (RecCon flds)
+  = RecCon (map (fmap (zonkLIdOcc env)) flds)
 
 zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
               -> TcM (ZonkEnv, HsPatSynDir GhcTc)
-zonkPatSynDir env Unidirectional = return (env, Unidirectional)
+zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
 zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
 zonkPatSynDir env (ExplicitBidirectional mg) = do
     mg' <- zonkMatchGroup env zonkLExpr mg
@@ -1343,7 +1351,7 @@ zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
 
 zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)
 zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec })
-  = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i
+  = return (ForeignExport { fd_name = zonkLIdOcc env i
                           , fd_sig_ty = undefined, fd_co = co
                           , fd_fe = spec })
 zonkForeignExport _ for_imp

compiler/typecheck/TcPatSyn.hs

@@ -307,12 +307,11 @@ collectPatSynArgInfo :: HsPatSynDetails (Located Name)
                      -> ([Name], [Name], Bool)
 collectPatSynArgInfo details =
   case details of
-    PrefixPatSyn names      -> (map unLoc names, [], False)
-    InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True)
-    RecordPatSyn names ->
-      let (vars, sels) = unzip (map splitRecordPatSyn names)
-      in (vars, sels, False)
-
+    PrefixCon names      -> (map unLoc names, [], False)
+    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
+    RecCon names         -> (vars, sels, False)
+                         where
+                            (vars, sels) = unzip (map splitRecordPatSyn names)
   where
     splitRecordPatSyn :: RecordPatSynField (Located Name)
                       -> (Name, Name)
@@ -615,9 +614,9 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
                                        (noLoc EmptyLocalBinds)
 
     args = case details of
-              PrefixPatSyn args     -> args
-              InfixPatSyn arg1 arg2 -> [arg1, arg2]
-              RecordPatSyn args     -> map recordPatSynPatVar args
+              PrefixCon args     -> args
+              InfixCon arg1 arg2 -> [arg1, arg2]
+              RecCon args        -> map recordPatSynPatVar args
 
     add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
                   -> MatchGroup GhcRn (LHsExpr GhcRn)