hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
- mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
- getClassDeclSysNames, conDetailsTys
+ mkClassDeclSysNames, isIfaceRuleDecl, isIfaceInstDecl, ifaceRuleDeclName,
+ getClassDeclSysNames, conDetailsTys,
+ collectRuleBndrSigTys
) where
#include "HsVersions.h"
-- 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(..), StrictnessMark(..) )
+import CoreSyn ( CoreRule(..), RuleName )
+import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..) )
import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )
-- others:
import Class ( FunDep, DefMeth(..) )
import CStrings ( CLabelString )
import Outputable
-import Util ( eqListBy )
+import Util ( eqListBy, count )
import SrcLoc ( SrcLoc )
import FastString
+
+import Maybe ( isNothing, isJust, fromJust )
\end{code}
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
- = (length [() | ClassDecl {} <- decls],
- length [() | TySynonym {} <- decls],
- length [() | IfaceSig {} <- decls],
- length [() | TyData {tcdND = DataType} <- decls],
- length [() | TyData {tcdND = NewType} <- decls])
+ = (count isClassDecl decls,
+ count isSynDecl decls,
+ count isIfaceSigDecl decls,
+ count isDataTy decls,
+ count isNewTy decls)
+ where
+ isDataTy TyData{tcdND=DataType} = True
+ isDataTy _ = False
+
+ isNewTy TyData{tcdND=NewType} = True
+ isNewTy _ = False
\end{code}
\begin{code}
=> 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]
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]
ppr_con_details con (InfixCon ty1 ty2)
= hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
+-- ConDecls generated by MkIface.ifaceTyThing 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 (sep (punctuate comma (map ppr_field fields)))
-- Nothing for source-file instance decls
SrcLoc
+
+isIfaceInstDecl :: InstDecl name pat -> Bool
+isIfaceInstDecl (InstDecl _ _ _ maybe_dfun _) = isJust maybe_dfun
\end{code}
\begin{code}
\begin{code}
data RuleDecl name pat
= HsRule -- Source rule
- FAST_STRING -- Rule name
- [name] -- Forall'd tyvars, filled in by the renamer with
- -- tyvars mentioned in sigs; then filled out by typechecker
- [RuleBndr name] -- Forall'd term vars
+ RuleName -- Rule name
+ Activation
+ [RuleBndr name] -- Forall'd vars; after typechecking this includes tyvars
(HsExpr name pat) -- LHS
(HsExpr name pat) -- RHS
SrcLoc
| IfaceRule -- One that's come in from an interface file; pre-typecheck
- FAST_STRING
+ RuleName
+ Activation
[UfBinder name] -- Tyvars and term vars
name -- Head of lhs
[UfExpr name] -- Args of LHS
name -- Head of LHS
CoreRule
+isIfaceRuleDecl :: RuleDecl name pat -> Bool
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
ifaceRuleDeclName :: RuleDecl name pat -> name
-ifaceRuleDeclName (IfaceRule _ _ n _ _ _) = n
-ifaceRuleDeclName (IfaceRuleOut n r) = n
-ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs)
+ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n
+ifaceRuleDeclName (IfaceRuleOut n r) = n
+ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs)
data RuleBndr name
= RuleBndr name
| RuleBndrSig name (HsType name)
+collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name]
+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
+
instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
-- Works for IfaceRules only; used when comparing interface file versions
- (IfaceRule n1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 bs2 f2 es2 rhs2 _)
- = n1==n2 && f1 == f2 &&
+ (IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _)
+ = n1==n2 && f1 == f2 && a1==a2 &&
eq_ufBinders emptyEqHsEnv bs1 bs2 (\env ->
eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2))
instance (NamedThing name, Outputable name, Outputable pat)
=> Outputable (RuleDecl name pat) where
- ppr (HsRule name tvs ns lhs rhs loc)
- = sep [text "{-# RULES" <+> doubleQuotes (ptext name),
+ ppr (HsRule name act ns lhs rhs loc)
+ = sep [text "{-# RULES" <+> doubleQuotes (ptext name) <+> ppr act,
pp_forall, ppr lhs, equals <+> ppr rhs,
text "#-}" ]
where
- pp_forall | null tvs && null ns = empty
- | otherwise = text "forall" <+>
- fsep (map ppr tvs ++ map ppr ns)
- <> dot
+ pp_forall | null ns = empty
+ | otherwise = text "forall" <+> fsep (map ppr ns) <> dot
- ppr (IfaceRule name tpl_vars fn tpl_args rhs loc)
- = hsep [ doubleQuotes (ptext name),
+ ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc)
+ = hsep [ doubleQuotes (ptext name), ppr act,
ptext SLIT("__forall") <+> braces (interppSP tpl_vars),
ppr fn <+> sep (map (pprUfExpr parens) tpl_args),
ptext SLIT("=") <+> ppr rhs
projects / ghc-hetmet.git / blobdiff