X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Freader%2FReadPrefix.lhs;h=7e0dadd31429e692d0955cfa43eb6b3efb62bd20;hb=6ee2f67e582427f931c21c1fc58f62f8619d40b7;hp=6f724093a3ec47eb6b2db1512acfcce7f8eac2b3;hpb=2ca47382b67e317058f79b6bbbdf44a35822e650;p=ghc-hetmet.git diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 6f72409..7e0dadd 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -1,154 +1,89 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1998 % \section{Read parse tree built by Yacc parser} \begin{code} -#include "HsVersions.h" - module ReadPrefix ( rdModule ) where -IMP_Ubiq() -IMPORT_1_3(IO(hPutStr, stderr)) -#if __GLASGOW_HASKELL__ == 201 -import GHCio(stThen) -#elif __GLASGOW_HASKELL__ >= 202 -import GlaExts -import IOBase -import PrelRead -#endif +#include "HsVersions.h" import UgenAll -- all Yacc parser gumpff... import PrefixSyn -- and various syntaxen. import HsSyn import HsTypes ( HsTyVar(..) ) -import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas ) +import HsPragmas ( noDataPragmas, noClassPragmas ) import RdrHsSyn -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) ) +import PrelMods ( pRELUDE_Name ) import PrefixToHs - -import CmdLineOpts ( opt_PprUserLength ) -import ErrUtils ( addErrLoc, ghcExit ) -import FiniteMap ( elemFM, FiniteMap ) -import Name ( OccName(..), SYN_IE(Module) ) -import Lex ( isLexConId ) -import Outputable ( Outputable(..), PprStyle(..) ) -import PrelMods ( pRELUDE ) -import Pretty -import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc ) -import Util ( nOfThem, pprError, panic ) +import CallConv + +import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts, opt_D_dump_rdr ) +import Module ( ModuleName, mkSrcModuleFS, WhereFrom(..) ) +import OccName ( NameSpace, tcName, clsName, tcClsName, varName, dataName, tvName, + isLexCon + ) +import RdrName ( RdrName, isRdrDataCon, mkSrcQual, mkSrcUnqual, mkPreludeQual, + dummyRdrVarName + ) +import Outputable +import ErrUtils ( dumpIfSet ) +import SrcLoc ( SrcLoc ) +import FastString ( mkFastCharString ) +import PrelRead ( readRational__ ) \end{code} %************************************************************************ %* * -\subsection[ReadPrefix-help]{Help Functions} +\subsection[rdModule]{@rdModule@: reads in a Haskell module} %* * %************************************************************************ \begin{code} -wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a] - -wlkList wlk_it U_lnil = returnUgn [] - -wlkList wlk_it (U_lcons hd tl) - = wlk_it hd `thenUgn` \ hd_it -> - wlkList wlk_it tl `thenUgn` \ tl_it -> - returnUgn (hd_it : tl_it) -\end{code} - -\begin{code} -wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a) - -wlkMaybe wlk_it U_nothing = returnUgn Nothing -wlkMaybe wlk_it (U_just x) - = wlk_it x `thenUgn` \ it -> - returnUgn (Just it) -\end{code} - -\begin{code} -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 (noqual) A.x --- unqualified name (aqual) 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. - -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) - = 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 +rdModule :: IO (ModuleName, -- this module's name + RdrNameHsModule) -- the main goods -cvFlag :: U_long -> Bool -cvFlag 0 = False -cvFlag 1 = True -\end{code} +rdModule + = -- call the Yacc parser! + _ccall_ hspmain >>= \ pt -> -%************************************************************************ -%* * -\subsection[rdModule]{@rdModule@: reads in a Haskell module} -%* * -%************************************************************************ + -- Read from the Yacc tree + initUgn (read_module pt) >>= \ (mod_name, rdr_module) -> -\begin{code} -#if __GLASGOW_HASKELL__ == 201 -# define PACK_STR packCString -#elif __GLASGOW_HASKELL__ >= 202 -# define PACK_STR mkFastCharString -#else -# define PACK_STR mkFastCharString -#endif + -- Dump if reqd + dumpIfSet opt_D_dump_rdr "Reader" + (ppr rdr_module) >> -rdModule :: IO (Module, -- this module's name - RdrNameHsModule) -- the main goods + -- And return + return (mod_name, rdr_module) -rdModule - = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser! +read_module :: ParseTree -> UgnM (ModuleName, RdrNameHsModule) +read_module pt + = rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist + hmodlist srciface_version srcline) -> let - srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM) + srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM) + mod_name = mkSrcModuleFS mod_fs in - initUgn $ - rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist - hmodlist srciface_version srcline) -> - setSrcFileUgn srcfile $ - setSrcModUgn modname $ - mkSrcLocUgn srcline $ \ src_loc -> + setSrcFileUgn srcfile $ + mkSrcLocUgn srcline $ \ src_loc -> wlkMaybe rdEntities hexplist `thenUgn` \ exports -> wlkList rdImport himplist `thenUgn` \ imports -> - wlkList rdFixOp hfixlist `thenUgn` \ fixities -> wlkBinding hmodlist `thenUgn` \ binding -> let - val_decl = ValD (cvBinds srcfile cvValSig binding) - other_decls = cvOtherDecls binding + top_decls = cvTopDecls srcfile binding + rdr_module = HsModule mod_name + (case srciface_version of { 0 -> Nothing; n -> Just n }) + exports + imports + top_decls + src_loc in - returnUgn (modname, - HsModule modname - (case srciface_version of { 0 -> Nothing; n -> Just n }) - exports - imports - fixities - (val_decl: other_decls) - src_loc - ) + returnUgn (mod_name, rdr_module) \end{code} %************************************************************************ @@ -161,8 +96,8 @@ rdModule rdExpr :: ParseTree -> UgnM RdrNameHsExpr rdPat :: ParseTree -> UgnM RdrNamePat -rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree -rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree +rdExpr pt = rdU_tree pt `thenUgn` wlkExpr +rdPat pt = rdU_tree pt `thenUgn` wlkPat wlkExpr :: U_tree -> UgnM RdrNameHsExpr wlkPat :: U_tree -> UgnM RdrNamePat @@ -197,27 +132,15 @@ wlkExpr expr wlkExpr sccexp `thenUgn` \ expr -> returnUgn (HsSCC label expr) - U_lambda lampats lamexpr srcline -> -- lambda expression - mkSrcLocUgn srcline $ \ src_loc -> - wlkList rdPat lampats `thenUgn` \ pats -> - wlkExpr lamexpr `thenUgn` \ body -> - returnUgn ( - HsLam (foldr PatMatch - (GRHSMatch (GRHSsAndBindsIn - [OtherwiseGRHS body src_loc] - EmptyBinds)) - pats) - ) + U_lambda match -> -- lambda expression + wlkMatch match `thenUgn` \ match' -> + returnUgn (HsLam match') U_casee caseexpr casebody srcline -> -- case expression mkSrcLocUgn srcline $ \ src_loc -> wlkExpr caseexpr `thenUgn` \ expr -> wlkList rdMatch casebody `thenUgn` \ mats -> - getSrcFileUgn `thenUgn` \ sf -> - let - matches = cvMatches sf True mats - in - returnUgn (HsCase expr matches src_loc) + returnUgn (HsCase expr mats src_loc) U_ife ifpred ifthen ifelse srcline -> -- if expression mkSrcLocUgn srcline $ \ src_loc -> @@ -227,13 +150,9 @@ wlkExpr expr returnUgn (HsIf e1 e2 e3 src_loc) U_let letvdefs letvexpr -> -- let expression - wlkBinding letvdefs `thenUgn` \ binding -> - wlkExpr letvexpr `thenUgn` \ expr -> - getSrcFileUgn `thenUgn` \ sf -> - let - binds = cvBinds sf cvValSig binding - in - returnUgn (HsLet binds expr) + wlkLocalBinding letvdefs `thenUgn` \ binding -> + wlkExpr letvexpr `thenUgn` \ expr -> + returnUgn (HsLet binding expr) U_doe gdo srcline -> -- do expression mkSrcLocUgn srcline $ \ src_loc -> @@ -255,11 +174,7 @@ wlkExpr expr returnUgn (BindStmt patt expr src_loc) U_seqlet seqlet -> - wlkBinding seqlet `thenUgn` \ bs -> - getSrcFileUgn `thenUgn` \ sf -> - let - binds = cvBinds sf cvValSig bs - in + wlkLocalBinding seqlet `thenUgn` \ binds -> returnUgn (LetStmt binds) U_comprh cexp cquals -> -- list comprehension @@ -281,7 +196,7 @@ wlkExpr expr U_restr restre restrt -> -- expression with type signature wlkExpr restre `thenUgn` \ expr -> - wlkHsType restrt `thenUgn` \ ty -> + wlkHsSigType restrt `thenUgn` \ ty -> returnUgn (ExprWithTySig expr ty) -------------------------------------------------------------- @@ -319,7 +234,11 @@ wlkExpr expr U_tuple tuplelist -> -- explicit tuple wlkList rdExpr tuplelist `thenUgn` \ exprs -> - returnUgn (ExplicitTuple exprs) + returnUgn (ExplicitTuple exprs True) + + U_utuple tuplelist -> -- explicit tuple + wlkList rdExpr tuplelist `thenUgn` \ exprs -> + returnUgn (ExplicitTuple exprs False) U_record con rbinds -> -- record construction wlkDataId con `thenUgn` \ rcon -> @@ -332,17 +251,15 @@ wlkExpr expr returnUgn (RecordUpd aexp recbinds) #ifdef DEBUG - U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule" + U_hmodule _ _ _ _ _ _ -> error "U_hmodule" U_as _ _ -> error "U_as" U_lazyp _ -> error "U_lazyp" - U_wildp -> error "U_wildp" U_qual _ _ -> error "U_qual" U_guard _ -> error "U_guard" U_seqlet _ -> error "U_seqlet" U_dobind _ _ _ -> error "U_dobind" U_doexp _ _ -> error "U_doexp" U_rbind _ _ -> error "U_rbind" - U_fixop _ _ _ -> error "U_fixop" #endif rdRbind pt @@ -376,20 +293,13 @@ wlkQuals cquals returnUgn (BindStmt pat expr loc) U_seqlet seqlet -> - wlkBinding seqlet `thenUgn` \ bs -> - getSrcFileUgn `thenUgn` \ sf -> - let - binds = cvBinds sf cvValSig bs - in + wlkLocalBinding seqlet `thenUgn` \ binds -> 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 + wlkLocalBinding letvdefs `thenUgn` \ binds -> + wlkExpr letvexpr `thenUgn` \ expr -> + getSrcLocUgn `thenUgn` \ loc -> returnUgn (GuardStmt (HsLet binds expr) loc) \end{code} @@ -413,6 +323,11 @@ wlkPat pat wlkPat as_pat `thenUgn` \ pat -> returnUgn (AsPatIn var pat) + U_restr pat ty -> + wlkPat pat `thenUgn` \ pat' -> + wlkHsType ty `thenUgn` \ ty' -> + returnUgn (SigPatIn pat' ty') + U_lazyp lazyp -> -- irrefutable ("twiddle") pattern wlkPat lazyp `thenUgn` \ pat -> returnUgn (LazyPatIn pat) @@ -422,18 +337,19 @@ wlkPat pat wlkLiteral lit `thenUgn` \ lit -> returnUgn (NPlusKPatIn var lit) - U_wildp -> returnUgn WildPatIn -- wildcard pattern - U_lit lit -> -- literal pattern wlkLiteral lit `thenUgn` \ lit -> returnUgn (LitPatIn lit) - U_ident nn -> -- simple identifier + U_ident (U_noqual s) | s == SLIT("_")-> returnUgn WildPatIn -- Wild-card pattern + + U_ident nn -> -- simple identifier wlkVarId nn `thenUgn` \ n -> returnUgn ( - case rdrNameOcc n of - VarOcc occ | isLexConId occ -> ConPatIn n [] - other -> VarPatIn n + if isRdrDataCon n then + ConPatIn n [] + else + VarPatIn n ) U_ap l r -> -- "application": there's a list of patterns lurking here! @@ -444,22 +360,8 @@ wlkPat pat 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 -> hsep (map (ppr sty) (lpat:lpats))) - msg = show (err (PprForUser opt_PprUserLength)) - in -#if __GLASGOW_HASKELL__ == 201 - ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ -> - ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ -> -#elif __GLASGOW_HASKELL__ >= 202 - ioToUgnM (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ -> - ioToUgnM (IOBase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ -> -#else - ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ -> - ioToUgnM (ghcExit 1) `thenUgn` \ _ -> -#endif - returnUgn (error "ReadPrefix") + pprPanic "Illegal pattern `application'" + (ppr loc <> colon <+> hsep (map ppr (lpat:lpats))) ) `thenUgn` \ (n, arg_pats) -> returnUgn (ConPatIn n arg_pats) @@ -469,6 +371,8 @@ wlkPat pat U_ap l r -> wlkPat r `thenUgn` \ rpat -> collect_pats l (rpat:acc) + U_par l -> + collect_pats l acc other -> wlkPat other `thenUgn` \ pat -> returnUgn (pat,acc) @@ -489,7 +393,11 @@ wlkPat pat U_tuple tuplelist -> -- explicit tuple wlkList rdPat tuplelist `thenUgn` \ pats -> - returnUgn (TuplePatIn pats) + returnUgn (TuplePatIn pats True) + + U_utuple tuplelist -> -- explicit tuple + wlkList rdPat tuplelist `thenUgn` \ pats -> + returnUgn (TuplePatIn pats False) U_record con rpats -> -- record destruction wlkDataId con `thenUgn` \ rcon -> @@ -527,16 +435,8 @@ wlkLiteral ulit where as_char s = _HEAD_ s as_integer s = readInteger (_UNPK_ s) -#if __GLASGOW_HASKELL__ == 201 - as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std -#elif __GLASGOW_HASKELL__ == 202 - as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a } -#elif __GLASGOW_HASKELL__ >= 203 as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__ -- to handle rationals with leading '-' -#else - as_rational s = _readRational (_UNPK_ s) -- non-std -#endif as_string s = s \end{code} @@ -547,6 +447,11 @@ wlkLiteral ulit %************************************************************************ \begin{code} +wlkLocalBinding bind + = wlkBinding bind `thenUgn` \ bind' -> + getSrcFileUgn `thenUgn` \ sf -> + returnUgn (cvBinds sf cvValSig bind') + wlkBinding :: U_binding -> UgnM RdrBinding wlkBinding binding @@ -561,81 +466,188 @@ wlkBinding binding wlkBinding b `thenUgn` \ binding2 -> returnUgn (RdrAndBindings binding1 binding2) + -- fixity declaration + U_fixd op dir_n prec srcline -> + let + dir = case dir_n of + (-1) -> InfixL + 0 -> InfixN + 1 -> InfixR + in + wlkVarId op `thenUgn` \ op -> + mkSrcLocUgn srcline $ \ src_loc -> + returnUgn (RdrSig (FixSig (FixitySig op (Fixity prec dir) src_loc))) + + -- "data" declaration 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 DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc)) + returnUgn (RdrHsDecl (TyClD (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) -> + wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) -> wlkList rdConDecl ntcon `thenUgn` \ cons -> wlkDerivings ntderivs `thenUgn` \ derivings -> - returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc)) + returnUgn (RdrHsDecl (TyClD (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) -> - wlkMonoType nbindas `thenUgn` \ expansion -> - returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc)) + wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) -> + wlkHsType nbindas `thenUgn` \ expansion -> + returnUgn (RdrHsDecl (TyClD (TySynonym tycon tyvars expansion src_loc))) -- function binding - U_fbind fbindl srcline -> + U_fbind fbindm srcline -> mkSrcLocUgn srcline $ \ src_loc -> - wlkList rdMatch fbindl `thenUgn` \ matches -> - returnUgn (RdrFunctionBinding srcline matches) + wlkList rdMatch fbindm `thenUgn` \ matches -> + returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc)) -- pattern binding - U_pbind pbindl srcline -> - mkSrcLocUgn srcline $ \ src_loc -> - wlkList rdMatch pbindl `thenUgn` \ matches -> - returnUgn (RdrPatternBinding srcline matches) + U_pbind pbindl pbindr srcline -> + mkSrcLocUgn srcline $ \ src_loc -> + rdPat pbindl `thenUgn` \ pat -> + rdGRHSs pbindr `thenUgn` \ grhss -> + returnUgn (RdrValBinding (PatMonoBind pat grhss src_loc)) -- "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 (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding in - returnUgn (RdrClassDecl - (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc)) + returnUgn (RdrHsDecl (TyClD (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 -> - wlkTCId iclas `thenUgn` \ clas -> - wlkMonoType ibindi `thenUgn` \ at_ty -> - wlkBinding ibindw `thenUgn` \ binding -> - getSrcModUgn `thenUgn` \ modname -> - getSrcFileUgn `thenUgn` \ sf -> + wlkInstType ty `thenUgn` \ inst_ty -> + wlkBinding ibindw `thenUgn` \ binding -> + getSrcFileUgn `thenUgn` \ sf -> let (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding - inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty) in - returnUgn (RdrInstDecl - (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc)) + returnUgn (RdrHsDecl (InstD (InstDecl inst_ty binds uprags + dummyRdrVarName {- No dfun id yet -} + src_loc))) -- "default" declaration U_dbind dbindts srcline -> mkSrcLocUgn srcline $ \ src_loc -> wlkList rdMonoType dbindts `thenUgn` \ tys -> - returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc)) + returnUgn (RdrHsDecl (DefD (DefaultDecl tys src_loc))) + + -- "foreign" declaration + U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline -> + mkSrcLocUgn srcline $ \ src_loc -> + wlkVarId id `thenUgn` \ h_id -> + wlkHsSigType ty `thenUgn` \ h_ty -> + wlkExtName ext_name `thenUgn` \ h_ext_name -> + rdCallConv cconv `thenUgn` \ h_cconv -> + rdForKind imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp -> + returnUgn (RdrHsDecl (ForD (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))) + + U_sbind sbindids sbindid srcline -> + -- Type signature + mkSrcLocUgn srcline $ \ src_loc -> + wlkList rdVarId sbindids `thenUgn` \ vars -> + wlkHsSigType sbindid `thenUgn` \ poly_ty -> + returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars]) + + U_vspec_uprag uvar vspec_tys srcline -> + -- value specialisation user-pragma + mkSrcLocUgn srcline $ \ src_loc -> + wlkVarId uvar `thenUgn` \ var -> + wlkList rdHsSigType vspec_tys `thenUgn` \ tys -> + returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty src_loc) + | ty <- tys ]) + + U_ispec_uprag ispec_ty srcline -> + -- instance specialisation user-pragma + mkSrcLocUgn srcline $ \ src_loc -> + wlkInstType ispec_ty `thenUgn` \ ty -> + returnUgn (RdrSig (SpecInstSig ty src_loc)) + + U_inline_uprag ivar srcline -> + -- value inlining user-pragma + mkSrcLocUgn srcline $ \ src_loc -> + wlkVarId ivar `thenUgn` \ var -> + returnUgn (RdrSig (InlineSig var src_loc)) + + U_noinline_uprag ivar srcline -> + -- No-inline pragma + mkSrcLocUgn srcline $ \ src_loc -> + wlkVarId ivar `thenUgn` \ var -> + returnUgn (RdrSig (NoInlineSig var src_loc)) + + U_rule_prag name ivars ilhs irhs srcline -> + -- Transforamation rule + mkSrcLocUgn srcline $ \ src_loc -> + wlkList rdRuleBndr ivars `thenUgn` \ vars -> + rdExpr ilhs `thenUgn` \ lhs -> + rdExpr irhs `thenUgn` \ rhs -> + returnUgn (RdrHsDecl (RuleD (RuleDecl name [] vars lhs rhs src_loc))) + +mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds +mkRdrFunctionBinding fun_matches src_loc + = FunMonoBind (head fns) (head infs) matches src_loc + where + (fns, infs, matches) = unzip3 (map de_fun_match fun_matches) + + de_fun_match (Match _ [ConPatIn fn pats] sig grhss) = (fn, False, Match [] pats sig grhss) + de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True, Match [] [p1,p2] sig grhss) + + +rdRuleBndr :: ParseTree -> UgnM RdrNameRuleBndr +rdRuleBndr pt = rdU_rulevar pt `thenUgn` wlkRuleBndr + +wlkRuleBndr :: U_rulevar -> UgnM RdrNameRuleBndr +wlkRuleBndr (U_prulevar v) + = returnUgn (RuleBndr (mkSrcUnqual varName v)) +wlkRuleBndr (U_prulevarsig v ty) + = wlkHsType ty `thenUgn` \ ty' -> + returnUgn (RuleBndrSig (mkSrcUnqual varName v) ty') + - a_sig_we_hope -> - -- signature(-like) things, including user pragmas - wlk_sig_thing a_sig_we_hope + +rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs +rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs + +wlkGRHSs :: U_grhsb -> UgnM RdrNameGRHSs +wlkGRHSs (U_pguards rhss bind) + = wlkList rdGdExp rhss `thenUgn` \ gdexps -> + wlkLocalBinding bind `thenUgn` \ bind' -> + returnUgn (GRHSs gdexps bind' Nothing) +wlkGRHSs (U_pnoguards srcline rhs bind) + = mkSrcLocUgn srcline $ \ src_loc -> + rdExpr rhs `thenUgn` \ rhs' -> + wlkLocalBinding bind `thenUgn` \ bind' -> + returnUgn (GRHSs (unguardedRHS rhs' src_loc) bind' Nothing) + + +rdGdExp :: ParseTree -> UgnM RdrNameGRHS +rdGdExp pt = rdU_gdexp pt `thenUgn` \ (U_pgdexp guards srcline rhs) -> + wlkQuals guards `thenUgn` \ guards' -> + mkSrcLocUgn srcline $ \ src_loc -> + wlkExpr rhs `thenUgn` \ expr' -> + returnUgn (GRHS (guards' ++ [ExprStmt expr' src_loc]) src_loc) \end{code} \begin{code} @@ -648,56 +660,6 @@ wlkDerivings (U_just pt) returnUgn (Just derivs) \end{code} -\begin{code} - -- type signature -wlk_sig_thing (U_sbind sbindids sbindid srcline) - = mkSrcLocUgn srcline $ \ src_loc -> - 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 -> - 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 (RdrNameHsType, Maybe RdrName) - rd_ty_and_id pt - = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) -> - 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 -> - 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 -> - wlkTCId itycon `thenUgn` \ tycon -> - wlkList rdMonoType dspec_tys `thenUgn` \ tys -> - 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 -> - wlkVarId ivar `thenUgn` \ var -> - returnUgn (RdrInlineValSig (InlineSig var src_loc)) - - -- "magic" unfolding user-pragma -wlk_sig_thing (U_magicuf_uprag ivar str srcline) - = mkSrcLocUgn srcline $ \ src_loc -> - wlkVarId ivar `thenUgn` \ var -> - returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc)) -\end{code} - %************************************************************************ %* * \subsection[wlkTypes]{Reading in types in various forms (and data constructors)} @@ -705,147 +667,175 @@ wlk_sig_thing (U_magicuf_uprag ivar str srcline) %************************************************************************ \begin{code} -rdHsType :: ParseTree -> UgnM RdrNameHsType -rdMonoType :: ParseTree -> UgnM RdrNameHsType - -rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype -rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype +rdHsSigType :: ParseTree -> UgnM RdrNameHsType +rdHsType :: ParseTree -> UgnM RdrNameHsType +rdMonoType :: ParseTree -> UgnM RdrNameHsType + +rdHsSigType pt = rdU_ttype pt `thenUgn` wlkHsSigType +rdHsType pt = rdU_ttype pt `thenUgn` wlkHsType +rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType + +wlkHsConstrArgType ttype + -- Used for the argument types of contructors + -- Only an implicit quantification point if -fglasgow-exts + | opt_GlasgowExts = wlkHsSigType ttype + | otherwise = wlkHsType ttype + + -- wlkHsSigType is used for type signatures: any place there + -- should be *implicit* quantification +wlkHsSigType ttype + = wlkHsType ttype `thenUgn` \ ty -> + -- This is an implicit quantification point, so + -- make sure it starts with a ForAll + case ty of + HsForAllTy _ _ _ -> returnUgn ty + other -> returnUgn (HsForAllTy Nothing [] ty) wlkHsType :: U_ttype -> UgnM RdrNameHsType -wlkMonoType :: U_ttype -> UgnM RdrNameHsType - wlkHsType ttype = case ttype of - U_context tcontextl tcontextt -> -- context - wlkContext tcontextl `thenUgn` \ ctxt -> - wlkMonoType tcontextt `thenUgn` \ ty -> - returnUgn (HsPreForAllTy ctxt ty) - - other -> -- something else - wlkMonoType other `thenUgn` \ ty -> - returnUgn (HsPreForAllTy [{-no context-}] ty) + U_forall u_tyvars u_theta u_ty -> -- Explicit forall + wlkList rdTvId u_tyvars `thenUgn` \ tyvars -> + wlkContext u_theta `thenUgn` \ theta -> + wlkHsType u_ty `thenUgn` \ ty -> + returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta ty) -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_imp_forall u_theta u_ty -> -- Implicit forall + wlkContext u_theta `thenUgn` \ theta -> + wlkHsType u_ty `thenUgn` \ ty -> + returnUgn (HsForAllTy Nothing theta ty) U_namedtvar tv -> -- type variable wlkTvId tv `thenUgn` \ tyvar -> returnUgn (MonoTyVar tyvar) U_tname tcon -> -- type constructor - wlkTCId tcon `thenUgn` \ tycon -> + wlkTcId tcon `thenUgn` \ tycon -> returnUgn (MonoTyVar tycon) U_tapp t1 t2 -> - wlkMonoType t1 `thenUgn` \ ty1 -> - wlkMonoType t2 `thenUgn` \ ty2 -> + wlkHsType t1 `thenUgn` \ ty1 -> + wlkHsType t2 `thenUgn` \ ty2 -> returnUgn (MonoTyApp ty1 ty2) U_tllist tlist -> -- list type - wlkMonoType tlist `thenUgn` \ ty -> - returnUgn (MonoListTy dummyRdrTcName ty) + wlkHsType tlist `thenUgn` \ ty -> + returnUgn (MonoListTy ty) U_ttuple ttuple -> wlkList rdMonoType ttuple `thenUgn` \ tys -> - returnUgn (MonoTupleTy dummyRdrTcName tys) + returnUgn (MonoTupleTy tys True) + + U_tutuple ttuple -> + wlkList rdMonoType ttuple `thenUgn` \ tys -> + returnUgn (MonoTupleTy tys False) U_tfun tfun targ -> - wlkMonoType tfun `thenUgn` \ ty1 -> - wlkMonoType targ `thenUgn` \ ty2 -> + wlkHsType tfun `thenUgn` \ ty1 -> + wlkHsType targ `thenUgn` \ ty2 -> returnUgn (MonoFunTy ty1 ty2) +wlkInstType ttype + = case ttype of + U_forall u_tyvars u_theta inst_head -> + wlkList rdTvId u_tyvars `thenUgn` \ tyvars -> + wlkContext u_theta `thenUgn` \ theta -> + wlkClsTys inst_head `thenUgn` \ (clas, tys) -> + returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta (MonoDictTy clas tys)) + + U_imp_forall u_theta inst_head -> + wlkContext u_theta `thenUgn` \ theta -> + wlkClsTys inst_head `thenUgn` \ (clas, tys) -> + returnUgn (HsForAllTy Nothing theta (MonoDictTy clas tys)) + + other -> -- something else + wlkClsTys other `thenUgn` \ (clas, tys) -> + returnUgn (HsForAllTy Nothing [] (MonoDictTy clas tys)) \end{code} \begin{code} -wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName]) -wlkContext :: U_list -> UgnM RdrNameContext -wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName) - -wlkTyConAndTyVars ttype - = wlkMonoType ttype `thenUgn` \ ty -> +wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName]) +wlkConAndTyVars ttype + = wlkHsType ttype `thenUgn` \ ty -> let 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 (split ty []) -wlkContext list - = wlkList rdMonoType list `thenUgn` \ tys -> - returnUgn (map mk_class_assertion tys) -wlkClassAssertTy xs - = wlkMonoType xs `thenUgn` \ mono_ty -> - returnUgn (case mk_class_assertion mono_ty of - (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar) - ) +wlkContext :: U_list -> UgnM RdrNameContext +rdClsTys :: ParseTree -> UgnM (RdrName, [HsType RdrName]) -mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType) +wlkContext list = wlkList rdClsTys list -mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty) -mk_class_assertion other - = pprError "ERROR: malformed type context: " (ppr (PprForUser opt_PprUserLength) other) - -- regrettably, the parser does let some junk past - -- e.g., f :: Num {-nothing-} => a -> ... +rdClsTys pt = rdU_ttype pt `thenUgn` wlkClsTys + +wlkClsTys ttype + = go ttype [] + where + go (U_tname tcon) tys = wlkClsId tcon `thenUgn` \ cls -> + returnUgn (cls, tys) + + go (U_tapp t1 t2) tys = wlkHsType t2 `thenUgn` \ ty2 -> + go t1 (ty2 : tys) \end{code} \begin{code} rdConDecl :: ParseTree -> UgnM RdrNameConDecl -rdConDecl pt - = rdU_constr pt `thenUgn` \ blah -> - wlkConDecl blah +rdConDecl pt = rdU_constr pt `thenUgn` wlkConDecl 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_constrex u_tvs ccxt ccdecl) + = wlkList rdTvId u_tvs `thenUgn` \ tyvars -> + wlkContext ccxt `thenUgn` \ theta -> + wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ _ details loc) -> + returnUgn (ConDecl con (map UserTyVar tyvars) theta details loc) wlkConDecl (U_constrpre ccon ctys srcline) = mkSrcLocUgn srcline $ \ src_loc -> wlkDataId ccon `thenUgn` \ con -> wlkList rdBangType ctys `thenUgn` \ tys -> - returnUgn (ConDecl con [] (VanillaCon 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 -> wlkDataId cop `thenUgn` \ op -> wlkBangType cty2 `thenUgn` \ ty2 -> - returnUgn (ConDecl op [] (InfixCon ty1 ty2) src_loc) + returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc) -wlkConDecl (U_constrnew ccon cty srcline) - = mkSrcLocUgn srcline $ \ src_loc -> - wlkDataId ccon `thenUgn` \ con -> - wlkMonoType cty `thenUgn` \ ty -> - returnUgn (ConDecl con [] (NewCon ty) src_loc) +wlkConDecl (U_constrnew ccon cty mb_lab srcline) + = mkSrcLocUgn srcline $ \ src_loc -> + wlkDataId ccon `thenUgn` \ con -> + wlkHsSigType cty `thenUgn` \ ty -> + wlkMaybe rdVarId mb_lab `thenUgn` \ mb_lab -> + returnUgn (ConDecl con [] [] (NewCon ty mb_lab) src_loc) wlkConDecl (U_constrrec ccon cfields srcline) = mkSrcLocUgn srcline $ \ src_loc -> wlkDataId ccon `thenUgn` \ con -> wlkList rd_field cfields `thenUgn` \ fields_lists -> - returnUgn (ConDecl con [] (RecCon fields_lists) src_loc) - where + 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 rdVarId fvars `thenUgn` \ vars -> - wlkBangType fty `thenUgn` \ ty -> - returnUgn (vars, ty) + rd_field pt = + rdU_constr pt `thenUgn` \ (U_field fvars fty) -> + wlkList rdVarId fvars `thenUgn` \ vars -> + wlkBangType fty `thenUgn` \ ty -> + returnUgn (vars, ty) ----------------- -rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty +rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType wlkBangType :: U_ttype -> UgnM (BangType RdrName) -wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> +wlkBangType (U_tbang bty) = wlkHsConstrArgType bty `thenUgn` \ ty -> returnUgn (Banged ty) -wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> +wlkBangType uty = wlkHsConstrArgType uty `thenUgn` \ ty -> returnUgn (Unbanged ty) \end{code} @@ -856,52 +846,15 @@ wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> %************************************************************************ \begin{code} -rdMatch :: ParseTree -> UgnM RdrMatch - -rdMatch pt - = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) -> - mkSrcLocUgn srcline $ \ src_loc -> - wlkPat gpat `thenUgn` \ pat -> - wlkBinding gbind `thenUgn` \ binding -> - wlkVarId gsrcfun `thenUgn` \ srcfun -> - let - wlk_guards (U_pnoguards exp) - = wlkExpr exp `thenUgn` \ expr -> - returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding) - - wlk_guards (U_pguards gs) - = wlkList rd_gd_expr gs `thenUgn` \ gd_exps -> - returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding) - in - wlk_guards gdexprs - where - rd_gd_expr pt - = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) -> - wlkQuals g `thenUgn` \ guard -> - wlkExpr e `thenUgn` \ expr -> - returnUgn (guard, expr) -\end{code} - -%************************************************************************ -%* * -\subsection[rdFixOp]{Read in a fixity declaration} -%* * -%************************************************************************ - -\begin{code} -rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl -rdFixOp pt - = rdU_tree pt `thenUgn` \ fix -> - case fix of - U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op -> - returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc) - -- ToDo: add SrcLoc! - where - dir = case dir_n of - (-1) -> InfixL - 0 -> InfixN - 1 -> InfixR - _ -> error "ReadPrefix:rdFixOp" +rdMatch :: ParseTree -> UgnM RdrNameMatch +rdMatch pt = rdU_match pt `thenUgn` wlkMatch + +wlkMatch :: U_match -> UgnM RdrNameMatch +wlkMatch (U_pmatch pats sig grhsb) + = wlkList rdPat pats `thenUgn` \ pats' -> + wlkMaybe rdHsType sig `thenUgn` \ maybe_ty -> + wlkGRHSs grhsb `thenUgn` \ grhss' -> + returnUgn (Match [] pats' maybe_ty grhss') \end{code} %************************************************************************ @@ -919,7 +872,11 @@ rdImport pt mkSrcLocUgn srcline $ \ src_loc -> wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as -> wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec -> - returnUgn (ImportDecl imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as maybe_spec src_loc) + returnUgn (ImportDecl (mkSrcModuleFS imod) + (cvImportSource isrc) + (cvFlag iqual) + (case maybe_as of { Just m -> Just (mkSrcModuleFS m); Nothing -> Nothing }) + maybe_spec src_loc) where rd_spec pt = rdU_either pt `thenUgn` \ spec -> case spec of @@ -928,14 +885,12 @@ rdImport pt U_right pt -> rdEntities pt `thenUgn` \ ents -> returnUgn (True, ents) -cvIfaceFlavour 0 = HiFile -- No pragam -cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-} +cvImportSource 0 = ImportByUser -- No pragam +cvImportSource 1 = ImportByUserSource -- {-# SOURCE #-} \end{code} \begin{code} -rdEntities pt - = rdU_list pt `thenUgn` \ list -> - wlkList rdEntity list +rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity rdEntity :: ParseTree -> UgnM (IE RdrName) @@ -943,24 +898,137 @@ rdEntity pt = rdU_entidt pt `thenUgn` \ entity -> case entity of U_entid evar -> -- just a value - wlkEntId evar `thenUgn` \ var -> + wlkEntId evar `thenUgn` \ var -> returnUgn (IEVar var) U_enttype x -> -- abstract type constructor/class - wlkTCId x `thenUgn` \ thing -> + wlkTcClsId x `thenUgn` \ thing -> returnUgn (IEThingAbs thing) U_enttypeall x -> -- non-abstract type constructor/class - wlkTCId x `thenUgn` \ thing -> + wlkTcClsId x `thenUgn` \ thing -> returnUgn (IEThingAll thing) U_enttypenamed x ns -> -- non-abstract type constructor/class -- with specified constrs/methods - wlkTCId x `thenUgn` \ thing -> + wlkTcClsId x `thenUgn` \ thing -> wlkList rdVarId ns `thenUgn` \ names -> returnUgn (IEThingWith thing names) U_entmod mod -> -- everything provided unqualified by a module - returnUgn (IEModuleContents mod) + returnUgn (IEModuleContents (mkSrcModuleFS mod)) +\end{code} + + +%************************************************************************ +%* * +\subsection[rdExtName]{Read an external name} +%* * +%************************************************************************ + +\begin{code} +wlkExtName :: U_maybe -> UgnM ExtName +wlkExtName (U_nothing) = returnUgn Dynamic +wlkExtName (U_just pt) + = rdU_list pt `thenUgn` \ ds -> + wlkList rdU_hstring ds `thenUgn` \ ss -> + case ss of + [nm] -> returnUgn (ExtName nm Nothing) + [mod,nm] -> returnUgn (ExtName nm (Just mod)) + +rdCallConv :: Int -> UgnM CallConv +rdCallConv x = + -- this tracks the #defines in parser/utils.h + case x of + (-1) -> -- no calling convention specified, use default. + returnUgn defaultCallConv + _ -> returnUgn x + +rdForKind :: Int -> Bool -> UgnM ForKind +rdForKind 0 isUnsafe = -- foreign import + returnUgn (FoImport isUnsafe) +rdForKind 1 _ = -- foreign export + returnUgn FoExport +rdForKind 2 _ = -- foreign label + returnUgn FoLabel + +\end{code} + +%************************************************************************ +%* * +\subsection[ReadPrefix-help]{Help Functions} +%* * +%************************************************************************ + +\begin{code} +wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a] + +wlkList wlk_it U_lnil = returnUgn [] + +wlkList wlk_it (U_lcons hd tl) + = wlk_it hd `thenUgn` \ hd_it -> + wlkList wlk_it tl `thenUgn` \ tl_it -> + returnUgn (hd_it : tl_it) +\end{code} + +\begin{code} +wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a) + +wlkMaybe wlk_it U_nothing = returnUgn Nothing +wlkMaybe wlk_it (U_just x) + = wlk_it x `thenUgn` \ it -> + returnUgn (Just it) +\end{code} + +\begin{code} +wlkTcClsId = wlkQid (\_ -> tcClsName) +wlkTcId = wlkQid (\_ -> tcName) +wlkClsId = wlkQid (\_ -> clsName) +wlkVarId = wlkQid (\occ -> if isLexCon occ + then dataName + else varName) +wlkDataId = wlkQid (\_ -> dataName) +wlkEntId = wlkQid (\occ -> if isLexCon occ + then tcClsName + else varName) + +wlkQid :: (FAST_STRING -> NameSpace) -> 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_name_space (U_noqual name) + = returnUgn (mkSrcUnqual (mk_name_space name) name) +wlkQid mk_name_space (U_aqual mod name) + = returnUgn (mkSrcQual (mk_name_space name) mod name) +wlkQid mk_name_space (U_gid n name) -- Built in Prelude things + | opt_NoImplicitPrelude + = returnUgn (mkSrcUnqual (mk_name_space name) name) + | otherwise + = returnUgn (mkPreludeQual (mk_name_space name) pRELUDE_Name name) + + +rdTCId pt = rdU_qid pt `thenUgn` wlkTcId +rdVarId pt = rdU_qid pt `thenUgn` wlkVarId + +rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string +wlkTvId string = returnUgn (mkSrcUnqual tvName string) + +-- Unqualified variables, used in the 'forall' of a RULE +rdUVarId pt = rdU_stringId pt `thenUgn` \ string -> wlkUVarId string +wlkUVarId string = returnUgn (mkSrcUnqual varName string) + +cvFlag :: U_long -> Bool +cvFlag 0 = False +cvFlag 1 = True \end{code}