TcTyClsDecls.lhs 9.06 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
%
% (c) The AQUA Project, Glasgow University, 1996
%
\section[TcTyClsDecls]{Typecheck type and class declarations}

\begin{code}
#include "HsVersions.h"

module TcTyClsDecls (
	tcTyAndClassDecls1
    ) where

13
IMP_Ubiq(){-uitous-}
14

sof's avatar
sof committed
15
import HsSyn		( HsDecl(..), TyDecl(..),  ConDecl(..), ConDetails(..), BangType(..),
16
			  ClassDecl(..), HsType(..), HsTyVar, DefaultDecl, InstDecl,
sof's avatar
sof committed
17
18
			  IfaceSig, Sig(..), MonoBinds, Fake, InPat, HsBinds(..), HsExpr, NewOrData,
			  hsDeclName
19
20
			)
import RnHsSyn		( RenamedTyDecl(..), RenamedClassDecl(..), SYN_IE(RenamedHsDecl)
21
			)
sof's avatar
sof committed
22
import TcHsSyn		( SYN_IE(TcHsBinds) )
23

24
import TcMonad
25
import Inst		( SYN_IE(InstanceMapper) )
26
import TcClassDcl	( tcClassDecl1 )
27
import TcEnv		( tcExtendTyConEnv, tcExtendClassEnv )
28
import SpecEnv		( SpecEnv )
29
import TcKind		( TcKind, newKindVars )
30
import TcTyDecls	( tcTyDecl, mkDataBinds )
31
import TcMonoType	( tcTyVarScope )
sof's avatar
sof committed
32
import TcType		( TcIdOcc(..) )
33
34

import Bag	
sof's avatar
sof committed
35
36
import Class		( SYN_IE(Class) )
import Digraph		( stronglyConnComp, SCC(..) )
37
import Name		( Name, getSrcLoc, isTvOcc, nameOccName )
sof's avatar
sof committed
38
import Outputable
39
import Pretty
sof's avatar
sof committed
40
import Maybes		( mapMaybe )
41
import UniqSet		( SYN_IE(UniqSet), emptyUniqSet,
42
			  unitUniqSet, unionUniqSets, 
43
44
			  unionManyUniqSets, uniqSetToList ) 
import SrcLoc		( SrcLoc )
sof's avatar
sof committed
45
import TyCon		( TyCon, SYN_IE(Arity) )
46
import Unique		( Unique, Uniquable(..) )
47
import Util		( panic{-, pprTrace-} )
48
49
50
51
52
53

\end{code}

The main function
~~~~~~~~~~~~~~~~~
\begin{code}
sof's avatar
sof committed
54
tcTyAndClassDecls1 :: TcEnv s -> InstanceMapper	-- Knot tying stuff
55
		   -> [RenamedHsDecl]
56
		   -> TcM s (TcEnv s)
57

sof's avatar
sof committed
58
tcTyAndClassDecls1 unf_env inst_mapper decls
59
  = sortByDependency decls 		`thenTc` \ groups ->
sof's avatar
sof committed
60
    tcGroups unf_env inst_mapper groups
61

sof's avatar
sof committed
62
tcGroups unf_env inst_mapper []
63
64
  = tcGetEnv	`thenNF_Tc` \ env ->
    returnTc env
65

sof's avatar
sof committed
66
67
tcGroups unf_env inst_mapper (group:groups)
  = tcGroup unf_env inst_mapper group	`thenTc` \ new_env ->
68
69
70
71
72

	-- Extend the environment using the new tycons and classes
    tcSetEnv new_env $

	-- Do the remaining groups
sof's avatar
sof committed
73
    tcGroups unf_env inst_mapper groups
74
75
76
77
78
\end{code}

Dealing with a group
~~~~~~~~~~~~~~~~~~~~
\begin{code}
sof's avatar
sof committed
79
80
81
tcGroup :: TcEnv s -> InstanceMapper -> Bag RenamedHsDecl -> TcM s (TcEnv s)
tcGroup unf_env inst_mapper decls
  = 	-- TIE THE KNOT
