From ffbb910909e5339c976d9713dbaab98bf20cc077 Mon Sep 17 00:00:00 2001
From: Brad Richardson <brichardson@structint.com>
Date: Sat, 25 Jul 2020 13:12:22 -0700
Subject: Propogate exit codes from tests and executables

---
 bootstrap/src/Fpm.hs | 51 +++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 39 insertions(+), 12 deletions(-)

(limited to 'bootstrap/src')

diff --git a/bootstrap/src/Fpm.hs b/bootstrap/src/Fpm.hs
index 60f4aac..fdd83d9 100644
--- a/bootstrap/src/Fpm.hs
+++ b/bootstrap/src/Fpm.hs
@@ -14,6 +14,7 @@ import           Build                          ( buildLibrary
                                                 , buildWithScript
                                                 )
 import           Control.Monad.Extra            ( concatMapM
+                                                , forM_
                                                 , when
                                                 )
 import           Data.List                      ( isSuffixOf
@@ -55,6 +56,9 @@ import           System.Directory               ( createDirectory
                                                 , makeAbsolute
                                                 , withCurrentDirectory
                                                 )
+import           System.Exit                    ( ExitCode(..)
+                                                , exitWith
+                                                )
 import           System.Process                 ( runCommand
                                                 , system
                                                 )
@@ -144,15 +148,25 @@ app args settings = case command' args of
     case canonicalExecutables of
       [] -> putStrLn "No Executables Found"
       _  -> case whichOne of
-        "" -> mapM_
-          system
-          (map (++ " " ++ commandArguments args) canonicalExecutables)
+        "" -> do
+          exitCodes <- mapM
+            system
+            (map (++ " " ++ commandArguments args) canonicalExecutables)
+          forM_
+            exitCodes
+            (\exitCode -> when
+              (case exitCode of
+                ExitSuccess -> False
+                _           -> True
+              )
+              (exitWith exitCode)
+            )
         name -> do
           case find (name `isSuffixOf`) canonicalExecutables of
             Nothing        -> putStrLn "Executable Not Found"
             Just specified -> do
-              system (specified ++ " " ++ (commandArguments args))
-              return ()
+              exitCode <- system (specified ++ " " ++ (commandArguments args))
+              exitWith exitCode
   Test whichOne -> do
     build settings
     let buildPrefix = appSettingsBuildPrefix settings
@@ -168,15 +182,25 @@ app args settings = case command' args of
     case canonicalExecutables of
       [] -> putStrLn "No Tests Found"
       _  -> case whichOne of
-        "" -> mapM_
-          system
-          (map (++ " " ++ commandArguments args) canonicalExecutables)
+        "" -> do
+          exitCodes <- mapM
+            system
+            (map (++ " " ++ commandArguments args) canonicalExecutables)
+          forM_
+            exitCodes
+            (\exitCode -> when
+              (case exitCode of
+                ExitSuccess -> False
+                _           -> True
+              )
+              (exitWith exitCode)
+            )
         name -> do
           case find (name `isSuffixOf`) canonicalExecutables of
             Nothing        -> putStrLn "Test Not Found"
             Just specified -> do
-              system (specified ++ " " ++ (commandArguments args))
-              return ()
+              exitCode <- system (specified ++ " " ++ (commandArguments args))
+              exitWith exitCode
 
 build :: AppSettings -> IO ()
 build settings = do
@@ -285,8 +309,11 @@ arguments =
           <> command "test" (info testArguments (progDesc "Run the tests"))
           <> command "build"
                      (info buildArguments (progDesc "Build the executable"))
-          <> command "new"
-                     (info newArguments (progDesc "Create a new project in a new directory"))
+          <> command
+               "new"
+               (info newArguments
+                     (progDesc "Create a new project in a new directory")
+               )
           )
     <*> switch (long "release" <> help "Build in release mode")
     <*> strOption
-- 
cgit v1.2.3