RdrHsSyn.lhs 33.9 KB
Newer Older
1
%
2
% (c) The University of Glasgow, 1996-2003
3

4
Functions over HsSyn specialised to RdrName.
5
6
7

\begin{code}
module RdrHsSyn (
8
9
	extractHsTyRdrTyVars, 
	extractHsRhoRdrTyVars, extractGenericPatTyVars,
10
 
11
	mkHsOpApp, mkClassDecl, 
12
	mkHsNegApp, mkHsIntegral, mkHsFractional,
13
	mkHsDo, mkHsSplice,
14
15
        mkTyData, mkPrefixCon, mkRecCon,
	mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
16
	mkBootIface,
17

18
19
	cvBindGroup,
	cvBindsAndSigs,
20
	cvTopDecls,
21
	findSplice, mkGroup,
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

	-- Stuff to do with Foreign declarations
	, CallConv(..)
	, mkImport            -- CallConv -> Safety 
			      -- -> (FastString, RdrName, RdrNameHsType)
			      -- -> P RdrNameHsDecl
	, mkExport            -- CallConv
			      -- -> (FastString, RdrName, RdrNameHsType)
			      -- -> P RdrNameHsDecl
	, mkExtName           -- RdrName -> CLabelString
			      
	-- Bunch of functions in the parser monad for 
	-- checking and constructing values
	, checkPrecP 	      -- Int -> P Int
	, checkContext	      -- HsType -> P HsContext
	, checkPred	      -- HsType -> P HsPred
	, checkTyClHdr	      -- HsType -> (name,[tyvar])
	, checkInstType	      -- HsType -> P HsType
	, checkPattern	      -- HsExp -> P HsPat
	, checkPatterns	      -- SrcLoc -> [HsExp] -> P [HsPat]
	, checkDo	      -- [Stmt] -> P [Stmt]
	, checkMDo	      -- [Stmt] -> P [Stmt]
	, checkValDef	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
	, checkValSig	      -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
	, parseError	      -- String -> Pa
47
48
    ) where

49
#include "HsVersions.h"
50

51
import HsSyn		-- Lots of it
52
53
54
import IfaceType
import HscTypes		( ModIface(..), emptyModIface, mkIfaceVerCache )
import IfaceSyn		( IfaceDecl(..), IfaceIdInfo(..) )
55
import RdrName		( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 
56
			  isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual,
57
58
			  setRdrNameSpace, rdrNameModule )
import BasicTypes	( RecFlag(..), mapIPName, maxPrecedence, initialVersion )
59
import Lexer		( P, failSpanMsgP )
60
61
import HscTypes		( GenAvailInfo(..) )
import TysWiredIn	( unitTyCon ) 
62
import ForeignCall	( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
sof's avatar
sof committed
63
			  DNCallSpec(..), DNKind(..))
64
import OccName  	( OccName, srcDataName, varName, isDataOcc, isTcOcc, 
65
			  occNameUserString, isValOcc )
66
67
68
import BasicTypes	( initialVersion )
import TyCon		( DataConDetails(..) )
import Module		( ModuleName )
69
70
import SrcLoc
import CStrings		( CLabelString )
71
import CmdLineOpts	( opt_InPackage )
72
import OrdList		( OrdList, fromOL )
73
import Bag		( Bag, emptyBag, snocBag, consBag, foldrBag )
74
75
76
import Outputable
import FastString
import Panic
77
78

import List		( isSuffixOf, nubBy )
79
80
\end{code}

81
82
83
84

%************************************************************************
%*									*
\subsection{A few functions over HsSyn at RdrName}
85
%*                                                                    *
86
87
%************************************************************************

88
extractHsTyRdrNames finds the free variables of a HsType
89
90
91
It's used when making the for-alls explicit.

\begin{code}
92
93
extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName]
extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty [])
94

95
extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName]
96
97
-- This one takes the context and tau-part of a 
-- sigma type and returns their free type variables
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
extractHsRhoRdrTyVars ctxt ty 
 = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty [])

extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt)

extract_pred (HsClassP cls tys) acc	= foldr extract_lty acc tys
extract_pred (HsIParam n ty) acc	= extract_lty ty acc

extract_lty (L loc (HsTyVar tv)) acc
  | isRdrTyVar tv = L loc tv : acc
  | otherwise = acc
extract_lty ty acc = extract_ty (unLoc ty) acc

