X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=c4d38fd7a302ebd2c9329799019d54b8fbe24978;hb=302e2e29f2e1074bfba561e077a484dc4e1d15f6;hp=a6d8523e93e752b13e0663017695a31d956b284c;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index a6d8523..c4d38fd 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -13,6 +13,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
 -- any warnings in the module. See
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
+{-# LANGUAGE DeriveDataTypeable #-}
 
 module HsBinds where
 
@@ -34,6 +35,8 @@ import Util
 import Var
 import Bag
 import FastString
+
+import Data.Data hiding ( Fixity )
 \end{code}
 
 %************************************************************************
@@ -58,6 +61,7 @@ data HsLocalBindsLR idL idR	-- Bindings in a 'let' expression
   = HsValBinds (HsValBindsLR idL idR)
   | HsIPBinds  (HsIPBinds idR)
   | EmptyLocalBinds
+  deriving (Data, Typeable)
 
 type HsValBinds id = HsValBindsLR id id
 
@@ -71,6 +75,7 @@ data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
                                         -- in the list may depend on earlier
                                         -- ones.
 	[LSig Name]
+  deriving (Data, Typeable)
 
 type LHsBinds id  = Bag (LHsBind id)
 type DictBinds id = LHsBinds id		-- Used for dictionary or method bindings
@@ -143,11 +148,12 @@ data HsBindLR idL idR
        -- AbsBinds only gets used when idL = idR after renaming,
        -- but these need to be idL's for the collect... code in HsUtil to have
        -- the right type
-	abs_exports :: [([TyVar], idL, idL, [LSpecPrag])],	-- (tvs, poly_id, mono_id, prags)
+	abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],	-- (tvs, poly_id, mono_id, prags)
 	abs_binds   :: LHsBinds idL		-- The dictionary bindings and typechecked user bindings
 						-- mixed up together; you can tell the dict bindings because
 						-- they are all VarBinds
     }
+  deriving (Data, Typeable)
 	-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
 	-- 
 	-- Creates bindings for (polymorphic, overloaded) poly_f
@@ -292,7 +298,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
   where
     ppr_exp (tvs, gbl, lcl, prags)
 	= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
-	  	nest 2 (vcat (map (pprPrag gbl) prags))]
+	  	nest 2 (pprTcSpecPrags gbl prags)]
 \end{code}
 
 
@@ -317,6 +323,7 @@ data HsIPBinds id
 	[LIPBind id] 
 	(DictBinds id)	-- Only in typechecker output; binds 
 			-- uses of the implicit parameters
+  deriving (Data, Typeable)
 
 isEmptyIPBinds :: HsIPBinds id -> Bool
 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
@@ -328,6 +335,7 @@ data IPBind id
   = IPBind
 	(IPName id)
 	(LHsExpr id)
+  deriving (Data, Typeable)
 
 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) 
@@ -370,6 +378,7 @@ data HsWrapper
 	-- is always exactly WpHole
   | WpLet (LHsBinds Id)		-- let binds in []
 				-- (would be nicer to be core bindings)
+  deriving (Data, Typeable)
 
 instance Outputable HsWrapper where 
   ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
@@ -466,17 +475,37 @@ data Sig name	-- Signatures and pragmas
 	-- {-# SPECIALISE instance Eq [Int] #-}
   | SpecInstSig (LHsType name)	-- (Class tys); should be a specialisation of the 
 				-- current instance decl
+  deriving (Data, Typeable)
 
 
 type LFixitySig name = Located (FixitySig name)
 data FixitySig name = FixitySig (Located name) Fixity 
+  deriving (Data, Typeable)
+
+-- TsSpecPrags conveys pragmas from the type checker to the desugarer
+data TcSpecPrags 
+  = IsDefaultMethod	-- Super-specialised: a default method should 
+    			-- be macro-expanded at every call site
+  | SpecPrags [Located TcSpecPrag]
+  deriving (Data, Typeable)
 
--- A Prag conveys pragmas from the type checker to the desugarer
-type LSpecPrag = Located SpecPrag
-data SpecPrag 
+data TcSpecPrag 
   = SpecPrag   
 	HsWrapper	-- An wrapper, that specialises the polymorphic function
 	InlinePragma 	-- Inlining spec for the specialised function
+  deriving (Data, Typeable)
+
+noSpecPrags :: TcSpecPrags
+noSpecPrags = SpecPrags []
+
+hasSpecPrags :: TcSpecPrags -> Bool
+hasSpecPrags (SpecPrags ps) = not (null ps)
+hasSpecPrags IsDefaultMethod = False
+
+isDefaultMethod :: TcSpecPrags -> Bool
+isDefaultMethod IsDefaultMethod = True
+isDefaultMethod (SpecPrags {})  = False
+
 \end{code}
 
 \begin{code}
@@ -597,7 +626,14 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p
     pp_inl | isDefaultInlinePragma inl = empty
            | otherwise = ppr inl
 
-pprPrag :: Outputable id => id -> LSpecPrag -> SDoc
-pprPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
+pprTcSpecPrags :: Outputable id => id -> TcSpecPrags -> SDoc
+pprTcSpecPrags _   IsDefaultMethod = ptext (sLit "<default method>")
+pprTcSpecPrags gbl (SpecPrags ps)  = vcat (map (pprSpecPrag gbl) ps)
+
+pprSpecPrag :: Outputable id => id -> Located TcSpecPrag -> SDoc
+pprSpecPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl
+
+instance Outputable TcSpecPrag where
+  ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
 \end{code}