{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

-- |
-- Statistics for per-module compilations
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--

module GHC.Hs.Stats ( ppSourceStats ) where

import GHC.Prelude

import GHC.Data.Bag
import GHC.Hs
import GHC.Types.SrcLoc

import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic

import Data.Char

-- | Source Statistics
ppSourceStats :: Bool -> Located HsModule -> SDoc
ppSourceStats :: Bool -> Located HsModule -> SDoc
ppSourceStats Bool
short (L SrcSpan
_ (HsModule{ hsmodExports :: HsModule -> Maybe (LocatedL [LIE GhcPs])
hsmodExports = Maybe (LocatedL [LIE GhcPs])
exports, hsmodImports :: HsModule -> [LImportDecl GhcPs]
hsmodImports = [LImportDecl GhcPs]
imports, hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDecls = [LHsDecl GhcPs]
ldecls }))
  = (if Bool
short then [SDoc] -> SDoc
hcat else [SDoc] -> SDoc
vcat)
        (forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> SDoc
pp_val
            [(String
"ExportAll        ", Int
export_all), -- 1 if no export list
             (String
"ExportDecls      ", Int
export_ds),
             (String
"ExportModules    ", Int
export_ms),
             (String
"Imports          ", Int
imp_no),
             (String
"  ImpSafe        ", Int
imp_safe),
             (String
"  ImpQual        ", Int
imp_qual),
             (String
"  ImpAs          ", Int
imp_as),
             (String
"  ImpAll         ", Int
imp_all),
             (String
"  ImpPartial     ", Int
imp_partial),
             (String
"  ImpHiding      ", Int
imp_hiding),
             (String
"FixityDecls      ", Int
fixity_sigs),
             (String
"DefaultDecls     ", Int
default_ds),
             (String
"TypeDecls        ", Int
type_ds),
             (String
"DataDecls        ", Int
data_ds),
             (String
"NewTypeDecls     ", Int
newt_ds),
             (String
"TypeFamilyDecls  ", Int
type_fam_ds),
             (String
"DataConstrs      ", Int
data_constrs),
             (String
"DataDerivings    ", Int
data_derivs),
             (String
"ClassDecls       ", Int
class_ds),
             (String
"ClassMethods     ", Int
class_method_ds),
             (String
"DefaultMethods   ", Int
default_method_ds),
             (String
"InstDecls        ", Int
inst_ds),
             (String
"InstMethods      ", Int
inst_method_ds),
             (String
"InstType         ", Int
inst_type_ds),
             (String
"InstData         ", Int
inst_data_ds),
             (String
"TypeSigs         ", Int
bind_tys),
             (String
"ClassOpSigs      ", Int
generic_sigs),
             (String
"ValBinds         ", Int
val_bind_ds),
             (String
"FunBinds         ", Int
fn_bind_ds),
             (String
"PatSynBinds      ", Int
patsyn_ds),
             (String
"InlineMeths      ", Int
method_inlines),
             (String
"InlineBinds      ", Int
bind_inlines),
             (String
"SpecialisedMeths ", Int
method_specs),
             (String
"SpecialisedBinds ", Int
bind_specs)
            ])
  where
    decls :: [HsDecl GhcPs]
decls = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [LHsDecl GhcPs]
ldecls

    pp_val :: (String, Int) -> SDoc
pp_val (String
_, Int
0) = SDoc
empty
    pp_val (String
str, Int
n)
      | Bool -> Bool
not Bool
short   = [SDoc] -> SDoc
hcat [String -> SDoc
text String
str, Int -> SDoc
int Int
n]
      | Bool
otherwise   = [SDoc] -> SDoc
hcat [String -> SDoc
text (String -> String
trim String
str), SDoc
equals, Int -> SDoc
int Int
n, SDoc
semi]

    trim :: String -> String
trim String
ls    = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace) (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
ls)

    (Int
fixity_sigs, Int
bind_tys, Int
bind_specs, Int
bind_inlines, Int
generic_sigs)
        = forall {pass}. [Sig pass] -> (Int, Int, Int, Int, Int)
count_sigs [Sig GhcPs
d | SigD XSigD GhcPs
_ Sig GhcPs
d <- [HsDecl GhcPs]
decls]
                -- NB: this omits fixity decls on local bindings and
                -- in class decls. ToDo

    tycl_decls :: [TyClDecl GhcPs]
