X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsDecls.lhs;h=036a427318de764afa667b73c7921f7233cd2e14;hb=a63bd8f558fedec86451f36d86833c9afb934ae8;hp=9160f4a03f798c14ff5a63547fe0362a6c2adfb6;hpb=1553c7788e7f663bfc55813158325d695a21a229;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 9160f4a..036a427 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -17,7 +17,8 @@ module HsDecls ( DeprecDecl(..), DeprecTxt, hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars, - isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls, + isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isCoreDecl, + isTypeOrClassDecl, countTyClDecls, mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName, getClassDeclSysNames, conDetailsTys, collectRuleBndrSigTys @@ -302,12 +303,19 @@ data TyClDecl name pat tcdSysNames :: ClassSysNames name, tcdLoc :: SrcLoc } + -- a Core value binding (coming from 'external Core' input.) + | CoreDecl { tcdName :: name, + tcdType :: HsType name, + tcdRhs :: UfExpr name, + tcdLoc :: SrcLoc + } + \end{code} Simple classifiers \begin{code} -isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool +isIfaceSigDecl, isCoreDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool isIfaceSigDecl (IfaceSig {}) = True isIfaceSigDecl other = False @@ -320,6 +328,16 @@ isDataDecl other = False isClassDecl (ClassDecl {}) = True isClassDecl other = False + +isTypeOrClassDecl (ClassDecl {}) = True +isTypeOrClassDecl (TyData {}) = True +isTypeOrClassDecl (TySynonym {}) = True +isTypeOrClassDecl (ForeignType {}) = True +isTypeOrClassDecl other = False + +isCoreDecl (CoreDecl {}) = True +isCoreDecl other = False + \end{code} Dealing with names @@ -338,6 +356,7 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)] +tyClDeclNames (CoreDecl {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc}) @@ -352,6 +371,7 @@ tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs tyClDeclTyVars (ForeignType {}) = [] tyClDeclTyVars (IfaceSig {}) = [] +tyClDeclTyVars (CoreDecl {}) = [] -------------------------------- @@ -396,6 +416,11 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where tcdType d1 == tcdType d2 && tcdIdInfo d1 == tcdIdInfo d2 + (==) d1@(CoreDecl {}) d2@(CoreDecl {}) + = tcdName d1 == tcdName d2 && + tcdType d1 == tcdType d2 && + tcdRhs d1 == tcdRhs d2 + (==) d1@(ForeignType {}) d2@(ForeignType {}) = tcdName d1 == tcdName d2 && tcdFoType d1 == tcdFoType d2 @@ -453,7 +478,7 @@ countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int) countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, - count isIfaceSigDecl decls, + count (\ x -> isIfaceSigDecl x || isCoreDecl x) decls, count isDataTy decls, count isNewTy decls) where @@ -470,9 +495,7 @@ instance (NamedThing name, Outputable name, Outputable pat) ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info}) = getPprStyle $ \ sty -> - hsep [ if ifaceStyle sty then ppr var else ppr_var var, - dcolon, ppr ty, pprHsIdInfo info - ] + hsep [ ppr_var var, dcolon, ppr ty, pprHsIdInfo info ] ppr (ForeignType {tcdName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] @@ -504,11 +527,14 @@ instance (NamedThing name, Outputable name, Outputable pat) 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 || isNothing methods + pp_methods = if isNothing methods then empty else ppr (fromJust methods) + ppr (CoreDecl {tcdName = var, tcdType = ty, tcdRhs = rhs}) + = getPprStyle $ \ sty -> + hsep [ ppr_var var, dcolon, ppr ty, ppr rhs ] + pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars] @@ -629,9 +655,7 @@ ppr_con_details con (InfixCon ty1 ty2) -- 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) - = getPprStyle $ \ sty -> - hsep ((if ifaceStyle sty then ppr con else ppr_var con) - : map (ppr_bang) tys) + = hsep (ppr_var con : map (ppr_bang) tys) ppr_con_details con (RecCon fields) = ppr con <+> braces (sep (punctuate comma (map ppr_field fields))) @@ -677,13 +701,9 @@ instance (Outputable name, Outputable pat) => Outputable (InstDecl name pat) where ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc) - = getPprStyle $ \ sty -> - if ifaceStyle sty then - hsep [ptext SLIT("instance"), ppr inst_ty, equals, pp_dfun] - else - vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], - nest 4 (ppr uprags), - nest 4 (ppr binds) ] + = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], + nest 4 (ppr uprags), + nest 4 (ppr binds) ] where pp_dfun = case maybe_dfun_name of Just df -> ppr df @@ -809,10 +829,10 @@ instance Outputable ForeignImport where char '"' <> pprCEntity header lib spec <> char '"' where pprCEntity header lib (CLabel lbl) = - ptext SLIT("static") <+> ptext header <+> char '&' <> + ptext SLIT("static") <+> ftext header <+> char '&' <> pprLib lib <> ppr lbl pprCEntity header lib (CFunction (StaticTarget lbl)) = - ptext SLIT("static") <+> ptext header <+> char '&' <> + ptext SLIT("static") <+> ftext header <+> char '&' <> pprLib lib <> ppr lbl pprCEntity header lib (CFunction (DynamicTarget)) = ptext SLIT("dynamic") @@ -885,7 +905,7 @@ instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where instance (NamedThing name, Outputable name, Outputable pat) => Outputable (RuleDecl name pat) where ppr (HsRule name act ns lhs rhs loc) - = sep [text "{-# RULES" <+> doubleQuotes (ptext name) <+> ppr act, + = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act, pp_forall, ppr lhs, equals <+> ppr rhs, text "#-}" ] where @@ -893,7 +913,7 @@ instance (NamedThing name, Outputable name, Outputable pat) | otherwise = text "forall" <+> fsep (map ppr ns) <> dot ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc) - = hsep [ doubleQuotes (ptext name), ppr act, + = hsep [ doubleQuotes (ftext name), ppr act, ptext SLIT("__forall") <+> braces (interppSP tpl_vars), ppr fn <+> sep (map (pprUfExpr parens) tpl_args), ptext SLIT("=") <+> ppr rhs @@ -918,7 +938,7 @@ We use exported entities for things to deprecate. \begin{code} data DeprecDecl name = Deprecation name DeprecTxt SrcLoc -type DeprecTxt = FAST_STRING -- reason/explanation for deprecation +type DeprecTxt = FastString -- reason/explanation for deprecation instance Outputable name => Outputable (DeprecDecl name) where ppr (Deprecation thing txt _)