diff --git a/src/HpcMain.hs b/src/HpcMain.hs
index 13069ef6dbc3827195b17b73f7891cdbf7776a17..fe07047d85601baa3d728c5905abe47e1209880c 100644
--- a/src/HpcMain.hs
+++ b/src/HpcMain.hs
@@ -8,30 +8,35 @@ import Data.Bifunctor (bimap)
import Data.List (intercalate, partition, uncons)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Maybe (catMaybes, isJust)
-import Data.Version
-import System.Environment
-import System.Exit
-import System.Console.GetOpt
+import Data.Version ( showVersion )
+import System.Environment ( getArgs )
+import System.Exit ( exitFailure, exitWith, ExitCode(ExitSuccess) )
+import System.Console.GetOpt ( getOpt, ArgOrder(Permute) )
import System.Directory (doesPathExist)
import HpcFlags
-import HpcReport
-import HpcMarkup
-import HpcCombine
-import HpcShowTix
-import HpcDraft
-import HpcOverlay
-import Paths_hpc_bin
+ ( Plugin(..),
+ Flags,
+ default_flags,
+ default_final_flags,
+ command_usage )
+import HpcReport ( report_plugin )
+import HpcMarkup ( markup_plugin )
+import HpcCombine ( sum_plugin, combine_plugin, map_plugin )
+import HpcShowTix ( showtix_plugin )
+import HpcDraft ( draft_plugin )
+import HpcOverlay ( overlay_plugin )
+import Paths_hpc_bin ( version )
helpList :: IO ()
helpList = do
putStrLn $
- "Usage: hpc COMMAND ...\n\n" ++
- section "Commands" help ++
- section "Reporting Coverage" reporting ++
- section "Processing Coverage files" processing ++
- section "Coverage Overlays" overlays ++
- section "Others" other ++
+ "Usage: hpc COMMAND ...\n\n" <>
+ section "Commands" [help_plugin] <>
+ section "Reporting Coverage" [report_plugin, markup_plugin] <>
+ section "Processing Coverage files" [sum_plugin, combine_plugin, map_plugin] <>
+ section "Coverage Overlays" [overlay_plugin, draft_plugin] <>
+ section "Others" [showtix_plugin, version_plugin] <>
""
putStrLn ""
putStrLn "or: hpc @response_file_1 @response_file_2 ..."
@@ -42,35 +47,31 @@ helpList = do
putStrLn "example:"
putStrLn "report my_library.tix --include=ModuleA \\"
putStrLn "--include=ModuleB"
+
+-- | Print the summaries of all plugins belonging to a given section.
+section :: String -- ^ Name of the section.
+ -> [Plugin] -- ^ Plugins belonging to that section.
+ -> String
+section msg plugins = msg <> ":\n" <> unlines summaries
where
- help = ["help"]
- reporting = ["report","markup"]
- overlays = ["overlay","draft"]
- processing = ["sum","combine","map"]
- other = [ name hook
- | hook <- hooks
- , name hook `notElem`
- (concat [help,reporting,processing,overlays])
- ]
-
-section :: String -> [String] -> String
-section _ [] = ""
-section msg cmds = msg ++ ":\n"
- ++ unlines [ take 14 (" " ++ cmd ++ repeat ' ') ++ summary hook
- | cmd <- cmds
- , hook <- hooks
- , name hook == cmd
- ]
+ summaries = [ take 14 (" " <> name plugin <> repeat ' ') <> summary plugin | plugin <- plugins ]
+
+main :: IO ()
+main = do
+ args <- getArgs
+ dispatch args
+-- | The main dispatch function. It either accepts a valid command followed by a list of its arguments,
+-- or a list of response files of the form '@filename'.
dispatch :: [String] -> IO ()
dispatch [] = do
helpList
exitWith ExitSuccess
dispatch (txt:args0) = do
case lookup txt hooks' of
- Just plugin -> parse plugin args0
+ Just plugin -> dispatchOnPlugin plugin args0
_ -> case getResponseFileName txt of
- Nothing -> parse help_plugin (txt:args0)
+ Nothing -> dispatchOnPlugin help_plugin (txt:args0)
Just firstResponseFileName -> do
let
(responseFileNames', nonResponseFileNames) = partitionFileNames args0
@@ -82,38 +83,7 @@ dispatch (txt:args0) = do
putStrLn $ "When first argument is a Response File, " <>
"all arguments should be Response Files."
exitFailure
- let
- responseFileNames :: NonEmpty FilePath
- responseFileNames = firstResponseFileName :| responseFileNames'
-
- forM_ responseFileNames $ \responseFileName -> do
- exists <- doesPathExist responseFileName
- when (not exists) $ do
- putStrLn $ "Response File '" <> responseFileName <> "' does not exist"
- exitFailure
-
- -- read all Response Files
- responseFileNamesAndText :: NonEmpty (FilePath, String) <-
- forM responseFileNames $ \responseFileName ->
- fmap (responseFileName, ) (readFile responseFileName)
- forM_ responseFileNamesAndText $ \(responseFileName, responseFileText) ->
- -- parse first word of Response File, which should be a command
- case uncons $ words responseFileText of
- Nothing -> do
- putStrLn $ "Response File '" <> responseFileName <> "' has no command"
- exitFailure
- Just (responseFileCommand, args1) -> case lookup responseFileCommand hooks' of
- -- check command for validity
- -- It is important than a Response File cannot specify another Response File;
- -- this is prevented
- Nothing -> do
- putStrLn $ "Response File '" <> responseFileName <>
- "' command '" <> responseFileCommand <> "' invalid"
- exitFailure
- Just plugin -> do
- putStrLn $ "Response File '" <> responseFileName <> "':"
- parse plugin args1
-
+ dispatchOnResponseFiles (firstResponseFileName :| responseFileNames')
where
getResponseFileName :: String -> Maybe FilePath
getResponseFileName s = do
@@ -132,26 +102,52 @@ dispatch (txt:args0) = do
bimap (fmap snd) (fmap fst) $ partition (isJust . snd) hasFileName
in (catMaybes fileNames, nonFileNames)
- parse plugin args =
- case getOpt Permute (options plugin []) args of
- (_,_,errs) | not (null errs)
- -> do putStrLn "hpc failed:"
- sequence_ [ putStr (" " ++ err)
- | err <- errs
- ]
- putStrLn $ "\n"
- command_usage plugin
- exitFailure
- (o,ns,_) -> do
- let flags = final_flags plugin
- . foldr (.) id o
- $ init_flags plugin
- implementation plugin flags ns
-
-main :: IO ()
-main = do
- args <- getArgs
- dispatch args
+-- | Dispatch on a given list of response files.
+dispatchOnResponseFiles :: NonEmpty FilePath -> IO ()
+dispatchOnResponseFiles fps = do
+ forM_ fps $ \responseFileName -> do
+ exists <- doesPathExist responseFileName
+ when (not exists) $ do
+ putStrLn $ "Response File '" <> responseFileName <> "' does not exist"
+ exitFailure
+
+ -- read all Response Files
+ responseFileNamesAndText :: NonEmpty (FilePath, String) <-
+ forM fps $ \responseFileName ->
+ fmap (responseFileName, ) (readFile responseFileName)
+ forM_ responseFileNamesAndText $ \(responseFileName, responseFileText) ->
+ -- parse first word of Response File, which should be a command
+ case uncons $ words responseFileText of
+ Nothing -> do
+ putStrLn $ "Response File '" <> responseFileName <> "' has no command"
+ exitFailure
+ Just (responseFileCommand, args1) -> case lookup responseFileCommand hooks' of
+ -- check command for validity
+ -- It is important than a Response File cannot specify another Response File;
+ -- this is prevented
+ Nothing -> do
+ putStrLn $ "Response File '" <> responseFileName <>
+ "' command '" <> responseFileCommand <> "' invalid"
+ exitFailure
+ Just plugin -> do
+ putStrLn $ "Response File '" <> responseFileName <> "':"
+ dispatchOnPlugin plugin args1
+
+-- | Dispatch on a given plugin and its arguments.
+dispatchOnPlugin :: Plugin -> [String] -> IO ()
+dispatchOnPlugin plugin args =
+ case getOpt Permute (options plugin []) args of
+ (_,_,errs) | not (null errs) -> do
+ putStrLn "hpc failed:"
+ sequence_ [ putStr (" " <> err) | err <- errs ]
+ putStrLn $ "\n"
+ command_usage plugin
+ exitFailure
+ (o,ns,_) -> do
+ let flags = final_flags plugin
+ . foldr (.) id o
+ $ init_flags plugin
+ implementation plugin flags ns
------------------------------------------------------------------------------
@@ -177,7 +173,7 @@ help_plugin :: Plugin
help_plugin = Plugin { name = "help"
, usage = "[<HPC_COMMAND>]"
, summary = "Display help for hpc or a single command"
- , options = help_options
+ , options = id
, implementation = help_main
, init_flags = default_flags
, final_flags = default_final_flags
@@ -196,9 +192,6 @@ help_main _ (sub_txt:_) = do
command_usage plugin'
exitWith ExitSuccess
-help_options :: FlagOptSeq
-help_options = id
-
------------------------------------------------------------------------------
version_plugin :: Plugin