X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsDecls.lhs;h=5789d7824f780e9178d2745d58e4b5eb0fe011d3;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=4503e05c9571d2c18bcd5b5e5aed9c00096890ff;hpb=2c8f04b5b883db74f449dfc8c224929fe28b027d;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 4503e05..5789d78 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -1,10 +1,10 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsDecls]{Abstract syntax: global declarations} Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@, -@InstDecl@, @DefaultDecl@. +@InstDecl@, @DefaultDecl@ and @ForeignDecl@. \begin{code} module HsDecls where @@ -17,11 +17,12 @@ import HsPragmas ( DataPragmas, ClassPragmas ) import HsTypes import HsCore ( UfExpr ) import BasicTypes ( Fixity, NewOrData(..) ) -import IdInfo ( ArgUsageInfo, FBTypeInfo, ArityInfo, UpdateInfo ) +import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo ) import Demand ( Demand ) +import CallConv ( CallConv, pprCallConv ) -- others: -import Name ( getOccName, OccName, NamedThing(..) ) +import Name ( NamedThing ) import Outputable import SrcLoc ( SrcLoc ) import Util @@ -42,6 +43,7 @@ data HsDecl flexi name pat | DefD (DefaultDecl name) | ValD (HsBinds flexi name pat) | SigD (IfaceSig name) + | ForD (ForeignDecl name) \end{code} \begin{code} @@ -54,6 +56,7 @@ hsDeclName (TyD (TySynonym name _ _ _)) = name hsDeclName (ClD (ClassDecl _ name _ _ _ _ _ _ _)) = name hsDeclName (SigD (IfaceSig name _ _ _)) = name hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name +hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name -- Others don't make sense #ifdef DEBUG hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) @@ -70,6 +73,7 @@ instance (NamedThing name, Outputable name, Outputable pat) ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def ppr (InstD inst) = ppr inst + ppr (ForD fd) = ppr fd #ifdef DEBUG -- hsDeclName needs more context when DEBUG is on @@ -141,7 +145,7 @@ instance (NamedThing name, Outputable name) ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc) = pp_tydecl - (pp_decl_head keyword (pp_context_and_arrow context) tycon tyvars) + (pp_decl_head keyword (pprContext context) tycon tyvars) (pp_condecls condecls) derivings where @@ -164,10 +168,6 @@ pp_tydecl pp_head pp_decl_rhs derivings Nothing -> empty Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)] ]) - -pp_context_and_arrow :: Outputable name => Context name -> SDoc -pp_context_and_arrow [] = empty -pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")] \end{code} A type for recording what types a datatype should be specialised to. @@ -196,7 +196,11 @@ instance (NamedThing name, Outputable name) \begin{code} data ConDecl name = ConDecl name -- Constructor name - (Context name) -- Existential context for this constructor + + [HsTyVar name] -- Existentially quantified type variables + (Context name) -- ...and context + -- If both are empty then there are no existentials + (ConDetails name) SrcLoc @@ -221,8 +225,8 @@ data BangType name \begin{code} instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where - ppr (ConDecl con cxt con_details loc) - = pp_context_and_arrow cxt <+> ppr_con_details con con_details + ppr (ConDecl con tvs cxt con_details loc) + = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) = hsep [ppr_bang ty1, ppr con, ppr_bang ty2] @@ -277,14 +281,14 @@ instance (NamedThing name, Outputable name, Outputable pat) ppr methods, char '}'])] where - top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow context, + top_matter = hsep [ptext SLIT("class"), pprContext context, ppr clas, hsep (map (ppr) tyvars)] ppr_sig sig = ppr sig <> semi \end{code} %************************************************************************ %* * -\subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)} +\subsection[InstDecl]{An instance declaration %* * %************************************************************************ @@ -317,21 +321,6 @@ instance (NamedThing name, Outputable name, Outputable pat) nest 4 (ppr binds) ] \end{code} -A type for recording what instances the user wants to specialise; -called a ``Sig'' because it's sort of like a ``type signature'' for an -instance. -\begin{code} -data SpecInstSig name - = SpecInstSig name -- class - (HsType name) -- type to specialise to - SrcLoc - -instance (NamedThing name, Outputable name) - => Outputable (SpecInstSig name) where - - ppr (SpecInstSig clas ty _) - = hsep [text "{-# SPECIALIZE instance", ppr clas, ppr ty, text "#-}"] -\end{code} %************************************************************************ %* * @@ -357,6 +346,59 @@ instance (NamedThing name, Outputable name) %************************************************************************ %* * +\subsection{Foreign function interface declaration} +%* * +%************************************************************************ + +\begin{code} +data ForeignDecl name = + ForeignDecl + name + ForKind + (HsType name) + ExtName + CallConv + SrcLoc + +instance (NamedThing name, Outputable name) + => Outputable (ForeignDecl name) where + + ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc) + = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+> + ppr ext_name <+> ppr_unsafe <+> ppr nm <+> ptext SLIT("::") <+> ppr ty + where + (ppr_imp_exp, ppr_unsafe) = + case imp_exp of + FoLabel -> (ptext SLIT("label"), empty) + FoExport -> (ptext SLIT("export"), empty) + FoImport us + | us -> (ptext SLIT("import"), ptext SLIT("unsafe")) + | otherwise -> (ptext SLIT("import"), empty) + +data ForKind + = FoLabel + | FoExport + | FoImport Bool -- True => unsafe call. + +data ExtName + = Dynamic + | ExtName FAST_STRING (Maybe FAST_STRING) + +isDynamic :: ExtName -> Bool +isDynamic Dynamic = True +isDynamic _ = False + + +instance Outputable ExtName where + ppr Dynamic = ptext SLIT("dynamic") + ppr (ExtName nm mb_mod) = + case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+> + doubleQuotes (ptext nm) + +\end{code} + +%************************************************************************ +%* * \subsection{Signatures in interface files} %* * %************************************************************************ @@ -376,11 +418,10 @@ instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where data HsIdInfo name = HsArity ArityInfo | HsStrictness (HsStrictnessInfo name) - | HsUnfold Bool (UfExpr name) -- True <=> INLINE pragma + | HsUnfold InlinePragInfo (Maybe (UfExpr name)) | HsUpdate UpdateInfo - | HsArgUsage ArgUsageInfo - | HsFBType FBTypeInfo | HsSpecialise [HsTyVar name] [HsType name] (UfExpr name) + | HsNoCafRefs data HsStrictnessInfo name