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(..) )
21 import CmdLineOpts ( opt_NoImplicitPrelude )
22 import FiniteMap ( elemFM, FiniteMap )
23 import Name ( OccName(..), Module )
24 import Lex ( isLexConId )
26 import PrelMods ( pRELUDE )
27 import Util ( nOfThem )
28 import FastString ( mkFastCharString )
29 import IO ( hPutStr, stderr )
30 import PrelRead ( readRational__ )
33 %************************************************************************
35 \subsection[ReadPrefix-help]{Help Functions}
37 %************************************************************************
40 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
42 wlkList wlk_it U_lnil = returnUgn []
44 wlkList wlk_it (U_lcons hd tl)
45 = wlk_it hd `thenUgn` \ hd_it ->
46 wlkList wlk_it tl `thenUgn` \ tl_it ->
47 returnUgn (hd_it : tl_it)
51 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
53 wlkMaybe wlk_it U_nothing = returnUgn Nothing
54 wlkMaybe wlk_it (U_just x)
55 = wlk_it x `thenUgn` \ it ->
60 wlkTvId = wlkQid TvOcc
61 wlkTCId = wlkQid TCOcc
62 wlkVarId = wlkQid VarOcc
63 wlkDataId = wlkQid VarOcc
64 wlkEntId = wlkQid (\occ -> if isLexConId occ
68 wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
70 -- There are three kinds of qid:
71 -- qualified name (aqual) A.x
72 -- unqualified name (noqual) x
73 -- special name (gid) [], (), ->, (,,,)
74 -- The special names always mean "Prelude.whatever"; that's why
75 -- they are distinct. So if you write "()", it's just as if you
76 -- had written "Prelude.()".
77 -- NB: The (qualified) prelude is always in scope, so the renamer will find it.
79 -- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
80 -- case we need to unqualify these things. -- SDM.
82 wlkQid mk_occ_name (U_noqual name)
83 = returnUgn (Unqual (mk_occ_name name))
84 wlkQid mk_occ_name (U_aqual mod name)
85 = returnUgn (Qual mod (mk_occ_name name) HiFile)
86 wlkQid mk_occ_name (U_gid n name)
87 | opt_NoImplicitPrelude
88 = returnUgn (Unqual (mk_occ_name name))
90 = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
92 rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
93 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
95 cvFlag :: U_long -> Bool
100 %************************************************************************
102 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
104 %************************************************************************
107 rdModule :: IO (Module, -- this module's name
108 RdrNameHsModule) -- the main goods
111 = _ccall_ hspmain >>= \ pt -> -- call the Yacc parser!
113 srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
116 rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
117 hmodlist srciface_version srcline) ->
119 setSrcFileUgn srcfile $
120 setSrcModUgn modname $
121 mkSrcLocUgn srcline $ \ src_loc ->
123 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
124 wlkList rdImport himplist `thenUgn` \ imports ->
125 wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
126 wlkBinding hmodlist `thenUgn` \ binding ->
129 val_decl = ValD (cvBinds srcfile cvValSig binding)
130 for_decls = cvForeignDecls binding
131 other_decls = cvOtherDecls binding
135 (case srciface_version of { 0 -> Nothing; n -> Just n })
139 (for_decls ++ val_decl: other_decls)
144 %************************************************************************
146 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
148 %************************************************************************
151 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
152 rdPat :: ParseTree -> UgnM RdrNamePat
154 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
155 rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
157 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
158 wlkPat :: U_tree -> UgnM RdrNamePat
162 U_par pexpr -> -- parenthesised expr
163 wlkExpr pexpr `thenUgn` \ expr ->
164 returnUgn (HsPar expr)
166 U_lsection lsexp lop -> -- left section
167 wlkExpr lsexp `thenUgn` \ expr ->
168 wlkVarId lop `thenUgn` \ op ->
169 returnUgn (SectionL expr (HsVar op))
171 U_rsection rop rsexp -> -- right section
172 wlkVarId rop `thenUgn` \ op ->
173 wlkExpr rsexp `thenUgn` \ expr ->
174 returnUgn (SectionR (HsVar op) expr)
176 U_ccall fun flavor ccargs -> -- ccall/casm
177 wlkList rdExpr ccargs `thenUgn` \ args ->
181 returnUgn (CCall fun args
182 (tag == 'p' || tag == 'P') -- may invoke GC
183 (tag == 'N' || tag == 'P') -- really a "casm"
184 (panic "CCall:result_ty"))
186 U_scc label sccexp -> -- scc (set-cost-centre) expression
187 wlkExpr sccexp `thenUgn` \ expr ->
188 returnUgn (HsSCC label expr)
190 U_lambda lampats lamexpr srcline -> -- lambda expression
191 mkSrcLocUgn srcline $ \ src_loc ->
192 wlkList rdPat lampats `thenUgn` \ pats ->
193 wlkExpr lamexpr `thenUgn` \ body ->
195 HsLam (foldr PatMatch
196 (GRHSMatch (GRHSsAndBindsIn
197 (unguardedRHS body src_loc)
202 U_casee caseexpr casebody srcline -> -- case expression
203 mkSrcLocUgn srcline $ \ src_loc ->
204 wlkExpr caseexpr `thenUgn` \ expr ->
205 wlkList rdMatch casebody `thenUgn` \ mats ->
206 getSrcFileUgn `thenUgn` \ sf ->
208 matches = cvMatches sf True mats
210 returnUgn (HsCase expr matches src_loc)
212 U_ife ifpred ifthen ifelse srcline -> -- if expression
213 mkSrcLocUgn srcline $ \ src_loc ->
214 wlkExpr ifpred `thenUgn` \ e1 ->
215 wlkExpr ifthen `thenUgn` \ e2 ->
216 wlkExpr ifelse `thenUgn` \ e3 ->
217 returnUgn (HsIf e1 e2 e3 src_loc)
219 U_let letvdefs letvexpr -> -- let expression
220 wlkBinding letvdefs `thenUgn` \ binding ->
221 wlkExpr letvexpr `thenUgn` \ expr ->
222 getSrcFileUgn `thenUgn` \ sf ->
224 binds = cvBinds sf cvValSig binding
226 returnUgn (HsLet binds expr)
228 U_doe gdo srcline -> -- do expression
229 mkSrcLocUgn srcline $ \ src_loc ->
230 wlkList rd_stmt gdo `thenUgn` \ stmts ->
231 returnUgn (HsDo DoStmt stmts src_loc)
234 = rdU_tree pt `thenUgn` \ bind ->
236 U_doexp exp srcline ->
237 mkSrcLocUgn srcline $ \ src_loc ->
238 wlkExpr exp `thenUgn` \ expr ->
239 returnUgn (ExprStmt expr src_loc)
241 U_dobind pat exp srcline ->
242 mkSrcLocUgn srcline $ \ src_loc ->
243 wlkPat pat `thenUgn` \ patt ->
244 wlkExpr exp `thenUgn` \ expr ->
245 returnUgn (BindStmt patt expr src_loc)
248 wlkBinding seqlet `thenUgn` \ bs ->
249 getSrcFileUgn `thenUgn` \ sf ->
251 binds = cvBinds sf cvValSig bs
253 returnUgn (LetStmt binds)
255 U_comprh cexp cquals -> -- list comprehension
256 wlkExpr cexp `thenUgn` \ expr ->
257 wlkQuals cquals `thenUgn` \ quals ->
258 getSrcLocUgn `thenUgn` \ loc ->
259 returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
261 U_eenum efrom estep eto -> -- arithmetic sequence
262 wlkExpr efrom `thenUgn` \ e1 ->
263 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
264 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
265 returnUgn (cv_arith_seq e1 es2 es3)
267 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
268 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
269 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
270 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
272 U_restr restre restrt -> -- expression with type signature
273 wlkExpr restre `thenUgn` \ expr ->
274 wlkHsType restrt `thenUgn` \ ty ->
275 returnUgn (ExprWithTySig expr ty)
277 --------------------------------------------------------------
278 -- now the prefix items that can either be an expression or
279 -- pattern, except we know they are *expressions* here
280 -- (this code could be commoned up with the pattern version;
281 -- but it probably isn't worth it)
282 --------------------------------------------------------------
284 wlkLiteral lit `thenUgn` \ lit ->
285 returnUgn (HsLit lit)
287 U_ident n -> -- simple identifier
288 wlkVarId n `thenUgn` \ var ->
289 returnUgn (HsVar var)
291 U_ap fun arg -> -- application
292 wlkExpr fun `thenUgn` \ expr1 ->
293 wlkExpr arg `thenUgn` \ expr2 ->
294 returnUgn (HsApp expr1 expr2)
296 U_infixap fun arg1 arg2 -> -- infix application
297 wlkVarId fun `thenUgn` \ op ->
298 wlkExpr arg1 `thenUgn` \ expr1 ->
299 wlkExpr arg2 `thenUgn` \ expr2 ->
300 returnUgn (mkOpApp expr1 op expr2)
302 U_negate nexp -> -- prefix negation
303 wlkExpr nexp `thenUgn` \ expr ->
304 returnUgn (NegApp expr (HsVar dummyRdrVarName))
306 U_llist llist -> -- explicit list
307 wlkList rdExpr llist `thenUgn` \ exprs ->
308 returnUgn (ExplicitList exprs)
310 U_tuple tuplelist -> -- explicit tuple
311 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
312 returnUgn (ExplicitTuple exprs)
314 U_record con rbinds -> -- record construction
315 wlkDataId con `thenUgn` \ rcon ->
316 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
317 returnUgn (RecordCon rcon (HsVar rcon) recbinds)
319 U_rupdate updexp updbinds -> -- record update
320 wlkExpr updexp `thenUgn` \ aexp ->
321 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
322 returnUgn (RecordUpd aexp recbinds)
325 U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
326 U_as _ _ -> error "U_as"
327 U_lazyp _ -> error "U_lazyp"
328 U_wildp -> error "U_wildp"
329 U_qual _ _ -> error "U_qual"
330 U_guard _ -> error "U_guard"
331 U_seqlet _ -> error "U_seqlet"
332 U_dobind _ _ _ -> error "U_dobind"
333 U_doexp _ _ -> error "U_doexp"
334 U_rbind _ _ -> error "U_rbind"
335 U_fixop _ _ _ _ -> error "U_fixop"
339 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
340 wlkVarId var `thenUgn` \ rvar ->
341 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
344 Nothing -> (rvar, HsVar rvar, True{-pun-})
345 Just re -> (rvar, re, False)
349 = wlkList rd_qual cquals
352 = rdU_tree pt `thenUgn` \ qual ->
358 wlkExpr exp `thenUgn` \ expr ->
359 getSrcLocUgn `thenUgn` \ loc ->
360 returnUgn (GuardStmt expr loc)
363 wlkPat qpat `thenUgn` \ pat ->
364 wlkExpr qexp `thenUgn` \ expr ->
365 getSrcLocUgn `thenUgn` \ loc ->
366 returnUgn (BindStmt pat expr loc)
369 wlkBinding seqlet `thenUgn` \ bs ->
370 getSrcFileUgn `thenUgn` \ sf ->
372 binds = cvBinds sf cvValSig bs
374 returnUgn (LetStmt binds)
375 U_let letvdefs letvexpr ->
376 wlkBinding letvdefs `thenUgn` \ binding ->
377 wlkExpr letvexpr `thenUgn` \ expr ->
378 getSrcLocUgn `thenUgn` \ loc ->
379 getSrcFileUgn `thenUgn` \ sf ->
381 binds = cvBinds sf cvValSig binding
383 returnUgn (GuardStmt (HsLet binds expr) loc)
386 Patterns: just bear in mind that lists of patterns are represented as
387 a series of ``applications''.
391 U_par ppat -> -- parenthesised pattern
392 wlkPat ppat `thenUgn` \ pat ->
393 -- tidy things up a little:
398 other -> ParPatIn pat
401 U_as avar as_pat -> -- "as" pattern
402 wlkVarId avar `thenUgn` \ var ->
403 wlkPat as_pat `thenUgn` \ pat ->
404 returnUgn (AsPatIn var pat)
406 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
407 wlkPat lazyp `thenUgn` \ pat ->
408 returnUgn (LazyPatIn pat)
411 wlkVarId avar `thenUgn` \ var ->
412 wlkLiteral lit `thenUgn` \ lit ->
413 returnUgn (NPlusKPatIn var lit)
415 U_wildp -> returnUgn WildPatIn -- wildcard pattern
417 U_lit lit -> -- literal pattern
418 wlkLiteral lit `thenUgn` \ lit ->
419 returnUgn (LitPatIn lit)
421 U_ident nn -> -- simple identifier
422 wlkVarId nn `thenUgn` \ n ->
425 VarOcc occ | isLexConId occ -> ConPatIn n []
429 U_ap l r -> -- "application": there's a list of patterns lurking here!
430 wlkPat r `thenUgn` \ rpat ->
431 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
433 VarPatIn x -> returnUgn (x, lpats)
434 ConPatIn x [] -> returnUgn (x, lpats)
435 ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
436 _ -> getSrcLocUgn `thenUgn` \ loc ->
437 pprPanic "Illegal pattern `application'"
438 (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
440 ) `thenUgn` \ (n, arg_pats) ->
441 returnUgn (ConPatIn n arg_pats)
446 wlkPat r `thenUgn` \ rpat ->
447 collect_pats l (rpat:acc)
449 wlkPat other `thenUgn` \ pat ->
452 U_infixap fun arg1 arg2 -> -- infix pattern
453 wlkVarId fun `thenUgn` \ op ->
454 wlkPat arg1 `thenUgn` \ pat1 ->
455 wlkPat arg2 `thenUgn` \ pat2 ->
456 returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
458 U_negate npat -> -- negated pattern
459 wlkPat npat `thenUgn` \ pat ->
460 returnUgn (NegPatIn pat)
462 U_llist llist -> -- explicit list
463 wlkList rdPat llist `thenUgn` \ pats ->
464 returnUgn (ListPatIn pats)
466 U_tuple tuplelist -> -- explicit tuple
467 wlkList rdPat tuplelist `thenUgn` \ pats ->
468 returnUgn (TuplePatIn pats)
470 U_record con rpats -> -- record destruction
471 wlkDataId con `thenUgn` \ rcon ->
472 wlkList rdRpat rpats `thenUgn` \ recpats ->
473 returnUgn (RecPatIn rcon recpats)
476 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
477 wlkVarId var `thenUgn` \ rvar ->
478 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
481 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
482 Just rp -> (rvar, rp, False)
487 wlkLiteral :: U_literal -> UgnM HsLit
492 U_integer s -> HsInt (as_integer s)
493 U_floatr s -> HsFrac (as_rational s)
494 U_intprim s -> HsIntPrim (as_integer s)
495 U_doubleprim s -> HsDoublePrim (as_rational s)
496 U_floatprim s -> HsFloatPrim (as_rational s)
497 U_charr s -> HsChar (as_char s)
498 U_charprim s -> HsCharPrim (as_char s)
499 U_string s -> HsString (as_string s)
500 U_stringprim s -> HsStringPrim (as_string s)
501 U_clitlit s -> HsLitLit (as_string s)
505 as_integer s = readInteger (_UNPK_ s)
506 as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
507 -- to handle rationals with leading '-'
511 %************************************************************************
513 \subsection{wlkBinding}
515 %************************************************************************
518 wlkBinding :: U_binding -> UgnM RdrBinding
524 returnUgn RdrNullBind
526 -- "and" binding (just glue, really)
528 wlkBinding a `thenUgn` \ binding1 ->
529 wlkBinding b `thenUgn` \ binding2 ->
530 returnUgn (RdrAndBindings binding1 binding2)
532 -- "data" declaration
533 U_tbind tctxt ttype tcons tderivs srcline ->
534 mkSrcLocUgn srcline $ \ src_loc ->
535 wlkContext tctxt `thenUgn` \ ctxt ->
536 wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
537 wlkList rdConDecl tcons `thenUgn` \ cons ->
538 wlkDerivings tderivs `thenUgn` \ derivings ->
539 returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
541 -- "newtype" declaration
542 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
543 mkSrcLocUgn srcline $ \ src_loc ->
544 wlkContext ntctxt `thenUgn` \ ctxt ->
545 wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
546 wlkList rdConDecl ntcon `thenUgn` \ cons ->
547 wlkDerivings ntderivs `thenUgn` \ derivings ->
548 returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
550 -- "type" declaration
551 U_nbind nbindid nbindas srcline ->
552 mkSrcLocUgn srcline $ \ src_loc ->
553 wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
554 wlkMonoType nbindas `thenUgn` \ expansion ->
555 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
558 U_fbind fbindl srcline ->
559 mkSrcLocUgn srcline $ \ src_loc ->
560 wlkList rdMatch fbindl `thenUgn` \ matches ->
561 returnUgn (RdrFunctionBinding srcline matches)
564 U_pbind pbindl srcline ->
565 mkSrcLocUgn srcline $ \ src_loc ->
566 wlkList rdMatch pbindl `thenUgn` \ matches ->
567 returnUgn (RdrPatternBinding srcline matches)
569 -- "class" declaration
570 U_cbind cbindc cbindid cbindw srcline ->
571 mkSrcLocUgn srcline $ \ src_loc ->
572 wlkContext cbindc `thenUgn` \ ctxt ->
573 wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) ->
574 wlkBinding cbindw `thenUgn` \ binding ->
575 getSrcFileUgn `thenUgn` \ sf ->
577 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
579 returnUgn (RdrClassDecl
580 (mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc))
582 -- "instance" declaration
583 U_ibind ty ibindw srcline ->
584 -- The "ty" contains the instance context too
585 -- So for "instance Eq a => Eq [a]" the type will be
587 mkSrcLocUgn srcline $ \ src_loc ->
588 wlkInstType ty `thenUgn` \ inst_ty ->
589 wlkBinding ibindw `thenUgn` \ binding ->
590 getSrcModUgn `thenUgn` \ modname ->
591 getSrcFileUgn `thenUgn` \ sf ->
593 (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
595 returnUgn (RdrInstDecl
596 (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
598 -- "default" declaration
599 U_dbind dbindts srcline ->
600 mkSrcLocUgn srcline $ \ src_loc ->
601 wlkList rdMonoType dbindts `thenUgn` \ tys ->
602 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
604 -- "foreign" declaration
605 U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
606 mkSrcLocUgn srcline $ \ src_loc ->
607 wlkVarId id `thenUgn` \ h_id ->
608 wlkHsType ty `thenUgn` \ h_ty ->
609 wlkExtName ext_name `thenUgn` \ h_ext_name ->
610 rdCallConv cconv `thenUgn` \ h_cconv ->
611 rdImpExp imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
612 returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
615 -- signature(-like) things, including user pragmas
616 wlk_sig_thing a_sig_we_hope
620 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
622 wlkDerivings (U_nothing) = returnUgn Nothing
623 wlkDerivings (U_just pt)
624 = rdU_list pt `thenUgn` \ ds ->
625 wlkList rdTCId ds `thenUgn` \ derivs ->
626 returnUgn (Just derivs)
631 wlk_sig_thing (U_sbind sbindids sbindid srcline)
632 = mkSrcLocUgn srcline $ \ src_loc ->
633 wlkList rdVarId sbindids `thenUgn` \ vars ->
634 wlkHsType sbindid `thenUgn` \ poly_ty ->
635 returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
637 -- value specialisation user-pragma
638 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
639 = mkSrcLocUgn srcline $ \ src_loc ->
640 wlkVarId uvar `thenUgn` \ var ->
641 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
642 returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
643 | (ty, using_id) <- tys_and_ids ])
645 rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
647 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
648 wlkHsType vspec_ty `thenUgn` \ ty ->
649 wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
650 returnUgn(ty, id_maybe)
652 -- instance specialisation user-pragma
653 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
654 = mkSrcLocUgn srcline $ \ src_loc ->
655 wlkHsType ispec_ty `thenUgn` \ ty ->
656 returnUgn (RdrSig (SpecInstSig ty src_loc))
658 -- value inlining user-pragma
659 wlk_sig_thing (U_inline_uprag ivar srcline)
660 = mkSrcLocUgn srcline $ \ src_loc ->
661 wlkVarId ivar `thenUgn` \ var ->
662 returnUgn (RdrSig (InlineSig var src_loc))
664 wlk_sig_thing (U_noinline_uprag ivar srcline)
665 = mkSrcLocUgn srcline $ \ src_loc ->
666 wlkVarId ivar `thenUgn` \ var ->
667 returnUgn (RdrSig (NoInlineSig var src_loc))
670 %************************************************************************
672 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
674 %************************************************************************
677 rdHsType :: ParseTree -> UgnM RdrNameHsType
678 rdMonoType :: ParseTree -> UgnM RdrNameHsType
680 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
681 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
683 wlkHsType :: U_ttype -> UgnM RdrNameHsType
684 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
688 U_context tcontextl tcontextt -> -- context
689 wlkContext tcontextl `thenUgn` \ ctxt ->
690 wlkMonoType tcontextt `thenUgn` \ ty ->
691 returnUgn (HsPreForAllTy ctxt ty)
693 other -> -- something else
694 wlkMonoType other `thenUgn` \ ty ->
695 returnUgn (HsPreForAllTy [{-no context-}] ty)
699 -- Glasgow extension: nested polymorhism
700 U_context tcontextl tcontextt -> -- context
701 wlkContext tcontextl `thenUgn` \ ctxt ->
702 wlkMonoType tcontextt `thenUgn` \ ty ->
703 returnUgn (HsPreForAllTy ctxt ty)
705 U_namedtvar tv -> -- type variable
706 wlkTvId tv `thenUgn` \ tyvar ->
707 returnUgn (MonoTyVar tyvar)
709 U_tname tcon -> -- type constructor
710 wlkTCId tcon `thenUgn` \ tycon ->
711 returnUgn (MonoTyVar tycon)
714 wlkMonoType t1 `thenUgn` \ ty1 ->
715 wlkMonoType t2 `thenUgn` \ ty2 ->
716 returnUgn (MonoTyApp ty1 ty2)
718 U_tllist tlist -> -- list type
719 wlkMonoType tlist `thenUgn` \ ty ->
720 returnUgn (MonoListTy dummyRdrTcName ty)
723 wlkList rdMonoType ttuple `thenUgn` \ tys ->
724 returnUgn (MonoTupleTy dummyRdrTcName tys)
727 wlkMonoType tfun `thenUgn` \ ty1 ->
728 wlkMonoType targ `thenUgn` \ ty2 ->
729 returnUgn (MonoFunTy ty1 ty2)
733 U_context tcontextl tcontextt -> -- context
734 wlkContext tcontextl `thenUgn` \ ctxt ->
735 wlkConAndTys tcontextt `thenUgn` \ (clas, tys) ->
736 returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys))
738 other -> -- something else
739 wlkConAndTys other `thenUgn` \ (clas, tys) ->
740 returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys))
744 wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
745 wlkConAndTyVars ttype
746 = wlkMonoType ttype `thenUgn` \ ty ->
748 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
749 split (MonoTyVar tycon) args = (tycon,args)
750 split other args = pprPanic "ERROR: malformed type: "
753 returnUgn (split ty [])
756 wlkContext :: U_list -> UgnM RdrNameContext
757 rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
759 wlkContext list = wlkList rdConAndTys list
762 = rdU_ttype pt `thenUgn` \ ttype ->
766 = wlkMonoType ttype `thenUgn` \ ty ->
768 split (MonoTyApp fun ty) tys = split fun (ty : tys)
769 split (MonoTyVar tycon) tys = (tycon, tys)
770 split other tys = pprPanic "ERROR: malformed type: "
773 returnUgn (split ty [])
777 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
779 = rdU_constr pt `thenUgn` \ blah ->
782 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
784 wlkConDecl (U_constrcxt ccxt ccdecl)
785 = wlkContext ccxt `thenUgn` \ theta ->
786 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
787 returnUgn (ConDecl con theta details loc)
789 wlkConDecl (U_constrpre ccon ctys srcline)
790 = mkSrcLocUgn srcline $ \ src_loc ->
791 wlkDataId ccon `thenUgn` \ con ->
792 wlkList rdBangType ctys `thenUgn` \ tys ->
793 returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
795 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
796 = mkSrcLocUgn srcline $ \ src_loc ->
797 wlkBangType cty1 `thenUgn` \ ty1 ->
798 wlkDataId cop `thenUgn` \ op ->
799 wlkBangType cty2 `thenUgn` \ ty2 ->
800 returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
802 wlkConDecl (U_constrnew ccon cty srcline)
803 = mkSrcLocUgn srcline $ \ src_loc ->
804 wlkDataId ccon `thenUgn` \ con ->
805 wlkMonoType cty `thenUgn` \ ty ->
806 returnUgn (ConDecl con [] (NewCon ty) src_loc)
808 wlkConDecl (U_constrrec ccon cfields srcline)
809 = mkSrcLocUgn srcline $ \ src_loc ->
810 wlkDataId ccon `thenUgn` \ con ->
811 wlkList rd_field cfields `thenUgn` \ fields_lists ->
812 returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
814 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
816 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
817 wlkList rdVarId fvars `thenUgn` \ vars ->
818 wlkBangType fty `thenUgn` \ ty ->
822 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
824 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
826 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
827 returnUgn (Banged ty)
828 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
829 returnUgn (Unbanged ty)
832 %************************************************************************
834 \subsection{Read a ``match''}
836 %************************************************************************
839 rdMatch :: ParseTree -> UgnM RdrMatch
842 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
843 mkSrcLocUgn srcline $ \ src_loc ->
844 wlkPat gpat `thenUgn` \ pat ->
845 wlkBinding gbind `thenUgn` \ binding ->
846 wlkVarId gsrcfun `thenUgn` \ srcfun ->
848 wlk_guards (U_pnoguards exp)
849 = wlkExpr exp `thenUgn` \ expr ->
850 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
852 wlk_guards (U_pguards gs)
853 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
854 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
859 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
860 wlkQuals g `thenUgn` \ guard ->
861 wlkExpr e `thenUgn` \ expr ->
862 returnUgn (guard, expr)
865 %************************************************************************
867 \subsection[rdFixOp]{Read in a fixity declaration}
869 %************************************************************************
872 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
874 = rdU_tree pt `thenUgn` \ fix ->
876 U_fixop op dir_n prec srcline -> wlkVarId op `thenUgn` \ op ->
877 mkSrcLocUgn srcline $ \ src_loc ->
878 returnUgn (FixityDecl op (Fixity prec dir) src_loc)
884 _ -> error "ReadPrefix:rdFixOp"
887 %************************************************************************
889 \subsection[rdImport]{Read an import decl}
891 %************************************************************************
894 rdImport :: ParseTree
895 -> UgnM RdrNameImportDecl
898 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
899 mkSrcLocUgn srcline $ \ src_loc ->
900 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
901 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
902 returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
904 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
906 U_left pt -> rdEntities pt `thenUgn` \ ents ->
907 returnUgn (False, ents)
908 U_right pt -> rdEntities pt `thenUgn` \ ents ->
909 returnUgn (True, ents)
911 cvIfaceFlavour 0 = HiFile -- No pragam
912 cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
917 = rdU_list pt `thenUgn` \ list ->
918 wlkList rdEntity list
920 rdEntity :: ParseTree -> UgnM (IE RdrName)
923 = rdU_entidt pt `thenUgn` \ entity ->
925 U_entid evar -> -- just a value
926 wlkEntId evar `thenUgn` \ var ->
927 returnUgn (IEVar var)
929 U_enttype x -> -- abstract type constructor/class
930 wlkTCId x `thenUgn` \ thing ->
931 returnUgn (IEThingAbs thing)
933 U_enttypeall x -> -- non-abstract type constructor/class
934 wlkTCId x `thenUgn` \ thing ->
935 returnUgn (IEThingAll thing)
937 U_enttypenamed x ns -> -- non-abstract type constructor/class
938 -- with specified constrs/methods
939 wlkTCId x `thenUgn` \ thing ->
940 wlkList rdVarId ns `thenUgn` \ names ->
941 returnUgn (IEThingWith thing names)
943 U_entmod mod -> -- everything provided unqualified by a module
944 returnUgn (IEModuleContents mod)
948 %************************************************************************
950 \subsection[rdExtName]{Read an external name}
952 %************************************************************************
955 wlkExtName :: U_maybe -> UgnM ExtName
956 wlkExtName (U_nothing) = returnUgn Dynamic
957 wlkExtName (U_just pt)
958 = rdU_list pt `thenUgn` \ ds ->
959 wlkList rdU_hstring ds `thenUgn` \ ss ->
961 [nm] -> returnUgn (ExtName nm Nothing)
962 [mod,nm] -> returnUgn (ExtName nm (Just mod))
964 rdCallConv :: Int -> UgnM CallConv
965 rdCallConv x = returnUgn x
967 rdImpExp :: Int -> Bool -> UgnM (Maybe Bool)
968 rdImpExp 0 isUnsafe = -- foreign import
969 returnUgn (Just isUnsafe)
970 rdImpExp 1 _ = -- foreign export