--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section[GHC_Stats]{Statistics for per-module compilations}
+
+\begin{code}
+module HscStats ( ppSourceStats ) where
+
+#include "HsVersions.h"
+
+import HsSyn
+import Outputable
+import SrcLoc ( unLoc, Located(..) )
+import Char ( isSpace )
+import Bag ( bagToList )
+import Util ( count )
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Statistics}
+%* *
+%************************************************************************
+
+\begin{code}
+ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
+ = (if short then hcat else vcat)
+ (map pp_val
+ [("ExportAll ", export_all), -- 1 if no export list
+ ("ExportDecls ", export_ds),
+ ("ExportModules ", export_ms),
+ ("Imports ", import_no),
+ (" ImpQual ", import_qual),
+ (" ImpAs ", import_as),
+ (" ImpAll ", import_all),
+ (" ImpPartial ", import_partial),
+ (" ImpHiding ", import_hiding),
+ ("FixityDecls ", fixity_sigs),
+ ("DefaultDecls ", default_ds),
+ ("TypeDecls ", type_ds),
+ ("DataDecls ", data_ds),
+ ("NewTypeDecls ", newt_ds),
+ ("DataConstrs ", data_constrs),
+ ("DataDerivings ", data_derivs),
+ ("ClassDecls ", class_ds),
+ ("ClassMethods ", class_method_ds),
+ ("DefaultMethods ", default_method_ds),
+ ("InstDecls ", inst_ds),
+ ("InstMethods ", inst_method_ds),
+ ("TypeSigs ", bind_tys),
+ ("ValBinds ", val_bind_ds),
+ ("FunBinds ", fn_bind_ds),
+ ("InlineMeths ", method_inlines),
+ ("InlineBinds ", bind_inlines),
+-- ("SpecialisedData ", data_specs),
+-- ("SpecialisedInsts ", inst_specs),
+ ("SpecialisedMeths ", method_specs),
+ ("SpecialisedBinds ", bind_specs)
+ ])
+ where
+ decls = map unLoc ldecls
+
+ pp_val (str, 0) = empty
+ pp_val (str, n)
+ | not short = hcat [text str, int n]
+ | otherwise = hcat [text (trim str), equals, int n, semi]
+
+ trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
+
+ (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
+
+ tycl_decls = [d | TyClD d <- decls]
+ (class_ds, type_ds, data_ds, newt_ds) = countTyClDecls tycl_decls
+
+ inst_decls = [d | InstD d <- decls]
+ inst_ds = length inst_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 = count (\ e -> case unLoc 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)
+ = foldr add2 (0,0) (map count_bind 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)
+ (data_constrs, data_derivs)
+ = foldr add2 (0,0) (map data_info tycl_decls)
+ (class_method_ds, default_method_ds)
+ = foldr add2 (0,0) (map class_info tycl_decls)
+ (inst_method_ds, method_specs, method_inlines)
+ = foldr add3 (0,0,0) (map inst_info inst_decls)
+
+ count_bind (PatBind { pat_lhs = L _ (VarPat n) }) = (1,0)
+ count_bind (PatBind {}) = (0,1)
+ count_bind (FunBind {}) = (0,1)
+
+ count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
+
+ sig_info (FixSig _) = (1,0,0,0)
+ sig_info (TypeSig _ _) = (0,1,0,0)
+ sig_info (SpecSig _ _ _) = (0,0,1,0)
+ sig_info (InlineSig _ _) = (0,0,0,1)
+ sig_info _ = (0,0,0,0)
+
+ import_info (L _ (ImportDecl _ _ qual as spec))
+ = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
+ qual_info False = 0
+ qual_info True = 1
+ as_info Nothing = 0
+ as_info (Just _) = 1
+ spec_info Nothing = (0,0,0,1,0,0)
+ spec_info (Just (False, _)) = (0,0,0,0,1,0)
+ spec_info (Just (True, _)) = (0,0,0,0,0,1)
+
+ data_info (TyData {tcdCons = 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 (map unLoc (tcdSigs decl)) of
+ (_,classops,_,_) ->
+ (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
+ class_info other = (0,0)
+
+ inst_info (InstDecl _ inst_meths inst_sigs)
+ = case count_sigs (map unLoc inst_sigs) of
+ (_,_,ss,is) ->
+ (addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is)
+
+ addpr :: (Int,Int) -> Int
+ add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
+ add3 :: (Int,Int,Int) -> (Int,Int,Int) -> (Int, Int, Int)
+ add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
+ add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
+
+ addpr (x,y) = x+y
+ add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
+ add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
+ add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
+ add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
+\end{code}
+
+
+
+
+
+
+
+
+
projects / ghc-hetmet.git / blobdiff