tycl_decls = [TyClDecl GhcPs
d | TyClD XTyClD GhcPs
_ TyClDecl GhcPs
d <- [HsDecl GhcPs]
decls]
    (Int
class_ds, Int
type_ds, Int
data_ds, Int
newt_ds, Int
type_fam_ds) =
      forall pass. [TyClDecl pass] -> (Int, Int, Int, Int, Int)
countTyClDecls [TyClDecl GhcPs]
tycl_decls

    inst_decls :: [InstDecl GhcPs]
inst_decls = [InstDecl GhcPs
d | InstD XInstD GhcPs
_ InstDecl GhcPs
d <- [HsDecl GhcPs]
decls]
    inst_ds :: Int
inst_ds    = forall (t :: * -> *) a. Foldable t => t a -> Int
length [InstDecl GhcPs]
inst_decls
    default_ds :: Int
default_ds = forall a. (a -> Bool) -> [a] -> Int
count (\ HsDecl GhcPs
x -> case HsDecl GhcPs
x of { DefD{} -> Bool
True; HsDecl GhcPs
_ -> Bool
False}) [HsDecl GhcPs]
decls
    val_decls :: [HsBindLR GhcPs GhcPs]
val_decls  = [HsBindLR GhcPs GhcPs
d | ValD XValD GhcPs
_ HsBindLR GhcPs GhcPs
d <- [HsDecl GhcPs]
decls]

    real_exports :: [GenLocated SrcSpanAnnA (IE GhcPs)]
real_exports = case Maybe (LocatedL [LIE GhcPs])
exports of { Maybe (LocatedL [LIE GhcPs])
Nothing -> []; Just (L SrcSpanAnnL
_ [LIE GhcPs]
es) -> [LIE GhcPs]
es }
    n_exports :: Int
n_exports    = forall (t :: * -> *) a. Foldable t => t a -> Int
length [GenLocated SrcSpanAnnA (IE GhcPs)]
real_exports
    export_ms :: Int
export_ms    = forall a. (a -> Bool) -> [a] -> Int
count (\ GenLocated SrcSpanAnnA (IE GhcPs)
e -> case forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (IE GhcPs)
e of { IEModuleContents{} -> Bool
True
                                                 ; IE GhcPs
_ -> Bool
False})
                         [GenLocated SrcSpanAnnA (IE GhcPs)]
real_exports
    export_ds :: Int
export_ds    = Int
n_exports forall a. Num a => a -> a -> a
- Int
export_ms
    export_all :: Int
export_all   = case Maybe (LocatedL [LIE GhcPs])
exports of { Maybe (LocatedL [LIE GhcPs])
Nothing -> Int
1; Maybe (LocatedL [LIE GhcPs])
_ -> Int
0 }

    (Int
val_bind_ds, Int
fn_bind_ds, Int
patsyn_ds)
        = [(Int, Int, Int)] -> (Int, Int, Int)
sum3 (forall a b. (a -> b) -> [a] -> [b]
map forall {idL} {l} {a} {b} {c} {idR}.
(XRec idL (Pat idL) ~ GenLocated l (Pat idL), Num a, Num b, Num c,
 Outputable (HsBindLR idL idR)) =>
HsBindLR idL idR -> (a, b, c)
count_bind [HsBindLR GhcPs GhcPs]
val_decls)

    (Int
imp_no, Int
imp_safe, Int
imp_qual, Int
imp_as, Int
imp_all, Int
imp_partial, Int
imp_hiding)
        = [(Int, Int, Int, Int, Int, Int, Int)]
-> (Int, Int, Int, Int, Int, Int, Int)
sum7 (forall a b. (a -> b) -> [a] -> [b]
map LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int)
import_info [LImportDecl GhcPs]
imports)
    (Int
data_constrs, Int
data_derivs)
        = [(Int, Int)] -> (Int, Int)
sum2 (forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {t :: * -> *} {a} {l}.
(XRec pass (DerivClauseTys pass) ~ t a,
 XRec pass (HsDerivingClause pass)
 ~ GenLocated l (HsDerivingClause pass),
 Foldable t) =>
TyClDecl pass -> (Int, Int)
data_info [TyClDecl GhcPs]
tycl_decls)
    (Int
class_method_ds, Int
default_method_ds)
        = [(Int, Int)] -> (Int, Int)
