1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1998
\section[ConLike]{@ConLike@: Constructor-like things}
-}
{-# LANGUAGE CPP #-}
module GHC.Core.ConLike (
ConLike(..)
, conLikeArity
, conLikeFieldLabels
, conLikeInstOrigArgTys
, conLikeExTyCoVars
, conLikeName
, conLikeStupidTheta
, conLikeWrapId_maybe
, conLikeImplBangs
, conLikeFullSig
, conLikeResTy
, conLikeFieldType
, conLikesWithFields
, conLikeIsInfix
) where
#include "HsVersions.h"
import GhcPrelude
import GHC.Core.DataCon
import GHC.Core.PatSyn
import Outputable
import GHC.Types.Unique
import Util
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Core.TyCo.Rep (Type, ThetaType)
import GHC.Types.Var
import GHC.Core.Type(mkTyConApp)
import qualified Data.Data as Data
{-
************************************************************************
* *
\subsection{Constructor-like things}
* *
************************************************************************
-}
-- | A constructor-like thing
data ConLike = RealDataCon DataCon
| PatSynCon PatSyn
{-
************************************************************************
* *
\subsection{Instances}
* *
************************************************************************
-}
instance Eq ConLike where
(==) = eqConLike
eqConLike :: ConLike -> ConLike -> Bool
eqConLike x y = getUnique x == getUnique y
-- There used to be an Ord ConLike instance here that used Unique for ordering.
-- It was intentionally removed to prevent determinism problems.
-- See Note [Unique Determinism] in GHC.Types.Unique.
instance Uniquable ConLike where
getUnique (RealDataCon dc) = getUnique dc
getUnique (PatSynCon ps) = getUnique ps
instance NamedThing ConLike where
getName (RealDataCon dc) = getName dc
getName (PatSynCon ps) = getName ps
instance Outputable ConLike where
ppr (RealDataCon dc) = ppr dc
ppr (PatSynCon ps) = ppr ps
instance OutputableBndr ConLike where
pprInfixOcc (RealDataCon dc) = pprInfixOcc dc
pprInfixOcc (PatSynCon ps) = pprInfixOcc ps
pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc
pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps
instance Data.Data ConLike where
-- don't traverse?
toConstr _ = abstractConstr "ConLike"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "ConLike"
-- | Number of arguments
conLikeArity :: ConLike -> Arity
conLikeArity (RealDataCon data_con) = dataConSourceArity data_con
conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn
-- | Names of fields used for selectors
conLikeFieldLabels :: ConLike -> [FieldLabel]
conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con
conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn
-- | Returns just the instantiated /value/ argument types of a 'ConLike',
-- (excluding dictionary args)
conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type]
conLikeInstOrigArgTys (RealDataCon data_con) tys =
dataConInstOrigArgTys data_con tys
conLikeInstOrigArgTys (PatSynCon pat_syn) tys =
patSynInstArgTys pat_syn tys
-- | Existentially quantified type/coercion variables
conLikeExTyCoVars :: ConLike -> [TyCoVar]
conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1
conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1
conLikeName :: ConLike -> Name
conLikeName (RealDataCon data_con) = dataConName data_con
conLikeName (PatSynCon pat_syn) = patSynName pat_syn
-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:
--
-- > data Eq a => T a = ...
-- It is empty for `PatSynCon` as they do not allow such contexts.
conLikeStupidTheta :: ConLike -> ThetaType
conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con
conLikeStupidTheta (PatSynCon {}) = []
-- | Returns the `Id` of the wrapper. This is also known as the builder in
-- some contexts. The value is Nothing only in the case of unidirectional
-- pattern synonyms.
conLikeWrapId_maybe :: ConLike -> Maybe Id
conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con
conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn
-- | Returns the strictness information for each constructor
conLikeImplBangs :: ConLike -> [HsImplBang]
conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con
conLikeImplBangs (PatSynCon pat_syn) =
replicate (patSynArity pat_syn) HsLazy
-- | Returns the type of the whole pattern
conLikeResTy :: ConLike -> [Type] -> Type
conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys
conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys
-- | The \"full signature\" of the 'ConLike' returns, in order:
--
-- 1) The universally quantified type variables
--
-- 2) The existentially quantified type/coercion variables
--
-- 3) The equality specification
--
-- 4) The provided theta (the constraints provided by a match)
--
-- 5) The required theta (the constraints required for a match)
--
-- 6) The original argument types (i.e. before
-- any change of the representation of the type)
--
-- 7) The original result type
conLikeFullSig :: ConLike
-> ([TyVar], [TyCoVar], [EqSpec]
-- Why tyvars for universal but tycovars for existential?
-- See Note [Existential coercion variables] in GHC.Core.DataCon
, ThetaType, ThetaType, [Type], Type)
conLikeFullSig (RealDataCon con) =
let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con
-- Required theta is empty as normal data cons require no additional
-- constraints for a match
in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty)
conLikeFullSig (PatSynCon pat_syn) =
let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn
-- eqSpec is empty
in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)
-- | Extract the type for any given labelled field of the 'ConLike'
conLikeFieldType :: ConLike -> FieldLabelString -> Type
conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label
conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label
-- | The ConLikes that have *all* the given fields
conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields con_likes lbls = filter has_flds con_likes
where has_flds dc = all (has_fld dc) lbls
has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
conLikeIsInfix :: ConLike -> Bool
conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc
conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps
|