extract_ty (HsAppTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
extract_ty (HsListTy ty)             acc = extract_lty ty acc
extract_ty (HsPArrTy ty)             acc = extract_lty ty acc
extract_ty (HsTupleTy _ tys)         acc = foldr extract_lty acc tys
extract_ty (HsFunTy ty1 ty2)         acc = extract_lty ty1 (extract_lty ty2 acc)
extract_ty (HsPredTy p)		     acc = extract_pred (unLoc p) acc
extract_ty (HsOpTy ty1 nam ty2)      acc = extract_lty ty1 (extract_lty ty2 acc)
extract_ty (HsParTy ty)              acc = extract_lty ty acc
119
extract_ty (HsNumTy num)             acc = acc
120
121
extract_ty (HsKindSig ty k)	     acc = extract_lty ty acc
extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc)
122
extract_ty (HsForAllTy exp tvs cx ty) 
123
124
                                acc = (filter ((`notElem` locals) . unLoc) $
				       extract_lctxt cx (extract_lty ty [])) ++ acc
125
				    where
126
				      locals = hsLTyVarNames tvs
127

128
extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName]
129
130
131
-- Get the type variables out of the type patterns in a bunch of
-- possibly-generic bindings in a class declaration
extractGenericPatTyVars binds
132
  = nubBy eqLocated (foldrBag get [] binds)
133
  where
134
135
    get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms
    get other	               acc = acc
136

137
138
    get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
    get_m other			       		   acc = acc
139
140
\end{code}

141
142
143
144
145
146
147

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

148
mkClassDecl builds a RdrClassDecl, filling in the names for tycon and datacon
149
150
151
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
152
153
file (which would be equally good).

154
Similarly for mkConDecl, mkClassOpSig and default-method names.
155
156

	*** See "THE NAMING STORY" in HsDecls ****
157
  
158
\begin{code}
159
160
mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
  = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars,
161
		tcdFDs = fds,  
162
		tcdSigs = sigs,
163
		tcdMeths = mbinds
164
		}
165

166
167
mkTyData new_or_data (context, tname, tyvars) data_cons maybe
  = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
168
	     tcdTyVars = tyvars,  tcdCons = data_cons, 
169
	     tcdDerivs = maybe }
170
\end{code}
171

172
\begin{code}
173
174
mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName
-- RdrName If the type checker sees (negate 3#) it will barf, because negate
175
176
-- 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!
177
178
179
180
181
mkHsNegApp (L loc e) = f e
  where f (HsLit (HsIntPrim i))    = HsLit (HsIntPrim (-i))    
	f (HsLit (HsFloatPrim i))  = HsLit (HsFloatPrim (-i))  
	f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) 
	f expr	    		   = NegApp (L loc e) placeHolderName
182
\end{code}
183

184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
%************************************************************************
%*									*
		Hi-boot files
%*									*
%************************************************************************

mkBootIface, and its boring helper functions, have two purposes:
a) HsSyn to IfaceSyn.  The parser parses the former, but we're reading
	an hi-boot file, and interfaces consist of the latter
b) Convert unqualifed names from the "current module" to qualified Orig
   names.  E.g.
	module This where
	 foo :: GHC.Base.Int -> GHC.Base.Int
   becomes
	 This.foo :: GHC.Base.Int -> GHC.Base.Int

It assumes that everything is well kinded, of course.

\begin{code}
mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface
-- Make the ModIface for a hi-boot file
-- The decls are of very limited form
mkBootIface mod decls
  = (emptyModIface opt_InPackage mod) {
	mi_boot     = True,
	mi_exports  = [(mod, map mk_export decls')],
	mi_decls    = decls_w_vers,
	mi_ver_fn   = mkIfaceVerCache decls_w_vers }
  where
    decls' = map hsIfaceDecl decls
    decls_w_vers = repeat initialVersion `zip` decls'

		-- hi-boot declarations don't (currently)
		-- expose constructors or class methods
    mk_export decl | isValOcc occ = Avail occ
	           | otherwise    = AvailTC occ [occ]
		   where
		     occ = ifName decl


hsIfaceDecl :: HsDecl RdrName -> IfaceDecl
	-- Change to Iface syntax, and replace unqualified names with
	-- qualified Orig names from this module.  Reason: normal
	-- iface files have everything fully qualified, so it's convenient
	-- for hi-boot files to look the same
	--
	-- NB: no constructors or class ops to worry about
231
232
233
hsIfaceDecl (SigD (Sig name ty)) 
  = IfaceId { ifName = rdrNameOcc (unLoc name),
	      ifType = hsIfaceLType ty,
234
235
236
237
238
	      ifIdInfo = NoInfo }

hsIfaceDecl (TyClD decl@(TySynonym {}))
  = IfaceSyn { ifName = rdrNameOcc (tcdName decl), 
	       ifTyVars = hsIfaceTvs (tcdTyVars decl), 
239
	       ifSynRhs = hsIfaceLType (tcdSynRhs decl), 
240
241
242
243
244
245
	       ifVrcs = [] } 

hsIfaceDecl (TyClD decl@(TyData {}))
  = IfaceData { ifND = tcdND decl, 
	        ifName = rdrNameOcc (tcdName decl), 
	        ifTyVars = hsIfaceTvs (tcdTyVars decl), 
246
		ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
247
248
		ifCons = Unknown, ifRec = NonRecursive,
		ifVrcs = [], ifGeneric = False }
249
250
	-- I'm not sure that [] is right for ifVrcs, but
	-- since we don't use them I'm not going to fiddle
251
252
253
254

hsIfaceDecl (TyClD decl@(ClassDecl {}))
  = IfaceClass { ifName = rdrNameOcc (tcdName decl), 
	         ifTyVars = hsIfaceTvs (tcdTyVars decl), 
255
256
		 ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)),
		 ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)),
