TcTyClsDecls.lhs 63.4 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The AQUA Project, Glasgow University, 1996-1998
4
%
5
6

TcTyClsDecls: Typecheck type and class declarations
7
8
9

\begin{code}
module TcTyClsDecls (
10
	tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
11
12
    ) where

13
#include "HsVersions.h"
14

15
16
17
import HsSyn
import HscTypes
import BuildTyCl
18
import TcUnify
19
import TcRnMonad
20
21
22
23
24
25
import TcEnv
import TcTyDecls
import TcClassDcl
import TcHsType
import TcMType
import TcType
26
import TysWiredIn	( unitTy )
27
28
29
30
31
import Type
import Generics
import Class
import TyCon
import DataCon
32
import Id
33
34
import MkId		( mkDefaultMethodId )
import MkCore		( rEC_SEL_ERROR_ID )
35
import IdInfo
36
37
38
import Var
import VarSet
import Name
sof's avatar
sof committed
39
import Outputable
40
41
42
43
44
45
46
import Maybes
import Unify
import Util
import SrcLoc
import ListSetOps
import Digraph
import DynFlags
47
import FastString
48
49
import Unique		( mkBuiltinUnique )
import BasicTypes
50

51
import Bag
Ian Lynagh's avatar
Ian Lynagh committed
52
import Control.Monad
53
import Data.List
54
55
\end{code}

56
57
58
59
60
61
62

%************************************************************************
%*									*
\subsection{Type checking for type and class declarations}
%*									*
%************************************************************************

63
64
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
Consider a mutually-recursive group, binding 
a type constructor T and a class C.

Step 1: 	getInitialKind
	Construct a KindEnv by binding T and C to a kind variable 

Step 2: 	kcTyClDecl
	In that environment, do a kind check

Step 3: Zonk the kinds

Step 4: 	buildTyConOrClass
	Construct an environment binding T to a TyCon and C to a Class.
	a) Their kinds comes from zonking the relevant kind variable
	b) Their arity (for synonyms) comes direct from the decl
	c) The funcional dependencies come from the decl
	d) The rest comes a knot-tied binding of T and C, returned from Step 4
	e) The variances of the tycons in the group is calculated from 
		the knot-tied stuff

Step 5: 	tcTyClDecl1
	In this environment, walk over the decls, constructing the TyCons and Classes.
	This uses in a strict way items (a)-(c) above, which is why they must
88
89
90
	be constructed in Step 4. Feed the results back to Step 4.
	For this step, pass the is-recursive flag as the wimp-out flag
	to tcTyClDecl1.
91
	
92

93
Step 6:		Extend environment
94
95
96
	We extend the type environment with bindings not only for the TyCons and Classes,
	but also for their "implicit Ids" like data constructors and class selectors

97
98
99
100
101
Step 7:		checkValidTyCl
	For a recursive group only, check all the decls again, just
	to check all the side conditions on validity.  We could not
	do this before because we were in a mutually recursive knot.

102
103
Identification of recursive TyCons
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
104
The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
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
@TyThing@s.

Identifying a TyCon as recursive serves two purposes

1.  Avoid infinite types.  Non-recursive newtypes are treated as
"transparent", like type synonyms, after the type checker.  If we did
this for all newtypes, we'd get infinite types.  So we figure out for
each newtype whether it is "recursive", and add a coercion if so.  In
effect, we are trying to "cut the loops" by identifying a loop-breaker.

2.  Avoid infinite unboxing.  This is nothing to do with newtypes.
Suppose we have
        data T = MkT Int T
        f (MkT x t) = f t
Well, this function diverges, but we don't want the strictness analyser
to diverge.  But the strictness analyser will diverge because it looks
deeper and deeper into the structure of T.   (I believe there are
examples where the function does something sane, and the strictness
analyser still diverges, but I can't see one now.)

Now, concerning (1), the FC2 branch currently adds a coercion for ALL
newtypes.  I did this as an experiment, to try to expose cases in which
the coercions got in the way of optimisations.  If it turns out that we
can indeed always use a coercion, then we don't risk recursive types,
and don't need to figure out what the loop breakers are.

For newtype *families* though, we will always have a coercion, so they
are always loop breakers!  So you can easily adjust the current
algorithm by simply treating all newtype families as loop breakers (and
indeed type families).  I think.
135

136
\begin{code}
137
tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
138
139
   	           -> TcM (TcGblEnv,   	     -- Input env extended by types and classes 
					     -- and their implicit Ids,DataCons
140
141
142
		           HsValBinds Name,  -- Renamed bindings for record selectors
			   [Id])      	     -- Default method ids

143
144
-- Fails if there are any errors

145
tcTyAndClassDecls boot_details allDecls
146
147
148
  = checkNoErrs $ 	-- The code recovers internally, but if anything gave rise to
			-- an error we'd better stop now, to avoid a cascade
    do	{       -- Omit instances of type families; they are handled together
149
		-- with the *heads* of class instances
150
        ; let decls = filter (not . isFamInstDecl . unLoc) allDecls
151
152

        	-- First check for cyclic type synonysm or classes
153
		-- See notes with checkCycleErrs
154
	; checkCycleErrs decls
155
	; mod <- getModule
156
	; traceTc "tcTyAndCl" (ppr mod)
Ian Lynagh's avatar
Ian Lynagh committed
157
	; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) ->
158
159
160
161
162
	  do	{ let {	-- Seperate ordinary synonyms from all other type and
			-- class declarations and add all associated type
			-- declarations from type classes.  The latter is
			-- required so that the temporary environment for the
			-- knot includes all associated family declarations.
163
		      ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc)
164
165
166
						   decls
		      ; alg_at_decls           = concatMap addATs alg_decls
		      }
167
168
169
			-- Extend the global env with the knot-tied results
			-- for data types and classes
			-- 
170
171
172
173
174
			-- We must populate the environment with the loop-tied
			-- T's right away, because the kind checker may "fault
			-- in" some type  constructors that recursively
			-- mention T
		; let gbl_things = mkGlobalThings alg_at_decls rec_alg_tyclss
175
176
177
178
179
		; tcExtendRecEnv gbl_things $ do

			-- Kind-check the declarations
		{ (kc_syn_decls, kc_alg_decls) <- kcTyClDecls syn_decls alg_decls

180
181
		; let {	-- Calculate rec-flag
		      ; calc_rec  = calcRecFlags boot_details rec_alg_tyclss
182
		      ; tc_decl   = addLocM (tcTyClDecl calc_rec) }
183

184
			-- Type-check the type synonyms, and extend the envt
185
		; syn_tycons <- tcSynDecls kc_syn_decls
186
187
188
		; tcExtendGlobalEnv syn_tycons $ do

			-- Type-check the data types and classes
189
		{ alg_tyclss <- mapM tc_decl kc_alg_decls
190
		; return (syn_tycons, concat alg_tyclss)
191
	    }}})
