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
......@@ -9,16 +9,26 @@
module 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 {}) = []
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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -4,6 +4,7 @@ import Name (Name)
import Unique (Unique)
data TyCon
type FieldLabel = Name
tyConName :: TyCon -> Name
tyConUnique :: TyCon -> Unique
......
......@@ -8,5 +8,6 @@ data TyThing
type PredType = Type
type Kind = Type
type SuperKind = Type
type ThetaType = [PredType]
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