82
    fixTc ( \ ~(tycons,classes,_) ->
83
84

		-- EXTEND TYPE AND CLASS ENVIRONMENTS
85
86
87
88
89
		-- NB: it's important that the tycons and classes come back in just
		-- the same order from this fix as from get_binders, so that these
		-- extend-env things work properly.  A bit UGH-ish.
      tcExtendTyConEnv tycon_names_w_arities tycons		  $
      tcExtendClassEnv class_names classes			  $
90
91
92
93
94

		-- DEAL WITH TYPE VARIABLES
      tcTyVarScope tyvar_names 			( \ tyvars ->

		-- DEAL WITH THE DEFINITIONS THEMSELVES
sof's avatar
sof committed
95
	foldBag combine (tcDecl unf_env inst_mapper)
96
97
		(returnTc (emptyBag, emptyBag))
		decls
98
99
100
101
102
      )						`thenTc` \ (tycon_bag,class_bag) ->
      let
	tycons = bagToList tycon_bag
	classes = bagToList class_bag
      in 
103

104
105
106
107
		-- SNAFFLE ENV TO RETURN
      tcGetEnv					`thenNF_Tc` \ final_env ->

      returnTc (tycons, classes, final_env)
108
    ) `thenTc` \ (_, _, final_env) ->
109

110
    returnTc final_env
111
112

  where