192
193
	-- Finished with knot-tying now
	-- Extend the environment with the finished things
194
	; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
195
196

	-- Perform the validity check
197
	{ traceTc "ready for validity check" empty
198
	; mapM_ (addLocM checkValidTyCl) decls
199
 	; traceTc "done" empty
200
   
201
202
203
	-- Add the implicit things;
	-- we want them in the environment because 
	-- they may be mentioned in interface files
204
205
206
	-- NB: All associated types and their implicit things will be added a
	--     second time here.  This doesn't matter as the definitions are
	--     the same.
207
	; let {	implicit_things = concatMap implicitTyThings alg_tyclss
208
209
	      ; rec_sel_binds   = mkRecSelBinds alg_tyclss
              ; dm_ids          = mkDefaultMethodIds alg_tyclss }
210
211
212
	; traceTc "Adding types and classes" $ vcat
                 [ ppr alg_tyclss 
		 , text "and" <+> ppr implicit_things ]
213
  	; env <- tcExtendGlobalEnv implicit_things getGblEnv
214
	; return (env, rec_sel_binds, dm_ids) }
215
    }
216
  where
217
218
219
220
221
    -- Pull associated types out of class declarations, to tie them into the
    -- knot above.  
    -- NB: We put them in the same place in the list as `tcTyClDecl' will
    --	   eventually put the matching `TyThing's.  That's crucial; otherwise,
    --	   the two argument lists of `mkGlobalThings' don't match up.
222
223
    addATs decl@(L _ (ClassDecl {tcdATs = ats})) = decl : ats
    addATs decl				         = [decl]
224

225
mkGlobalThings :: [LTyClDecl Name] 	-- The decls
226
227
228
229
230
231
	       -> [TyThing]		-- Knot-tied, in 1-1 correspondence with the decls
	       -> [(Name,TyThing)]
-- Driven by the Decls, and treating the TyThings lazily
-- make a TypeEnv for the new things
mkGlobalThings decls things
  = map mk_thing (decls `zipLazy` things)
232
  where
233
    mk_thing (L _ (ClassDecl {tcdLName = L _ name}), ~(AClass cl))
234
	 = (name, AClass cl)
235
    mk_thing (L _ decl, ~(ATyCon tc))
236
         = (tcdName decl, ATyCon tc)
237
\end{code}
238
239


240
241
%************************************************************************
%*									*
242
               Type checking family instances
243
244
245
%*									*
%************************************************************************

246
247
248
249
Family instances are somewhat of a hybrid.  They are processed together with
class instance heads, but can contain data constructors and hence they share a
lot of kinding and type checking code with ordinary algebraic data types (and
GADTs).
250
251

\begin{code}
252
253
tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
tcFamInstDecl top_lvl (L loc decl)
254
  =	-- Prime error recovery, set source location
255
256
    setSrcSpan loc				$
    tcAddDeclCtxt decl				$
257
258
    do { -- type family instances require -XTypeFamilies
	 -- and can't (currently) be in an hs-boot file
259
       ; type_families <- xoptM Opt_TypeFamilies
260
       ; is_boot  <- tcIsHsBoot	  -- Are we compiling an hs-boot file?
Ian Lynagh's avatar
Ian Lynagh committed
261
       ; checkTc type_families $ badFamInstDecl (tcdLName decl)
262
       ; checkTc (not is_boot) $ badBootFamInstDeclErr
263

264
265
266
267
	 -- Perform kind and type checking
       ; tc <- tcFamInstDecl1 decl
       ; checkValidTyCon tc	-- Remember to check validity;
				-- no recursion to worry about here
268
269
270
271
272

       -- Check that toplevel type instances are not for associated types.
       ; when (isTopLevel top_lvl && isAssocFamily tc)
              (addErr $ assocInClassErr (tcdName decl))

273
       ; return (ATyCon tc) }
274

275
276
277
278
279
280
281
282
283
284
285
286
287
isAssocFamily :: TyCon -> Bool	-- Is an assocaited type
isAssocFamily tycon
  = case tyConFamInst_maybe tycon of
          Nothing       -> panic "isAssocFamily: no family?!?"
          Just (fam, _) -> isTyConAssoc fam

assocInClassErr :: Name -> SDoc
assocInClassErr name
 = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
   ptext (sLit "must be inside a class instance")



288
tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
289

290
291
  -- "type instance"
tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
292
293
  = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
    do { -- check that the family declaration is for a synonym
294
         checkTc (isFamilyTyCon family) (notFamily family)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
295
       ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
296

297
       ; -- (1) kind check the right-hand side of the type equation
298
299
       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
       	       	  -- ToDo: the ExpKind could be better
300

301
302
         -- we need the exact same number of type parameters as the family
         -- declaration 
303
       ; let famArity = tyConArity family
304
305
       ; checkTc (length k_typats == famArity) $ 
           wrongNumberOfParmsErr famArity
306

307
308
         -- (2) type check type equation
       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
309
       ; t_typats <- mapM tcHsKindedType k_typats
310
311
       ; t_rhs    <- tcHsKindedType k_rhs

312
         -- (3) check the well-formedness of the instance
313
       ; checkValidTypeInst t_typats t_rhs
314
315

         -- (4) construct representation tycon
316
       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
317
       ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
318
319
                       (typeKind t_rhs) 
                       NoParentTyCon (Just (family, t_typats))
320
       }}
321
322

  -- "newtype instance" and "data instance"
323
324
tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
			     tcdCons = cons})
325
  = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
326
    do { -- check that the family declaration is for the right kind
327
         checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
328
       ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
329
330

       ; -- (1) kind check the data declaration as usual
331
       ; k_decl <- kcDataDecl decl k_tvs
332
333
       ; let k_ctxt = tcdCtxt k_decl
	     k_cons = tcdCons k_decl
334
335

         -- result kind must be '*' (otherwise, we have too few patterns)
336
       ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
337

338
339
         -- (2) type check indexed data type declaration
       ; tcTyVarBndrs k_tvs $ \t_tvs -> do {  -- turn kinded into proper tyvars
340
341
       ; unbox_strict <- doptM Opt_UnboxStrictFields

342
         -- kind check the type indexes and the context
343
       ; t_typats     <- mapM tcHsKindedType k_typats
344
345
346
       ; stupid_theta <- tcHsKindedContext k_ctxt

         -- (3) Check that
347
348
349
         --     (a) left-hand side contains no type family applications
         --         (vanilla synonyms are fine, though, and we checked for
         --         foralls earlier)
350
       ; mapM_ checkTyFamFreeness t_typats
351

352
	 -- Check that we don't use GADT syntax in H98 world
353
       ; gadt_ok <- xoptM Opt_GADTs
354
355
       ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)

356
	 --     (b) a newtype has exactly one constructor
357
       ; checkTc (new_or_data == DataType || isSingleton k_cons) $
358
	         newtypeConError tc_name (length k_cons)
359

360
         -- (4) construct representation tycon
361
       ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
362
       ; let ex_ok = True	-- Existentials ok for type families!
363
364
365
366
       ; fixM (\ rep_tycon -> do 
	     { let orig_res_ty = mkTyConApp fam_tycon t_typats
	     ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
				       (t_tvs, orig_res_ty) k_cons
367
368
369
	     ; tc_rhs <-
		 case new_or_data of
		   DataType -> return (mkDataTyConRhs data_cons)
370
		   NewType  -> ASSERT( not (null data_cons) )
371
			       mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
372
	     ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
373
			     False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
374
375
376
377
378
379
380
381
382
383
                 -- We always assume that indexed types are recursive.  Why?
                 -- (1) Due to their open nature, we can never be sure that a
                 -- further instance might not introduce a new recursive
                 -- dependency.  (2) They are always valid loop breakers as
                 -- they involve a coercion.
	     })
       }}
       where
	 h98_syntax = case cons of 	-- All constructors have same shape
			L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
Ian Lynagh's avatar
Ian Lynagh committed
384
385
386
			_ -> True

tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
387
388
389
390
391
392
393
394

-- Kind checking of indexed types
-- -

-- Kind check type patterns and kind annotate the embedded type variables.
--
-- * Here we check that a type instance matches its kind signature, but we do
--   not check whether there is a pattern for each type index; the latter
395
--   check is only required for type synonym instances.
396

397
kcIdxTyPats :: TyClDecl Name
398
	    -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
399
400
401
402
	       -- ^^kinded tvs         ^^kinded ty pats  ^^res kind
	    -> TcM a
kcIdxTyPats decl thing_inside
  = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
403
404
    do { let tc_name = tcdLName decl
       ; fam_tycon <- tcLookupLocatedTyCon tc_name
405
       ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
406
	     ; hs_typats	= fromJust $ tcdTyPats decl }
407
408
409
410
411
412
413

         -- we may not have more parameters than the kind indicates
       ; checkTc (length kinds >= length hs_typats) $
	   tooManyParmsErr (tcdLName decl)

         -- type functions can have a higher-kinded result
       ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
414
415
416
       ; typats <- zipWithM kcCheckLHsType hs_typats 
       	 	   	    [ EK kind (EkArg (ppr tc_name) n) 
                            | (kind,n) <- kinds `zip` [1..]]
417
       ; thing_inside tvs typats resultKind fam_tycon
418
419
420
421
       }
\end{code}


422
423
%************************************************************************
%*									*
424
		Kind checking
425
426
%*									*
%************************************************************************
427

428
429
We need to kind check all types in the mutually recursive group
before we know the kind of the type variables.  For example:
430
431
432
433
434
435
436
437
438
439
440

class C a where
   op :: D b => a -> b -> b

class D c where
   bop :: (Monad c) => ...

Here, the kind of the locally-polymorphic type variable "b"
depends on *all the uses of class D*.  For example, the use of
Monad c in bop's type signature means that D must have kind Type->Type.

441
442
443
444
445
446
447
448
However type synonyms work differently.  They can have kinds which don't
just involve (->) and *:
	type R = Int#		-- Kind #
	type S a = Array# a	-- Kind * -> #
	type T a b = (# a,b #)	-- Kind * -> * -> (# a,b #)
So we must infer their kinds from their right-hand sides *first* and then
use them, whereas for the mutually recursive data types D we bring into
scope kind bindings D -> k, where k is a kind variable, and do inference.
449

450
Type families
451
452
453
454
~~~~~~~~~~~~~
This treatment of type synonyms only applies to Haskell 98-style synonyms.
General type functions can be recursive, and hence, appear in `alg_decls'.

