HscStats.hs 7.1 KB
Newer Older
dterei's avatar
dterei committed
1 2 3 4 5
-- |
-- Statistics for per-module compilations
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--
6

7
{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
8

9 10
module HscStats ( ppSourceStats ) where

11 12
import GhcPrelude

dterei's avatar
dterei committed
13
import Bag
14 15
import HsSyn
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
16 17
import SrcLoc
import Util
Ian Lynagh's avatar
Ian Lynagh committed
18 19

import Data.Char
20

dterei's avatar
dterei committed
21
-- | Source Statistics
22
ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc
23
ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
dterei's avatar
dterei committed
24
  = (if short then hcat else vcat)
25
        (map pp_val
dterei's avatar
dterei committed
26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
            [("ExportAll        ", export_all), -- 1 if no export list
             ("ExportDecls      ", export_ds),
             ("ExportModules    ", export_ms),
             ("Imports          ", imp_no),
             ("  ImpSafe        ", imp_safe),
             ("  ImpQual        ", imp_qual),
             ("  ImpAs          ", imp_as),
             ("  ImpAll         ", imp_all),
             ("  ImpPartial     ", imp_partial),
             ("  ImpHiding      ", imp_hiding),
             ("FixityDecls      ", fixity_sigs),
             ("DefaultDecls     ", default_ds),
             ("TypeDecls        ", type_ds),
             ("DataDecls        ", data_ds),
             ("NewTypeDecls     ", newt_ds),
             ("TypeFamilyDecls  ", type_fam_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),
             ("InstType         ", inst_type_ds),
             ("InstData         ", inst_data_ds),
             ("TypeSigs         ", bind_tys),
52
             ("ClassOpSigs      ", generic_sigs),
dterei's avatar
dterei committed
53 54
             ("ValBinds         ", val_bind_ds),
             ("FunBinds         ", fn_bind_ds),
cactus's avatar
cactus committed
55
             ("PatSynBinds      ", patsyn_ds),
dterei's avatar
dterei committed
56 57 58 59 60
             ("InlineMeths      ", method_inlines),
             ("InlineBinds      ", bind_inlines),
             ("SpecialisedMeths ", method_specs),
             ("SpecialisedBinds ", bind_specs)
            ])
61
  where
62 63
    decls = map unLoc ldecls

Ian Lynagh's avatar
Ian Lynagh committed
64
    pp_val (_, 0) = empty
65
    pp_val (str, n)
66 67
      | not short   = hcat [text str, int n]
      | otherwise   = hcat [text (trim str), equals, int n, semi]
68

dterei's avatar
dterei committed
69
    trim ls    = takeWhile (not.isSpace) (dropWhile isSpace ls)
70

71
    (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
72
        = count_sigs [d | SigD _ d <- decls]
dterei's avatar
dterei committed
73
                -- NB: this omits fixity decls on local bindings and
dterei's avatar
dterei committed
74
                -- in class decls. ToDo
75

76
    tycl_decls = [d | TyClD _ d <- decls]
77
    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =
78
      countTyClDecls tycl_decls
79

80
    inst_decls = [d | InstD _ d <- decls]
dterei's avatar
dterei committed
81 82
    inst_ds    = length inst_decls
    default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
83
    val_decls  = [d | ValD _ d <- decls]
84

85
    real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }
dterei's avatar
dterei committed
86 87
    n_exports    = length real_exports
    export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False})
sof's avatar
sof committed
88
                         real_exports
dterei's avatar
dterei committed
89 90
    export_ds    = n_exports - export_ms
    export_all   = case exports of { Nothing -> 1; _ -> 0 }
91

cactus's avatar
cactus committed
92 93
    (val_bind_ds, fn_bind_ds, patsyn_ds)
        = sum3 (map count_bind val_decls)
94

95
    (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)
cactus's avatar
cactus committed
96
        = sum7 (map import_info imports)
97
    (data_constrs, data_derivs)
