Nat fixes

src/Frontend/ContractDesugar.hs

@@ -47,7 +47,16 @@ desugarDefAnn name args ret body
     body' = wrapReturn ret body
 
     okCont = SLambda ["r"] (SVar "r" Nothing)
-    errCont = SLambda ["msg"] (SVar "msg" Nothing)
+    -- | Failure continuation used for the final argument contract or the
+    -- result contract. It returns the diagnostic message directly because
+    -- no further arguments are expected.
+    errContFinal = SLambda ["msg"] (SVar "msg" Nothing)
+    -- | Failure continuation used for non-final argument contracts. It
+    -- returns a function that ignores the next argument and then returns the
+    -- diagnostic message. This prevents a failed partial application from
+    -- being treated as the final result when the remaining arguments are
+    -- eventually supplied.
+    errContAbsorb = SLambda ["msg"] (SLambda ["_"] (SVar "msg" Nothing))
 
     isPhantom (DefPhantom _) = True
     isPhantom _              = False
@@ -57,15 +66,16 @@ desugarDefAnn name args ret body
 
     wrapReturn Nothing b = b
     wrapReturn (Just c) b =
-      withContractE (viewExprToAst c) b okCont errCont
+      withContractE (viewExprToAst c) b okCont errContFinal
 
     wrapArgs [] b = b
     wrapArgs (DefBinder nm Nothing : rest) b = SLambda [nm] (wrapArgs rest b)
     wrapArgs (DefBinder nm (Just c) : rest) b =
-      SLambda [nm] $
+      let onFail = if null rest then errContFinal else errContAbsorb
+      in SLambda [nm] $
         withContractE (viewExprToAst c) (SVar nm Nothing)
           (SLambda [nm] (wrapArgs rest b))
-          errCont
+          onFail
     wrapArgs (DefPhantom _ : _) _ =
       error "phantom contract arguments are not yet supported by the frontend"