257
258
259
260
261
262
263
264
265
266
		 ifSigs = [], 	-- Is this right??
		 ifRec = NonRecursive, ifVrcs = [] }

hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl)

hsIfaceName rdr_name	-- Qualify unqualifed occurrences
				-- with the module name
  | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name)
  | otherwise         = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name)

267
268
269
hsIfaceLType :: LHsType RdrName -> IfaceType
hsIfaceLType = hsIfaceType . unLoc

270
hsIfaceType :: HsType RdrName -> IfaceType	
271
272
hsIfaceType (HsForAllTy exp tvs cxt ty) 
  = foldr (IfaceForAllTy . hsIfaceTv) rho tvs'
273
  where
274
275
    rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt)
    tau = hsIfaceLType ty
276
    tvs' = case exp of
277
278
	     Explicit -> map unLoc tvs
	     Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty)
279
280
281

hsIfaceType ty@(HsTyVar _)     = hs_tc_app ty []
hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty []
282
283
284
285
286
287
hsIfaceType (HsFunTy t1 t2)    = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2)
hsIfaceType (HsListTy t)       = IfaceTyConApp IfaceListTc [hsIfaceLType t]
hsIfaceType (HsPArrTy t)       = IfaceTyConApp IfacePArrTc [hsIfaceLType t]
hsIfaceType (HsTupleTy bx ts)  = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts)
hsIfaceType (HsOpTy t1 tc t2)  = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2])
hsIfaceType (HsParTy t)	       = hsIfaceLType t
288
hsIfaceType (HsNumTy n)	       = panic "hsIfaceType:HsNum"
289
290
hsIfaceType (HsPredTy p)       = IfacePredTy (hsIfaceLPred p)
hsIfaceType (HsKindSig t _)    = hsIfaceLType t
291
292

-----------
293
hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys
294
295

-----------
296
297
hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType]
hsIfaceCtxt ctxt = map hsIfaceLPred ctxt
298
299

-----------
300
301
302
hsIfaceLPred :: LHsPred RdrName -> IfacePredType	
hsIfaceLPred = hsIfacePred . unLoc

303
hsIfacePred :: HsPred RdrName -> IfacePredType	
304
305
hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts)
hsIfacePred (HsIParam ip t)   = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t)
306
307
308

-----------
hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType
309
hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args)
310
311
312
313
314
315
hs_tc_app (HsTyVar n) args
  | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args
  | otherwise		   = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args
hs_tc_app ty args 	   = foldl IfaceAppTy (hsIfaceType ty) args

-----------
316
hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs
317
318
319
320
321
322
323
324
325
326
327

-----------
hsIfaceTv (UserTyVar n)     = (rdrNameOcc n, IfaceLiftedTypeKind)
hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, toIfaceKind k)

-----------
hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])]
hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys)
		 | (xs,ys) <- fds ]
\end{code}

328
329
%************************************************************************
%*									*
330
\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.}
331
332
333
334
335
336
337
338
%*									*
%************************************************************************

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


339
\begin{code}
340
341
342
-- | Groups together bindings for a single function
cvTopDecls :: OrdList (LHsDecl RdrName) -> [LHsDecl RdrName]
cvTopDecls decls = go (fromOL decls)
343
  where
