2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section{Read parse tree built by Yacc parser}
7 #include "HsVersions.h"
15 import UgenAll -- all Yacc parser gumpff...
16 import PrefixSyn -- and various syntaxen.
18 import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas )
22 import CmdLineOpts ( opt_CompilingPrelude )
23 import ErrUtils ( addErrLoc, ghcExit )
24 import FiniteMap ( elemFM, FiniteMap )
25 import Name ( RdrName(..), isRdrLexCon )
26 import PprStyle ( PprStyle(..) )
27 import PrelMods ( fromPrelude )
29 import SrcLoc ( SrcLoc )
30 import Util ( nOfThem, pprError, panic )
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 rdQid :: ParseTree -> UgnM RdrName
61 rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
63 wlkQid :: U_qid -> UgnM RdrName
64 wlkQid (U_noqual name)
65 = returnUgn (Unqual name)
66 wlkQid (U_aqual mod name)
68 = returnUgn (Unqual name)
70 = returnUgn (Qual mod name)
72 = returnUgn (Unqual name)
74 cvFlag :: U_long -> Bool
79 %************************************************************************
81 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
83 %************************************************************************
86 rdModule :: IO (Module, -- this module's name
87 RdrNameHsModule) -- the main goods
90 = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
92 srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM)
95 rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
96 hmodlist srciface_version srcline) ->
98 setSrcFileUgn srcfile $
99 setSrcModUgn modname $
100 mkSrcLocUgn srcline $ \ src_loc ->
102 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
103 wlkList rdImport himplist `thenUgn` \ imports ->
104 wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
105 wlkBinding hmodlist `thenUgn` \ binding ->
107 case sepDeclsForTopBinds binding of
108 (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
112 (case srciface_version of { 0 -> Nothing; n -> Just n })
122 (cvSepdBinds srcfile cvValSig binds)
123 [{-no interface sigs yet-}]
128 %************************************************************************
130 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
132 %************************************************************************
135 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
136 rdPat :: ParseTree -> UgnM RdrNamePat
138 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
139 rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
141 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
142 wlkPat :: U_tree -> UgnM RdrNamePat
146 U_par pexpr -> -- parenthesised expr
147 wlkExpr pexpr `thenUgn` \ expr ->
148 returnUgn (HsPar expr)
150 U_lsection lsexp lop -> -- left section
151 wlkExpr lsexp `thenUgn` \ expr ->
152 wlkQid lop `thenUgn` \ op ->
153 returnUgn (SectionL expr (HsVar op))
155 U_rsection rop rsexp -> -- right section
156 wlkQid rop `thenUgn` \ op ->
157 wlkExpr rsexp `thenUgn` \ expr ->
158 returnUgn (SectionR (HsVar op) expr)
160 U_ccall fun flavor ccargs -> -- ccall/casm
161 wlkList rdExpr ccargs `thenUgn` \ args ->
165 returnUgn (CCall fun args
166 (tag == 'p' || tag == 'P') -- may invoke GC
167 (tag == 'N' || tag == 'P') -- really a "casm"
168 (panic "CCall:result_ty"))
170 U_scc label sccexp -> -- scc (set-cost-centre) expression
171 wlkExpr sccexp `thenUgn` \ expr ->
172 returnUgn (HsSCC label expr)
174 U_lambda lampats lamexpr srcline -> -- lambda expression
175 mkSrcLocUgn srcline $ \ src_loc ->
176 wlkList rdPat lampats `thenUgn` \ pats ->
177 wlkExpr lamexpr `thenUgn` \ body ->
179 HsLam (foldr PatMatch
180 (GRHSMatch (GRHSsAndBindsIn
181 [OtherwiseGRHS body src_loc]
186 U_casee caseexpr casebody srcline -> -- case expression
187 mkSrcLocUgn srcline $ \ src_loc ->
188 wlkExpr caseexpr `thenUgn` \ expr ->
189 wlkList rdMatch casebody `thenUgn` \ mats ->
190 getSrcFileUgn `thenUgn` \ sf ->
192 matches = cvMatches sf True mats
194 returnUgn (HsCase expr matches src_loc)
196 U_ife ifpred ifthen ifelse srcline -> -- if expression
197 mkSrcLocUgn srcline $ \ src_loc ->
198 wlkExpr ifpred `thenUgn` \ e1 ->
199 wlkExpr ifthen `thenUgn` \ e2 ->
200 wlkExpr ifelse `thenUgn` \ e3 ->
201 returnUgn (HsIf e1 e2 e3 src_loc)
203 U_let letvdefs letvexpr -> -- let expression
204 wlkBinding letvdefs `thenUgn` \ binding ->
205 wlkExpr letvexpr `thenUgn` \ expr ->
206 getSrcFileUgn `thenUgn` \ sf ->
208 binds = cvBinds sf cvValSig binding
210 returnUgn (HsLet binds expr)
212 U_doe gdo srcline -> -- do expression
213 mkSrcLocUgn srcline $ \ src_loc ->
214 wlkList rd_stmt gdo `thenUgn` \ stmts ->
215 returnUgn (HsDo stmts src_loc)
218 = rdU_tree pt `thenUgn` \ bind ->
220 U_doexp exp srcline ->
221 mkSrcLocUgn srcline $ \ src_loc ->
222 wlkExpr exp `thenUgn` \ expr ->
223 returnUgn (ExprStmt expr src_loc)
225 U_dobind pat exp srcline ->
226 mkSrcLocUgn srcline $ \ src_loc ->
227 wlkPat pat `thenUgn` \ patt ->
228 wlkExpr exp `thenUgn` \ expr ->
229 returnUgn (BindStmt patt expr src_loc)
232 wlkBinding seqlet `thenUgn` \ bs ->
233 getSrcFileUgn `thenUgn` \ sf ->
235 binds = cvBinds sf cvValSig bs
237 returnUgn (LetStmt binds)
239 U_comprh cexp cquals -> -- list comprehension
240 wlkExpr cexp `thenUgn` \ expr ->
241 wlkList rd_qual cquals `thenUgn` \ quals ->
242 returnUgn (ListComp expr quals)
245 = rdU_tree pt `thenUgn` \ qual ->
251 wlkExpr exp `thenUgn` \ expr ->
252 returnUgn (FilterQual expr)
255 wlkPat qpat `thenUgn` \ pat ->
256 wlkExpr qexp `thenUgn` \ expr ->
257 returnUgn (GeneratorQual pat expr)
260 wlkBinding seqlet `thenUgn` \ bs ->
261 getSrcFileUgn `thenUgn` \ sf ->
263 binds = cvBinds sf cvValSig bs
265 returnUgn (LetQual binds)
267 U_eenum efrom estep eto -> -- arithmetic sequence
268 wlkExpr efrom `thenUgn` \ e1 ->
269 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
270 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
271 returnUgn (cv_arith_seq e1 es2 es3)
273 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
274 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
275 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
276 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
278 U_restr restre restrt -> -- expression with type signature
279 wlkExpr restre `thenUgn` \ expr ->
280 wlkPolyType restrt `thenUgn` \ ty ->
281 returnUgn (ExprWithTySig expr ty)
283 --------------------------------------------------------------
284 -- now the prefix items that can either be an expression or
285 -- pattern, except we know they are *expressions* here
286 -- (this code could be commoned up with the pattern version;
287 -- but it probably isn't worth it)
288 --------------------------------------------------------------
290 wlkLiteral lit `thenUgn` \ lit ->
291 returnUgn (HsLit lit)
293 U_ident n -> -- simple identifier
294 wlkQid n `thenUgn` \ var ->
295 returnUgn (HsVar var)
297 U_ap fun arg -> -- application
298 wlkExpr fun `thenUgn` \ expr1 ->
299 wlkExpr arg `thenUgn` \ expr2 ->
300 returnUgn (HsApp expr1 expr2)
302 U_infixap fun arg1 arg2 -> -- infix application
303 wlkQid fun `thenUgn` \ op ->
304 wlkExpr arg1 `thenUgn` \ expr1 ->
305 wlkExpr arg2 `thenUgn` \ expr2 ->
306 returnUgn (OpApp expr1 (HsVar op) expr2)
308 U_negate nexp -> -- prefix negation
309 wlkExpr nexp `thenUgn` \ expr ->
310 returnUgn (NegApp expr (Unqual SLIT("negate")) )
312 U_llist llist -> -- explicit list
313 wlkList rdExpr llist `thenUgn` \ exprs ->
314 returnUgn (ExplicitList exprs)
316 U_tuple tuplelist -> -- explicit tuple
317 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
318 returnUgn (ExplicitTuple exprs)
320 U_record con rbinds -> -- record construction
321 wlkQid con `thenUgn` \ rcon ->
322 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
323 returnUgn (RecordCon (HsVar rcon) recbinds)
325 U_rupdate updexp updbinds -> -- record update
326 wlkExpr updexp `thenUgn` \ aexp ->
327 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
328 returnUgn (RecordUpd aexp recbinds)
331 U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
332 U_as _ _ -> error "U_as"
333 U_lazyp _ -> error "U_lazyp"
334 U_wildp -> error "U_wildp"
335 U_qual _ _ -> error "U_qual"
336 U_guard _ -> error "U_guard"
337 U_seqlet _ -> error "U_seqlet"
338 U_dobind _ _ _ -> error "U_dobind"
339 U_doexp _ _ -> error "U_doexp"
340 U_rbind _ _ -> error "U_rbind"
341 U_fixop _ _ _ -> error "U_fixop"
345 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
346 wlkQid var `thenUgn` \ rvar ->
347 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
350 Nothing -> (rvar, HsVar rvar, True{-pun-})
351 Just re -> (rvar, re, False)
355 Patterns: just bear in mind that lists of patterns are represented as
356 a series of ``applications''.
360 U_par ppat -> -- parenthesised pattern
361 wlkPat ppat `thenUgn` \ pat ->
362 returnUgn (ParPatIn pat)
364 U_as avar as_pat -> -- "as" pattern
365 wlkQid avar `thenUgn` \ var ->
366 wlkPat as_pat `thenUgn` \ pat ->
367 returnUgn (AsPatIn var pat)
369 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
370 wlkPat lazyp `thenUgn` \ pat ->
371 returnUgn (LazyPatIn pat)
373 U_wildp -> returnUgn WildPatIn -- wildcard pattern
375 U_lit lit -> -- literal pattern
376 wlkLiteral lit `thenUgn` \ lit ->
377 returnUgn (LitPatIn lit)
379 U_ident nn -> -- simple identifier
380 wlkQid nn `thenUgn` \ n ->
387 U_ap l r -> -- "application": there's a list of patterns lurking here!
388 wlkPat r `thenUgn` \ rpat ->
389 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
391 VarPatIn x -> returnUgn (x, lpats)
392 ConPatIn x [] -> returnUgn (x, lpats)
393 ConOpPatIn x op y -> returnUgn (op, x:y:lpats)
394 _ -> getSrcLocUgn `thenUgn` \ loc ->
396 err = addErrLoc loc "Illegal pattern `application'"
397 (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
398 msg = ppShow 100 (err PprForUser)
400 ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
401 ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
402 returnUgn (error "ReadPrefix")
404 ) `thenUgn` \ (n, arg_pats) ->
405 returnUgn (ConPatIn n arg_pats)
410 wlkPat r `thenUgn` \ rpat ->
411 collect_pats l (rpat:acc)
413 wlkPat other `thenUgn` \ pat ->
416 U_infixap fun arg1 arg2 -> -- infix pattern
417 wlkQid fun `thenUgn` \ op ->
418 wlkPat arg1 `thenUgn` \ pat1 ->
419 wlkPat arg2 `thenUgn` \ pat2 ->
420 returnUgn (ConOpPatIn pat1 op pat2)
422 U_negate npat -> -- negated pattern
423 wlkPat npat `thenUgn` \ pat ->
424 returnUgn (NegPatIn pat)
426 U_llist llist -> -- explicit list
427 wlkList rdPat llist `thenUgn` \ pats ->
428 returnUgn (ListPatIn pats)
430 U_tuple tuplelist -> -- explicit tuple
431 wlkList rdPat tuplelist `thenUgn` \ pats ->
432 returnUgn (TuplePatIn pats)
434 U_record con rpats -> -- record destruction
435 wlkQid con `thenUgn` \ rcon ->
436 wlkList rdRpat rpats `thenUgn` \ recpats ->
437 returnUgn (RecPatIn rcon recpats)
440 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
441 wlkQid var `thenUgn` \ rvar ->
442 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
445 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
446 Just rp -> (rvar, rp, False)
451 wlkLiteral :: U_literal -> UgnM HsLit
456 U_integer s -> HsInt (as_integer s)
457 U_floatr s -> HsFrac (as_rational s)
458 U_intprim s -> HsIntPrim (as_integer s)
459 U_doubleprim s -> HsDoublePrim (as_rational s)
460 U_floatprim s -> HsFloatPrim (as_rational s)
461 U_charr s -> HsChar (as_char s)
462 U_charprim s -> HsCharPrim (as_char s)
463 U_string s -> HsString (as_string s)
464 U_stringprim s -> HsStringPrim (as_string s)
465 U_clitlit s -> HsLitLit (as_string s)
469 as_integer s = readInteger (_UNPK_ s)
470 as_rational s = _readRational (_UNPK_ s) -- non-std
474 %************************************************************************
476 \subsection{wlkBinding}
478 %************************************************************************
481 wlkBinding :: U_binding -> UgnM RdrBinding
487 returnUgn RdrNullBind
489 -- "and" binding (just glue, really)
491 wlkBinding a `thenUgn` \ binding1 ->
492 wlkBinding b `thenUgn` \ binding2 ->
493 returnUgn (RdrAndBindings binding1 binding2)
495 -- "data" declaration
496 U_tbind tctxt ttype tcons tderivs srcline ->
497 mkSrcLocUgn srcline $ \ src_loc ->
498 wlkContext tctxt `thenUgn` \ ctxt ->
499 wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
500 wlkList rdConDecl tcons `thenUgn` \ cons ->
501 wlkDerivings tderivs `thenUgn` \ derivings ->
502 returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc))
504 -- "newtype" declaration
505 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
506 mkSrcLocUgn srcline $ \ src_loc ->
507 wlkContext ntctxt `thenUgn` \ ctxt ->
508 wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
509 wlkList rdConDecl ntcon `thenUgn` \ con ->
510 wlkDerivings ntderivs `thenUgn` \ derivings ->
511 returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
513 -- "type" declaration
514 U_nbind nbindid nbindas srcline ->
515 mkSrcLocUgn srcline $ \ src_loc ->
516 wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
517 wlkMonoType nbindas `thenUgn` \ expansion ->
518 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
521 U_fbind fbindl srcline ->
522 mkSrcLocUgn srcline $ \ src_loc ->
523 wlkList rdMatch fbindl `thenUgn` \ matches ->
524 returnUgn (RdrFunctionBinding srcline matches)
527 U_pbind pbindl srcline ->
528 mkSrcLocUgn srcline $ \ src_loc ->
529 wlkList rdMatch pbindl `thenUgn` \ matches ->
530 returnUgn (RdrPatternBinding srcline matches)
532 -- "class" declaration
533 U_cbind cbindc cbindid cbindw srcline ->
534 mkSrcLocUgn srcline $ \ src_loc ->
535 wlkContext cbindc `thenUgn` \ ctxt ->
536 wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
537 wlkBinding cbindw `thenUgn` \ binding ->
538 getSrcFileUgn `thenUgn` \ sf ->
540 (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
542 final_sigs = concat (map cvClassOpSig class_sigs)
543 final_methods = cvMonoBinds sf class_methods
545 returnUgn (RdrClassDecl
546 (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
548 -- "instance" declaration
549 U_ibind ibindc iclas ibindi ibindw srcline ->
550 mkSrcLocUgn srcline $ \ src_loc ->
551 wlkContext ibindc `thenUgn` \ ctxt ->
552 wlkQid iclas `thenUgn` \ clas ->
553 wlkMonoType ibindi `thenUgn` \ inst_ty ->
554 wlkBinding ibindw `thenUgn` \ binding ->
555 getSrcModUgn `thenUgn` \ modname ->
556 getSrcFileUgn `thenUgn` \ sf ->
558 (ss, bs) = sepDeclsIntoSigsAndBinds binding
559 binds = cvMonoBinds sf bs
560 uprags = concat (map cvInstDeclSig ss)
561 ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
562 maybe_mod = if opt_CompilingPrelude
566 returnUgn (RdrInstDecl
567 (InstDecl clas ctxt_inst_ty binds True maybe_mod uprags noInstancePragmas src_loc))
569 -- "default" declaration
570 U_dbind dbindts srcline ->
571 mkSrcLocUgn srcline $ \ src_loc ->
572 wlkList rdMonoType dbindts `thenUgn` \ tys ->
573 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
576 -- signature(-like) things, including user pragmas
577 wlk_sig_thing a_sig_we_hope
581 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
583 wlkDerivings (U_nothing) = returnUgn Nothing
584 wlkDerivings (U_just pt)
585 = rdU_list pt `thenUgn` \ ds ->
586 wlkList rdQid ds `thenUgn` \ derivs ->
587 returnUgn (Just derivs)
592 wlk_sig_thing (U_sbind sbindids sbindid srcline)
593 = mkSrcLocUgn srcline $ \ src_loc ->
594 wlkList rdQid sbindids `thenUgn` \ vars ->
595 wlkPolyType sbindid `thenUgn` \ poly_ty ->
596 returnUgn (RdrTySig vars poly_ty src_loc)
598 -- value specialisation user-pragma
599 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
600 = mkSrcLocUgn srcline $ \ src_loc ->
601 wlkQid uvar `thenUgn` \ var ->
602 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
603 returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
604 | (ty, using_id) <- tys_and_ids ])
606 rd_ty_and_id :: ParseTree -> UgnM (RdrNamePolyType, Maybe RdrName)
608 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
609 wlkPolyType vspec_ty `thenUgn` \ ty ->
610 wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
611 returnUgn(ty, id_maybe)
613 -- instance specialisation user-pragma
614 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
615 = mkSrcLocUgn srcline $ \ src_loc ->
616 wlkQid iclas `thenUgn` \ clas ->
617 wlkMonoType ispec_ty `thenUgn` \ ty ->
618 returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
620 -- data specialisation user-pragma
621 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
622 = mkSrcLocUgn srcline $ \ src_loc ->
623 wlkQid itycon `thenUgn` \ tycon ->
624 wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
625 returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
627 -- value inlining user-pragma
628 wlk_sig_thing (U_inline_uprag ivar srcline)
629 = mkSrcLocUgn srcline $ \ src_loc ->
630 wlkQid ivar `thenUgn` \ var ->
631 returnUgn (RdrInlineValSig (InlineSig var src_loc))
633 -- "deforest me" user-pragma
634 wlk_sig_thing (U_deforest_uprag ivar srcline)
635 = mkSrcLocUgn srcline $ \ src_loc ->
636 wlkQid ivar `thenUgn` \ var ->
637 returnUgn (RdrDeforestSig (DeforestSig var src_loc))
639 -- "magic" unfolding user-pragma
640 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
641 = mkSrcLocUgn srcline $ \ src_loc ->
642 wlkQid ivar `thenUgn` \ var ->
643 returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
646 %************************************************************************
648 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
650 %************************************************************************
653 rdPolyType :: ParseTree -> UgnM RdrNamePolyType
654 rdMonoType :: ParseTree -> UgnM RdrNameMonoType
656 rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
657 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
659 wlkPolyType :: U_ttype -> UgnM RdrNamePolyType
660 wlkMonoType :: U_ttype -> UgnM RdrNameMonoType
664 U_context tcontextl tcontextt -> -- context
665 wlkContext tcontextl `thenUgn` \ ctxt ->
666 wlkMonoType tcontextt `thenUgn` \ ty ->
667 returnUgn (HsPreForAllTy ctxt ty)
669 other -> -- something else
670 wlkMonoType other `thenUgn` \ ty ->
671 returnUgn (HsPreForAllTy [{-no context-}] ty)
675 U_namedtvar tv -> -- type variable
676 wlkQid tv `thenUgn` \ tyvar ->
677 returnUgn (MonoTyVar tyvar)
679 U_tname tcon -> -- type constructor
680 wlkQid tcon `thenUgn` \ tycon ->
681 returnUgn (MonoTyApp tycon [])
684 wlkMonoType t2 `thenUgn` \ ty2 ->
685 collect t1 [ty2] `thenUgn` \ (tycon, tys) ->
686 returnUgn (MonoTyApp tycon tys)
690 U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
692 U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
693 returnUgn (tycon, acc)
694 U_namedtvar tv -> wlkQid tv `thenUgn` \ tyvar ->
695 returnUgn (tyvar, acc)
696 U_tllist _ -> panic "tlist"
697 U_ttuple _ -> panic "ttuple"
698 U_tfun _ _ -> panic "tfun"
699 U_tbang _ -> panic "tbang"
700 U_context _ _ -> panic "context"
701 _ -> panic "something else"
703 U_tllist tlist -> -- list type
704 wlkMonoType tlist `thenUgn` \ ty ->
705 returnUgn (MonoListTy ty)
708 wlkList rdMonoType ttuple `thenUgn` \ tys ->
709 returnUgn (MonoTupleTy tys)
712 wlkMonoType tfun `thenUgn` \ ty1 ->
713 wlkMonoType targ `thenUgn` \ ty2 ->
714 returnUgn (MonoFunTy ty1 ty2)
719 wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName])
720 wlkContext :: U_list -> UgnM RdrNameContext
721 wlkClassAssertTy :: U_ttype -> UgnM (RdrName, RdrName)
723 wlkTyConAndTyVars ttype
724 = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
726 args = [ a | (MonoTyVar a) <- ty_args ]
728 returnUgn (tycon, args)
731 = wlkList rdMonoType list `thenUgn` \ tys ->
732 returnUgn (map mk_class_assertion tys)
735 = wlkMonoType xs `thenUgn` \ mono_ty ->
736 returnUgn (mk_class_assertion mono_ty)
738 mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName)
740 mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
741 mk_class_assertion other
742 = pprError "ERROR: malformed type context: " (ppr PprForUser other)
743 -- regrettably, the parser does let some junk past
744 -- e.g., f :: Num {-nothing-} => a -> ...
748 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
750 = rdU_constr pt `thenUgn` \ blah ->
753 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
755 wlkConDecl (U_constrpre ccon ctys srcline)
756 = mkSrcLocUgn srcline $ \ src_loc ->
757 wlkQid ccon `thenUgn` \ con ->
758 wlkList rdBangType ctys `thenUgn` \ tys ->
759 returnUgn (ConDecl con tys src_loc)
761 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
762 = mkSrcLocUgn srcline $ \ src_loc ->
763 wlkBangType cty1 `thenUgn` \ ty1 ->
764 wlkQid cop `thenUgn` \ op ->
765 wlkBangType cty2 `thenUgn` \ ty2 ->
766 returnUgn (ConOpDecl ty1 op ty2 src_loc)
768 wlkConDecl (U_constrnew ccon cty srcline)
769 = mkSrcLocUgn srcline $ \ src_loc ->
770 wlkQid ccon `thenUgn` \ con ->
771 wlkMonoType cty `thenUgn` \ ty ->
772 returnUgn (NewConDecl con ty src_loc)
774 wlkConDecl (U_constrrec ccon cfields srcline)
775 = mkSrcLocUgn srcline $ \ src_loc ->
776 wlkQid ccon `thenUgn` \ con ->
777 wlkList rd_field cfields `thenUgn` \ fields_lists ->
778 returnUgn (RecConDecl con fields_lists src_loc)
780 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
782 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
783 wlkList rdQid fvars `thenUgn` \ vars ->
784 wlkBangType fty `thenUgn` \ ty ->
788 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
790 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
792 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
793 returnUgn (Banged (HsPreForAllTy [] ty))
794 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
795 returnUgn (Unbanged (HsPreForAllTy [] ty))
798 %************************************************************************
800 \subsection{Read a ``match''}
802 %************************************************************************
805 rdMatch :: ParseTree -> UgnM RdrMatch
808 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
809 mkSrcLocUgn srcline $ \ src_loc ->
810 wlkPat gpat `thenUgn` \ pat ->
811 wlkBinding gbind `thenUgn` \ binding ->
812 wlkQid gsrcfun `thenUgn` \ srcfun ->
814 wlk_guards (U_pnoguards exp)
815 = wlkExpr exp `thenUgn` \ expr ->
816 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
818 wlk_guards (U_pguards gs)
819 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
820 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
825 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
826 wlkExpr g `thenUgn` \ guard ->
827 wlkExpr e `thenUgn` \ expr ->
828 returnUgn (guard, expr)
831 %************************************************************************
833 \subsection[rdFixOp]{Read in a fixity declaration}
835 %************************************************************************
838 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
840 = rdU_tree pt `thenUgn` \ fix ->
842 U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op ->
843 returnUgn (InfixL op prec)
844 U_fixop op 0 prec -> wlkQid op `thenUgn` \ op ->
845 returnUgn (InfixN op prec)
846 U_fixop op 1 prec -> wlkQid op `thenUgn` \ op ->
847 returnUgn (InfixR op prec)
848 _ -> error "ReadPrefix:rdFixOp"
851 %************************************************************************
853 \subsection[rdImport]{Read an import decl}
855 %************************************************************************
858 rdImport :: ParseTree
859 -> UgnM RdrNameImportDecl
862 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) ->
863 mkSrcLocUgn srcline $ \ src_loc ->
864 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
865 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
866 returnUgn (ImportDecl imod (cvFlag iqual) maybe_as maybe_spec src_loc)
868 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
870 U_left pt -> rdEntities pt `thenUgn` \ ents ->
871 returnUgn (False, ents)
872 U_right pt -> rdEntities pt `thenUgn` \ ents ->
873 returnUgn (True, ents)
878 = rdU_list pt `thenUgn` \ list ->
879 wlkList rdEntity list
881 rdEntity :: ParseTree -> UgnM (IE RdrName)
884 = rdU_entidt pt `thenUgn` \ entity ->
886 U_entid evar -> -- just a value
887 wlkQid evar `thenUgn` \ var ->
888 returnUgn (IEVar var)
890 U_enttype x -> -- abstract type constructor/class
891 wlkQid x `thenUgn` \ thing ->
892 returnUgn (IEThingAbs thing)
894 U_enttypeall x -> -- non-abstract type constructor/class
895 wlkQid x `thenUgn` \ thing ->
896 returnUgn (IEThingAll thing)
898 U_enttypenamed x ns -> -- non-abstract type constructor/class
899 -- with specified constrs/methods
900 wlkQid x `thenUgn` \ thing ->
901 wlkList rdQid ns `thenUgn` \ names ->
902 returnUgn (IEThingWith thing names)
904 U_entmod mod -> -- everything provided unqualified by a module
905 returnUgn (IEModuleContents mod)