X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FReadPrefix.lhs;h=d2b2f0746ffb217e9138f71d27fa0ac5eb399665;hb=23c94851fb2c98d345d913d35a5a12bbc3a346bd;hp=0aa0e50f522ce9cef5a9a9e0106a080629207e05;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 0aa0e50..d2b2f07 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -4,30 +4,29 @@ \section{Read parse tree built by Yacc parser} \begin{code} -#include "HsVersions.h" - -module ReadPrefix ( - rdModule - ) where +module ReadPrefix ( rdModule ) where -import Ubiq +#include "HsVersions.h" import UgenAll -- all Yacc parser gumpff... import PrefixSyn -- and various syntaxen. import HsSyn -import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas ) -import RdrHsSyn +import HsTypes ( HsTyVar(..) ) +import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas ) +import RdrHsSyn +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) ) import PrefixToHs -import CmdLineOpts ( opt_CompilingPrelude ) -import ErrUtils ( addErrLoc, ghcExit ) +import CmdLineOpts ( opt_NoImplicitPrelude ) import FiniteMap ( elemFM, FiniteMap ) -import Name ( RdrName(..), isRdrLexConOrSpecial ) -import PprStyle ( PprStyle(..) ) -import PrelMods ( fromPrelude ) -import Pretty -import SrcLoc ( SrcLoc ) -import Util ( nOfThem, pprError, panic ) +import Name ( OccName(..), Module ) +import Lex ( isLexConId ) +import Outputable +import PrelMods ( pRELUDE ) +import Util ( nOfThem ) +import FastString ( mkFastCharString ) +import IO ( hPutStr, stderr ) +import PrelRead ( readRational__ ) \end{code} %************************************************************************ @@ -57,19 +56,40 @@ wlkMaybe wlk_it (U_just x) \end{code} \begin{code} -rdQid :: ParseTree -> UgnM RdrName -rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid - -wlkQid :: U_qid -> UgnM RdrName -wlkQid (U_noqual name) - = returnUgn (Unqual name) -wlkQid (U_aqual mod name) - | fromPrelude mod - = returnUgn (Unqual name) +wlkTvId = wlkQid TvOcc +wlkTCId = wlkQid TCOcc +wlkVarId = wlkQid VarOcc +wlkDataId = wlkQid VarOcc +wlkEntId = wlkQid (\occ -> if isLexConId occ + then TCOcc occ + else VarOcc occ) + +wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName + +-- There are three kinds of qid: +-- qualified name (aqual) A.x +-- unqualified name (noqual) x +-- special name (gid) [], (), ->, (,,,) +-- The special names always mean "Prelude.whatever"; that's why +-- they are distinct. So if you write "()", it's just as if you +-- had written "Prelude.()". +-- NB: The (qualified) prelude is always in scope, so the renamer will find it. + +-- EXCEPT: when we're compiling with -fno-implicit-prelude, in which +-- case we need to unqualify these things. -- SDM. + +wlkQid mk_occ_name (U_noqual name) + = returnUgn (Unqual (mk_occ_name name)) +wlkQid mk_occ_name (U_aqual mod name) + = returnUgn (Qual mod (mk_occ_name name) HiFile) +wlkQid mk_occ_name (U_gid n name) + | opt_NoImplicitPrelude + = returnUgn (Unqual (mk_occ_name name)) | otherwise - = returnUgn (Qual mod name) -wlkQid (U_gid n name) - = returnUgn (Unqual name) + = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile) + +rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid +rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid cvFlag :: U_long -> Bool cvFlag 0 = False @@ -87,9 +107,9 @@ rdModule :: IO (Module, -- this module's name RdrNameHsModule) -- the main goods rdModule - = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser! + = _ccall_ hspmain >>= \ pt -> -- call the Yacc parser! let - srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM) + srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM) in initUgn $ rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist @@ -97,30 +117,24 @@ rdModule setSrcFileUgn srcfile $ setSrcModUgn modname $ - mkSrcLocUgn srcline $ \ src_loc -> - - wlkMaybe rdEntities hexplist `thenUgn` \ exports -> - wlkList rdImport himplist `thenUgn` \ imports -> - wlkList rdFixOp hfixlist `thenUgn` \ fixities -> - wlkBinding hmodlist `thenUgn` \ binding -> + mkSrcLocUgn srcline $ \ src_loc -> - case sepDeclsForTopBinds binding of - (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) -> + wlkMaybe rdEntities hexplist `thenUgn` \ exports -> + wlkList rdImport himplist `thenUgn` \ imports -> + wlkList rdFixOp hfixlist `thenUgn` \ fixities -> + wlkBinding hmodlist `thenUgn` \ binding -> - returnUgn (modname, - HsModule modname + let + val_decl = ValD (cvBinds srcfile cvValSig binding) + other_decls = cvOtherDecls binding + in + returnUgn (modname, + HsModule modname (case srciface_version of { 0 -> Nothing; n -> Just n }) exports imports fixities - tydecls - tysigs - classdecls - instdecls - instsigs - defaultdecls - (cvSepdBinds srcfile cvValSig binds) - [{-no interface sigs yet-}] + (val_decl: other_decls) src_loc ) \end{code} @@ -149,11 +163,11 @@ wlkExpr expr U_lsection lsexp lop -> -- left section wlkExpr lsexp `thenUgn` \ expr -> - wlkQid lop `thenUgn` \ op -> + wlkVarId lop `thenUgn` \ op -> returnUgn (SectionL expr (HsVar op)) U_rsection rop rsexp -> -- right section - wlkQid rop `thenUgn` \ op -> + wlkVarId rop `thenUgn` \ op -> wlkExpr rsexp `thenUgn` \ expr -> returnUgn (SectionR (HsVar op) expr) @@ -178,7 +192,7 @@ wlkExpr expr returnUgn ( HsLam (foldr PatMatch (GRHSMatch (GRHSsAndBindsIn - [OtherwiseGRHS body src_loc] + (unguardedRHS body src_loc) EmptyBinds)) pats) ) @@ -212,7 +226,7 @@ wlkExpr expr U_doe gdo srcline -> -- do expression mkSrcLocUgn srcline $ \ src_loc -> wlkList rd_stmt gdo `thenUgn` \ stmts -> - returnUgn (HsDo stmts src_loc) + returnUgn (HsDo DoStmt stmts src_loc) where rd_stmt pt = rdU_tree pt `thenUgn` \ bind -> @@ -238,31 +252,9 @@ wlkExpr expr U_comprh cexp cquals -> -- list comprehension wlkExpr cexp `thenUgn` \ expr -> - wlkList rd_qual cquals `thenUgn` \ quals -> - returnUgn (ListComp expr quals) - where - rd_qual pt - = rdU_tree pt `thenUgn` \ qual -> - wlk_qual qual - - wlk_qual qual - = case qual of - U_guard exp -> - wlkExpr exp `thenUgn` \ expr -> - returnUgn (FilterQual expr) - - U_qual qpat qexp -> - wlkPat qpat `thenUgn` \ pat -> - wlkExpr qexp `thenUgn` \ expr -> - returnUgn (GeneratorQual pat expr) - - U_seqlet seqlet -> - wlkBinding seqlet `thenUgn` \ bs -> - getSrcFileUgn `thenUgn` \ sf -> - let - binds = cvBinds sf cvValSig bs - in - returnUgn (LetQual binds) + wlkQuals cquals `thenUgn` \ quals -> + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc) U_eenum efrom estep eto -> -- arithmetic sequence wlkExpr efrom `thenUgn` \ e1 -> @@ -277,7 +269,7 @@ wlkExpr expr U_restr restre restrt -> -- expression with type signature wlkExpr restre `thenUgn` \ expr -> - wlkPolyType restrt `thenUgn` \ ty -> + wlkHsType restrt `thenUgn` \ ty -> returnUgn (ExprWithTySig expr ty) -------------------------------------------------------------- @@ -291,7 +283,7 @@ wlkExpr expr returnUgn (HsLit lit) U_ident n -> -- simple identifier - wlkQid n `thenUgn` \ var -> + wlkVarId n `thenUgn` \ var -> returnUgn (HsVar var) U_ap fun arg -> -- application @@ -300,14 +292,14 @@ wlkExpr expr returnUgn (HsApp expr1 expr2) U_infixap fun arg1 arg2 -> -- infix application - wlkQid fun `thenUgn` \ op -> + wlkVarId fun `thenUgn` \ op -> wlkExpr arg1 `thenUgn` \ expr1 -> wlkExpr arg2 `thenUgn` \ expr2 -> - returnUgn (OpApp expr1 (HsVar op) expr2) + returnUgn (mkOpApp expr1 op expr2) U_negate nexp -> -- prefix negation wlkExpr nexp `thenUgn` \ expr -> - returnUgn (NegApp expr (Unqual SLIT("negate")) ) + returnUgn (NegApp expr (HsVar dummyRdrVarName)) U_llist llist -> -- explicit list wlkList rdExpr llist `thenUgn` \ exprs -> @@ -318,9 +310,9 @@ wlkExpr expr returnUgn (ExplicitTuple exprs) U_record con rbinds -> -- record construction - wlkQid con `thenUgn` \ rcon -> + wlkDataId con `thenUgn` \ rcon -> wlkList rdRbind rbinds `thenUgn` \ recbinds -> - returnUgn (RecordCon (HsVar rcon) recbinds) + returnUgn (RecordCon rcon (HsVar rcon) recbinds) U_rupdate updexp updbinds -> -- record update wlkExpr updexp `thenUgn` \ aexp -> @@ -338,18 +330,55 @@ wlkExpr expr U_dobind _ _ _ -> error "U_dobind" U_doexp _ _ -> error "U_doexp" U_rbind _ _ -> error "U_rbind" - U_fixop _ _ _ -> error "U_fixop" + U_fixop _ _ _ _ -> error "U_fixop" #endif rdRbind pt = rdU_tree pt `thenUgn` \ (U_rbind var exp) -> - wlkQid var `thenUgn` \ rvar -> + wlkVarId var `thenUgn` \ rvar -> wlkMaybe rdExpr exp `thenUgn` \ expr_maybe -> returnUgn ( case expr_maybe of Nothing -> (rvar, HsVar rvar, True{-pun-}) Just re -> (rvar, re, False) ) + +wlkQuals cquals + = wlkList rd_qual cquals + where + rd_qual pt + = rdU_tree pt `thenUgn` \ qual -> + wlk_qual qual + + wlk_qual qual + = case qual of + U_guard exp -> + wlkExpr exp `thenUgn` \ expr -> + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (GuardStmt expr loc) + + U_qual qpat qexp -> + wlkPat qpat `thenUgn` \ pat -> + wlkExpr qexp `thenUgn` \ expr -> + getSrcLocUgn `thenUgn` \ loc -> + returnUgn (BindStmt pat expr loc) + + U_seqlet seqlet -> + wlkBinding seqlet `thenUgn` \ bs -> + getSrcFileUgn `thenUgn` \ sf -> + let + binds = cvBinds sf cvValSig bs + in + returnUgn (LetStmt binds) + U_let letvdefs letvexpr -> + wlkBinding letvdefs `thenUgn` \ binding -> + wlkExpr letvexpr `thenUgn` \ expr -> + getSrcLocUgn `thenUgn` \ loc -> + getSrcFileUgn `thenUgn` \ sf -> + let + binds = cvBinds sf cvValSig binding + in + returnUgn (GuardStmt (HsLet binds expr) loc) \end{code} Patterns: just bear in mind that lists of patterns are represented as @@ -359,10 +388,16 @@ wlkPat pat = case pat of U_par ppat -> -- parenthesised pattern wlkPat ppat `thenUgn` \ pat -> - returnUgn (ParPatIn pat) + -- tidy things up a little: + returnUgn ( + case pat of + VarPatIn _ -> pat + WildPatIn -> pat + other -> ParPatIn pat + ) U_as avar as_pat -> -- "as" pattern - wlkQid avar `thenUgn` \ var -> + wlkVarId avar `thenUgn` \ var -> wlkPat as_pat `thenUgn` \ pat -> returnUgn (AsPatIn var pat) @@ -370,6 +405,11 @@ wlkPat pat wlkPat lazyp `thenUgn` \ pat -> returnUgn (LazyPatIn pat) + U_plusp avar lit -> + wlkVarId avar `thenUgn` \ var -> + wlkLiteral lit `thenUgn` \ lit -> + returnUgn (NPlusKPatIn var lit) + U_wildp -> returnUgn WildPatIn -- wildcard pattern U_lit lit -> -- literal pattern @@ -377,29 +417,23 @@ wlkPat pat returnUgn (LitPatIn lit) U_ident nn -> -- simple identifier - wlkQid nn `thenUgn` \ n -> + wlkVarId nn `thenUgn` \ n -> returnUgn ( - if isRdrLexConOrSpecial n - then ConPatIn n [] - else VarPatIn n + case rdrNameOcc n of + VarOcc occ | isLexConId occ -> ConPatIn n [] + other -> VarPatIn n ) U_ap l r -> -- "application": there's a list of patterns lurking here! wlkPat r `thenUgn` \ rpat -> collect_pats l [rpat] `thenUgn` \ (lpat,lpats) -> (case lpat of - VarPatIn x -> returnUgn (x, lpats) - ConPatIn x [] -> returnUgn (x, lpats) - ConOpPatIn x op y -> returnUgn (op, x:y:lpats) + VarPatIn x -> returnUgn (x, lpats) + ConPatIn x [] -> returnUgn (x, lpats) + ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats) _ -> getSrcLocUgn `thenUgn` \ loc -> - let - err = addErrLoc loc "Illegal pattern `application'" - (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats))) - msg = ppShow 100 (err PprForUser) - in - ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ -> - ioToUgnM (ghcExit 1) `thenUgn` \ _ -> - returnUgn (error "ReadPrefix") + pprPanic "Illegal pattern `application'" + (ppr loc <> colon <+> hsep (map ppr (lpat:lpats))) ) `thenUgn` \ (n, arg_pats) -> returnUgn (ConPatIn n arg_pats) @@ -414,10 +448,10 @@ wlkPat pat returnUgn (pat,acc) U_infixap fun arg1 arg2 -> -- infix pattern - wlkQid fun `thenUgn` \ op -> + wlkVarId fun `thenUgn` \ op -> wlkPat arg1 `thenUgn` \ pat1 -> wlkPat arg2 `thenUgn` \ pat2 -> - returnUgn (ConOpPatIn pat1 op pat2) + returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2) U_negate npat -> -- negated pattern wlkPat npat `thenUgn` \ pat -> @@ -432,13 +466,13 @@ wlkPat pat returnUgn (TuplePatIn pats) U_record con rpats -> -- record destruction - wlkQid con `thenUgn` \ rcon -> + wlkDataId con `thenUgn` \ rcon -> wlkList rdRpat rpats `thenUgn` \ recpats -> returnUgn (RecPatIn rcon recpats) where rdRpat pt = rdU_tree pt `thenUgn` \ (U_rbind var pat) -> - wlkQid var `thenUgn` \ rvar -> + wlkVarId var `thenUgn` \ rvar -> wlkMaybe rdPat pat `thenUgn` \ pat_maybe -> returnUgn ( case pat_maybe of @@ -453,7 +487,7 @@ wlkLiteral :: U_literal -> UgnM HsLit wlkLiteral ulit = returnUgn ( case ulit of - U_integer s -> HsInt (as_integer s) + U_integer s -> HsInt (as_integer s) U_floatr s -> HsFrac (as_rational s) U_intprim s -> HsIntPrim (as_integer s) U_doubleprim s -> HsDoublePrim (as_rational s) @@ -467,7 +501,8 @@ wlkLiteral ulit where as_char s = _HEAD_ s as_integer s = readInteger (_UNPK_ s) - as_rational s = _readRational (_UNPK_ s) -- non-std + as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__ + -- to handle rationals with leading '-' as_string s = s \end{code} @@ -496,24 +531,24 @@ wlkBinding binding U_tbind tctxt ttype tcons tderivs srcline -> mkSrcLocUgn srcline $ \ src_loc -> wlkContext tctxt `thenUgn` \ ctxt -> - wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) -> + wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) -> wlkList rdConDecl tcons `thenUgn` \ cons -> wlkDerivings tderivs `thenUgn` \ derivings -> - returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc)) + returnUgn (RdrTyDecl (TyData DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc)) -- "newtype" declaration U_ntbind ntctxt nttype ntcon ntderivs srcline -> mkSrcLocUgn srcline $ \ src_loc -> wlkContext ntctxt `thenUgn` \ ctxt -> - wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) -> - wlkList rdConDecl ntcon `thenUgn` \ con -> + wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) -> + wlkList rdConDecl ntcon `thenUgn` \ cons -> wlkDerivings ntderivs `thenUgn` \ derivings -> - returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc)) + returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc)) -- "type" declaration U_nbind nbindid nbindas srcline -> mkSrcLocUgn srcline $ \ src_loc -> - wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) -> + wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) -> wlkMonoType nbindas `thenUgn` \ expansion -> returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc)) @@ -531,40 +566,32 @@ wlkBinding binding -- "class" declaration U_cbind cbindc cbindid cbindw srcline -> - mkSrcLocUgn srcline $ \ src_loc -> - wlkContext cbindc `thenUgn` \ ctxt -> - wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)-> - wlkBinding cbindw `thenUgn` \ binding -> - getSrcFileUgn `thenUgn` \ sf -> + mkSrcLocUgn srcline $ \ src_loc -> + wlkContext cbindc `thenUgn` \ ctxt -> + wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) -> + wlkBinding cbindw `thenUgn` \ binding -> + getSrcFileUgn `thenUgn` \ sf -> let - (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding - - final_sigs = concat (map cvClassOpSig class_sigs) - final_methods = cvMonoBinds sf class_methods + (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding in returnUgn (RdrClassDecl - (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc)) + (mkClassDecl ctxt clas tyvars final_sigs final_methods noClassPragmas src_loc)) -- "instance" declaration - U_ibind ibindc iclas ibindi ibindw srcline -> + U_ibind ty ibindw srcline -> + -- The "ty" contains the instance context too + -- So for "instance Eq a => Eq [a]" the type will be + -- Eq a => Eq [a] mkSrcLocUgn srcline $ \ src_loc -> - wlkContext ibindc `thenUgn` \ ctxt -> - wlkQid iclas `thenUgn` \ clas -> - wlkMonoType ibindi `thenUgn` \ inst_ty -> - wlkBinding ibindw `thenUgn` \ binding -> - getSrcModUgn `thenUgn` \ modname -> - getSrcFileUgn `thenUgn` \ sf -> + wlkInstType ty `thenUgn` \ inst_ty -> + wlkBinding ibindw `thenUgn` \ binding -> + getSrcModUgn `thenUgn` \ modname -> + getSrcFileUgn `thenUgn` \ sf -> let - (ss, bs) = sepDeclsIntoSigsAndBinds binding - binds = cvMonoBinds sf bs - uprags = concat (map cvInstDeclSig ss) - ctxt_inst_ty = HsPreForAllTy ctxt inst_ty - maybe_mod = if opt_CompilingPrelude - then Nothing - else Just modname + (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding in returnUgn (RdrInstDecl - (InstDecl clas ctxt_inst_ty binds True maybe_mod uprags noInstancePragmas src_loc)) + (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc)) -- "default" declaration U_dbind dbindts srcline -> @@ -583,7 +610,7 @@ wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName]) wlkDerivings (U_nothing) = returnUgn Nothing wlkDerivings (U_just pt) = rdU_list pt `thenUgn` \ ds -> - wlkList rdQid ds `thenUgn` \ derivs -> + wlkList rdTCId ds `thenUgn` \ derivs -> returnUgn (Just derivs) \end{code} @@ -591,55 +618,49 @@ wlkDerivings (U_just pt) -- type signature wlk_sig_thing (U_sbind sbindids sbindid srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkList rdQid sbindids `thenUgn` \ vars -> - wlkPolyType sbindid `thenUgn` \ poly_ty -> + wlkList rdVarId sbindids `thenUgn` \ vars -> + wlkHsType sbindid `thenUgn` \ poly_ty -> returnUgn (RdrTySig vars poly_ty src_loc) -- value specialisation user-pragma wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid uvar `thenUgn` \ var -> + wlkVarId uvar `thenUgn` \ var -> wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids -> returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc | (ty, using_id) <- tys_and_ids ]) where - rd_ty_and_id :: ParseTree -> UgnM (RdrNamePolyType, Maybe RdrName) + rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName) rd_ty_and_id pt = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) -> - wlkPolyType vspec_ty `thenUgn` \ ty -> - wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe -> + wlkHsType vspec_ty `thenUgn` \ ty -> + wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe -> returnUgn(ty, id_maybe) -- instance specialisation user-pragma wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid iclas `thenUgn` \ clas -> + wlkTCId iclas `thenUgn` \ clas -> wlkMonoType ispec_ty `thenUgn` \ ty -> returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc)) -- data specialisation user-pragma wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid itycon `thenUgn` \ tycon -> + wlkTCId itycon `thenUgn` \ tycon -> wlkList rdMonoType dspec_tys `thenUgn` \ tys -> - returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc)) + returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc)) -- value inlining user-pragma wlk_sig_thing (U_inline_uprag ivar srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ivar `thenUgn` \ var -> + wlkVarId ivar `thenUgn` \ var -> returnUgn (RdrInlineValSig (InlineSig var src_loc)) - -- "deforest me" user-pragma -wlk_sig_thing (U_deforest_uprag ivar srcline) - = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ivar `thenUgn` \ var -> - returnUgn (RdrDeforestSig (DeforestSig var src_loc)) - -- "magic" unfolding user-pragma wlk_sig_thing (U_magicuf_uprag ivar str srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ivar `thenUgn` \ var -> + wlkVarId ivar `thenUgn` \ var -> returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc)) \end{code} @@ -650,16 +671,16 @@ wlk_sig_thing (U_magicuf_uprag ivar str srcline) %************************************************************************ \begin{code} -rdPolyType :: ParseTree -> UgnM RdrNamePolyType -rdMonoType :: ParseTree -> UgnM RdrNameMonoType +rdHsType :: ParseTree -> UgnM RdrNameHsType +rdMonoType :: ParseTree -> UgnM RdrNameHsType -rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype +rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype -wlkPolyType :: U_ttype -> UgnM RdrNamePolyType -wlkMonoType :: U_ttype -> UgnM RdrNameMonoType +wlkHsType :: U_ttype -> UgnM RdrNameHsType +wlkMonoType :: U_ttype -> UgnM RdrNameHsType -wlkPolyType ttype +wlkHsType ttype = case ttype of U_context tcontextl tcontextt -> -- context wlkContext tcontextl `thenUgn` \ ctxt -> @@ -672,76 +693,81 @@ wlkPolyType ttype wlkMonoType ttype = case ttype of + -- Glasgow extension: nested polymorhism + U_context tcontextl tcontextt -> -- context + wlkContext tcontextl `thenUgn` \ ctxt -> + wlkMonoType tcontextt `thenUgn` \ ty -> + returnUgn (HsPreForAllTy ctxt ty) + U_namedtvar tv -> -- type variable - wlkQid tv `thenUgn` \ tyvar -> + wlkTvId tv `thenUgn` \ tyvar -> returnUgn (MonoTyVar tyvar) U_tname tcon -> -- type constructor - wlkQid tcon `thenUgn` \ tycon -> - returnUgn (MonoTyApp tycon []) + wlkTCId tcon `thenUgn` \ tycon -> + returnUgn (MonoTyVar tycon) U_tapp t1 t2 -> + wlkMonoType t1 `thenUgn` \ ty1 -> wlkMonoType t2 `thenUgn` \ ty2 -> - collect t1 [ty2] `thenUgn` \ (tycon, tys) -> - returnUgn (MonoTyApp tycon tys) - where - collect t acc - = case t of - U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 -> - collect t1 (ty2:acc) - U_tname tcon -> wlkQid tcon `thenUgn` \ tycon -> - returnUgn (tycon, acc) - U_namedtvar tv -> wlkQid tv `thenUgn` \ tyvar -> - returnUgn (tyvar, acc) - U_tllist _ -> panic "tlist" - U_ttuple _ -> panic "ttuple" - U_tfun _ _ -> panic "tfun" - U_tbang _ -> panic "tbang" - U_context _ _ -> panic "context" - _ -> panic "something else" + returnUgn (MonoTyApp ty1 ty2) U_tllist tlist -> -- list type wlkMonoType tlist `thenUgn` \ ty -> - returnUgn (MonoListTy ty) + returnUgn (MonoListTy dummyRdrTcName ty) U_ttuple ttuple -> wlkList rdMonoType ttuple `thenUgn` \ tys -> - returnUgn (MonoTupleTy tys) + returnUgn (MonoTupleTy dummyRdrTcName tys) U_tfun tfun targ -> wlkMonoType tfun `thenUgn` \ ty1 -> wlkMonoType targ `thenUgn` \ ty2 -> returnUgn (MonoFunTy ty1 ty2) +wlkInstType ttype + = case ttype of + U_context tcontextl tcontextt -> -- context + wlkContext tcontextl `thenUgn` \ ctxt -> + wlkConAndTys tcontextt `thenUgn` \ (clas, tys) -> + returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys)) + + other -> -- something else + wlkConAndTys other `thenUgn` \ (clas, tys) -> + returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys)) \end{code} \begin{code} -wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName]) -wlkContext :: U_list -> UgnM RdrNameContext -wlkClassAssertTy :: U_ttype -> UgnM (RdrName, RdrName) - -wlkTyConAndTyVars ttype - = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) -> +wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName]) +wlkConAndTyVars ttype + = wlkMonoType ttype `thenUgn` \ ty -> let - args = [ a | (MonoTyVar a) <- ty_args ] + split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args) + split (MonoTyVar tycon) args = (tycon,args) + split other args = pprPanic "ERROR: malformed type: " + (ppr other) in - returnUgn (tycon, args) + returnUgn (split ty []) + -wlkContext list - = wlkList rdMonoType list `thenUgn` \ tys -> - returnUgn (map mk_class_assertion tys) +wlkContext :: U_list -> UgnM RdrNameContext +rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName]) -wlkClassAssertTy xs - = wlkMonoType xs `thenUgn` \ mono_ty -> - returnUgn (mk_class_assertion mono_ty) +wlkContext list = wlkList rdConAndTys list -mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName) +rdConAndTys pt + = rdU_ttype pt `thenUgn` \ ttype -> + wlkConAndTys ttype -mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname) -mk_class_assertion other - = pprError "ERROR: malformed type context: " (ppr PprForUser other) - -- regrettably, the parser does let some junk past - -- e.g., f :: Num {-nothing-} => a -> ... +wlkConAndTys ttype + = wlkMonoType ttype `thenUgn` \ ty -> + let + split (MonoTyApp fun ty) tys = split fun (ty : tys) + split (MonoTyVar tycon) tys = (tycon, tys) + split other tys = pprPanic "ERROR: malformed type: " + (ppr other) + in + returnUgn (split ty []) \end{code} \begin{code} @@ -752,35 +778,40 @@ rdConDecl pt wlkConDecl :: U_constr -> UgnM RdrNameConDecl +wlkConDecl (U_constrcxt ccxt ccdecl) + = wlkContext ccxt `thenUgn` \ theta -> + wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) -> + returnUgn (ConDecl con theta details loc) + wlkConDecl (U_constrpre ccon ctys srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ccon `thenUgn` \ con -> + wlkDataId ccon `thenUgn` \ con -> wlkList rdBangType ctys `thenUgn` \ tys -> - returnUgn (ConDecl con tys src_loc) + returnUgn (ConDecl con [] (VanillaCon tys) src_loc) wlkConDecl (U_constrinf cty1 cop cty2 srcline) = mkSrcLocUgn srcline $ \ src_loc -> wlkBangType cty1 `thenUgn` \ ty1 -> - wlkQid cop `thenUgn` \ op -> + wlkDataId cop `thenUgn` \ op -> wlkBangType cty2 `thenUgn` \ ty2 -> - returnUgn (ConOpDecl ty1 op ty2 src_loc) + returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc) wlkConDecl (U_constrnew ccon cty srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ccon `thenUgn` \ con -> + wlkDataId ccon `thenUgn` \ con -> wlkMonoType cty `thenUgn` \ ty -> - returnUgn (NewConDecl con ty src_loc) + returnUgn (ConDecl con [] (NewCon ty) src_loc) wlkConDecl (U_constrrec ccon cfields srcline) = mkSrcLocUgn srcline $ \ src_loc -> - wlkQid ccon `thenUgn` \ con -> + wlkDataId ccon `thenUgn` \ con -> wlkList rd_field cfields `thenUgn` \ fields_lists -> - returnUgn (RecConDecl con fields_lists src_loc) + returnUgn (ConDecl con [] (RecCon fields_lists) src_loc) where rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName) rd_field pt = rdU_constr pt `thenUgn` \ (U_field fvars fty) -> - wlkList rdQid fvars `thenUgn` \ vars -> + wlkList rdVarId fvars `thenUgn` \ vars -> wlkBangType fty `thenUgn` \ ty -> returnUgn (vars, ty) @@ -790,9 +821,9 @@ rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty wlkBangType :: U_ttype -> UgnM (BangType RdrName) wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> - returnUgn (Banged (HsPreForAllTy [] ty)) + returnUgn (Banged ty) wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> - returnUgn (Unbanged (HsPreForAllTy [] ty)) + returnUgn (Unbanged ty) \end{code} %************************************************************************ @@ -809,7 +840,7 @@ rdMatch pt mkSrcLocUgn srcline $ \ src_loc -> wlkPat gpat `thenUgn` \ pat -> wlkBinding gbind `thenUgn` \ binding -> - wlkQid gsrcfun `thenUgn` \ srcfun -> + wlkVarId gsrcfun `thenUgn` \ srcfun -> let wlk_guards (U_pnoguards exp) = wlkExpr exp `thenUgn` \ expr -> @@ -823,7 +854,7 @@ rdMatch pt where rd_gd_expr pt = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) -> - wlkExpr g `thenUgn` \ guard -> + wlkQuals g `thenUgn` \ guard -> wlkExpr e `thenUgn` \ expr -> returnUgn (guard, expr) \end{code} @@ -839,12 +870,14 @@ rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl rdFixOp pt = rdU_tree pt `thenUgn` \ fix -> case fix of - U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op -> - returnUgn (InfixL op prec) - U_fixop op 0 prec -> wlkQid op `thenUgn` \ op -> - returnUgn (InfixN op prec) - U_fixop op 1 prec -> wlkQid op `thenUgn` \ op -> - returnUgn (InfixR op prec) + U_fixop op dir_n prec srcline -> wlkVarId op `thenUgn` \ op -> + mkSrcLocUgn srcline $ \ src_loc -> + returnUgn (FixityDecl op (Fixity prec dir) src_loc) + where + dir = case dir_n of + (-1) -> InfixL + 0 -> InfixN + 1 -> InfixR _ -> error "ReadPrefix:rdFixOp" \end{code} @@ -859,11 +892,11 @@ rdImport :: ParseTree -> UgnM RdrNameImportDecl rdImport pt - = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) -> + = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) -> mkSrcLocUgn srcline $ \ src_loc -> wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as -> wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec -> - returnUgn (ImportDecl imod (cvFlag iqual) maybe_as maybe_spec src_loc) + returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc) where rd_spec pt = rdU_either pt `thenUgn` \ spec -> case spec of @@ -871,6 +904,9 @@ rdImport pt returnUgn (False, ents) U_right pt -> rdEntities pt `thenUgn` \ ents -> returnUgn (True, ents) + +cvIfaceFlavour 0 = HiFile -- No pragam +cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-} \end{code} \begin{code} @@ -884,21 +920,21 @@ rdEntity pt = rdU_entidt pt `thenUgn` \ entity -> case entity of U_entid evar -> -- just a value - wlkQid evar `thenUgn` \ var -> + wlkEntId evar `thenUgn` \ var -> returnUgn (IEVar var) U_enttype x -> -- abstract type constructor/class - wlkQid x `thenUgn` \ thing -> + wlkTCId x `thenUgn` \ thing -> returnUgn (IEThingAbs thing) U_enttypeall x -> -- non-abstract type constructor/class - wlkQid x `thenUgn` \ thing -> + wlkTCId x `thenUgn` \ thing -> returnUgn (IEThingAll thing) U_enttypenamed x ns -> -- non-abstract type constructor/class -- with specified constrs/methods - wlkQid x `thenUgn` \ thing -> - wlkList rdQid ns `thenUgn` \ names -> + wlkTCId x `thenUgn` \ thing -> + wlkList rdVarId ns `thenUgn` \ names -> returnUgn (IEThingWith thing names) U_entmod mod -> -- everything provided unqualified by a module