RdrHsSyn.lhs 12.7 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1996-1998
3
4
5
%
\section[RdrHsSyn]{Specialisations of the @HsSyn@ syntax for the reader}

6
(Well, really, for specialisations involving @RdrName@s, even if
7
8
9
10
they are used somewhat later on in the compiler...)

\begin{code}
module RdrHsSyn (
11
12
13
14
	RdrNameArithSeqInfo,
	RdrNameBangType,
	RdrNameClassOpSig,
	RdrNameConDecl,
15
	RdrNameConDetails,
16
17
	RdrNameContext,
	RdrNameDefaultDecl,
sof's avatar
sof committed
18
	RdrNameForeignDecl,
19
	RdrNameGRHS,
20
	RdrNameGRHSs,
21
22
23
24
25
26
27
28
29
30
31
	RdrNameHsBinds,
	RdrNameHsDecl,
	RdrNameHsExpr,
	RdrNameHsModule,
	RdrNameIE,
	RdrNameImportDecl,
	RdrNameInstDecl,
	RdrNameMatch,
	RdrNameMonoBinds,
	RdrNamePat,
	RdrNameHsType,
32
	RdrNameHsTyVar,
33
34
	RdrNameSig,
	RdrNameStmt,
35
	RdrNameTyClDecl,
36
	RdrNameRuleDecl,
37
	RdrNameRuleBndr,
38
	RdrNameDeprecation,
39
	RdrNameHsRecordBinds,
40
	RdrNameFixitySig,
41
42
43
44

	RdrBinding(..),
	RdrMatch(..),
	SigConverter,
45

46
	extractHsTyRdrNames,  extractHsTyRdrTyVars, 
47
	extractHsCtxtRdrTyVars, extractGenericPatTyVars,
48
 
49
	mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
50
	mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
51

52
53
54
	cvBinds,
	cvMonoBindsAndSigs,
	cvTopDecls,
55
56
	cvValSig, cvClassOpSig, cvInstDeclSig,
        mkTyData
57
58
    ) where

59
#include "HsVersions.h"
60

61
import HsSyn		-- Lots of it
62
import OccName		( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
63
                          mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
64
			  mkGenOcc2, 
65
                      	)
66
import PrelNames	( minusName, negateName, fromIntegerName, fromRationalName )
67
import RdrName		( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar )
68
import List		( nub )
69
import BasicTypes	( RecFlag(..) )
70
import Class            ( DefMeth (..) )
71
72
\end{code}

73
74
75
76
77
78
79
 
%************************************************************************
%*									*
\subsection{Type synonyms}
%*									*
%************************************************************************

80
\begin{code}
81
type RdrNameArithSeqInfo	= ArithSeqInfo		RdrName RdrNamePat
82
type RdrNameBangType		= BangType		RdrName
83
84
type RdrNameClassOpSig		= Sig			RdrName
type RdrNameConDecl		= ConDecl		RdrName
85
type RdrNameConDetails		= ConDetails		RdrName
86
type RdrNameContext		= HsContext 		RdrName
87
type RdrNameHsDecl		= HsDecl		RdrName RdrNamePat
88
type RdrNameDefaultDecl		= DefaultDecl		RdrName
sof's avatar
sof committed
89
type RdrNameForeignDecl		= ForeignDecl		RdrName
90
91
92
93
94
type RdrNameGRHS		= GRHS			RdrName RdrNamePat
type RdrNameGRHSs		= GRHSs			RdrName RdrNamePat
type RdrNameHsBinds		= HsBinds		RdrName RdrNamePat
type RdrNameHsExpr		= HsExpr		RdrName RdrNamePat
type RdrNameHsModule		= HsModule		RdrName RdrNamePat
95
96
type RdrNameIE			= IE			RdrName
type RdrNameImportDecl 		= ImportDecl		RdrName
97
98
99
type RdrNameInstDecl		= InstDecl		RdrName RdrNamePat
type RdrNameMatch		= Match			RdrName RdrNamePat
type RdrNameMonoBinds		= MonoBinds		RdrName RdrNamePat
100
type RdrNamePat			= InPat			RdrName
101
type RdrNameHsType		= HsType		RdrName
102
type RdrNameHsTyVar		= HsTyVarBndr		RdrName
103
type RdrNameSig			= Sig			RdrName
104
105
type RdrNameStmt		= Stmt			RdrName RdrNamePat
type RdrNameTyClDecl		= TyClDecl		RdrName RdrNamePat
106

107
108
type RdrNameRuleBndr            = RuleBndr              RdrName
type RdrNameRuleDecl            = RuleDecl              RdrName RdrNamePat
109
110
type RdrNameDeprecation         = DeprecDecl            RdrName
type RdrNameFixitySig		= FixitySig		RdrName
111
112

