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 (RdrTySig vars poly_ty src_loc)
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 (RdrSpecValSig [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 wlkTCId iclas `thenUgn` \ clas ->
644 wlkMonoType ispec_ty `thenUgn` \ ty ->
645 returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
647 -- data specialisation user-pragma
648 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
649 = mkSrcLocUgn srcline $ \ src_loc ->
650 wlkTCId itycon `thenUgn` \ tycon ->
651 wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
652 returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
654 -- value inlining user-pragma
655 wlk_sig_thing (U_inline_uprag ivar srcline)
656 = mkSrcLocUgn srcline $ \ src_loc ->
657 wlkVarId ivar `thenUgn` \ var ->
658 returnUgn (RdrInlineValSig (InlineSig var src_loc))
660 -- "magic" unfolding user-pragma
661 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
662 = mkSrcLocUgn srcline $ \ src_loc ->
663 wlkVarId ivar `thenUgn` \ var ->
664 returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
667 %************************************************************************
669 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
671 %************************************************************************
674 rdHsType :: ParseTree -> UgnM RdrNameHsType
675 rdMonoType :: ParseTree -> UgnM RdrNameHsType
677 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
678 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
680 wlkHsType :: U_ttype -> UgnM RdrNameHsType
681 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
685 U_context tcontextl tcontextt -> -- context
686 wlkContext tcontextl `thenUgn` \ ctxt ->
687 wlkMonoType tcontextt `thenUgn` \ ty ->
688 returnUgn (HsPreForAllTy ctxt ty)
690 other -> -- something else
691 wlkMonoType other `thenUgn` \ ty ->
692 returnUgn (HsPreForAllTy [{-no context-}] ty)
696 -- Glasgow extension: nested polymorhism
697 U_context tcontextl tcontextt -> -- context
698 wlkContext tcontextl `thenUgn` \ ctxt ->
699 wlkMonoType tcontextt `thenUgn` \ ty ->
700 returnUgn (HsPreForAllTy ctxt ty)
702 U_namedtvar tv -> -- type variable
703 wlkTvId tv `thenUgn` \ tyvar ->
704 returnUgn (MonoTyVar tyvar)
706 U_tname tcon -> -- type constructor
707 wlkTCId tcon `thenUgn` \ tycon ->
708 returnUgn (MonoTyVar tycon)
711 wlkMonoType t1 `thenUgn` \ ty1 ->
712 wlkMonoType t2 `thenUgn` \ ty2 ->
713 returnUgn (MonoTyApp ty1 ty2)
715 U_tllist tlist -> -- list type
716 wlkMonoType tlist `thenUgn` \ ty ->
717 returnUgn (MonoListTy dummyRdrTcName ty)
720 wlkList rdMonoType ttuple `thenUgn` \ tys ->
721 returnUgn (MonoTupleTy dummyRdrTcName tys)
724 wlkMonoType tfun `thenUgn` \ ty1 ->
725 wlkMonoType targ `thenUgn` \ ty2 ->
726 returnUgn (MonoFunTy ty1 ty2)
730 U_context tcontextl tcontextt -> -- context
731 wlkContext tcontextl `thenUgn` \ ctxt ->
732 wlkConAndTys tcontextt `thenUgn` \ (clas, tys) ->
733 returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys))
735 other -> -- something else
736 wlkConAndTys other `thenUgn` \ (clas, tys) ->
737 returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys))
741 wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
742 wlkConAndTyVars ttype
743 = wlkMonoType ttype `thenUgn` \ ty ->
745 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
746 split (MonoTyVar tycon) args = (tycon,args)
747 split other args = pprPanic "ERROR: malformed type: "
750 returnUgn (split ty [])
753 wlkContext :: U_list -> UgnM RdrNameContext
754 rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
756 wlkContext list = wlkList rdConAndTys list
759 = rdU_ttype pt `thenUgn` \ ttype ->
763 = wlkMonoType ttype `thenUgn` \ ty ->
765 split (MonoTyApp fun ty) tys = split fun (ty : tys)
766 split (MonoTyVar tycon) tys = (tycon, tys)
767 split other tys = pprPanic "ERROR: malformed type: "
770 returnUgn (split ty [])
774 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
776 = rdU_constr pt `thenUgn` \ blah ->
779 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
781 wlkConDecl (U_constrcxt ccxt ccdecl)
782 = wlkContext ccxt `thenUgn` \ theta ->
783 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
784 returnUgn (ConDecl con theta details loc)
786 wlkConDecl (U_constrpre ccon ctys srcline)
787 = mkSrcLocUgn srcline $ \ src_loc ->
788 wlkDataId ccon `thenUgn` \ con ->
789 wlkList rdBangType ctys `thenUgn` \ tys ->
790 returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
792 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
793 = mkSrcLocUgn srcline $ \ src_loc ->
794 wlkBangType cty1 `thenUgn` \ ty1 ->
795 wlkDataId cop `thenUgn` \ op ->
796 wlkBangType cty2 `thenUgn` \ ty2 ->
797 returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
799 wlkConDecl (U_constrnew ccon cty srcline)
800 = mkSrcLocUgn srcline $ \ src_loc ->
801 wlkDataId ccon `thenUgn` \ con ->
802 wlkMonoType cty `thenUgn` \ ty ->
803 returnUgn (ConDecl con [] (NewCon ty) src_loc)
805 wlkConDecl (U_constrrec ccon cfields srcline)
806 = mkSrcLocUgn srcline $ \ src_loc ->
807 wlkDataId ccon `thenUgn` \ con ->
808 wlkList rd_field cfields `thenUgn` \ fields_lists ->
809 returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
811 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
813 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
814 wlkList rdVarId fvars `thenUgn` \ vars ->
815 wlkBangType fty `thenUgn` \ ty ->
819 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
821 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
823 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
824 returnUgn (Banged ty)
825 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
826 returnUgn (Unbanged ty)
829 %************************************************************************
831 \subsection{Read a ``match''}
833 %************************************************************************
836 rdMatch :: ParseTree -> UgnM RdrMatch
839 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
840 mkSrcLocUgn srcline $ \ src_loc ->
841 wlkPat gpat `thenUgn` \ pat ->
842 wlkBinding gbind `thenUgn` \ binding ->
843 wlkVarId gsrcfun `thenUgn` \ srcfun ->
845 wlk_guards (U_pnoguards exp)
846 = wlkExpr exp `thenUgn` \ expr ->
847 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
849 wlk_guards (U_pguards gs)
850 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
851 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
856 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
857 wlkQuals g `thenUgn` \ guard ->
858 wlkExpr e `thenUgn` \ expr ->
859 returnUgn (guard, expr)
862 %************************************************************************
864 \subsection[rdFixOp]{Read in a fixity declaration}
866 %************************************************************************
869 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
871 = rdU_tree pt `thenUgn` \ fix ->
873 U_fixop op dir_n prec srcline -> wlkVarId op `thenUgn` \ op ->
874 mkSrcLocUgn srcline $ \ src_loc ->
875 returnUgn (FixityDecl op (Fixity prec dir) src_loc)
881 _ -> error "ReadPrefix:rdFixOp"
884 %************************************************************************
886 \subsection[rdImport]{Read an import decl}
888 %************************************************************************
891 rdImport :: ParseTree
892 -> UgnM RdrNameImportDecl
895 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
896 mkSrcLocUgn srcline $ \ src_loc ->
897 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
898 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
899 returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
901 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
903 U_left pt -> rdEntities pt `thenUgn` \ ents ->
904 returnUgn (False, ents)
905 U_right pt -> rdEntities pt `thenUgn` \ ents ->
906 returnUgn (True, ents)
908 cvIfaceFlavour 0 = HiFile -- No pragam
909 cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
914 = rdU_list pt `thenUgn` \ list ->
915 wlkList rdEntity list
917 rdEntity :: ParseTree -> UgnM (IE RdrName)
920 = rdU_entidt pt `thenUgn` \ entity ->
922 U_entid evar -> -- just a value
923 wlkEntId evar `thenUgn` \ var ->
924 returnUgn (IEVar var)
926 U_enttype x -> -- abstract type constructor/class
927 wlkTCId x `thenUgn` \ thing ->
928 returnUgn (IEThingAbs thing)
930 U_enttypeall x -> -- non-abstract type constructor/class
931 wlkTCId x `thenUgn` \ thing ->
932 returnUgn (IEThingAll thing)
934 U_enttypenamed x ns -> -- non-abstract type constructor/class
935 -- with specified constrs/methods
936 wlkTCId x `thenUgn` \ thing ->
937 wlkList rdVarId ns `thenUgn` \ names ->
938 returnUgn (IEThingWith thing names)
940 U_entmod mod -> -- everything provided unqualified by a module
941 returnUgn (IEModuleContents mod)