X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=e6cad1ab9a9b157123e52108037291f01a6667dc;hp=da247c28ed708f9a14129332a6ca87b2343c05f3;hb=ada48bbc7f6a43b2c042df629327902d82cea681;hpb=92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44 diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index da247c2..e6cad1a 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -155,6 +155,7 @@ data HsBindLR idL idR abs_ev_binds :: TcEvBinds, -- Evidence bindings abs_binds :: LHsBinds idL -- Typechecked user bindings } + deriving (Data, Typeable) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -299,8 +300,8 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf, $$ pprFunBind (unLoc fun) inf matches $$ ifPprDebug (ppr wrap) -ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars - , abs_exports = exports, abs_binds = val_binds +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) = sep [ptext (sLit "AbsBinds"), brackets (interpp'SP tyvars), @@ -447,7 +448,7 @@ data EvTerm | EvCast EvVar Coercion -- d |> co | EvDFunApp DFunId -- Dictionary instance application - [Type] [EvVar] + [Type] [EvVar] | EvSuperClass DictId Int -- n'th superclass. Used for both equalities and -- dictionaries, even though the former have no @@ -574,8 +575,7 @@ instance Outputable EvTerm where ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co ppr (EvCoercion co) = ppr co ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) - ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys - , ppr ts ] + ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] \end{code} %************************************************************************ @@ -597,6 +597,10 @@ data Sig name -- Signatures and pragmas -- f :: Num a => a -> a TypeSig (Located name) (LHsType name) + -- A type signature for a default method inside a class + -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool + | GenericSig (Located name) (LHsType name) + -- A type signature in generated code, notably the code -- generated for record selectors. We simply record -- the desired Id itself, replete with its name, type @@ -621,10 +625,10 @@ data Sig name -- Signatures and pragmas -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE - -- A specialisation pragma for instance declarations only - -- {-# SPECIALISE instance Eq [Int] #-} - | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the - -- current instance decl + -- A specialisation pragma for instance declarations only + -- {-# SPECIALISE instance Eq [Int] #-} + | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the + -- current instance decl deriving (Data, Typeable) @@ -666,29 +670,27 @@ okBindSig :: Sig a -> Bool okBindSig _ = True okHsBootSig :: Sig a -> Bool -okHsBootSig (TypeSig _ _) = True -okHsBootSig (FixSig _) = True -okHsBootSig _ = False +okHsBootSig (TypeSig _ _) = True +okHsBootSig (GenericSig _ _) = True -- JPM: Is this true? +okHsBootSig (FixSig _) = True +okHsBootSig _ = False okClsDclSig :: Sig a -> Bool okClsDclSig (SpecInstSig _) = False okClsDclSig _ = True -- All others OK okInstDclSig :: Sig a -> Bool -okInstDclSig (TypeSig _ _) = False -okInstDclSig (FixSig _) = False -okInstDclSig _ = True - -sigForThisGroup :: NameSet -> LSig Name -> Bool -sigForThisGroup ns sig - = case sigName sig of - Nothing -> False - Just n -> n `elemNameSet` ns +okInstDclSig (TypeSig _ _) = False +okInstDclSig (GenericSig _ _) = False +okInstDclSig (FixSig _) = False +okInstDclSig _ = True sigName :: LSig name -> Maybe name +-- Used only in Haddock sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> Maybe name +-- Used only in Haddock sigNameNoLoc (TypeSig n _) = Just (unLoc n) sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) sigNameNoLoc (InlineSig n _) = Just (unLoc n) @@ -706,9 +708,10 @@ isVanillaLSig (L _(TypeSig {})) = True isVanillaLSig _ = False isTypeLSig :: LSig name -> Bool -- Type signatures -isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(IdSig {})) = True -isTypeLSig _ = False +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(GenericSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False isSpecLSig :: LSig name -> Bool isSpecLSig (L _(SpecSig {})) = True @@ -731,6 +734,7 @@ isInlineLSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = ptext (sLit "type signature") +hsSigDoc (GenericSig {}) = ptext (sLit "default type signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma") @@ -745,6 +749,7 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over -- HsType, so it's not convenient to spot duplicate @@ -758,6 +763,7 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr_sig :: OutputableBndr name => Sig name -> SDoc ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) +ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty) ppr_sig (IdSig id) = pprVarSig id (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)