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
  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 = ["combine"]
  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 msg []   = ""
  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:args) = do
  51      case lookup txt hooks' of
  52        Just plugin -> parse plugin
  53        _ -> parse help_plugin
  54   where
  55      parse plugin =
  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 = foldr (.) (final_flags plugin) o
  67                                    $ init_flags plugin
  68                          implementation plugin flags ns
  69 main = do
  70  args <- getArgs
  71  dispatch args
  72
  73 ------------------------------------------------------------------------------
  74
  75 hooks = [ help_plugin
  76         , report_plugin
  77         , markup_plugin
  78         , combine_plugin
  79         , showtix_plugin
  80         , draft_plugin
  81         , version_plugin
  82         ]
  83
  84 hooks' = [ (name hook,hook) | hook <- hooks ]
  85
  86 ------------------------------------------------------------------------------
  87
  88 help_plugin = Plugin { name = "help"
  89                    , usage = "[<HPC_COMMAND>]"
  90                    , summary = "Display help for hpc or a single command."
  91                    , options = help_options
  92                    , implementation = help_main
  93                    , init_flags = default_flags
  94                    , final_flags = default_final_flags
  95                    }
  96
  97 help_main flags [] = do
  98             helpList
  99             exitWith ExitSuccess
 100 help_main flags (sub_txt:_) = do
 101     case lookup sub_txt hooks' of
 102       Nothing -> do
 103           putStrLn $ "no such hpc command : " ++ sub_txt
 104           exitFailure
 105       Just plugin' -> do
 106           command_usage plugin'
 107           exitWith ExitSuccess
 108
 109 help_options   = []
 110
 111 ------------------------------------------------------------------------------
 112
 113 version_plugin = Plugin { name = "version"
 114                    , usage = ""
 115                    , summary = "Display version for hpc"
 116                    , options = []
 117                    , implementation = version_main
 118                    , init_flags = default_flags
 119                    , final_flags = default_final_flags
 120                    }
 121
 122 version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev"
 123
 124
 125 ------------------------------------------------------------------------------