344
345
346
347
348
349
350
    go :: [LHsDecl RdrName] -> [LHsDecl RdrName]
    go [] 		    = []
    go (L l (ValD b) : ds)  = L l' (ValD b') : go ds'
			    where (L l' b', ds') = getMonoBind (L l b) ds
    go (d : ds)   	    = d : go ds

cvBindGroup :: OrdList (LHsDecl RdrName) -> HsBindGroup RdrName
351
352
353
cvBindGroup binding
  = case (cvBindsAndSigs binding) of { (mbs, sigs) ->
    HsBindGroup mbs sigs Recursive -- just one big group for now
354
355
    }

356
357
358
359
cvBindsAndSigs :: OrdList (LHsDecl RdrName)
  -> (Bag (LHsBind RdrName), [LSig RdrName])
-- Input decls contain just value bindings and signatures
cvBindsAndSigs  fb = go (fromOL fb)
360
  where
361
362
363
364
365
366
    go [] 		   = (emptyBag, [])
    go (L l (SigD s) : ds) = (bs, L l s : ss)
			    where (bs,ss) = go ds
    go (L l (ValD b) : ds) = (b' `consBag` bs, ss)
			    where (b',ds') = getMonoBind (L l b) ds
				  (bs,ss)  = go ds'
367
368
369
370

-----------------------------------------------------------------------------
-- Group function bindings into equation groups

371
372
getMonoBind :: LHsBind RdrName -> [LHsDecl RdrName]
  -> (LHsBind RdrName, [LHsDecl RdrName])
373
374
375
376
377
378
379
380
381
382
-- Suppose 	(b',ds') = getMonoBind b ds
-- 	ds is a *reversed* list of parsed bindings
--	b is a MonoBinds that has just been read off the front

-- Then b' is the result of grouping more equations from ds that
-- belong with b into a single MonoBinds, and ds' is the depleted
-- list of parsed bindings.
--
-- No AndMonoBinds or EmptyMonoBinds here; just single equations

383
getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds
384
385
  | has_args mtchs
  = go mtchs loc binds
386
  where
387
    go mtchs1 loc1 (L loc2 (ValD (FunBind f2 inf2 mtchs2)) : binds)
388
	| f == unLoc f2 = go (mtchs2++mtchs1) loc binds
389
	where loc = combineSrcSpans loc1 loc2
390
391
392
    go mtchs1 loc binds
	= (L loc (FunBind lf inf (reverse mtchs1)), binds)
	-- reverse the final matches, to get it back in the right order
393

394
395
getMonoBind bind binds = (bind, binds)

396
397
has_args ((L _ (Match args _ _)) : _) = not (null args)
	-- Don't group together FunBinds if they have
398
	-- no arguments.  This is necessary now that variable bindings
399
	-- with no arguments are now treated as FunBinds rather
400
	-- than pattern bindings (tests/rename/should_fail/rnfail002).
401
402
\end{code}

403
\begin{code}
404
emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive],
405
406
		       hs_tyclds = [], hs_instds = [],
		       hs_fixds = [], hs_defds = [], hs_fords = [], 
407
		       hs_depds = [] ,hs_ruleds = [] }
408

409
410
findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
findSplice ds = addl emptyGroup ds
411

412
mkGroup :: [LHsDecl a] -> HsGroup a
413
414
mkGroup ds = addImpDecls emptyGroup ds

415
addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a
416
-- The decls are imported, and should not have a splice
417
addImpDecls group decls = case addl group decls of
418
419
420
				(group', Nothing) -> group'
				other		  -> panic "addImpDecls"

421
addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))
422
423
424
	-- This stuff reverses the declarations (again) but it doesn't matter

-- Base cases
425
426
427
428
429
430
431
432
addl gp []		   = (gp, Nothing)
addl gp (L l d : ds) = add gp l d ds


add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a]
  -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a]))

add gp l (SpliceD e) ds = (gp, Just (e, ds))
433
434

-- Class declarations: pull out the fixity signatures to the top
435
436
437
438
439
440
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
	| isClassDecl d = 	
		let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
		addl (gp { hs_tyclds = L l d : ts, hs_fixds  = fsigs ++ fs }) ds
	| otherwise =
		addl (gp { hs_tyclds = L l d : ts }) ds
441
442

-- Signatures: fixity sigs go a different place than all others
443
444
445
446
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
  = addl (gp {hs_fixds = L l f : ts}) ds
add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
  = addl (gp {hs_valds = add_sig (L l d) ts}) ds
447
448

-- Value declarations: use add_bind
449
450
add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
  = addl (gp { hs_valds = add_bind (L l d) ts }) ds
451
452

-- The rest are routine
453
454
455
456
457
458
459
460
461
462
463
464
465
add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
  = addl (gp { hs_instds = L l d : ts }) ds
add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
  = addl (gp { hs_defds = L l d : ts }) ds
