X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=e080bee8cf70b70482502fe2d373b0f89e627240;hp=92b050a7f225850e76c509c261f0f653989878bf;hb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;hpb=7998a24404ffa577a3c303e37e4cfe0baf846454

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 92b050a..e080bee 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]
 	-- 
@@ -245,6 +246,13 @@ plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
+
+getTypeSigNames :: HsValBinds a -> NameSet
+-- Get the names that have a user type sig
+getTypeSigNames (ValBindsIn {}) 
+  = panic "getTypeSigNames"
+getTypeSigNames (ValBindsOut _ sigs) 
+  = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs]
 \end{code}
 
 What AbsBinds means
@@ -288,11 +296,12 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
   = pprTicks empty (case tick of 
 			Nothing -> empty
 			Just t  -> text "-- tick id = " <> ppr t)
+    $$  ifPprDebug (pprBndr LetBind (unLoc fun))
     $$  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),
@@ -307,7 +316,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
   where
     ppr_exp (tvs, gbl, lcl, prags)
 	= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
-	  	nest 2 (pprTcSpecPrags gbl prags)]
+	  	nest 2 (pprTcSpecPrags prags)]
 \end{code}
 
 
@@ -348,7 +357,7 @@ data IPBind id
 
 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) 
-			$$ ppr ds
+			$$ ifPprDebug (ppr ds)
 
 instance (OutputableBndr id) => Outputable (IPBind id) where
   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
@@ -439,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
@@ -566,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}
 
 %************************************************************************
@@ -613,10 +621,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)
 
 
@@ -628,11 +636,14 @@ data FixitySig name = FixitySig (Located name) Fixity
 data TcSpecPrags 
   = IsDefaultMethod	-- Super-specialised: a default method should 
     			-- be macro-expanded at every call site
-  | SpecPrags [Located TcSpecPrag]
+  | SpecPrags [LTcSpecPrag]
   deriving (Data, Typeable)
 
+type LTcSpecPrag = Located TcSpecPrag
+
 data TcSpecPrag 
   = SpecPrag   
+        Id		-- The Id to be specialised
 	HsWrapper	-- An wrapper, that specialises the polymorphic function
 	InlinePragma 	-- Inlining spec for the specialised function
   deriving (Data, Typeable)
@@ -768,14 +779,11 @@ pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var p
     pp_inl | isDefaultInlinePragma inl = empty
            | otherwise = ppr 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
+pprTcSpecPrags :: TcSpecPrags -> SDoc
+pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
+pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)
 
 instance Outputable TcSpecPrag where
-  ppr (SpecPrag _ p) = ptext (sLit "SpecPrag") <+> ppr p
+  ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
 \end{code}