cactus's avatar
cactus committed
98
        = sum2 (map data_info tycl_decls)
99
    (class_method_ds, default_method_ds)
cactus's avatar
cactus committed
100
        = sum2 (map class_info tycl_decls)
101
    (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
cactus's avatar
cactus committed
102
        = sum5 (map inst_info inst_decls)
103

104
    count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0)
cactus's avatar
cactus committed
105 106 107
    count_bind (PatBind {})                           = (0,1,0)
    count_bind (FunBind {})                           = (0,1,0)
    count_bind (PatSynBind {})                        = (0,0,1)
Ian Lynagh's avatar
Ian Lynagh committed
108
    count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
109

cactus's avatar
cactus committed
110
    count_sigs sigs = sum5 (map sig_info sigs)
111

112 113 114 115 116 117
    sig_info (FixSig {})     = (1,0,0,0,0)
    sig_info (TypeSig {})    = (0,1,0,0,0)
    sig_info (SpecSig {})    = (0,0,1,0,0)
    sig_info (InlineSig {})  = (0,0,0,1,0)
    sig_info (ClassOpSig {}) = (0,0,0,0,1)
    sig_info _               = (0,0,0,0,0)
118

119 120
    import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
                                 , ideclAs = as, ideclHiding = spec }))
dterei's avatar
dterei committed
121
        = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
122
    import_info (L _ (XImportDecl _)) = panic "import_info"
123
    safe_info = qual_info
124 125 126 127
    qual_info False  = 0
    qual_info True   = 1
    as_info Nothing  = 0
    as_info (Just _) = 1
dterei's avatar
dterei committed
128
    spec_info Nothing           = (0,0,0,0,1,0,0)
129 130
    spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
    spec_info (Just (True, _))  = (0,0,0,0,0,0,1)
131

132
    data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
Ryan Scott's avatar
Ryan Scott committed
133 134 135 136
                                                   , dd_derivs = L _ derivs}})
        = ( length cs
          , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
                   0 derivs )
Ian Lynagh's avatar
Ian Lynagh committed
137
    data_info _ = (0,0)
138

139
    class_info decl@(ClassDecl {})
cactus's avatar
cactus committed
140 141
        = (classops, addpr (sum3 (map count_bind methods)))
      where
142
        methods = map unLoc $ bagToList (tcdMeths decl)
cactus's avatar
cactus committed
143
        (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
Ian Lynagh's avatar
Ian Lynagh committed
144
    class_info _ = (0,0)
145

146 147 148 149 150 151
    inst_info (TyFamInstD {}) = (0,0,0,1,0)
    inst_info (DataFamInstD {}) = (0,0,0,0,1)
    inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths
                                                 , cid_sigs = inst_sigs
                                                 , cid_tyfam_insts = ats
                                                 , cid_datafam_insts = adts } })
dterei's avatar
dterei committed
152 153
        = case count_sigs (map unLoc inst_sigs) of
            (_,_,ss,is,_) ->
cactus's avatar
cactus committed
154
                  (addpr (sum3 (map count_bind methods)),
155
                   ss, is, length ats, length adts)
cactus's avatar
cactus committed
156
      where
157
        methods = map unLoc $ bagToList inst_meths
158 159
    inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info"
    inst_info (XInstDecl _)                 = panic "inst_info"
cactus's avatar
cactus committed
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180

    -- TODO: use Sum monoid
    addpr :: (Int,Int,Int) -> Int
    sum2 :: [(Int, Int)] -> (Int, Int)
    sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)
    sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
    sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int)
    add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int)
         -> (Int, Int, Int, Int, Int, Int, Int)

    addpr (x,y,z) = x+y+z
    sum2 = foldr add2 (0,0)
      where
        add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
    sum3 = foldr add3 (0,0,0)
      where
        add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
    sum5 = foldr add5 (0,0,0,0,0)
      where
        add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
    sum7 = foldr add7 (0,0,0,0,0,0,0)
181

182
    add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)