diff options
Diffstat (limited to 'utils/hpc/Main.hs')
| -rw-r--r-- | utils/hpc/Main.hs | 217 |
1 files changed, 0 insertions, 217 deletions
diff --git a/utils/hpc/Main.hs b/utils/hpc/Main.hs deleted file mode 100644 index f7617ec677..0000000000 --- a/utils/hpc/Main.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TupleSections #-} --- (c) 2007 Andy Gill - --- Main driver for Hpc -import Control.Monad (forM, forM_, when) -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 System.Directory (doesPathExist) - -import HpcFlags -import HpcReport -import HpcMarkup -import HpcCombine -import HpcShowTix -import HpcDraft -import HpcOverlay -import Paths_hpc_bin - -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 ++ - "" - putStrLn "" - putStrLn "or: hpc @response_file_1 @response_file_2 ..." - putStrLn "" - putStrLn "The contents of a Response File must have this format:" - putStrLn "COMMAND ..." - putStrLn "" - putStrLn "example:" - putStrLn "report my_library.tix --include=ModuleA \\" - putStrLn "--include=ModuleB" - 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 - ] - -dispatch :: [String] -> IO () -dispatch [] = do - helpList - exitWith ExitSuccess -dispatch (txt:args0) = do - case lookup txt hooks' of - Just plugin -> parse plugin args0 - _ -> case getResponseFileName txt of - Nothing -> parse help_plugin (txt:args0) - Just firstResponseFileName -> do - let - (responseFileNames', nonResponseFileNames) = partitionFileNames args0 - -- if arguments are combination of Response Files and non-Response Files, exit with error - when (length nonResponseFileNames > 0) $ do - let - putStrLn $ "First argument '" <> txt <> "' is a Response File, " <> - "followed by non-Response File(s): '" <> intercalate "', '" nonResponseFileNames <> "'" - 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 - - where - getResponseFileName :: String -> Maybe FilePath - getResponseFileName s = do - (firstChar, filename) <- uncons s - if firstChar == '@' - then pure filename - else Nothing - - -- first member of tuple is list of Response File names, - -- second member of tuple is list of all other arguments - partitionFileNames :: [String] -> ([FilePath], [String]) - partitionFileNames xs = let - hasFileName :: [(String, Maybe FilePath)] - hasFileName = fmap (\x -> (x, getResponseFileName x)) xs - (fileNames, nonFileNames) :: ([Maybe FilePath], [String]) = - 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 - ------------------------------------------------------------------------------- - -hooks :: [Plugin] -hooks = [ help_plugin - , report_plugin - , markup_plugin - , sum_plugin - , combine_plugin - , map_plugin - , showtix_plugin - , overlay_plugin - , draft_plugin - , version_plugin - ] - -hooks' :: [(String, Plugin)] -hooks' = [ (name hook,hook) | hook <- hooks ] - ------------------------------------------------------------------------------- - -help_plugin :: Plugin -help_plugin = Plugin { name = "help" - , usage = "[<HPC_COMMAND>]" - , summary = "Display help for hpc or a single command" - , options = help_options - , implementation = help_main - , init_flags = default_flags - , final_flags = default_final_flags - } - -help_main :: Flags -> [String] -> IO () -help_main _ [] = do - helpList - exitWith ExitSuccess -help_main _ (sub_txt:_) = do - case lookup sub_txt hooks' of - Nothing -> do - putStrLn $ "no such HPC command: " <> sub_txt - exitFailure - Just plugin' -> do - command_usage plugin' - exitWith ExitSuccess - -help_options :: FlagOptSeq -help_options = id - ------------------------------------------------------------------------------- - -version_plugin :: Plugin -version_plugin = Plugin { name = "version" - , usage = "" - , summary = "Display version for hpc" - , options = id - , implementation = version_main - , init_flags = default_flags - , final_flags = default_final_flags - } - -version_main :: Flags -> [String] -> IO () -version_main _ _ = putStrLn ("hpc tools, version " ++ showVersion version) - - ------------------------------------------------------------------------------- |