sum2 (forall a b. (a -> b) -> [a] -> [b]
map forall {pass} {l} {l} {l}.
(XRec pass (HsBindLR pass pass)
 ~ GenLocated l (HsBindLR pass pass),
 XRec pass (Sig pass) ~ GenLocated l (Sig pass),
 XRec pass (Pat pass) ~ GenLocated l (Pat pass),
 Outputable (HsBindLR pass pass)) =>
TyClDecl pass -> (Int, Int)
class_info [TyClDecl GhcPs]
tycl_decls)
    (Int
inst_method_ds, Int
method_specs, Int
method_inlines, Int
inst_type_ds, Int
inst_data_ds)
        = [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
sum5 (forall a b. (a -> b) -> [a] -> [b]
map InstDecl GhcPs -> (Int, Int, Int, Int, Int)
inst_info [InstDecl GhcPs]
inst_decls)

    count_bind :: HsBindLR idL idR -> (a, b, c)
count_bind (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = L l
_ (VarPat{}) }) = (a
1,b
0,c
0)
    count_bind (PatBind {})                           = (a
0,b
1,c
0)
    count_bind (FunBind {})                           = (a
0,b
1,c
0)
    count_bind (PatSynBind {})                        = (a
0,b
0,c
1)
    count_bind HsBindLR idL idR
b = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"count_bind: Unhandled binder" (forall a. Outputable a => a -> SDoc
ppr HsBindLR idL idR
b)

    count_sigs :: [Sig pass] -> (Int, Int, Int, Int, Int)
count_sigs [Sig pass]
sigs = [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
sum5 (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c} {d} {e} {pass}.
(Num a, Num b, Num c, Num d, Num e) =>
Sig pass -> (a, b, c, d, e)
sig_info [Sig pass]
sigs)

    sig_info :: Sig pass -> (a, b, c, d, e)
sig_info (FixSig {})     = (a
1,b
0,c
0,d
0,e
0)
    sig_info (TypeSig {})    = (a
0,b
1,c
0,d
0,e
0)
    sig_info (SpecSig {})    = (a
0,b
0,c
1,d
0,e
0)
    sig_info (InlineSig {})  = (a
0,b
0,c
0,d
1,e
0)
    sig_info (ClassOpSig {}) = (a
0,b
0,c
0,d
0,e
1)
    sig_info Sig pass
_               = (a
0,b
0,c
0,d
0,e
0)

    import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int)
    import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int)
import_info (L SrcSpanAnnA
_ (ImportDecl { ideclSafe :: forall pass. ImportDecl pass -> Bool
ideclSafe = Bool
safe, ideclQualified :: forall pass. ImportDecl pass -> ImportDeclQualifiedStyle
ideclQualified = ImportDeclQualifiedStyle
qual
                                 , ideclAs :: forall pass. ImportDecl pass -> Maybe (XRec pass ModuleName)
ideclAs = Maybe (XRec GhcPs ModuleName)
as, ideclHiding :: forall pass. ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])
ideclHiding = Maybe (Bool, XRec GhcPs [LIE GhcPs])
spec }))
        = (Int, Int, Int, Int, Int, Int, Int)
-> (Int, Int, Int, Int, Int, Int, Int)
-> (Int, Int, Int, Int, Int, Int, Int)
add7 (Int
1, forall {a}. Num a => Bool -> a
safe_info Bool
safe, forall {a}. Num a => ImportDeclQualifiedStyle -> a
qual_info ImportDeclQualifiedStyle
qual, forall {a} {a}. Num a => Maybe a -> a
as_info Maybe (XRec GhcPs ModuleName)
as, Int
0,Int
0,Int
0) (forall {a} {b} {c} {d} {e} {f} {g} {b}.
(Num a, Num b, Num c, Num d, Num e, Num f, Num g) =>
Maybe (Bool, b) -> (a, b, c, d, e, f, g)
spec_info Maybe (Bool, XRec GhcPs [LIE GhcPs])
spec)

    safe_info :: Bool -> a
safe_info Bool
False = a
0
    safe_info Bool
