[commit: ghc] master: Add selectors for common fields (DataCon/PatSyn) to ConLike (18a1567)
git at git.haskell.org
git at git.haskell.org
Tue Aug 18 16:33:16 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/18a15679ad6727c36b799da7c3b2a38be2001c4a/ghc
>---------------------------------------------------------------
commit 18a15679ad6727c36b799da7c3b2a38be2001c4a
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date: Tue Aug 18 18:07:18 2015 +0200
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
>---------------------------------------------------------------
18a15679ad6727c36b799da7c3b2a38be2001c4a
compiler/basicTypes/ConLike.hs | 43 ++++++++++++++++++++++++++++++++++---
compiler/basicTypes/DataCon.hs-boot | 8 ++++++-
compiler/basicTypes/PatSyn.hs-boot | 11 ++++++++++
compiler/deSugar/Check.hs | 4 +---
compiler/deSugar/MatchCon.hs | 14 +++---------
compiler/typecheck/TcPat.hs | 8 +------
compiler/types/TyCon.hs-boot | 1 +
compiler/types/TypeRep.hs-boot | 1 +
8 files changed, 65 insertions(+), 25 deletions(-)
diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs
index 7b8f70d..b770183 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 4f19ffc..0d53fdd 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 733c51b..0ac4b7a 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 af72f74..d03e367 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 b42522c..4ea523a 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 17d0441..8e05cb3 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 5d27fa0..c2855ad 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 94832b1..e4117de 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
More information about the ghc-commits
mailing list