2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section{Read parse tree built by Yacc parser}
7 #include "HsVersions.h"
9 module ReadPrefix ( rdModule ) where
12 IMPORT_1_3(IO(hPutStr, stderr))
13 IMPORT_1_3(GHCio(stThen))
15 import UgenAll -- all Yacc parser gumpff...
16 import PrefixSyn -- and various syntaxen.
18 import HsTypes ( HsTyVar(..) )
19 import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
23 import ErrUtils ( addErrLoc, ghcExit )
24 import FiniteMap ( elemFM, FiniteMap )
25 import Name ( RdrName(..), OccName(..) )
26 import Lex ( isLexConId )
27 import PprStyle ( PprStyle(..) )
30 import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
31 import Util ( nOfThem, pprError, panic )
34 %************************************************************************
36 \subsection[ReadPrefix-help]{Help Functions}
38 %************************************************************************
41 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
43 wlkList wlk_it U_lnil = returnUgn []
45 wlkList wlk_it (U_lcons hd tl)
46 = wlk_it hd `thenUgn` \ hd_it ->
47 wlkList wlk_it tl `thenUgn` \ tl_it ->
48 returnUgn (hd_it : tl_it)
52 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
54 wlkMaybe wlk_it U_nothing = returnUgn Nothing
55 wlkMaybe wlk_it (U_just x)
56 = wlk_it x `thenUgn` \ it ->
61 wlkTvId = wlkQid TvOcc
62 wlkTCId = wlkQid TCOcc
63 wlkVarId = wlkQid VarOcc
64 wlkDataId = wlkQid VarOcc
65 wlkEntId = wlkQid (\occ -> if isLexConId occ
69 wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
70 wlkQid mk_occ_name (U_noqual name)
71 = returnUgn (Unqual (mk_occ_name name))
72 wlkQid mk_occ_name (U_aqual mod name)
73 = returnUgn (Qual mod (mk_occ_name name))
75 -- I don't understand this one! It is what shows up when we meet (), [], or (,,,).
76 wlkQid mk_occ_name (U_gid n name)
77 = returnUgn (Unqual (mk_occ_name name))
79 rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
80 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
82 cvFlag :: U_long -> Bool
87 %************************************************************************
89 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
91 %************************************************************************
94 #if __GLASGOW_HASKELL__ >= 200
95 # define PACK_STR packCString
96 # define CCALL_THEN `stThen`
98 # define PACK_STR _packCString
99 # define CCALL_THEN `thenPrimIO`
102 rdModule :: IO (Module, -- this module's name
103 RdrNameHsModule) -- the main goods
106 = _ccall_ hspmain CCALL_THEN \ pt -> -- call the Yacc parser!
108 srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
111 rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
112 hmodlist srciface_version srcline) ->
114 setSrcFileUgn srcfile $
115 setSrcModUgn modname $
116 mkSrcLocUgn srcline $ \ src_loc ->
118 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
119 wlkList rdImport himplist `thenUgn` \ imports ->
120 wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
121 wlkBinding hmodlist `thenUgn` \ binding ->
124 val_decl = ValD (add_main_sig modname (cvBinds srcfile cvValSig binding))
125 other_decls = cvOtherDecls binding
129 (case srciface_version of { 0 -> Nothing; n -> Just n })
133 (val_decl: other_decls)
137 add_main_sig modname binds
138 = if modname == mAIN then
140 s = Sig (varUnqual SLIT("main")) (io_ty SLIT("IO")) mkGeneratedSrcLoc
144 else if modname == gHC_MAIN then
146 s = Sig (varUnqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) mkGeneratedSrcLoc
153 add_sig (SingleBind b) s = BindWith b [s]
154 add_sig (BindWith b ss) s = BindWith b (s:ss)
155 add_sig _ _ = panic "rdModule:add_sig"
157 io_ty t = MonoTyApp (Unqual (TCOcc t)) [MonoTupleTy dummyRdrTcName []]
160 %************************************************************************
162 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
164 %************************************************************************
167 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
168 rdPat :: ParseTree -> UgnM RdrNamePat
170 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
171 rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
173 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
174 wlkPat :: U_tree -> UgnM RdrNamePat
178 U_par pexpr -> -- parenthesised expr
179 wlkExpr pexpr `thenUgn` \ expr ->
180 returnUgn (HsPar expr)
182 U_lsection lsexp lop -> -- left section
183 wlkExpr lsexp `thenUgn` \ expr ->
184 wlkVarId lop `thenUgn` \ op ->
185 returnUgn (SectionL expr (HsVar op))
187 U_rsection rop rsexp -> -- right section
188 wlkVarId rop `thenUgn` \ op ->
189 wlkExpr rsexp `thenUgn` \ expr ->
190 returnUgn (SectionR (HsVar op) expr)
192 U_ccall fun flavor ccargs -> -- ccall/casm
193 wlkList rdExpr ccargs `thenUgn` \ args ->
197 returnUgn (CCall fun args
198 (tag == 'p' || tag == 'P') -- may invoke GC
199 (tag == 'N' || tag == 'P') -- really a "casm"
200 (panic "CCall:result_ty"))
202 U_scc label sccexp -> -- scc (set-cost-centre) expression
203 wlkExpr sccexp `thenUgn` \ expr ->
204 returnUgn (HsSCC label expr)
206 U_lambda lampats lamexpr srcline -> -- lambda expression
207 mkSrcLocUgn srcline $ \ src_loc ->
208 wlkList rdPat lampats `thenUgn` \ pats ->
209 wlkExpr lamexpr `thenUgn` \ body ->
211 HsLam (foldr PatMatch
212 (GRHSMatch (GRHSsAndBindsIn
213 [OtherwiseGRHS body src_loc]
218 U_casee caseexpr casebody srcline -> -- case expression
219 mkSrcLocUgn srcline $ \ src_loc ->
220 wlkExpr caseexpr `thenUgn` \ expr ->
221 wlkList rdMatch casebody `thenUgn` \ mats ->
222 getSrcFileUgn `thenUgn` \ sf ->
224 matches = cvMatches sf True mats
226 returnUgn (HsCase expr matches src_loc)
228 U_ife ifpred ifthen ifelse srcline -> -- if expression
229 mkSrcLocUgn srcline $ \ src_loc ->
230 wlkExpr ifpred `thenUgn` \ e1 ->
231 wlkExpr ifthen `thenUgn` \ e2 ->
232 wlkExpr ifelse `thenUgn` \ e3 ->
233 returnUgn (HsIf e1 e2 e3 src_loc)
235 U_let letvdefs letvexpr -> -- let expression
236 wlkBinding letvdefs `thenUgn` \ binding ->
237 wlkExpr letvexpr `thenUgn` \ expr ->
238 getSrcFileUgn `thenUgn` \ sf ->
240 binds = cvBinds sf cvValSig binding
242 returnUgn (HsLet binds expr)
244 U_doe gdo srcline -> -- do expression
245 mkSrcLocUgn srcline $ \ src_loc ->
246 wlkList rd_stmt gdo `thenUgn` \ stmts ->
247 returnUgn (HsDo stmts src_loc)
250 = rdU_tree pt `thenUgn` \ bind ->
252 U_doexp exp srcline ->
253 mkSrcLocUgn srcline $ \ src_loc ->
254 wlkExpr exp `thenUgn` \ expr ->
255 returnUgn (ExprStmt expr src_loc)
257 U_dobind pat exp srcline ->
258 mkSrcLocUgn srcline $ \ src_loc ->
259 wlkPat pat `thenUgn` \ patt ->
260 wlkExpr exp `thenUgn` \ expr ->
261 returnUgn (BindStmt patt expr src_loc)
264 wlkBinding seqlet `thenUgn` \ bs ->
265 getSrcFileUgn `thenUgn` \ sf ->
267 binds = cvBinds sf cvValSig bs
269 returnUgn (LetStmt binds)
271 U_comprh cexp cquals -> -- list comprehension
272 wlkExpr cexp `thenUgn` \ expr ->
273 wlkList rd_qual cquals `thenUgn` \ quals ->
274 returnUgn (ListComp expr quals)
277 = rdU_tree pt `thenUgn` \ qual ->
283 wlkExpr exp `thenUgn` \ expr ->
284 returnUgn (FilterQual expr)
287 wlkPat qpat `thenUgn` \ pat ->
288 wlkExpr qexp `thenUgn` \ expr ->
289 returnUgn (GeneratorQual pat expr)
292 wlkBinding seqlet `thenUgn` \ bs ->
293 getSrcFileUgn `thenUgn` \ sf ->
295 binds = cvBinds sf cvValSig bs
297 returnUgn (LetQual binds)
299 U_eenum efrom estep eto -> -- arithmetic sequence
300 wlkExpr efrom `thenUgn` \ e1 ->
301 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
302 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
303 returnUgn (cv_arith_seq e1 es2 es3)
305 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
306 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
307 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
308 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
310 U_restr restre restrt -> -- expression with type signature
311 wlkExpr restre `thenUgn` \ expr ->
312 wlkHsType restrt `thenUgn` \ ty ->
313 returnUgn (ExprWithTySig expr ty)
315 --------------------------------------------------------------
316 -- now the prefix items that can either be an expression or
317 -- pattern, except we know they are *expressions* here
318 -- (this code could be commoned up with the pattern version;
319 -- but it probably isn't worth it)
320 --------------------------------------------------------------
322 wlkLiteral lit `thenUgn` \ lit ->
323 returnUgn (HsLit lit)
325 U_ident n -> -- simple identifier
326 wlkVarId n `thenUgn` \ var ->
327 returnUgn (HsVar var)
329 U_ap fun arg -> -- application
330 wlkExpr fun `thenUgn` \ expr1 ->
331 wlkExpr arg `thenUgn` \ expr2 ->
332 returnUgn (HsApp expr1 expr2)
334 U_infixap fun arg1 arg2 -> -- infix application
335 wlkVarId fun `thenUgn` \ op ->
336 wlkExpr arg1 `thenUgn` \ expr1 ->
337 wlkExpr arg2 `thenUgn` \ expr2 ->
338 returnUgn (OpApp expr1 (HsVar op) expr2)
340 U_negate nexp -> -- prefix negation
341 wlkExpr nexp `thenUgn` \ expr ->
342 returnUgn (NegApp expr (HsVar dummyRdrVarName))
344 U_llist llist -> -- explicit list
345 wlkList rdExpr llist `thenUgn` \ exprs ->
346 returnUgn (ExplicitList exprs)
348 U_tuple tuplelist -> -- explicit tuple
349 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
350 returnUgn (ExplicitTuple exprs)
352 U_record con rbinds -> -- record construction
353 wlkDataId con `thenUgn` \ rcon ->
354 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
355 returnUgn (RecordCon (HsVar rcon) recbinds)
357 U_rupdate updexp updbinds -> -- record update
358 wlkExpr updexp `thenUgn` \ aexp ->
359 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
360 returnUgn (RecordUpd aexp recbinds)
363 U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
364 U_as _ _ -> error "U_as"
365 U_lazyp _ -> error "U_lazyp"
366 U_wildp -> error "U_wildp"
367 U_qual _ _ -> error "U_qual"
368 U_guard _ -> error "U_guard"
369 U_seqlet _ -> error "U_seqlet"
370 U_dobind _ _ _ -> error "U_dobind"
371 U_doexp _ _ -> error "U_doexp"
372 U_rbind _ _ -> error "U_rbind"
373 U_fixop _ _ _ -> error "U_fixop"
377 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
378 wlkVarId var `thenUgn` \ rvar ->
379 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
382 Nothing -> (rvar, HsVar rvar, True{-pun-})
383 Just re -> (rvar, re, False)
387 Patterns: just bear in mind that lists of patterns are represented as
388 a series of ``applications''.
392 U_par ppat -> -- parenthesised pattern
393 wlkPat ppat `thenUgn` \ pat ->
394 -- tidy things up a little:
399 other -> ParPatIn pat
402 U_as avar as_pat -> -- "as" pattern
403 wlkVarId avar `thenUgn` \ var ->
404 wlkPat as_pat `thenUgn` \ pat ->
405 returnUgn (AsPatIn var pat)
407 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
408 wlkPat lazyp `thenUgn` \ pat ->
409 returnUgn (LazyPatIn pat)
411 U_wildp -> returnUgn WildPatIn -- wildcard pattern
413 U_lit lit -> -- literal pattern
414 wlkLiteral lit `thenUgn` \ lit ->
415 returnUgn (LitPatIn lit)
417 U_ident nn -> -- simple identifier
418 wlkVarId nn `thenUgn` \ n ->
421 VarOcc occ | isLexConId occ -> ConPatIn n []
425 U_ap l r -> -- "application": there's a list of patterns lurking here!
426 wlkPat r `thenUgn` \ rpat ->
427 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
429 VarPatIn x -> returnUgn (x, lpats)
430 ConPatIn x [] -> returnUgn (x, lpats)
431 ConOpPatIn x op y -> returnUgn (op, x:y:lpats)
432 _ -> getSrcLocUgn `thenUgn` \ loc ->
434 err = addErrLoc loc "Illegal pattern `application'"
435 (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
436 msg = ppShow 100 (err PprForUser)
438 #if __GLASGOW_HASKELL__ >= 200
439 ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
440 ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
442 ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
443 ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
445 returnUgn (error "ReadPrefix")
447 ) `thenUgn` \ (n, arg_pats) ->
448 returnUgn (ConPatIn n arg_pats)
453 wlkPat r `thenUgn` \ rpat ->
454 collect_pats l (rpat:acc)
456 wlkPat other `thenUgn` \ pat ->
459 U_infixap fun arg1 arg2 -> -- infix pattern
460 wlkVarId fun `thenUgn` \ op ->
461 wlkPat arg1 `thenUgn` \ pat1 ->
462 wlkPat arg2 `thenUgn` \ pat2 ->
463 returnUgn (ConOpPatIn pat1 op pat2)
465 U_negate npat -> -- negated pattern
466 wlkPat npat `thenUgn` \ pat ->
467 returnUgn (NegPatIn pat)
469 U_llist llist -> -- explicit list
470 wlkList rdPat llist `thenUgn` \ pats ->
471 returnUgn (ListPatIn pats)
473 U_tuple tuplelist -> -- explicit tuple
474 wlkList rdPat tuplelist `thenUgn` \ pats ->
475 returnUgn (TuplePatIn pats)
477 U_record con rpats -> -- record destruction
478 wlkDataId con `thenUgn` \ rcon ->
479 wlkList rdRpat rpats `thenUgn` \ recpats ->
480 returnUgn (RecPatIn rcon recpats)
483 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
484 wlkVarId var `thenUgn` \ rvar ->
485 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
488 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
489 Just rp -> (rvar, rp, False)
494 wlkLiteral :: U_literal -> UgnM HsLit
499 U_integer s -> HsInt (as_integer s)
500 U_floatr s -> HsFrac (as_rational s)
501 U_intprim s -> HsIntPrim (as_integer s)
502 U_doubleprim s -> HsDoublePrim (as_rational s)
503 U_floatprim s -> HsFloatPrim (as_rational s)
504 U_charr s -> HsChar (as_char s)
505 U_charprim s -> HsCharPrim (as_char s)
506 U_string s -> HsString (as_string s)
507 U_stringprim s -> HsStringPrim (as_string s)
508 U_clitlit s -> HsLitLit (as_string s)
512 as_integer s = readInteger (_UNPK_ s)
513 #if __GLASGOW_HASKELL__ >= 200
514 as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
516 as_rational s = _readRational (_UNPK_ s) -- non-std
521 %************************************************************************
523 \subsection{wlkBinding}
525 %************************************************************************
528 wlkBinding :: U_binding -> UgnM RdrBinding
534 returnUgn RdrNullBind
536 -- "and" binding (just glue, really)
538 wlkBinding a `thenUgn` \ binding1 ->
539 wlkBinding b `thenUgn` \ binding2 ->
540 returnUgn (RdrAndBindings binding1 binding2)
542 -- "data" declaration
543 U_tbind tctxt ttype tcons tderivs srcline ->
544 mkSrcLocUgn srcline $ \ src_loc ->
545 wlkContext tctxt `thenUgn` \ ctxt ->
546 wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
547 wlkList rdConDecl tcons `thenUgn` \ cons ->
548 wlkDerivings tderivs `thenUgn` \ derivings ->
549 returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc))
551 -- "newtype" declaration
552 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
553 mkSrcLocUgn srcline $ \ src_loc ->
554 wlkContext ntctxt `thenUgn` \ ctxt ->
555 wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
556 wlkList rdConDecl ntcon `thenUgn` \ [con] ->
557 wlkDerivings ntderivs `thenUgn` \ derivings ->
558 returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
560 -- "type" declaration
561 U_nbind nbindid nbindas srcline ->
562 mkSrcLocUgn srcline $ \ src_loc ->
563 wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
564 wlkMonoType nbindas `thenUgn` \ expansion ->
565 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
568 U_fbind fbindl srcline ->
569 mkSrcLocUgn srcline $ \ src_loc ->
570 wlkList rdMatch fbindl `thenUgn` \ matches ->
571 returnUgn (RdrFunctionBinding srcline matches)
574 U_pbind pbindl srcline ->
575 mkSrcLocUgn srcline $ \ src_loc ->
576 wlkList rdMatch pbindl `thenUgn` \ matches ->
577 returnUgn (RdrPatternBinding srcline matches)
579 -- "class" declaration
580 U_cbind cbindc cbindid cbindw srcline ->
581 mkSrcLocUgn srcline $ \ src_loc ->
582 wlkContext cbindc `thenUgn` \ ctxt ->
583 wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
584 wlkBinding cbindw `thenUgn` \ binding ->
585 getSrcFileUgn `thenUgn` \ sf ->
587 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
589 returnUgn (RdrClassDecl
590 (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
592 -- "instance" declaration
593 U_ibind ibindc iclas ibindi ibindw srcline ->
594 mkSrcLocUgn srcline $ \ src_loc ->
595 wlkContext ibindc `thenUgn` \ ctxt ->
596 wlkTCId iclas `thenUgn` \ clas ->
597 wlkMonoType ibindi `thenUgn` \ at_ty ->
598 wlkBinding ibindw `thenUgn` \ binding ->
599 getSrcModUgn `thenUgn` \ modname ->
600 getSrcFileUgn `thenUgn` \ sf ->
602 (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
603 inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
605 returnUgn (RdrInstDecl
606 (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
608 -- "default" declaration
609 U_dbind dbindts srcline ->
610 mkSrcLocUgn srcline $ \ src_loc ->
611 wlkList rdMonoType dbindts `thenUgn` \ tys ->
612 returnUgn (RdrDefaultDecl (DefaultDecl tys 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 (RdrTySig vars poly_ty src_loc)
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 (RdrSpecValSig [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 wlkTCId iclas `thenUgn` \ clas ->
656 wlkMonoType ispec_ty `thenUgn` \ ty ->
657 returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
659 -- data specialisation user-pragma
660 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
661 = mkSrcLocUgn srcline $ \ src_loc ->
662 wlkTCId itycon `thenUgn` \ tycon ->
663 wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
664 returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
666 -- value inlining user-pragma
667 wlk_sig_thing (U_inline_uprag ivar srcline)
668 = mkSrcLocUgn srcline $ \ src_loc ->
669 wlkVarId ivar `thenUgn` \ var ->
670 returnUgn (RdrInlineValSig (InlineSig var src_loc))
672 -- "deforest me" user-pragma
673 wlk_sig_thing (U_deforest_uprag ivar srcline)
674 = mkSrcLocUgn srcline $ \ src_loc ->
675 wlkVarId ivar `thenUgn` \ var ->
676 returnUgn (RdrDeforestSig (DeforestSig var src_loc))
678 -- "magic" unfolding user-pragma
679 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
680 = mkSrcLocUgn srcline $ \ src_loc ->
681 wlkVarId ivar `thenUgn` \ var ->
682 returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
685 %************************************************************************
687 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
689 %************************************************************************
692 rdHsType :: ParseTree -> UgnM RdrNameHsType
693 rdMonoType :: ParseTree -> UgnM RdrNameHsType
695 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
696 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
698 wlkHsType :: U_ttype -> UgnM RdrNameHsType
699 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
703 U_context tcontextl tcontextt -> -- context
704 wlkContext tcontextl `thenUgn` \ ctxt ->
705 wlkMonoType tcontextt `thenUgn` \ ty ->
706 returnUgn (HsPreForAllTy ctxt ty)
708 other -> -- something else
709 wlkMonoType other `thenUgn` \ ty ->
710 returnUgn (HsPreForAllTy [{-no context-}] ty)
714 U_namedtvar tv -> -- type variable
715 wlkTvId tv `thenUgn` \ tyvar ->
716 returnUgn (MonoTyVar tyvar)
718 U_tname tcon -> -- type constructor
719 wlkTCId tcon `thenUgn` \ tycon ->
720 returnUgn (MonoTyApp tycon [])
723 wlkMonoType t2 `thenUgn` \ ty2 ->
724 collect t1 [ty2] `thenUgn` \ (tycon, tys) ->
725 returnUgn (MonoTyApp tycon tys)
729 U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
731 U_tname tcon -> wlkTCId tcon `thenUgn` \ tycon ->
732 returnUgn (tycon, acc)
733 U_namedtvar tv -> wlkTvId tv `thenUgn` \ tyvar ->
734 returnUgn (tyvar, acc)
735 U_tllist _ -> panic "tlist"
736 U_ttuple _ -> panic "ttuple"
737 U_tfun _ _ -> panic "tfun"
738 U_tbang _ -> panic "tbang"
739 U_context _ _ -> panic "context"
740 _ -> panic "something else"
742 U_tllist tlist -> -- list type
743 wlkMonoType tlist `thenUgn` \ ty ->
744 returnUgn (MonoListTy dummyRdrTcName ty)
747 wlkList rdMonoType ttuple `thenUgn` \ tys ->
748 returnUgn (MonoTupleTy dummyRdrTcName tys)
751 wlkMonoType tfun `thenUgn` \ ty1 ->
752 wlkMonoType targ `thenUgn` \ ty2 ->
753 returnUgn (MonoFunTy ty1 ty2)
758 wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
759 wlkContext :: U_list -> UgnM RdrNameContext
760 wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
762 wlkTyConAndTyVars ttype
763 = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
765 args = [ UserTyVar a | (MonoTyVar a) <- ty_args ]
767 returnUgn (tycon, args)
770 = wlkList rdMonoType list `thenUgn` \ tys ->
771 returnUgn (map mk_class_assertion tys)
774 = wlkMonoType xs `thenUgn` \ mono_ty ->
775 returnUgn (case mk_class_assertion mono_ty of
776 (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
779 mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
781 mk_class_assertion (MonoTyApp name [ty@(MonoTyVar tyname)]) = (name, ty)
782 mk_class_assertion other
783 = pprError "ERROR: malformed type context: " (ppr PprForUser other)
784 -- regrettably, the parser does let some junk past
785 -- e.g., f :: Num {-nothing-} => a -> ...
789 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
791 = rdU_constr pt `thenUgn` \ blah ->
794 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
796 wlkConDecl (U_constrpre ccon ctys srcline)
797 = mkSrcLocUgn srcline $ \ src_loc ->
798 wlkDataId ccon `thenUgn` \ con ->
799 wlkList rdBangType ctys `thenUgn` \ tys ->
800 returnUgn (ConDecl con tys src_loc)
802 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
803 = mkSrcLocUgn srcline $ \ src_loc ->
804 wlkBangType cty1 `thenUgn` \ ty1 ->
805 wlkDataId cop `thenUgn` \ op ->
806 wlkBangType cty2 `thenUgn` \ ty2 ->
807 returnUgn (ConOpDecl ty1 op ty2 src_loc)
809 wlkConDecl (U_constrnew ccon cty srcline)
810 = mkSrcLocUgn srcline $ \ src_loc ->
811 wlkDataId ccon `thenUgn` \ con ->
812 wlkMonoType cty `thenUgn` \ ty ->
813 returnUgn (NewConDecl con ty src_loc)
815 wlkConDecl (U_constrrec ccon cfields srcline)
816 = mkSrcLocUgn srcline $ \ src_loc ->
817 wlkDataId ccon `thenUgn` \ con ->
818 wlkList rd_field cfields `thenUgn` \ fields_lists ->
819 returnUgn (RecConDecl con fields_lists src_loc)
821 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
823 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
824 wlkList rdVarId fvars `thenUgn` \ vars ->
825 wlkBangType fty `thenUgn` \ ty ->
829 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
831 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
833 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
834 returnUgn (Banged ty)
835 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
836 returnUgn (Unbanged ty)
839 %************************************************************************
841 \subsection{Read a ``match''}
843 %************************************************************************
846 rdMatch :: ParseTree -> UgnM RdrMatch
849 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
850 mkSrcLocUgn srcline $ \ src_loc ->
851 wlkPat gpat `thenUgn` \ pat ->
852 wlkBinding gbind `thenUgn` \ binding ->
853 wlkVarId gsrcfun `thenUgn` \ srcfun ->
855 wlk_guards (U_pnoguards exp)
856 = wlkExpr exp `thenUgn` \ expr ->
857 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
859 wlk_guards (U_pguards gs)
860 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
861 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
866 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
867 wlkExpr g `thenUgn` \ guard ->
868 wlkExpr e `thenUgn` \ expr ->
869 returnUgn (guard, expr)
872 %************************************************************************
874 \subsection[rdFixOp]{Read in a fixity declaration}
876 %************************************************************************
879 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
881 = rdU_tree pt `thenUgn` \ fix ->
883 U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
884 returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
891 _ -> error "ReadPrefix:rdFixOp"
894 %************************************************************************
896 \subsection[rdImport]{Read an import decl}
898 %************************************************************************
901 rdImport :: ParseTree
902 -> UgnM RdrNameImportDecl
905 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) ->
906 mkSrcLocUgn srcline $ \ src_loc ->
907 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
908 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
909 returnUgn (ImportDecl imod (cvFlag iqual) maybe_as maybe_spec src_loc)
911 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
913 U_left pt -> rdEntities pt `thenUgn` \ ents ->
914 returnUgn (False, ents)
915 U_right pt -> rdEntities pt `thenUgn` \ ents ->
916 returnUgn (True, ents)
921 = rdU_list pt `thenUgn` \ list ->
922 wlkList rdEntity list
924 rdEntity :: ParseTree -> UgnM (IE RdrName)
927 = rdU_entidt pt `thenUgn` \ entity ->
929 U_entid evar -> -- just a value
930 wlkEntId evar `thenUgn` \ var ->
931 returnUgn (IEVar var)
933 U_enttype x -> -- abstract type constructor/class
934 wlkTCId x `thenUgn` \ thing ->
935 returnUgn (IEThingAbs thing)
937 U_enttypeall x -> -- non-abstract type constructor/class
938 wlkTCId x `thenUgn` \ thing ->
939 returnUgn (IEThingAll thing)
941 U_enttypenamed x ns -> -- non-abstract type constructor/class
942 -- with specified constrs/methods
943 wlkTCId x `thenUgn` \ thing ->
944 wlkList rdVarId ns `thenUgn` \ names ->
945 returnUgn (IEThingWith thing names)
947 U_entmod mod -> -- everything provided unqualified by a module
948 returnUgn (IEModuleContents mod)