Fix: bail if purs exits non-ok (#1285)

src/Spago/Cmd.purs

@@ -39,6 +39,14 @@ type ExecResult =
   , timedOut :: Boolean
   }
 
+exitedOk :: Either ExecResult ExecResult -> Boolean
+exitedOk = either identity identity >>> case _ of
+  { exit: Normally 0 } -> true
+  _ -> false
+
+exit :: Either ExecResult ExecResult -> Exit
+exit = either identity identity >>> _.exit
+
 printExecResult :: ExecResult -> String
 printExecResult r = Array.intercalate "\n"
   [ "escapedCommand: " <> show r.escapedCommand

src/Spago/Psa.purs

@@ -10,9 +10,12 @@ import Spago.Prelude
 
 import Codec.JSON.DecodeError as CJ.DecodeError
 import Control.Alternative as Alternative
+import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
+import Control.Monad.Trans.Class (lift)
 import Data.Array as Array
 import Data.Array.NonEmpty as NonEmptyArray
 import Data.Codec.JSON as CJ
+import Data.Either (blush)
 import Data.Map as Map
 import Data.Set as Set
 import Data.String as Str
@@ -21,6 +24,7 @@ import Data.Tuple as Tuple
 import Effect.Ref as Ref
 import Foreign.Object as FO
 import JSON as JSON
+import Node.ChildProcess.Types (Exit(..))
 import Node.Encoding as Encoding
 import Node.FS.Aff as FSA
 import Node.Path as Path
@@ -40,35 +44,40 @@ defaultStatVerbosity = Core.CompactStats
 
 psaCompile :: forall a. Set.Set FilePath -> Array String -> PsaArgs -> Spago (Purs.PursEnv a) Boolean
 psaCompile globs pursArgs psaArgs = do
-  result <- Purs.compile globs (Array.snoc pursArgs "--json-errors")
-  let resultStdout = Cmd.getStdout result
-  arrErrorsIsEmpty <- forWithIndex (Str.split (Str.Pattern "\n") resultStdout) \idx err ->
-    case JSON.parse err >>= CJ.decode psaResultCodec >>> lmap CJ.DecodeError.print of
-      Left decodeErrMsg -> do
-        logWarn $ Array.intercalate "\n"
-          [ "Failed to decode PsaResult at index '" <> show idx <> "': " <> decodeErrMsg
-          , "Json was: " <> err
-          ]
-        -- If we can't decode the error, then there's likely a codec issue on Spago's side.
-        -- So, this shouldn't fail the build.
-        pure true
-      Right out -> do
-        files <- liftEffect $ Ref.new FO.empty
-        out' <- buildOutput (loadLines files) psaArgs out
-
-        liftEffect $ if psaArgs.jsonErrors then printJsonOutputToOut out' else printDefaultOutputToErr psaArgs out'
-
-        pure $ FO.isEmpty out'.stats.allErrors
-
-  if Array.all identity arrErrorsIsEmpty then do
-    logSuccess "Build succeeded."
-    pure true
-  else do
-    case result of
-      Left r -> logDebug $ Cmd.printExecResult r
-      _ -> pure unit
-    prepareToDie [ "Failed to build." ]
-    pure false
+  purs <- Purs.compile globs (Array.snoc pursArgs "--json-errors")
+  let
+    resultStdout = Cmd.getStdout purs
+    print' = if psaArgs.jsonErrors then printJsonOutputToOut else printDefaultOutputToErr psaArgs
+
+  errors <- for (Str.split (Str.Pattern "\n") resultStdout) \err -> runExceptT do
+    -- If we can't decode the error, then there's likely a codec issue on Spago's side.
+    -- So, this shouldn't fail the build.
+    out <- ExceptT $ pure $ JSON.parse err >>= CJ.decode psaResultCodec >>> lmap CJ.DecodeError.print
+    files <- liftEffect $ Ref.new FO.empty
+    out' <- lift $ buildOutput (loadLines files) psaArgs out
+    liftEffect (print' out') $> FO.isEmpty out'.stats.allErrors
+
+  let
+    noErrors = Array.all (either (const true) identity) errors
+    failedToDecodeMsg (idx /\ err) =
+      Array.intercalate "\n"
+        [ "Failed to decode PsaResult at index '" <> show idx <> "': " <> err
+        , "Json was: " <> err
+        ]
+    failedToDecode = failedToDecodeMsg <$> Array.catMaybes (Array.mapWithIndex (\idx e -> (idx /\ _) <$> blush e) errors)
+
+  case Cmd.exit purs, noErrors of
+    Normally 0, true ->
+      for failedToDecode logWarn
+        *> logSuccess "Build succeeded."
+        $> true
+    _, true ->
+      prepareToDie [ "purs exited with non-ok status code: " <> show (Cmd.exit purs) ]
+        $> false
+    _, _ ->
+      for (blush purs) (logDebug <<< Cmd.printExecResult)
+        *> prepareToDie [ "Failed to build." ]
+        $> false
 
   where
   isEmptySpan filename pos =

test-fixtures/purs-not-ok.txt

@@ -0,0 +1,15 @@
+Reading Spago workspace configuration...
+
+✓ Selecting package to build: aaa
+
+Downloading dependencies...
+No lockfile found, generating it...
+Lockfile written to spago.lock. Please commit this file.
+Building...
+Invalid option `--non-existent'
+
+Usage: purs COMMAND
+
+  The PureScript compiler and tools
+
+✘ purs exited with non-ok status code: Normally 1

test/Prelude.purs

@@ -98,15 +98,20 @@ shouldEqualStr
   -> String
   -> m Unit
 shouldEqualStr v1 v2 =
+  let
+    renderNonPrinting =
+      String.replaceAll (String.Pattern "\r") (String.Replacement "␍")
+      >>> String.replaceAll (String.Pattern "\t") (String.Replacement "␉-->")
+  in
   when (v1 /= v2) do
     fail $ Array.intercalate "\n"
       [ ""
       , "===== (Actual)"
-      , v1
+      , renderNonPrinting v1
       , "====="
       , "  ≠"
       , "===== (Expected)"
-      , v2
+      , renderNonPrinting v2
       , "====="
       , ""
       ]

test/Spago/Build.purs

@@ -32,6 +32,19 @@ spec = Spec.around withTempDir do
       spago [ "init", "--name", "aaa", "--use-solver" ] >>= shouldBeSuccess
       spago [ "build" ] >>= shouldBeSuccess
 
+    Spec.it "exits when purs exits non-ok" \{ spago, fixture } -> do
+      spago [ "init", "--name", "aaa" ] >>= shouldBeSuccess
+      spago [ "build", "--purs-args", "--non-existent" ] >>=
+        checkOutputs'
+          { stdoutFile: Nothing
+          , stderrFile: Just (fixture "purs-not-ok.txt")
+          , result: isLeft
+          , sanitize:
+              String.trim
+              >>> String.replaceAll (String.Pattern "Usage: purs.bin") (String.Replacement "Usage: purs")
+              >>> String.replaceAll (String.Pattern "\r\n") (String.Replacement "\n")
+          }
+
     Spec.it "passes options to purs" \{ spago } -> do
       spago [ "init" ] >>= shouldBeSuccess
       spago [ "build", "--purs-args", "--verbose-errors", "--purs-args", "--comments" ] >>= shouldBeSuccess