%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section{Read parse tree built by Yacc parser}
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 PrefixToHs
+import CallConv
-import CmdLineOpts ( opt_NoImplicitPrelude )
-import FiniteMap ( elemFM, FiniteMap )
-import Name ( OccName(..), Module )
-import Lex ( isLexConId )
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts )
+import Name ( OccName(..), Module, isLexConId )
import Outputable
import PrelMods ( pRELUDE )
-import Util ( nOfThem )
import FastString ( mkFastCharString )
-import IO ( hPutStr, stderr )
import PrelRead ( readRational__ )
\end{code}
\end{code}
\begin{code}
-wlkTvId = wlkQid TvOcc
wlkTCId = wlkQid TCOcc
wlkVarId = wlkQid VarOcc
wlkDataId = wlkQid VarOcc
| otherwise
= returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
-rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
+
+rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
+rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
+wlkTvId string = returnUgn (Unqual (TvOcc string))
+
cvFlag :: U_long -> Bool
cvFlag 0 = False
cvFlag 1 = True
let
val_decl = ValD (cvBinds srcfile cvValSig binding)
+ for_decls = cvForeignDecls binding
other_decls = cvOtherDecls binding
in
returnUgn (modname,
exports
imports
fixities
- (val_decl: other_decls)
+ (for_decls ++ val_decl: other_decls)
src_loc
)
\end{code}
U_restr restre restrt -> -- expression with type signature
wlkExpr restre `thenUgn` \ expr ->
- wlkHsType restrt `thenUgn` \ ty ->
+ wlkHsSigType restrt `thenUgn` \ ty ->
returnUgn (ExprWithTySig expr ty)
--------------------------------------------------------------
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 ->
wlkList rdRbind rbinds `thenUgn` \ recbinds ->
- returnUgn (RecordCon rcon (HsVar rcon) recbinds)
+ returnUgn (RecordCon rcon recbinds)
U_rupdate updexp updbinds -> -- record update
wlkExpr updexp `thenUgn` \ aexp ->
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 ->
U_nbind nbindid nbindas srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
- wlkMonoType nbindas `thenUgn` \ expansion ->
+ wlkHsType nbindas `thenUgn` \ expansion ->
returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
-- function binding
wlkList rdMonoType dbindts `thenUgn` \ tys ->
returnUgn (RdrDefaultDecl (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 ->
+ wlkHsType 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 (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
+
a_sig_we_hope ->
-- signature(-like) things, including user pragmas
wlk_sig_thing a_sig_we_hope
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)
+ wlkHsSigType sbindid `thenUgn` \ poly_ty ->
+ returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
-- 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 ])
+ returnUgn (foldr1 RdrAndBindings [ RdrSig (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 ->
+ wlkHsSigType 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))
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkHsSigType ispec_ty `thenUgn` \ ty ->
+ returnUgn (RdrSig (SpecInstSig ty 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))
+ returnUgn (RdrSig (InlineSig var src_loc))
- -- "magic" unfolding user-pragma
-wlk_sig_thing (U_magicuf_uprag ivar str srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
+wlk_sig_thing (U_noinline_uprag ivar srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
+ returnUgn (RdrSig (NoInlineSig var src_loc))
\end{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
+rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
+rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
+
+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 [] [] 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)
-
-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_forall u_tyvars u_theta u_ty -> -- context
+ wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
+ wlkContext u_theta `thenUgn` \ theta ->
+ wlkHsType u_ty `thenUgn` \ ty ->
+ returnUgn (HsForAllTy (map UserTyVar tyvars) theta ty)
U_namedtvar tv -> -- type variable
wlkTvId tv `thenUgn` \ tyvar ->
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_context tcontextl tcontextt -> -- context
- wlkContext tcontextl `thenUgn` \ ctxt ->
- wlkConAndTys tcontextt `thenUgn` \ (clas, tys) ->
- returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys))
+ U_forall u_tyvars u_theta inst_head ->
+ wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
+ wlkContext u_theta `thenUgn` \ theta ->
+ wlkConAndTys inst_head `thenUgn` \ (clas, tys) ->
+ returnUgn (HsForAllTy (map UserTyVar tyvars) theta (MonoDictTy clas tys))
other -> -- something else
wlkConAndTys other `thenUgn` \ (clas, tys) ->
- returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys))
+ returnUgn (HsForAllTy [] [] (MonoDictTy clas tys))
\end{code}
\begin{code}
-wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
+wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
wlkConAndTyVars ttype
- = wlkMonoType ttype `thenUgn` \ ty ->
+ = wlkHsType ttype `thenUgn` \ ty ->
let
split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
split (MonoTyVar tycon) args = (tycon,args)
wlkConAndTys ttype
wlkConAndTys ttype
- = wlkMonoType ttype `thenUgn` \ ty ->
+ = wlkHsType ttype `thenUgn` \ ty ->
let
split (MonoTyApp fun ty) tys = split fun (ty : tys)
split (MonoTyVar tycon) tys = (tycon, tys)
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)
+ wlkHsSigType cty `thenUgn` \ ty ->
+ returnUgn (ConDecl con [] [] (NewCon ty) 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)
+ returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
where
rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
rd_field pt
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}
returnUgn (IEModuleContents 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}
projects / ghc-hetmet.git / blobdiff