add gp@(HsGroup {hs_fords  = ts})  l (ForD d) ds
  = addl (gp { hs_fords = L l d : ts }) ds
add gp@(HsGroup {hs_depds  = ts})  l (DeprecD d) ds
  = addl (gp { hs_depds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
  = addl (gp { hs_ruleds = L l d : ts }) ds

add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs     r]
add_sig  s [HsBindGroup bs sigs r] = [HsBindGroup bs	           (s:sigs) r]
466
\end{code}
467
468
469
470
471
472
473
474
475

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


\begin{code}
476
477
478
479
480
481
482
483
-----------------------------------------------------------------------------
-- mkPrefixCon

-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.

484
485
mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
  -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
486
487
488
mkPrefixCon ty tys
 = split ty tys
 where
489
490
491
492
493
494
495
496
497
498
499
500
501
   split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts)
   split (L l (HsTyVar tc))  ts = do data_con <- tyConToDataCon l tc
				     return (data_con, PrefixCon ts)
   split (L l _) _ 		= parseError l "parse error in data/newtype declaration"

mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)]
  -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
mkRecCon (L loc con) fields
  = do data_con <- tyConToDataCon loc con
       return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ])

tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
502
  | isTcOcc (rdrNameOcc tc)
503
  = return (L loc (setRdrNameSpace tc srcDataName))
504
  | otherwise
505
  = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
506
507
508
509

----------------------------------------------------------------------------
-- Various Syntactic Checks

510
511
checkInstType :: LHsType RdrName -> P (LHsType RdrName)
checkInstType (L l t)
512
  = case t of
513
514
515
	HsForAllTy exp tvs ctxt ty -> do
		dict_ty <- checkDictTy ty
	      	return (L l (HsForAllTy exp tvs ctxt dict_ty))
516
517
518

        HsParTy ty -> checkInstType ty

519
520
	ty ->   do dict_ty <- checkDictTy (L l ty)
	      	   return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty))
521

522
checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
523
checkTyVars tvs 
524
  = mapM chk tvs
525
  where
526
	--  Check that the name space is correct!
527
528
529
530
531
532
533
534
535
    chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
	| isRdrTyVar tv = return (L l (KindedTyVar tv k))
    chk (L l (HsTyVar tv))
        | isRdrTyVar tv = return (L l (UserTyVar tv))
    chk (L l other)
	= parseError l "Type found where type variable expected"

checkTyClHdr :: LHsContext RdrName -> LHsType RdrName
  -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName])
536
537
538
539
540
-- The header of a type or class decl should look like
--	(C a, D b) => T a b
-- or	T a b
-- or	a + b
-- etc
541
542
543
544
checkTyClHdr (L l cxt) ty
  = do (tc, tvs) <- gol ty []
       mapM_ chk_pred cxt
       return (L l cxt, tc, tvs)
545
  where
546
547
548
549
550
551
552
553
554
555
    gol (L l ty) acc = go l ty acc

    go l (HsTyVar tc)    acc 
	| not (isRdrTyVar tc)   = checkTyVars acc		>>= \ tvs ->
				  return (L l tc, tvs)
    go l (HsOpTy t1 tc t2) acc  = checkTyVars (t1:t2:acc)	>>= \ tvs ->
				  return (tc, tvs)
    go l (HsParTy ty)    acc    = gol ty acc
    go l (HsAppTy t1 t2) acc    = gol t1 (t2:acc)
    go l other	         acc    = parseError l "Malformed LHS to type of class declaration"
556

557
558
559
	-- The predicates in a type or class decl must all
	-- be HsClassPs.  They need not all be type variables,
	-- even in Haskell 98.  E.g. class (Monad m, Monad (t m)) => MonadT t m
560
561
562
    chk_pred (L l (HsClassP _ args)) = return ()
    chk_pred (L l _)
       = parseError l "Malformed context in type or class declaration"
563
564

  
565
566
567
568
569
570
571
572
573
574
checkContext :: LHsType RdrName -> P (LHsContext RdrName)
checkContext (L l t)
  = check t
 where
  check (HsTupleTy _ ts) 	-- (Eq a, Ord b) shows up as a tuple type
    = do ctx <- mapM checkPred ts
	 return (L l ctx)

  check (HsParTy ty)	-- to be sure HsParTy doesn't get into the way
    = check (unLoc ty)
575

576
577
  check (HsTyVar t)	-- Empty context shows up as a unit type ()
    | t == getRdrName unitTyCon = return (L l [])
578

579
580
581
  check t 
    = do p <- checkPred (L l t)
         return (L l [p])
582
583