455
The kind of a type family is solely determinded by its kind signature;
456
457
hence, only kind signatures participate in the construction of the initial
kind environment (as constructed by `getInitialKind').  In fact, we ignore
458
459
instances of families altogether in the following.  However, we need to
include the kinds of associated families into the construction of the
460
461
initial kind environment.  (This is handled by `allDecls').

462
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
463
464
kcTyClDecls :: [LTyClDecl Name] -> [Located (TyClDecl Name)]
            -> TcM ([LTyClDecl Name], [Located (TyClDecl Name)])
465
kcTyClDecls syn_decls alg_decls
466
467
468
  = do	{ 	-- First extend the kind env with each data type, class, and
		-- indexed type, mapping them to a type variable
          let initialKindDecls = concat [allDecls decl | L _ decl <- alg_decls]
469
	; alg_kinds <- mapM getInitialKind initialKindDecls
470
471
472
473
474
475
476
477
478
479
480
	; tcExtendKindEnv alg_kinds $ do

		-- Now kind-check the type synonyms, in dependency order
		-- We do these differently to data type and classes,
		-- because a type synonym can be an unboxed type
		--	type Foo = Int#
		-- and a kind variable can't unify with UnboxedTypeKind
		-- So we infer their kinds in dependency order
	{ (kc_syn_decls, syn_kinds) <- kcSynDecls (calcSynCycles syn_decls)
	; tcExtendKindEnv syn_kinds $  do

481
482
483
484
		-- Now kind-check the data type, class, and kind signatures,
		-- returning kind-annotated decls; we don't kind-check
		-- instances of indexed types yet, but leave this to
		-- `tcInstDecls1'
485
	{ kc_alg_decls <- mapM (wrapLocM kcTyClDecl)
486
			    (filter (not . isFamInstDecl . unLoc) alg_decls)
487
488

	; return (kc_syn_decls, kc_alg_decls) }}}
489
490
491
492
493
  where
    -- get all declarations relevant for determining the initial kind
    -- environment
    allDecls (decl@ClassDecl {tcdATs = ats}) = decl : [ at 
						      | L _ at <- ats
494
495
496
						      , isFamilyDecl at]
    allDecls decl | isFamInstDecl decl = []
		  | otherwise	       = [decl]
497

498
------------------------------------------------------------------------
499
500
501
getInitialKind :: TyClDecl Name -> TcM (Name, TcKind)
-- Only for data type, class, and indexed type declarations
-- Get as much info as possible from the data, class, or indexed type decl,
502
-- so as to maximise usefulness of error messages
503
getInitialKind decl
504
505
506
507
  = do 	{ arg_kinds <- mapM (mk_arg_kind . unLoc) (tyClDeclTyVars decl)
	; res_kind  <- mk_res_kind decl
	; return (tcdName decl, mkArrowKinds arg_kinds res_kind) }
  where
508
    mk_arg_kind (UserTyVar _ _)      = newKindVar
509
510
    mk_arg_kind (KindedTyVar _ kind) = return kind

511
512
513
    mk_res_kind (TyFamily { tcdKind    = Just kind }) = return kind
    mk_res_kind (TyData   { tcdKindSig = Just kind }) = return kind
	-- On GADT-style declarations we allow a kind signature
514
	--	data T :: *->* where { ... }
Ian Lynagh's avatar
Ian Lynagh committed
515
    mk_res_kind _ = return liftedTypeKind
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532


----------------
kcSynDecls :: [SCC (LTyClDecl Name)] 
	   -> TcM ([LTyClDecl Name], 	-- Kind-annotated decls
		   [(Name,TcKind)])	-- Kind bindings
kcSynDecls []
  = return ([], [])
kcSynDecls (group : groups)
  = do	{ (decl,  nk)  <- kcSynDecl group
	; (decls, nks) <- tcExtendKindEnv [nk] (kcSynDecls groups)
	; return (decl:decls, nk:nks) }
			
----------------
kcSynDecl :: SCC (LTyClDecl Name) 
	   -> TcM (LTyClDecl Name, 	-- Kind-annotated decls
		   (Name,TcKind))	-- Kind bindings
Ian Lynagh's avatar
Ian Lynagh committed
533
kcSynDecl (AcyclicSCC (L loc decl))
534
535
  = tcAddDeclCtxt decl	$
    kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
536
    do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) 
537
			<+> brackets (ppr k_tvs))
538
       ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
539
       ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
540
       ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
541
542
543
544
545
546
       ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
		 (unLoc (tcdLName decl), tc_kind)) })

kcSynDecl (CyclicSCC decls)
  = do { recSynErr decls; failM }	-- Fail here to avoid error cascade
					-- of out-of-scope tycons
547

548
549
550
------------------------------------------------------------------------
kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name)
	-- Not used for type synonyms (see kcSynDecl)
551

552
kcTyClDecl decl@(TyData {})
553
  = ASSERT( not . isFamInstDecl $ decl )   -- must not be a family instance
554
555
    kcTyClDeclBody decl	$
      kcDataDecl decl
556

557
558
kcTyClDecl decl@(TyFamily {})
  = kcFamilyDecl [] decl      -- the empty list signals a toplevel decl      
559

560
kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs, tcdATs = ats})
561
  = kcTyClDeclBody decl	$ \ tvs' ->
Ian Lynagh's avatar
Ian Lynagh committed
562
    do	{ ctxt' <- kcHsContext ctxt	
563
564
	; ats'  <- mapM (wrapLocM (kcFamilyDecl tvs')) ats
	; sigs' <- mapM (wrapLocM kc_sig) sigs
565
566
	; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs',
		        tcdATs = ats'}) }
567
  where
568
569
    kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
				   ; return (TypeSig nm op_ty') }
570
571
    kc_sig other_sig	      = return other_sig

572
kcTyClDecl decl@(ForeignType {})
573
574
  = return decl

Ian Lynagh's avatar
Ian Lynagh committed
575
576
kcTyClDecl (TySynonym {}) = panic "kcTyClDecl TySynonym"

577
kcTyClDeclBody :: TyClDecl Name
578
	       -> ([LHsTyVarBndr Name] -> TcM a)
579
	       -> TcM a
580
581
582
583
-- getInitialKind has made a suitably-shaped kind for the type or class
-- Unpack it, and attribute those kinds to the type variables
-- Extend the env with bindings for the tyvars, taken from
-- the kind of the tycon/class.  Give it to the thing inside, and 
584
-- check the result kind matches
585
kcTyClDeclBody decl thing_inside
586
  = tcAddDeclCtxt decl		$
587
    do 	{ tc_ty_thing <- tcLookupLocated (tcdLName decl)
Ian Lynagh's avatar
Ian Lynagh committed
588
	; let tc_kind	 = case tc_ty_thing of
589
590
                             AThing k -> k
                             _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing)
591
592
593
	      (kinds, _) = splitKindFunTys tc_kind
	      hs_tvs 	 = tcdTyVars decl
	      kinded_tvs = ASSERT( length kinds >= length hs_tvs )
594
595
596
597
598
			   zipWith add_kind hs_tvs kinds
	; tcExtendKindEnvTvs kinded_tvs thing_inside }
  where
    add_kind (L loc (UserTyVar n _))   k = L loc (UserTyVar n k)
    add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k)
599
600
601
602
603
604
605
606
607

-- Kind check a data declaration, assuming that we already extended the
-- kind environment with the type variables of the left-hand side (these
-- kinded type variables are also passed as the second parameter).
--
kcDataDecl :: TyClDecl Name -> [LHsTyVarBndr Name] -> TcM (TyClDecl Name)
kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
	   tvs
  = do	{ ctxt' <- kcHsContext ctxt	
608
	; cons' <- mapM (wrapLocM kc_con_decl) cons
609
610
	; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
  where
611
    -- doc comments are typechecked to Nothing here
612
613
    kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
                                  , con_cxt = ex_ctxt, con_details = details, con_res = res })
614
615
616
617
618
619
620
      = addErrCtxt (dataConCtxt name)	$ 
        kcHsTyVars ex_tvs $ \ex_tvs' -> do
        do { ex_ctxt' <- kcHsContext ex_ctxt
           ; details' <- kc_con_details details 
           ; res'     <- case res of
                ResTyH98 -> return ResTyH98
                ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
621
622
           ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
                              , con_details = details', con_res = res' }) }
623
624

    kc_con_details (PrefixCon btys) 
625
	= do { btys' <- mapM kc_larg_ty btys 
626
             ; return (PrefixCon btys') }
627
    kc_con_details (InfixCon bty1 bty2) 
628
629
630
	= do { bty1' <- kc_larg_ty bty1
             ; bty2' <- kc_larg_ty bty2
             ; return (InfixCon bty1' bty2') }
631
    kc_con_details (RecCon fields) 
632
	= do { fields' <- mapM kc_field fields
633
             ; return (RecCon fields') }
634

635
636
    kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty
					   ; return (ConDeclField fld bty' d) }
637
638
639
640
641
642
643

    kc_larg_ty bty = case new_or_data of
			DataType -> kcHsSigType bty
			NewType  -> kcHsLiftedSigType bty
	-- Can't allow an unlifted type for newtypes, because we're effectively
	-- going to remove the constructor while coercing it to a lifted type.
	-- And newtypes can't be bang'd
Ian Lynagh's avatar
Ian Lynagh committed
644
kcDataDecl d _ = pprPanic "kcDataDecl" (ppr d)
645
646
647
648
649
650
651
652
653
654
655
656
657

-- Kind check a family declaration or type family default declaration.
--
kcFamilyDecl :: [LHsTyVarBndr Name]  -- tyvars of enclosing class decl if any
             -> TyClDecl Name -> TcM (TyClDecl Name)
kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind})
  = kcTyClDeclBody decl $ \tvs' ->
    do { mapM_ unifyClassParmKinds tvs'
       ; return (decl {tcdTyVars = tvs', 
		       tcdKind = kind `mplus` Just liftedTypeKind})
		       -- default result kind is '*'
       }
  where
658
659
660
661
662
663
664
    unifyClassParmKinds (L _ tv) 
      | (n,k) <- hsTyVarNameKind tv
      , Just classParmKind <- lookup n classTyKinds 
      = unifyKind k classParmKind
      | otherwise = return ()
    classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs]

Ian Lynagh's avatar
Ian Lynagh committed
665
kcFamilyDecl _ (TySynonym {})              -- type family defaults
666
  = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet"
Ian Lynagh's avatar
Ian Lynagh committed
667
kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d)
668
669
670
671
672
\end{code}


%************************************************************************
%*									*
673
\subsection{Type checking}
674
675
%*									*
%************************************************************************
676
677

\begin{code}
678
679
680
681
682
tcSynDecls :: [LTyClDecl Name] -> TcM [TyThing]
tcSynDecls [] = return []
tcSynDecls (decl : decls) 
  = do { syn_tc <- addLocM tcSynDecl decl
       ; syn_tcs <- tcExtendGlobalEnv [syn_tc] (tcSynDecls decls)
683
684
       ; return (syn_tc : syn_tcs) }

685
  -- "type"
Ian Lynagh's avatar
Ian Lynagh committed
686
tcSynDecl :: TyClDecl Name -> TcM TyThing
687
tcSynDecl
688
689
  (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
  = tcTyVarBndrs tvs		$ \ tvs' -> do 
690
    { traceTc "tcd1" (ppr tc_name) 
691
    ; rhs_ty' <- tcHsKindedType rhs_ty
692
    ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') 
693
      	       		     (typeKind rhs_ty') NoParentTyCon  Nothing
694
695
    ; return (ATyCon tycon) 
    }
Ian Lynagh's avatar
Ian Lynagh committed
696
tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
697
698

--------------------
699
tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
700

701
tcTyClDecl calc_isrec decl
702
  = tcAddDeclCtxt decl (tcTyClDecl1 NoParentTyCon calc_isrec decl)
703

704
  -- "type family" declarations
705
706
tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
tcTyClDecl1 parent _calc_isrec 
707
  (TyFamily {tcdFlavour = TypeFamily, 
708
709
	     tcdLName = L _ tc_name, tcdTyVars = tvs,
             tcdKind = Just kind}) -- NB: kind at latest added during kind checking
710
  = tcTyVarBndrs tvs  $ \ tvs' -> do 
711
  { traceTc "type family:" (ppr tc_name) 
712

713
	-- Check that we don't use families without -XTypeFamilies
714
  ; idx_tys <- xoptM Opt_TypeFamilies
715
  ; checkTc idx_tys $ badFamInstDecl tc_name
716

717
  ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
718
  ; return [ATyCon tycon]
719
  }
720

721
  -- "data family" declaration
722
tcTyClDecl1 parent _calc_isrec 
723
  (TyFamily {tcdFlavour = DataFamily, 
724
	     tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
725
  = tcTyVarBndrs tvs  $ \ tvs' -> do 
726
  { traceTc "data family:" (ppr tc_name) 
727
  ; extra_tvs <- tcDataKindSig mb_kind
728
729
730
  ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these


731
	-- Check that we don't use families without -XTypeFamilies
732
  ; idx_tys <- xoptM Opt_TypeFamilies
733
  ; checkTc idx_tys $ badFamInstDecl tc_name
734
735

  ; tycon <- buildAlgTyCon tc_name final_tvs [] 
736
737
               DataFamilyTyCon Recursive False True 
               parent Nothing
738
  ; return [ATyCon tycon]
739
740
  }

741
  -- "newtype" and "data"
742
  -- NB: not used for newtype/data instances (whether associated or not)
743
tcTyClDecl1 parent calc_isrec
744
  (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
745
746
747
748
	   tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
  = tcTyVarBndrs tvs	$ \ tvs' -> do 
  { extra_tvs <- tcDataKindSig mb_ksig
  ; let final_tvs = tvs' ++ extra_tvs
749
  ; stupid_theta <- tcHsKindedContext ctxt
750
  ; want_generic <- xoptM Opt_Generics
751
  ; unbox_strict <- doptM Opt_UnboxStrictFields
752
753
754
755
  ; empty_data_decls <- xoptM Opt_EmptyDataDecls
  ; kind_signatures <- xoptM Opt_KindSignatures
  ; existential_ok <- xoptM Opt_ExistentialQuantification
  ; gadt_ok      <- xoptM Opt_GADTs
Ian Lynagh's avatar
Ian Lynagh committed
756
  ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
757
  ; is_boot	 <- tcIsHsBoot	-- Are we compiling an hs-boot file?
758
  ; let ex_ok = existential_ok || gadt_ok	-- Data cons can have existential context
759
760

	-- Check that we don't use GADT syntax in H98 world
Ian Lynagh's avatar
Ian Lynagh committed
761
  ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
762

763
	-- Check that we don't use kind signatures without Glasgow extensions
Ian Lynagh's avatar
Ian Lynagh committed
764
  ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
765

766
767
768
	-- Check that the stupid theta is empty for a GADT-style declaration
  ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)

769
770
771
772
773
774
	-- Check that a newtype has exactly one constructor
	-- Do this before checking for empty data decls, so that
	-- we don't suggest -XEmptyDataDecls for newtypes
  ; checkTc (new_or_data == DataType || isSingleton cons) 
	    (newtypeConError tc_name (length cons))

775
	-- Check that there's at least one condecl,
Ian Lynagh's avatar
Ian Lynagh committed
776
777
	-- or else we're reading an hs-boot file, or -XEmptyDataDecls
  ; checkTc (not (null cons) || empty_data_decls || is_boot)
778
779
	    (emptyConDeclsErr tc_name)
    
780
  ; tycon <- fixM (\ tycon -> do 
781
782
783
	{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
	; data_cons <- tcConDecls unbox_strict ex_ok 
				  tycon (final_tvs, res_ty) cons
784
785
786
787
788
	; tc_rhs <-
	    if null cons && is_boot 	-- In a hs-boot file, empty cons means
	    then return AbstractTyCon	-- "don't know"; hence Abstract
	    else case new_or_data of
		   DataType -> return (mkDataTyConRhs data_cons)
789
790
		   NewType  -> ASSERT( not (null data_cons) )
                               mkNewTyConRhs tc_name tycon (head data_cons)
791
	; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
792
793
	    (want_generic && canDoGenerics data_cons) (not h98_syntax) 
            parent Nothing
794
	})
795
  ; return [ATyCon tycon]
796
  }
797
  where
798
    is_rec   = calc_isrec tc_name
799
    h98_syntax = consUseH98Syntax cons
800

801
tcTyClDecl1 _parent calc_isrec 
802
  (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
803
	      tcdCtxt = ctxt, tcdMeths = meths,
804
	      tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
805
806
  = tcTyVarBndrs tvs		$ \ tvs' -> do 
  { ctxt' <- tcHsKindedContext ctxt
807
  ; fds' <- mapM (addLocM tc_fundep) fundeps
808
  ; sig_stuff <- tcClassSigs class_name sigs meths
809
810
  ; clas <- fixM $ \ clas -> do
	    { let 	-- This little knot is just so we can get
811
			-- hold of the name of the class TyCon, which we
812
			-- need to look up its recursiveness
813
814
		    tycon_name = tyConName (classTyCon clas)
		    tc_isrec = calc_isrec tycon_name
815
816
817
818
819
820
821
	    ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
            -- NB: 'ats' only contains "type family" and "data family"
            --     declarations as well as type family defaults
            ; buildClass False {- Must include unfoldings for selectors -}
			 class_name tvs' ctxt' fds' (concat atss')
			 sig_stuff tc_isrec }
  ; return (AClass clas : map ATyCon (classATs clas))
822
823
824
      -- NB: Order is important due to the call to `mkGlobalThings' when
      --     tying the the type and class declaration type checking knot.
  }
825
  where
826
827
    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tcLookupTyVar tvs1 ;
				; tvs2' <- mapM tcLookupTyVar tvs2 ;
828
				; return (tvs1', tvs2') }
829

830
tcTyClDecl1 _ _
831
  (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
832
  = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
833

834
tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
Ian Lynagh's avatar
Ian Lynagh committed
835

836
-----------------------------------
837
838
839
840
841
tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
	   -> [LConDecl Name] -> TcM [DataCon]
tcConDecls unbox ex_ok rep_tycon res_tmpl cons
  = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons

842
tcConDecl :: Bool 		-- True <=> -funbox-strict_fields
843
	  -> Bool		-- True <=> -XExistentialQuantificaton or -XGADTs
844
845
	  -> TyCon 		-- Representation tycon
	  -> ([TyVar], Type)	-- Return type template (with its template tyvars)
846
847
	  -> ConDecl Name 
	  -> TcM DataCon
848

849
tcConDecl unbox_strict existential_ok rep_tycon res_tmpl 	-- Data types
Ian Lynagh's avatar
Ian Lynagh committed
850
	  con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt
851
                   , con_details = details, con_res = res_ty })