True = a
1
    qual_info :: ImportDeclQualifiedStyle -> a
qual_info ImportDeclQualifiedStyle
NotQualified = a
0
    qual_info ImportDeclQualifiedStyle
_  = a
1
    as_info :: Maybe a -> a
as_info Maybe a
Nothing  = a
0
    as_info (Just a
_) = a
1
    spec_info :: Maybe (Bool, b) -> (a, b, c, d, e, f, g)
spec_info Maybe (Bool, b)
Nothing           = (a
0,b
0,c
0,d
0,e
1,f
0,g
0)
    spec_info (Just (Bool
False, b
_)) = (a
0,b
0,c
0,d
0,e
0,f
1,g
0)
    spec_info (Just (Bool
True, b
_))  = (a
0,b
0,c
0,d
0,e
0,f
0,g
1)

    data_info :: TyClDecl pass -> (Int, Int)
data_info (DataDecl { tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn
                                          { dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl pass]
cs
                                          , dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving pass
derivs}})
        = ( forall (t :: * -> *) a. Foldable t => t a -> Int
length [LConDecl pass]
cs
          , forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
s GenLocated l (HsDerivingClause pass)
dc -> forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall pass. HsDerivingClause pass -> LDerivClauseTys pass
deriv_clause_tys forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc GenLocated l (HsDerivingClause pass)
dc) forall a. Num a => a -> a -> a
+ Int
s)
                   Int
0 HsDeriving pass
derivs )
    data_info TyClDecl pass
_ = (Int
0,Int
0)

    class_info :: TyClDecl pass -> (Int, Int)
class_info decl :: TyClDecl pass
decl@(ClassDecl {})
        = (Int
classops, (Int, Int, Int) -> Int
addpr ([(Int, Int, Int)] -> (Int, Int, Int)
sum3 (forall a b. (a -> b) -> [a] -> [b]
map forall {idL} {l} {a} {b} {c} {idR}.
(XRec idL (Pat idL) ~ GenLocated l (Pat idL), Num a, Num b, Num c,
 Outputable (HsBindLR idL idR)) =>
HsBindLR idL idR -> (a, b, c)
count_bind [HsBindLR pass pass]
methods)))
      where
        methods :: [HsBindLR pass pass]
methods = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> [a]
bagToList (forall pass. TyClDecl pass -> LHsBinds pass
tcdMeths TyClDecl pass
decl)
        (Int
_, Int
classops, Int
_, Int
_, Int
_) = forall {pass}. [Sig pass] -> (Int, Int, Int, Int, Int)
count_sigs (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc (forall pass. TyClDecl pass -> [LSig pass]
tcdSigs TyClDecl pass
decl))
    class_info TyClDecl pass
_ = (Int
0,Int
0)

    inst_info :: InstDecl GhcPs -> (Int, Int, Int, Int, Int)
    inst_info :: InstDecl GhcPs -> (Int, Int, Int, Int, Int)
inst_info (TyFamInstD {}) = (Int
0,Int
0,Int
0,Int
1,Int
0)
    inst_info (DataFamInstD {}) = (Int
0,Int
0,Int
0,Int
0,Int
1)
    inst_info (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl {cid_binds :: forall pass. ClsInstDecl pass -> LHsBinds pass
cid_binds = LHsBinds GhcPs
inst_meths
                                                 , cid_sigs :: forall pass. ClsInstDecl pass -> [LSig pass]
cid_sigs = [XRec GhcPs (Sig GhcPs)]
inst_sigs
                                                 , cid_tyfam_insts :: forall pass. ClsInstDecl pass -> [LTyFamInstDecl pass]
cid_tyfam_insts = [LTyFamInstDecl GhcPs]
ats
                                                 , cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl GhcPs]
adts } })
        = case forall {pass}. [Sig pass] -> (Int, Int, Int, Int, Int)
