1-- (c) 2007 Andy Gill
2
3-- Main driver for Hpc
4import Data.Version
5import System.Environment
6import System.Exit
7import System.Console.GetOpt
8
9import HpcFlags
10import HpcReport
11import HpcMarkup
12import HpcCombine
13import HpcShowTix
14import HpcDraft
15import HpcOverlay
16import Paths_hpc_bin
17
18helpList :: IO ()
19helpList =
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
39section :: String -> [String] -> String
40section _   []   = ""
41section msg cmds = msg ++ ":\n"
42        ++ unlines [ take 14 ("  " ++ cmd ++ repeat ' ') ++ summary hook
43                   | cmd <- cmds
44                   , hook <- hooks
45                   , name hook == cmd
46                   ]
47
48dispatch :: [String] -> IO ()
49dispatch [] = do
50             helpList
51             exitWith ExitSuccess
52dispatch (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
73main :: IO ()
74main = do
75 args <- getArgs
76 dispatch args
77
78------------------------------------------------------------------------------
79
80hooks :: [Plugin]
81hooks = [ 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
93hooks' :: [(String, Plugin)]
94hooks' = [ (name hook,hook) | hook <- hooks ]
95
96------------------------------------------------------------------------------
97
98help_plugin :: Plugin
99help_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
108help_main :: Flags -> [String] -> IO ()
109help_main _ [] = do
110            helpList
111            exitWith ExitSuccess
112help_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
121help_options :: FlagOptSeq
122help_options   = id
123
124------------------------------------------------------------------------------
125
126version_plugin :: Plugin
127version_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
136version_main :: Flags -> [String] -> IO ()
137version_main _ _ = putStrLn ("hpc tools, version " ++ showVersion version)
138
139
140------------------------------------------------------------------------------
141