X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscStats.lhs;h=8e59f3c16f55ae22731a5ad33f0e712ce92dfc25;hb=d28ba8c800901bea01f70c4719278c2a364cf9fc;hp=8338b01ee6d6a6487e8d849ebf4dd3bdee9fae2a;hpb=83eef621e4a4fbb6c1343304ec638cafd6c9dc09;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs
index 8338b01..8e59f3c 100644
--- a/ghc/compiler/main/HscStats.lhs
+++ b/ghc/compiler/main/HscStats.lhs
@@ -9,8 +9,10 @@ module HscStats ( ppSourceStats ) where
 #include "HsVersions.h"
 
 import HsSyn
+import TyCon		( DataConDetails(..) )
 import Outputable
 import Char		( isSpace )
+import Util             ( count )
 \end{code}
 
 %************************************************************************
@@ -20,7 +22,7 @@ import Char		( isSpace )
 %************************************************************************
 
 \begin{code}
-ppSourceStats short (HsModule name version exports imports decls _ src_loc)
+ppSourceStats short (HsModule _ exports imports decls _ src_loc)
  = (if short then hcat else vcat)
         (map pp_val
 	       [("ExportAll        ", export_all), -- 1 if no export list
@@ -32,7 +34,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
 		("  ImpAll         ", import_all),
 		("  ImpPartial     ", import_partial),
 		("  ImpHiding      ", import_hiding),
-		("FixityDecls      ", fixity_ds),
+		("FixityDecls      ", fixity_sigs),
 		("DefaultDecls     ", default_ds),
 	      	("TypeDecls        ", type_ds),
 	      	("DataDecls        ", data_ds),
@@ -62,7 +64,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
     
     trim ls     = takeWhile (not.isSpace) (dropWhile isSpace ls)
 
-    fixity_ds   = length [() | FixD d <- decls]
+    (fixity_sigs, bind_tys, _, bind_specs, bind_inlines) 
+	= count_sigs [d | SigD d <- decls]
 		-- NB: this omits fixity decls on local bindings and
 		-- in class decls.  ToDo
 
@@ -71,17 +74,18 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
 
     inst_decls  = [d | InstD d <- decls]
     inst_ds     = length inst_decls
-    default_ds  = length [() | DefD _ <- decls]
+    default_ds  = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
     val_decls   = [d | ValD d <- decls]
 
     real_exports = case exports of { Nothing -> []; Just es -> es }
     n_exports  	 = length real_exports
-    export_ms  	 = length [() | IEModuleContents _ <- real_exports]
+    export_ms  	 = count (\ e -> case e of { IEModuleContents{} -> True;_ -> False})
+                         real_exports
     export_ds  	 = n_exports - export_ms
     export_all 	 = case exports of { Nothing -> 1; other -> 0 }
 
-    (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
-	= count_binds (foldr ThenBinds EmptyBinds val_decls)
+    (val_bind_ds, fn_bind_ds)
+	= foldr add2 (0,0) (map count_monobinds val_decls)
 
     (import_no, import_qual, import_as, import_all, import_partial, import_hiding)
 	= foldr add6 (0,0,0,0,0,0) (map import_info imports)
@@ -92,29 +96,23 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
     (inst_method_ds, method_specs, method_inlines)
 	= foldr add3 (0,0,0) (map inst_info inst_decls)
 
-
-    count_binds EmptyBinds        = (0,0,0,0,0)
-    count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
-    count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of
-				        ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
-
-    count_monobinds EmptyMonoBinds	  	   = (0,0)
-    count_monobinds (AndMonoBinds b1 b2)  	   = count_monobinds b1 `add2` count_monobinds b2
-    count_monobinds (PatMonoBind (VarPatIn n) r _) = (1,0)
-    count_monobinds (PatMonoBind p r _)            = (0,1)
-    count_monobinds (FunMonoBind f _ m _)          = (0,1)
+    count_monobinds EmptyMonoBinds	  	 = (0,0)
+    count_monobinds (AndMonoBinds b1 b2)  	 = count_monobinds b1 `add2` count_monobinds b2
+    count_monobinds (PatMonoBind (VarPat n) r _) = (1,0)
+    count_monobinds (PatMonoBind p r _)          = (0,1)
+    count_monobinds (FunMonoBind f _ m _)        = (0,1)
 
     count_mb_monobinds (Just mbs) = count_monobinds mbs
     count_mb_monobinds Nothing	  = (0,0)
 
-    count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
+    count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
 
-    sig_info (Sig _ _ _)            = (1,0,0,0)
-    sig_info (ClassOpSig _ _ _ _)   = (0,1,0,0)
-    sig_info (SpecSig _ _ _)        = (0,0,1,0)
-    sig_info (InlineSig _ _ _)      = (0,0,0,1)
-    sig_info (NoInlineSig _ _ _)    = (0,0,0,1)
-    sig_info _                      = (0,0,0,0)
+    sig_info (FixSig _)		    = (1,0,0,0,0)
+    sig_info (Sig _ _ _)            = (0,1,0,0,0)
+    sig_info (ClassOpSig _ _ _ _)   = (0,0,1,0,0)
+    sig_info (SpecSig _ _ _)        = (0,0,0,1,0)
+    sig_info (InlineSig _ _ _ _)    = (0,0,0,0,1)
+    sig_info _                      = (0,0,0,0,0)
 
     import_info (ImportDecl _ _ qual as spec _)
 	= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
@@ -126,19 +124,19 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
     spec_info (Just (False, _)) = (0,0,0,0,1,0)
     spec_info (Just (True, _))  = (0,0,0,0,0,1)
 
-    data_info (TyData {tcdNCons = nconstrs, tcdDerivs = derivs})
-	= (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
+    data_info (TyData {tcdCons = DataCons cs, tcdDerivs = derivs})
+	= (length cs, case derivs of {Nothing -> 0; Just ds -> length ds})
     data_info other = (0,0)
 
     class_info decl@(ClassDecl {})
 	= case count_sigs (tcdSigs decl) of
-	    (_,classops,_,_) ->
+	    (_,_,classops,_,_) ->
 	       (classops, addpr (count_mb_monobinds (tcdMeths decl)))
     class_info other = (0,0)
 
     inst_info (InstDecl _ inst_meths inst_sigs _ _)
 	= case count_sigs inst_sigs of
-	    (_,_,ss,is) ->
+	    (_,_,_,ss,is) ->
 	       (addpr (count_monobinds inst_meths), ss, is)
 
     addpr :: (Int,Int) -> Int