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, 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 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 ->
355 returnUgn (rvar, expr_maybe)
358 Patterns: just bear in mind that lists of patterns are represented as
359 a series of ``applications''.
363 U_par pat -> -- parenthesised pattern
366 U_as avar as_pat -> -- "as" pattern
367 wlkQid avar `thenUgn` \ var ->
368 wlkPat as_pat `thenUgn` \ pat ->
369 returnUgn (AsPatIn var pat)
371 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
372 wlkPat lazyp `thenUgn` \ pat ->
373 returnUgn (LazyPatIn pat)
375 U_wildp -> returnUgn WildPatIn -- wildcard pattern
377 --------------------------------------------------------------
378 -- now the prefix items that can either be an expression or
379 -- pattern, except we know they are *patterns* here.
380 --------------------------------------------------------------
381 U_negate nexp _ _ -> -- negated pattern: must be a literal
382 wlkPat nexp `thenUgn` \ lit_pat ->
384 LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit))
385 _ -> panic "wlkPat: bad negated pattern!"
387 U_lit lit -> -- literal pattern
388 wlkLiteral lit `thenUgn` \ lit ->
389 returnUgn (LitPatIn lit)
391 U_ident nn -> -- simple identifier
392 wlkQid nn `thenUgn` \ n ->
399 U_ap l r -> -- "application": there's a list of patterns lurking here!
400 wlkPat r `thenUgn` \ rpat ->
401 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
405 VarPatIn x -> (x, lpats)
406 ConPatIn x [] -> (x, lpats)
407 ConOpPatIn x op y -> (op, x:y:lpats)
408 _ -> -- sorry about the weedy msg; the parser missed this one
409 error (ppShow 100 (ppCat [
410 ppStr "ERROR: an illegal `application' of a pattern to another one:",
411 ppInterleave ppSP (map (ppr PprForUser) (lpat:lpats))]))
413 returnUgn (ConPatIn n arg_pats)
418 wlkPat r `thenUgn` \ rpat ->
419 collect_pats l (rpat:acc)
421 wlkPat other `thenUgn` \ pat ->
424 U_infixap fun arg1 arg2 ->
425 wlkQid fun `thenUgn` \ op ->
426 wlkPat arg1 `thenUgn` \ pat1 ->
427 wlkPat arg2 `thenUgn` \ pat2 ->
428 returnUgn (ConOpPatIn pat1 op pat2)
430 U_llist llist -> -- explicit list
431 wlkList rdPat llist `thenUgn` \ pats ->
432 returnUgn (ListPatIn pats)
434 U_tuple tuplelist -> -- explicit tuple
435 wlkList rdPat tuplelist `thenUgn` \ pats ->
436 returnUgn (TuplePatIn pats)
438 U_record con rpats -> -- record destruction
439 wlkQid con `thenUgn` \ rcon ->
440 wlkList rdRpat rpats `thenUgn` \ recpats ->
441 returnUgn (RecPatIn rcon recpats)
444 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
445 wlkQid var `thenUgn` \ rvar ->
446 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
447 returnUgn (rvar, pat_maybe)
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
485 U_nullbind -> -- null binding
486 returnUgn RdrNullBind
488 U_abind a b -> -- "and" binding (just glue, really)
489 wlkBinding a `thenUgn` \ binding1 ->
490 wlkBinding b `thenUgn` \ binding2 ->
491 returnUgn (RdrAndBindings binding1 binding2)
493 U_tbind tctxt ttype tcons tderivs srcline tpragma -> -- "data" declaration
494 wlkContext tctxt `thenUgn` \ ctxt ->
495 wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
496 wlkList rdConDecl tcons `thenUgn` \ cons ->
497 wlkDerivings tderivs `thenUgn` \ derivings ->
498 wlkDataPragma tpragma `thenUgn` \ pragmas ->
499 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
500 returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings pragmas src_loc))
502 U_ntbind ntctxt nttype ntcon ntderivs srcline ntpragma -> -- "newtype" declaration
503 wlkContext ntctxt `thenUgn` \ ctxt ->
504 wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
505 wlkList rdConDecl ntcon `thenUgn` \ con ->
506 wlkDerivings ntderivs `thenUgn` \ derivings ->
507 wlkDataPragma ntpragma `thenUgn` \ pragma ->
508 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
509 returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings pragma src_loc))
511 U_nbind nbindid nbindas srcline -> -- "type" declaration
512 wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
513 wlkMonoType nbindas `thenUgn` \ expansion ->
514 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
515 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
517 U_fbind fbindl srcline -> -- function binding
518 wlkList rdMatch fbindl `thenUgn` \ matches ->
519 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
520 returnUgn (RdrFunctionBinding srcline matches)
522 U_pbind pbindl srcline -> -- pattern binding
523 wlkList rdMatch pbindl `thenUgn` \ matches ->
524 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
525 returnUgn (RdrPatternBinding srcline matches)
527 U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration
528 wlkContext cbindc `thenUgn` \ ctxt ->
529 wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
530 wlkBinding cbindw `thenUgn` \ binding ->
531 wlkClassPragma cpragma `thenUgn` \ pragma ->
532 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
533 getSrcFileUgn `thenUgn` \ sf ->
535 (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
537 final_sigs = concat (map cvClassOpSig class_sigs)
538 final_methods = cvMonoBinds sf class_methods
540 returnUgn (RdrClassDecl
541 (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc))
543 U_ibind from_source orig_mod -- "instance" declaration
544 ibindc iclas ibindi ibindw srcline ipragma ->
545 wlkContext ibindc `thenUgn` \ ctxt ->
546 wlkQid iclas `thenUgn` \ clas ->
547 wlkMonoType ibindi `thenUgn` \ inst_ty ->
548 wlkBinding ibindw `thenUgn` \ binding ->
549 wlkInstPragma ipragma `thenUgn` \ pragma ->
550 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
551 getSrcFileUgn `thenUgn` \ sf ->
553 from_here = case from_source of { 0 -> False; 1 -> True }
554 (ss, bs) = sepDeclsIntoSigsAndBinds binding
555 binds = cvMonoBinds sf bs
556 uprags = concat (map cvInstDeclSig ss)
557 ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
559 returnUgn (RdrInstDecl
560 (InstDecl clas ctxt_inst_ty binds from_here orig_mod uprags pragma src_loc))
562 U_dbind dbindts srcline -> -- "default" declaration
563 wlkList rdMonoType dbindts `thenUgn` \ tys ->
564 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
565 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
567 U_mbind mod mbindimp srcline ->
568 -- "import" declaration in an interface
569 wlkList rdEntity mbindimp `thenUgn` \ entities ->
570 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
571 returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities src_loc))
574 -- "infix" declarations in an interface
575 wlkList rdFixOp fixes `thenUgn` \ fixities ->
576 returnUgn (RdrIfaceFixities fixities)
579 -- signature(-like) things, including user pragmas
580 wlk_sig_thing a_sig_we_hope
584 wlkDerivings :: U_maybe -> UgnM (Maybe [ProtoName])
586 wlkDerivings (U_nothing) = returnUgn Nothing
587 wlkDerivings (U_just pt)
588 = rdU_list pt `thenUgn` \ ds ->
589 wlkList rdQid ds `thenUgn` \ derivs ->
590 returnUgn (Just derivs)
594 wlk_sig_thing (U_sbind sbindids sbindid srcline spragma) -- type signature
595 = wlkList rdQid sbindids `thenUgn` \ vars ->
596 wlkPolyType sbindid `thenUgn` \ poly_ty ->
597 wlkTySigPragmas spragma `thenUgn` \ pragma ->
598 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
599 returnUgn (RdrTySig vars poly_ty pragma src_loc)
601 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) -- value specialisation user-pragma
602 = wlkQid uvar `thenUgn` \ var ->
603 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
604 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
605 returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
606 | (ty, using_id) <- tys_and_ids ])
608 rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName)
610 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
611 wlkPolyType vspec_ty `thenUgn` \ ty ->
612 wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
613 returnUgn(ty, id_maybe)
615 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)-- instance specialisation user-pragma
616 = wlkQid iclas `thenUgn` \ clas ->
617 wlkMonoType ispec_ty `thenUgn` \ ty ->
618 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
619 returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
621 wlk_sig_thing (U_inline_uprag ivar srcline) -- value inlining user-pragma
622 = wlkQid ivar `thenUgn` \ var ->
623 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
624 returnUgn (RdrInlineValSig (InlineSig var src_loc))
626 wlk_sig_thing (U_deforest_uprag ivar srcline) -- "deforest me" user-pragma
627 = wlkQid ivar `thenUgn` \ var ->
628 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
629 returnUgn (RdrDeforestSig (DeforestSig var src_loc))
631 wlk_sig_thing (U_magicuf_uprag ivar str srcline) -- "magic" unfolding user-pragma
632 = wlkQid ivar `thenUgn` \ var ->
633 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
634 returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
636 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
637 = wlkQid itycon `thenUgn` \ tycon ->
638 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
639 wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
641 spec_ty = MonoTyApp tycon tys
643 returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc))
646 %************************************************************************
648 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
650 %************************************************************************
653 rdPolyType :: ParseTree -> UgnM ProtoNamePolyType
654 rdMonoType :: ParseTree -> UgnM ProtoNameMonoType
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 ProtoNamePolyType
660 wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType
665 U_uniforall utvs uty -> -- forall type (pragmas)
666 wlkList rdU_unkId utvs `thenUgn` \ tvs ->
667 wlkMonoType uty `thenUgn` \ ty ->
668 returnUgn (HsForAllTy tvs ty)
671 U_context tcontextl tcontextt -> -- context
672 wlkContext tcontextl `thenUgn` \ ctxt ->
673 wlkMonoType tcontextt `thenUgn` \ ty ->
674 returnUgn (HsPreForAllTy ctxt ty)
676 other -> -- something else
677 wlkMonoType other `thenUgn` \ ty ->
678 returnUgn (HsPreForAllTy [{-no context-}] ty)
682 U_namedtvar tyvar -> -- type variable
683 returnUgn (MonoTyVar tyvar)
685 U_tname tcon -> -- type constructor
686 wlkQid tcon `thenUgn` \ tycon ->
687 returnUgn (MonoTyApp tycon [])
690 wlkMonoType t2 `thenUgn` \ ty2 ->
691 collect t1 [ty2] `thenUgn` \ (tycon, tys) ->
692 returnUgn (MonoTyApp tycon tys)
696 U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
698 U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
699 returnUgn (tycon, acc)
700 U_namedtvar tv -> returnUgn (tv, acc)
701 U_tllist _ -> panic "tlist"
702 U_ttuple _ -> panic "ttuple"
703 U_tfun _ _ -> panic "tfun"
704 U_tbang _ -> panic "tbang"
705 U_context _ _ -> panic "context"
706 _ -> panic "something else"
708 U_tllist tlist -> -- list type
709 wlkMonoType tlist `thenUgn` \ ty ->
710 returnUgn (MonoListTy ty)
713 wlkList rdMonoType ttuple `thenUgn` \ tys ->
714 returnUgn (MonoTupleTy tys)
717 wlkMonoType tfun `thenUgn` \ ty1 ->
718 wlkMonoType targ `thenUgn` \ ty2 ->
719 returnUgn (MonoFunTy ty1 ty2)
721 U_unidict uclas t -> -- DictTy (pragmas)
722 wlkQid uclas `thenUgn` \ clas ->
723 wlkMonoType t `thenUgn` \ ty ->
724 returnUgn (MonoDictTy clas ty)
728 wlkTyConAndTyVars :: U_ttype -> UgnM (ProtoName, [ProtoName])
729 wlkContext :: U_list -> UgnM ProtoNameContext
730 wlkClassAssertTy :: U_ttype -> UgnM (ProtoName, ProtoName)
732 wlkTyConAndTyVars ttype
733 = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
735 args = [ a | (MonoTyVar a) <- ty_args ]
737 returnUgn (tycon, args)
740 = wlkList rdMonoType list `thenUgn` \ tys ->
741 returnUgn (map mk_class_assertion tys)
744 = wlkMonoType xs `thenUgn` \ mono_ty ->
745 returnUgn (mk_class_assertion mono_ty)
747 mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
749 mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
750 mk_class_assertion other
751 = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
752 -- regrettably, the parser does let some junk past
753 -- e.g., f :: Num {-nothing-} => a -> ...
757 rdConDecl :: ParseTree -> UgnM ProtoNameConDecl
759 = rdU_constr pt `thenUgn` \ blah ->
762 wlkConDecl :: U_constr -> UgnM ProtoNameConDecl
764 wlkConDecl (U_constrpre ccon ctys srcline)
765 = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
766 wlkQid ccon `thenUgn` \ con ->
767 wlkList rdBangType ctys `thenUgn` \ tys ->
768 returnUgn (ConDecl con tys src_loc)
770 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
771 = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
772 wlkBangType cty1 `thenUgn` \ ty1 ->
773 wlkQid cop `thenUgn` \ op ->
774 wlkBangType cty2 `thenUgn` \ ty2 ->
775 returnUgn (ConOpDecl ty1 op ty2 src_loc)
777 wlkConDecl (U_constrnew ccon cty srcline)
778 = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
779 wlkQid ccon `thenUgn` \ con ->
780 wlkMonoType cty `thenUgn` \ ty ->
781 returnUgn (NewConDecl con ty src_loc)
783 wlkConDecl (U_constrrec ccon cfields srcline)
784 = mkSrcLocUgn srcline `thenUgn` \ src_loc ->
785 wlkQid ccon `thenUgn` \ con ->
786 wlkList rd_field cfields `thenUgn` \ fields_lists ->
787 returnUgn (RecConDecl con (concat fields_lists) src_loc)
789 rd_field :: ParseTree -> UgnM [(ProtoName, BangType ProtoName)]
791 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
792 wlkList rdQid fvars `thenUgn` \ vars ->
793 wlkBangType fty `thenUgn` \ ty ->
794 returnUgn [ (var, ty) | var <- vars ]
797 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
799 wlkBangType :: U_ttype -> UgnM (BangType ProtoName)
801 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged ty)
802 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
806 %************************************************************************
808 \subsection{Read a ``match''}
810 %************************************************************************
813 rdMatch :: ParseTree -> UgnM RdrMatch
816 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
818 wlkPat gpat `thenUgn` \ pat ->
819 wlkBinding gbind `thenUgn` \ binding ->
820 wlkQid gsrcfun `thenUgn` \ srcfun ->
822 wlk_guards (U_pnoguards exp)
823 = wlkExpr exp `thenUgn` \ expr ->
824 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
826 wlk_guards (U_pguards gs)
827 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
828 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
833 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
834 wlkExpr g `thenUgn` \ guard ->
835 wlkExpr e `thenUgn` \ expr ->
836 returnUgn (guard, expr)
839 %************************************************************************
841 \subsection[rdFixOp]{Read in a fixity declaration}
843 %************************************************************************
846 rdFixOp :: ParseTree -> UgnM ProtoNameFixityDecl
848 = rdU_tree pt `thenUgn` \ fix ->
850 U_fixop op (-1) prec -> returnUgn (InfixL op prec)
851 U_fixop op 0 prec -> returnUgn (InfixN op prec)
852 U_fixop op 1 prec -> returnUgn (InfixR op prec)
853 _ -> error "ReadPrefix:rdFixOp"
856 %************************************************************************
858 \subsection[rdImportedInterface]{Read an imported interface}
860 %************************************************************************
863 rdImportedInterface :: ParseTree
864 -> UgnM ProtoNameImportedInterface
866 rdImportedInterface pt
868 `thenUgn` \ (U_import ifname iffile binddef imod iqual ias ispec srcline) ->
870 mkSrcLocUgn srcline `thenUgn` \ src_loc ->
871 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
872 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
874 setSrcFileUgn iffile ( -- looking inside the .hi file...
876 ) `thenUgn` \ iface_bs ->
878 case (sepDeclsForInterface iface_bs) of {
879 (tydecls,classdecls,instdecls,sigs,iimpdecls,ifixities) ->
881 cv_sigs = concat (map cvValSig sigs)
883 cv_iface = Interface ifname iimpdecls ifixities
884 tydecls classdecls instdecls cv_sigs
887 cv_qual = case iqual of {0 -> False; 1 -> True}
889 returnUgn (ImportMod cv_iface cv_qual maybe_as maybe_spec)
892 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
894 U_left pt -> rdEntities pt `thenUgn` \ ents ->
895 returnUgn (False, ents)
896 U_right pt -> rdEntities pt `thenUgn` \ ents ->
897 returnUgn (True, ents)
902 = rdU_list pt `thenUgn` \ list ->
903 wlkList rdEntity list
905 rdEntity :: ParseTree -> UgnM (IE ProtoName)
908 = rdU_entidt pt `thenUgn` \ entity ->
910 U_entid evar -> -- just a value
911 wlkQid evar `thenUgn` \ var ->
912 returnUgn (IEVar var)
914 U_enttype x -> -- abstract type constructor/class
915 wlkQid x `thenUgn` \ thing ->
916 returnUgn (IEThingAbs thing)
918 U_enttypeall x -> -- non-abstract type constructor/class
919 wlkQid x `thenUgn` \ thing ->
920 returnUgn (IEThingAll thing)
922 U_enttypenamed x ns -> -- non-abstract type constructor/class
923 -- with specified constrs/methods
924 wlkQid x `thenUgn` \ thing ->
925 wlkList rdQid ns `thenUgn` \ names ->
926 returnUgn (IEThingAll thing)
927 -- returnUgn (IEThingWith thing names)
929 U_entmod mod -> -- everything provided by a module
930 returnUgn (IEModuleContents mod)