2 % (c) The AQUA Project, Glasgow University, 1994-1996
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, noInstancePragmas, noGenPragmas )
17 import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
20 import CmdLineOpts ( opt_NoImplicitPrelude )
21 import FiniteMap ( elemFM, FiniteMap )
22 import Name ( OccName(..), Module )
23 import Lex ( isLexConId )
25 import PrelMods ( pRELUDE )
26 import Util ( nOfThem )
27 import FastString ( mkFastCharString )
28 import IO ( hPutStr, stderr )
29 import PrelRead ( readRational__ )
32 %************************************************************************
34 \subsection[ReadPrefix-help]{Help Functions}
36 %************************************************************************
39 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
41 wlkList wlk_it U_lnil = returnUgn []
43 wlkList wlk_it (U_lcons hd tl)
44 = wlk_it hd `thenUgn` \ hd_it ->
45 wlkList wlk_it tl `thenUgn` \ tl_it ->
46 returnUgn (hd_it : tl_it)
50 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
52 wlkMaybe wlk_it U_nothing = returnUgn Nothing
53 wlkMaybe wlk_it (U_just x)
54 = wlk_it x `thenUgn` \ it ->
59 wlkTvId = wlkQid TvOcc
60 wlkTCId = wlkQid TCOcc
61 wlkVarId = wlkQid VarOcc
62 wlkDataId = wlkQid VarOcc
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 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)
91 rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
92 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
94 cvFlag :: U_long -> Bool
99 %************************************************************************
101 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
103 %************************************************************************
106 rdModule :: IO (Module, -- this module's name
107 RdrNameHsModule) -- the main goods
110 = _ccall_ hspmain >>= \ pt -> -- call the Yacc parser!
112 srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
115 rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
116 hmodlist srciface_version srcline) ->
118 setSrcFileUgn srcfile $
119 setSrcModUgn modname $
120 mkSrcLocUgn srcline $ \ src_loc ->
122 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
123 wlkList rdImport himplist `thenUgn` \ imports ->
124 wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
125 wlkBinding hmodlist `thenUgn` \ binding ->
128 val_decl = ValD (cvBinds srcfile cvValSig binding)
129 other_decls = cvOtherDecls binding
133 (case srciface_version of { 0 -> Nothing; n -> Just n })
137 (val_decl: other_decls)
142 %************************************************************************
144 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
146 %************************************************************************
149 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
150 rdPat :: ParseTree -> UgnM RdrNamePat
152 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
153 rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
155 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
156 wlkPat :: U_tree -> UgnM RdrNamePat
160 U_par pexpr -> -- parenthesised expr
161 wlkExpr pexpr `thenUgn` \ expr ->
162 returnUgn (HsPar expr)
164 U_lsection lsexp lop -> -- left section
165 wlkExpr lsexp `thenUgn` \ expr ->
166 wlkVarId lop `thenUgn` \ op ->
167 returnUgn (SectionL expr (HsVar op))
169 U_rsection rop rsexp -> -- right section
170 wlkVarId rop `thenUgn` \ op ->
171 wlkExpr rsexp `thenUgn` \ expr ->
172 returnUgn (SectionR (HsVar op) expr)
174 U_ccall fun flavor ccargs -> -- ccall/casm
175 wlkList rdExpr ccargs `thenUgn` \ args ->
179 returnUgn (CCall fun args
180 (tag == 'p' || tag == 'P') -- may invoke GC
181 (tag == 'N' || tag == 'P') -- really a "casm"
182 (panic "CCall:result_ty"))
184 U_scc label sccexp -> -- scc (set-cost-centre) expression
185 wlkExpr sccexp `thenUgn` \ expr ->
186 returnUgn (HsSCC label expr)
188 U_lambda lampats lamexpr srcline -> -- lambda expression
189 mkSrcLocUgn srcline $ \ src_loc ->
190 wlkList rdPat lampats `thenUgn` \ pats ->
191 wlkExpr lamexpr `thenUgn` \ body ->
193 HsLam (foldr PatMatch
194 (GRHSMatch (GRHSsAndBindsIn
195 (unguardedRHS body src_loc)
200 U_casee caseexpr casebody srcline -> -- case expression
201 mkSrcLocUgn srcline $ \ src_loc ->
202 wlkExpr caseexpr `thenUgn` \ expr ->
203 wlkList rdMatch casebody `thenUgn` \ mats ->
204 getSrcFileUgn `thenUgn` \ sf ->
206 matches = cvMatches sf True mats
208 returnUgn (HsCase expr matches src_loc)
210 U_ife ifpred ifthen ifelse srcline -> -- if expression
211 mkSrcLocUgn srcline $ \ src_loc ->
212 wlkExpr ifpred `thenUgn` \ e1 ->
213 wlkExpr ifthen `thenUgn` \ e2 ->
214 wlkExpr ifelse `thenUgn` \ e3 ->
215 returnUgn (HsIf e1 e2 e3 src_loc)
217 U_let letvdefs letvexpr -> -- let expression
218 wlkBinding letvdefs `thenUgn` \ binding ->
219 wlkExpr letvexpr `thenUgn` \ expr ->
220 getSrcFileUgn `thenUgn` \ sf ->
222 binds = cvBinds sf cvValSig binding
224 returnUgn (HsLet binds expr)
226 U_doe gdo srcline -> -- do expression
227 mkSrcLocUgn srcline $ \ src_loc ->
228 wlkList rd_stmt gdo `thenUgn` \ stmts ->
229 returnUgn (HsDo DoStmt stmts src_loc)
232 = rdU_tree pt `thenUgn` \ bind ->
234 U_doexp exp srcline ->
235 mkSrcLocUgn srcline $ \ src_loc ->
236 wlkExpr exp `thenUgn` \ expr ->
237 returnUgn (ExprStmt expr src_loc)
239 U_dobind pat exp srcline ->
240 mkSrcLocUgn srcline $ \ src_loc ->
241 wlkPat pat `thenUgn` \ patt ->
242 wlkExpr exp `thenUgn` \ expr ->
243 returnUgn (BindStmt patt expr src_loc)
246 wlkBinding seqlet `thenUgn` \ bs ->
247 getSrcFileUgn `thenUgn` \ sf ->
249 binds = cvBinds sf cvValSig bs
251 returnUgn (LetStmt binds)
253 U_comprh cexp cquals -> -- list comprehension
254 wlkExpr cexp `thenUgn` \ expr ->
255 wlkQuals cquals `thenUgn` \ quals ->
256 getSrcLocUgn `thenUgn` \ loc ->
257 returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
259 U_eenum efrom estep eto -> -- arithmetic sequence
260 wlkExpr efrom `thenUgn` \ e1 ->
261 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
262 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
263 returnUgn (cv_arith_seq e1 es2 es3)
265 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
266 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
267 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
268 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
270 U_restr restre restrt -> -- expression with type signature
271 wlkExpr restre `thenUgn` \ expr ->
272 wlkHsType restrt `thenUgn` \ ty ->
273 returnUgn (ExprWithTySig expr ty)
275 --------------------------------------------------------------
276 -- now the prefix items that can either be an expression or
277 -- pattern, except we know they are *expressions* here
278 -- (this code could be commoned up with the pattern version;
279 -- but it probably isn't worth it)
280 --------------------------------------------------------------
282 wlkLiteral lit `thenUgn` \ lit ->
283 returnUgn (HsLit lit)
285 U_ident n -> -- simple identifier
286 wlkVarId n `thenUgn` \ var ->
287 returnUgn (HsVar var)
289 U_ap fun arg -> -- application
290 wlkExpr fun `thenUgn` \ expr1 ->
291 wlkExpr arg `thenUgn` \ expr2 ->
292 returnUgn (HsApp expr1 expr2)
294 U_infixap fun arg1 arg2 -> -- infix application
295 wlkVarId fun `thenUgn` \ op ->
296 wlkExpr arg1 `thenUgn` \ expr1 ->
297 wlkExpr arg2 `thenUgn` \ expr2 ->
298 returnUgn (mkOpApp expr1 op expr2)
300 U_negate nexp -> -- prefix negation
301 wlkExpr nexp `thenUgn` \ expr ->
302 returnUgn (NegApp expr (HsVar dummyRdrVarName))
304 U_llist llist -> -- explicit list
305 wlkList rdExpr llist `thenUgn` \ exprs ->
306 returnUgn (ExplicitList exprs)
308 U_tuple tuplelist -> -- explicit tuple
309 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
310 returnUgn (ExplicitTuple exprs)
312 U_record con rbinds -> -- record construction
313 wlkDataId con `thenUgn` \ rcon ->
314 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
315 returnUgn (RecordCon rcon (HsVar rcon) recbinds)
317 U_rupdate updexp updbinds -> -- record update
318 wlkExpr updexp `thenUgn` \ aexp ->
319 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
320 returnUgn (RecordUpd aexp recbinds)
323 U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
324 U_as _ _ -> error "U_as"
325 U_lazyp _ -> error "U_lazyp"
326 U_wildp -> error "U_wildp"
327 U_qual _ _ -> error "U_qual"
328 U_guard _ -> error "U_guard"
329 U_seqlet _ -> error "U_seqlet"
330 U_dobind _ _ _ -> error "U_dobind"
331 U_doexp _ _ -> error "U_doexp"
332 U_rbind _ _ -> error "U_rbind"
333 U_fixop _ _ _ _ -> error "U_fixop"
337 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
338 wlkVarId var `thenUgn` \ rvar ->
339 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
342 Nothing -> (rvar, HsVar rvar, True{-pun-})
343 Just re -> (rvar, re, False)
347 = wlkList rd_qual cquals
350 = rdU_tree pt `thenUgn` \ qual ->
356 wlkExpr exp `thenUgn` \ expr ->
357 getSrcLocUgn `thenUgn` \ loc ->
358 returnUgn (GuardStmt expr loc)
361 wlkPat qpat `thenUgn` \ pat ->
362 wlkExpr qexp `thenUgn` \ expr ->
363 getSrcLocUgn `thenUgn` \ loc ->
364 returnUgn (BindStmt pat expr loc)
367 wlkBinding seqlet `thenUgn` \ bs ->
368 getSrcFileUgn `thenUgn` \ sf ->
370 binds = cvBinds sf cvValSig bs
372 returnUgn (LetStmt binds)
373 U_let letvdefs letvexpr ->
374 wlkBinding letvdefs `thenUgn` \ binding ->
375 wlkExpr letvexpr `thenUgn` \ expr ->
376 getSrcLocUgn `thenUgn` \ loc ->
377 getSrcFileUgn `thenUgn` \ sf ->
379 binds = cvBinds sf cvValSig binding
381 returnUgn (GuardStmt (HsLet binds expr) loc)
384 Patterns: just bear in mind that lists of patterns are represented as
385 a series of ``applications''.
389 U_par ppat -> -- parenthesised pattern
390 wlkPat ppat `thenUgn` \ pat ->
391 -- tidy things up a little:
396 other -> ParPatIn pat
399 U_as avar as_pat -> -- "as" pattern
400 wlkVarId avar `thenUgn` \ var ->
401 wlkPat as_pat `thenUgn` \ pat ->
402 returnUgn (AsPatIn var pat)
404 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
405 wlkPat lazyp `thenUgn` \ pat ->
406 returnUgn (LazyPatIn pat)
409 wlkVarId avar `thenUgn` \ var ->
410 wlkLiteral lit `thenUgn` \ lit ->
411 returnUgn (NPlusKPatIn var lit)
413 U_wildp -> returnUgn WildPatIn -- wildcard pattern
415 U_lit lit -> -- literal pattern
416 wlkLiteral lit `thenUgn` \ lit ->
417 returnUgn (LitPatIn lit)
419 U_ident nn -> -- simple identifier
420 wlkVarId nn `thenUgn` \ n ->
423 VarOcc occ | isLexConId occ -> ConPatIn n []
427 U_ap l r -> -- "application": there's a list of patterns lurking here!
428 wlkPat r `thenUgn` \ rpat ->
429 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
431 VarPatIn x -> returnUgn (x, lpats)
432 ConPatIn x [] -> returnUgn (x, lpats)
433 ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
434 _ -> getSrcLocUgn `thenUgn` \ loc ->
435 pprPanic "Illegal pattern `application'"
436 (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
438 ) `thenUgn` \ (n, arg_pats) ->
439 returnUgn (ConPatIn n arg_pats)
444 wlkPat r `thenUgn` \ rpat ->
445 collect_pats l (rpat:acc)
447 wlkPat other `thenUgn` \ pat ->
450 U_infixap fun arg1 arg2 -> -- infix pattern
451 wlkVarId fun `thenUgn` \ op ->
452 wlkPat arg1 `thenUgn` \ pat1 ->
453 wlkPat arg2 `thenUgn` \ pat2 ->
454 returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
456 U_negate npat -> -- negated pattern
457 wlkPat npat `thenUgn` \ pat ->
458 returnUgn (NegPatIn pat)
460 U_llist llist -> -- explicit list
461 wlkList rdPat llist `thenUgn` \ pats ->
462 returnUgn (ListPatIn pats)
464 U_tuple tuplelist -> -- explicit tuple
465 wlkList rdPat tuplelist `thenUgn` \ pats ->
466 returnUgn (TuplePatIn pats)
468 U_record con rpats -> -- record destruction
469 wlkDataId con `thenUgn` \ rcon ->
470 wlkList rdRpat rpats `thenUgn` \ recpats ->
471 returnUgn (RecPatIn rcon recpats)
474 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
475 wlkVarId var `thenUgn` \ rvar ->
476 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
479 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
480 Just rp -> (rvar, rp, False)
485 wlkLiteral :: U_literal -> UgnM HsLit
490 U_integer s -> HsInt (as_integer s)
491 U_floatr s -> HsFrac (as_rational s)
492 U_intprim s -> HsIntPrim (as_integer s)
493 U_doubleprim s -> HsDoublePrim (as_rational s)
494 U_floatprim s -> HsFloatPrim (as_rational s)
495 U_charr s -> HsChar (as_char s)
496 U_charprim s -> HsCharPrim (as_char s)
497 U_string s -> HsString (as_string s)
498 U_stringprim s -> HsStringPrim (as_string s)
499 U_clitlit s -> HsLitLit (as_string s)
503 as_integer s = readInteger (_UNPK_ s)
504 as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
505 -- to handle rationals with leading '-'
509 %************************************************************************
511 \subsection{wlkBinding}
513 %************************************************************************
516 wlkBinding :: U_binding -> UgnM RdrBinding
522 returnUgn RdrNullBind
524 -- "and" binding (just glue, really)
526 wlkBinding a `thenUgn` \ binding1 ->
527 wlkBinding b `thenUgn` \ binding2 ->
528 returnUgn (RdrAndBindings binding1 binding2)
530 -- "data" declaration
531 U_tbind tctxt ttype tcons tderivs srcline ->
532 mkSrcLocUgn srcline $ \ src_loc ->
533 wlkContext tctxt `thenUgn` \ ctxt ->
534 wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
535 wlkList rdConDecl tcons `thenUgn` \ cons ->
536 wlkDerivings tderivs `thenUgn` \ derivings ->
537 returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
539 -- "newtype" declaration
540 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
541 mkSrcLocUgn srcline $ \ src_loc ->
542 wlkContext ntctxt `thenUgn` \ ctxt ->
543 wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
544 wlkList rdConDecl ntcon `thenUgn` \ cons ->
545 wlkDerivings ntderivs `thenUgn` \ derivings ->
546 returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
548 -- "type" declaration
549 U_nbind nbindid nbindas srcline ->
550 mkSrcLocUgn srcline $ \ src_loc ->
551 wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
552 wlkMonoType nbindas `thenUgn` \ expansion ->
553 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
556 U_fbind fbindl srcline ->
557 mkSrcLocUgn srcline $ \ src_loc ->
558 wlkList rdMatch fbindl `thenUgn` \ matches ->
559 returnUgn (RdrFunctionBinding srcline matches)
562 U_pbind pbindl srcline ->
563 mkSrcLocUgn srcline $ \ src_loc ->
564 wlkList rdMatch pbindl `thenUgn` \ matches ->
565 returnUgn (RdrPatternBinding srcline matches)
567 -- "class" declaration
568 U_cbind cbindc cbindid cbindw srcline ->
569 mkSrcLocUgn srcline $ \ src_loc ->
570 wlkContext cbindc `thenUgn` \ ctxt ->
571 wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) ->
572 wlkBinding cbindw `thenUgn` \ binding ->
573 getSrcFileUgn `thenUgn` \ sf ->
575 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
577 returnUgn (RdrClassDecl
578 (mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc))
580 -- "instance" declaration
581 U_ibind ty ibindw srcline ->
582 -- The "ty" contains the instance context too
583 -- So for "instance Eq a => Eq [a]" the type will be
585 mkSrcLocUgn srcline $ \ src_loc ->
586 wlkInstType ty `thenUgn` \ inst_ty ->
587 wlkBinding ibindw `thenUgn` \ binding ->
588 getSrcModUgn `thenUgn` \ modname ->
589 getSrcFileUgn `thenUgn` \ sf ->
591 (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
593 returnUgn (RdrInstDecl
594 (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
596 -- "default" declaration
597 U_dbind dbindts srcline ->
598 mkSrcLocUgn srcline $ \ src_loc ->
599 wlkList rdMonoType dbindts `thenUgn` \ tys ->
600 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
603 -- signature(-like) things, including user pragmas
604 wlk_sig_thing a_sig_we_hope
608 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
610 wlkDerivings (U_nothing) = returnUgn Nothing
611 wlkDerivings (U_just pt)
612 = rdU_list pt `thenUgn` \ ds ->
613 wlkList rdTCId ds `thenUgn` \ derivs ->
614 returnUgn (Just derivs)
619 wlk_sig_thing (U_sbind sbindids sbindid srcline)
620 = mkSrcLocUgn srcline $ \ src_loc ->
621 wlkList rdVarId sbindids `thenUgn` \ vars ->
622 wlkHsType sbindid `thenUgn` \ poly_ty ->
623 returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
625 -- value specialisation user-pragma
626 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
627 = mkSrcLocUgn srcline $ \ src_loc ->
628 wlkVarId uvar `thenUgn` \ var ->
629 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
630 returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
631 | (ty, using_id) <- tys_and_ids ])
633 rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
635 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
636 wlkHsType vspec_ty `thenUgn` \ ty ->
637 wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
638 returnUgn(ty, id_maybe)
640 -- instance specialisation user-pragma
641 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
642 = mkSrcLocUgn srcline $ \ src_loc ->
643 wlkHsType ispec_ty `thenUgn` \ ty ->
644 returnUgn (RdrSig (SpecInstSig ty src_loc))
646 -- value inlining user-pragma
647 wlk_sig_thing (U_inline_uprag ivar srcline)
648 = mkSrcLocUgn srcline $ \ src_loc ->
649 wlkVarId ivar `thenUgn` \ var ->
650 returnUgn (RdrSig (InlineSig var src_loc))
652 wlk_sig_thing (U_noinline_uprag ivar srcline)
653 = mkSrcLocUgn srcline $ \ src_loc ->
654 wlkVarId ivar `thenUgn` \ var ->
655 returnUgn (RdrSig (NoInlineSig var src_loc))
658 %************************************************************************
660 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
662 %************************************************************************
665 rdHsType :: ParseTree -> UgnM RdrNameHsType
666 rdMonoType :: ParseTree -> UgnM RdrNameHsType
668 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
669 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
671 wlkHsType :: U_ttype -> UgnM RdrNameHsType
672 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
676 U_context tcontextl tcontextt -> -- context
677 wlkContext tcontextl `thenUgn` \ ctxt ->
678 wlkMonoType tcontextt `thenUgn` \ ty ->
679 returnUgn (HsPreForAllTy ctxt ty)
681 other -> -- something else
682 wlkMonoType other `thenUgn` \ ty ->
683 returnUgn (HsPreForAllTy [{-no context-}] ty)
687 -- Glasgow extension: nested polymorhism
688 U_context tcontextl tcontextt -> -- context
689 wlkContext tcontextl `thenUgn` \ ctxt ->
690 wlkMonoType tcontextt `thenUgn` \ ty ->
691 returnUgn (HsPreForAllTy ctxt ty)
693 U_namedtvar tv -> -- type variable
694 wlkTvId tv `thenUgn` \ tyvar ->
695 returnUgn (MonoTyVar tyvar)
697 U_tname tcon -> -- type constructor
698 wlkTCId tcon `thenUgn` \ tycon ->
699 returnUgn (MonoTyVar tycon)
702 wlkMonoType t1 `thenUgn` \ ty1 ->
703 wlkMonoType t2 `thenUgn` \ ty2 ->
704 returnUgn (MonoTyApp ty1 ty2)
706 U_tllist tlist -> -- list type
707 wlkMonoType tlist `thenUgn` \ ty ->
708 returnUgn (MonoListTy dummyRdrTcName ty)
711 wlkList rdMonoType ttuple `thenUgn` \ tys ->
712 returnUgn (MonoTupleTy dummyRdrTcName tys)
715 wlkMonoType tfun `thenUgn` \ ty1 ->
716 wlkMonoType targ `thenUgn` \ ty2 ->
717 returnUgn (MonoFunTy ty1 ty2)
721 U_context tcontextl tcontextt -> -- context
722 wlkContext tcontextl `thenUgn` \ ctxt ->
723 wlkConAndTys tcontextt `thenUgn` \ (clas, tys) ->
724 returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys))
726 other -> -- something else
727 wlkConAndTys other `thenUgn` \ (clas, tys) ->
728 returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys))
732 wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
733 wlkConAndTyVars ttype
734 = wlkMonoType ttype `thenUgn` \ ty ->
736 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
737 split (MonoTyVar tycon) args = (tycon,args)
738 split other args = pprPanic "ERROR: malformed type: "
741 returnUgn (split ty [])
744 wlkContext :: U_list -> UgnM RdrNameContext
745 rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
747 wlkContext list = wlkList rdConAndTys list
750 = rdU_ttype pt `thenUgn` \ ttype ->
754 = wlkMonoType ttype `thenUgn` \ ty ->
756 split (MonoTyApp fun ty) tys = split fun (ty : tys)
757 split (MonoTyVar tycon) tys = (tycon, tys)
758 split other tys = pprPanic "ERROR: malformed type: "
761 returnUgn (split ty [])
765 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
767 = rdU_constr pt `thenUgn` \ blah ->
770 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
772 wlkConDecl (U_constrcxt ccxt ccdecl)
773 = wlkContext ccxt `thenUgn` \ theta ->
774 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
775 returnUgn (ConDecl con theta details loc)
777 wlkConDecl (U_constrpre ccon ctys srcline)
778 = mkSrcLocUgn srcline $ \ src_loc ->
779 wlkDataId ccon `thenUgn` \ con ->
780 wlkList rdBangType ctys `thenUgn` \ tys ->
781 returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
783 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
784 = mkSrcLocUgn srcline $ \ src_loc ->
785 wlkBangType cty1 `thenUgn` \ ty1 ->
786 wlkDataId cop `thenUgn` \ op ->
787 wlkBangType cty2 `thenUgn` \ ty2 ->
788 returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
790 wlkConDecl (U_constrnew ccon cty srcline)
791 = mkSrcLocUgn srcline $ \ src_loc ->
792 wlkDataId ccon `thenUgn` \ con ->
793 wlkMonoType cty `thenUgn` \ ty ->
794 returnUgn (ConDecl con [] (NewCon ty) src_loc)
796 wlkConDecl (U_constrrec ccon cfields srcline)
797 = mkSrcLocUgn srcline $ \ src_loc ->
798 wlkDataId ccon `thenUgn` \ con ->
799 wlkList rd_field cfields `thenUgn` \ fields_lists ->
800 returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
802 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
804 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
805 wlkList rdVarId fvars `thenUgn` \ vars ->
806 wlkBangType fty `thenUgn` \ ty ->
810 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
812 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
814 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
815 returnUgn (Banged ty)
816 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
817 returnUgn (Unbanged ty)
820 %************************************************************************
822 \subsection{Read a ``match''}
824 %************************************************************************
827 rdMatch :: ParseTree -> UgnM RdrMatch
830 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
831 mkSrcLocUgn srcline $ \ src_loc ->
832 wlkPat gpat `thenUgn` \ pat ->
833 wlkBinding gbind `thenUgn` \ binding ->
834 wlkVarId gsrcfun `thenUgn` \ srcfun ->
836 wlk_guards (U_pnoguards exp)
837 = wlkExpr exp `thenUgn` \ expr ->
838 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
840 wlk_guards (U_pguards gs)
841 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
842 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
847 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
848 wlkQuals g `thenUgn` \ guard ->
849 wlkExpr e `thenUgn` \ expr ->
850 returnUgn (guard, expr)
853 %************************************************************************
855 \subsection[rdFixOp]{Read in a fixity declaration}
857 %************************************************************************
860 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
862 = rdU_tree pt `thenUgn` \ fix ->
864 U_fixop op dir_n prec srcline -> wlkVarId op `thenUgn` \ op ->
865 mkSrcLocUgn srcline $ \ src_loc ->
866 returnUgn (FixityDecl op (Fixity prec dir) src_loc)
872 _ -> error "ReadPrefix:rdFixOp"
875 %************************************************************************
877 \subsection[rdImport]{Read an import decl}
879 %************************************************************************
882 rdImport :: ParseTree
883 -> UgnM RdrNameImportDecl
886 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
887 mkSrcLocUgn srcline $ \ src_loc ->
888 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
889 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
890 returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
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)
899 cvIfaceFlavour 0 = HiFile -- No pragam
900 cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
905 = rdU_list pt `thenUgn` \ list ->
906 wlkList rdEntity list
908 rdEntity :: ParseTree -> UgnM (IE RdrName)
911 = rdU_entidt pt `thenUgn` \ entity ->
913 U_entid evar -> -- just a value
914 wlkEntId evar `thenUgn` \ var ->
915 returnUgn (IEVar var)
917 U_enttype x -> -- abstract type constructor/class
918 wlkTCId x `thenUgn` \ thing ->
919 returnUgn (IEThingAbs thing)
921 U_enttypeall x -> -- non-abstract type constructor/class
922 wlkTCId x `thenUgn` \ thing ->
923 returnUgn (IEThingAll thing)
925 U_enttypenamed x ns -> -- non-abstract type constructor/class
926 -- with specified constrs/methods
927 wlkTCId x `thenUgn` \ thing ->
928 wlkList rdVarId ns `thenUgn` \ names ->
929 returnUgn (IEThingWith thing names)
931 U_entmod mod -> -- everything provided unqualified by a module
932 returnUgn (IEModuleContents mod)