+ doDump opt_D_dump_asm "" ncg_output_d >>
+ doOutput opt_ProduceS ncg_output_w >>
+
+ doDump opt_D_dump_realC "" c_output_d >>
+ doOutput opt_ProduceC c_output_w >>
+
+ ghcExit 0
+ } } }
+ where
+ -------------------------------------------------------------
+ -- ****** printing styles and column width:
+
+
+ -------------------------------------------------------------
+ -- ****** help functions:
+
+ show_pass
+ = if opt_D_show_passes
+ then \ what -> hPutStr stderr ("*** "++what++":\n")
+ else \ what -> return ()
+
+ doOutput switch io_action
+ = case switch of
+ Nothing -> return ()
+ Just fname ->
+ openFile fname WriteMode >>= \ handle ->
+ io_action handle >>
+ hClose handle
+
+ doDump switch hdr string
+ = if switch
+ then hPutStr stderr ("\n\n" ++ (take 80 $ repeat '=')) >>
+ hPutStr stderr ('\n': hdr) >>
+ hPutStr stderr ('\n': string) >>
+ hPutStr stderr "\n"
+ else return ()
+
+
+pprCols = (80 :: Int) -- could make configurable
+
+(pprStyle, pprErrorsStyle)
+ | opt_PprStyle_All = (PprShowAll, PprShowAll)
+ | opt_PprStyle_Debug = (PprDebug, PprDebug)
+ | opt_PprStyle_User = (PprQuote, PprQuote)
+ | otherwise = (PprDebug, PprQuote)
+
+pp_show p = show p -- ToDo: use pprCols
+
+checkErrors errs_bag warns_bag
+ | not (isEmptyBag errs_bag)
+ = hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle errs_bag))
+ >> hPutStr stderr "\n" >>
+ hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle warns_bag))
+ >> hPutStr stderr "\n" >>
+ ghcExit 1
+
+ | not (isEmptyBag warns_bag)
+ = hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle warns_bag)) >>
+ hPutStr stderr "\n"
+
+ | otherwise = return ()
+
+
+ppSourceStats (HsModule name version exports imports fixities decls src_loc)
+ = 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_ds),
+ ("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
+ pp_val (str, 0) = empty
+ pp_val (str, n) = hcat [text str, int n]
+
+ fixity_ds = length fixities
+ type_decls = [d | TyD d@(TySynonym _ _ _ _) <- decls]
+ data_decls = [d | TyD d@(TyData DataType _ _ _ _ _ _ _) <- decls]
+ newt_decls = [d | TyD d@(TyData NewType _ _ _ _ _ _ _) <- decls]
+ type_ds = length type_decls
+ data_ds = length data_decls
+ newt_ds = length newt_decls
+ class_decls = [d | ClD d <- decls]
+ class_ds = length class_decls
+ inst_decls = [d | InstD d <- decls]
+ inst_ds = length inst_decls
+ default_ds = length [() | DefD _ <- 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_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)
+
+ (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 class_decls)
+ (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_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 (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 _ _ _ _ constrs derivs _ _)
+ = (length constrs, 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)
+
+ 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)