852
853
  = addErrCtxt (dataConCtxt name)	$ 
    tcTyVarBndrs tvs			$ \ tvs' -> do 
854
    { ctxt' <- tcHsKindedContext ctxt
Ian Lynagh's avatar
Ian Lynagh committed
855
    ; checkTc (existential_ok || conRepresentibleWithH98Syntax con)
856
	      (badExistential name)
857
    ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty
858
    ; let 
859
	tc_datacon is_infix field_lbls btys
860
	  = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys
861
    	       ; buildDataCon (unLoc name) is_infix
862
    		    stricts field_lbls
863
    		    univ_tvs ex_tvs eq_preds ctxt' arg_tys
864
		    res_ty' rep_tycon }
865
866
867
		-- NB:	we put data_tc, the type constructor gotten from the
		--	constructor type signature into the data constructor;
		--	that way checkValidDataCon can complain if it's wrong.
868

869
    ; case details of
870
	PrefixCon btys     -> tc_datacon False [] btys
871
872
873
	InfixCon bty1 bty2 -> tc_datacon True  [] [bty1,bty2]
	RecCon fields      -> tc_datacon False field_names btys
			   where
874
			      field_names = map (unLoc . cd_fld_name) fields
875
			      btys        = map cd_fld_type fields
876
877
    }

