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