6e69a1cbce10f2dc64bd16b1361ef4702ee90f37
[ghc.git] / compiler / basicTypes / DataCon.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1998
4
5 \section[DataCon]{@DataCon@: Data Constructors}
6 -}
7
8 {-# LANGUAGE CPP, DeriveDataTypeable #-}
9
10 module DataCon (
11 -- * Main data types
12 DataCon, DataConRep(..),
13 SrcStrictness(..), SrcUnpackedness(..),
14 HsSrcBang(..), HsImplBang(..),
15 StrictnessMark(..),
16 ConTag,
17
18 -- ** Field labels
19 FieldLbl(..), FieldLabel, FieldLabelString,
20
21 -- ** Type construction
22 mkDataCon, fIRST_TAG,
23 buildAlgTyCon,
24
25 -- ** Type deconstruction
26 dataConRepType, dataConSig, dataConInstSig, dataConFullSig,
27 dataConName, dataConIdentity, dataConTag, dataConTyCon,
28 dataConOrigTyCon, dataConUserType,
29 dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
30 dataConEqSpec, eqSpecPreds, dataConTheta,
31 dataConStupidTheta,
32 dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
33 dataConInstOrigArgTys, dataConRepArgTys,
34 dataConFieldLabels, dataConFieldType,
35 dataConSrcBangs,
36 dataConSourceArity, dataConRepArity, dataConRepRepArity,
37 dataConIsInfix,
38 dataConWorkId, dataConWrapId, dataConWrapId_maybe,
39 dataConImplicitTyThings,
40 dataConRepStrictness, dataConImplBangs, dataConBoxer,
41
42 splitDataProductType_maybe,
43
44 -- ** Predicates on DataCons
45 isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
46 isVanillaDataCon, classDataCon, dataConCannotMatch,
47 isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
48
49 -- ** Promotion related functions
50 promoteDataCon, promoteDataCon_maybe,
51 promoteType, promoteKind,
52 isPromotableType, computeTyConPromotability,
53 ) where
54
55 #include "HsVersions.h"
56
57 import {-# SOURCE #-} MkId( DataConBoxer )
58 import Type
59 import ForeignCall( CType )
60 import TypeRep( Type(..) ) -- Used in promoteType
61 import PrelNames( liftedTypeKindTyConKey )
62 import Coercion
63 import Kind
64 import Unify
65 import TyCon
66 import FieldLabel
67 import Class
68 import Name
69 import Var
70 import Outputable
71 import Unique
72 import ListSetOps
73 import Util
74 import BasicTypes
75 import FastString
76 import Module
77 import VarEnv
78 import NameSet
79 import Binary
80
81 import qualified Data.Data as Data
82 import qualified Data.Typeable
83 import Data.Char
84 import Data.Word
85 import Data.List( mapAccumL, find )
86
87 {-
88 Data constructor representation
89 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
90 Consider the following Haskell data type declaration
91
92 data T = T !Int ![Int]
93
94 Using the strictness annotations, GHC will represent this as
95
96 data T = T Int# [Int]
97
98 That is, the Int has been unboxed. Furthermore, the Haskell source construction
99
100 T e1 e2
101
102 is translated to
103
104 case e1 of { I# x ->
105 case e2 of { r ->
106 T x r }}
107
108 That is, the first argument is unboxed, and the second is evaluated. Finally,
109 pattern matching is translated too:
110
111 case e of { T a b -> ... }
112
113 becomes
114
115 case e of { T a' b -> let a = I# a' in ... }
116
117 To keep ourselves sane, we name the different versions of the data constructor
118 differently, as follows.
119
120
121 Note [Data Constructor Naming]
122 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
123 Each data constructor C has two, and possibly up to four, Names associated with it:
124
125 OccName Name space Name of Notes
126 ---------------------------------------------------------------------------
127 The "data con itself" C DataName DataCon In dom( GlobalRdrEnv )
128 The "worker data con" C VarName Id The worker
129 The "wrapper data con" $WC VarName Id The wrapper
130 The "newtype coercion" :CoT TcClsName TyCon
131
132 EVERY data constructor (incl for newtypes) has the former two (the
133 data con itself, and its worker. But only some data constructors have a
134 wrapper (see Note [The need for a wrapper]).
135
136 Each of these three has a distinct Unique. The "data con itself" name
137 appears in the output of the renamer, and names the Haskell-source
138 data constructor. The type checker translates it into either the wrapper Id
139 (if it exists) or worker Id (otherwise).
140
141 The data con has one or two Ids associated with it:
142
143 The "worker Id", is the actual data constructor.
144 * Every data constructor (newtype or data type) has a worker
145
146 * The worker is very like a primop, in that it has no binding.
147
148 * For a *data* type, the worker *is* the data constructor;
149 it has no unfolding
150
151 * For a *newtype*, the worker has a compulsory unfolding which
152 does a cast, e.g.
153 newtype T = MkT Int
154 The worker for MkT has unfolding
155 \\(x:Int). x `cast` sym CoT
156 Here CoT is the type constructor, witnessing the FC axiom
157 axiom CoT : T = Int
158
159 The "wrapper Id", \$WC, goes as follows
160
161 * Its type is exactly what it looks like in the source program.
162
163 * It is an ordinary function, and it gets a top-level binding
164 like any other function.
165
166 * The wrapper Id isn't generated for a data type if there is
167 nothing for the wrapper to do. That is, if its defn would be
168 \$wC = C
169
170 Note [The need for a wrapper]
171 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
172 Why might the wrapper have anything to do? Two reasons:
173
174 * Unboxing strict fields (with -funbox-strict-fields)
175 data T = MkT !(Int,Int)
176 \$wMkT :: (Int,Int) -> T
177 \$wMkT (x,y) = MkT x y
178 Notice that the worker has two fields where the wapper has
179 just one. That is, the worker has type
180 MkT :: Int -> Int -> T
181
182 * Equality constraints for GADTs
183 data T a where { MkT :: a -> T [a] }
184
185 The worker gets a type with explicit equality
186 constraints, thus:
187 MkT :: forall a b. (a=[b]) => b -> T a
188
189 The wrapper has the programmer-specified type:
190 \$wMkT :: a -> T [a]
191 \$wMkT a x = MkT [a] a [a] x
192 The third argument is a coercion
193 [a] :: [a]~[a]
194
195 INVARIANT: the dictionary constructor for a class
196 never has a wrapper.
197
198
199 A note about the stupid context
200 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
201 Data types can have a context:
202
203 data (Eq a, Ord b) => T a b = T1 a b | T2 a
204
205 and that makes the constructors have a context too
206 (notice that T2's context is "thinned"):
207
208 T1 :: (Eq a, Ord b) => a -> b -> T a b
209 T2 :: (Eq a) => a -> T a b
210
211 Furthermore, this context pops up when pattern matching
212 (though GHC hasn't implemented this, but it is in H98, and
213 I've fixed GHC so that it now does):
214
215 f (T2 x) = x
216 gets inferred type
217 f :: Eq a => T a b -> a
218
219 I say the context is "stupid" because the dictionaries passed
220 are immediately discarded -- they do nothing and have no benefit.
221 It's a flaw in the language.
222
223 Up to now [March 2002] I have put this stupid context into the
224 type of the "wrapper" constructors functions, T1 and T2, but
225 that turned out to be jolly inconvenient for generics, and
226 record update, and other functions that build values of type T
227 (because they don't have suitable dictionaries available).
228
229 So now I've taken the stupid context out. I simply deal with
230 it separately in the type checker on occurrences of a
231 constructor, either in an expression or in a pattern.
232
233 [May 2003: actually I think this decision could evasily be
234 reversed now, and probably should be. Generics could be
235 disabled for types with a stupid context; record updates now
236 (H98) needs the context too; etc. It's an unforced change, so
237 I'm leaving it for now --- but it does seem odd that the
238 wrapper doesn't include the stupid context.]
239
240 [July 04] With the advent of generalised data types, it's less obvious
241 what the "stupid context" is. Consider
242 C :: forall a. Ord a => a -> a -> T (Foo a)
243 Does the C constructor in Core contain the Ord dictionary? Yes, it must:
244
245 f :: T b -> Ordering
246 f = /\b. \x:T b.
247 case x of
248 C a (d:Ord a) (p:a) (q:a) -> compare d p q
249
250 Note that (Foo a) might not be an instance of Ord.
251
252 ************************************************************************
253 * *
254 \subsection{Data constructors}
255 * *
256 ************************************************************************
257 -}
258
259 -- | A data constructor
260 --
261 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
262 -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma'
263
264 -- For details on above see note [Api annotations] in ApiAnnotation
265 data DataCon
266 = MkData {
267 dcName :: Name, -- This is the name of the *source data con*
268 -- (see "Note [Data Constructor Naming]" above)
269 dcUnique :: Unique, -- Cached from Name
270 dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's
271
272 -- Running example:
273 --
274 -- *** As declared by the user
275 -- data T a where
276 -- MkT :: forall x y. (x~y,Ord x) => x -> y -> T (x,y)
277
278 -- *** As represented internally
279 -- data T a where
280 -- MkT :: forall a. forall x y. (a~(x,y),x~y,Ord x) => x -> y -> T a
281 --
282 -- The next six fields express the type of the constructor, in pieces
283 -- e.g.
284 --
285 -- dcUnivTyVars = [a]
286 -- dcExTyVars = [x,y]
287 -- dcEqSpec = [a~(x,y)]
288 -- dcOtherTheta = [x~y, Ord x]
289 -- dcOrigArgTys = [x,y]
290 -- dcRepTyCon = T
291
292 dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor
293 -- Its type is of form
294 -- forall a1..an . t1 -> ... tm -> T a1..an
295 -- No existentials, no coercions, nothing.
296 -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []
297 -- NB 1: newtypes always have a vanilla data con
298 -- NB 2: a vanilla constructor can still be declared in GADT-style
299 -- syntax, provided its type looks like the above.
300 -- The declaration format is held in the TyCon (algTcGadtSyntax)
301
302 dcUnivTyVars :: [TyVar], -- Universally-quantified type vars [a,b,c]
303 -- INVARIANT: length matches arity of the dcRepTyCon
304 --- result type of (rep) data con is exactly (T a b c)
305
306 dcExTyVars :: [TyVar], -- Existentially-quantified type vars
307 -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
308 -- FOR THE PARENT TyCon. With GADTs the data con might not even have
309 -- the same number of type variables.
310 -- [This is a change (Oct05): previously, vanilla datacons guaranteed to
311 -- have the same type variables as their parent TyCon, but that seems ugly.]
312
313 -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames
314 -- Reason: less confusing, and easier to generate IfaceSyn
315
316 dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type,
317 -- _as written by the programmer_
318 -- This field allows us to move conveniently between the two ways
319 -- of representing a GADT constructor's type:
320 -- MkT :: forall a b. (a ~ [b]) => b -> T a
321 -- MkT :: forall b. b -> T [b]
322 -- Each equality is of the form (a ~ ty), where 'a' is one of
323 -- the universally quantified type variables
324
325 -- The next two fields give the type context of the data constructor
326 -- (aside from the GADT constraints,
327 -- which are given by the dcExpSpec)
328 -- In GADT form, this is *exactly* what the programmer writes, even if
329 -- the context constrains only universally quantified variables
330 -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b
331 dcOtherTheta :: ThetaType, -- The other constraints in the data con's type
332 -- other than those in the dcEqSpec
333
334 dcStupidTheta :: ThetaType, -- The context of the data type declaration
335 -- data Eq a => T a = ...
336 -- or, rather, a "thinned" version thereof
337 -- "Thinned", because the Report says
338 -- to eliminate any constraints that don't mention
339 -- tyvars free in the arg types for this constructor
340 --
341 -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars
342 -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon
343 --
344 -- "Stupid", because the dictionaries aren't used for anything.
345 -- Indeed, [as of March 02] they are no longer in the type of
346 -- the wrapper Id, because that makes it harder to use the wrap-id
347 -- to rebuild values after record selection or in generics.
348
349 dcOrigArgTys :: [Type], -- Original argument types
350 -- (before unboxing and flattening of strict fields)
351 dcOrigResTy :: Type, -- Original result type, as seen by the user
352 -- NB: for a data instance, the original user result type may
353 -- differ from the DataCon's representation TyCon. Example
354 -- data instance T [a] where MkT :: a -> T [a]
355 -- The OrigResTy is T [a], but the dcRepTyCon might be :T123
356
357 -- Now the strictness annotations and field labels of the constructor
358 dcSrcBangs :: [HsSrcBang],
359 -- See Note [Bangs on data constructor arguments]
360 --
361 -- The [HsSrcBang] as written by the programmer.
362 --
363 -- Matches 1-1 with dcOrigArgTys
364 -- Hence length = dataConSourceArity dataCon
365
366 dcFields :: [FieldLabel],
367 -- Field labels for this constructor, in the
368 -- same order as the dcOrigArgTys;
369 -- length = 0 (if not a record) or dataConSourceArity.
370
371 -- The curried worker function that corresponds to the constructor:
372 -- It doesn't have an unfolding; the code generator saturates these Ids
373 -- and allocates a real constructor when it finds one.
374 dcWorkId :: Id,
375
376 -- Constructor representation
377 dcRep :: DataConRep,
378
379 -- Cached
380 dcRepArity :: Arity, -- == length dataConRepArgTys
381 dcSourceArity :: Arity, -- == length dcOrigArgTys
382
383 -- Result type of constructor is T t1..tn
384 dcRepTyCon :: TyCon, -- Result tycon, T
385
386 dcRepType :: Type, -- Type of the constructor
387 -- forall a x y. (a~(x,y), x~y, Ord x) =>
388 -- x -> y -> T a
389 -- (this is *not* of the constructor wrapper Id:
390 -- see Note [Data con representation] below)
391 -- Notice that the existential type parameters come *second*.
392 -- Reason: in a case expression we may find:
393 -- case (e :: T t) of
394 -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ...
395 -- It's convenient to apply the rep-type of MkT to 't', to get
396 -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t
397 -- and use that to check the pattern. Mind you, this is really only
398 -- used in CoreLint.
399
400
401 dcInfix :: Bool, -- True <=> declared infix
402 -- Used for Template Haskell and 'deriving' only
403 -- The actual fixity is stored elsewhere
404
405 dcPromoted :: Promoted TyCon -- The promoted TyCon if this DataCon is promotable
406 -- See Note [Promoted data constructors] in TyCon
407 }
408 deriving Data.Typeable.Typeable
409
410 data DataConRep
411 = NoDataConRep -- No wrapper
412
413 | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens,
414 -- and constructs the representation
415
416 , dcr_boxer :: DataConBoxer
417
418 , dcr_arg_tys :: [Type] -- Final, representation argument types,
419 -- after unboxing and flattening,
420 -- and *including* all evidence args
421
422 , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys
423 -- See also Note [Data-con worker strictness] in MkId.hs
424
425 , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures)
426 -- about the original arguments; 1-1 with orig_arg_tys
427 -- See Note [Bangs on data constructor arguments]
428
429 }
430 -- Algebraic data types always have a worker, and
431 -- may or may not have a wrapper, depending on whether
432 -- the wrapper does anything.
433 --
434 -- Data types have a worker with no unfolding
435 -- Newtypes just have a worker, which has a compulsory unfolding (just a cast)
436
437 -- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
438
439 -- The wrapper (if it exists) takes dcOrigArgTys as its arguments
440 -- The worker takes dataConRepArgTys as its arguments
441 -- If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys
442
443 -- The 'NoDataConRep' case is important
444 -- Not only is this efficient,
445 -- but it also ensures that the wrapper is replaced
446 -- by the worker (because it *is* the worker)
447 -- even when there are no args. E.g. in
448 -- f (:) x
449 -- the (:) *is* the worker.
450 -- This is really important in rule matching,
451 -- (We could match on the wrappers,
452 -- but that makes it less likely that rules will match
453 -- when we bring bits of unfoldings together.)
454
455 -------------------------
456
457 -- | Bangs on data constructor arguments as the user wrote them in the
458 -- source code.
459 --
460 -- (HsSrcBang _ SrcUnpack SrcLazy) and
461 -- (HsSrcBang _ SrcUnpack NoSrcStrict) (without StrictData) makes no sense, we
462 -- emit a warning (in checkValidDataCon) and treat it like
463 -- (HsSrcBang _ NoSrcUnpack SrcLazy)
464 data HsSrcBang =
465 HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
466 SrcUnpackedness
467 SrcStrictness
468 deriving (Data.Data, Data.Typeable)
469
470 -- | Bangs of data constructor arguments as generated by the compiler
471 -- after consulting HsSrcBang, flags, etc.
472 data HsImplBang
473 = HsLazy -- ^ Lazy field
474 | HsStrict -- ^ Strict but not unpacked field
475 | HsUnpack (Maybe Coercion)
476 -- ^ Strict and unpacked field
477 -- co :: arg-ty ~ product-ty HsBang
478 deriving (Data.Data, Data.Typeable)
479
480 -- | What strictness annotation the user wrote
481 data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'
482 | SrcStrict -- ^ Strict, ie '!'
483 | NoSrcStrict -- ^ no strictness annotation
484 deriving (Eq, Data.Data, Data.Typeable)
485
486 -- | What unpackedness the user requested
487 data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
488 | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified
489 | NoSrcUnpack -- ^ no unpack pragma
490 deriving (Eq, Data.Data, Data.Typeable)
491
492
493
494 -------------------------
495 -- StrictnessMark is internal only, used to indicate strictness
496 -- of the DataCon *worker* fields
497 data StrictnessMark = MarkedStrict | NotMarkedStrict
498
499 {- Note [Bangs on data constructor arguments]
500 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
501 Consider
502 data T = MkT !Int {-# UNPACK #-} !Int Bool
503
504 When compiling the module, GHC will decide how to represent
505 MkT, depending on the optimisation level, and settings of
506 flags like -funbox-small-strict-fields.
507
508 Terminology:
509 * HsSrcBang: What the user wrote
510 Constructors: HsSrcBang
511
512 * HsImplBang: What GHC decided
513 Constructors: HsLazy, HsStrict, HsUnpack
514
515 * If T was defined in this module, MkT's dcSrcBangs field
516 records the [HsSrcBang] of what the user wrote; in the example
517 [ HsSrcBang _ NoSrcUnpack SrcStrict
518 , HsSrcBang _ SrcUnpack SrcStrict
519 , HsSrcBang _ NoSrcUnpack NoSrcStrictness]
520
521 * However, if T was defined in an imported module, the importing module
522 must follow the decisions made in the original module, regardless of
523 the flag settings in the importing module.
524 Also see Note [Bangs on imported data constructors] in MkId
525
526 * The dcr_bangs field of the dcRep field records the [HsImplBang]
527 If T was defined in this module, Without -O the dcr_bangs might be
528 [HsStrict, HsStrict, HsLazy]
529 With -O it might be
530 [HsStrict, HsUnpack _, HsLazy]
531 With -funbox-small-strict-fields it might be
532 [HsUnpack, HsUnpack _, HsLazy]
533 With -XStrictData it might be
534 [HsStrict, HsUnpack _, HsStrict]
535
536 Note [Data con representation]
537 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
538 The dcRepType field contains the type of the representation of a contructor
539 This may differ from the type of the constructor *Id* (built
540 by MkId.mkDataConId) for two reasons:
541 a) the constructor Id may be overloaded, but the dictionary isn't stored
542 e.g. data Eq a => T a = MkT a a
543
544 b) the constructor may store an unboxed version of a strict field.
545
546 Here's an example illustrating both:
547 data Ord a => T a = MkT Int! a
548 Here
549 T :: Ord a => Int -> a -> T a
550 but the rep type is
551 Trep :: Int# -> a -> T a
552 Actually, the unboxed part isn't implemented yet!
553
554
555
556 ************************************************************************
557 * *
558 \subsection{Instances}
559 * *
560 ************************************************************************
561 -}
562
563 instance Eq DataCon where
564 a == b = getUnique a == getUnique b
565 a /= b = getUnique a /= getUnique b
566
567 instance Ord DataCon where
568 a <= b = getUnique a <= getUnique b
569 a < b = getUnique a < getUnique b
570 a >= b = getUnique a >= getUnique b
571 a > b = getUnique a > getUnique b
572 compare a b = getUnique a `compare` getUnique b
573
574 instance Uniquable DataCon where
575 getUnique = dcUnique
576
577 instance NamedThing DataCon where
578 getName = dcName
579
580 instance Outputable DataCon where
581 ppr con = ppr (dataConName con)
582
583 instance OutputableBndr DataCon where
584 pprInfixOcc con = pprInfixName (dataConName con)
585 pprPrefixOcc con = pprPrefixName (dataConName con)
586
587 instance Data.Data DataCon where
588 -- don't traverse?
589 toConstr _ = abstractConstr "DataCon"
590 gunfold _ _ = error "gunfold"
591 dataTypeOf _ = mkNoRepType "DataCon"
592
593 instance Outputable HsSrcBang where
594 ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark
595
596 instance Outputable HsImplBang where
597 ppr HsLazy = ptext (sLit "Lazy")
598 ppr (HsUnpack Nothing) = ptext (sLit "Unpacked")
599 ppr (HsUnpack (Just co)) = ptext (sLit "Unpacked") <> parens (ppr co)
600 ppr HsStrict = ptext (sLit "StrictNotUnpacked")
601
602 instance Outputable SrcStrictness where
603 ppr SrcLazy = char '~'
604 ppr SrcStrict = char '!'
605 ppr NoSrcStrict = empty
606
607 instance Outputable SrcUnpackedness where
608 ppr SrcUnpack = ptext (sLit "{-# UNPACK #-}")
609 ppr SrcNoUnpack = ptext (sLit "{-# NOUNPACK #-}")
610 ppr NoSrcUnpack = empty
611
612 instance Outputable StrictnessMark where
613 ppr MarkedStrict = ptext (sLit "!")
614 ppr NotMarkedStrict = empty
615
616 instance Binary SrcStrictness where
617 put_ bh SrcLazy = putByte bh 0
618 put_ bh SrcStrict = putByte bh 1
619 put_ bh NoSrcStrict = putByte bh 2
620
621 get bh =
622 do h <- getByte bh
623 case h of
624 0 -> return SrcLazy
625 1 -> return SrcLazy
626 _ -> return NoSrcStrict
627
628 instance Binary SrcUnpackedness where
629 put_ bh SrcNoUnpack = putByte bh 0
630 put_ bh SrcUnpack = putByte bh 1
631 put_ bh NoSrcUnpack = putByte bh 2
632
633 get bh =
634 do h <- getByte bh
635 case h of
636 0 -> return SrcNoUnpack
637 1 -> return SrcUnpack
638 _ -> return NoSrcUnpack
639
640 -- | Compare strictness annotations
641 eqHsBang :: HsImplBang -> HsImplBang -> Bool
642 eqHsBang HsLazy HsLazy = True
643 eqHsBang HsStrict HsStrict = True
644 eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True
645 eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))
646 = eqType (coercionType c1) (coercionType c2)
647 eqHsBang _ _ = False
648
649 isBanged :: HsImplBang -> Bool
650 isBanged (HsUnpack {}) = True
651 isBanged (HsStrict {}) = True
652 isBanged HsLazy = False
653
654 isSrcStrict :: SrcStrictness -> Bool
655 isSrcStrict SrcStrict = True
656 isSrcStrict _ = False
657
658 isSrcUnpacked :: SrcUnpackedness -> Bool
659 isSrcUnpacked SrcUnpack = True
660 isSrcUnpacked _ = False
661
662 isMarkedStrict :: StrictnessMark -> Bool
663 isMarkedStrict NotMarkedStrict = False
664 isMarkedStrict _ = True -- All others are strict
665
666 {-
667 ************************************************************************
668 * *
669 \subsection{Construction}
670 * *
671 ************************************************************************
672 -}
673
674 -- | Build a new data constructor
675 mkDataCon :: Name
676 -> Bool -- ^ Is the constructor declared infix?
677 -> Promoted TyConRepName -- ^ Whether promoted, and if so the TyConRepName
678 -- for the promoted TyCon
679 -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
680 -> [FieldLabel] -- ^ Field labels for the constructor,
681 -- if it is a record, otherwise empty
682 -> [TyVar] -- ^ Universally quantified type variables
683 -> [TyVar] -- ^ Existentially quantified type variables
684 -> [(TyVar,Type)] -- ^ GADT equalities
685 -> ThetaType -- ^ Theta-type occuring before the arguments proper
686 -> [Type] -- ^ Original argument types
687 -> Type -- ^ Original result type
688 -> TyCon -- ^ Representation type constructor
689 -> ThetaType -- ^ The "stupid theta", context of the data
690 -- declaration e.g. @data Eq a => T a ...@
691 -> Id -- ^ Worker Id
692 -> DataConRep -- ^ Representation
693 -> DataCon
694 -- Can get the tag from the TyCon
695
696 mkDataCon name declared_infix prom_info
697 arg_stricts -- Must match orig_arg_tys 1-1
698 fields
699 univ_tvs ex_tvs
700 eq_spec theta
701 orig_arg_tys orig_res_ty rep_tycon
702 stupid_theta work_id rep
703 -- Warning: mkDataCon is not a good place to check invariants.
704 -- If the programmer writes the wrong result type in the decl, thus:
705 -- data T a where { MkT :: S }
706 -- then it's possible that the univ_tvs may hit an assertion failure
707 -- if you pull on univ_tvs. This case is checked by checkValidDataCon,
708 -- so the error is detected properly... it's just that asaertions here
709 -- are a little dodgy.
710
711 = con
712 where
713 is_vanilla = null ex_tvs && null eq_spec && null theta
714 con = MkData {dcName = name, dcUnique = nameUnique name,
715 dcVanilla = is_vanilla, dcInfix = declared_infix,
716 dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
717 dcEqSpec = eq_spec,
718 dcOtherTheta = theta,
719 dcStupidTheta = stupid_theta,
720 dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
721 dcRepTyCon = rep_tycon,
722 dcSrcBangs = arg_stricts,
723 dcFields = fields, dcTag = tag, dcRepType = rep_ty,
724 dcWorkId = work_id,
725 dcRep = rep,
726 dcSourceArity = length orig_arg_tys,
727 dcRepArity = length rep_arg_tys,
728 dcPromoted = mb_promoted }
729
730 -- The 'arg_stricts' passed to mkDataCon are simply those for the
731 -- source-language arguments. We add extra ones for the
732 -- dictionary arguments right here.
733
734 tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
735 rep_arg_tys = dataConRepArgTys con
736 rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
737 mkFunTys rep_arg_tys $
738 mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
739
740 mb_promoted -- See Note [Promoted data constructors] in TyCon
741 = case prom_info of
742 NotPromoted -> NotPromoted
743 Promoted rep_nm -> Promoted (mkPromotedDataCon con name rep_nm prom_kind prom_roles)
744 prom_kind = promoteType (dataConUserType con)
745 prom_roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
746 map (const Representational) orig_arg_tys
747
748 eqSpecPreds :: [(TyVar,Type)] -> ThetaType
749 eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
750
751 -- | The 'Name' of the 'DataCon', giving it a unique, rooted identification
752 dataConName :: DataCon -> Name
753 dataConName = dcName
754
755 -- | The tag used for ordering 'DataCon's
756 dataConTag :: DataCon -> ConTag
757 dataConTag = dcTag
758
759 -- | The type constructor that we are building via this data constructor
760 dataConTyCon :: DataCon -> TyCon
761 dataConTyCon = dcRepTyCon
762
763 -- | The original type constructor used in the definition of this data
764 -- constructor. In case of a data family instance, that will be the family
765 -- type constructor.
766 dataConOrigTyCon :: DataCon -> TyCon
767 dataConOrigTyCon dc
768 | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc
769 | otherwise = dcRepTyCon dc
770
771 -- | The representation type of the data constructor, i.e. the sort
772 -- type that will represent values of this type at runtime
773 dataConRepType :: DataCon -> Type
774 dataConRepType = dcRepType
775
776 -- | Should the 'DataCon' be presented infix?
777 dataConIsInfix :: DataCon -> Bool
778 dataConIsInfix = dcInfix
779
780 -- | The universally-quantified type variables of the constructor
781 dataConUnivTyVars :: DataCon -> [TyVar]
782 dataConUnivTyVars = dcUnivTyVars
783
784 -- | The existentially-quantified type variables of the constructor
785 dataConExTyVars :: DataCon -> [TyVar]
786 dataConExTyVars = dcExTyVars
787
788 -- | Both the universal and existentiatial type variables of the constructor
789 dataConAllTyVars :: DataCon -> [TyVar]
790 dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
791 = univ_tvs ++ ex_tvs
792
793 -- | Equalities derived from the result type of the data constructor, as written
794 -- by the programmer in any GADT declaration
795 dataConEqSpec :: DataCon -> [(TyVar,Type)]
796 dataConEqSpec = dcEqSpec
797
798 -- | The *full* constraints on the constructor type
799 dataConTheta :: DataCon -> ThetaType
800 dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
801 = eqSpecPreds eq_spec ++ theta
802
803 -- | Get the Id of the 'DataCon' worker: a function that is the "actual"
804 -- constructor and has no top level binding in the program. The type may
805 -- be different from the obvious one written in the source program. Panics
806 -- if there is no such 'Id' for this 'DataCon'
807 dataConWorkId :: DataCon -> Id
808 dataConWorkId dc = dcWorkId dc
809
810 -- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"
811 -- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'.
812 -- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor
813 -- and also for a newtype (whose constructor is inlined compulsorily)
814 dataConWrapId_maybe :: DataCon -> Maybe Id
815 dataConWrapId_maybe dc = case dcRep dc of
816 NoDataConRep -> Nothing
817 DCR { dcr_wrap_id = wrap_id } -> Just wrap_id
818
819 -- | Returns an Id which looks like the Haskell-source constructor by using
820 -- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to
821 -- the worker (see 'dataConWorkId')
822 dataConWrapId :: DataCon -> Id
823 dataConWrapId dc = case dcRep dc of
824 NoDataConRep-> dcWorkId dc -- worker=wrapper
825 DCR { dcr_wrap_id = wrap_id } -> wrap_id
826
827 -- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
828 -- the union of the 'dataConWorkId' and the 'dataConWrapId'
829 dataConImplicitTyThings :: DataCon -> [TyThing]
830 dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })
831 = [AnId work] ++ wrap_ids
832 where
833 wrap_ids = case rep of
834 NoDataConRep -> []
835 DCR { dcr_wrap_id = wrap } -> [AnId wrap]
836
837 -- | The labels for the fields of this particular 'DataCon'
838 dataConFieldLabels :: DataCon -> [FieldLabel]
839 dataConFieldLabels = dcFields
840
841 -- | Extract the type for any given labelled field of the 'DataCon'
842 dataConFieldType :: DataCon -> FieldLabelString -> Type
843 dataConFieldType con label
844 = case find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) of
845 Just (_, ty) -> ty
846 Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
847
848 -- | Strictness/unpack annotations, from user; or, for imported
849 -- DataCons, from the interface file
850 -- The list is in one-to-one correspondence with the arity of the 'DataCon'
851
852 dataConSrcBangs :: DataCon -> [HsSrcBang]
853 dataConSrcBangs = dcSrcBangs
854
855 -- | Source-level arity of the data constructor
856 dataConSourceArity :: DataCon -> Arity
857 dataConSourceArity (MkData { dcSourceArity = arity }) = arity
858
859 -- | Gives the number of actual fields in the /representation/ of the
860 -- data constructor. This may be more than appear in the source code;
861 -- the extra ones are the existentially quantified dictionaries
862 dataConRepArity :: DataCon -> Arity
863 dataConRepArity (MkData { dcRepArity = arity }) = arity
864
865
866 -- | The number of fields in the /representation/ of the constructor
867 -- AFTER taking into account the unpacking of any unboxed tuple fields
868 dataConRepRepArity :: DataCon -> RepArity
869 dataConRepRepArity dc = typeRepArity (dataConRepArity dc) (dataConRepType dc)
870
871 -- | Return whether there are any argument types for this 'DataCon's original source type
872 isNullarySrcDataCon :: DataCon -> Bool
873 isNullarySrcDataCon dc = null (dcOrigArgTys dc)
874
875 -- | Return whether there are any argument types for this 'DataCon's runtime representation type
876 isNullaryRepDataCon :: DataCon -> Bool
877 isNullaryRepDataCon dc = dataConRepArity dc == 0
878
879 dataConRepStrictness :: DataCon -> [StrictnessMark]
880 -- ^ Give the demands on the arguments of a
881 -- Core constructor application (Con dc args)
882 dataConRepStrictness dc = case dcRep dc of
883 NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
884 DCR { dcr_stricts = strs } -> strs
885
886 dataConImplBangs :: DataCon -> [HsImplBang]
887 -- The implementation decisions about the strictness/unpack of each
888 -- source program argument to the data constructor
889 dataConImplBangs dc
890 = case dcRep dc of
891 NoDataConRep -> replicate (dcSourceArity dc) HsLazy
892 DCR { dcr_bangs = bangs } -> bangs
893
894 dataConBoxer :: DataCon -> Maybe DataConBoxer
895 dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer
896 dataConBoxer _ = Nothing
897
898 -- | The \"signature\" of the 'DataCon' returns, in order:
899 --
900 -- 1) The result of 'dataConAllTyVars',
901 --
902 -- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit
903 -- parameter - whatever)
904 --
905 -- 3) The type arguments to the constructor
906 --
907 -- 4) The /original/ result type of the 'DataCon'
908 dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
909 dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
910 dcEqSpec = eq_spec, dcOtherTheta = theta,
911 dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
912 = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty)
913
914 dataConInstSig
915 :: DataCon
916 -> [Type] -- Instantiate the *universal* tyvars with these types
917 -> ([TyVar], ThetaType, [Type]) -- Return instantiated existentials
918 -- theta and arg tys
919 -- ^ Instantantiate the universal tyvars of a data con,
920 -- returning the instantiated existentials, constraints, and args
921 dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs
922 , dcEqSpec = eq_spec, dcOtherTheta = theta
923 , dcOrigArgTys = arg_tys })
924 univ_tys
925 = (ex_tvs'
926 , substTheta subst (eqSpecPreds eq_spec ++ theta)
927 , substTys subst arg_tys)
928 where
929 univ_subst = zipTopTvSubst univ_tvs univ_tys
930 (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst ex_tvs
931
932
933 -- | The \"full signature\" of the 'DataCon' returns, in order:
934 --
935 -- 1) The result of 'dataConUnivTyVars'
936 --
937 -- 2) The result of 'dataConExTyVars'
938 --
939 -- 3) The result of 'dataConEqSpec'
940 --
941 -- 4) The result of 'dataConDictTheta'
942 --
943 -- 5) The original argument types to the 'DataCon' (i.e. before
944 -- any change of the representation of the type)
945 --
946 -- 6) The original result type of the 'DataCon'
947 dataConFullSig :: DataCon
948 -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
949 dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
950 dcEqSpec = eq_spec, dcOtherTheta = theta,
951 dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
952 = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
953
954 dataConOrigResTy :: DataCon -> Type
955 dataConOrigResTy dc = dcOrigResTy dc
956
957 -- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in:
958 --
959 -- > data Eq a => T a = ...
960 dataConStupidTheta :: DataCon -> ThetaType
961 dataConStupidTheta dc = dcStupidTheta dc
962
963 dataConUserType :: DataCon -> Type
964 -- ^ The user-declared type of the data constructor
965 -- in the nice-to-read form:
966 --
967 -- > T :: forall a b. a -> b -> T [a]
968 --
969 -- rather than:
970 --
971 -- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c
972 --
973 -- NB: If the constructor is part of a data instance, the result type
974 -- mentions the family tycon, not the internal one.
975 dataConUserType (MkData { dcUnivTyVars = univ_tvs,
976 dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
977 dcOtherTheta = theta, dcOrigArgTys = arg_tys,
978 dcOrigResTy = res_ty })
979 = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
980 mkFunTys theta $
981 mkFunTys arg_tys $
982 res_ty
983
984 -- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation
985 -- NB: these INCLUDE any dictionary args
986 -- but EXCLUDE the data-declaration context, which is discarded
987 -- It's all post-flattening etc; this is a representation type
988 dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints
989 -- However, it can have a dcTheta (notably it can be a
990 -- class dictionary, with superclasses)
991 -> [Type] -- ^ Instantiated at these types
992 -> [Type]
993 dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,
994 dcExTyVars = ex_tvs}) inst_tys
995 = ASSERT2( length univ_tvs == length inst_tys
996 , ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
997 ASSERT2( null ex_tvs, ppr dc )
998 map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)
999
1000 -- | Returns just the instantiated /value/ argument types of a 'DataCon',
1001 -- (excluding dictionary args)
1002 dataConInstOrigArgTys
1003 :: DataCon -- Works for any DataCon
1004 -> [Type] -- Includes existential tyvar args, but NOT
1005 -- equality constraints or dicts
1006 -> [Type]
1007 -- For vanilla datacons, it's all quite straightforward
1008 -- But for the call in MatchCon, we really do want just the value args
1009 dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
1010 dcUnivTyVars = univ_tvs,
1011 dcExTyVars = ex_tvs}) inst_tys
1012 = ASSERT2( length tyvars == length inst_tys
1013 , ptext (sLit "dataConInstOrigArgTys") <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
1014 map (substTyWith tyvars inst_tys) arg_tys
1015 where
1016 tyvars = univ_tvs ++ ex_tvs
1017
1018 -- | Returns the argument types of the wrapper, excluding all dictionary arguments
1019 -- and without substituting for any type variables
1020 dataConOrigArgTys :: DataCon -> [Type]
1021 dataConOrigArgTys dc = dcOrigArgTys dc
1022
1023 -- | Returns the arg types of the worker, including *all* evidence, after any
1024 -- flattening has been done and without substituting for any type variables
1025 dataConRepArgTys :: DataCon -> [Type]
1026 dataConRepArgTys (MkData { dcRep = rep
1027 , dcEqSpec = eq_spec
1028 , dcOtherTheta = theta
1029 , dcOrigArgTys = orig_arg_tys })
1030 = case rep of
1031 NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys
1032 DCR { dcr_arg_tys = arg_tys } -> arg_tys
1033
1034 -- | The string @package:module.name@ identifying a constructor, which is attached
1035 -- to its info table and used by the GHCi debugger and the heap profiler
1036 dataConIdentity :: DataCon -> [Word8]
1037 -- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.
1038 dataConIdentity dc = bytesFS (unitIdFS (moduleUnitId mod)) ++
1039 fromIntegral (ord ':') : bytesFS (moduleNameFS (moduleName mod)) ++
1040 fromIntegral (ord '.') : bytesFS (occNameFS (nameOccName name))
1041 where name = dataConName dc
1042 mod = ASSERT( isExternalName name ) nameModule name
1043
1044 isTupleDataCon :: DataCon -> Bool
1045 isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc
1046
1047 isUnboxedTupleCon :: DataCon -> Bool
1048 isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc
1049
1050 -- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors
1051 isVanillaDataCon :: DataCon -> Bool
1052 isVanillaDataCon dc = dcVanilla dc
1053
1054 classDataCon :: Class -> DataCon
1055 classDataCon clas = case tyConDataCons (classTyCon clas) of
1056 (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
1057 [] -> panic "classDataCon"
1058
1059 dataConCannotMatch :: [Type] -> DataCon -> Bool
1060 -- Returns True iff the data con *definitely cannot* match a
1061 -- scrutinee of type (T tys)
1062 -- where T is the dcRepTyCon for the data con
1063 -- NB: look at *all* equality constraints, not only those
1064 -- in dataConEqSpec; see Trac #5168
1065 dataConCannotMatch tys con
1066 | null inst_theta = False -- Common
1067 | all isTyVarTy tys = False -- Also common
1068 | otherwise = typesCantMatch (concatMap predEqs inst_theta)
1069 where
1070 (_, inst_theta, _) = dataConInstSig con tys
1071
1072 -- TODO: could gather equalities from superclasses too
1073 predEqs pred = case classifyPredType pred of
1074 EqPred NomEq ty1 ty2 -> [(ty1, ty2)]
1075 _ -> []
1076
1077 {-
1078 ************************************************************************
1079 * *
1080 Promotion
1081
1082 These functions are here because
1083 - isPromotableTyCon calls dataConFullSig
1084 - mkDataCon calls promoteType
1085 - It's nice to keep the promotion stuff together
1086 * *
1087 ************************************************************************
1088
1089 Note [The overall promotion story]
1090 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1091 Here is the overall plan.
1092
1093 * Compared to a TyCon T, the promoted 'T has
1094 same Name (and hence Unique)
1095 same TyConRepName
1096 In future the two will collapse into one anyhow.
1097
1098 * Compared to a DataCon K, the promoted 'K (a type constructor) has
1099 same Name (and hence Unique)
1100 But it has a fresh TyConRepName; after all, the DataCon doesn't have
1101 a TyConRepName at all. (See Note [Grand plan for Typeable] in TcTypeable
1102 for TyConRepName.)
1103
1104 Why does 'K have the same unique as K? It's acceptable because we don't
1105 mix types and terms, so we won't get them confused. And it's helpful mainly
1106 so that we know when to print 'K as a qualified name in error message. The
1107 PrintUnqualified stuff depends on whether K is lexically in scope.. but 'K
1108 never is!
1109
1110 * It follows that the tick-mark (eg 'K) is not part of the Occ name of
1111 either promoted data constructors or type constructors. Instead,
1112 pretty-printing: the pretty-printer prints a tick in front of
1113 - promoted DataCons (always)
1114 - promoted TyCons (with -dppr-debug)
1115 See TyCon.pprPromotionQuote
1116
1117 * For a promoted data constructor K, the pipeline goes like this:
1118 User writes (in a type): K or 'K
1119 Parser produces OccName: K{tc} or K{d}, respectively
1120 Renamer makes Name: M.K{d}_r62 (i.e. same unique as DataCon K)
1121 and K{tc} has been turned into K{d}
1122 provided it was unambiguous
1123 Typechecker makes TyCon: PromotedDataCon MK{d}_r62
1124
1125
1126 Note [Checking whether a group is promotable]
1127 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1128 We only want to promote a TyCon if all its data constructors
1129 are promotable; it'd be very odd to promote some but not others.
1130
1131 But the data constructors may mention this or other TyCons.
1132
1133 So we treat the recursive uses as all OK (ie promotable) and
1134 do one pass to check that each TyCon is promotable.
1135
1136 Currently type synonyms are not promotable, though that
1137 could change.
1138 -}
1139
1140 promoteDataCon :: DataCon -> TyCon
1141 promoteDataCon (MkData { dcPromoted = Promoted tc }) = tc
1142 promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc)
1143
1144 promoteDataCon_maybe :: DataCon -> Promoted TyCon
1145 promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc
1146
1147 computeTyConPromotability :: NameSet -> TyCon -> Bool
1148 computeTyConPromotability rec_tycons tc
1149 = isAlgTyCon tc -- Only algebraic; not even synonyms
1150 -- (we could reconsider the latter)
1151 && ok_kind (tyConKind tc)
1152 && case algTyConRhs tc of
1153 DataTyCon { data_cons = cs } -> all ok_con cs
1154 TupleTyCon { data_con = c } -> ok_con c
1155 NewTyCon { data_con = c } -> ok_con c
1156 AbstractTyCon {} -> False
1157 where
1158 ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res
1159 where -- Checks for * -> ... -> * -> *
1160 (args, res) = splitKindFunTys kind
1161
1162 -- See Note [Promoted data constructors] in TyCon
1163 ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs
1164 && null eq_spec -- No constraints
1165 && null theta
1166 && all (isPromotableType rec_tycons) orig_arg_tys
1167 where
1168 (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con
1169
1170
1171 isPromotableType :: NameSet -> Type -> Bool
1172 -- Must line up with promoteType
1173 -- But the function lives here because we must treat the
1174 -- *recursive* tycons as promotable
1175 isPromotableType rec_tcs con_arg_ty
1176 = go con_arg_ty
1177 where
1178 go (TyConApp tc tys) = tys `lengthIs` tyConArity tc
1179 && (tyConName tc `elemNameSet` rec_tcs
1180 || isPromotableTyCon tc)
1181 && all go tys
1182 go (FunTy arg res) = go arg && go res
1183 go (TyVarTy {}) = True
1184 go _ = False
1185
1186 {-
1187 Note [Promoting a Type to a Kind]
1188 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1189 Suppsoe we have a data constructor D
1190 D :: forall (a:*). Maybe a -> T a
1191 We promote this to be a type constructor 'D:
1192 'D :: forall (k:BOX). 'Maybe k -> 'T k
1193
1194 The transformation from type to kind is done by promoteType
1195
1196 * Convert forall (a:*) to forall (k:BOX), and substitute
1197
1198 * Ensure all foralls are at the top (no higher rank stuff)
1199
1200 * Ensure that all type constructors mentioned (Maybe and T
1201 in the example) are promotable; that is, they have kind
1202 * -> ... -> * -> *
1203 -}
1204
1205 -- | Promotes a type to a kind.
1206 -- Assumes the argument satisfies 'isPromotableType'
1207 promoteType :: Type -> Kind
1208 promoteType ty
1209 = mkForAllTys kvs (go rho)
1210 where
1211 (tvs, rho) = splitForAllTys ty
1212 kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ]
1213 env = zipVarEnv tvs kvs
1214
1215 go (TyConApp tc tys) | Promoted prom_tc <- promotableTyCon_maybe tc
1216 = mkTyConApp prom_tc (map go tys)
1217 go (FunTy arg res) = mkArrowKind (go arg) (go res)
1218 go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
1219 = TyVarTy kv
1220 go _ = panic "promoteType" -- Argument did not satisfy isPromotableType
1221
1222 promoteKind :: Kind -> SuperKind
1223 -- Promote the kind of a type constructor
1224 -- from (* -> * -> *) to (BOX -> BOX -> BOX)
1225 promoteKind (TyConApp tc [])
1226 | tc `hasKey` liftedTypeKindTyConKey = superKind
1227 promoteKind (FunTy arg res) = FunTy (promoteKind arg) (promoteKind res)
1228 promoteKind k = pprPanic "promoteKind" (ppr k)
1229
1230 {-
1231 ************************************************************************
1232 * *
1233 \subsection{Splitting products}
1234 * *
1235 ************************************************************************
1236 -}
1237
1238 -- | Extract the type constructor, type argument, data constructor and it's
1239 -- /representation/ argument types from a type if it is a product type.
1240 --
1241 -- Precisely, we return @Just@ for any type that is all of:
1242 --
1243 -- * Concrete (i.e. constructors visible)
1244 --
1245 -- * Single-constructor
1246 --
1247 -- * Not existentially quantified
1248 --
1249 -- Whether the type is a @data@ type or a @newtype@
1250 splitDataProductType_maybe
1251 :: Type -- ^ A product type, perhaps
1252 -> Maybe (TyCon, -- The type constructor
1253 [Type], -- Type args of the tycon
1254 DataCon, -- The data constructor
1255 [Type]) -- Its /representation/ arg types
1256
1257 -- Rejecting existentials is conservative. Maybe some things
1258 -- could be made to work with them, but I'm not going to sweat
1259 -- it through till someone finds it's important.
1260
1261 splitDataProductType_maybe ty
1262 | Just (tycon, ty_args) <- splitTyConApp_maybe ty
1263 , Just con <- isDataProductTyCon_maybe tycon
1264 = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
1265 | otherwise
1266 = Nothing
1267
1268 {-
1269 ************************************************************************
1270 * *
1271 Building an algebraic data type
1272 * *
1273 ************************************************************************
1274
1275 buildAlgTyCon is here because it is called from TysWiredIn, which can
1276 depend on this module, but not on BuildTyCl.
1277 -}
1278
1279 buildAlgTyCon :: Name
1280 -> [TyVar] -- ^ Kind variables and type variables
1281 -> [Role]
1282 -> Maybe CType
1283 -> ThetaType -- ^ Stupid theta
1284 -> AlgTyConRhs
1285 -> RecFlag
1286 -> Bool -- ^ True <=> this TyCon is promotable
1287 -> Bool -- ^ True <=> was declared in GADT syntax
1288 -> AlgTyConFlav
1289 -> TyCon
1290
1291 buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
1292 is_rec is_promotable gadt_syn parent
1293 = tc
1294 where
1295 kind = mkPiKinds ktvs liftedTypeKind
1296
1297 -- tc and mb_promoted_tc are mutually recursive
1298 tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
1299 rhs parent is_rec gadt_syn
1300 mb_promoted_tc
1301
1302 mb_promoted_tc
1303 | is_promotable = Promoted (mkPromotedTyCon tc (promoteKind kind))
1304 | otherwise = NotPromoted