type RdrNameHsRecordBinds	= HsRecordBinds		RdrName RdrNamePat
113
114
\end{code}

115
116
117
118

%************************************************************************
%*									*
\subsection{A few functions over HsSyn at RdrName}
119
%*                                                                    *
120
121
%************************************************************************

122
@extractHsTyRdrNames@ finds the free variables of a HsType
123
124
125
It's used when making the for-alls explicit.

\begin{code}
126
extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
127
extractHsTyRdrNames ty = nub (extract_ty ty [])
128

129
130
extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
131

132
extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
133
extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
134
135
extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
extractHsCtxtRdrTyVars ty = filter isRdrTyVar (extractHsCtxtRdrNames ty)
136

137
138
extract_ctxt ctxt acc = foldr extract_pred acc ctxt

139
140
extract_pred (HsClassP cls tys) acc	= foldr extract_ty (cls : acc) tys
extract_pred (HsIParam n ty) acc	= extract_ty ty acc
141

142
extract_tys tys = foldr extract_ty [] tys
143

144
145
extract_ty (HsAppTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsListTy ty)              acc = extract_ty ty acc
chak's avatar
chak committed
146
extract_ty (HsPArrTy ty)              acc = extract_ty ty acc
147
148
149
150
extract_ty (HsTupleTy _ tys)          acc = foldr extract_ty acc tys
extract_ty (HsFunTy ty1 ty2)          acc = extract_ty ty1 (extract_ty ty2 acc)
extract_ty (HsPredTy p)		      acc = extract_pred p acc
extract_ty (HsTyVar tv)               acc = tv : acc
151
extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc)
152
-- Generics
153
extract_ty (HsOpTy ty1 nam ty2)       acc = extract_ty ty1 (extract_ty ty2 acc)
154
extract_ty (HsNumTy num)              acc = acc
155
extract_ty (HsKindSig ty k)	      acc = extract_ty ty acc
156
extract_ty (HsForAllTy (Just tvs) ctxt ty) 
157
158
                                acc = acc ++
                                      (filter (`notElem` locals) $
159
160
				       extract_ctxt ctxt (extract_ty ty []))
				    where
161
				      locals = hsTyVarNames tvs
162

163
164
165
166
167
168
169
170
171
172
extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName]
-- Get the type variables out of the type patterns in a bunch of
-- possibly-generic bindings in a class declaration
extractGenericPatTyVars binds
  = filter isRdrTyVar (nub (get binds []))
  where
    get (AndMonoBinds b1 b2)   acc = get b1 (get b2 acc)
    get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
    get other		       acc = acc

173
174
    get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc
    get_m other				 acc = acc
175
176
\end{code}

177
178
179
180
181
182
183

%************************************************************************
%*									*
\subsection{Construction functions for Rdr stuff}
%*                                                                    *
%************************************************************************

184
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
185
186
187
by deriving them from the name of the class.  We fill in the names for the
tycon and datacon corresponding to the class, by deriving them from the
name of the class itself.  This saves recording the names in the interface
188
189
file (which would be equally good).

190
Similarly for mkConDecl, mkClassOpSig and default-method names.
191
192

	*** See "THE NAMING STORY" in HsDecls ****
193
  
194
\begin{code}
195
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
196
197
198
  = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars,
		tcdFDs = fds,  tcdSigs = sigs,  tcdMeths = mbinds,
		tcdSysNames = new_names, tcdLoc = loc }
199
  where
200
201
    cls_occ  = rdrNameOcc cname
    data_occ = mkClassDataConOcc cls_occ
202
203
204
205
    dname    = mkRdrUnqual data_occ
    dwname   = mkRdrUnqual (mkWorkerOcc data_occ)
    tname    = mkRdrUnqual (mkClassTyConOcc   cls_occ)
    sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ) 
206
207
208
209
210
211
212
213
		   | n <- [1..length cxt]]
      -- We number off the superclass selectors, 1, 2, 3 etc so that we 
      -- can construct names for the selectors.  Thus
      --      class (C a, C b) => D a b where ...
      -- gives superclass selectors
      --      D_sc1, D_sc2
      -- (We used to call them D_C, but now we can have two different
      --  superclasses both called C!)
214
    new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
215

216
mkTyData new_or_data (context, tname, tyvars) list_con i maybe src
217
  = let t_occ  = rdrNameOcc tname
218
219
        name1 = mkRdrUnqual (mkGenOcc1 t_occ) 
	name2 = mkRdrUnqual (mkGenOcc2 t_occ) 
220
    in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
221
		tcdTyVars = tyvars, tcdCons = list_con, tcdNCons = i,
222
		tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
223

224
225
mkClassOpSigDM op ty loc
  = ClassOpSig op (DefMeth dm_rn) ty loc