878
879
880
881
882
883
884
885
886
887
-- Example
--   data instance T (b,c) where 
--	TI :: forall e. e -> T (e,e)
--
-- The representation tycon looks like this:
--   data :R7T b c where 
--	TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
-- In this case orig_res_ty = T (e,e)

tcResultType :: ([TyVar], Type)	-- Template for result type; e.g.
888
889
890
				-- data instance T [a] b c = ...  
				--      gives template ([a,b,c], T [a] b c)
	     -> [TyVar] 	-- where MkT :: forall x y z. ...
891
892
	     -> ResType Name
	     -> TcM ([TyVar],	 	-- Universal
893
		     [TyVar],		-- Existential (distinct OccNames from univs)
894
		     [(TyVar,Type)],	-- Equality predicates
895
		     Type)		-- Typechecked return type
896
897
898
899
	-- We don't check that the TyCon given in the ResTy is
	-- the same as the parent tycon, becuase we are in the middle
	-- of a recursive knot; so it's postponed until checkValidDataCon

900
901
tcResultType (tmpl_tvs, res_ty) dc_tvs ResTyH98
  = return (tmpl_tvs, dc_tvs, [], res_ty)
902
903
904
905
	-- In H98 syntax the dc_tvs are the existential ones
	--	data T a b c = forall d e. MkT ...
	-- The {a,b,c} are tc_tvs, and {d,e} are dc_tvs

