Refactor hpcmain

This PR does mainly two things:

• Simplify the helpList function by explicitly passing the plugins to the section function, instead of passing the names of the plugins which then have to be looked up.
• Split the big dispatch function into three smaller functions on the toplevel: dispatch, dispatchOnPlugin and dispatchOnResponseFiles

This is all in preparation of the simplification of the command line parsing logic which is distributed all over the codebase.

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