+ } ) } } }
+ where
+ -------------------------------------------------------------
+ -- ****** printing styles and column width:
+
+ pprCols = (80 :: Int) -- could make configurable
+
+ (pprStyle, pprErrorsStyle)
+ = if opt_PprStyle_All then
+ (PprShowAll, PprShowAll)
+ else if opt_PprStyle_Debug then
+ (PprDebug, PprDebug)
+ else if opt_PprStyle_User then
+ (PprForUser, PprForUser)
+ else -- defaults...
+ (PprDebug, PprForUser)
+
+ pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
+
+ -------------------------------------------------------------
+ -- ****** help functions:
+
+ show_pass
+ = if opt_D_show_passes
+ then \ what -> writeMn stderr ("*** "++what++":\n")
+ else \ what -> returnMn ()
+
+ doOutput switch io_action
+ = case switch of
+ Nothing -> returnMn ()
+ Just fn -> let fname = _UNPK_ fn in
+ fopen fname "a+" `thenPrimIO` \ file ->
+ if (file == ``NULL'') then
+ error ("doOutput: failed to open:"++fname)
+ else
+ io_action file `thenMn` \ () ->
+ fclose file `thenPrimIO` \ status ->
+ if status == 0
+ then returnMn ()
+ else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
+
+ doDump switch hdr string
+ = if switch
+ then writeMn stderr hdr `thenMn_`
+ writeMn stderr ('\n': string) `thenMn_`
+ writeMn stderr "\n"
+ else returnMn ()
+
+
+ppSourceStats (HsModule name exports imports fixities typedecls typesigs
+ classdecls instdecls instsigs defdecls binds
+ [{-no sigs-}] src_loc)
+ = ppAboves (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_ds),
+ ("DefaultDecls ", defalut_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
+ pp_val (str, 0) = ppNil
+ pp_val (str, n) = ppBesides [ppStr str, ppInt n]
+
+ (export_decls, export_mods) = getRawExportees exports
+ type_decls = filter is_type_decl typedecls
+ data_decls = filter is_data_decl typedecls
+ newt_decls = filter is_newt_decl typedecls
+
+ export_ds = length export_decls
+ export_ms = length export_mods
+ export_all = if export_ds == 0 && export_ms == 0 then 1 else 0
+
+ fixity_ds = length fixities
+ defalut_ds = length defdecls
+ type_ds = length type_decls
+ data_ds = length data_decls
+ newt_ds = length newt_decls
+ class_ds = length classdecls
+ inst_ds = length instdecls
+
+ (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
+ = count_binds binds
+
+ (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 (newt_decls ++ data_decls))
+ (class_method_ds, default_method_ds)
+ = foldr add2 (0,0) (map class_info classdecls)
+ (inst_method_ds, method_specs, method_inlines)
+ = foldr add3 (0,0,0) (map inst_info instdecls)
+
+ data_specs = length typesigs
+ inst_specs = length instsigs
+
+ count_binds EmptyBinds = (0,0,0,0,0)
+ count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
+ count_binds (SingleBind b) = case count_bind b of
+ (vs,fs) -> (vs,fs,0,0,0)
+ count_binds (BindWith b sigs) = case (count_bind b, count_sigs sigs) of
+ ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
+
+ count_bind EmptyBind = (0,0)
+ count_bind (NonRecBind b) = count_monobinds b
+ count_bind (RecBind b) = count_monobinds b
+
+ 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_sigs sigs = foldr add4 (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 _ = (0,0,0,0)
+
+ import_info (ImportMod _ 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 _ _ _ constrs derivs _ _)
+ = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
+ data_info (TyNew _ _ _ constr derivs _ _)
+ = (length constr, case derivs of {Nothing -> 0; Just ds -> length ds})
+
+ class_info (ClassDecl _ _ _ meth_sigs def_meths _ _)
+ = case count_sigs meth_sigs of
+ (_,classops,_,_) ->
+ (classops, addpr (count_monobinds def_meths))
+
+ inst_info (InstDecl _ _ inst_meths _ _ inst_sigs _ _)
+ = case count_sigs inst_sigs of
+ (_,_,ss,is) ->
+ (addpr (count_monobinds inst_meths), ss, is)
+
+ is_type_decl (TySynonym _ _ _ _) = True
+ is_type_decl _ = False
+ is_data_decl (TyData _ _ _ _ _ _ _) = True
+ is_data_decl _ = False
+ is_newt_decl (TyNew _ _ _ _ _ _ _) = True
+ is_newt_decl _ = False
+
+ addpr (x,y) = x+y
+ add1 x1 y1 = x1+y1
+ 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)
+ add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
+ 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)