Add selectors for common fields (DataCon/PatSyn) to ConLike
authorMatthew Pickering <matthewtpickering@gmail.com>
Tue, 18 Aug 2015 16:07:18 +0000 (18:07 +0200)
committerBen Gamari <bgamari.foss@gmail.com>
Tue, 18 Aug 2015 16:32:28 +0000 (12:32 -0400)
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

compiler/basicTypes/ConLike.hs
compiler/basicTypes/DataCon.hs-boot
compiler/basicTypes/PatSyn.hs-boot
compiler/deSugar/Check.hs
compiler/deSugar/MatchCon.hs
compiler/typecheck/TcPat.hs
compiler/types/TyCon.hs-boot
compiler/types/TypeRep.hs-boot

index 7b8f70d..b770183 100644 (file)
@@ -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 {})         = []
index 4f19ffc..0d53fdd 100644 (file)
@@ -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
index 733c51b..0ac4b7a 100644 (file)
@@ -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
index af72f74..d03e367 100644 (file)
@@ -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
index b42522c..4ea523a 100644 (file)
@@ -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
index 17d0441..8e05cb3 100644 (file)
@@ -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
index 5d27fa0..c2855ad 100644 (file)
@@ -4,6 +4,7 @@ import Name (Name)
 import Unique (Unique)
 
 data TyCon
+type FieldLabel = Name
 
 tyConName           :: TyCon -> Name
 tyConUnique         :: TyCon -> Unique
index 94832b1..e4117de 100644 (file)
@@ -8,5 +8,6 @@ data TyThing
 type PredType = Type
 type Kind = Type
 type SuperKind = Type
+type ThetaType = [PredType]
 
 instance Outputable Type