X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsBinds.lhs;h=0942703312e714cb7055aec07635402dfbc5e8a9;hb=e5ca7e6e5137a2e6081717e5e90ca52a30840f68;hp=05880476954f3146f33ecc9465c24849f6850f29;hpb=e6d057711f4d6d6ff6342c39fa2b9e44d25447f1;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 0588047..0942703 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
@@ -15,18 +16,18 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
 			       GRHSs, pprPatBind )
 import {-# SOURCE #-} HsPat  ( LPat )
 
-import HsTypes		( LHsType, PostTcType )
-import PprCore		( {- instances -} )
-import Coercion		( Coercion )
-import Type		( Type, pprParendType )
-import Name		( Name )
-import NameSet		( NameSet, elemNameSet )
-import BasicTypes	( IPName, RecFlag(..), InlineSpec(..), Fixity )
+import HsTypes
+import PprCore
+import Coercion
+import Type
+import Name
+import NameSet
+import BasicTypes
 import Outputable	
-import SrcLoc		( Located(..), SrcSpan, unLoc )
-import Util		( sortLe )
-import Var		( TyVar, DictId, Id, Var )
-import Bag		( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
+import SrcLoc
+import Util
+import Var
+import Bag
 \end{code}
 
 %************************************************************************
@@ -86,11 +87,13 @@ data HsBind id
 				-- type 	Int -> forall a'. a' -> a'
 				-- Notice that the coercion captures the free a'.
 
-	bind_fvs :: NameSet	-- After the renamer, this contains a superset of the 
+	bind_fvs :: NameSet,	-- After the renamer, this contains a superset of the 
 				-- Names of the other binders in this binding group that 
 				-- are free in the RHS of the defn
 				-- Before renaming, and after typechecking, 
 				-- the field is unused; it's just an error thunk
+
+        fun_tick :: Maybe Int   -- This is the (optional) module-local tick number. 
     }
 
   | PatBind {	-- The pattern is never a simple variable;
@@ -237,7 +240,13 @@ ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 
 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = ppr var <+> equals <+> pprExpr (unLoc rhs)
-ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
+ppr_monobind (FunBind { fun_id = fun, 
+			fun_matches = matches,
+		        fun_tick = tick }) = 
+		           (case tick of 
+			      Nothing -> empty
+			      Just t  -> text "-- tick id = " <> ppr t
+			   ) $$ pprFunBind (unLoc fun) matches
       -- ToDo: print infix if appropriate
 
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, 
@@ -374,21 +383,32 @@ serves for both.
 \begin{code}
 type LSig name = Located (Sig name)
 
-data Sig name
-  = TypeSig	(Located name)	-- A bog-std type signature
+data Sig name	-- Signatures and pragmas
+  = 	-- An ordinary type signature
+	-- f :: Num a => a -> a
+    TypeSig	(Located name)	-- A bog-std type signature
 		(LHsType name)
 
-  | SpecSig 	(Located name)	-- Specialise a function or datatype ...
-		(LHsType name)	-- ... to these types
-		InlineSpec
+	-- An ordinary fixity declaration
+	--	infixl *** 8
+  | FixSig	(FixitySig name)	-- Fixity declaration
 
+	-- An inline pragma
+	-- {#- INLINE f #-}
   | InlineSig	(Located name)	-- Function name
 		InlineSpec
 
+	-- A specialisation pragma
+	-- {-# SPECIALISE f :: Int -> Int #-}
+  | SpecSig 	(Located name)	-- Specialise a function or datatype ...
+		(LHsType name)	-- ... to these types
+		InlineSpec
+
+	-- 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
 
-  | FixSig	(FixitySig name)	-- Fixity declaration
 
 type LFixitySig name = Located (FixitySig name)
 data FixitySig name = FixitySig (Located name) Fixity 
@@ -439,13 +459,14 @@ sigForThisGroup ns sig
 	Just n  -> n `elemNameSet` ns
 
 sigName :: LSig name -> Maybe name
-sigName (L _ sig) = f sig
- where
-    f (TypeSig   n _)          = Just (unLoc n)
-    f (SpecSig   n _ _)        = Just (unLoc n)
-    f (InlineSig n _)          = Just (unLoc n)
-    f (FixSig (FixitySig n _)) = Just (unLoc n)
-    f other			= Nothing
+sigName (L _ sig) = sigNameNoLoc sig
+
+sigNameNoLoc :: Sig name -> Maybe name    
+sigNameNoLoc (TypeSig   n _)          = Just (unLoc n)
+sigNameNoLoc (SpecSig   n _ _)        = Just (unLoc n)
+sigNameNoLoc (InlineSig n _)          = Just (unLoc n)
+sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n)
+sigNameNoLoc other		                = Nothing
 
 isFixityLSig :: LSig name -> Bool
 isFixityLSig (L _ (FixSig {})) = True