584
checkPred :: LHsType RdrName -> P (LHsPred RdrName)
585
586
587
-- Watch out.. in ...deriving( Show )... we use checkPred on 
-- the list of partially applied predicates in the deriving,
-- so there can be zero args.
588
589
590
591
checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) )
  = return (L spn (HsIParam n ty))
checkPred (L spn ty)
  = check spn ty []
592
  where
593
    checkl (L l ty) args = check l ty args
594

595
596
597
598
599
    check loc (HsTyVar t)   args | not (isRdrTyVar t) 
		  	     = return (L spn (HsClassP t args))
    check loc (HsAppTy l r) args = checkl l (r:args)
    check loc (HsParTy t)   args = checkl t args
    check loc _             _    = parseError loc  "malformed class assertion"
600

601
602
603
604
605
606
607
608
checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
checkDictTy (L spn ty) = check ty []
  where
  check (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
  	= return (L spn (HsPredTy (L spn (HsClassP t args))))
  check (HsAppTy l r) args = check (unLoc l) (r:args)
  check (HsParTy t)   args = check (unLoc t) args
  check _ _ = parseError spn "Malformed context in instance header"
609
610
611
612
613
614
615
616
617
618
619
620

---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- 	We parse   do { e1 ; e2 ; }
-- 	as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
--	   (b) transforms it to a ResultStmt
-- same comments apply for mdo as well

checkDo	 = checkDoMDo "a " "'do'"
checkMDo = checkDoMDo "an " "'mdo'"

621
622
623
624
625
626
627
628
629
630
631
checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName]
checkDoMDo pre nm loc []   = parseError loc ("Empty " ++ nm ++ " construct")
checkDoMDo pre nm loc ss   = do 
  check ss
  where 
	check  [L l (ExprStmt e _)] = return [L l (ResultStmt e)]
	check  [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
					 " construct must be an expression")
	check (s:ss) = do
	  ss' <-  check ss
	  return (s:ss')
632

633
-- -------------------------------------------------------------------------
634
635
636
637
638
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
checkPattern e = checkLPat e

checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
checkPatterns es = mapM checkPattern es

checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
checkLPat e@(L l _) = checkPat l e []

checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
checkPat loc (L l (HsVar c)) args
  | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
checkPat loc (L _ (HsApp f x)) args = do
  x <- checkLPat x
  checkPat loc f (x:args)
checkPat loc (L _ e) [] = do
  p <- checkAPat loc e
  return (L loc p)
checkPat loc pat _some_args
  = patFail loc

checkAPat loc e = case e of
   EWildPat	       -> return (WildPat placeHolderType)
   HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
					 ++ showRdrName x)
   	   | otherwise -> return (VarPat x)
   HsLit l 	       -> return (LitPat l)

   -- Overloaded numeric patterns (e.g. f 0 x = x)
   -- Negation is recorded separately, so that the literal is zero or +ve
   -- NB. Negative *primitive* literals are already handled by
   --     RdrHsSyn.mkHsNegApp
   HsOverLit pos_lit            -> return (NPatIn pos_lit Nothing)
   NegApp (L _ (HsOverLit pos_lit)) _ 
			-> return (NPatIn pos_lit (Just placeHolderName))
   
   ELazyPat e	   -> checkLPat e >>= (return . LazyPat)
   EAsPat n e	   -> checkLPat e >>= (return . AsPat n)
   ExprWithTySig e t  -> checkLPat e >>= \e ->
   			 -- Pattern signatures are parsed as sigtypes,
   			 -- but they aren't explicit forall points.  Hence
   			 -- we have to remove the implicit forall here.
   			 let t' = case t of 
   				     L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
   				     other -> other
   			 in
   			 return (SigPatIn e t')
   
   -- n+k patterns
   OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ 
	(L _ (HsOverLit lit@(HsIntegral _ _)))
   		      | plus == plus_RDR
   		      -> return (mkNPlusKPat (L nloc n) lit)
   		      where
   			 plus_RDR = mkUnqual varName FSLIT("+")	-- Hack
   
   OpApp l op fix r   -> checkLPat l >>= \l ->
   			 checkLPat r >>= \r ->
   			 case op of
   			    L cl (HsVar c) | isDataOcc (rdrNameOcc c)
   				   -> return (ConPatIn (L cl c) (InfixCon l r))
   			    _ -> patFail loc
   
   HsPar e		   -> checkLPat e >>= (return . ParPat)
   ExplicitList _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
   			 return (ListPat ps placeHolderType)
   ExplicitPArr _ es  -> mapM (\e -> checkLPat e) es >>= \ps ->
   			 return (PArrPat ps placeHolderType)
   
   ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
   			 return (TuplePat ps b)
   
   RecordCon c fs     -> mapM checkPatField fs >>= \fs ->
			 return (ConPatIn c (RecCon fs))
713
-- Generics 
714
715
   HsType ty          -> return (TypePat ty) 
   _                  -> patFail loc
716

717
checkAPat loc _ = patFail loc
718

719
720
721
722
checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
checkPatField (n,e) = do
  p <- checkLPat e
  return (n,p)
723

724
patFail loc = parseError loc "Parse error in pattern"
725
726
727
728
729
730


---------------------------------------------------------------------------
-- Check Equation Syntax

checkValDef 
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
	:: LHsExpr RdrName
	-> Maybe (LHsType RdrName)
	-> GRHSs RdrName
	-> P (HsBind RdrName)

checkValDef lhs opt_sig grhss
  | Just (f,inf,es)  <- isFunLhs lhs []
  = if isQual (unLoc f)
	then parseError (getLoc f) ("Qualified name in function definition: "  ++ 
					showRdrName (unLoc f))
	else do ps <- checkPatterns es
		return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)])
			-- TODO: span is wrong
  | otherwise = do
	lhs <- checkPattern lhs
	return (PatBind lhs grhss)
