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))
653 %************************************************************************
655 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
657 %************************************************************************
660 rdHsType :: ParseTree -> UgnM RdrNameHsType
661 rdMonoType :: ParseTree -> UgnM RdrNameHsType
663 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
664 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
666 wlkHsType :: U_ttype -> UgnM RdrNameHsType
667 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
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 -- Glasgow extension: nested polymorhism
683 U_context tcontextl tcontextt -> -- context
684 wlkContext tcontextl `thenUgn` \ ctxt ->
685 wlkMonoType tcontextt `thenUgn` \ ty ->
686 returnUgn (HsPreForAllTy ctxt ty)
688 U_namedtvar tv -> -- type variable
689 wlkTvId tv `thenUgn` \ tyvar ->
690 returnUgn (MonoTyVar tyvar)
692 U_tname tcon -> -- type constructor
693 wlkTCId tcon `thenUgn` \ tycon ->
694 returnUgn (MonoTyVar tycon)
697 wlkMonoType t1 `thenUgn` \ ty1 ->
698 wlkMonoType t2 `thenUgn` \ ty2 ->
699 returnUgn (MonoTyApp ty1 ty2)
701 U_tllist tlist -> -- list type
702 wlkMonoType tlist `thenUgn` \ ty ->
703 returnUgn (MonoListTy dummyRdrTcName ty)
706 wlkList rdMonoType ttuple `thenUgn` \ tys ->
707 returnUgn (MonoTupleTy dummyRdrTcName tys)
710 wlkMonoType tfun `thenUgn` \ ty1 ->
711 wlkMonoType targ `thenUgn` \ ty2 ->
712 returnUgn (MonoFunTy ty1 ty2)
716 U_context tcontextl tcontextt -> -- context
717 wlkContext tcontextl `thenUgn` \ ctxt ->
718 wlkConAndTys tcontextt `thenUgn` \ (clas, tys) ->
719 returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys))
721 other -> -- something else
722 wlkConAndTys other `thenUgn` \ (clas, tys) ->
723 returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys))
727 wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
728 wlkConAndTyVars ttype
729 = wlkMonoType ttype `thenUgn` \ ty ->
731 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
732 split (MonoTyVar tycon) args = (tycon,args)
733 split other args = pprPanic "ERROR: malformed type: "
736 returnUgn (split ty [])
739 wlkContext :: U_list -> UgnM RdrNameContext
740 rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
742 wlkContext list = wlkList rdConAndTys list
745 = rdU_ttype pt `thenUgn` \ ttype ->
749 = wlkMonoType ttype `thenUgn` \ ty ->
751 split (MonoTyApp fun ty) tys = split fun (ty : tys)
752 split (MonoTyVar tycon) tys = (tycon, tys)
753 split other tys = pprPanic "ERROR: malformed type: "
756 returnUgn (split ty [])
760 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
762 = rdU_constr pt `thenUgn` \ blah ->
765 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
767 wlkConDecl (U_constrcxt ccxt ccdecl)
768 = wlkContext ccxt `thenUgn` \ theta ->
769 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
770 returnUgn (ConDecl con theta details loc)
772 wlkConDecl (U_constrpre ccon ctys srcline)
773 = mkSrcLocUgn srcline $ \ src_loc ->
774 wlkDataId ccon `thenUgn` \ con ->
775 wlkList rdBangType ctys `thenUgn` \ tys ->
776 returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
778 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
779 = mkSrcLocUgn srcline $ \ src_loc ->
780 wlkBangType cty1 `thenUgn` \ ty1 ->
781 wlkDataId cop `thenUgn` \ op ->
782 wlkBangType cty2 `thenUgn` \ ty2 ->
783 returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
785 wlkConDecl (U_constrnew ccon cty srcline)
786 = mkSrcLocUgn srcline $ \ src_loc ->
787 wlkDataId ccon `thenUgn` \ con ->
788 wlkMonoType cty `thenUgn` \ ty ->
789 returnUgn (ConDecl con [] (NewCon ty) src_loc)
791 wlkConDecl (U_constrrec ccon cfields srcline)
792 = mkSrcLocUgn srcline $ \ src_loc ->
793 wlkDataId ccon `thenUgn` \ con ->
794 wlkList rd_field cfields `thenUgn` \ fields_lists ->
795 returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
797 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
799 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
800 wlkList rdVarId fvars `thenUgn` \ vars ->
801 wlkBangType fty `thenUgn` \ ty ->
805 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
807 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
809 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
810 returnUgn (Banged ty)
811 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
812 returnUgn (Unbanged ty)
815 %************************************************************************
817 \subsection{Read a ``match''}
819 %************************************************************************
822 rdMatch :: ParseTree -> UgnM RdrMatch
825 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
826 mkSrcLocUgn srcline $ \ src_loc ->
827 wlkPat gpat `thenUgn` \ pat ->
828 wlkBinding gbind `thenUgn` \ binding ->
829 wlkVarId gsrcfun `thenUgn` \ srcfun ->
831 wlk_guards (U_pnoguards exp)
832 = wlkExpr exp `thenUgn` \ expr ->
833 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
835 wlk_guards (U_pguards gs)
836 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
837 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
842 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
843 wlkQuals g `thenUgn` \ guard ->
844 wlkExpr e `thenUgn` \ expr ->
845 returnUgn (guard, expr)
848 %************************************************************************
850 \subsection[rdFixOp]{Read in a fixity declaration}
852 %************************************************************************
855 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
857 = rdU_tree pt `thenUgn` \ fix ->
859 U_fixop op dir_n prec srcline -> wlkVarId op `thenUgn` \ op ->
860 mkSrcLocUgn srcline $ \ src_loc ->
861 returnUgn (FixityDecl op (Fixity prec dir) src_loc)
867 _ -> error "ReadPrefix:rdFixOp"
870 %************************************************************************
872 \subsection[rdImport]{Read an import decl}
874 %************************************************************************
877 rdImport :: ParseTree
878 -> UgnM RdrNameImportDecl
881 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
882 mkSrcLocUgn srcline $ \ src_loc ->
883 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
884 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
885 returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
887 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
889 U_left pt -> rdEntities pt `thenUgn` \ ents ->
890 returnUgn (False, ents)
891 U_right pt -> rdEntities pt `thenUgn` \ ents ->
892 returnUgn (True, ents)
894 cvIfaceFlavour 0 = HiFile -- No pragam
895 cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
900 = rdU_list pt `thenUgn` \ list ->
901 wlkList rdEntity list
903 rdEntity :: ParseTree -> UgnM (IE RdrName)
906 = rdU_entidt pt `thenUgn` \ entity ->
908 U_entid evar -> -- just a value
909 wlkEntId evar `thenUgn` \ var ->
910 returnUgn (IEVar var)
912 U_enttype x -> -- abstract type constructor/class
913 wlkTCId x `thenUgn` \ thing ->
914 returnUgn (IEThingAbs thing)
916 U_enttypeall x -> -- non-abstract type constructor/class
917 wlkTCId x `thenUgn` \ thing ->
918 returnUgn (IEThingAll thing)
920 U_enttypenamed x ns -> -- non-abstract type constructor/class
921 -- with specified constrs/methods
922 wlkTCId x `thenUgn` \ thing ->
923 wlkList rdVarId ns `thenUgn` \ names ->
924 returnUgn (IEThingWith thing names)
926 U_entmod mod -> -- everything provided unqualified by a module
927 returnUgn (IEModuleContents mod)