68fe87f98b8ecd026ec7e529d170eb90ee624f6d
[ghc.git] / utils / hpc / Hpc.hs
1 -- (c) 2007 Andy Gill
2
3 -- Main driver for Hpc
4 import Trace.Hpc.Tix
5 import HpcFlags
6 import System.Environment
7 import System.Exit
8 import System.Console.GetOpt
9
10 import HpcReport
11 import HpcMarkup
12 import HpcCombine
13 import HpcShowTix
14 import HpcDraft
15 import HpcOverlay
16
17 helpList :: IO ()
18 helpList =
19 putStrLn $
20 "Usage: hpc COMMAND ...\n\n" ++
21 section "Commands" help ++
22 section "Reporting Coverage" reporting ++
23 section "Processing Coverage files" processing ++
24 section "Coverage Overlays" overlays ++
25 section "Others" other ++
26 ""
27 where
28 help = ["help"]
29 reporting = ["report","markup"]
30 overlays = ["overlay","draft"]
31 processing = ["sum","combine","map"]
32 other = [ name hook
33 | hook <- hooks
34 , name hook `notElem`
35 (concat [help,reporting,processing,overlays])
36 ]
37
38 section :: String -> [String] -> String
39 section msg [] = ""
40 section msg cmds = msg ++ ":\n"
41 ++ unlines [ take 14 (" " ++ cmd ++ repeat ' ') ++ summary hook
42 | cmd <- cmds
43 , hook <- hooks
44 , name hook == cmd
45 ]
46
47 dispatch :: [String] -> IO ()
48 dispatch [] = do
49 helpList
50 exitWith ExitSuccess
51 dispatch (txt:args) = do
52 case lookup txt hooks' of
53 Just plugin -> parse plugin args
54 _ -> parse help_plugin (txt:args)
55 where
56 parse plugin args =
57 case getOpt Permute (options plugin []) args of
58 (_,_,errs) | not (null errs)
59 -> do putStrLn "hpc failed:"
60 sequence [ putStr (" " ++ err)
61 | err <- errs
62 ]
63 putStrLn $ "\n"
64 command_usage plugin
65 exitFailure
66 (o,ns,_) -> do
67 let flags = final_flags plugin
68 $ foldr (.) id o
69 $ init_flags plugin
70 implementation plugin flags ns
71 main = do
72 args <- getArgs
73 dispatch args
74
75 ------------------------------------------------------------------------------
76
77 hooks = [ help_plugin
78 , report_plugin
79 , markup_plugin
80 , sum_plugin
81 , combine_plugin
82 , map_plugin
83 , showtix_plugin
84 , overlay_plugin
85 , draft_plugin
86 , version_plugin
87 ]
88
89 hooks' = [ (name hook,hook) | hook <- hooks ]
90
91 ------------------------------------------------------------------------------
92
93 help_plugin = Plugin { name = "help"
94 , usage = "[<HPC_COMMAND>]"
95 , summary = "Display help for hpc or a single command"
96 , options = help_options
97 , implementation = help_main
98 , init_flags = default_flags
99 , final_flags = default_final_flags
100 }
101
102 help_main flags [] = do
103 helpList
104 exitWith ExitSuccess
105 help_main flags (sub_txt:_) = do
106 case lookup sub_txt hooks' of
107 Nothing -> do
108 putStrLn $ "no such hpc command : " ++ sub_txt
109 exitFailure
110 Just plugin' -> do
111 command_usage plugin'
112 exitWith ExitSuccess
113
114 help_options = id
115
116 ------------------------------------------------------------------------------
117
118 version_plugin = Plugin { name = "version"
119 , usage = ""
120 , summary = "Display version for hpc"
121 , options = id
122 , implementation = version_main
123 , init_flags = default_flags
124 , final_flags = default_final_flags
125 }
126
127 version_main _ _ = putStrLn $ "hpc tools, version 0.6"
128
129
130 ------------------------------------------------------------------------------