\begin{code}
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
- DefaultDecl(..), ForeignDecl(..), ForKind(..),
- ExtName(..), isDynamicExtName, extNameStatic,
+ DefaultDecl(..),
+ ForeignDecl(..), FoImport(..), FoExport(..), FoType(..),
ConDecl(..), ConDetails(..),
BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt,
- hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames,
+ hsDeclName, instDeclName,
+ tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys
eq_ufBinders, eq_ufExpr, pprUfExpr
)
import CoreSyn ( CoreRule(..) )
-import BasicTypes ( NewOrData(..) )
-import Demand ( StrictnessMark(..) )
-import CallConv ( CallConv, pprCallConv )
+import BasicTypes ( NewOrData(..), StrictnessMark(..) )
+import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )
-- others:
import Name ( NamedThing )
import FunDeps ( pprFundeps )
import Class ( FunDep, DefMeth(..) )
-import CStrings ( CLabelString, pprCLabelString )
+import CStrings ( CLabelString )
import Outputable
+import Util ( eqListBy )
import SrcLoc ( SrcLoc )
+import FastString
\end{code}
hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
=> HsDecl name pat -> name
#endif
-hsDeclName (TyClD decl) = tyClDeclName decl
-hsDeclName (InstD decl) = instDeclName decl
-hsDeclName (ForD (ForeignDecl name _ _ _ _ _)) = name
-hsDeclName (FixD (FixitySig name _ _)) = name
+hsDeclName (TyClD decl) = tyClDeclName decl
+hsDeclName (InstD decl) = instDeclName decl
+hsDeclName (ForD decl) = forDeclName decl
+hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
\begin{code}
+-- TyClDecls are precisely the kind of declarations that can
+-- appear in interface files; or (internally) in GHC's interface
+-- for a module. That's why (despite the misnomer) IfaceSig and ForeignType
+-- are both in TyClDecl
+
data TyClDecl name pat
= IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature
- tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. These three
- tcdIdInfo :: [HsIdInfo name], -- are the kind that appear in interface files.
+ tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient.
+ tcdIdInfo :: [HsIdInfo name],
tcdLoc :: SrcLoc
}
+ | ForeignType { tcdName :: name, -- See remarks about IfaceSig above
+ tcdExtName :: Maybe FastString,
+ tcdFoType :: FoType,
+ tcdLoc :: SrcLoc }
+
| TyData { tcdND :: NewOrData,
tcdCtxt :: HsContext name, -- context
tcdName :: name, -- type constructor
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names
-tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
-tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
+tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)]
+tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)]
+tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)]
tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
= (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
= (tc_name,loc) : conDeclsNames cons
+tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ForeignType {}) = []
+tyClDeclTyVars (IfaceSig {}) = []
+
+
--------------------------------
-- The "system names" are extra implicit names *bound* by the decl.
-- They are kept in a list rather than a tuple
tcdType d1 == tcdType d2 &&
tcdIdInfo d1 == tcdIdInfo d2
+ (==) d1@(ForeignType {}) d2@(ForeignType {})
+ = tcdName d1 == tcdName d2 &&
+ tcdFoType d1 == tcdFoType d2
+
(==) d1@(TyData {}) d2@(TyData {})
= tcdName d1 == tcdName d2 &&
tcdND d1 == tcdND d2 &&
ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
= hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
+ ppr (ForeignType {tcdName = tycon})
+ = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
+
ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
= hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
4 (ppr mono_ty)
ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons,
tcdDerivs = derivings})
- = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
+ = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars)
(pp_condecls condecls ncons)
derivings
where
pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
pp_condecls [] ncons = ptext SLIT("{- abstract with") <+> int ncons <+> ptext SLIT("constructors -}")
-pp_condecls (c:cs) ncons = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
+pp_condecls (c:cs) ncons = equals <+> sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
pp_tydecl pp_head pp_decl_rhs derivings
= hang pp_head 4 (sep [
= ppr con <+> hsep (map (ppr_bang) tys)
ppr_con_details con (RecCon fields)
- = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
+ = ppr con <+> braces (sep (punctuate comma (map ppr_field fields)))
where
ppr_field (ns, ty) = hsep (map (ppr) ns) <+>
dcolon <+>
%************************************************************************
\begin{code}
-data ForeignDecl name =
- ForeignDecl
- name
- ForKind
- (HsType name)
- ExtName
- CallConv
- SrcLoc
-
-instance (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 <+> dcolon <+> 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 CLabelString -- The external name of the foreign thing,
- (Maybe CLabelString) -- and optionally its DLL or module name
- -- Both of these are completely unencoded;
- -- we just print them as they are
-
-isDynamicExtName :: ExtName -> Bool
-isDynamicExtName Dynamic = True
-isDynamicExtName _ = False
-
-extNameStatic :: ExtName -> CLabelString
-extNameStatic (ExtName f _) = f
-extNameStatic Dynamic = panic "staticExtName: Dynamic - shouldn't ever happen."
-
-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 (pprCLabelString nm)
+data ForeignDecl name
+ = ForeignImport name (HsType name) FoImport SrcLoc
+ | ForeignExport name (HsType name) FoExport SrcLoc
+
+forDeclName (ForeignImport n _ _ _) = n
+forDeclName (ForeignExport n _ _ _) = n
+
+data FoImport
+ = LblImport CLabelString -- foreign label
+ | CImport CCallSpec -- foreign import
+ | CDynImport CCallConv -- foreign export dynamic
+ | DNImport DNCallSpec -- foreign import dotnet
+
+data FoExport = CExport CExportSpec
+
+data FoType = DNType -- In due course we'll add subtype stuff
+ deriving( Eq ) -- Used for equality instance for TyClDecl
+
+instance Outputable name => Outputable (ForeignDecl name) where
+ ppr (ForeignImport nm ty (LblImport lbl) src_loc)
+ = ptext SLIT("foreign label") <+> ppr lbl <+> ppr nm <+> dcolon <+> ppr ty
+ ppr (ForeignImport nm ty decl src_loc)
+ = ptext SLIT("foreign import") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
+ ppr (ForeignExport nm ty decl src_loc)
+ = ptext SLIT("foreign export") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
+
+instance Outputable FoImport where
+ ppr (CImport d) = ppr d
+ ppr (CDynImport conv) = text "dynamic" <+> ppr conv
+ ppr (DNImport d) = ptext SLIT("dotnet") <+> ppr d
+ ppr (LblImport l) = ptext SLIT("label") <+> ppr l
+
+instance Outputable FoExport where
+ ppr (CExport d) = ppr d
+
+instance Outputable FoType where
+ ppr DNType = ptext SLIT("type dotnet")
\end{code}
+
%************************************************************************
%* *
\subsection{Transformation rules}
projects / ghc-hetmet.git / blobdiff