Commit 18a15679 authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

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