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 )
27 import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
30 import CmdLineOpts ( opt_PprUserLength )
31 import ErrUtils ( addErrLoc, ghcExit )
32 import FiniteMap ( elemFM, FiniteMap )
33 import Name ( OccName(..), SYN_IE(Module) )
34 import Lex ( isLexConId )
35 import Outputable ( Outputable(..), PprStyle(..) )
36 import PrelMods ( pRELUDE )
38 import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
39 import Util ( nOfThem, pprError, panic )
42 %************************************************************************
44 \subsection[ReadPrefix-help]{Help Functions}
46 %************************************************************************
49 wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
51 wlkList wlk_it U_lnil = returnUgn []
53 wlkList wlk_it (U_lcons hd tl)
54 = wlk_it hd `thenUgn` \ hd_it ->
55 wlkList wlk_it tl `thenUgn` \ tl_it ->
56 returnUgn (hd_it : tl_it)
60 wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
62 wlkMaybe wlk_it U_nothing = returnUgn Nothing
63 wlkMaybe wlk_it (U_just x)
64 = wlk_it x `thenUgn` \ it ->
69 wlkTvId = wlkQid TvOcc
70 wlkTCId = wlkQid TCOcc
71 wlkVarId = wlkQid VarOcc
72 wlkDataId = wlkQid VarOcc
73 wlkEntId = wlkQid (\occ -> if isLexConId occ
77 wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
79 -- There are three kinds of qid:
80 -- qualified name (noqual) A.x
81 -- unqualified name (aqual) x
82 -- special name (gid) [], (), ->, (,,,)
83 -- The special names always mean "Prelude.whatever"; that's why
84 -- they are distinct. So if you write "()", it's just as if you
85 -- had written "Prelude.()". NB: The (qualified) prelude is always in scope,
86 -- so the renamer will find it.
88 wlkQid mk_occ_name (U_noqual name)
89 = returnUgn (Unqual (mk_occ_name name))
90 wlkQid mk_occ_name (U_aqual mod name)
91 = returnUgn (Qual mod (mk_occ_name name) HiFile)
92 wlkQid mk_occ_name (U_gid n name)
93 = returnUgn (Qual pRELUDE (mk_occ_name name))
95 rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
96 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
98 cvFlag :: U_long -> Bool
103 %************************************************************************
105 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
107 %************************************************************************
110 #if __GLASGOW_HASKELL__ == 201
111 # define PACK_STR packCString
112 #elif __GLASGOW_HASKELL__ >= 202
113 # define PACK_STR mkFastCharString
115 # define PACK_STR mkFastCharString
118 rdModule :: IO (Module, -- this module's name
119 RdrNameHsModule) -- the main goods
122 = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser!
124 srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
127 rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
128 hmodlist srciface_version srcline) ->
130 setSrcFileUgn srcfile $
131 setSrcModUgn modname $
132 mkSrcLocUgn srcline $ \ src_loc ->
134 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
135 wlkList rdImport himplist `thenUgn` \ imports ->
136 wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
137 wlkBinding hmodlist `thenUgn` \ binding ->
140 val_decl = ValD (cvBinds srcfile cvValSig binding)
141 other_decls = cvOtherDecls binding
145 (case srciface_version of { 0 -> Nothing; n -> Just n })
149 (val_decl: other_decls)
154 %************************************************************************
156 \subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
158 %************************************************************************
161 rdExpr :: ParseTree -> UgnM RdrNameHsExpr
162 rdPat :: ParseTree -> UgnM RdrNamePat
164 rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
165 rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
167 wlkExpr :: U_tree -> UgnM RdrNameHsExpr
168 wlkPat :: U_tree -> UgnM RdrNamePat
172 U_par pexpr -> -- parenthesised expr
173 wlkExpr pexpr `thenUgn` \ expr ->
174 returnUgn (HsPar expr)
176 U_lsection lsexp lop -> -- left section
177 wlkExpr lsexp `thenUgn` \ expr ->
178 wlkVarId lop `thenUgn` \ op ->
179 returnUgn (SectionL expr (HsVar op))
181 U_rsection rop rsexp -> -- right section
182 wlkVarId rop `thenUgn` \ op ->
183 wlkExpr rsexp `thenUgn` \ expr ->
184 returnUgn (SectionR (HsVar op) expr)
186 U_ccall fun flavor ccargs -> -- ccall/casm
187 wlkList rdExpr ccargs `thenUgn` \ args ->
191 returnUgn (CCall fun args
192 (tag == 'p' || tag == 'P') -- may invoke GC
193 (tag == 'N' || tag == 'P') -- really a "casm"
194 (panic "CCall:result_ty"))
196 U_scc label sccexp -> -- scc (set-cost-centre) expression
197 wlkExpr sccexp `thenUgn` \ expr ->
198 returnUgn (HsSCC label expr)
200 U_lambda lampats lamexpr srcline -> -- lambda expression
201 mkSrcLocUgn srcline $ \ src_loc ->
202 wlkList rdPat lampats `thenUgn` \ pats ->
203 wlkExpr lamexpr `thenUgn` \ body ->
205 HsLam (foldr PatMatch
206 (GRHSMatch (GRHSsAndBindsIn
207 [OtherwiseGRHS body src_loc]
212 U_casee caseexpr casebody srcline -> -- case expression
213 mkSrcLocUgn srcline $ \ src_loc ->
214 wlkExpr caseexpr `thenUgn` \ expr ->
215 wlkList rdMatch casebody `thenUgn` \ mats ->
216 getSrcFileUgn `thenUgn` \ sf ->
218 matches = cvMatches sf True mats
220 returnUgn (HsCase expr matches src_loc)
222 U_ife ifpred ifthen ifelse srcline -> -- if expression
223 mkSrcLocUgn srcline $ \ src_loc ->
224 wlkExpr ifpred `thenUgn` \ e1 ->
225 wlkExpr ifthen `thenUgn` \ e2 ->
226 wlkExpr ifelse `thenUgn` \ e3 ->
227 returnUgn (HsIf e1 e2 e3 src_loc)
229 U_let letvdefs letvexpr -> -- let expression
230 wlkBinding letvdefs `thenUgn` \ binding ->
231 wlkExpr letvexpr `thenUgn` \ expr ->
232 getSrcFileUgn `thenUgn` \ sf ->
234 binds = cvBinds sf cvValSig binding
236 returnUgn (HsLet binds expr)
238 U_doe gdo srcline -> -- do expression
239 mkSrcLocUgn srcline $ \ src_loc ->
240 wlkList rd_stmt gdo `thenUgn` \ stmts ->
241 returnUgn (HsDo DoStmt stmts src_loc)
244 = rdU_tree pt `thenUgn` \ bind ->
246 U_doexp exp srcline ->
247 mkSrcLocUgn srcline $ \ src_loc ->
248 wlkExpr exp `thenUgn` \ expr ->
249 returnUgn (ExprStmt expr src_loc)
251 U_dobind pat exp srcline ->
252 mkSrcLocUgn srcline $ \ src_loc ->
253 wlkPat pat `thenUgn` \ patt ->
254 wlkExpr exp `thenUgn` \ expr ->
255 returnUgn (BindStmt patt expr src_loc)
258 wlkBinding seqlet `thenUgn` \ bs ->
259 getSrcFileUgn `thenUgn` \ sf ->
261 binds = cvBinds sf cvValSig bs
263 returnUgn (LetStmt binds)
265 U_comprh cexp cquals -> -- list comprehension
266 wlkExpr cexp `thenUgn` \ expr ->
267 wlkQuals cquals `thenUgn` \ quals ->
268 getSrcLocUgn `thenUgn` \ loc ->
269 returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
271 U_eenum efrom estep eto -> -- arithmetic sequence
272 wlkExpr efrom `thenUgn` \ e1 ->
273 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
274 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
275 returnUgn (cv_arith_seq e1 es2 es3)
277 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
278 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
279 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
280 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
282 U_restr restre restrt -> -- expression with type signature
283 wlkExpr restre `thenUgn` \ expr ->
284 wlkHsType restrt `thenUgn` \ ty ->
285 returnUgn (ExprWithTySig expr ty)
287 --------------------------------------------------------------
288 -- now the prefix items that can either be an expression or
289 -- pattern, except we know they are *expressions* here
290 -- (this code could be commoned up with the pattern version;
291 -- but it probably isn't worth it)
292 --------------------------------------------------------------
294 wlkLiteral lit `thenUgn` \ lit ->
295 returnUgn (HsLit lit)
297 U_ident n -> -- simple identifier
298 wlkVarId n `thenUgn` \ var ->
299 returnUgn (HsVar var)
301 U_ap fun arg -> -- application
302 wlkExpr fun `thenUgn` \ expr1 ->
303 wlkExpr arg `thenUgn` \ expr2 ->
304 returnUgn (HsApp expr1 expr2)
306 U_infixap fun arg1 arg2 -> -- infix application
307 wlkVarId fun `thenUgn` \ op ->
308 wlkExpr arg1 `thenUgn` \ expr1 ->
309 wlkExpr arg2 `thenUgn` \ expr2 ->
310 returnUgn (mkOpApp expr1 op expr2)
312 U_negate nexp -> -- prefix negation
313 wlkExpr nexp `thenUgn` \ expr ->
314 returnUgn (NegApp expr (HsVar dummyRdrVarName))
316 U_llist llist -> -- explicit list
317 wlkList rdExpr llist `thenUgn` \ exprs ->
318 returnUgn (ExplicitList exprs)
320 U_tuple tuplelist -> -- explicit tuple
321 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
322 returnUgn (ExplicitTuple exprs)
324 U_record con rbinds -> -- record construction
325 wlkDataId con `thenUgn` \ rcon ->
326 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
327 returnUgn (RecordCon rcon recbinds)
329 U_rupdate updexp updbinds -> -- record update
330 wlkExpr updexp `thenUgn` \ aexp ->
331 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
332 returnUgn (RecordUpd aexp recbinds)
335 U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
336 U_as _ _ -> error "U_as"
337 U_lazyp _ -> error "U_lazyp"
338 U_wildp -> error "U_wildp"
339 U_qual _ _ -> error "U_qual"
340 U_guard _ -> error "U_guard"
341 U_seqlet _ -> error "U_seqlet"
342 U_dobind _ _ _ -> error "U_dobind"
343 U_doexp _ _ -> error "U_doexp"
344 U_rbind _ _ -> error "U_rbind"
345 U_fixop _ _ _ -> error "U_fixop"
349 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
350 wlkVarId var `thenUgn` \ rvar ->
351 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
354 Nothing -> (rvar, HsVar rvar, True{-pun-})
355 Just re -> (rvar, re, False)
359 = wlkList rd_qual cquals
362 = rdU_tree pt `thenUgn` \ qual ->
368 wlkExpr exp `thenUgn` \ expr ->
369 getSrcLocUgn `thenUgn` \ loc ->
370 returnUgn (GuardStmt expr loc)
373 wlkPat qpat `thenUgn` \ pat ->
374 wlkExpr qexp `thenUgn` \ expr ->
375 getSrcLocUgn `thenUgn` \ loc ->
376 returnUgn (BindStmt pat expr loc)
379 wlkBinding seqlet `thenUgn` \ bs ->
380 getSrcFileUgn `thenUgn` \ sf ->
382 binds = cvBinds sf cvValSig bs
384 returnUgn (LetStmt binds)
385 U_let letvdefs letvexpr ->
386 wlkBinding letvdefs `thenUgn` \ binding ->
387 wlkExpr letvexpr `thenUgn` \ expr ->
388 getSrcLocUgn `thenUgn` \ loc ->
389 getSrcFileUgn `thenUgn` \ sf ->
391 binds = cvBinds sf cvValSig binding
393 returnUgn (GuardStmt (HsLet binds expr) loc)
396 Patterns: just bear in mind that lists of patterns are represented as
397 a series of ``applications''.
401 U_par ppat -> -- parenthesised pattern
402 wlkPat ppat `thenUgn` \ pat ->
403 -- tidy things up a little:
408 other -> ParPatIn pat
411 U_as avar as_pat -> -- "as" pattern
412 wlkVarId avar `thenUgn` \ var ->
413 wlkPat as_pat `thenUgn` \ pat ->
414 returnUgn (AsPatIn var pat)
416 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
417 wlkPat lazyp `thenUgn` \ pat ->
418 returnUgn (LazyPatIn pat)
421 wlkVarId avar `thenUgn` \ var ->
422 wlkLiteral lit `thenUgn` \ lit ->
423 returnUgn (NPlusKPatIn var lit)
425 U_wildp -> returnUgn WildPatIn -- wildcard pattern
427 U_lit lit -> -- literal pattern
428 wlkLiteral lit `thenUgn` \ lit ->
429 returnUgn (LitPatIn lit)
431 U_ident nn -> -- simple identifier
432 wlkVarId nn `thenUgn` \ n ->
435 VarOcc occ | isLexConId occ -> ConPatIn n []
439 U_ap l r -> -- "application": there's a list of patterns lurking here!
440 wlkPat r `thenUgn` \ rpat ->
441 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
443 VarPatIn x -> returnUgn (x, lpats)
444 ConPatIn x [] -> returnUgn (x, lpats)
445 ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
446 _ -> getSrcLocUgn `thenUgn` \ loc ->
448 err = addErrLoc loc "Illegal pattern `application'"
449 (\sty -> hsep (map (ppr sty) (lpat:lpats)))
450 msg = show (err (PprForUser opt_PprUserLength))
452 #if __GLASGOW_HASKELL__ == 201
453 ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
454 ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
455 #elif __GLASGOW_HASKELL__ >= 202
456 ioToUgnM (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
457 ioToUgnM (IOBase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
459 ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
460 ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
462 returnUgn (error "ReadPrefix")
464 ) `thenUgn` \ (n, arg_pats) ->
465 returnUgn (ConPatIn n arg_pats)
470 wlkPat r `thenUgn` \ rpat ->
471 collect_pats l (rpat:acc)
473 wlkPat other `thenUgn` \ pat ->
476 U_infixap fun arg1 arg2 -> -- infix pattern
477 wlkVarId fun `thenUgn` \ op ->
478 wlkPat arg1 `thenUgn` \ pat1 ->
479 wlkPat arg2 `thenUgn` \ pat2 ->
480 returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
482 U_negate npat -> -- negated pattern
483 wlkPat npat `thenUgn` \ pat ->
484 returnUgn (NegPatIn pat)
486 U_llist llist -> -- explicit list
487 wlkList rdPat llist `thenUgn` \ pats ->
488 returnUgn (ListPatIn pats)
490 U_tuple tuplelist -> -- explicit tuple
491 wlkList rdPat tuplelist `thenUgn` \ pats ->
492 returnUgn (TuplePatIn pats)
494 U_record con rpats -> -- record destruction
495 wlkDataId con `thenUgn` \ rcon ->
496 wlkList rdRpat rpats `thenUgn` \ recpats ->
497 returnUgn (RecPatIn rcon recpats)
500 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
501 wlkVarId var `thenUgn` \ rvar ->
502 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
505 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
506 Just rp -> (rvar, rp, False)
511 wlkLiteral :: U_literal -> UgnM HsLit
516 U_integer s -> HsInt (as_integer s)
517 U_floatr s -> HsFrac (as_rational s)
518 U_intprim s -> HsIntPrim (as_integer s)
519 U_doubleprim s -> HsDoublePrim (as_rational s)
520 U_floatprim s -> HsFloatPrim (as_rational s)
521 U_charr s -> HsChar (as_char s)
522 U_charprim s -> HsCharPrim (as_char s)
523 U_string s -> HsString (as_string s)
524 U_stringprim s -> HsStringPrim (as_string s)
525 U_clitlit s -> HsLitLit (as_string s)
529 as_integer s = readInteger (_UNPK_ s)
530 #if __GLASGOW_HASKELL__ == 201
531 as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
532 #elif __GLASGOW_HASKELL__ == 202
533 as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a }
534 #elif __GLASGOW_HASKELL__ >= 203
535 as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
536 -- to handle rationals with leading '-'
538 as_rational s = _readRational (_UNPK_ s) -- non-std
543 %************************************************************************
545 \subsection{wlkBinding}
547 %************************************************************************
550 wlkBinding :: U_binding -> UgnM RdrBinding
556 returnUgn RdrNullBind
558 -- "and" binding (just glue, really)
560 wlkBinding a `thenUgn` \ binding1 ->
561 wlkBinding b `thenUgn` \ binding2 ->
562 returnUgn (RdrAndBindings binding1 binding2)
564 -- "data" declaration
565 U_tbind tctxt ttype tcons tderivs srcline ->
566 mkSrcLocUgn srcline $ \ src_loc ->
567 wlkContext tctxt `thenUgn` \ ctxt ->
568 wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
569 wlkList rdConDecl tcons `thenUgn` \ cons ->
570 wlkDerivings tderivs `thenUgn` \ derivings ->
571 returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
573 -- "newtype" declaration
574 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
575 mkSrcLocUgn srcline $ \ src_loc ->
576 wlkContext ntctxt `thenUgn` \ ctxt ->
577 wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
578 wlkList rdConDecl ntcon `thenUgn` \ cons ->
579 wlkDerivings ntderivs `thenUgn` \ derivings ->
580 returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
582 -- "type" declaration
583 U_nbind nbindid nbindas srcline ->
584 mkSrcLocUgn srcline $ \ src_loc ->
585 wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
586 wlkMonoType nbindas `thenUgn` \ expansion ->
587 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
590 U_fbind fbindl srcline ->
591 mkSrcLocUgn srcline $ \ src_loc ->
592 wlkList rdMatch fbindl `thenUgn` \ matches ->
593 returnUgn (RdrFunctionBinding srcline matches)
596 U_pbind pbindl srcline ->
597 mkSrcLocUgn srcline $ \ src_loc ->
598 wlkList rdMatch pbindl `thenUgn` \ matches ->
599 returnUgn (RdrPatternBinding srcline matches)
601 -- "class" declaration
602 U_cbind cbindc cbindid cbindw srcline ->
603 mkSrcLocUgn srcline $ \ src_loc ->
604 wlkContext cbindc `thenUgn` \ ctxt ->
605 wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
606 wlkBinding cbindw `thenUgn` \ binding ->
607 getSrcFileUgn `thenUgn` \ sf ->
609 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
611 returnUgn (RdrClassDecl
612 (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
614 -- "instance" declaration
615 U_ibind ibindc iclas ibindi ibindw srcline ->
616 mkSrcLocUgn srcline $ \ src_loc ->
617 wlkContext ibindc `thenUgn` \ ctxt ->
618 wlkTCId iclas `thenUgn` \ clas ->
619 wlkMonoType ibindi `thenUgn` \ at_ty ->
620 wlkBinding ibindw `thenUgn` \ binding ->
621 getSrcModUgn `thenUgn` \ modname ->
622 getSrcFileUgn `thenUgn` \ sf ->
624 (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
625 inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
627 returnUgn (RdrInstDecl
628 (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
630 -- "default" declaration
631 U_dbind dbindts srcline ->
632 mkSrcLocUgn srcline $ \ src_loc ->
633 wlkList rdMonoType dbindts `thenUgn` \ tys ->
634 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
637 -- signature(-like) things, including user pragmas
638 wlk_sig_thing a_sig_we_hope
642 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
644 wlkDerivings (U_nothing) = returnUgn Nothing
645 wlkDerivings (U_just pt)
646 = rdU_list pt `thenUgn` \ ds ->
647 wlkList rdTCId ds `thenUgn` \ derivs ->
648 returnUgn (Just derivs)
653 wlk_sig_thing (U_sbind sbindids sbindid srcline)
654 = mkSrcLocUgn srcline $ \ src_loc ->
655 wlkList rdVarId sbindids `thenUgn` \ vars ->
656 wlkHsType sbindid `thenUgn` \ poly_ty ->
657 returnUgn (RdrTySig vars poly_ty src_loc)
659 -- value specialisation user-pragma
660 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
661 = mkSrcLocUgn srcline $ \ src_loc ->
662 wlkVarId uvar `thenUgn` \ var ->
663 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
664 returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
665 | (ty, using_id) <- tys_and_ids ])
667 rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
669 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
670 wlkHsType vspec_ty `thenUgn` \ ty ->
671 wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
672 returnUgn(ty, id_maybe)
674 -- instance specialisation user-pragma
675 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
676 = mkSrcLocUgn srcline $ \ src_loc ->
677 wlkTCId iclas `thenUgn` \ clas ->
678 wlkMonoType ispec_ty `thenUgn` \ ty ->
679 returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
681 -- data specialisation user-pragma
682 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
683 = mkSrcLocUgn srcline $ \ src_loc ->
684 wlkTCId itycon `thenUgn` \ tycon ->
685 wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
686 returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
688 -- value inlining user-pragma
689 wlk_sig_thing (U_inline_uprag ivar srcline)
690 = mkSrcLocUgn srcline $ \ src_loc ->
691 wlkVarId ivar `thenUgn` \ var ->
692 returnUgn (RdrInlineValSig (InlineSig var src_loc))
694 -- "magic" unfolding user-pragma
695 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
696 = mkSrcLocUgn srcline $ \ src_loc ->
697 wlkVarId ivar `thenUgn` \ var ->
698 returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
701 %************************************************************************
703 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
705 %************************************************************************
708 rdHsType :: ParseTree -> UgnM RdrNameHsType
709 rdMonoType :: ParseTree -> UgnM RdrNameHsType
711 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
712 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
714 wlkHsType :: U_ttype -> UgnM RdrNameHsType
715 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
719 U_context tcontextl tcontextt -> -- context
720 wlkContext tcontextl `thenUgn` \ ctxt ->
721 wlkMonoType tcontextt `thenUgn` \ ty ->
722 returnUgn (HsPreForAllTy ctxt ty)
724 other -> -- something else
725 wlkMonoType other `thenUgn` \ ty ->
726 returnUgn (HsPreForAllTy [{-no context-}] ty)
730 -- Glasgow extension: nested polymorhism
731 U_context tcontextl tcontextt -> -- context
732 wlkContext tcontextl `thenUgn` \ ctxt ->
733 wlkMonoType tcontextt `thenUgn` \ ty ->
734 returnUgn (HsPreForAllTy ctxt ty)
736 U_namedtvar tv -> -- type variable
737 wlkTvId tv `thenUgn` \ tyvar ->
738 returnUgn (MonoTyVar tyvar)
740 U_tname tcon -> -- type constructor
741 wlkTCId tcon `thenUgn` \ tycon ->
742 returnUgn (MonoTyVar tycon)
745 wlkMonoType t1 `thenUgn` \ ty1 ->
746 wlkMonoType t2 `thenUgn` \ ty2 ->
747 returnUgn (MonoTyApp ty1 ty2)
749 U_tllist tlist -> -- list type
750 wlkMonoType tlist `thenUgn` \ ty ->
751 returnUgn (MonoListTy dummyRdrTcName ty)
754 wlkList rdMonoType ttuple `thenUgn` \ tys ->
755 returnUgn (MonoTupleTy dummyRdrTcName tys)
758 wlkMonoType tfun `thenUgn` \ ty1 ->
759 wlkMonoType targ `thenUgn` \ ty2 ->
760 returnUgn (MonoFunTy ty1 ty2)
765 wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
766 wlkContext :: U_list -> UgnM RdrNameContext
767 wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
769 wlkTyConAndTyVars ttype
770 = wlkMonoType ttype `thenUgn` \ ty ->
772 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
773 split (MonoTyVar tycon) args = (tycon,args)
775 returnUgn (split ty [])
778 = wlkList rdMonoType list `thenUgn` \ tys ->
779 returnUgn (map mk_class_assertion tys)
782 = wlkMonoType xs `thenUgn` \ mono_ty ->
783 returnUgn (case mk_class_assertion mono_ty of
784 (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
787 mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
789 mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
790 mk_class_assertion other
791 = pprError "ERROR: malformed type context: " (ppr (PprForUser opt_PprUserLength) other)
792 -- regrettably, the parser does let some junk past
793 -- e.g., f :: Num {-nothing-} => a -> ...
797 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
799 = rdU_constr pt `thenUgn` \ blah ->
802 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
804 wlkConDecl (U_constrcxt ccxt ccdecl)
805 = wlkContext ccxt `thenUgn` \ theta ->
806 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
807 returnUgn (ConDecl con theta details loc)
809 wlkConDecl (U_constrpre ccon ctys srcline)
810 = mkSrcLocUgn srcline $ \ src_loc ->
811 wlkDataId ccon `thenUgn` \ con ->
812 wlkList rdBangType ctys `thenUgn` \ tys ->
813 returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
815 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
816 = mkSrcLocUgn srcline $ \ src_loc ->
817 wlkBangType cty1 `thenUgn` \ ty1 ->
818 wlkDataId cop `thenUgn` \ op ->
819 wlkBangType cty2 `thenUgn` \ ty2 ->
820 returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
822 wlkConDecl (U_constrnew ccon cty srcline)
823 = mkSrcLocUgn srcline $ \ src_loc ->
824 wlkDataId ccon `thenUgn` \ con ->
825 wlkMonoType cty `thenUgn` \ ty ->
826 returnUgn (ConDecl con [] (NewCon ty) src_loc)
828 wlkConDecl (U_constrrec ccon cfields srcline)
829 = mkSrcLocUgn srcline $ \ src_loc ->
830 wlkDataId ccon `thenUgn` \ con ->
831 wlkList rd_field cfields `thenUgn` \ fields_lists ->
832 returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
834 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
836 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
837 wlkList rdVarId fvars `thenUgn` \ vars ->
838 wlkBangType fty `thenUgn` \ ty ->
842 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
844 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
846 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
847 returnUgn (Banged ty)
848 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
849 returnUgn (Unbanged ty)
852 %************************************************************************
854 \subsection{Read a ``match''}
856 %************************************************************************
859 rdMatch :: ParseTree -> UgnM RdrMatch
862 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
863 mkSrcLocUgn srcline $ \ src_loc ->
864 wlkPat gpat `thenUgn` \ pat ->
865 wlkBinding gbind `thenUgn` \ binding ->
866 wlkVarId gsrcfun `thenUgn` \ srcfun ->
868 wlk_guards (U_pnoguards exp)
869 = wlkExpr exp `thenUgn` \ expr ->
870 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
872 wlk_guards (U_pguards gs)
873 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
874 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
879 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
880 wlkQuals g `thenUgn` \ guard ->
881 wlkExpr e `thenUgn` \ expr ->
882 returnUgn (guard, expr)
885 %************************************************************************
887 \subsection[rdFixOp]{Read in a fixity declaration}
889 %************************************************************************
892 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
894 = rdU_tree pt `thenUgn` \ fix ->
896 U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
897 returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
904 _ -> error "ReadPrefix:rdFixOp"
907 %************************************************************************
909 \subsection[rdImport]{Read an import decl}
911 %************************************************************************
914 rdImport :: ParseTree
915 -> UgnM RdrNameImportDecl
918 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
919 mkSrcLocUgn srcline $ \ src_loc ->
920 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
921 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
922 returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
924 rd_spec pt = rdU_either pt `thenUgn` \ spec ->
926 U_left pt -> rdEntities pt `thenUgn` \ ents ->
927 returnUgn (False, ents)
928 U_right pt -> rdEntities pt `thenUgn` \ ents ->
929 returnUgn (True, ents)
931 cvIfaceFlavour 0 = HiFile -- No pragam
932 cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
937 = rdU_list pt `thenUgn` \ list ->
938 wlkList rdEntity list
940 rdEntity :: ParseTree -> UgnM (IE RdrName)
943 = rdU_entidt pt `thenUgn` \ entity ->
945 U_entid evar -> -- just a value
946 wlkEntId evar `thenUgn` \ var ->
947 returnUgn (IEVar var)
949 U_enttype x -> -- abstract type constructor/class
950 wlkTCId x `thenUgn` \ thing ->
951 returnUgn (IEThingAbs thing)
953 U_enttypeall x -> -- non-abstract type constructor/class
954 wlkTCId x `thenUgn` \ thing ->
955 returnUgn (IEThingAll thing)
957 U_enttypenamed x ns -> -- non-abstract type constructor/class
958 -- with specified constrs/methods
959 wlkTCId x `thenUgn` \ thing ->
960 wlkList rdVarId ns `thenUgn` \ names ->
961 returnUgn (IEThingWith thing names)
963 U_entmod mod -> -- everything provided unqualified by a module
964 returnUgn (IEModuleContents mod)