summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthew Pickering <matthewtpickering@gmail.com>2015-08-18 18:07:18 +0200
committerBen Gamari <bgamari.foss@gmail.com>2015-08-18 12:32:28 -0400
commit18a15679ad6727c36b799da7c3b2a38be2001c4a (patch)
tree7d936cabd631063f69f6bdda8e8a4474f78bc655
parentebca3f80b9deb50bda1e3913b969785b27d92b4e (diff)
downloadhaskell-18a15679ad6727c36b799da7c3b2a38be2001c4a.tar.gz
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
-rw-r--r--compiler/basicTypes/ConLike.hs43
-rw-r--r--compiler/basicTypes/DataCon.hs-boot8
-rw-r--r--compiler/basicTypes/PatSyn.hs-boot11
-rw-r--r--compiler/deSugar/Check.hs4
-rw-r--r--compiler/deSugar/MatchCon.hs14
-rw-r--r--compiler/typecheck/TcPat.hs8
-rw-r--r--compiler/types/TyCon.hs-boot1
-rw-r--r--compiler/types/TypeRep.hs-boot1
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