summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-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
View Lorry Controller Status