#include "HsVersions.h"
-import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr )
-import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
+import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
+ Match, pprFunBind,
+ GRHSs, pprPatBind )
-- friends:
import HsTypes ( HsType )
import CoreSyn ( CoreExpr )
+import PprCore ( {- instance Outputable (Expr a) -} )
--others:
-import Name ( Name, isUnboundName )
+import Name ( Name )
+import PrelNames ( isUnboundName )
import NameSet ( NameSet, elemNameSet, nameSetToList )
import BasicTypes ( RecFlag(..), Fixity )
import Outputable
import SrcLoc ( SrcLoc )
import Var ( TyVar )
+import Class ( DefMeth (..) )
\end{code}
%************************************************************************
ppr_binds EmptyBinds = empty
ppr_binds (ThenBinds binds1 binds2)
- = ($$) (ppr_binds binds1) (ppr_binds binds2)
+ = ppr_binds binds1 $$ ppr_binds binds2
ppr_binds (MonoBind bind sigs is_rec)
- = vcat [ifNotPprForUser (ptext rec_str),
+ = vcat [ppr_isrec,
vcat (map ppr sigs),
ppr bind
]
where
- rec_str = case is_rec of
- Recursive -> SLIT("{- rec -}")
- NonRecursive -> SLIT("{- nonrec -}")
+ ppr_isrec = getPprStyle $ \ sty ->
+ if userStyle sty then empty else
+ case is_rec of
+ Recursive -> ptext SLIT("{- rec -}")
+ NonRecursive -> ptext SLIT("{- nonrec -}")
\end{code}
%************************************************************************
ppr_monobind (AndMonoBinds binds1 binds2)
= ppr_monobind binds1 $$ ppr_monobind binds2
-ppr_monobind (PatMonoBind pat grhss locn)
- = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
-
-ppr_monobind (FunMonoBind fun inf matches locn)
- = pprMatches (False, ppr fun) matches
+ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss
+ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
-- ToDo: print infix if appropriate
ppr_monobind (VarMonoBind name expr)
SrcLoc
| ClassOpSig name -- Selector name
- name -- Default-method name (if any)
- Bool -- True <=> there is an explicit, programmer-supplied
- -- default declaration in the class decl
+ (DefMeth name) -- Default-method info
+ -- See "THE NAMING STORY" in HsDecls
(HsType name)
SrcLoc
\begin{code}
okBindSig :: NameSet -> Sig Name -> Bool
-okBindSig ns (ClassOpSig _ _ _ _ _) = False
+okBindSig ns (ClassOpSig _ _ _ _) = False
okBindSig ns sig = sigForThisGroup ns sig
okClsDclSig :: NameSet -> Sig Name -> Bool
sigName :: Sig name -> Maybe name
sigName (Sig n _ _) = Just n
-sigName (ClassOpSig n _ _ _ _) = Just n
+sigName (ClassOpSig n _ _ _) = Just n
sigName (SpecSig n _ _) = Just n
sigName (InlineSig n _ _) = Just n
sigName (NoInlineSig n _ _) = Just n
isFixitySig _ = False
isClassOpSig :: Sig name -> Bool
-isClassOpSig (ClassOpSig _ _ _ _ _) = True
-isClassOpSig _ = False
+isClassOpSig (ClassOpSig _ _ _ _) = True
+isClassOpSig _ = False
isPragSig :: Sig name -> Bool
-- Identifies pragmas
\begin{code}
hsSigDoc (Sig _ _ loc) = (SLIT("type signature"),loc)
-hsSigDoc (ClassOpSig _ _ _ _ loc) = (SLIT("class-method type signature"), loc)
+hsSigDoc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
hsSigDoc (SpecSig _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
hsSigDoc (InlineSig _ _ loc) = (SLIT("INLINE pragma"),loc)
hsSigDoc (NoInlineSig _ _ loc) = (SLIT("NOINLINE pragma"),loc)
ppr_sig (Sig var ty _)
= sep [ppr var <+> dcolon, nest 4 (ppr ty)]
-ppr_sig (ClassOpSig var _ dm ty _)
+ppr_sig (ClassOpSig var dm ty _)
= sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
where
- pp_dm = if dm then equals else empty -- Default-method indicator
+ pp_dm = case dm of
+ DefMeth _ -> equals -- Default method indicator
+ GenDefMeth -> semi -- Generic method indicator
+ NoDefMeth -> empty -- No Method at all
ppr_sig (SpecSig var ty _)
= sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2
eqHsSig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = ty1 == ty2
-eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _)
- = -- may have many specialisations for one value;
+eqHsSig (SpecSig n1 ty1 _) (SpecSig n2 ty2 _) =
+ -- may have many specialisations for one value;
-- but not ones that are exactly the same...
(n1 == n2) && (ty1 == ty2)
-eqHsSig other_1 other_2 = False
+eqHsSig _other1 _other2 = False
\end{code}