906
907
908
tcResultType (tmpl_tvs, res_tmpl) dc_tvs (ResTyGADT res_ty)
	-- E.g.  data T [a] b c where
	--	   MkT :: forall x y z. T [(x,y)] z z
909
	-- Then we generate
910
911
912
913
914
	--	Univ tyvars	Eq-spec
	--	    a              a~(x,y)
	--	    b		   b~z
	--	    z		   
	-- Existentials are the leftover type vars: [x,y]
915
	-- So we return ([a,b,z], [x,y], [a~(x,y),b~z], T [(x,y)] z z)
916
917
918
  = do	{ res_ty' <- tcHsKindedType res_ty
	; let Just subst = tcMatchTy (mkVarSet tmpl_tvs) res_tmpl res_ty'

Ian Lynagh's avatar
Ian Lynagh committed
919
		-- /Lazily/ figure out the univ_tvs etc
920
921
922
923
924
925
926
927
928
		-- Each univ_tv is either a dc_tv or a tmpl_tv
	      (univ_tvs, eq_spec) = foldr choose ([], []) tidy_tmpl_tvs
	      choose tmpl (univs, eqs)
		| Just ty <- lookupTyVar subst tmpl 
		= case tcGetTyVar_maybe ty of
		    Just tv | not (tv `elem` univs)
			    -> (tv:univs,   eqs)
		    _other  -> (tmpl:univs, (tmpl,ty):eqs)
		| otherwise = pprPanic "tcResultType" (ppr res_ty)
929
	      ex_tvs = dc_tvs `minusList` univ_tvs
930
931

	; return (univ_tvs, ex_tvs, eq_spec, res_ty') }
932
  where
933
	-- NB: tmpl_tvs and dc_tvs are distinct, but
934
935
936
937
	-- we want them to be *visibly* distinct, both for
	-- interface files and general confusion.  So rename
	-- the tc_tvs, since they are not used yet (no 
	-- consequential renaming needed)
938
939
940
    (_, tidy_tmpl_tvs) = mapAccumL tidy_one init_occ_env tmpl_tvs
    init_occ_env       = initTidyOccEnv (map getOccName dc_tvs)
    tidy_one env tv    = (env', setTyVarName tv (tidyNameOcc name occ'))
941
942
943
944
	      where
		 name = tyVarName tv
		 (env', occ') = tidyOccName env (getOccName name) 

945
946
947
948
949
consUseH98Syntax :: [LConDecl a] -> Bool
consUseH98Syntax (L _ (ConDecl { con_res = ResTyGADT _ }) : _) = False
consUseH98Syntax _                                             = True
		 -- All constructors have same shape

Ian Lynagh's avatar
Ian Lynagh committed
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
conRepresentibleWithH98Syntax
    (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
        = null tvs && null (unLoc ctxt)
conRepresentibleWithH98Syntax
    (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
        = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
    where -- Each type variable should be used exactly once in the
          -- result type, and the result type must just be the type
          -- constructor applied to type variables
          f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs
              = (v2 `elem` vs) && f t1 (delete v2 vs)
          f (HsTyVar _) [] = True
          f _ _ = False

965
966
967
-------------------
tcConArg :: Bool		-- True <=> -funbox-strict_fields
	   -> LHsType Name
968
	   -> TcM (TcType, HsBang)
969
970
971
tcConArg unbox_strict bty
  = do  { arg_ty <- tcHsBangType bty
	; let bang = getBangStrictness bty
972
        ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang
973
	; return (arg_ty, strict_mark) }
974
975
976
977

-- We attempt to unbox/unpack a strict field when either:
--   (i)  The field is marked '!!', or
--   (ii) The field is marked '!', and the -funbox-strict-fields flag is on.
978
979
980
--
-- We have turned off unboxing of newtypes because coercions make unboxing 
-- and reboxing more complicated
981
chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang
982
chooseBoxingStrategy unbox_strict_fields arg_ty bang
983
  = case bang of
984
985
986
987
988
989
	HsNoBang			-> HsNoBang
	HsUnpack                        -> can_unbox HsUnpackFailed arg_ty
	HsStrict | unbox_strict_fields  -> can_unbox HsStrict       arg_ty
		 | otherwise            -> HsStrict
	HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty)
		       	  -- Source code never has shtes
990
  where
991
992
993
994
995
996
997
998
999
1000
    can_unbox :: HsBang -> TcType -> HsBang
    -- Returns   HsUnpack  if we can unpack arg_ty
    -- 		 fail_bang if we know what arg_ty is but we can't unpack it
    -- 		 HsStrict  if it's abstract, so we don't know whether or not we can unbox it
    can_unbox fail_bang arg_ty 
       = case splitTyConApp_maybe arg_ty of
	    Nothing -> fail_bang

	    Just (arg_tycon, tycon_args) 
              | isAbstractTyCon arg_tycon -> HsStrict