count_sigs (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [XRec GhcPs (Sig GhcPs)]
inst_sigs) of
            (Int
_,Int
_,Int
ss,Int
is,Int
_) ->
                  ((Int, Int, Int) -> Int
addpr ([(Int, Int, Int)] -> (Int, Int, Int)
sum3 (forall a b. (a -> b) -> [a] -> [b]
map forall {idL} {l} {a} {b} {c} {idR}.
(XRec idL (Pat idL) ~ GenLocated l (Pat idL), Num a, Num b, Num c,
 Outputable (HsBindLR idL idR)) =>
HsBindLR idL idR -> (a, b, c)
count_bind [HsBindLR GhcPs GhcPs]
methods)),
                   Int
ss, Int
is, forall (t :: * -> *) a. Foldable t => t a -> Int
length [LTyFamInstDecl GhcPs]
ats, forall (t :: * -> *) a. Foldable t => t a -> Int
length [LDataFamInstDecl GhcPs]
adts)
      where
        methods :: [HsBindLR GhcPs GhcPs]
methods = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> [a]
bagToList LHsBinds GhcPs
inst_meths

    -- 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 :: (Int, Int, Int) -> Int
addpr (Int
x,Int
y,Int
z) = Int
xforall a. Num a => a -> a -> a
+Int
yforall a. Num a => a -> a -> a
+Int
z
    sum2 :: [(Int, Int)] -> (Int, Int)
sum2 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {b}. (Num a, Num b) => (a, b) -> (a, b) -> (a, b)
add2 (Int
0,Int
0)
      where
        add2 :: (a, b) -> (a, b) -> (a, b)
add2 (a
x1,b
x2) (a
y1,b
y2) = (a
x1forall a. Num a => a -> a -> a
+a
y1,b
x2forall a. Num a => a -> a -> a
+b
y2)
    sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)
sum3 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {b} {c}.
(Num a, Num b, Num c) =>
(a, b, c) -> (a, b, c) -> (a, b, c)
add3 (Int
0,Int
0,Int
0)
      where
        add3 :: (a, b, c) -> (a, b, c) -> (a, b, c)
add3 (a
x1,b
x2,c
x3) (a
y1,b
y2,c
y3) = (a
x1forall a. Num a => a -> a -> a
+a
y1,b
x2forall a. Num a => a -> a -> a
+b
y2,c
x3forall a. Num a => a -> a -> a
+c
y3)
    sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
sum5 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {b} {c} {d} {e}.
(Num a, Num b, Num c, Num d, Num e) =>
(a, b, c, d, e) -> (a, b, c, d, e) -> (a, b, c, d, e)
add5 (Int
0,Int
0,Int
0,Int
0,Int
0)
      where
        add5 :: (a, b, c, d, e) -> (a, b, c, d, e) -> (a, b, c, d, e)
add5 (a
x1,b
x2,c
x3,d
x4,e
x5) (a
y1,b
y2,c
y3,d
y4,e
y5) = (a
x1forall a. Num a => a -> a -> a
+a
y1,b
x2forall a. Num a => a -> a -> a
+b
y2,c
x3forall a. Num a => a -> a -> a
+c
y3,d
x4forall a. Num a => a -> a -> a
+d
y4,e
x5forall a. Num a => a -> a -> a
+e
y5)
    sum7 :: [(Int, Int, Int, Int, Int, Int, Int)]
-> (Int, Int, Int, Int, Int, Int, Int)
sum7 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int, Int, Int, Int, Int, Int)
-> (Int, Int, Int, Int, Int, Int, Int)
-> (Int, Int, Int, Int, Int, Int, Int)
add7 (Int
0,Int
0,Int
0,Int
0,Int
0,Int
0,Int
0)

    add7 :: (Int, Int, Int, Int, Int, Int, Int)
-> (Int, Int, Int, Int, Int, Int, Int)
-> (Int, Int, Int, Int, Int, Int, Int)
add7 (Int
x1,Int
x2,Int
x3,Int
x4,Int
x5,Int
x6,Int
x7) (Int
y1,Int
y2,Int
y3,Int
y4,Int
y5,Int
y6,Int
y7) = (Int
x1forall a. Num a => a -> a -> a
+Int
y1,Int
x2forall a. Num a => a -> a -> a
+Int
y2,Int
x3forall a. Num a => a -> a -> a
+Int
y3,Int
x4forall a. Num a => a -> a -> a
+Int
y4,Int
x5forall a. Num a => a -> a -> a
+Int
y5,Int
x6forall a. Num a => a -> a -> a
+Int
y6,Int
x7forall a. Num a => a -> a -> a
+Int
y7)