X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsDecls.lhs;h=04b2af1ba381cdca29649f8334f4e07707ef0fad;hb=cb97b80de5d1596117e6c807741cda5a02e0b35d;hp=d6901889f6231b2d9ec04550e72517ea1a475175;hpb=1b471823339bc0bdbf3d1b6a64028f90c4ff1f77;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index d690188..04b2af1 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -9,12 +9,13 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, \begin{code} module HsDecls ( HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..), - DefaultDecl(..), ForeignDecl(..), ForKind(..), - ExtName(..), isDynamicExtName, extNameStatic, + DefaultDecl(..), + ForeignDecl(..), FoImport(..), FoExport(..), FoType(..), ConDecl(..), ConDetails(..), - BangType(..), getBangType, + 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 @@ -25,22 +26,27 @@ module HsDecls ( -- friends: import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) ) import HsExpr ( HsExpr ) +import HsImpExp ( ppr_var ) import HsTypes import PprCore ( pprCoreRule ) import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, eq_ufBinders, eq_ufExpr, pprUfExpr ) import CoreSyn ( CoreRule(..) ) -import BasicTypes ( NewOrData(..) ) -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 + +import Maybe ( isNothing, fromJust ) \end{code} @@ -80,10 +86,10 @@ data HsDecl name pat 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) @@ -247,13 +253,23 @@ Interface file code: \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 @@ -319,8 +335,9 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] -- 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] @@ -329,6 +346,13 @@ tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc}) = (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 @@ -371,6 +395,10 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where 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 && @@ -429,7 +457,13 @@ instance (NamedThing name, Outputable name, Outputable pat) => Outputable (TyClDecl name pat) where ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info}) - = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info] + = getPprStyle $ \ sty -> + hsep [ if ifaceStyle sty then ppr var else ppr_var 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) @@ -438,7 +472,7 @@ instance (NamedThing name, Outputable name, Outputable pat) 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 @@ -457,14 +491,17 @@ instance (NamedThing name, Outputable name, Outputable pat) where top_matter = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds ppr_sig sig = ppr sig <> semi + pp_methods = getPprStyle $ \ sty -> - if ifaceStyle sty then empty else ppr methods + if ifaceStyle sty || isNothing methods + then empty + else ppr (fromJust methods) pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc 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 [ @@ -556,19 +593,14 @@ eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2 \end{code} \begin{code} -data BangType name - = Banged (HsType name) -- HsType: to allow Haskell extensions - | Unbanged (HsType name) -- (MonoType only needed for straight Haskell) - | Unpacked (HsType name) -- Field is strict and to be unpacked if poss. - -getBangType (Banged ty) = ty -getBangType (Unbanged ty) = ty -getBangType (Unpacked ty) = ty - -eq_btype env (Banged t1) (Banged t2) = eq_hsType env t1 t2 -eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2 -eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2 -eq_btype env _ _ = False +data BangType name = BangType StrictnessMark (HsType name) + +getBangType (BangType _ ty) = ty +getBangStrictness (BangType s _) = s + +unbangedType ty = BangType NotMarkedStrict ty + +eq_btype env (BangType s1 t1) (BangType s2 t2) = s1==s2 && eq_hsType env t1 t2 \end{code} \begin{code} @@ -579,11 +611,17 @@ instance (Outputable name) => Outputable (ConDecl name) where ppr_con_details con (InfixCon ty1 ty2) = hsep [ppr_bang ty1, ppr con, ppr_bang ty2] +-- ConDecls generated by MkIface.ifaceTyCls always have a VanillaCon, even +-- if the constructor is an infix one. This is because in an interface file +-- we don't distinguish between the two. Hence when printing these for the +-- user, we need to parenthesise infix constructor names. ppr_con_details con (VanillaCon tys) - = ppr con <+> hsep (map (ppr_bang) tys) + = getPprStyle $ \ sty -> + hsep ((if ifaceStyle sty then ppr con else ppr_var con) + : 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 <+> @@ -592,9 +630,7 @@ ppr_con_details con (RecCon fields) instance Outputable name => Outputable (BangType name) where ppr = ppr_bang -ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty -ppr_bang (Unbanged ty) = pprParendHsType ty -ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty +ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty \end{code} @@ -675,57 +711,46 @@ instance (Outputable name) %************************************************************************ \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}