X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=c8348cb6cd7e24e8432b8ae7462b827d2e3b11ff;hb=2b8358cfe8b6399874090c099e3b96e932c6ccbb;hp=1db78220b747af6d4b85029a011bad5492ee6a8e;hpb=77166b1729061531eeb77c33f4d3b2581f7d4c41;p=ghc-hetmet.git

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 1db7822..c8348cb 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -105,7 +105,7 @@ data IfaceDecl
                                                 -- beyond .NET
 		   ifExtName :: Maybe FastString }
 
-data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
+data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
 	-- Nothing    => no default method
 	-- Just False => ordinary polymorphic default method
 	-- Just True  => generic default method
@@ -133,7 +133,7 @@ data IfaceConDecl
 	ifConCtxt    :: IfaceContext,		-- Non-stupid context
 	ifConArgTys  :: [IfaceType],		-- Arg types
 	ifConFields  :: [OccName],		-- ...ditto... (field labels)
-	ifConStricts :: [StrictnessMark]}	-- Empty (meaning all lazy),
+	ifConStricts :: [HsBang]}		-- Empty (meaning all lazy),
 						-- or 1-1 corresp with arg tys
 
 data IfaceInst 
@@ -210,7 +210,8 @@ data IfaceInfoItem
 -- only later attached to the Id.  Partial reason: some are orphans.
 
 data IfaceUnfolding 
-  = IfCoreUnfold IfaceExpr
+  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
+
   | IfCompulsory IfaceExpr	-- Only used for default methods, in fact
 
   | IfInlineRule Arity 
@@ -524,10 +525,13 @@ pprIfaceConDecl tc
 	 if is_infix then ptext (sLit "Infix") else empty,
 	 if has_wrap then ptext (sLit "HasWrapper") else empty,
 	 ppUnless (null strs) $
-	    nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
+	    nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
 	 ppUnless (null fields) $
 	    nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
   where
+    ppr_bang HsNoBang = char '_'	-- Want to see these
+    ppr_bang bang     = ppr bang
+        
     main_payload = ppr name <+> dcolon <+> 
 		   pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
 
@@ -547,7 +551,7 @@ instance Outputable IfaceRule where
 		   ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) 
     = sep [hsep [doubleQuotes (ftext name), ppr act,
 		 ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
-	   nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
+	   nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
 		        ptext (sLit "=") <+> ppr rhs])
       ]
 
@@ -577,6 +581,9 @@ ppr_rough (Just tc) = ppr tc
 instance Outputable IfaceExpr where
     ppr e = pprIfaceExpr noParens e
 
+pprParendIfaceExpr :: IfaceExpr -> SDoc
+pprParendIfaceExpr = pprIfaceExpr parens
+
 pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
 	-- The function adds parens in context that need
 	-- an atomic value (e.g. function args)
@@ -612,7 +619,7 @@ pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
   		  nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 
 pprIfaceExpr _       (IfaceCast expr co)
-  = sep [pprIfaceExpr parens expr,
+  = sep [pprParendIfaceExpr expr,
 	 nest 2 (ptext (sLit "`cast`")),
 	 pprParendIfaceType co]
 
@@ -628,7 +635,7 @@ pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
 		  ptext (sLit "} in"),
 		  pprIfaceExpr noParens body])
 
-pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
+pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body)
 
 ppr_alt :: (IfaceConAlt, [FastString], IfaceExpr) -> SDoc
 ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, 
@@ -645,8 +652,8 @@ ppr_bind (IfLetBndr b ty info, rhs)
 
 ------------------
 pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
-pprIfaceApp fun	 	       args = sep (pprIfaceExpr parens fun : args)
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args)
+pprIfaceApp fun	 	       args = sep (pprParendIfaceExpr fun : args)
 
 ------------------
 instance Outputable IfaceNote where
@@ -682,12 +689,13 @@ instance Outputable IfaceInfoItem where
 
 instance Outputable IfaceUnfolding where
   ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
-  ppr (IfCoreUnfold e)     = parens (ppr e)
-  ppr (IfInlineRule a uok bok e) = ptext (sLit "InlineRule")
-                                  <+> ppr (a,uok,bok) 
-      		      	          <+> parens (ppr e)
-  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
-  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns)
+  ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
+  ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
+      		           	        pprParendIfaceExpr e]
+  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr
+                             <+> parens (ptext (sLit "arity") <+> int a)
+  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:")
+                             <+> brackets (pprWithCommas pprParendIfaceExpr ns)
 
 
 -- -----------------------------------------------------------------------------
@@ -805,7 +813,7 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
 freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e
 freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
 freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v