2 % (c) The AQUA Project, Glasgow University, 1994-1998
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 )
17 import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
18 import PrelMods ( pRELUDE )
22 import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts )
23 import Module ( Module, mkSrcModuleFS, mkImportModuleFS,
26 import OccName ( NameSpace, tcName, clsName, tcClsName, varName, dataName, tvName,
29 import RdrName ( RdrName, isRdrDataCon, mkSrcQual, mkSrcUnqual, mkPreludeQual,
33 import SrcLoc ( SrcLoc )
34 import FastString ( mkFastCharString )
35 import PrelRead ( readRational__ )
38 %************************************************************************
40 \subsection[ReadPrefix-help]{Help Functions}
42 %************************************************************************
45 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
47 wlkList wlk_it U_lnil = returnUgn []
49 wlkList wlk_it (U_lcons hd tl)
50 = wlk_it hd `thenUgn` \ hd_it ->
51 wlkList wlk_it tl `thenUgn` \ tl_it ->
52 returnUgn (hd_it : tl_it)
56 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
58 wlkMaybe wlk_it U_nothing = returnUgn Nothing
59 wlkMaybe wlk_it (U_just x)
60 = wlk_it x `thenUgn` \ it ->
65 wlkTcClsId = wlkQid (\_ -> tcClsName)
66 wlkTcId = wlkQid (\_ -> tcName)
67 wlkClsId = wlkQid (\_ -> clsName)
68 wlkVarId = wlkQid (\occ -> if isLexCon occ
71 wlkDataId = wlkQid (\_ -> dataName)
72 wlkEntId = wlkQid (\occ -> if isLexCon occ
76 wlkQid :: (FAST_STRING -> NameSpace) -> U_qid -> UgnM RdrName
78 -- There are three kinds of qid:
79 -- qualified name (aqual) A.x
80 -- unqualified name (noqual) x
81 -- special name (gid) [], (), ->, (,,,)
82 -- The special names always mean "Prelude.whatever"; that's why
83 -- they are distinct. So if you write "()", it's just as if you
84 -- had written "Prelude.()".
85 -- NB: The (qualified) prelude is always in scope, so the renamer will find it.
87 -- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
88 -- case we need to unqualify these things. -- SDM.
90 wlkQid mk_name_space (U_noqual name)
91 = returnUgn (mkSrcUnqual (mk_name_space name) name)
92 wlkQid mk_name_space (U_aqual mod name)
93 = returnUgn (mkSrcQual (mk_name_space name) mod name)
94 wlkQid mk_name_space (U_gid n name) -- Built in Prelude things
95 | opt_NoImplicitPrelude
96 = returnUgn (mkSrcUnqual (mk_name_space name) name)
98 = returnUgn (mkPreludeQual (mk_name_space name) pRELUDE name)
101 rdTCId pt = rdU_qid pt `thenUgn` wlkTcId
102 rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
104 rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
105 wlkTvId string = returnUgn (mkSrcUnqual tvName string)
107 cvFlag :: U_long -> Bool
112 %************************************************************************
114 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
116 %************************************************************************
119 rdModule :: IO (Module, -- this module's name
120 RdrNameHsModule) -- the main goods
123 = _ccall_ hspmain >>= \ pt -> -- call the Yacc parser!
125 srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
128 rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
129 hmodlist srciface_version srcline) ->
131 mod_name = mkSrcModuleFS mod_fs
134 setSrcFileUgn srcfile $
135 setSrcModUgn mod_name $
136 mkSrcLocUgn srcline $ \ src_loc ->
138 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
139 wlkList rdImport himplist `thenUgn` \ imports ->
140 wlkBinding hmodlist `thenUgn` \ binding ->
143 top_decls = cvTopDecls srcfile binding
147 (case srciface_version of { 0 -> Nothing; n -> Just n })
155 %************************************************************************
157 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
159 %************************************************************************
162 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
163 rdPat :: ParseTree -> UgnM RdrNamePat
165 rdExpr pt = rdU_tree pt `thenUgn` wlkExpr
166 rdPat pt = rdU_tree pt `thenUgn` wlkPat
168 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
169 wlkPat :: U_tree -> UgnM RdrNamePat
173 U_par pexpr -> -- parenthesised expr
174 wlkExpr pexpr `thenUgn` \ expr ->
175 returnUgn (HsPar expr)
177 U_lsection lsexp lop -> -- left section
178 wlkExpr lsexp `thenUgn` \ expr ->
179 wlkVarId lop `thenUgn` \ op ->
180 returnUgn (SectionL expr (HsVar op))
182 U_rsection rop rsexp -> -- right section
183 wlkVarId rop `thenUgn` \ op ->
184 wlkExpr rsexp `thenUgn` \ expr ->
185 returnUgn (SectionR (HsVar op) expr)
187 U_ccall fun flavor ccargs -> -- ccall/casm
188 wlkList rdExpr ccargs `thenUgn` \ args ->
192 returnUgn (CCall fun args
193 (tag == 'p' || tag == 'P') -- may invoke GC
194 (tag == 'N' || tag == 'P') -- really a "casm"
195 (panic "CCall:result_ty"))
197 U_scc label sccexp -> -- scc (set-cost-centre) expression
198 wlkExpr sccexp `thenUgn` \ expr ->
199 returnUgn (HsSCC label expr)
201 U_lambda match -> -- lambda expression
202 wlkMatch match `thenUgn` \ match' ->
203 returnUgn (HsLam match')
205 U_casee caseexpr casebody srcline -> -- case expression
206 mkSrcLocUgn srcline $ \ src_loc ->
207 wlkExpr caseexpr `thenUgn` \ expr ->
208 wlkList rdMatch casebody `thenUgn` \ mats ->
209 returnUgn (HsCase expr mats src_loc)
211 U_ife ifpred ifthen ifelse srcline -> -- if expression
212 mkSrcLocUgn srcline $ \ src_loc ->
213 wlkExpr ifpred `thenUgn` \ e1 ->
214 wlkExpr ifthen `thenUgn` \ e2 ->
215 wlkExpr ifelse `thenUgn` \ e3 ->
216 returnUgn (HsIf e1 e2 e3 src_loc)
218 U_let letvdefs letvexpr -> -- let expression
219 wlkLocalBinding letvdefs `thenUgn` \ binding ->
220 wlkExpr letvexpr `thenUgn` \ expr ->
221 returnUgn (HsLet binding expr)
223 U_doe gdo srcline -> -- do expression
224 mkSrcLocUgn srcline $ \ src_loc ->
225 wlkList rd_stmt gdo `thenUgn` \ stmts ->
226 returnUgn (HsDo DoStmt stmts src_loc)
229 = rdU_tree pt `thenUgn` \ bind ->
231 U_doexp exp srcline ->
232 mkSrcLocUgn srcline $ \ src_loc ->
233 wlkExpr exp `thenUgn` \ expr ->
234 returnUgn (ExprStmt expr src_loc)
236 U_dobind pat exp srcline ->
237 mkSrcLocUgn srcline $ \ src_loc ->
238 wlkPat pat `thenUgn` \ patt ->
239 wlkExpr exp `thenUgn` \ expr ->
240 returnUgn (BindStmt patt expr src_loc)
243 wlkLocalBinding seqlet `thenUgn` \ binds ->
244 returnUgn (LetStmt binds)
246 U_comprh cexp cquals -> -- list comprehension
247 wlkExpr cexp `thenUgn` \ expr ->
248 wlkQuals cquals `thenUgn` \ quals ->
249 getSrcLocUgn `thenUgn` \ loc ->
250 returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
252 U_eenum efrom estep eto -> -- arithmetic sequence
253 wlkExpr efrom `thenUgn` \ e1 ->
254 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
255 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
256 returnUgn (cv_arith_seq e1 es2 es3)
258 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
259 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
260 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
261 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
263 U_restr restre restrt -> -- expression with type signature
264 wlkExpr restre `thenUgn` \ expr ->
265 wlkHsSigType restrt `thenUgn` \ ty ->
266 returnUgn (ExprWithTySig expr ty)
268 --------------------------------------------------------------
269 -- now the prefix items that can either be an expression or
270 -- pattern, except we know they are *expressions* here
271 -- (this code could be commoned up with the pattern version;
272 -- but it probably isn't worth it)
273 --------------------------------------------------------------
275 wlkLiteral lit `thenUgn` \ lit ->
276 returnUgn (HsLit lit)
278 U_ident n -> -- simple identifier
279 wlkVarId n `thenUgn` \ var ->
280 returnUgn (HsVar var)
282 U_ap fun arg -> -- application
283 wlkExpr fun `thenUgn` \ expr1 ->
284 wlkExpr arg `thenUgn` \ expr2 ->
285 returnUgn (HsApp expr1 expr2)
287 U_infixap fun arg1 arg2 -> -- infix application
288 wlkVarId fun `thenUgn` \ op ->
289 wlkExpr arg1 `thenUgn` \ expr1 ->
290 wlkExpr arg2 `thenUgn` \ expr2 ->
291 returnUgn (mkOpApp expr1 op expr2)
293 U_negate nexp -> -- prefix negation
294 wlkExpr nexp `thenUgn` \ expr ->
295 returnUgn (NegApp expr (HsVar dummyRdrVarName))
297 U_llist llist -> -- explicit list
298 wlkList rdExpr llist `thenUgn` \ exprs ->
299 returnUgn (ExplicitList exprs)
301 U_tuple tuplelist -> -- explicit tuple
302 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
303 returnUgn (ExplicitTuple exprs True)
305 U_utuple tuplelist -> -- explicit tuple
306 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
307 returnUgn (ExplicitTuple exprs False)
309 U_record con rbinds -> -- record construction
310 wlkDataId con `thenUgn` \ rcon ->
311 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
312 returnUgn (RecordCon rcon recbinds)
314 U_rupdate updexp updbinds -> -- record update
315 wlkExpr updexp `thenUgn` \ aexp ->
316 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
317 returnUgn (RecordUpd aexp recbinds)
320 U_hmodule _ _ _ _ _ _ -> error "U_hmodule"
321 U_as _ _ -> error "U_as"
322 U_lazyp _ -> error "U_lazyp"
323 U_qual _ _ -> error "U_qual"
324 U_guard _ -> error "U_guard"
325 U_seqlet _ -> error "U_seqlet"
326 U_dobind _ _ _ -> error "U_dobind"
327 U_doexp _ _ -> error "U_doexp"
328 U_rbind _ _ -> error "U_rbind"
332 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
333 wlkVarId var `thenUgn` \ rvar ->
334 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
337 Nothing -> (rvar, HsVar rvar, True{-pun-})
338 Just re -> (rvar, re, False)
342 = wlkList rd_qual cquals
345 = rdU_tree pt `thenUgn` \ qual ->
351 wlkExpr exp `thenUgn` \ expr ->
352 getSrcLocUgn `thenUgn` \ loc ->
353 returnUgn (GuardStmt expr loc)
356 wlkPat qpat `thenUgn` \ pat ->
357 wlkExpr qexp `thenUgn` \ expr ->
358 getSrcLocUgn `thenUgn` \ loc ->
359 returnUgn (BindStmt pat expr loc)
362 wlkLocalBinding seqlet `thenUgn` \ binds ->
363 returnUgn (LetStmt binds)
365 U_let letvdefs letvexpr ->
366 wlkLocalBinding letvdefs `thenUgn` \ binds ->
367 wlkExpr letvexpr `thenUgn` \ expr ->
368 getSrcLocUgn `thenUgn` \ loc ->
369 returnUgn (GuardStmt (HsLet binds expr) loc)
372 Patterns: just bear in mind that lists of patterns are represented as
373 a series of ``applications''.
377 U_par ppat -> -- parenthesised pattern
378 wlkPat ppat `thenUgn` \ pat ->
379 -- tidy things up a little:
384 other -> ParPatIn pat
387 U_as avar as_pat -> -- "as" pattern
388 wlkVarId avar `thenUgn` \ var ->
389 wlkPat as_pat `thenUgn` \ pat ->
390 returnUgn (AsPatIn var pat)
393 wlkPat pat `thenUgn` \ pat' ->
394 wlkHsType ty `thenUgn` \ ty' ->
395 returnUgn (SigPatIn pat' ty')
397 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
398 wlkPat lazyp `thenUgn` \ pat ->
399 returnUgn (LazyPatIn pat)
402 wlkVarId avar `thenUgn` \ var ->
403 wlkLiteral lit `thenUgn` \ lit ->
404 returnUgn (NPlusKPatIn var lit)
406 U_lit lit -> -- literal pattern
407 wlkLiteral lit `thenUgn` \ lit ->
408 returnUgn (LitPatIn lit)
410 U_ident (U_noqual s) | s == SLIT("_")-> returnUgn WildPatIn -- Wild-card pattern
412 U_ident nn -> -- simple identifier
413 wlkVarId nn `thenUgn` \ n ->
415 if isRdrDataCon n then
421 U_ap l r -> -- "application": there's a list of patterns lurking here!
422 wlkPat r `thenUgn` \ rpat ->
423 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
425 VarPatIn x -> returnUgn (x, lpats)
426 ConPatIn x [] -> returnUgn (x, lpats)
427 ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
428 _ -> getSrcLocUgn `thenUgn` \ loc ->
429 pprPanic "Illegal pattern `application'"
430 (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
432 ) `thenUgn` \ (n, arg_pats) ->
433 returnUgn (ConPatIn n arg_pats)
438 wlkPat r `thenUgn` \ rpat ->
439 collect_pats l (rpat:acc)
443 wlkPat other `thenUgn` \ pat ->
446 U_infixap fun arg1 arg2 -> -- infix pattern
447 wlkVarId fun `thenUgn` \ op ->
448 wlkPat arg1 `thenUgn` \ pat1 ->
449 wlkPat arg2 `thenUgn` \ pat2 ->
450 returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
452 U_negate npat -> -- negated pattern
453 wlkPat npat `thenUgn` \ pat ->
454 returnUgn (NegPatIn pat)
456 U_llist llist -> -- explicit list
457 wlkList rdPat llist `thenUgn` \ pats ->
458 returnUgn (ListPatIn pats)
460 U_tuple tuplelist -> -- explicit tuple
461 wlkList rdPat tuplelist `thenUgn` \ pats ->
462 returnUgn (TuplePatIn pats True)
464 U_utuple tuplelist -> -- explicit tuple
465 wlkList rdPat tuplelist `thenUgn` \ pats ->
466 returnUgn (TuplePatIn pats False)
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 %************************************************************************
517 = wlkBinding bind `thenUgn` \ bind' ->
518 getSrcFileUgn `thenUgn` \ sf ->
519 returnUgn (cvBinds sf cvValSig bind')
521 wlkBinding :: U_binding -> UgnM RdrBinding
527 returnUgn RdrNullBind
529 -- "and" binding (just glue, really)
531 wlkBinding a `thenUgn` \ binding1 ->
532 wlkBinding b `thenUgn` \ binding2 ->
533 returnUgn (RdrAndBindings binding1 binding2)
535 -- fixity declaration
536 U_fixd op dir_n prec srcline ->
543 wlkVarId op `thenUgn` \ op ->
544 mkSrcLocUgn srcline $ \ src_loc ->
545 returnUgn (RdrSig (FixSig (FixitySig op (Fixity prec dir) src_loc)))
548 -- "data" declaration
549 U_tbind tctxt ttype tcons tderivs srcline ->
550 mkSrcLocUgn srcline $ \ src_loc ->
551 wlkContext tctxt `thenUgn` \ ctxt ->
552 wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
553 wlkList rdConDecl tcons `thenUgn` \ cons ->
554 wlkDerivings tderivs `thenUgn` \ derivings ->
555 returnUgn (RdrTyClDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
557 -- "newtype" declaration
558 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
559 mkSrcLocUgn srcline $ \ src_loc ->
560 wlkContext ntctxt `thenUgn` \ ctxt ->
561 wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
562 wlkList rdConDecl ntcon `thenUgn` \ cons ->
563 wlkDerivings ntderivs `thenUgn` \ derivings ->
564 returnUgn (RdrTyClDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
566 -- "type" declaration
567 U_nbind nbindid nbindas srcline ->
568 mkSrcLocUgn srcline $ \ src_loc ->
569 wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
570 wlkHsType nbindas `thenUgn` \ expansion ->
571 returnUgn (RdrTyClDecl (TySynonym tycon tyvars expansion src_loc))
574 U_fbind fbindm srcline ->
575 mkSrcLocUgn srcline $ \ src_loc ->
576 wlkList rdMatch fbindm `thenUgn` \ matches ->
577 returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc))
580 U_pbind pbindl pbindr srcline ->
581 mkSrcLocUgn srcline $ \ src_loc ->
582 rdPat pbindl `thenUgn` \ pat ->
583 rdGRHSs pbindr `thenUgn` \ grhss ->
584 returnUgn (RdrValBinding (PatMonoBind pat grhss src_loc))
586 -- "class" declaration
587 U_cbind cbindc cbindid cbindw srcline ->
588 mkSrcLocUgn srcline $ \ src_loc ->
589 wlkContext cbindc `thenUgn` \ ctxt ->
590 wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) ->
591 wlkBinding cbindw `thenUgn` \ binding ->
592 getSrcFileUgn `thenUgn` \ sf ->
594 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
596 returnUgn (RdrTyClDecl
597 (mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc))
599 -- "instance" declaration
600 U_ibind ty ibindw srcline ->
601 -- The "ty" contains the instance context too
602 -- So for "instance Eq a => Eq [a]" the type will be
604 mkSrcLocUgn srcline $ \ src_loc ->
605 wlkInstType ty `thenUgn` \ inst_ty ->
606 wlkBinding ibindw `thenUgn` \ binding ->
607 getSrcModUgn `thenUgn` \ modname ->
608 getSrcFileUgn `thenUgn` \ sf ->
610 (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
612 returnUgn (RdrInstDecl
613 (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
615 -- "default" declaration
616 U_dbind dbindts srcline ->
617 mkSrcLocUgn srcline $ \ src_loc ->
618 wlkList rdMonoType dbindts `thenUgn` \ tys ->
619 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
621 -- "foreign" declaration
622 U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
623 mkSrcLocUgn srcline $ \ src_loc ->
624 wlkVarId id `thenUgn` \ h_id ->
625 wlkHsSigType ty `thenUgn` \ h_ty ->
626 wlkExtName ext_name `thenUgn` \ h_ext_name ->
627 rdCallConv cconv `thenUgn` \ h_cconv ->
628 rdForKind imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
629 returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
631 U_sbind sbindids sbindid srcline ->
633 mkSrcLocUgn srcline $ \ src_loc ->
634 wlkList rdVarId sbindids `thenUgn` \ vars ->
635 wlkHsSigType sbindid `thenUgn` \ poly_ty ->
636 returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
638 U_vspec_uprag uvar vspec_tys srcline ->
639 -- value specialisation user-pragma
640 mkSrcLocUgn srcline $ \ src_loc ->
641 wlkVarId uvar `thenUgn` \ var ->
642 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
643 returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
644 | (ty, using_id) <- tys_and_ids ])
646 rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
648 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
649 wlkHsSigType vspec_ty `thenUgn` \ ty ->
650 wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
651 returnUgn(ty, id_maybe)
653 U_ispec_uprag iclas ispec_ty srcline ->
654 -- instance specialisation user-pragma
655 mkSrcLocUgn srcline $ \ src_loc ->
656 wlkHsSigType ispec_ty `thenUgn` \ ty ->
657 returnUgn (RdrSig (SpecInstSig ty src_loc))
659 U_inline_uprag ivar srcline ->
660 -- value inlining user-pragma
661 mkSrcLocUgn srcline $ \ src_loc ->
662 wlkVarId ivar `thenUgn` \ var ->
663 returnUgn (RdrSig (InlineSig var src_loc))
665 U_noinline_uprag ivar srcline ->
667 mkSrcLocUgn srcline $ \ src_loc ->
668 wlkVarId ivar `thenUgn` \ var ->
669 returnUgn (RdrSig (NoInlineSig var src_loc))
672 mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds
673 mkRdrFunctionBinding fun_matches src_loc
674 = FunMonoBind (head fns) (head infs) matches src_loc
676 (fns, infs, matches) = unzip3 (map de_fun_match fun_matches)
678 de_fun_match (Match _ [ConPatIn fn pats] sig grhss) = (fn, False, Match [] pats sig grhss)
679 de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True, Match [] [p1,p2] sig grhss)
682 rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs
683 rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs
685 wlkGRHSs :: U_grhsb -> UgnM RdrNameGRHSs
686 wlkGRHSs (U_pguards rhss bind)
687 = wlkList rdGdExp rhss `thenUgn` \ gdexps ->
688 wlkLocalBinding bind `thenUgn` \ bind' ->
689 returnUgn (GRHSs gdexps bind' Nothing)
690 wlkGRHSs (U_pnoguards srcline rhs bind)
691 = mkSrcLocUgn srcline $ \ src_loc ->
692 rdExpr rhs `thenUgn` \ rhs' ->
693 wlkLocalBinding bind `thenUgn` \ bind' ->
694 returnUgn (GRHSs (unguardedRHS rhs' src_loc) bind' Nothing)
697 rdGdExp :: ParseTree -> UgnM RdrNameGRHS
698 rdGdExp pt = rdU_gdexp pt `thenUgn` \ (U_pgdexp guards srcline rhs) ->
699 wlkQuals guards `thenUgn` \ guards' ->
700 mkSrcLocUgn srcline $ \ src_loc ->
701 wlkExpr rhs `thenUgn` \ expr' ->
702 returnUgn (GRHS (guards' ++ [ExprStmt expr' src_loc]) src_loc)
706 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
708 wlkDerivings (U_nothing) = returnUgn Nothing
709 wlkDerivings (U_just pt)
710 = rdU_list pt `thenUgn` \ ds ->
711 wlkList rdTCId ds `thenUgn` \ derivs ->
712 returnUgn (Just derivs)
715 %************************************************************************
717 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
719 %************************************************************************
722 rdHsType :: ParseTree -> UgnM RdrNameHsType
723 rdMonoType :: ParseTree -> UgnM RdrNameHsType
725 rdHsType pt = rdU_ttype pt `thenUgn` wlkHsType
726 rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType
728 wlkHsConstrArgType ttype
729 -- Used for the argument types of contructors
730 -- Only an implicit quantification point if -fglasgow-exts
731 | opt_GlasgowExts = wlkHsSigType ttype
732 | otherwise = wlkHsType ttype
734 -- wlkHsSigType is used for type signatures: any place there
735 -- should be *implicit* quantification
737 = wlkHsType ttype `thenUgn` \ ty ->
738 -- This is an implicit quantification point, so
739 -- make sure it starts with a ForAll
741 HsForAllTy _ _ _ -> returnUgn ty
742 other -> returnUgn (HsForAllTy Nothing [] ty)
744 wlkHsType :: U_ttype -> UgnM RdrNameHsType
747 U_forall u_tyvars u_theta u_ty -> -- Explicit forall
748 wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
749 wlkContext u_theta `thenUgn` \ theta ->
750 wlkHsType u_ty `thenUgn` \ ty ->
751 returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta ty)
753 U_imp_forall u_theta u_ty -> -- Implicit forall
754 wlkContext u_theta `thenUgn` \ theta ->
755 wlkHsType u_ty `thenUgn` \ ty ->
756 returnUgn (HsForAllTy Nothing theta ty)
758 U_namedtvar tv -> -- type variable
759 wlkTvId tv `thenUgn` \ tyvar ->
760 returnUgn (MonoTyVar tyvar)
762 U_tname tcon -> -- type constructor
763 wlkTcId tcon `thenUgn` \ tycon ->
764 returnUgn (MonoTyVar tycon)
767 wlkHsType t1 `thenUgn` \ ty1 ->
768 wlkHsType t2 `thenUgn` \ ty2 ->
769 returnUgn (MonoTyApp ty1 ty2)
771 U_tllist tlist -> -- list type
772 wlkHsType tlist `thenUgn` \ ty ->
773 returnUgn (MonoListTy ty)
776 wlkList rdMonoType ttuple `thenUgn` \ tys ->
777 returnUgn (MonoTupleTy tys True)
780 wlkList rdMonoType ttuple `thenUgn` \ tys ->
781 returnUgn (MonoTupleTy tys False)
784 wlkHsType tfun `thenUgn` \ ty1 ->
785 wlkHsType targ `thenUgn` \ ty2 ->
786 returnUgn (MonoFunTy ty1 ty2)
790 U_forall u_tyvars u_theta inst_head ->
791 wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
792 wlkContext u_theta `thenUgn` \ theta ->
793 wlkClsTys inst_head `thenUgn` \ (clas, tys) ->
794 returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta (MonoDictTy clas tys))
796 U_imp_forall u_theta inst_head ->
797 wlkContext u_theta `thenUgn` \ theta ->
798 wlkClsTys inst_head `thenUgn` \ (clas, tys) ->
799 returnUgn (HsForAllTy Nothing theta (MonoDictTy clas tys))
801 other -> -- something else
802 wlkClsTys other `thenUgn` \ (clas, tys) ->
803 returnUgn (HsForAllTy Nothing [] (MonoDictTy clas tys))
807 wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
808 wlkConAndTyVars ttype
809 = wlkHsType ttype `thenUgn` \ ty ->
811 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
812 split (MonoTyVar tycon) args = (tycon,args)
813 split other args = pprPanic "ERROR: malformed type: "
816 returnUgn (split ty [])
819 wlkContext :: U_list -> UgnM RdrNameContext
820 rdClsTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
822 wlkContext list = wlkList rdClsTys list
824 rdClsTys pt = rdU_ttype pt `thenUgn` wlkClsTys
829 go (U_tname tcon) tys = wlkClsId tcon `thenUgn` \ cls ->
832 go (U_tapp t1 t2) tys = wlkHsType t2 `thenUgn` \ ty2 ->
837 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
838 rdConDecl pt = rdU_constr pt `thenUgn` wlkConDecl
840 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
842 wlkConDecl (U_constrex u_tvs ccxt ccdecl)
843 = wlkList rdTvId u_tvs `thenUgn` \ tyvars ->
844 wlkContext ccxt `thenUgn` \ theta ->
845 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ _ details loc) ->
846 returnUgn (ConDecl con (map UserTyVar tyvars) theta details loc)
848 wlkConDecl (U_constrpre ccon ctys srcline)
849 = mkSrcLocUgn srcline $ \ src_loc ->
850 wlkDataId ccon `thenUgn` \ con ->
851 wlkList rdBangType ctys `thenUgn` \ tys ->
852 returnUgn (ConDecl con [] [] (VanillaCon tys) src_loc)
854 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
855 = mkSrcLocUgn srcline $ \ src_loc ->
856 wlkBangType cty1 `thenUgn` \ ty1 ->
857 wlkDataId cop `thenUgn` \ op ->
858 wlkBangType cty2 `thenUgn` \ ty2 ->
859 returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
861 wlkConDecl (U_constrnew ccon cty mb_lab srcline)
862 = mkSrcLocUgn srcline $ \ src_loc ->
863 wlkDataId ccon `thenUgn` \ con ->
864 wlkHsSigType cty `thenUgn` \ ty ->
865 wlkMaybe rdVarId mb_lab `thenUgn` \ mb_lab ->
866 returnUgn (ConDecl con [] [] (NewCon ty mb_lab) src_loc)
868 wlkConDecl (U_constrrec ccon cfields srcline)
869 = mkSrcLocUgn srcline $ \ src_loc ->
870 wlkDataId ccon `thenUgn` \ con ->
871 wlkList rd_field cfields `thenUgn` \ fields_lists ->
872 returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
874 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
876 rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
877 wlkList rdVarId fvars `thenUgn` \ vars ->
878 wlkBangType fty `thenUgn` \ ty ->
882 rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
884 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
886 wlkBangType (U_tbang bty) = wlkHsConstrArgType bty `thenUgn` \ ty ->
887 returnUgn (Banged ty)
888 wlkBangType uty = wlkHsConstrArgType uty `thenUgn` \ ty ->
889 returnUgn (Unbanged ty)
892 %************************************************************************
894 \subsection{Read a ``match''}
896 %************************************************************************
899 rdMatch :: ParseTree -> UgnM RdrNameMatch
900 rdMatch pt = rdU_match pt `thenUgn` wlkMatch
902 wlkMatch :: U_match -> UgnM RdrNameMatch
903 wlkMatch (U_pmatch pats sig grhsb)
904 = wlkList rdPat pats `thenUgn` \ pats' ->
905 wlkMaybe rdHsType sig `thenUgn` \ maybe_ty ->
906 wlkGRHSs grhsb `thenUgn` \ grhss' ->
907 returnUgn (Match [] pats' maybe_ty grhss')
910 %************************************************************************
912 \subsection[rdImport]{Read an import decl}
914 %************************************************************************
917 rdImport :: ParseTree
918 -> UgnM RdrNameImportDecl
921 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
922 mkSrcLocUgn srcline $ \ src_loc ->
923 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
924 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
925 returnUgn (ImportDecl (mkImportModuleFS imod (cvIfaceFlavour isrc))
927 (case maybe_as of { Just m -> Just (mkSrcModuleFS m); Nothing -> Nothing })
930 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
932 U_left pt -> rdEntities pt `thenUgn` \ ents ->
933 returnUgn (False, ents)
934 U_right pt -> rdEntities pt `thenUgn` \ ents ->
935 returnUgn (True, ents)
937 cvIfaceFlavour 0 = hiFile -- No pragam
938 cvIfaceFlavour 1 = hiBootFile -- {-# SOURCE #-}
942 rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity
944 rdEntity :: ParseTree -> UgnM (IE RdrName)
947 = rdU_entidt pt `thenUgn` \ entity ->
949 U_entid evar -> -- just a value
950 wlkEntId evar `thenUgn` \ var ->
951 returnUgn (IEVar var)
953 U_enttype x -> -- abstract type constructor/class
954 wlkTcClsId x `thenUgn` \ thing ->
955 returnUgn (IEThingAbs thing)
957 U_enttypeall x -> -- non-abstract type constructor/class
958 wlkTcClsId x `thenUgn` \ thing ->
959 returnUgn (IEThingAll thing)
961 U_enttypenamed x ns -> -- non-abstract type constructor/class
962 -- with specified constrs/methods
963 wlkTcClsId x `thenUgn` \ thing ->
964 wlkList rdVarId ns `thenUgn` \ names ->
965 returnUgn (IEThingWith thing names)
967 U_entmod mod -> -- everything provided unqualified by a module
968 returnUgn (IEModuleContents (mkSrcModuleFS mod))
972 %************************************************************************
974 \subsection[rdExtName]{Read an external name}
976 %************************************************************************
979 wlkExtName :: U_maybe -> UgnM ExtName
980 wlkExtName (U_nothing) = returnUgn Dynamic
981 wlkExtName (U_just pt)
982 = rdU_list pt `thenUgn` \ ds ->
983 wlkList rdU_hstring ds `thenUgn` \ ss ->
985 [nm] -> returnUgn (ExtName nm Nothing)
986 [mod,nm] -> returnUgn (ExtName nm (Just mod))
988 rdCallConv :: Int -> UgnM CallConv
990 -- this tracks the #defines in parser/utils.h
992 (-1) -> -- no calling convention specified, use default.
993 returnUgn defaultCallConv
996 rdForKind :: Int -> Bool -> UgnM ForKind
997 rdForKind 0 isUnsafe = -- foreign import
998 returnUgn (FoImport isUnsafe)
999 rdForKind 1 _ = -- foreign export
1001 rdForKind 2 _ = -- foreign label