Add selectors for common fields (DataCon/PatSyn) to ConLike

When pattern synonyms were introduced a new sum type was used
in places where DataCon used to be used. PatSyn and DataCon share many
of the same fields, this patch adds selectors to ConLike for these
fields.

Reviewers: austin, goldfire, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1154

8 files changed, 65 insertions, 25 deletions

diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs
index 7b8f70d625..b7701830d4 100644
--- a/compiler/basicTypes/ConLike.hs
+++ b/compiler/basicTypes/ConLike.hs
@@ -8,17 +8,27 @@
 {-# LANGUAGE CPP, DeriveDataTypeable #-}
 
 module ConLike (
-        ConLike(..)
+          ConLike(..)
+        , conLikeArity
+        , conLikeFieldLabels
+        , conLikeInstOrigArgTys
+        , conLikeExTyVars
+        , conLikeName
+        , conLikeStupidTheta
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DataCon (DataCon)
-import {-# SOURCE #-} PatSyn (PatSyn)
+import {-# SOURCE #-} DataCon
+import {-# SOURCE #-} PatSyn
 import Outputable
 import Unique
 import Util
 import Name
+import TyCon
+import BasicTypes
+import {-# SOURCE #-} TypeRep (Type, ThetaType)
+import Var
 
 import Data.Function (on)
 import qualified Data.Data as Data
@@ -79,3 +89,30 @@ instance Data.Data ConLike where
     toConstr _   = abstractConstr "ConLike"
     gunfold _ _  = error "gunfold"
     dataTypeOf _ = mkNoRepType "ConLike"
+
+
+conLikeArity :: ConLike -> Arity
+conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
+conLikeArity (PatSynCon pat_syn)    = patSynArity pat_syn
+
+conLikeFieldLabels :: ConLike -> [FieldLabel]
+conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con
+conLikeFieldLabels (PatSynCon _) = []
+
+conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]
+conLikeInstOrigArgTys (RealDataCon data_con) tys =
+    dataConInstOrigArgTys data_con tys
+conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
+    patSynInstArgTys pat_syn tys
+
+conLikeExTyVars :: ConLike -> [TyVar]
+conLikeExTyVars (RealDataCon dcon1) = dataConExTyVars dcon1
+conLikeExTyVars (PatSynCon psyn1)   = patSynExTyVars psyn1
+
+conLikeName :: ConLike -> Name
+conLikeName (RealDataCon data_con) = dataConName data_con
+conLikeName (PatSynCon pat_syn)    = patSynName pat_syn
+
+conLikeStupidTheta :: ConLike -> ThetaType
+conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con
+conLikeStupidTheta (PatSynCon {})         = []
diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot
index 4f19ffcaa7..0d53fddd4a 100644
--- a/compiler/basicTypes/DataCon.hs-boot
+++ b/compiler/basicTypes/DataCon.hs-boot
@@ -1,15 +1,21 @@
 module DataCon where
 import Var( TyVar )
 import Name( Name, NamedThing )
-import {-# SOURCE #-} TyCon( TyCon )
+import {-# SOURCE #-} TyCon( TyCon, FieldLabel )
 import Unique ( Uniquable )
 import Outputable ( Outputable, OutputableBndr )
+import BasicTypes (Arity)
+import {-# SOURCE #-} TypeRep (Type, ThetaType)
 
 data DataCon
 data DataConRep
 dataConName      :: DataCon -> Name
 dataConTyCon     :: DataCon -> TyCon
 dataConExTyVars  :: DataCon -> [TyVar]
+dataConSourceArity  :: DataCon -> Arity
+dataConFieldLabels :: DataCon -> [FieldLabel]
+dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]
+dataConStupidTheta :: DataCon -> ThetaType
 
 instance Eq DataCon
 instance Ord DataCon
diff --git a/compiler/basicTypes/PatSyn.hs-boot b/compiler/basicTypes/PatSyn.hs-boot
index 733c51b355..0ac4b7a625 100644
--- a/compiler/basicTypes/PatSyn.hs-boot
+++ b/compiler/basicTypes/PatSyn.hs-boot
@@ -4,9 +4,20 @@ import Data.Typeable ( Typeable )
 import Data.Data ( Data )
 import Outputable ( Outputable, OutputableBndr )
 import Unique ( Uniquable )
+import BasicTypes (Arity)
+import {-# SOURCE #-} TypeRep (Type)
+import Var (TyVar)
+import Name (Name)
 
 data PatSyn
 
+patSynArity :: PatSyn -> Arity
+patSynInstArgTys :: PatSyn -> [Type] -> [Type]
+patSynExTyVars :: PatSyn -> [TyVar]
+patSynName :: PatSyn -> Name
+
+
+
 instance Eq PatSyn
 instance Ord PatSyn
 instance NamedThing PatSyn
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index af72f74312..d03e36774c 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -754,9 +754,7 @@ tidy_con con (RecCon (HsRecFields fs _))
                 -- Special case for null patterns; maybe not a record at all
   | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)
   where
-    arity = case con of
-        RealDataCon dcon -> dataConSourceArity dcon
-        PatSynCon psyn -> patSynArity psyn
+    arity = conLikeArity con
 
      -- pad out all the missing fields with WildPats.
     field_pats = case con of
diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs
index b42522c3c0..4ea523a0df 100644
--- a/compiler/deSugar/MatchCon.hs
+++ b/compiler/deSugar/MatchCon.hs
@@ -17,8 +17,6 @@ import {-# SOURCE #-} Match     ( match )
 import HsSyn
 import DsBinds
 import ConLike
-import DataCon
-import PatSyn
 import TcType
 import DsMonad
 import DsUtils
@@ -139,21 +137,15 @@ matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
     ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,
                 pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
               = firstPat eqn1
-    fields1 = case con1 of
-                RealDataCon dcon1 -> dataConFieldLabels dcon1
-                PatSynCon{}       -> []
+    fields1 = conLikeFieldLabels con1
 
-    val_arg_tys = case con1 of
-                    RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys
-                    PatSynCon psyn1   -> patSynInstArgTys      psyn1 inst_tys
+    val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
     inst_tys = ASSERT( tvs1 `equalLength` ex_tvs )
                arg_tys ++ mkTyVarTys tvs1
         -- dataConInstOrigArgTys takes the univ and existential tyvars
         -- and returns the types of the *value* args, which is what we want
 
-    ex_tvs = case con1 of
-               RealDataCon dcon1 -> dataConExTyVars dcon1
-               PatSynCon psyn1   -> patSynExTyVars psyn1
+    ex_tvs = conLikeExTyVars con1
 
     match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
     -- All members of the group have compatible ConArgPats
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 17d044176f..8e05cb318e 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -1073,16 +1073,10 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
                    ; return (sel_id, pat_ty) }
 
     field_tys :: [(FieldLabel, TcType)]
-    field_tys = case con_like of
-        RealDataCon data_con -> zip (dataConFieldLabels data_con) arg_tys
+    field_tys = zip (conLikeFieldLabels con_like) arg_tys
           -- Don't use zipEqual! If the constructor isn't really a record, then
           -- dataConFieldLabels will be empty (and each field in the pattern
           -- will generate an error below).
-        PatSynCon{} -> []
-
-conLikeArity :: ConLike -> Arity
-conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
-conLikeArity (PatSynCon   pat_syn)  = patSynArity pat_syn
 
 tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id)
 tcConArg (arg_pat, arg_ty) penv thing_inside
diff --git a/compiler/types/TyCon.hs-boot b/compiler/types/TyCon.hs-boot
index 5d27fa0bc9..c2855adbfa 100644
--- a/compiler/types/TyCon.hs-boot
+++ b/compiler/types/TyCon.hs-boot
@@ -4,6 +4,7 @@ import Name (Name)
 import Unique (Unique)
 
 data TyCon
+type FieldLabel = Name
 
 tyConName           :: TyCon -> Name
 tyConUnique         :: TyCon -> Unique
diff --git a/compiler/types/TypeRep.hs-boot b/compiler/types/TypeRep.hs-boot
index 94832b1a24..e4117de3da 100644
--- a/compiler/types/TypeRep.hs-boot
+++ b/compiler/types/TypeRep.hs-boot
@@ -8,5 +8,6 @@ data TyThing
 type PredType = Type
 type Kind = Type
 type SuperKind = Type
+type ThetaType = [PredType]
 
 instance Outputable Type