2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section{Read parse tree built by Yacc parser}
7 #include "HsVersions.h"
12 -- used over in ReadPragmas...
13 wlkList, wlkMaybe, rdConDecl, wlkMonoType, rdMonoType
17 import RdrLoop -- for paranoia checking
19 import UgenAll -- all Yacc parser gumpff...
20 import PrefixSyn -- and various syntaxen.
26 import PrefixToHs -- reader utilities
29 import FiniteMap ( elemFM, FiniteMap )
30 import MainMonad ( thenMn, MainIO(..) )
31 import PprStyle ( PprStyle(..) )
33 import ProtoName ( isConopPN, ProtoName(..) )
34 import Util ( nOfThem, pprError, panic )
37 %************************************************************************
39 \subsection[ReadPrefix-help]{Help Functions}
41 %************************************************************************
44 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
46 wlkList wlk_it U_lnil = returnUgn []
48 wlkList wlk_it (U_lcons hd tl)
49 = wlk_it hd `thenUgn` \ hd_it ->
50 wlkList wlk_it tl `thenUgn` \ tl_it ->
51 returnUgn (hd_it : tl_it)
55 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
57 wlkMaybe wlk_it U_nothing = returnUgn Nothing
58 wlkMaybe wlk_it (U_just x)
59 = wlk_it x `thenUgn` \ it ->
64 rdQid :: ParseTree -> UgnM ProtoName
65 rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
67 wlkQid :: U_qid -> UgnM ProtoName
68 wlkQid (U_noqual name)
69 = returnUgn (Unk name)
70 wlkQid (U_aqual mod name)
71 = returnUgn (Qunk mod name)
73 = returnUgn (Unk name)
76 %************************************************************************
78 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
80 %************************************************************************
84 (FAST_STRING, -- this module's name
85 (FAST_STRING -> Bool, -- a function to chk if <x> is in the export list
86 FAST_STRING -> Bool), -- a function to chk if <M> is among the M..
87 -- ("dotdot") modules in the export list.
88 ProtoNameHsModule) -- the main goods
91 = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
93 srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM)
97 rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hfixlist hmodlist srcline) ->
98 wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
99 wlkBinding hmodlist `thenUgn` \ binding ->
100 wlkList rdImportedInterface himplist `thenUgn` \ imports ->
101 wlkMaybe rdEntities hexplist `thenUgn` \ exp_list ->
102 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
104 case sepDeclsForTopBinds binding of {
105 (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
109 mk_export_list_chker exp_list,
120 (cvSepdBinds srcfile cvValSig binds)
125 mk_export_list_chker = panic "ReadPrefix:mk_export_list_chker"
127 mk_export_list_chker exp_list
128 = case (getExportees exp_list) of
129 Nothing -> ( \ n -> False, \ n -> False ) -- all suspicious
130 Just (entity_info, dotdot_modules) ->
131 ( \ n -> n `elemFM` entity_info,
132 \ n -> n `elemFM` dotdot_modules )
136 %************************************************************************
138 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
140 %************************************************************************
143 rdExpr :: ParseTree -> UgnM ProtoNameHsExpr
144 rdPat :: ParseTree -> UgnM ProtoNamePat
146 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
147 rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
149 wlkExpr :: U_tree -> UgnM ProtoNameHsExpr
150 wlkPat :: U_tree -> UgnM ProtoNamePat
154 U_par expr -> -- parenthesised expr
157 U_lsection lsexp lop -> -- left section
158 wlkExpr lsexp `thenUgn` \ expr ->
159 wlkQid lop `thenUgn` \ op ->
160 returnUgn (SectionL expr (HsVar op))
162 U_rsection rop rsexp -> -- right section
163 wlkQid rop `thenUgn` \ op ->
164 wlkExpr rsexp `thenUgn` \ expr ->
165 returnUgn (SectionR (HsVar op) expr)
167 U_ccall fun flavor ccargs -> -- ccall/casm
168 wlkList rdExpr ccargs `thenUgn` \ args ->
172 returnUgn (CCall fun args
173 (tag == 'p' || tag == 'P') -- may invoke GC
174 (tag == 'N' || tag == 'P') -- really a "casm"
175 (panic "CCall:result_ty"))
177 U_scc label sccexp -> -- scc (set-cost-centre) expression
178 wlkExpr sccexp `thenUgn` \ expr ->
179 returnUgn (HsSCC label expr)
181 U_lambda lampats lamexpr srcline -> -- lambda expression
182 wlkList rdPat lampats `thenUgn` \ pats ->
183 wlkExpr lamexpr `thenUgn` \ body ->
184 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
186 HsLam (foldr PatMatch
187 (GRHSMatch (GRHSsAndBindsIn
188 [OtherwiseGRHS body src_loc]
193 U_casee caseexpr casebody srcline -> -- case expression
194 wlkExpr caseexpr `thenUgn` \ expr ->
195 wlkList rdMatch casebody `thenUgn` \ mats ->
196 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
197 getSrcFileUgn `thenUgn` \ sf ->
199 matches = cvMatches sf True mats
201 returnUgn (HsCase expr matches src_loc)
203 U_ife ifpred ifthen ifelse srcline -> -- if expression
204 wlkExpr ifpred `thenUgn` \ e1 ->
205 wlkExpr ifthen `thenUgn` \ e2 ->
206 wlkExpr ifelse `thenUgn` \ e3 ->
207 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
208 returnUgn (HsIf e1 e2 e3 src_loc)
210 U_let letvdefs letvexpr -> -- let expression
211 wlkBinding letvdefs `thenUgn` \ binding ->
212 wlkExpr letvexpr `thenUgn` \ expr ->
213 getSrcFileUgn `thenUgn` \ sf ->
215 binds = cvBinds sf cvValSig binding
217 returnUgn (HsLet binds expr)
219 U_doe gdo srcline -> -- do expression
220 wlkList rd_stmt gdo `thenUgn` \ stmts ->
221 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
222 returnUgn (HsDo stmts src_loc)
225 = rdU_tree pt `thenUgn` \ bind ->
227 U_doexp exp srcline ->
228 wlkExpr exp `thenUgn` \ expr ->
229 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
230 returnUgn (ExprStmt expr src_loc)
232 U_dobind pat exp srcline ->
233 wlkPat pat `thenUgn` \ patt ->
234 wlkExpr exp `thenUgn` \ expr ->
235 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
236 returnUgn (BindStmt patt expr src_loc)
239 wlkBinding seqlet `thenUgn` \ bs ->
240 getSrcFileUgn `thenUgn` \ sf ->
242 binds = cvBinds sf cvValSig bs
244 returnUgn (LetStmt binds)
246 U_comprh cexp cquals -> -- list comprehension
247 wlkExpr cexp `thenUgn` \ expr ->
248 wlkList rd_qual cquals `thenUgn` \ quals ->
249 returnUgn (ListComp expr quals)
252 = rdU_tree pt `thenUgn` \ qual ->
258 wlkExpr exp `thenUgn` \ expr ->
259 returnUgn (FilterQual expr)
262 wlkPat qpat `thenUgn` \ pat ->
263 wlkExpr qexp `thenUgn` \ expr ->
264 returnUgn (GeneratorQual pat expr)
267 wlkBinding seqlet `thenUgn` \ bs ->
268 getSrcFileUgn `thenUgn` \ sf ->
270 binds = cvBinds sf cvValSig bs
272 returnUgn (LetQual binds)
274 U_eenum efrom estep eto -> -- arithmetic sequence
275 wlkExpr efrom `thenUgn` \ e1 ->
276 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
277 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
278 returnUgn (cv_arith_seq e1 es2 es3)
280 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
281 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
282 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
283 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
285 U_restr restre restrt -> -- expression with type signature
286 wlkExpr restre `thenUgn` \ expr ->
287 wlkPolyType restrt `thenUgn` \ ty ->
288 returnUgn (ExprWithTySig expr ty)
290 --------------------------------------------------------------
291 -- now the prefix items that can either be an expression or
292 -- pattern, except we know they are *expressions* here
293 -- (this code could be commoned up with the pattern version;
294 -- but it probably isn't worth it)
295 --------------------------------------------------------------
297 wlkLiteral lit `thenUgn` \ lit ->
298 returnUgn (HsLit lit)
300 U_ident n -> -- simple identifier
301 wlkQid n `thenUgn` \ var ->
302 returnUgn (HsVar var)
304 U_ap fun arg -> -- application
305 wlkExpr fun `thenUgn` \ expr1 ->
306 wlkExpr arg `thenUgn` \ expr2 ->
307 returnUgn (HsApp expr1 expr2)
309 U_infixap fun arg1 arg2 -> -- infix application
310 wlkQid fun `thenUgn` \ op ->
311 wlkExpr arg1 `thenUgn` \ expr1 ->
312 wlkExpr arg2 `thenUgn` \ expr2 ->
313 returnUgn (OpApp expr1 (HsVar op) expr2)
315 U_negate nexp _ _ -> -- prefix negation
316 wlkExpr nexp `thenUgn` \ expr ->
317 returnUgn (HsApp (HsVar (Unk SLIT("negate"))) expr)
319 U_llist llist -> -- explicit list
320 wlkList rdExpr llist `thenUgn` \ exprs ->
321 returnUgn (ExplicitList exprs)
323 U_tuple tuplelist -> -- explicit tuple
324 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
325 returnUgn (ExplicitTuple exprs)
327 U_record con rbinds -> -- record construction
328 wlkQid con `thenUgn` \ rcon ->
329 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
330 returnUgn (RecordCon (HsVar rcon) recbinds)
332 U_rupdate updexp updbinds -> -- record update
333 wlkExpr updexp `thenUgn` \ aexp ->
334 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
335 returnUgn (RecordUpd aexp recbinds)
338 U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
339 U_as _ _ -> error "U_as"
340 U_lazyp _ -> error "U_lazyp"
341 U_wildp -> error "U_wildp"
342 U_qual _ _ -> error "U_qual"
343 U_guard _ -> error "U_guard"
344 U_seqlet _ -> error "U_seqlet"
345 U_dobind _ _ _ -> error "U_dobind"
346 U_doexp _ _ -> error "U_doexp"
347 U_rbind _ _ -> error "U_rbind"
348 U_fixop _ _ _ -> error "U_fixop"
352 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
353 wlkQid var `thenUgn` \ rvar ->
354 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
357 Nothing -> (rvar, HsVar rvar, True{-pun-})
358 Just re -> (rvar, re, False)
362 Patterns: just bear in mind that lists of patterns are represented as
363 a series of ``applications''.
367 U_par pat -> -- parenthesised pattern
370 U_as avar as_pat -> -- "as" pattern
371 wlkQid avar `thenUgn` \ var ->
372 wlkPat as_pat `thenUgn` \ pat ->
373 returnUgn (AsPatIn var pat)
375 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
376 wlkPat lazyp `thenUgn` \ pat ->
377 returnUgn (LazyPatIn pat)
379 U_wildp -> returnUgn WildPatIn -- wildcard pattern
381 --------------------------------------------------------------
382 -- now the prefix items that can either be an expression or
383 -- pattern, except we know they are *patterns* here.
384 --------------------------------------------------------------
385 U_negate nexp _ _ -> -- negated pattern: must be a literal
386 wlkPat nexp `thenUgn` \ lit_pat ->
388 LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
389 _ -> panic "wlkPat: bad negated pattern!"
391 U_lit lit -> -- literal pattern
392 wlkLiteral lit `thenUgn` \ lit ->
393 returnUgn (LitPatIn lit)
395 U_ident nn -> -- simple identifier
396 wlkQid nn `thenUgn` \ n ->
403 U_ap l r -> -- "application": there's a list of patterns lurking here!
404 wlkPat r `thenUgn` \ rpat ->
405 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
409 VarPatIn x -> (x, lpats)
410 ConPatIn x [] -> (x, lpats)
411 ConOpPatIn x op y -> (op, x:y:lpats)
412 _ -> -- sorry about the weedy msg; the parser missed this one
413 pprError "ERROR: an illegal `application' of a pattern to another one:"
414 (ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats)))
416 returnUgn (ConPatIn n arg_pats)
421 wlkPat r `thenUgn` \ rpat ->
422 collect_pats l (rpat:acc)
424 wlkPat other `thenUgn` \ pat ->
427 U_infixap fun arg1 arg2 ->
428 wlkQid fun `thenUgn` \ op ->
429 wlkPat arg1 `thenUgn` \ pat1 ->
430 wlkPat arg2 `thenUgn` \ pat2 ->
431 returnUgn (ConOpPatIn pat1 op pat2)
433 U_llist llist -> -- explicit list
434 wlkList rdPat llist `thenUgn` \ pats ->
435 returnUgn (ListPatIn pats)
437 U_tuple tuplelist -> -- explicit tuple
438 wlkList rdPat tuplelist `thenUgn` \ pats ->
439 returnUgn (TuplePatIn pats)
441 U_record con rpats -> -- record destruction
442 wlkQid con `thenUgn` \ rcon ->
443 wlkList rdRpat rpats `thenUgn` \ recpats ->
444 returnUgn (RecPatIn rcon recpats)
447 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
448 wlkQid var `thenUgn` \ rvar ->
449 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
452 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
453 Just rp -> (rvar, rp, False)
458 wlkLiteral :: U_literal -> UgnM HsLit
463 U_integer s -> HsInt (as_integer s)
464 U_floatr s -> HsFrac (as_rational s)
465 U_intprim s -> HsIntPrim (as_integer s)
466 U_doubleprim s -> HsDoublePrim (as_rational s)
467 U_floatprim s -> HsFloatPrim (as_rational s)
468 U_charr s -> HsChar (as_char s)
469 U_charprim s -> HsCharPrim (as_char s)
470 U_string s -> HsString (as_string s)
471 U_stringprim s -> HsStringPrim (as_string s)
472 U_clitlit s _ -> HsLitLit (as_string s)
476 as_integer s = readInteger (_UNPK_ s)
477 as_rational s = _readRational (_UNPK_ s) -- non-std
481 %************************************************************************
483 \subsection{wlkBinding}
485 %************************************************************************
488 wlkBinding :: U_binding -> UgnM RdrBinding
492 U_nullbind -> -- null binding
493 returnUgn RdrNullBind
495 U_abind a b -> -- "and" binding (just glue, really)
496 wlkBinding a `thenUgn` \ binding1 ->
497 wlkBinding b `thenUgn` \ binding2 ->
498 returnUgn (RdrAndBindings binding1 binding2)
500 U_tbind tctxt ttype tcons tderivs srcline tpragma -> -- "data" declaration
501 wlkContext tctxt `thenUgn` \ ctxt ->
502 wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
503 wlkList rdConDecl tcons `thenUgn` \ cons ->
504 wlkDerivings tderivs `thenUgn` \ derivings ->
505 wlkDataPragma tpragma `thenUgn` \ pragmas ->
506 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
507 returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings pragmas src_loc))
509 U_ntbind ntctxt nttype ntcon ntderivs srcline ntpragma -> -- "newtype" declaration
510 wlkContext ntctxt `thenUgn` \ ctxt ->
511 wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
512 wlkList rdConDecl ntcon `thenUgn` \ con ->
513 wlkDerivings ntderivs `thenUgn` \ derivings ->
514 wlkDataPragma ntpragma `thenUgn` \ pragma ->
515 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
516 returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings pragma src_loc))
518 U_nbind nbindid nbindas srcline -> -- "type" declaration
519 wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
520 wlkMonoType nbindas `thenUgn` \ expansion ->
521 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
522 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
524 U_fbind fbindl srcline -> -- function binding
525 wlkList rdMatch fbindl `thenUgn` \ matches ->
526 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
527 returnUgn (RdrFunctionBinding srcline matches)
529 U_pbind pbindl srcline -> -- pattern binding
530 wlkList rdMatch pbindl `thenUgn` \ matches ->
531 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
532 returnUgn (RdrPatternBinding srcline matches)
534 U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration
535 wlkContext cbindc `thenUgn` \ ctxt ->
536 wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
537 wlkBinding cbindw `thenUgn` \ binding ->
538 wlkClassPragma cpragma `thenUgn` \ pragma ->
539 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
540 getSrcFileUgn `thenUgn` \ sf ->
542 (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
544 final_sigs = concat (map cvClassOpSig class_sigs)
545 final_methods = cvMonoBinds sf class_methods
547 returnUgn (RdrClassDecl
548 (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
550 U_ibind from_source orig_mod -- "instance" declaration
551 ibindc iclas ibindi ibindw srcline ipragma ->
552 wlkContext ibindc `thenUgn` \ ctxt ->
553 wlkQid iclas `thenUgn` \ clas ->
554 wlkMonoType ibindi `thenUgn` \ inst_ty ->
555 wlkBinding ibindw `thenUgn` \ binding ->
556 wlkInstPragma ipragma `thenUgn` \ pragma ->
557 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
558 getSrcFileUgn `thenUgn` \ sf ->
560 from_here = case from_source of { 0 -> False; 1 -> True }
561 (ss, bs) = sepDeclsIntoSigsAndBinds binding
562 binds = cvMonoBinds sf bs
563 uprags = concat (map cvInstDeclSig ss)
564 ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
566 returnUgn (RdrInstDecl
567 (InstDecl clas ctxt_inst_ty binds from_here orig_mod uprags pragma src_loc))
569 U_dbind dbindts srcline -> -- "default" declaration
570 wlkList rdMonoType dbindts `thenUgn` \ tys ->
571 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
572 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
574 U_mbind mod mbindimp srcline ->
575 -- "import" declaration in an interface
576 wlkList rdEntity mbindimp `thenUgn` \ entities ->
577 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
578 returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities src_loc))
581 -- "infix" declarations in an interface
582 wlkList rdFixOp fixes `thenUgn` \ fixities ->
583 returnUgn (RdrIfaceFixities fixities)
586 -- signature(-like) things, including user pragmas
587 wlk_sig_thing a_sig_we_hope
591 wlkDerivings :: U_maybe -> UgnM (Maybe [ProtoName])
593 wlkDerivings (U_nothing) = returnUgn Nothing
594 wlkDerivings (U_just pt)
595 = rdU_list pt `thenUgn` \ ds ->
596 wlkList rdQid ds `thenUgn` \ derivs ->
597 returnUgn (Just derivs)
601 wlk_sig_thing (U_sbind sbindids sbindid srcline spragma) -- type signature
602 = wlkList rdQid sbindids `thenUgn` \ vars ->
603 wlkPolyType sbindid `thenUgn` \ poly_ty ->
604 wlkTySigPragmas spragma `thenUgn` \ pragma ->
605 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
606 returnUgn (RdrTySig vars poly_ty pragma src_loc)
608 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) -- value specialisation user-pragma
609 = wlkQid uvar `thenUgn` \ var ->
610 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
611 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
612 returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
613 | (ty, using_id) <- tys_and_ids ])
615 rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
617 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
618 wlkPolyType vspec_ty `thenUgn` \ ty ->
619 wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
620 returnUgn(ty, id_maybe)
622 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)-- instance specialisation user-pragma
623 = wlkQid iclas `thenUgn` \ clas ->
624 wlkMonoType ispec_ty `thenUgn` \ ty ->
625 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
626 returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
628 wlk_sig_thing (U_inline_uprag ivar srcline) -- value inlining user-pragma
629 = wlkQid ivar `thenUgn` \ var ->
630 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
631 returnUgn (RdrInlineValSig (InlineSig var src_loc))
633 wlk_sig_thing (U_deforest_uprag ivar srcline) -- "deforest me" user-pragma
634 = wlkQid ivar `thenUgn` \ var ->
635 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
636 returnUgn (RdrDeforestSig (DeforestSig var src_loc))
638 wlk_sig_thing (U_magicuf_uprag ivar str srcline) -- "magic" unfolding user-pragma
639 = wlkQid ivar `thenUgn` \ var ->
640 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
641 returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
643 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
644 = wlkQid itycon `thenUgn` \ tycon ->
645 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
646 wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
648 spec_ty = MonoTyApp tycon tys
650 returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
653 %************************************************************************
655 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
657 %************************************************************************
660 rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
661 rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
663 rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
664 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
666 wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType
667 wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
672 U_uniforall utvs uty -> -- forall type (pragmas)
673 wlkList rdU_unkId utvs `thenUgn` \ tvs ->
674 wlkMonoType uty `thenUgn` \ ty ->
675 returnUgn (HsForAllTy tvs ty)
678 U_context tcontextl tcontextt -> -- context
679 wlkContext tcontextl `thenUgn` \ ctxt ->
680 wlkMonoType tcontextt `thenUgn` \ ty ->
681 returnUgn (HsPreForAllTy ctxt ty)
683 other -> -- something else
684 wlkMonoType other `thenUgn` \ ty ->
685 returnUgn (HsPreForAllTy [{-no context-}] ty)
689 U_namedtvar tyvar -> -- type variable
690 returnUgn (MonoTyVar tyvar)
692 U_tname tcon -> -- type constructor
693 wlkQid tcon `thenUgn` \ tycon ->
694 returnUgn (MonoTyApp tycon [])
697 wlkMonoType t2 `thenUgn` \ ty2 ->
698 collect t1 [ty2] `thenUgn` \ (tycon, tys) ->
699 returnUgn (MonoTyApp tycon tys)
703 U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
705 U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
706 returnUgn (tycon, acc)
707 U_namedtvar tv -> returnUgn (tv, acc)
708 U_tllist _ -> panic "tlist"
709 U_ttuple _ -> panic "ttuple"
710 U_tfun _ _ -> panic "tfun"
711 U_tbang _ -> panic "tbang"
712 U_context _ _ -> panic "context"
713 _ -> panic "something else"
715 U_tllist tlist -> -- list type
716 wlkMonoType tlist `thenUgn` \ ty ->
717 returnUgn (MonoListTy ty)
720 wlkList rdMonoType ttuple `thenUgn` \ tys ->
721 returnUgn (MonoTupleTy tys)
724 wlkMonoType tfun `thenUgn` \ ty1 ->
725 wlkMonoType targ `thenUgn` \ ty2 ->
726 returnUgn (MonoFunTy ty1 ty2)
728 U_unidict uclas t -> -- DictTy (pragmas)
729 wlkQid uclas `thenUgn` \ clas ->
730 wlkMonoType t `thenUgn` \ ty ->
731 returnUgn (MonoDictTy clas ty)
735 wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
736 wlkContext :: U_list -> UgnM ProtoNameContext
737 wlkClassAssertTy :: U_ttype -> UgnM (ProtoName, ProtoName)
739 wlkTyConAndTyVars ttype
740 = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
742 args = [ a | (MonoTyVar a) <- ty_args ]
744 returnUgn (tycon, args)
747 = wlkList rdMonoType list `thenUgn` \ tys ->
748 returnUgn (map mk_class_assertion tys)
751 = wlkMonoType xs `thenUgn` \ mono_ty ->
752 returnUgn (mk_class_assertion mono_ty)
754 mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
756 mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
757 mk_class_assertion other
758 = pprError "ERROR: malformed type context: " (ppr PprForUser other)
759 -- regrettably, the parser does let some junk past
760 -- e.g., f :: Num {-nothing-} => a -> ...
764 rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
766 = rdU_constr pt `thenUgn` \ blah ->
769 wlkConDecl :: U_constr -> UgnM ProtoNameConDecl
771 wlkConDecl (U_constrpre ccon ctys srcline)
772 = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
773 wlkQid ccon `thenUgn` \ con ->
774 wlkList rdBangType ctys `thenUgn` \ tys ->
775 returnUgn (ConDecl con tys src_loc)
777 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
778 = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
779 wlkBangType cty1 `thenUgn` \ ty1 ->
780 wlkQid cop `thenUgn` \ op ->
781 wlkBangType cty2 `thenUgn` \ ty2 ->
782 returnUgn (ConOpDecl ty1 op ty2 src_loc)
784 wlkConDecl (U_constrnew ccon cty srcline)
785 = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
786 wlkQid ccon `thenUgn` \ con ->
787 wlkMonoType cty `thenUgn` \ ty ->
788 returnUgn (NewConDecl con ty src_loc)
790 wlkConDecl (U_constrrec ccon cfields srcline)
791 = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
792 wlkQid ccon `thenUgn` \ con ->
793 wlkList rd_field cfields `thenUgn` \ fields_lists ->
794 returnUgn (RecConDecl con fields_lists src_loc)
796 rd_field :: ParseTree -> UgnM ([ProtoName], BangType ProtoName)
798 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
799 wlkList rdQid fvars `thenUgn` \ vars ->
800 wlkBangType fty `thenUgn` \ ty ->
804 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
806 wlkBangType :: U_ttype -> UgnM (BangType ProtoName)
808 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged ty)
809 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
813 %************************************************************************
815 \subsection{Read a ``match''}
817 %************************************************************************
820 rdMatch :: ParseTree -> UgnM RdrMatch
823 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
825 wlkPat gpat `thenUgn` \ pat ->
826 wlkBinding gbind `thenUgn` \ binding ->
827 wlkQid gsrcfun `thenUgn` \ srcfun ->
829 wlk_guards (U_pnoguards exp)
830 = wlkExpr exp `thenUgn` \ expr ->
831 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
833 wlk_guards (U_pguards gs)
834 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
835 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
840 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
841 wlkExpr g `thenUgn` \ guard ->
842 wlkExpr e `thenUgn` \ expr ->
843 returnUgn (guard, expr)
846 %************************************************************************
848 \subsection[rdFixOp]{Read in a fixity declaration}
850 %************************************************************************
853 rdFixOp :: ParseTree -> UgnM ProtoNameFixityDecl
855 = rdU_tree pt `thenUgn` \ fix ->
857 U_fixop op (-1) prec -> returnUgn (InfixL op prec)
858 U_fixop op 0 prec -> returnUgn (InfixN op prec)
859 U_fixop op 1 prec -> returnUgn (InfixR op prec)
860 _ -> error "ReadPrefix:rdFixOp"
863 %************************************************************************
865 \subsection[rdImportedInterface]{Read an imported interface}
867 %************************************************************************
870 rdImportedInterface :: ParseTree
871 -> UgnM ProtoNameImportedInterface
873 rdImportedInterface pt
875 `thenUgn` \ (U_import ifname iffile binddef imod iqual ias ispec srcline) ->
877 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
878 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
879 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
881 setSrcFileUgn iffile ( -- looking inside the .hi file...
883 ) `thenUgn` \ iface_bs ->
885 case (sepDeclsForInterface iface_bs) of {
886 (tydecls,classdecls,instdecls,sigs,iimpdecls,ifixities) ->
888 cv_sigs = concat (map cvValSig sigs)
890 cv_iface = Interface ifname iimpdecls ifixities
891 tydecls classdecls instdecls cv_sigs
894 cv_qual = case iqual of {0 -> False; 1 -> True}
896 returnUgn (ImportMod cv_iface cv_qual maybe_as maybe_spec)
899 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
901 U_left pt -> rdEntities pt `thenUgn` \ ents ->
902 returnUgn (False, ents)
903 U_right pt -> rdEntities pt `thenUgn` \ ents ->
904 returnUgn (True, ents)
909 = rdU_list pt `thenUgn` \ list ->
910 wlkList rdEntity list
912 rdEntity :: ParseTree -> UgnM (IE ProtoName)
915 = rdU_entidt pt `thenUgn` \ entity ->
917 U_entid evar -> -- just a value
918 wlkQid evar `thenUgn` \ var ->
919 returnUgn (IEVar var)
921 U_enttype x -> -- abstract type constructor/class
922 wlkQid x `thenUgn` \ thing ->
923 returnUgn (IEThingAbs thing)
925 U_enttypeall x -> -- non-abstract type constructor/class
926 wlkQid x `thenUgn` \ thing ->
927 returnUgn (IEThingAll thing)
929 U_enttypenamed x ns -> -- non-abstract type constructor/class
930 -- with specified constrs/methods
931 wlkQid x `thenUgn` \ thing ->
932 wlkList rdQid ns `thenUgn` \ names ->
933 returnUgn (IEThingAll thing)
934 -- returnUgn (IEThingWith thing names)
936 U_entmod mod -> -- everything provided by a module
937 returnUgn (IEModuleContents mod)