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 #if __GLASGOW_HASKELL__ == 201
15 #elif __GLASGOW_HASKELL__ >= 202
21 import UgenAll -- all Yacc parser gumpff...
22 import PrefixSyn -- and various syntaxen.
24 import HsTypes ( HsTyVar(..) )
25 import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
29 import ErrUtils ( addErrLoc, ghcExit )
30 import FiniteMap ( elemFM, FiniteMap )
31 import Name ( OccName(..), SYN_IE(Module) )
32 import Lex ( isLexConId )
33 import PprStyle ( PprStyle(..) )
36 import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
37 import Util ( nOfThem, pprError, panic )
39 #if __GLASGOW_HASKELL__ >= 202
40 import Outputable ( Outputable(..) )
45 %************************************************************************
47 \subsection[ReadPrefix-help]{Help Functions}
49 %************************************************************************
52 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
54 wlkList wlk_it U_lnil = returnUgn []
56 wlkList wlk_it (U_lcons hd tl)
57 = wlk_it hd `thenUgn` \ hd_it ->
58 wlkList wlk_it tl `thenUgn` \ tl_it ->
59 returnUgn (hd_it : tl_it)
63 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
65 wlkMaybe wlk_it U_nothing = returnUgn Nothing
66 wlkMaybe wlk_it (U_just x)
67 = wlk_it x `thenUgn` \ it ->
72 wlkTvId = wlkQid TvOcc
73 wlkTCId = wlkQid TCOcc
74 wlkVarId = wlkQid VarOcc
75 wlkDataId = wlkQid VarOcc
76 wlkEntId = wlkQid (\occ -> if isLexConId occ
80 wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
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))
86 -- I don't understand this one! It is what shows up when we meet (), [], or (,,,).
87 wlkQid mk_occ_name (U_gid n name)
88 = returnUgn (Unqual (mk_occ_name name))
90 rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
91 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
93 cvFlag :: U_long -> Bool
98 %************************************************************************
100 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
102 %************************************************************************
105 #if __GLASGOW_HASKELL__ == 201
106 # define PACK_STR packCString
107 #elif __GLASGOW_HASKELL__ >= 202
108 # define PACK_STR mkFastCharString
110 # define PACK_STR mkFastCharString
113 rdModule :: IO (Module, -- this module's name
114 RdrNameHsModule) -- the main goods
117 = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser!
119 srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
122 rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
123 hmodlist srciface_version srcline) ->
125 setSrcFileUgn srcfile $
126 setSrcModUgn modname $
127 mkSrcLocUgn srcline $ \ src_loc ->
129 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
130 wlkList rdImport himplist `thenUgn` \ imports ->
131 wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
132 wlkBinding hmodlist `thenUgn` \ binding ->
135 val_decl = ValD (cvBinds srcfile cvValSig binding)
136 other_decls = cvOtherDecls binding
140 (case srciface_version of { 0 -> Nothing; n -> Just n })
144 (val_decl: other_decls)
149 %************************************************************************
151 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
153 %************************************************************************
156 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
157 rdPat :: ParseTree -> UgnM RdrNamePat
159 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
160 rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
162 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
163 wlkPat :: U_tree -> UgnM RdrNamePat
167 U_par pexpr -> -- parenthesised expr
168 wlkExpr pexpr `thenUgn` \ expr ->
169 returnUgn (HsPar expr)
171 U_lsection lsexp lop -> -- left section
172 wlkExpr lsexp `thenUgn` \ expr ->
173 wlkVarId lop `thenUgn` \ op ->
174 returnUgn (SectionL expr (HsVar op))
176 U_rsection rop rsexp -> -- right section
177 wlkVarId rop `thenUgn` \ op ->
178 wlkExpr rsexp `thenUgn` \ expr ->
179 returnUgn (SectionR (HsVar op) expr)
181 U_ccall fun flavor ccargs -> -- ccall/casm
182 wlkList rdExpr ccargs `thenUgn` \ args ->
186 returnUgn (CCall fun args
187 (tag == 'p' || tag == 'P') -- may invoke GC
188 (tag == 'N' || tag == 'P') -- really a "casm"
189 (panic "CCall:result_ty"))
191 U_scc label sccexp -> -- scc (set-cost-centre) expression
192 wlkExpr sccexp `thenUgn` \ expr ->
193 returnUgn (HsSCC label expr)
195 U_lambda lampats lamexpr srcline -> -- lambda expression
196 mkSrcLocUgn srcline $ \ src_loc ->
197 wlkList rdPat lampats `thenUgn` \ pats ->
198 wlkExpr lamexpr `thenUgn` \ body ->
200 HsLam (foldr PatMatch
201 (GRHSMatch (GRHSsAndBindsIn
202 [OtherwiseGRHS body src_loc]
207 U_casee caseexpr casebody srcline -> -- case expression
208 mkSrcLocUgn srcline $ \ src_loc ->
209 wlkExpr caseexpr `thenUgn` \ expr ->
210 wlkList rdMatch casebody `thenUgn` \ mats ->
211 getSrcFileUgn `thenUgn` \ sf ->
213 matches = cvMatches sf True mats
215 returnUgn (HsCase expr matches src_loc)
217 U_ife ifpred ifthen ifelse srcline -> -- if expression
218 mkSrcLocUgn srcline $ \ src_loc ->
219 wlkExpr ifpred `thenUgn` \ e1 ->
220 wlkExpr ifthen `thenUgn` \ e2 ->
221 wlkExpr ifelse `thenUgn` \ e3 ->
222 returnUgn (HsIf e1 e2 e3 src_loc)
224 U_let letvdefs letvexpr -> -- let expression
225 wlkBinding letvdefs `thenUgn` \ binding ->
226 wlkExpr letvexpr `thenUgn` \ expr ->
227 getSrcFileUgn `thenUgn` \ sf ->
229 binds = cvBinds sf cvValSig binding
231 returnUgn (HsLet binds expr)
233 U_doe gdo srcline -> -- do expression
234 mkSrcLocUgn srcline $ \ src_loc ->
235 wlkList rd_stmt gdo `thenUgn` \ stmts ->
236 returnUgn (HsDo DoStmt stmts src_loc)
239 = rdU_tree pt `thenUgn` \ bind ->
241 U_doexp exp srcline ->
242 mkSrcLocUgn srcline $ \ src_loc ->
243 wlkExpr exp `thenUgn` \ expr ->
244 returnUgn (ExprStmt expr src_loc)
246 U_dobind pat exp srcline ->
247 mkSrcLocUgn srcline $ \ src_loc ->
248 wlkPat pat `thenUgn` \ patt ->
249 wlkExpr exp `thenUgn` \ expr ->
250 returnUgn (BindStmt patt expr src_loc)
253 wlkBinding seqlet `thenUgn` \ bs ->
254 getSrcFileUgn `thenUgn` \ sf ->
256 binds = cvBinds sf cvValSig bs
258 returnUgn (LetStmt binds)
260 U_comprh cexp cquals -> -- list comprehension
261 wlkExpr cexp `thenUgn` \ expr ->
262 wlkQuals cquals `thenUgn` \ quals ->
263 getSrcLocUgn `thenUgn` \ loc ->
264 returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
266 U_eenum efrom estep eto -> -- arithmetic sequence
267 wlkExpr efrom `thenUgn` \ e1 ->
268 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
269 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
270 returnUgn (cv_arith_seq e1 es2 es3)
272 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
273 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
274 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
275 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
277 U_restr restre restrt -> -- expression with type signature
278 wlkExpr restre `thenUgn` \ expr ->
279 wlkHsType restrt `thenUgn` \ ty ->
280 returnUgn (ExprWithTySig expr ty)
282 --------------------------------------------------------------
283 -- now the prefix items that can either be an expression or
284 -- pattern, except we know they are *expressions* here
285 -- (this code could be commoned up with the pattern version;
286 -- but it probably isn't worth it)
287 --------------------------------------------------------------
289 wlkLiteral lit `thenUgn` \ lit ->
290 returnUgn (HsLit lit)
292 U_ident n -> -- simple identifier
293 wlkVarId n `thenUgn` \ var ->
294 returnUgn (HsVar var)
296 U_ap fun arg -> -- application
297 wlkExpr fun `thenUgn` \ expr1 ->
298 wlkExpr arg `thenUgn` \ expr2 ->
299 returnUgn (HsApp expr1 expr2)
301 U_infixap fun arg1 arg2 -> -- infix application
302 wlkVarId fun `thenUgn` \ op ->
303 wlkExpr arg1 `thenUgn` \ expr1 ->
304 wlkExpr arg2 `thenUgn` \ expr2 ->
305 returnUgn (mkOpApp expr1 op expr2)
307 U_negate nexp -> -- prefix negation
308 wlkExpr nexp `thenUgn` \ expr ->
309 returnUgn (NegApp expr (HsVar dummyRdrVarName))
311 U_llist llist -> -- explicit list
312 wlkList rdExpr llist `thenUgn` \ exprs ->
313 returnUgn (ExplicitList exprs)
315 U_tuple tuplelist -> -- explicit tuple
316 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
317 returnUgn (ExplicitTuple exprs)
319 U_record con rbinds -> -- record construction
320 wlkDataId con `thenUgn` \ rcon ->
321 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
322 returnUgn (RecordCon (HsVar rcon) recbinds)
324 U_rupdate updexp updbinds -> -- record update
325 wlkExpr updexp `thenUgn` \ aexp ->
326 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
327 returnUgn (RecordUpd aexp recbinds)
330 U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
331 U_as _ _ -> error "U_as"
332 U_lazyp _ -> error "U_lazyp"
333 U_wildp -> error "U_wildp"
334 U_qual _ _ -> error "U_qual"
335 U_guard _ -> error "U_guard"
336 U_seqlet _ -> error "U_seqlet"
337 U_dobind _ _ _ -> error "U_dobind"
338 U_doexp _ _ -> error "U_doexp"
339 U_rbind _ _ -> error "U_rbind"
340 U_fixop _ _ _ -> error "U_fixop"
344 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
345 wlkVarId var `thenUgn` \ rvar ->
346 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
349 Nothing -> (rvar, HsVar rvar, True{-pun-})
350 Just re -> (rvar, re, False)
354 = wlkList rd_qual cquals
357 = rdU_tree pt `thenUgn` \ qual ->
363 wlkExpr exp `thenUgn` \ expr ->
364 getSrcLocUgn `thenUgn` \ loc ->
365 returnUgn (GuardStmt expr loc)
368 wlkPat qpat `thenUgn` \ pat ->
369 wlkExpr qexp `thenUgn` \ expr ->
370 getSrcLocUgn `thenUgn` \ loc ->
371 returnUgn (BindStmt pat expr loc)
374 wlkBinding seqlet `thenUgn` \ bs ->
375 getSrcFileUgn `thenUgn` \ sf ->
377 binds = cvBinds sf cvValSig bs
379 returnUgn (LetStmt binds)
382 Patterns: just bear in mind that lists of patterns are represented as
383 a series of ``applications''.
387 U_par ppat -> -- parenthesised pattern
388 wlkPat ppat `thenUgn` \ pat ->
389 -- tidy things up a little:
394 other -> ParPatIn pat
397 U_as avar as_pat -> -- "as" pattern
398 wlkVarId avar `thenUgn` \ var ->
399 wlkPat as_pat `thenUgn` \ pat ->
400 returnUgn (AsPatIn var pat)
402 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
403 wlkPat lazyp `thenUgn` \ pat ->
404 returnUgn (LazyPatIn pat)
407 wlkVarId avar `thenUgn` \ var ->
408 wlkLiteral lit `thenUgn` \ lit ->
409 returnUgn (NPlusKPatIn var lit)
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 -> hsep (map (ppr sty) (lpat:lpats)))
436 msg = show (err PprForUser)
438 #if __GLASGOW_HASKELL__ == 201
439 ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
440 ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
441 #elif __GLASGOW_HASKELL__ >= 202
442 ioToUgnM (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
443 ioToUgnM (IOBase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
445 ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
446 ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
448 returnUgn (error "ReadPrefix")
450 ) `thenUgn` \ (n, arg_pats) ->
451 returnUgn (ConPatIn n arg_pats)
456 wlkPat r `thenUgn` \ rpat ->
457 collect_pats l (rpat:acc)
459 wlkPat other `thenUgn` \ pat ->
462 U_infixap fun arg1 arg2 -> -- infix pattern
463 wlkVarId fun `thenUgn` \ op ->
464 wlkPat arg1 `thenUgn` \ pat1 ->
465 wlkPat arg2 `thenUgn` \ pat2 ->
466 returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
468 U_negate npat -> -- negated pattern
469 wlkPat npat `thenUgn` \ pat ->
470 returnUgn (NegPatIn pat)
472 U_llist llist -> -- explicit list
473 wlkList rdPat llist `thenUgn` \ pats ->
474 returnUgn (ListPatIn pats)
476 U_tuple tuplelist -> -- explicit tuple
477 wlkList rdPat tuplelist `thenUgn` \ pats ->
478 returnUgn (TuplePatIn pats)
480 U_record con rpats -> -- record destruction
481 wlkDataId con `thenUgn` \ rcon ->
482 wlkList rdRpat rpats `thenUgn` \ recpats ->
483 returnUgn (RecPatIn rcon recpats)
486 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
487 wlkVarId var `thenUgn` \ rvar ->
488 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
491 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
492 Just rp -> (rvar, rp, False)
497 wlkLiteral :: U_literal -> UgnM HsLit
502 U_integer s -> HsInt (as_integer s)
503 U_floatr s -> HsFrac (as_rational s)
504 U_intprim s -> HsIntPrim (as_integer s)
505 U_doubleprim s -> HsDoublePrim (as_rational s)
506 U_floatprim s -> HsFloatPrim (as_rational s)
507 U_charr s -> HsChar (as_char s)
508 U_charprim s -> HsCharPrim (as_char s)
509 U_string s -> HsString (as_string s)
510 U_stringprim s -> HsStringPrim (as_string s)
511 U_clitlit s -> HsLitLit (as_string s)
515 as_integer s = readInteger (_UNPK_ s)
516 #if __GLASGOW_HASKELL__ == 201
517 as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
518 #elif __GLASGOW_HASKELL__ >= 202
519 as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a } -- ToDo, use non-std readRational__
521 as_rational s = _readRational (_UNPK_ s) -- non-std
526 %************************************************************************
528 \subsection{wlkBinding}
530 %************************************************************************
533 wlkBinding :: U_binding -> UgnM RdrBinding
539 returnUgn RdrNullBind
541 -- "and" binding (just glue, really)
543 wlkBinding a `thenUgn` \ binding1 ->
544 wlkBinding b `thenUgn` \ binding2 ->
545 returnUgn (RdrAndBindings binding1 binding2)
547 -- "data" declaration
548 U_tbind tctxt ttype tcons tderivs srcline ->
549 mkSrcLocUgn srcline $ \ src_loc ->
550 wlkContext tctxt `thenUgn` \ ctxt ->
551 wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
552 wlkList rdConDecl tcons `thenUgn` \ cons ->
553 wlkDerivings tderivs `thenUgn` \ derivings ->
554 returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
556 -- "newtype" declaration
557 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
558 mkSrcLocUgn srcline $ \ src_loc ->
559 wlkContext ntctxt `thenUgn` \ ctxt ->
560 wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
561 wlkList rdConDecl ntcon `thenUgn` \ cons ->
562 wlkDerivings ntderivs `thenUgn` \ derivings ->
563 returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
565 -- "type" declaration
566 U_nbind nbindid nbindas srcline ->
567 mkSrcLocUgn srcline $ \ src_loc ->
568 wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
569 wlkMonoType nbindas `thenUgn` \ expansion ->
570 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
573 U_fbind fbindl srcline ->
574 mkSrcLocUgn srcline $ \ src_loc ->
575 wlkList rdMatch fbindl `thenUgn` \ matches ->
576 returnUgn (RdrFunctionBinding srcline matches)
579 U_pbind pbindl srcline ->
580 mkSrcLocUgn srcline $ \ src_loc ->
581 wlkList rdMatch pbindl `thenUgn` \ matches ->
582 returnUgn (RdrPatternBinding srcline matches)
584 -- "class" declaration
585 U_cbind cbindc cbindid cbindw srcline ->
586 mkSrcLocUgn srcline $ \ src_loc ->
587 wlkContext cbindc `thenUgn` \ ctxt ->
588 wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
589 wlkBinding cbindw `thenUgn` \ binding ->
590 getSrcFileUgn `thenUgn` \ sf ->
592 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
594 returnUgn (RdrClassDecl
595 (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
597 -- "instance" declaration
598 U_ibind ibindc iclas ibindi ibindw srcline ->
599 mkSrcLocUgn srcline $ \ src_loc ->
600 wlkContext ibindc `thenUgn` \ ctxt ->
601 wlkTCId iclas `thenUgn` \ clas ->
602 wlkMonoType ibindi `thenUgn` \ at_ty ->
603 wlkBinding ibindw `thenUgn` \ binding ->
604 getSrcModUgn `thenUgn` \ modname ->
605 getSrcFileUgn `thenUgn` \ sf ->
607 (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
608 inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
610 returnUgn (RdrInstDecl
611 (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
613 -- "default" declaration
614 U_dbind dbindts srcline ->
615 mkSrcLocUgn srcline $ \ src_loc ->
616 wlkList rdMonoType dbindts `thenUgn` \ tys ->
617 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
620 -- signature(-like) things, including user pragmas
621 wlk_sig_thing a_sig_we_hope
625 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
627 wlkDerivings (U_nothing) = returnUgn Nothing
628 wlkDerivings (U_just pt)
629 = rdU_list pt `thenUgn` \ ds ->
630 wlkList rdTCId ds `thenUgn` \ derivs ->
631 returnUgn (Just derivs)
636 wlk_sig_thing (U_sbind sbindids sbindid srcline)
637 = mkSrcLocUgn srcline $ \ src_loc ->
638 wlkList rdVarId sbindids `thenUgn` \ vars ->
639 wlkHsType sbindid `thenUgn` \ poly_ty ->
640 returnUgn (RdrTySig vars poly_ty src_loc)
642 -- value specialisation user-pragma
643 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
644 = mkSrcLocUgn srcline $ \ src_loc ->
645 wlkVarId uvar `thenUgn` \ var ->
646 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
647 returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
648 | (ty, using_id) <- tys_and_ids ])
650 rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
652 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
653 wlkHsType vspec_ty `thenUgn` \ ty ->
654 wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
655 returnUgn(ty, id_maybe)
657 -- instance specialisation user-pragma
658 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
659 = mkSrcLocUgn srcline $ \ src_loc ->
660 wlkTCId iclas `thenUgn` \ clas ->
661 wlkMonoType ispec_ty `thenUgn` \ ty ->
662 returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
664 -- data specialisation user-pragma
665 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
666 = mkSrcLocUgn srcline $ \ src_loc ->
667 wlkTCId itycon `thenUgn` \ tycon ->
668 wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
669 returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
671 -- value inlining user-pragma
672 wlk_sig_thing (U_inline_uprag ivar srcline)
673 = mkSrcLocUgn srcline $ \ src_loc ->
674 wlkVarId ivar `thenUgn` \ var ->
675 returnUgn (RdrInlineValSig (InlineSig var src_loc))
677 -- "deforest me" user-pragma
678 wlk_sig_thing (U_deforest_uprag ivar srcline)
679 = mkSrcLocUgn srcline $ \ src_loc ->
680 wlkVarId ivar `thenUgn` \ var ->
681 returnUgn (RdrDeforestSig (DeforestSig var src_loc))
683 -- "magic" unfolding user-pragma
684 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
685 = mkSrcLocUgn srcline $ \ src_loc ->
686 wlkVarId ivar `thenUgn` \ var ->
687 returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
690 %************************************************************************
692 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
694 %************************************************************************
697 rdHsType :: ParseTree -> UgnM RdrNameHsType
698 rdMonoType :: ParseTree -> UgnM RdrNameHsType
700 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
701 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
703 wlkHsType :: U_ttype -> UgnM RdrNameHsType
704 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
708 U_context tcontextl tcontextt -> -- context
709 wlkContext tcontextl `thenUgn` \ ctxt ->
710 wlkMonoType tcontextt `thenUgn` \ ty ->
711 returnUgn (HsPreForAllTy ctxt ty)
713 other -> -- something else
714 wlkMonoType other `thenUgn` \ ty ->
715 returnUgn (HsPreForAllTy [{-no context-}] ty)
719 -- Glasgow extension: nested polymorhism
720 U_context tcontextl tcontextt -> -- context
721 wlkContext tcontextl `thenUgn` \ ctxt ->
722 wlkMonoType tcontextt `thenUgn` \ ty ->
723 returnUgn (HsPreForAllTy ctxt ty)
725 U_namedtvar tv -> -- type variable
726 wlkTvId tv `thenUgn` \ tyvar ->
727 returnUgn (MonoTyVar tyvar)
729 U_tname tcon -> -- type constructor
730 wlkTCId tcon `thenUgn` \ tycon ->
731 returnUgn (MonoTyVar tycon)
734 wlkMonoType t1 `thenUgn` \ ty1 ->
735 wlkMonoType t2 `thenUgn` \ ty2 ->
736 returnUgn (MonoTyApp ty1 ty2)
738 U_tllist tlist -> -- list type
739 wlkMonoType tlist `thenUgn` \ ty ->
740 returnUgn (MonoListTy dummyRdrTcName ty)
743 wlkList rdMonoType ttuple `thenUgn` \ tys ->
744 returnUgn (MonoTupleTy dummyRdrTcName tys)
747 wlkMonoType tfun `thenUgn` \ ty1 ->
748 wlkMonoType targ `thenUgn` \ ty2 ->
749 returnUgn (MonoFunTy ty1 ty2)
754 wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
755 wlkContext :: U_list -> UgnM RdrNameContext
756 wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
758 wlkTyConAndTyVars ttype
759 = wlkMonoType ttype `thenUgn` \ ty ->
761 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
762 split (MonoTyVar tycon) args = (tycon,args)
764 returnUgn (split ty [])
767 = wlkList rdMonoType list `thenUgn` \ tys ->
768 returnUgn (map mk_class_assertion tys)
771 = wlkMonoType xs `thenUgn` \ mono_ty ->
772 returnUgn (case mk_class_assertion mono_ty of
773 (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
776 mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
778 mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
779 mk_class_assertion other
780 = pprError "ERROR: malformed type context: " (ppr PprForUser other)
781 -- regrettably, the parser does let some junk past
782 -- e.g., f :: Num {-nothing-} => a -> ...
786 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
788 = rdU_constr pt `thenUgn` \ blah ->
791 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
793 wlkConDecl (U_constrcxt ccxt ccdecl)
794 = wlkContext ccxt `thenUgn` \ theta ->
795 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
796 returnUgn (ConDecl con theta details loc)
798 wlkConDecl (U_constrpre ccon ctys srcline)
799 = mkSrcLocUgn srcline $ \ src_loc ->
800 wlkDataId ccon `thenUgn` \ con ->
801 wlkList rdBangType ctys `thenUgn` \ tys ->
802 returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
804 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
805 = mkSrcLocUgn srcline $ \ src_loc ->
806 wlkBangType cty1 `thenUgn` \ ty1 ->
807 wlkDataId cop `thenUgn` \ op ->
808 wlkBangType cty2 `thenUgn` \ ty2 ->
809 returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
811 wlkConDecl (U_constrnew ccon cty srcline)
812 = mkSrcLocUgn srcline $ \ src_loc ->
813 wlkDataId ccon `thenUgn` \ con ->
814 wlkMonoType cty `thenUgn` \ ty ->
815 returnUgn (ConDecl con [] (NewCon ty) src_loc)
817 wlkConDecl (U_constrrec ccon cfields srcline)
818 = mkSrcLocUgn srcline $ \ src_loc ->
819 wlkDataId ccon `thenUgn` \ con ->
820 wlkList rd_field cfields `thenUgn` \ fields_lists ->
821 returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
823 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
825 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
826 wlkList rdVarId fvars `thenUgn` \ vars ->
827 wlkBangType fty `thenUgn` \ ty ->
831 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
833 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
835 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
836 returnUgn (Banged ty)
837 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
838 returnUgn (Unbanged ty)
841 %************************************************************************
843 \subsection{Read a ``match''}
845 %************************************************************************
848 rdMatch :: ParseTree -> UgnM RdrMatch
851 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
852 mkSrcLocUgn srcline $ \ src_loc ->
853 wlkPat gpat `thenUgn` \ pat ->
854 wlkBinding gbind `thenUgn` \ binding ->
855 wlkVarId gsrcfun `thenUgn` \ srcfun ->
857 wlk_guards (U_pnoguards exp)
858 = wlkExpr exp `thenUgn` \ expr ->
859 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
861 wlk_guards (U_pguards gs)
862 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
863 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
868 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
869 wlkQuals g `thenUgn` \ guard ->
870 wlkExpr e `thenUgn` \ expr ->
871 returnUgn (guard, expr)
874 %************************************************************************
876 \subsection[rdFixOp]{Read in a fixity declaration}
878 %************************************************************************
881 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
883 = rdU_tree pt `thenUgn` \ fix ->
885 U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
886 returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
893 _ -> error "ReadPrefix:rdFixOp"
896 %************************************************************************
898 \subsection[rdImport]{Read an import decl}
900 %************************************************************************
903 rdImport :: ParseTree
904 -> UgnM RdrNameImportDecl
907 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) ->
908 mkSrcLocUgn srcline $ \ src_loc ->
909 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
910 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
911 returnUgn (ImportDecl imod (cvFlag iqual) maybe_as maybe_spec src_loc)
913 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
915 U_left pt -> rdEntities pt `thenUgn` \ ents ->
916 returnUgn (False, ents)
917 U_right pt -> rdEntities pt `thenUgn` \ ents ->
918 returnUgn (True, ents)
923 = rdU_list pt `thenUgn` \ list ->
924 wlkList rdEntity list
926 rdEntity :: ParseTree -> UgnM (IE RdrName)
929 = rdU_entidt pt `thenUgn` \ entity ->
931 U_entid evar -> -- just a value
932 wlkEntId evar `thenUgn` \ var ->
933 returnUgn (IEVar var)
935 U_enttype x -> -- abstract type constructor/class
936 wlkTCId x `thenUgn` \ thing ->
937 returnUgn (IEThingAbs thing)
939 U_enttypeall x -> -- non-abstract type constructor/class
940 wlkTCId x `thenUgn` \ thing ->
941 returnUgn (IEThingAll thing)
943 U_enttypenamed x ns -> -- non-abstract type constructor/class
944 -- with specified constrs/methods
945 wlkTCId x `thenUgn` \ thing ->
946 wlkList rdVarId ns `thenUgn` \ names ->
947 returnUgn (IEThingWith thing names)
949 U_entmod mod -> -- everything provided unqualified by a module
950 returnUgn (IEModuleContents mod)