113
    (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls
114
115
116
117
118
119
120
121
122
123

    combine do_a do_b
      = do_a `thenTc` \ (a1,a2) ->
        do_b `thenTc` \ (b1,b2) ->
	returnTc (a1 `unionBags` b1, a2 `unionBags` b2)
\end{code}

Dealing with one decl
~~~~~~~~~~~~~~~~~~~~~
\begin{code}
sof's avatar
sof committed
124
tcDecl  :: TcEnv s -> InstanceMapper
125
	-> RenamedHsDecl
126
127
	-> TcM s (Bag TyCon, Bag Class)

sof's avatar
sof committed
128
tcDecl unf_env inst_mapper (TyD decl)
129
130
131
  = tcTyDecl decl	`thenTc` \ tycon ->
    returnTc (unitBag tycon, emptyBag)

sof's avatar
sof committed
132
133
tcDecl unf_env inst_mapper (ClD decl)
  = tcClassDecl1 unf_env inst_mapper decl   `thenTc` \ clas ->
134
135
136
137
138
139
    returnTc (emptyBag, unitBag clas)
\end{code}

Dependency analysis
~~~~~~~~~~~~~~~~~~~
\begin{code}
140
141
sortByDependency :: [RenamedHsDecl] -> TcM s [Bag RenamedHsDecl]
sortByDependency decls
142
  = let		-- CHECK FOR SYNONYM CYCLES
sof's avatar
sof committed
143
144
	syn_sccs   = stronglyConnComp (filter is_syn_decl edges)
	syn_cycles = [ decls | CyclicSCC decls <- syn_sccs]
145
146
147
148
149

    in
    checkTc (null syn_cycles) (typeCycleErr syn_cycles)		`thenTc_`

    let		-- CHECK FOR CLASS CYCLES
sof's avatar
sof committed
150
151
	cls_sccs   = stronglyConnComp (filter is_cls_decl edges)
	cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
152
153
154
155
156
157

    in
    checkTc (null cls_cycles) (classCycleErr cls_cycles)	`thenTc_`

		-- DO THE MAIN DEPENDENCY ANALYSIS
    let
sof's avatar
sof committed
158
	decl_sccs  = stronglyConnComp (filter is_ty_cls_decl edges)
159
160
161
	scc_bags   = map bag_acyclic decl_sccs
    in
    returnTc (scc_bags)
162

163
  where
sof's avatar
sof committed
164
    edges = mapMaybe mk_edges decls
165
166
    
bag_acyclic (AcyclicSCC scc) = unitBag scc
sof's avatar
sof committed
167
bag_acyclic (CyclicSCC sccs) = listToBag sccs
168

sof's avatar
sof committed
169
170
is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True
is_syn_decl _		                    = False
171

sof's avatar
sof committed
172
173
174
is_ty_cls_decl (TyD _, _, _) = True
is_ty_cls_decl (ClD _, _, _) = True
is_ty_cls_decl other         = False
175

sof's avatar
sof committed
176
177
is_cls_decl (ClD _, _, _) = True
is_cls_decl other         = False
178
179
180
181
182
\end{code}

Edges in Type/Class decls
~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
sof's avatar
sof committed
183
184
185
186
mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _))
  = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets` 
					 get_cons condecls `unionUniqSets` 
					 get_deriv derivs))
187

sof's avatar
sof committed
188
189
mk_edges decl@(TyD (TySynonym name _ rhs _))
  = Just (decl, uniqueOf name, uniqSetToList (get_ty rhs))
190

sof's avatar
sof committed
191
192
193
mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _))
  = Just (decl, uniqueOf name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
				         get_sigs sigs))
194

sof's avatar
sof committed
195
mk_edges other_decl = Nothing
196

sof's avatar
sof committed
197
get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
198

199
200
201
get_deriv Nothing     = emptyUniqSet
get_deriv (Just clss) = unionManyUniqSets (map set_name clss)

sof's avatar
sof committed
202
203
204
205
get_cons cons = unionManyUniqSets (map get_con cons)

get_con (ConDecl _ ctxt details _) 
  = get_ctxt ctxt `unionUniqSets` get_con_details details
206

sof's avatar
sof committed
207
208
209
210
get_con_details (VanillaCon btys)    = unionManyUniqSets (map get_bty btys)
get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
get_con_details (NewCon ty)          =  get_ty ty
get_con_details (RecCon nbtys)       = unionManyUniqSets (map (get_bty.snd) nbtys)
211
212
213

get_bty (Banged ty)   = get_ty ty
get_bty (Unbanged ty) = get_ty ty
214

215
216
217
218
get_ty (MonoTyVar name)
  = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
get_ty (MonoTyApp ty1 ty2)
  = unionUniqSets (get_ty ty1) (get_ty ty2)
219
220
get_ty (MonoFunTy ty1 ty2)	
  = unionUniqSets (get_ty ty1) (get_ty ty2)
221
222
223
224
225
get_ty (MonoListTy tc ty)
  = set_name tc `unionUniqSets` get_ty ty
get_ty (MonoTupleTy tc tys)
  = set_name tc `unionUniqSets` get_tys tys
get_ty (HsForAllTy _ ctxt mty)
226
  = get_ctxt ctxt `unionUniqSets` get_ty mty
227
get_ty other = panic "TcTyClsDecls:get_ty"
228
229
230
231
232
233
234

get_tys tys
  = unionManyUniqSets (map get_ty tys)

get_sigs sigs
  = unionManyUniqSets (map get_sig sigs)
  where 
235
    get_sig (ClassOpSig _ _ ty _) = get_ty ty
236
237
    get_sig other = panic "TcTyClsDecls:get_sig"

238
set_name name = unitUniqSet (uniqueOf name)
239
240
241
242

set_to_bag set = listToBag (uniqSetToList set)
\end{code}

243
244
245

get_binders
~~~~~~~~~~~
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
Extract *binding* names from type and class decls.  Type variables are
bound in type, data, newtype and class declarations and the polytypes
in the class op sigs.

Why do we need to grab all these type variables at once, including
those locally-quantified type variables in class op signatures?
Because we can only commit to the final kind of a type variable when
we've completed the mutually recursive group. For example:

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.


\begin{code}
267
268
269
270
get_binders :: Bag RenamedHsDecl
	    -> ([HsTyVar Name],		-- TyVars;  no dups
		[(Name, Maybe Arity)],	-- Tycons;  no dups; arities for synonyms
		[Name])			-- Classes; no dups
271
272
273
274
275
276
277
278
279
280

get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
  where
    (tyvars, tycons, classes) = foldBag union3 get_binders1
					(emptyBag,emptyBag,emptyBag)
					decls

    union3 (a1,a2,a3) (b1,b2,b3)
      = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)

sof's avatar
sof committed
281
get_binders1 (TyD (TyData _ _ name tyvars _ _ _ _))
282
 = (listToBag tyvars, unitBag (name,Nothing), emptyBag)
283
get_binders1 (TyD (TySynonym name tyvars _ _))
284
 = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
285
286
287
288
289
290
get_binders1 (ClD (ClassDecl _ name tyvar sigs _ _ _))
 = (unitBag tyvar `unionBags` sigs_tvs sigs,
    emptyBag, unitBag name)

sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
  where 
291
292
293
    sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty
    pty_tvs (HsForAllTy tvs _ _)  = listToBag tvs 	-- tvs doesn't include the class tyvar
    pty_tvs other		  = emptyBag
294
295
296
297
298
\end{code}


\begin{code}
typeCycleErr syn_cycles sty
sof's avatar
sof committed
299
  = vcat (map (pp_cycle sty "Cycle in type declarations ...") syn_cycles)
300
301

classCycleErr cls_cycles sty
sof's avatar
sof committed
302
  = vcat (map (pp_cycle sty "Cycle in class declarations ...") cls_cycles)
303

sof's avatar
sof committed
304
305
306
pp_cycle sty str decls
  = hang (text str)
	 4 (vcat (map pp_decl decls))
307
  where
sof's avatar
sof committed
308
309
310
311
    pp_decl decl
      = hsep [ppr sty name, ppr sty (getSrcLoc name)]
     where
        name = hsDeclName decl
312
\end{code}