2 % (c) The AQUA Project, Glasgow University, 1994-1998
4 \section{Read parse tree built by Yacc parser}
7 module ReadPrefix ( rdModule ) where
9 #include "HsVersions.h"
11 import UgenAll -- all Yacc parser gumpff...
12 import PrefixSyn -- and various syntaxen.
14 import HsTypes ( HsTyVar(..) )
15 import HsPragmas ( noDataPragmas, noClassPragmas )
17 import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
21 import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts )
22 import Name ( OccName, srcTvOcc, srcVarOcc, srcTCOcc,
24 isConOcc, isLexConId, isWildCardOcc
27 import SrcLoc ( SrcLoc )
28 import PrelMods ( pRELUDE )
29 import FastString ( mkFastCharString )
30 import PrelRead ( readRational__ )
33 %************************************************************************
35 \subsection[ReadPrefix-help]{Help Functions}
37 %************************************************************************
40 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
42 wlkList wlk_it U_lnil = returnUgn []
44 wlkList wlk_it (U_lcons hd tl)
45 = wlk_it hd `thenUgn` \ hd_it ->
46 wlkList wlk_it tl `thenUgn` \ tl_it ->
47 returnUgn (hd_it : tl_it)
51 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
53 wlkMaybe wlk_it U_nothing = returnUgn Nothing
54 wlkMaybe wlk_it (U_just x)
55 = wlk_it x `thenUgn` \ it ->
60 wlkTCId = wlkQid srcTCOcc
61 wlkVarId = wlkQid srcVarOcc
62 wlkDataId = wlkQid srcVarOcc
63 wlkEntId = wlkQid (\occ -> if isLexConId occ
67 wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
69 -- There are three kinds of qid:
70 -- qualified name (aqual) A.x
71 -- unqualified name (noqual) x
72 -- special name (gid) [], (), ->, (,,,)
73 -- The special names always mean "Prelude.whatever"; that's why
74 -- they are distinct. So if you write "()", it's just as if you
75 -- had written "Prelude.()".
76 -- NB: The (qualified) prelude is always in scope, so the renamer will find it.
78 -- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
79 -- case we need to unqualify these things. -- SDM.
81 wlkQid mk_occ_name (U_noqual name)
82 = returnUgn (Unqual (mk_occ_name name))
83 wlkQid mk_occ_name (U_aqual mod name)
84 = returnUgn (Qual (mkModuleFS mod) (mk_occ_name name) HiFile)
85 wlkQid mk_occ_name (U_gid n name)
86 | opt_NoImplicitPrelude
87 = returnUgn (Unqual (mk_occ_name name))
89 = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
92 rdTCId pt = rdU_qid pt `thenUgn` wlkTCId
93 rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
95 rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
96 wlkTvId string = returnUgn (Unqual (srcTvOcc string))
98 cvFlag :: U_long -> Bool
103 %************************************************************************
105 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
107 %************************************************************************
110 rdModule :: IO (Module, -- this module's name
111 RdrNameHsModule) -- the main goods
114 = _ccall_ hspmain >>= \ pt -> -- call the Yacc parser!
116 srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
119 rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
120 hmodlist srciface_version srcline) ->
122 mod_name = mkModuleFS mod_fs
125 setSrcFileUgn srcfile $
126 setSrcModUgn mod_name $
127 mkSrcLocUgn srcline $ \ src_loc ->
129 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
130 wlkList rdImport himplist `thenUgn` \ imports ->
131 wlkBinding hmodlist `thenUgn` \ binding ->
134 top_decls = cvTopDecls srcfile binding
138 (case srciface_version of { 0 -> Nothing; n -> Just n })
146 %************************************************************************
148 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
150 %************************************************************************
153 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
154 rdPat :: ParseTree -> UgnM RdrNamePat
156 rdExpr pt = rdU_tree pt `thenUgn` wlkExpr
157 rdPat pt = rdU_tree pt `thenUgn` wlkPat
159 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
160 wlkPat :: U_tree -> UgnM RdrNamePat
164 U_par pexpr -> -- parenthesised expr
165 wlkExpr pexpr `thenUgn` \ expr ->
166 returnUgn (HsPar expr)
168 U_lsection lsexp lop -> -- left section
169 wlkExpr lsexp `thenUgn` \ expr ->
170 wlkVarId lop `thenUgn` \ op ->
171 returnUgn (SectionL expr (HsVar op))
173 U_rsection rop rsexp -> -- right section
174 wlkVarId rop `thenUgn` \ op ->
175 wlkExpr rsexp `thenUgn` \ expr ->
176 returnUgn (SectionR (HsVar op) expr)
178 U_ccall fun flavor ccargs -> -- ccall/casm
179 wlkList rdExpr ccargs `thenUgn` \ args ->
183 returnUgn (CCall fun args
184 (tag == 'p' || tag == 'P') -- may invoke GC
185 (tag == 'N' || tag == 'P') -- really a "casm"
186 (panic "CCall:result_ty"))
188 U_scc label sccexp -> -- scc (set-cost-centre) expression
189 wlkExpr sccexp `thenUgn` \ expr ->
190 returnUgn (HsSCC label expr)
192 U_lambda match -> -- lambda expression
193 wlkMatch match `thenUgn` \ match' ->
194 returnUgn (HsLam match')
196 U_casee caseexpr casebody srcline -> -- case expression
197 mkSrcLocUgn srcline $ \ src_loc ->
198 wlkExpr caseexpr `thenUgn` \ expr ->
199 wlkList rdMatch casebody `thenUgn` \ mats ->
200 returnUgn (HsCase expr mats src_loc)
202 U_ife ifpred ifthen ifelse srcline -> -- if expression
203 mkSrcLocUgn srcline $ \ src_loc ->
204 wlkExpr ifpred `thenUgn` \ e1 ->
205 wlkExpr ifthen `thenUgn` \ e2 ->
206 wlkExpr ifelse `thenUgn` \ e3 ->
207 returnUgn (HsIf e1 e2 e3 src_loc)
209 U_let letvdefs letvexpr -> -- let expression
210 wlkLocalBinding letvdefs `thenUgn` \ binding ->
211 wlkExpr letvexpr `thenUgn` \ expr ->
212 returnUgn (HsLet binding expr)
214 U_doe gdo srcline -> -- do expression
215 mkSrcLocUgn srcline $ \ src_loc ->
216 wlkList rd_stmt gdo `thenUgn` \ stmts ->
217 returnUgn (HsDo DoStmt stmts src_loc)
220 = rdU_tree pt `thenUgn` \ bind ->
222 U_doexp exp srcline ->
223 mkSrcLocUgn srcline $ \ src_loc ->
224 wlkExpr exp `thenUgn` \ expr ->
225 returnUgn (ExprStmt expr src_loc)
227 U_dobind pat exp srcline ->
228 mkSrcLocUgn srcline $ \ src_loc ->
229 wlkPat pat `thenUgn` \ patt ->
230 wlkExpr exp `thenUgn` \ expr ->
231 returnUgn (BindStmt patt expr src_loc)
234 wlkLocalBinding seqlet `thenUgn` \ binds ->
235 returnUgn (LetStmt binds)
237 U_comprh cexp cquals -> -- list comprehension
238 wlkExpr cexp `thenUgn` \ expr ->
239 wlkQuals cquals `thenUgn` \ quals ->
240 getSrcLocUgn `thenUgn` \ loc ->
241 returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
243 U_eenum efrom estep eto -> -- arithmetic sequence
244 wlkExpr efrom `thenUgn` \ e1 ->
245 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
246 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
247 returnUgn (cv_arith_seq e1 es2 es3)
249 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
250 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
251 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
252 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
254 U_restr restre restrt -> -- expression with type signature
255 wlkExpr restre `thenUgn` \ expr ->
256 wlkHsSigType restrt `thenUgn` \ ty ->
257 returnUgn (ExprWithTySig expr ty)
259 --------------------------------------------------------------
260 -- now the prefix items that can either be an expression or
261 -- pattern, except we know they are *expressions* here
262 -- (this code could be commoned up with the pattern version;
263 -- but it probably isn't worth it)
264 --------------------------------------------------------------
266 wlkLiteral lit `thenUgn` \ lit ->
267 returnUgn (HsLit lit)
269 U_ident n -> -- simple identifier
270 wlkVarId n `thenUgn` \ var ->
271 returnUgn (HsVar var)
273 U_ap fun arg -> -- application
274 wlkExpr fun `thenUgn` \ expr1 ->
275 wlkExpr arg `thenUgn` \ expr2 ->
276 returnUgn (HsApp expr1 expr2)
278 U_infixap fun arg1 arg2 -> -- infix application
279 wlkVarId fun `thenUgn` \ op ->
280 wlkExpr arg1 `thenUgn` \ expr1 ->
281 wlkExpr arg2 `thenUgn` \ expr2 ->
282 returnUgn (mkOpApp expr1 op expr2)
284 U_negate nexp -> -- prefix negation
285 wlkExpr nexp `thenUgn` \ expr ->
286 returnUgn (NegApp expr (HsVar dummyRdrVarName))
288 U_llist llist -> -- explicit list
289 wlkList rdExpr llist `thenUgn` \ exprs ->
290 returnUgn (ExplicitList exprs)
292 U_tuple tuplelist -> -- explicit tuple
293 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
294 returnUgn (ExplicitTuple exprs True)
296 U_utuple tuplelist -> -- explicit tuple
297 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
298 returnUgn (ExplicitTuple exprs False)
300 U_record con rbinds -> -- record construction
301 wlkDataId con `thenUgn` \ rcon ->
302 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
303 returnUgn (RecordCon rcon recbinds)
305 U_rupdate updexp updbinds -> -- record update
306 wlkExpr updexp `thenUgn` \ aexp ->
307 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
308 returnUgn (RecordUpd aexp recbinds)
311 U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
312 U_as _ _ -> error "U_as"
313 U_lazyp _ -> error "U_lazyp"
314 U_qual _ _ -> error "U_qual"
315 U_guard _ -> error "U_guard"
316 U_seqlet _ -> error "U_seqlet"
317 U_dobind _ _ _ -> error "U_dobind"
318 U_doexp _ _ -> error "U_doexp"
319 U_rbind _ _ -> error "U_rbind"
323 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
324 wlkVarId var `thenUgn` \ rvar ->
325 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
328 Nothing -> (rvar, HsVar rvar, True{-pun-})
329 Just re -> (rvar, re, False)
333 = wlkList rd_qual cquals
336 = rdU_tree pt `thenUgn` \ qual ->
342 wlkExpr exp `thenUgn` \ expr ->
343 getSrcLocUgn `thenUgn` \ loc ->
344 returnUgn (GuardStmt expr loc)
347 wlkPat qpat `thenUgn` \ pat ->
348 wlkExpr qexp `thenUgn` \ expr ->
349 getSrcLocUgn `thenUgn` \ loc ->
350 returnUgn (BindStmt pat expr loc)
353 wlkLocalBinding seqlet `thenUgn` \ binds ->
354 returnUgn (LetStmt binds)
356 U_let letvdefs letvexpr ->
357 wlkLocalBinding letvdefs `thenUgn` \ binds ->
358 wlkExpr letvexpr `thenUgn` \ expr ->
359 getSrcLocUgn `thenUgn` \ loc ->
360 returnUgn (GuardStmt (HsLet binds expr) loc)
363 Patterns: just bear in mind that lists of patterns are represented as
364 a series of ``applications''.
368 U_par ppat -> -- parenthesised pattern
369 wlkPat ppat `thenUgn` \ pat ->
370 -- tidy things up a little:
375 other -> ParPatIn pat
378 U_as avar as_pat -> -- "as" pattern
379 wlkVarId avar `thenUgn` \ var ->
380 wlkPat as_pat `thenUgn` \ pat ->
381 returnUgn (AsPatIn var pat)
384 wlkPat pat `thenUgn` \ pat' ->
385 wlkHsType ty `thenUgn` \ ty' ->
386 returnUgn (SigPatIn pat' ty')
388 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
389 wlkPat lazyp `thenUgn` \ pat ->
390 returnUgn (LazyPatIn pat)
393 wlkVarId avar `thenUgn` \ var ->
394 wlkLiteral lit `thenUgn` \ lit ->
395 returnUgn (NPlusKPatIn var lit)
397 U_lit lit -> -- literal pattern
398 wlkLiteral lit `thenUgn` \ lit ->
399 returnUgn (LitPatIn lit)
401 U_ident nn -> -- simple identifier
402 wlkVarId nn `thenUgn` \ n ->
403 let occ = rdrNameOcc n in
408 if (isWildCardOcc occ) then WildPatIn else (VarPatIn n)
411 U_ap l r -> -- "application": there's a list of patterns lurking here!
412 wlkPat r `thenUgn` \ rpat ->
413 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
415 VarPatIn x -> returnUgn (x, lpats)
416 ConPatIn x [] -> returnUgn (x, lpats)
417 ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
418 _ -> getSrcLocUgn `thenUgn` \ loc ->
419 pprPanic "Illegal pattern `application'"
420 (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
422 ) `thenUgn` \ (n, arg_pats) ->
423 returnUgn (ConPatIn n arg_pats)
428 wlkPat r `thenUgn` \ rpat ->
429 collect_pats l (rpat:acc)
433 wlkPat other `thenUgn` \ pat ->
436 U_infixap fun arg1 arg2 -> -- infix pattern
437 wlkVarId fun `thenUgn` \ op ->
438 wlkPat arg1 `thenUgn` \ pat1 ->
439 wlkPat arg2 `thenUgn` \ pat2 ->
440 returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
442 U_negate npat -> -- negated pattern
443 wlkPat npat `thenUgn` \ pat ->
444 returnUgn (NegPatIn pat)
446 U_llist llist -> -- explicit list
447 wlkList rdPat llist `thenUgn` \ pats ->
448 returnUgn (ListPatIn pats)
450 U_tuple tuplelist -> -- explicit tuple
451 wlkList rdPat tuplelist `thenUgn` \ pats ->
452 returnUgn (TuplePatIn pats True)
454 U_utuple tuplelist -> -- explicit tuple
455 wlkList rdPat tuplelist `thenUgn` \ pats ->
456 returnUgn (TuplePatIn pats False)
458 U_record con rpats -> -- record destruction
459 wlkDataId con `thenUgn` \ rcon ->
460 wlkList rdRpat rpats `thenUgn` \ recpats ->
461 returnUgn (RecPatIn rcon recpats)
464 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
465 wlkVarId var `thenUgn` \ rvar ->
466 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
469 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
470 Just rp -> (rvar, rp, False)
475 wlkLiteral :: U_literal -> UgnM HsLit
480 U_integer s -> HsInt (as_integer s)
481 U_floatr s -> HsFrac (as_rational s)
482 U_intprim s -> HsIntPrim (as_integer s)
483 U_doubleprim s -> HsDoublePrim (as_rational s)
484 U_floatprim s -> HsFloatPrim (as_rational s)
485 U_charr s -> HsChar (as_char s)
486 U_charprim s -> HsCharPrim (as_char s)
487 U_string s -> HsString (as_string s)
488 U_stringprim s -> HsStringPrim (as_string s)
489 U_clitlit s -> HsLitLit (as_string s)
493 as_integer s = readInteger (_UNPK_ s)
494 as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
495 -- to handle rationals with leading '-'
499 %************************************************************************
501 \subsection{wlkBinding}
503 %************************************************************************
507 = wlkBinding bind `thenUgn` \ bind' ->
508 getSrcFileUgn `thenUgn` \ sf ->
509 returnUgn (cvBinds sf cvValSig bind')
511 wlkBinding :: U_binding -> UgnM RdrBinding
517 returnUgn RdrNullBind
519 -- "and" binding (just glue, really)
521 wlkBinding a `thenUgn` \ binding1 ->
522 wlkBinding b `thenUgn` \ binding2 ->
523 returnUgn (RdrAndBindings binding1 binding2)
525 -- fixity declaration
526 U_fixd op dir_n prec srcline ->
533 wlkVarId op `thenUgn` \ op ->
534 mkSrcLocUgn srcline $ \ src_loc ->
535 returnUgn (RdrSig (FixSig (FixitySig op (Fixity prec dir) src_loc)))
538 -- "data" declaration
539 U_tbind tctxt ttype tcons tderivs srcline ->
540 mkSrcLocUgn srcline $ \ src_loc ->
541 wlkContext tctxt `thenUgn` \ ctxt ->
542 wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
543 wlkList rdConDecl tcons `thenUgn` \ cons ->
544 wlkDerivings tderivs `thenUgn` \ derivings ->
545 returnUgn (RdrTyClDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
547 -- "newtype" declaration
548 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
549 mkSrcLocUgn srcline $ \ src_loc ->
550 wlkContext ntctxt `thenUgn` \ ctxt ->
551 wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
552 wlkList rdConDecl ntcon `thenUgn` \ cons ->
553 wlkDerivings ntderivs `thenUgn` \ derivings ->
554 returnUgn (RdrTyClDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
556 -- "type" declaration
557 U_nbind nbindid nbindas srcline ->
558 mkSrcLocUgn srcline $ \ src_loc ->
559 wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
560 wlkHsType nbindas `thenUgn` \ expansion ->
561 returnUgn (RdrTyClDecl (TySynonym tycon tyvars expansion src_loc))
564 U_fbind fbindm srcline ->
565 mkSrcLocUgn srcline $ \ src_loc ->
566 wlkList rdMatch fbindm `thenUgn` \ matches ->
567 returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc))
570 U_pbind pbindl pbindr srcline ->
571 mkSrcLocUgn srcline $ \ src_loc ->
572 rdPat pbindl `thenUgn` \ pat ->
573 rdGRHSs pbindr `thenUgn` \ grhss ->
574 returnUgn (RdrValBinding (PatMonoBind pat grhss src_loc))
576 -- "class" declaration
577 U_cbind cbindc cbindid cbindw srcline ->
578 mkSrcLocUgn srcline $ \ src_loc ->
579 wlkContext cbindc `thenUgn` \ ctxt ->
580 wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) ->
581 wlkBinding cbindw `thenUgn` \ binding ->
582 getSrcFileUgn `thenUgn` \ sf ->
584 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
586 returnUgn (RdrTyClDecl
587 (mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc))
589 -- "instance" declaration
590 U_ibind ty ibindw srcline ->
591 -- The "ty" contains the instance context too
592 -- So for "instance Eq a => Eq [a]" the type will be
594 mkSrcLocUgn srcline $ \ src_loc ->
595 wlkInstType ty `thenUgn` \ inst_ty ->
596 wlkBinding ibindw `thenUgn` \ binding ->
597 getSrcModUgn `thenUgn` \ modname ->
598 getSrcFileUgn `thenUgn` \ sf ->
600 (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
602 returnUgn (RdrInstDecl
603 (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
605 -- "default" declaration
606 U_dbind dbindts srcline ->
607 mkSrcLocUgn srcline $ \ src_loc ->
608 wlkList rdMonoType dbindts `thenUgn` \ tys ->
609 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
611 -- "foreign" declaration
612 U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
613 mkSrcLocUgn srcline $ \ src_loc ->
614 wlkVarId id `thenUgn` \ h_id ->
615 wlkHsType ty `thenUgn` \ h_ty ->
616 wlkExtName ext_name `thenUgn` \ h_ext_name ->
617 rdCallConv cconv `thenUgn` \ h_cconv ->
618 rdForKind imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
619 returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
621 U_sbind sbindids sbindid srcline ->
623 mkSrcLocUgn srcline $ \ src_loc ->
624 wlkList rdVarId sbindids `thenUgn` \ vars ->
625 wlkHsSigType sbindid `thenUgn` \ poly_ty ->
626 returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
628 U_vspec_uprag uvar vspec_tys srcline ->
629 -- value specialisation user-pragma
630 mkSrcLocUgn srcline $ \ src_loc ->
631 wlkVarId uvar `thenUgn` \ var ->
632 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
633 returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
634 | (ty, using_id) <- tys_and_ids ])
636 rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
638 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
639 wlkHsSigType vspec_ty `thenUgn` \ ty ->
640 wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
641 returnUgn(ty, id_maybe)
643 U_ispec_uprag iclas ispec_ty srcline ->
644 -- instance specialisation user-pragma
645 mkSrcLocUgn srcline $ \ src_loc ->
646 wlkHsSigType ispec_ty `thenUgn` \ ty ->
647 returnUgn (RdrSig (SpecInstSig ty src_loc))
649 U_inline_uprag ivar srcline ->
650 -- value inlining user-pragma
651 mkSrcLocUgn srcline $ \ src_loc ->
652 wlkVarId ivar `thenUgn` \ var ->
653 returnUgn (RdrSig (InlineSig var src_loc))
655 U_noinline_uprag ivar srcline ->
657 mkSrcLocUgn srcline $ \ src_loc ->
658 wlkVarId ivar `thenUgn` \ var ->
659 returnUgn (RdrSig (NoInlineSig var src_loc))
662 mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds
663 mkRdrFunctionBinding fun_matches src_loc
664 = FunMonoBind (head fns) (head infs) matches src_loc
666 (fns, infs, matches) = unzip3 (map de_fun_match fun_matches)
668 de_fun_match (Match _ [ConPatIn fn pats] sig grhss) = (fn, False, Match [] pats sig grhss)
669 de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True, Match [] [p1,p2] sig grhss)
672 rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs
673 rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs
675 wlkGRHSs :: U_grhsb -> UgnM RdrNameGRHSs
676 wlkGRHSs (U_pguards rhss bind)
677 = wlkList rdGdExp rhss `thenUgn` \ gdexps ->
678 wlkLocalBinding bind `thenUgn` \ bind' ->
679 returnUgn (GRHSs gdexps bind' Nothing)
680 wlkGRHSs (U_pnoguards srcline rhs bind)
681 = mkSrcLocUgn srcline $ \ src_loc ->
682 rdExpr rhs `thenUgn` \ rhs' ->
683 wlkLocalBinding bind `thenUgn` \ bind' ->
684 returnUgn (GRHSs (unguardedRHS rhs' src_loc) bind' Nothing)
687 rdGdExp :: ParseTree -> UgnM RdrNameGRHS
688 rdGdExp pt = rdU_gdexp pt `thenUgn` \ (U_pgdexp guards srcline rhs) ->
689 wlkQuals guards `thenUgn` \ guards' ->
690 mkSrcLocUgn srcline $ \ src_loc ->
691 wlkExpr rhs `thenUgn` \ expr' ->
692 returnUgn (GRHS (guards' ++ [ExprStmt expr' src_loc]) src_loc)
696 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
698 wlkDerivings (U_nothing) = returnUgn Nothing
699 wlkDerivings (U_just pt)
700 = rdU_list pt `thenUgn` \ ds ->
701 wlkList rdTCId ds `thenUgn` \ derivs ->
702 returnUgn (Just derivs)
705 %************************************************************************
707 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
709 %************************************************************************
712 rdHsType :: ParseTree -> UgnM RdrNameHsType
713 rdMonoType :: ParseTree -> UgnM RdrNameHsType
715 rdHsType pt = rdU_ttype pt `thenUgn` wlkHsType
716 rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType
718 wlkHsConstrArgType ttype
719 -- Used for the argument types of contructors
720 -- Only an implicit quantification point if -fglasgow-exts
721 | opt_GlasgowExts = wlkHsSigType ttype
722 | otherwise = wlkHsType ttype
724 -- wlkHsSigType is used for type signatures: any place there
725 -- should be *implicit* quantification
727 = wlkHsType ttype `thenUgn` \ ty ->
728 -- This is an implicit quantification point, so
729 -- make sure it starts with a ForAll
731 HsForAllTy _ _ _ -> returnUgn ty
732 other -> returnUgn (HsForAllTy [] [] ty)
734 wlkHsType :: U_ttype -> UgnM RdrNameHsType
737 U_forall u_tyvars u_theta u_ty -> -- context
738 wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
739 wlkContext u_theta `thenUgn` \ theta ->
740 wlkHsType u_ty `thenUgn` \ ty ->
741 returnUgn (HsForAllTy (map UserTyVar tyvars) theta ty)
743 U_namedtvar tv -> -- type variable
744 wlkTvId tv `thenUgn` \ tyvar ->
745 returnUgn (MonoTyVar tyvar)
747 U_tname tcon -> -- type constructor
748 wlkTCId tcon `thenUgn` \ tycon ->
749 returnUgn (MonoTyVar tycon)
752 wlkHsType t1 `thenUgn` \ ty1 ->
753 wlkHsType t2 `thenUgn` \ ty2 ->
754 returnUgn (MonoTyApp ty1 ty2)
756 U_tllist tlist -> -- list type
757 wlkHsType tlist `thenUgn` \ ty ->
758 returnUgn (MonoListTy ty)
761 wlkList rdMonoType ttuple `thenUgn` \ tys ->
762 returnUgn (MonoTupleTy tys True)
765 wlkList rdMonoType ttuple `thenUgn` \ tys ->
766 returnUgn (MonoTupleTy tys False)
769 wlkHsType tfun `thenUgn` \ ty1 ->
770 wlkHsType targ `thenUgn` \ ty2 ->
771 returnUgn (MonoFunTy ty1 ty2)
775 U_forall u_tyvars u_theta inst_head ->
776 wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
777 wlkContext u_theta `thenUgn` \ theta ->
778 wlkConAndTys inst_head `thenUgn` \ (clas, tys) ->
779 returnUgn (HsForAllTy (map UserTyVar tyvars) theta (MonoDictTy clas tys))
781 other -> -- something else
782 wlkConAndTys other `thenUgn` \ (clas, tys) ->
783 returnUgn (HsForAllTy [] [] (MonoDictTy clas tys))
787 wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
788 wlkConAndTyVars ttype
789 = wlkHsType ttype `thenUgn` \ ty ->
791 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
792 split (MonoTyVar tycon) args = (tycon,args)
793 split other args = pprPanic "ERROR: malformed type: "
796 returnUgn (split ty [])
799 wlkContext :: U_list -> UgnM RdrNameContext
800 rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
802 wlkContext list = wlkList rdConAndTys list
804 rdConAndTys pt = rdU_ttype pt `thenUgn` wlkConAndTys
807 = wlkHsType ttype `thenUgn` \ ty ->
809 split (MonoTyApp fun ty) tys = split fun (ty : tys)
810 split (MonoTyVar tycon) tys = (tycon, tys)
811 split other tys = pprPanic "ERROR: malformed type: "
814 returnUgn (split ty [])
818 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
819 rdConDecl pt = rdU_constr pt `thenUgn` wlkConDecl
821 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
823 wlkConDecl (U_constrex u_tvs ccxt ccdecl)
824 = wlkList rdTvId u_tvs `thenUgn` \ tyvars ->
825 wlkContext ccxt `thenUgn` \ theta ->
826 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ _ details loc) ->
827 returnUgn (ConDecl con (map UserTyVar tyvars) theta details loc)
829 wlkConDecl (U_constrpre ccon ctys srcline)
830 = mkSrcLocUgn srcline $ \ src_loc ->
831 wlkDataId ccon `thenUgn` \ con ->
832 wlkList rdBangType ctys `thenUgn` \ tys ->
833 returnUgn (ConDecl con [] [] (VanillaCon tys) src_loc)
835 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
836 = mkSrcLocUgn srcline $ \ src_loc ->
837 wlkBangType cty1 `thenUgn` \ ty1 ->
838 wlkDataId cop `thenUgn` \ op ->
839 wlkBangType cty2 `thenUgn` \ ty2 ->
840 returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
842 wlkConDecl (U_constrnew ccon cty mb_lab srcline)
843 = mkSrcLocUgn srcline $ \ src_loc ->
844 wlkDataId ccon `thenUgn` \ con ->
845 wlkHsSigType cty `thenUgn` \ ty ->
846 wlkMaybe rdVarId mb_lab `thenUgn` \ mb_lab ->
847 returnUgn (ConDecl con [] [] (NewCon ty mb_lab) src_loc)
849 wlkConDecl (U_constrrec ccon cfields srcline)
850 = mkSrcLocUgn srcline $ \ src_loc ->
851 wlkDataId ccon `thenUgn` \ con ->
852 wlkList rd_field cfields `thenUgn` \ fields_lists ->
853 returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
855 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
857 rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
858 wlkList rdVarId fvars `thenUgn` \ vars ->
859 wlkBangType fty `thenUgn` \ ty ->
863 rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
865 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
867 wlkBangType (U_tbang bty) = wlkHsConstrArgType bty `thenUgn` \ ty ->
868 returnUgn (Banged ty)
869 wlkBangType uty = wlkHsConstrArgType uty `thenUgn` \ ty ->
870 returnUgn (Unbanged ty)
873 %************************************************************************
875 \subsection{Read a ``match''}
877 %************************************************************************
880 rdMatch :: ParseTree -> UgnM RdrNameMatch
881 rdMatch pt = rdU_match pt `thenUgn` wlkMatch
883 wlkMatch :: U_match -> UgnM RdrNameMatch
884 wlkMatch (U_pmatch pats sig grhsb)
885 = wlkList rdPat pats `thenUgn` \ pats' ->
886 wlkMaybe rdHsType sig `thenUgn` \ maybe_ty ->
887 wlkGRHSs grhsb `thenUgn` \ grhss' ->
888 returnUgn (Match [] pats' maybe_ty grhss')
891 %************************************************************************
893 \subsection[rdImport]{Read an import decl}
895 %************************************************************************
898 rdImport :: ParseTree
899 -> UgnM RdrNameImportDecl
902 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
903 mkSrcLocUgn srcline $ \ src_loc ->
904 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
905 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
906 returnUgn (ImportDecl (mkModuleFS imod)
908 (cvIfaceFlavour isrc)
909 (case maybe_as of { Just m -> Just (mkModuleFS m); Nothing -> Nothing })
912 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
914 U_left pt -> rdEntities pt `thenUgn` \ ents ->
915 returnUgn (False, ents)
916 U_right pt -> rdEntities pt `thenUgn` \ ents ->
917 returnUgn (True, ents)
919 cvIfaceFlavour 0 = HiFile -- No pragam
920 cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
924 rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity
926 rdEntity :: ParseTree -> UgnM (IE RdrName)
929 = rdU_entidt pt `thenUgn` \ entity ->
931 U_entid evar -> -- just a value
932 wlkEntId evar `thenUgn` \ var ->
933 returnUgn (IEVar var)
935 U_enttype x -> -- abstract type constructor/class
936 wlkTCId x `thenUgn` \ thing ->
937 returnUgn (IEThingAbs thing)
939 U_enttypeall x -> -- non-abstract type constructor/class
940 wlkTCId x `thenUgn` \ thing ->
941 returnUgn (IEThingAll thing)
943 U_enttypenamed x ns -> -- non-abstract type constructor/class
944 -- with specified constrs/methods
945 wlkTCId x `thenUgn` \ thing ->
946 wlkList rdVarId ns `thenUgn` \ names ->
947 returnUgn (IEThingWith thing names)
949 U_entmod mod -> -- everything provided unqualified by a module
950 returnUgn (IEModuleContents (mkModuleFS mod))
954 %************************************************************************
956 \subsection[rdExtName]{Read an external name}
958 %************************************************************************
961 wlkExtName :: U_maybe -> UgnM ExtName
962 wlkExtName (U_nothing) = returnUgn Dynamic
963 wlkExtName (U_just pt)
964 = rdU_list pt `thenUgn` \ ds ->
965 wlkList rdU_hstring ds `thenUgn` \ ss ->
967 [nm] -> returnUgn (ExtName nm Nothing)
968 [mod,nm] -> returnUgn (ExtName nm (Just mod))
970 rdCallConv :: Int -> UgnM CallConv
972 -- this tracks the #defines in parser/utils.h
974 (-1) -> -- no calling convention specified, use default.
975 returnUgn defaultCallConv
978 rdForKind :: Int -> Bool -> UgnM ForKind
979 rdForKind 0 isUnsafe = -- foreign import
980 returnUgn (FoImport isUnsafe)
981 rdForKind 1 _ = -- foreign export
983 rdForKind 2 _ = -- foreign label