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 = ["combine"]
  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         , combine_plugin
  81         , showtix_plugin
  82         , overlay_plugin
  83         , draft_plugin
  84         , version_plugin
  85         ]
  86
  87 hooks' = [ (name hook,hook) | hook <- hooks ]
  88
  89 ------------------------------------------------------------------------------
  90
  91 help_plugin = Plugin { name = "help"
  92                    , usage = "[<HPC_COMMAND>]"
  93                    , summary = "Display help for hpc or a single command."
  94                    , options = help_options
  95                    , implementation = help_main
  96                    , init_flags = default_flags
  97                    , final_flags = default_final_flags
  98                    }
  99
 100 help_main flags [] = do
 101             helpList
 102             exitWith ExitSuccess
 103 help_main flags (sub_txt:_) = do
 104     case lookup sub_txt hooks' of
 105       Nothing -> do
 106           putStrLn $ "no such hpc command : " ++ sub_txt
 107           exitFailure
 108       Just plugin' -> do
 109           command_usage plugin'
 110           exitWith ExitSuccess
 111
 112 help_options   = id
 113
 114 ------------------------------------------------------------------------------
 115
 116 version_plugin = Plugin { name = "version"
 117                    , usage = ""
 118                    , summary = "Display version for hpc"
 119                    , options = id
 120                    , implementation = version_main
 121                    , init_flags = default_flags
 122                    , final_flags = default_final_flags
 123                    }
 124
 125 version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev"
 126
 127
 128 ------------------------------------------------------------------------------