Skip to content
Snippets Groups Projects
Commit 4802509c authored by BinderDavid's avatar BinderDavid
Browse files

Refactor hpcmain:

* 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`
parent 60b17734
No related branches found
No related tags found
1 merge request!15Refactor hpcmain
Pipeline #58361 passed
......@@ -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
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment