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, opt_NoImplicitPrelude )
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 (aqual) A.x
81 -- unqualified name (noqual) 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.()".
86 -- NB: The (qualified) prelude is always in scope, so the renamer will find it.
88 -- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
89 -- case we need to unqualify these things. -- SDM.
91 wlkQid mk_occ_name (U_noqual name)
92 = returnUgn (Unqual (mk_occ_name name))
93 wlkQid mk_occ_name (U_aqual mod name)
94 = returnUgn (Qual mod (mk_occ_name name) HiFile)
95 wlkQid mk_occ_name (U_gid n name)
96 | opt_NoImplicitPrelude
97 = returnUgn (Unqual (mk_occ_name name))
99 = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
101 rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
102 rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
104 cvFlag :: U_long -> Bool
109 %************************************************************************
111 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
113 %************************************************************************
116 #if __GLASGOW_HASKELL__ == 201
117 # define PACK_STR packCString
118 #elif __GLASGOW_HASKELL__ >= 202
119 # define PACK_STR mkFastCharString
121 # define PACK_STR mkFastCharString
124 rdModule :: IO (Module, -- this module's name
125 RdrNameHsModule) -- the main goods
128 = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser!
130 srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
133 rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
134 hmodlist srciface_version srcline) ->
136 setSrcFileUgn srcfile $
137 setSrcModUgn modname $
138 mkSrcLocUgn srcline $ \ src_loc ->
140 wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
141 wlkList rdImport himplist `thenUgn` \ imports ->
142 wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
143 wlkBinding hmodlist `thenUgn` \ binding ->
146 val_decl = ValD (cvBinds srcfile cvValSig binding)
147 other_decls = cvOtherDecls binding
151 (case srciface_version of { 0 -> Nothing; n -> Just n })
155 (val_decl: other_decls)
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 DoStmt 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 wlkQuals cquals `thenUgn` \ quals ->
274 getSrcLocUgn `thenUgn` \ loc ->
275 returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
277 U_eenum efrom estep eto -> -- arithmetic sequence
278 wlkExpr efrom `thenUgn` \ e1 ->
279 wlkMaybe rdExpr estep `thenUgn` \ es2 ->
280 wlkMaybe rdExpr eto `thenUgn` \ es3 ->
281 returnUgn (cv_arith_seq e1 es2 es3)
283 cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
284 cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
285 cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
286 cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
288 U_restr restre restrt -> -- expression with type signature
289 wlkExpr restre `thenUgn` \ expr ->
290 wlkHsType restrt `thenUgn` \ ty ->
291 returnUgn (ExprWithTySig expr ty)
293 --------------------------------------------------------------
294 -- now the prefix items that can either be an expression or
295 -- pattern, except we know they are *expressions* here
296 -- (this code could be commoned up with the pattern version;
297 -- but it probably isn't worth it)
298 --------------------------------------------------------------
300 wlkLiteral lit `thenUgn` \ lit ->
301 returnUgn (HsLit lit)
303 U_ident n -> -- simple identifier
304 wlkVarId n `thenUgn` \ var ->
305 returnUgn (HsVar var)
307 U_ap fun arg -> -- application
308 wlkExpr fun `thenUgn` \ expr1 ->
309 wlkExpr arg `thenUgn` \ expr2 ->
310 returnUgn (HsApp expr1 expr2)
312 U_infixap fun arg1 arg2 -> -- infix application
313 wlkVarId fun `thenUgn` \ op ->
314 wlkExpr arg1 `thenUgn` \ expr1 ->
315 wlkExpr arg2 `thenUgn` \ expr2 ->
316 returnUgn (mkOpApp expr1 op expr2)
318 U_negate nexp -> -- prefix negation
319 wlkExpr nexp `thenUgn` \ expr ->
320 returnUgn (NegApp expr (HsVar dummyRdrVarName))
322 U_llist llist -> -- explicit list
323 wlkList rdExpr llist `thenUgn` \ exprs ->
324 returnUgn (ExplicitList exprs)
326 U_tuple tuplelist -> -- explicit tuple
327 wlkList rdExpr tuplelist `thenUgn` \ exprs ->
328 returnUgn (ExplicitTuple exprs)
330 U_record con rbinds -> -- record construction
331 wlkDataId con `thenUgn` \ rcon ->
332 wlkList rdRbind rbinds `thenUgn` \ recbinds ->
333 returnUgn (RecordCon rcon recbinds)
335 U_rupdate updexp updbinds -> -- record update
336 wlkExpr updexp `thenUgn` \ aexp ->
337 wlkList rdRbind updbinds `thenUgn` \ recbinds ->
338 returnUgn (RecordUpd aexp recbinds)
341 U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
342 U_as _ _ -> error "U_as"
343 U_lazyp _ -> error "U_lazyp"
344 U_wildp -> error "U_wildp"
345 U_qual _ _ -> error "U_qual"
346 U_guard _ -> error "U_guard"
347 U_seqlet _ -> error "U_seqlet"
348 U_dobind _ _ _ -> error "U_dobind"
349 U_doexp _ _ -> error "U_doexp"
350 U_rbind _ _ -> error "U_rbind"
351 U_fixop _ _ _ -> error "U_fixop"
355 = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
356 wlkVarId var `thenUgn` \ rvar ->
357 wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
360 Nothing -> (rvar, HsVar rvar, True{-pun-})
361 Just re -> (rvar, re, False)
365 = wlkList rd_qual cquals
368 = rdU_tree pt `thenUgn` \ qual ->
374 wlkExpr exp `thenUgn` \ expr ->
375 getSrcLocUgn `thenUgn` \ loc ->
376 returnUgn (GuardStmt expr loc)
379 wlkPat qpat `thenUgn` \ pat ->
380 wlkExpr qexp `thenUgn` \ expr ->
381 getSrcLocUgn `thenUgn` \ loc ->
382 returnUgn (BindStmt pat expr loc)
385 wlkBinding seqlet `thenUgn` \ bs ->
386 getSrcFileUgn `thenUgn` \ sf ->
388 binds = cvBinds sf cvValSig bs
390 returnUgn (LetStmt binds)
391 U_let letvdefs letvexpr ->
392 wlkBinding letvdefs `thenUgn` \ binding ->
393 wlkExpr letvexpr `thenUgn` \ expr ->
394 getSrcLocUgn `thenUgn` \ loc ->
395 getSrcFileUgn `thenUgn` \ sf ->
397 binds = cvBinds sf cvValSig binding
399 returnUgn (GuardStmt (HsLet binds expr) loc)
402 Patterns: just bear in mind that lists of patterns are represented as
403 a series of ``applications''.
407 U_par ppat -> -- parenthesised pattern
408 wlkPat ppat `thenUgn` \ pat ->
409 -- tidy things up a little:
414 other -> ParPatIn pat
417 U_as avar as_pat -> -- "as" pattern
418 wlkVarId avar `thenUgn` \ var ->
419 wlkPat as_pat `thenUgn` \ pat ->
420 returnUgn (AsPatIn var pat)
422 U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
423 wlkPat lazyp `thenUgn` \ pat ->
424 returnUgn (LazyPatIn pat)
427 wlkVarId avar `thenUgn` \ var ->
428 wlkLiteral lit `thenUgn` \ lit ->
429 returnUgn (NPlusKPatIn var lit)
431 U_wildp -> returnUgn WildPatIn -- wildcard pattern
433 U_lit lit -> -- literal pattern
434 wlkLiteral lit `thenUgn` \ lit ->
435 returnUgn (LitPatIn lit)
437 U_ident nn -> -- simple identifier
438 wlkVarId nn `thenUgn` \ n ->
441 VarOcc occ | isLexConId occ -> ConPatIn n []
445 U_ap l r -> -- "application": there's a list of patterns lurking here!
446 wlkPat r `thenUgn` \ rpat ->
447 collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
449 VarPatIn x -> returnUgn (x, lpats)
450 ConPatIn x [] -> returnUgn (x, lpats)
451 ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
452 _ -> getSrcLocUgn `thenUgn` \ loc ->
454 err = addErrLoc loc "Illegal pattern `application'"
455 (\sty -> hsep (map (ppr sty) (lpat:lpats)))
456 msg = show (err (PprForUser opt_PprUserLength))
458 #if __GLASGOW_HASKELL__ == 201
459 ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
460 ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
461 #elif __GLASGOW_HASKELL__ >= 202 && __GLASGOW_HASKELL__ < 209
462 ioToUgnM (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
463 ioToUgnM (IOBase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
465 ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
466 ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
468 returnUgn (error "ReadPrefix")
470 ) `thenUgn` \ (n, arg_pats) ->
471 returnUgn (ConPatIn n arg_pats)
476 wlkPat r `thenUgn` \ rpat ->
477 collect_pats l (rpat:acc)
479 wlkPat other `thenUgn` \ pat ->
482 U_infixap fun arg1 arg2 -> -- infix pattern
483 wlkVarId fun `thenUgn` \ op ->
484 wlkPat arg1 `thenUgn` \ pat1 ->
485 wlkPat arg2 `thenUgn` \ pat2 ->
486 returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
488 U_negate npat -> -- negated pattern
489 wlkPat npat `thenUgn` \ pat ->
490 returnUgn (NegPatIn pat)
492 U_llist llist -> -- explicit list
493 wlkList rdPat llist `thenUgn` \ pats ->
494 returnUgn (ListPatIn pats)
496 U_tuple tuplelist -> -- explicit tuple
497 wlkList rdPat tuplelist `thenUgn` \ pats ->
498 returnUgn (TuplePatIn pats)
500 U_record con rpats -> -- record destruction
501 wlkDataId con `thenUgn` \ rcon ->
502 wlkList rdRpat rpats `thenUgn` \ recpats ->
503 returnUgn (RecPatIn rcon recpats)
506 = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
507 wlkVarId var `thenUgn` \ rvar ->
508 wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
511 Nothing -> (rvar, VarPatIn rvar, True{-pun-})
512 Just rp -> (rvar, rp, False)
517 wlkLiteral :: U_literal -> UgnM HsLit
522 U_integer s -> HsInt (as_integer s)
523 U_floatr s -> HsFrac (as_rational s)
524 U_intprim s -> HsIntPrim (as_integer s)
525 U_doubleprim s -> HsDoublePrim (as_rational s)
526 U_floatprim s -> HsFloatPrim (as_rational s)
527 U_charr s -> HsChar (as_char s)
528 U_charprim s -> HsCharPrim (as_char s)
529 U_string s -> HsString (as_string s)
530 U_stringprim s -> HsStringPrim (as_string s)
531 U_clitlit s -> HsLitLit (as_string s)
535 as_integer s = readInteger (_UNPK_ s)
536 #if __GLASGOW_HASKELL__ == 201
537 as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
538 #elif __GLASGOW_HASKELL__ == 202
539 as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a }
540 #elif __GLASGOW_HASKELL__ >= 203
541 as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
542 -- to handle rationals with leading '-'
544 as_rational s = _readRational (_UNPK_ s) -- non-std
549 %************************************************************************
551 \subsection{wlkBinding}
553 %************************************************************************
556 wlkBinding :: U_binding -> UgnM RdrBinding
562 returnUgn RdrNullBind
564 -- "and" binding (just glue, really)
566 wlkBinding a `thenUgn` \ binding1 ->
567 wlkBinding b `thenUgn` \ binding2 ->
568 returnUgn (RdrAndBindings binding1 binding2)
570 -- "data" declaration
571 U_tbind tctxt ttype tcons tderivs srcline ->
572 mkSrcLocUgn srcline $ \ src_loc ->
573 wlkContext tctxt `thenUgn` \ ctxt ->
574 wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
575 wlkList rdConDecl tcons `thenUgn` \ cons ->
576 wlkDerivings tderivs `thenUgn` \ derivings ->
577 returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
579 -- "newtype" declaration
580 U_ntbind ntctxt nttype ntcon ntderivs srcline ->
581 mkSrcLocUgn srcline $ \ src_loc ->
582 wlkContext ntctxt `thenUgn` \ ctxt ->
583 wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
584 wlkList rdConDecl ntcon `thenUgn` \ cons ->
585 wlkDerivings ntderivs `thenUgn` \ derivings ->
586 returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
588 -- "type" declaration
589 U_nbind nbindid nbindas srcline ->
590 mkSrcLocUgn srcline $ \ src_loc ->
591 wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
592 wlkMonoType nbindas `thenUgn` \ expansion ->
593 returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
596 U_fbind fbindl srcline ->
597 mkSrcLocUgn srcline $ \ src_loc ->
598 wlkList rdMatch fbindl `thenUgn` \ matches ->
599 returnUgn (RdrFunctionBinding srcline matches)
602 U_pbind pbindl srcline ->
603 mkSrcLocUgn srcline $ \ src_loc ->
604 wlkList rdMatch pbindl `thenUgn` \ matches ->
605 returnUgn (RdrPatternBinding srcline matches)
607 -- "class" declaration
608 U_cbind cbindc cbindid cbindw srcline ->
609 mkSrcLocUgn srcline $ \ src_loc ->
610 wlkContext cbindc `thenUgn` \ ctxt ->
611 wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
612 wlkBinding cbindw `thenUgn` \ binding ->
613 getSrcFileUgn `thenUgn` \ sf ->
615 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
617 returnUgn (RdrClassDecl
618 (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
620 -- "instance" declaration
621 U_ibind ibindc iclas ibindi ibindw srcline ->
622 mkSrcLocUgn srcline $ \ src_loc ->
623 wlkContext ibindc `thenUgn` \ ctxt ->
624 wlkTCId iclas `thenUgn` \ clas ->
625 wlkMonoType ibindi `thenUgn` \ at_ty ->
626 wlkBinding ibindw `thenUgn` \ binding ->
627 getSrcModUgn `thenUgn` \ modname ->
628 getSrcFileUgn `thenUgn` \ sf ->
630 (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
631 inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
633 returnUgn (RdrInstDecl
634 (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
636 -- "default" declaration
637 U_dbind dbindts srcline ->
638 mkSrcLocUgn srcline $ \ src_loc ->
639 wlkList rdMonoType dbindts `thenUgn` \ tys ->
640 returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
643 -- signature(-like) things, including user pragmas
644 wlk_sig_thing a_sig_we_hope
648 wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
650 wlkDerivings (U_nothing) = returnUgn Nothing
651 wlkDerivings (U_just pt)
652 = rdU_list pt `thenUgn` \ ds ->
653 wlkList rdTCId ds `thenUgn` \ derivs ->
654 returnUgn (Just derivs)
659 wlk_sig_thing (U_sbind sbindids sbindid srcline)
660 = mkSrcLocUgn srcline $ \ src_loc ->
661 wlkList rdVarId sbindids `thenUgn` \ vars ->
662 wlkHsType sbindid `thenUgn` \ poly_ty ->
663 returnUgn (RdrTySig vars poly_ty src_loc)
665 -- value specialisation user-pragma
666 wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
667 = mkSrcLocUgn srcline $ \ src_loc ->
668 wlkVarId uvar `thenUgn` \ var ->
669 wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
670 returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
671 | (ty, using_id) <- tys_and_ids ])
673 rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
675 = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
676 wlkHsType vspec_ty `thenUgn` \ ty ->
677 wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
678 returnUgn(ty, id_maybe)
680 -- instance specialisation user-pragma
681 wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
682 = mkSrcLocUgn srcline $ \ src_loc ->
683 wlkTCId iclas `thenUgn` \ clas ->
684 wlkMonoType ispec_ty `thenUgn` \ ty ->
685 returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
687 -- data specialisation user-pragma
688 wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
689 = mkSrcLocUgn srcline $ \ src_loc ->
690 wlkTCId itycon `thenUgn` \ tycon ->
691 wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
692 returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
694 -- value inlining user-pragma
695 wlk_sig_thing (U_inline_uprag ivar srcline)
696 = mkSrcLocUgn srcline $ \ src_loc ->
697 wlkVarId ivar `thenUgn` \ var ->
698 returnUgn (RdrInlineValSig (InlineSig var src_loc))
700 -- "magic" unfolding user-pragma
701 wlk_sig_thing (U_magicuf_uprag ivar str srcline)
702 = mkSrcLocUgn srcline $ \ src_loc ->
703 wlkVarId ivar `thenUgn` \ var ->
704 returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
707 %************************************************************************
709 \subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
711 %************************************************************************
714 rdHsType :: ParseTree -> UgnM RdrNameHsType
715 rdMonoType :: ParseTree -> UgnM RdrNameHsType
717 rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
718 rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
720 wlkHsType :: U_ttype -> UgnM RdrNameHsType
721 wlkMonoType :: U_ttype -> UgnM RdrNameHsType
725 U_context tcontextl tcontextt -> -- context
726 wlkContext tcontextl `thenUgn` \ ctxt ->
727 wlkMonoType tcontextt `thenUgn` \ ty ->
728 returnUgn (HsPreForAllTy ctxt ty)
730 other -> -- something else
731 wlkMonoType other `thenUgn` \ ty ->
732 returnUgn (HsPreForAllTy [{-no context-}] ty)
736 -- Glasgow extension: nested polymorhism
737 U_context tcontextl tcontextt -> -- context
738 wlkContext tcontextl `thenUgn` \ ctxt ->
739 wlkMonoType tcontextt `thenUgn` \ ty ->
740 returnUgn (HsPreForAllTy ctxt ty)
742 U_namedtvar tv -> -- type variable
743 wlkTvId tv `thenUgn` \ tyvar ->
744 returnUgn (MonoTyVar tyvar)
746 U_tname tcon -> -- type constructor
747 wlkTCId tcon `thenUgn` \ tycon ->
748 returnUgn (MonoTyVar tycon)
751 wlkMonoType t1 `thenUgn` \ ty1 ->
752 wlkMonoType t2 `thenUgn` \ ty2 ->
753 returnUgn (MonoTyApp ty1 ty2)
755 U_tllist tlist -> -- list type
756 wlkMonoType tlist `thenUgn` \ ty ->
757 returnUgn (MonoListTy dummyRdrTcName ty)
760 wlkList rdMonoType ttuple `thenUgn` \ tys ->
761 returnUgn (MonoTupleTy dummyRdrTcName tys)
764 wlkMonoType tfun `thenUgn` \ ty1 ->
765 wlkMonoType targ `thenUgn` \ ty2 ->
766 returnUgn (MonoFunTy ty1 ty2)
771 wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
772 wlkContext :: U_list -> UgnM RdrNameContext
773 wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
775 wlkTyConAndTyVars ttype
776 = wlkMonoType ttype `thenUgn` \ ty ->
778 split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
779 split (MonoTyVar tycon) args = (tycon,args)
781 returnUgn (split ty [])
784 = wlkList rdMonoType list `thenUgn` \ tys ->
785 returnUgn (map mk_class_assertion tys)
788 = wlkMonoType xs `thenUgn` \ mono_ty ->
789 returnUgn (case mk_class_assertion mono_ty of
790 (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
793 mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
795 mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
796 mk_class_assertion other
797 = pprError "ERROR: malformed type context: " (ppr (PprForUser opt_PprUserLength) other)
798 -- regrettably, the parser does let some junk past
799 -- e.g., f :: Num {-nothing-} => a -> ...
803 rdConDecl :: ParseTree -> UgnM RdrNameConDecl
805 = rdU_constr pt `thenUgn` \ blah ->
808 wlkConDecl :: U_constr -> UgnM RdrNameConDecl
810 wlkConDecl (U_constrcxt ccxt ccdecl)
811 = wlkContext ccxt `thenUgn` \ theta ->
812 wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
813 returnUgn (ConDecl con theta details loc)
815 wlkConDecl (U_constrpre ccon ctys srcline)
816 = mkSrcLocUgn srcline $ \ src_loc ->
817 wlkDataId ccon `thenUgn` \ con ->
818 wlkList rdBangType ctys `thenUgn` \ tys ->
819 returnUgn (ConDecl con [] (VanillaCon tys) src_loc)
821 wlkConDecl (U_constrinf cty1 cop cty2 srcline)
822 = mkSrcLocUgn srcline $ \ src_loc ->
823 wlkBangType cty1 `thenUgn` \ ty1 ->
824 wlkDataId cop `thenUgn` \ op ->
825 wlkBangType cty2 `thenUgn` \ ty2 ->
826 returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc)
828 wlkConDecl (U_constrnew ccon cty srcline)
829 = mkSrcLocUgn srcline $ \ src_loc ->
830 wlkDataId ccon `thenUgn` \ con ->
831 wlkMonoType cty `thenUgn` \ ty ->
832 returnUgn (ConDecl con [] (NewCon ty) src_loc)
834 wlkConDecl (U_constrrec ccon cfields srcline)
835 = mkSrcLocUgn srcline $ \ src_loc ->
836 wlkDataId ccon `thenUgn` \ con ->
837 wlkList rd_field cfields `thenUgn` \ fields_lists ->
838 returnUgn (ConDecl con [] (RecCon fields_lists) src_loc)
840 rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
842 = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
843 wlkList rdVarId fvars `thenUgn` \ vars ->
844 wlkBangType fty `thenUgn` \ ty ->
848 rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
850 wlkBangType :: U_ttype -> UgnM (BangType RdrName)
852 wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
853 returnUgn (Banged ty)
854 wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
855 returnUgn (Unbanged ty)
858 %************************************************************************
860 \subsection{Read a ``match''}
862 %************************************************************************
865 rdMatch :: ParseTree -> UgnM RdrMatch
868 = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
869 mkSrcLocUgn srcline $ \ src_loc ->
870 wlkPat gpat `thenUgn` \ pat ->
871 wlkBinding gbind `thenUgn` \ binding ->
872 wlkVarId gsrcfun `thenUgn` \ srcfun ->
874 wlk_guards (U_pnoguards exp)
875 = wlkExpr exp `thenUgn` \ expr ->
876 returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
878 wlk_guards (U_pguards gs)
879 = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
880 returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
885 = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
886 wlkQuals g `thenUgn` \ guard ->
887 wlkExpr e `thenUgn` \ expr ->
888 returnUgn (guard, expr)
891 %************************************************************************
893 \subsection[rdFixOp]{Read in a fixity declaration}
895 %************************************************************************
898 rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
900 = rdU_tree pt `thenUgn` \ fix ->
902 U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
903 returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
910 _ -> error "ReadPrefix:rdFixOp"
913 %************************************************************************
915 \subsection[rdImport]{Read an import decl}
917 %************************************************************************
920 rdImport :: ParseTree
921 -> UgnM RdrNameImportDecl
924 = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
925 mkSrcLocUgn srcline $ \ src_loc ->
926 wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
927 wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
928 returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc)
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 #-}
943 = rdU_list pt `thenUgn` \ list ->
944 wlkList rdEntity list
946 rdEntity :: ParseTree -> UgnM (IE RdrName)
949 = rdU_entidt pt `thenUgn` \ entity ->
951 U_entid evar -> -- just a value
952 wlkEntId evar `thenUgn` \ var ->
953 returnUgn (IEVar var)
955 U_enttype x -> -- abstract type constructor/class
956 wlkTCId x `thenUgn` \ thing ->
957 returnUgn (IEThingAbs thing)
959 U_enttypeall x -> -- non-abstract type constructor/class
960 wlkTCId x `thenUgn` \ thing ->
961 returnUgn (IEThingAll thing)
963 U_enttypenamed x ns -> -- non-abstract type constructor/class
964 -- with specified constrs/methods
965 wlkTCId x `thenUgn` \ thing ->
966 wlkList rdVarId ns `thenUgn` \ names ->
967 returnUgn (IEThingWith thing names)
969 U_entmod mod -> -- everything provided unqualified by a module
970 returnUgn (IEModuleContents mod)