226
  where
227
    dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
228
229
230
231

mkConDecl cname ex_vars cxt details loc
  = ConDecl cname wkr_name ex_vars cxt details loc
  where
232
    wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
233
\end{code}
234

235
236
237
238
239
240
241
242
243
\begin{code}
mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr
-- If the type checker sees (negate 3#) it will barf, because negate
-- can't take an unboxed arg.  But that is exactly what it will see when
-- we write "-3#".  So we have to do the negation right now!

mkHsNegApp (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))    
mkHsNegApp (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))  
mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) 
244
mkHsNegApp expr		  	    = NegApp expr negateName
245
246
247
248
249
250
251
252
\end{code}

A useful function for building @OpApps@.  The operator is always a
variable, and we don't know the fixity yet.

\begin{code}
mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
\end{code}
253

254
255
256
257
258
259
260
261
262
These are the bits of syntax that contain rebindable names
See RnEnv.lookupSyntaxName

\begin{code}
mkHsIntegral   i = HsIntegral   i fromIntegerName
mkHsFractional f = HsFractional f fromRationalName
mkNPlusKPat n k  = NPlusKPatIn n k minusName
\end{code}

263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314

%************************************************************************
%*									*
\subsection[rdrBinding]{Bindings straight out of the parser}
%*									*
%************************************************************************

\begin{code}
data RdrBinding
  =   -- On input we use the Empty/And form rather than a list
    RdrNullBind
  | RdrAndBindings    RdrBinding RdrBinding

      -- Value bindings havn't been united with their
      -- signatures yet
  | RdrValBinding     RdrNameMonoBinds

      -- Signatures are mysterious; we can't
      -- tell if its a Sig or a ClassOpSig,
      -- so we just save the pieces:
  | RdrSig            RdrNameSig

      -- The remainder all fit into the main HsDecl form
  | RdrHsDecl         RdrNameHsDecl
  
type SigConverter = RdrNameSig -> RdrNameSig
\end{code}

\begin{code}
data RdrMatch
  = RdrMatch
	     [RdrNamePat]
	     (Maybe RdrNameHsType)
	     RdrNameGRHSs
\end{code}

%************************************************************************
%*									*
\subsection[cvDecls]{Convert various top-level declarations}
%*									*
%************************************************************************

We make a point not to throw any user-pragma ``sigs'' at
these conversion functions:

\begin{code}
cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter

cvValSig      sig = sig

cvInstDeclSig sig = sig

315
cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
cvClassOpSig sig 		       = sig
\end{code}


%************************************************************************
%*									*
\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
%*									*
%************************************************************************

Function definitions are restructured here. Each is assumed to be recursive
initially, and non recursive definitions are discovered by the dependency
analyser.

\begin{code}
cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds
	-- The mysterious SigConverter converts Sigs to ClassOpSigs
	-- in class declarations.  Mostly it's just an identity function

cvBinds sig_cvtr binding
  = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) ->
    MonoBind mbs sigs Recursive
    }
\end{code}

\begin{code}
cvMonoBindsAndSigs :: SigConverter
		   -> RdrBinding
		   -> (RdrNameMonoBinds, [RdrNameSig])

cvMonoBindsAndSigs sig_cvtr fb
  = mangle_bind (EmptyMonoBinds, []) fb
  where
    mangle_bind acc RdrNullBind
      = acc

    mangle_bind acc (RdrAndBindings fb1 fb2)
      = mangle_bind (mangle_bind acc fb1) fb2

    mangle_bind (b_acc, s_acc) (RdrSig sig)
      = (b_acc, sig_cvtr sig : s_acc)

    mangle_bind (b_acc, s_acc) (RdrValBinding binding)
      = (b_acc `AndMonoBinds` binding, s_acc)
\end{code}


%************************************************************************
%*									*
\subsection[PrefixToHS-utils]{Utilities for conversion}
%*									*
%************************************************************************

Separate declarations into all the various kinds:

\begin{code}
cvTopDecls :: RdrBinding -> [RdrNameHsDecl]
cvTopDecls bind
  = let
	(top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind 
    in
    (ValD (MonoBind mono_binds sigs Recursive) : top_decls)
  where
    go acc		  RdrNullBind		 = acc
    go acc                (RdrAndBindings b1 b2) = go (go acc b1) b2
    go (topds, mbs, sigs) (RdrHsDecl d)		 = (d : topds, mbs, sigs)
    go (topds, mbs, sigs) (RdrSig (FixSig d))    = (FixD d  : topds, mbs, sigs)
    go (topds, mbs, sigs) (RdrSig sig)		 = (topds, mbs, sig:sigs)
    go (topds, mbs, sigs) (RdrValBinding bind)   = (topds, mbs `AndMonoBinds` bind, sigs)
\end{code}