747
748

checkValSig
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
	:: LHsExpr RdrName
	-> LHsType RdrName
	-> P (Sig RdrName)
checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
checkValSig (L l other)     ty
  = parseError l "Type signature given for an expression"

-- A variable binding is parsed as a FunBind.

isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
  -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
isFunLhs (L loc e) = isFunLhs' loc e
 where
   isFunLhs' loc (HsVar f) es 
	| not (isRdrDataCon f)	 	= Just (L loc f, False, es)
   isFunLhs' loc (HsApp f e) es 	= isFunLhs f (e:es)
   isFunLhs' loc (HsPar e)   es@(_:_) 	= isFunLhs e es
   isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
	| not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
	| otherwise		= 
		case isFunLhs l es of
		    Just (op', True, j : k : es') ->
		      Just (op', True, 
			    j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
		    _ -> Nothing
   isFunLhs' _ _ _ = Nothing
775
776
777
778

---------------------------------------------------------------------------
-- Miscellaneous utilities

779
780
781
782
checkPrecP :: Located Int -> P Int
checkPrecP (L l i)
 | 0 <= i && i <= maxPrecedence = return i
 | otherwise     	        = parseError l "Precedence out of range"
783
784

mkRecConstrOrUpdate 
785
786
787
788
789
790
791
792
	:: LHsExpr RdrName 
	-> SrcSpan
	-> HsRecordBinds RdrName
	-> P (HsExpr RdrName)

mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
  = return (RecordCon (L l c) fs)
mkRecConstrOrUpdate exp loc fs@(_:_)
793
  = return (RecordUpd exp fs)
794
795
mkRecConstrOrUpdate _ loc []
  = parseError loc "Empty record update"
796
797
798
799
800
801
802
803
804
805
806
807
808

-----------------------------------------------------------------------------
-- utilities for foreign declarations

-- supported calling conventions
--
data CallConv = CCall  CCallConv	-- ccall or stdcall
	      | DNCall			-- .NET

-- construct a foreign import declaration
--
mkImport :: CallConv 
	 -> Safety 
809
810
811
812
813
814
815
816
	 -> (Located FastString, Located RdrName, LHsType RdrName) 
	 -> P (HsDecl RdrName)
mkImport (CCall  cconv) safety (entity, v, ty) = do
  importSpec <- parseCImport entity cconv safety v
  return (ForD (ForeignImport v ty importSpec False))
mkImport (DNCall      ) _      (entity, v, ty) = do
  spec <- parseDImport entity
  return $ ForD (ForeignImport v ty (DNImport spec) False)
817
818
819
820

-- parse the entity string of a foreign import declaration for the `ccall' or
-- `stdcall' calling convention'
--
821
parseCImport :: Located FastString
822
823
	     -> CCallConv 
	     -> Safety 
824
	     -> Located RdrName
825
	     -> P ForeignImport
826
parseCImport (L loc entity) cconv safety v
827
828
  -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
  | entity == FSLIT ("dynamic") = 
829
    return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
830
  | entity == FSLIT ("wrapper") =
831
    return $ CImport cconv safety nilFS nilFS CWrapper
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
  | otherwise		       = parse0 (unpackFS entity)
    where
      -- using the static keyword?
      parse0 (' ':                    rest) = parse0 rest
      parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
      parse0                          rest  = parse1 rest
      -- check for header file name
      parse1     ""               = parse4 ""    nilFS        False nilFS
      parse1     (' ':rest)       = parse1 rest
      parse1 str@('&':_   )       = parse2 str   nilFS
      parse1 str@('[':_   )       = parse3 str   nilFS        False
      parse1 str
	| ".h" `isSuffixOf` first = parse2 rest  (mkFastString first)
        | otherwise               = parse4 str   nilFS        False nilFS
        where
	  (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
      -- check for address operator (indicating a label import)
      parse2     ""         header = parse4 ""   header False nilFS
      parse2     (' ':rest) header = parse2 rest header
      parse2     ('&':rest) header = parse3 rest header True
      parse2 str@('[':_   ) header = parse3 str	 header False
      parse2 str	    header = parse4 str	 header False nilFS
      -- check for library object name
      parse3 (' ':rest) header isLbl = parse3 rest header isLbl
      parse3 ('[':rest) header isLbl = 
        case break (== ']') rest of 
	  (lib, ']':rest)           -> parse4 rest header isLbl (mkFastString lib)
859
	  _			    -> parseError loc "Missing ']' in entity"
860
861
      parse3 str	header isLbl = parse4 str  header isLbl nilFS
      -- check for name of C function
862
863
      parse4 ""         header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib
      parse4 (' ':rest) header isLbl lib = parse4 rest         	       header isLbl lib
864
865
      parse4 str	header isLbl lib
        | all (== ' ') rest              = build (mkFastString first)  header isLbl lib
866
	| otherwise			 = parseError loc "Malformed entity string"
867
868
869
        where
	  (first, rest) = break (== ' ') str
      --
870
      build cid header False lib = return $
871
        CImport cconv safety header lib (CFunction (StaticTarget cid))
872
      build cid header True  lib = return $
873
874
        CImport cconv safety header lib (CLabel                  cid )

sof's avatar
sof committed
875
876
877
--
-- Unravel a dotnet spec string.
--
878
879
parseDImport :: Located FastString -> P DNCallSpec
parseDImport (L loc entity) = parse0 comps
sof's avatar
sof committed
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
 where
  comps = words (unpackFS entity)

  parse0 [] = d'oh
  parse0 (x : xs) 
    | x == "static" = parse1 True xs
    | otherwise     = parse1 False (x:xs)

  parse1 _ [] = d'oh
  parse1 isStatic (x:xs)
    | x == "method" = parse2 isStatic DNMethod xs
    | x == "field"  = parse2 isStatic DNField xs
    | x == "ctor"   = parse2 isStatic DNConstructor xs
  parse1 isStatic xs = parse2 isStatic DNMethod xs

  parse2 _ _ [] = d'oh
  parse2 isStatic kind (('[':x):xs) =
     case x of
	[] -> d'oh
	vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
  parse2 isStatic kind xs = parse3 isStatic kind "" xs

  parse3 isStatic kind assem [x] = 
903
    return (DNCallSpec isStatic kind assem x 
sof's avatar
sof committed
904
905
906
907
908
    			  -- these will be filled in once known.
                        (error "FFI-dotnet-args")
                        (error "FFI-dotnet-result"))
  parse3 _ _ _ _ = d'oh

909
  d'oh = parseError loc "Malformed entity string"
sof's avatar
sof committed
910
  
911
912
913
-- construct a foreign export declaration
--
mkExport :: CallConv
914
915
916
917
         -> (Located FastString, Located RdrName, LHsType RdrName) 
	 -> P (HsDecl RdrName)
mkExport (CCall  cconv) (L loc entity, v, ty) = return $ 
  ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
918
  where
919
    entity' | nullFastString entity = mkExtName (unLoc v)
920
	    | otherwise		    = entity
921
922
923
mkExport DNCall (L loc entity, v, ty) =
  parseError (getLoc v){-TODO: not quite right-}
	"Foreign export is not yet supported for .NET"
924
925
926
927
928
929
930
931
932
933

-- Supplying the ext_name in a foreign decl is optional; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
-- of the Haskell name is then performed, so if you foreign export (++),
-- it's external name will be "++". Too bad; it's important because we don't
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
-- (This is why we use occNameUserString.)
--
mkExtName :: RdrName -> CLabelString
mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
934
\end{code}
935
936
937
938
939
940


-----------------------------------------------------------------------------
-- Misc utils

\begin{code}
941
942
943
showRdrName :: RdrName -> String
showRdrName r = showSDoc (ppr r)

944
945
parseError :: SrcSpan -> String -> P a
parseError span s = failSpanMsgP span s
946
\end{code}