-- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import Maybes ( maybeToBool )
-import ErrUtils ( Message )
-import CStrings ( isCLabelString )
import ListSetOps ( removeDupsEq )
\end{code}
= rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) ->
returnRn (RuleD new_rule, fvs)
+rnSourceDecl (ForD ford)
+ = rnHsForeignDecl ford `thenRn` \ (new_ford, fvs) ->
+ returnRn (ForD new_ford, fvs)
+
rnSourceDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) ->
returnRn (DefD (DefaultDecl tys' src_loc), fvs)
where
- doc_str = text "a `default' declaration"
+ doc_str = text "In a `default' declaration"
+\end{code}
-rnSourceDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn name `thenRn` \ name' ->
- let
- extra_fvs FoExport
- | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR,
- bindIO_RDR, returnIO_RDR]
- | otherwise =
- lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
- returnRn (addOneFV fvs name')
- extra_fvs other = returnRn emptyFVs
- in
- checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
- extra_fvs imp_exp `thenRn` \ fvs1 ->
+%*********************************************************
+%* *
+\subsection{Foreign declarations}
+%* *
+%*********************************************************
- rnHsTypeFVs fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
- returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
- fvs1 `plusFV` fvs2)
- where
- fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name
- isDyn = isDynamicExtName ext_nm
+\begin{code}
+rnHsForeignDecl (ForeignImport name ty spec src_loc)
+ = pushSrcLocRn src_loc $
+ lookupOccRn name `thenRn` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
+ lookupOrigNames (extras spec) `thenRn` \ fvs2 ->
+ returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+ where
+ extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR]
+ extras other = []
+
+rnHsForeignDecl (ForeignExport name ty spec src_loc)
+ = pushSrcLocRn src_loc $
+ lookupOccRn name `thenRn` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
+ lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 ->
+ returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
- ok_ext_nm Dynamic = True
- ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
- ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
+fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
\end{code}
-- Used for both source decls only
= ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
let
- meth_doc = text "the bindings in an instance declaration"
+ meth_doc = text "In the bindings in an instance declaration"
meth_names = collectLocatedMonoBinders mbinds
inst_tyvars = case inst_ty of
HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars
returnRn (HsRule rule_name sig_tvs' vars' lhs' rhs' src_loc,
fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
where
- doc = text "the transformation rule" <+> ptext rule_name
+ doc = text "In the transformation rule" <+> ptext rule_name
sig_tvs = extractRuleBndrsTyVars vars
get_var (RuleBndr v) = v
mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
returnRn (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
where
- doc_str = text "the interface signature for" <+> quotes (ppr name)
+ doc_str = text "In the interface signature for" <+> quotes (ppr name)
+
+rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
+ = pushSrcLocRn loc $
+ lookupTopBndrRn name `thenRn` \ name' ->
+ returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
rnContext data_doc context `thenRn` \ context' ->
checkDupOrQualNames data_doc con_names `thenRn_`
+
+ -- Check that there's at least one condecl,
+ -- or else we're reading an interface file, or -fglasgow-exts
+ (if null condecls then
+ doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
+ getModeRn `thenRn` \ mode ->
+ checkRn (glaExts || isInterfaceMode mode)
+ (emptyConDeclsErr tycon)
+ else returnRn ()
+ ) `thenRn_`
+
mapRn rnConDecl condecls `thenRn` \ condecls' ->
mapRn lookupSysBinder sys_names `thenRn` \ sys_names' ->
returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'})
where
- data_doc = text "the data type declaration for" <+> quotes (ppr tycon)
+ data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map conDeclName condecls
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
where
- syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
+ syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
-- For H98 we do *not* universally quantify on the RHS of a synonym
-- Silently discard context... but the tyvars in the rest won't be in scope
tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
tcdSysNames = names', tcdLoc = src_loc})
where
- cls_doc = text "the declaration for class" <+> ppr cname
- sig_doc = text "the signatures for class" <+> ppr cname
+ cls_doc = text "In the declaration for class" <+> ppr cname
+ sig_doc = text "In the signatures for class" <+> ppr cname
rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op dm_stuff ty locn)
= pushSrcLocRn locn $
rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
returnRn (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
where
- meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
+ meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl)
finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
- -- Not a class declaration
+ -- Not a class or data type declaration
\end{code}
rnConDetails doc locn details `thenRn` \ new_details ->
returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn)
where
- doc = text "the definition of data constructor" <+> quotes (ppr name)
+ doc = text "In the definition of data constructor" <+> quotes (ppr name)
rnConDetails doc locn (VanillaCon tys)
= mapRn (rnBangTy doc) tys `thenRn` \ new_tys ->
rnBangTy doc ty `thenRn` \ new_ty ->
returnRn (new_names, new_ty)
-rnBangTy doc (Banged ty)
+rnBangTy doc (BangType s ty)
= rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Banged new_ty)
-
-rnBangTy doc (Unbanged ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Unbanged new_ty)
-
-rnBangTy doc (Unpacked ty)
- = rnHsType doc ty `thenRn` \ new_ty ->
- returnRn (Unpacked new_ty)
+ returnRn (BangType s new_ty)
-- This data decl will parse OK
-- data T = a Int
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
- = rnHsType (text "the type signature for" <+> doc_str) ty
+ = rnHsType (text "In the type signature for" <+> doc_str) ty
---------------------------------------
rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType
rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
rnIdInfo (HsArity arity) = returnRn (HsArity arity)
rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs
-rnIdInfo HsCprInfo = returnRn HsCprInfo
\end{code}
@UfCore@ expressions.
= rnHsType (text "litlit") ty `thenRn` \ ty' ->
returnRn (UfLitLit l ty')
-rnCoreExpr (UfCCall cc ty)
+rnCoreExpr (UfFCall cc ty)
= rnHsType (text "ccall") ty `thenRn` \ ty' ->
- returnRn (UfCCall cc ty')
+ returnRn (UfFCall cc ty')
rnCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
= mapRn rnCoreExpr args `thenRn` \ args' ->
sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
$$
- (ptext SLIT("In") <+> doc)
+ doc
)
}
ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
ptext SLIT("does not appear on left hand side")]
-badExtName :: ExtName -> Message
-badExtName ext_nm
- = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
-
dupClassAssertWarn ctxt (assertion : dups)
= sep [hsep [ptext SLIT("Duplicate class assertion"),
quotes (ppr assertion),
naughtyCCallContextErr (HsClassP clas _)
= sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
ptext SLIT("in a context")]
+emptyConDeclsErr tycon
+ = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
+ nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
\end{code}
projects / ghc-hetmet.git / blobdiff