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