Runtime contract guard kernel

lib/base.tri

@@ -39,10 +39,10 @@ snd p = matchPair takeSecond p
   where takeSecond a b = b
 
 resultIsOk result =
-  matchResult (err rest : false) (val rest : true) result
+  matchResult (errR rest : false) (val rest : true) result
 
 resultIsErr result =
-  matchResult (err rest : true) (val rest : false) result
+  matchResult (errR rest : true) (val rest : false) result
 
 not? = matchBool false true
 and? = matchBool id (_ : false)
@@ -638,25 +638,52 @@ zipWith = f xs ys : y zipWith_ f xs ys
 -- The second argument is the conventional "rest" slot. On success a contract
 -- returns the checked value wrapped in the standard ok shape; on failure it
 -- returns a diagnostic wrapped in the standard err shape.
+--
+-- The contract kernel is a globally configurable function selected by the
+-- runner. It decides whether to accept the contract result, replace it, log
+-- it, or transform the diagnostic. The default kernel is the identity on the
+-- contract Result.
+--
+-- The runner may rebind 'kernel' to a different kernel before evaluating
+-- user code (e.g. via --contract-kernel).
 -- ---------------------------------------------------------------------------
 
 contractOk = (value : (rest : ok value rest))
 contractErr = (msg : (rest : err msg rest))
 
-check contract value =
-  withContract contract value
-    (x : x)
-    (msg : msg)
-
--- Apply a contract with the conventional rest slot and return the raw Result.
-checkContract = (contract value : contract value t)
-
--- Apply a contract and continue with either the onOk or onFail branch.
-withContract = (contract value onOk onFail :
+-- Default contract kernel. Return the contract Result unchanged.
+defaultKernel = (contract value result :
   matchResult
-    (msg _ : onFail msg)
-    (checked _ : onOk checked)
-    (contract value t))
+    (msg rest : err msg rest)
+    (v rest : ok v rest)
+    result)
+
+-- The active kernel. The runner may rebind this name to a different kernel
+-- before evaluating user code (e.g. via --contract-kernel). Internally,
+-- withContract dispatches through this binding, so rebinding 'kernel' changes
+-- the behaviour of every contract boundary in the program.
+kernel = defaultKernel
+
+-- Skip-everything kernel. Resume with the original value on failure.
+skipKernel = (contract value result :
+  matchResult
+    (msg rest : ok value rest)
+    (v rest : ok v rest)
+    result)
+
+-- Apply a contract and pass the raw Result to the kernel.
+withContract = (contract value :
+  kernel contract value (contract value t))
+
+-- Apply a contract and return the checked value or the diagnostic message.
+check contract value =
+  matchResult
+    (msg _ : msg)
+    (v _ : v)
+    (withContract contract value)
+
+-- Apply a contract and return the raw Result (kernel is bypassed).
+checkContract = (contract value : contract value t)
 
 -- ---------------------------------------------------------------------------
 -- Basic contracts
@@ -774,29 +801,34 @@ pairOf = (c1 c2 p rest :
 fnContract = (argC resC f rest :
   contractOk
     (x : (rest1 :
-      withContract argC x
-        (x' :
-          withContract resC (f x')
-            (y : contractOk y rest1)
-            (msg : contractErr msg rest1))
-        (msg : contractErr msg rest1)))
+      matchResult
+        (msg _ : contractErr msg rest1)
+        (x' _ :
+          matchResult
+            (msg _ : contractErr msg rest1)
+            (y _ : contractOk y rest1)
+            (withContract resC (f x')))
+        (withContract argC x)))
     rest)
 
 fn2 = (arg1C arg2C resC f rest :
   contractOk
     (x : (rest1 :
-      withContract arg1C x
-        (x' :
+      matchResult
+        (msg _ : contractErr msg rest1)
+        (x' _ :
           contractOk
             (y : (rest2 :
-              withContract arg2C y
-                (y' :
-                  withContract resC (f x' y')
-                    (z : contractOk z rest2)
-                    (msg : contractErr msg rest2))
-                (msg : contractErr msg rest2)))
+              matchResult
+                (msg _ : contractErr msg rest2)
+                (y' _ :
+                  matchResult
+                    (msg _ : contractErr msg rest2)
+                    (z _ : contractOk z rest2)
+                    (withContract resC (f x' y')))
+                (withContract arg2C y)))
             rest1)
-        (msg : contractErr msg rest1)))
+        (withContract arg1C x)))
     rest)
 
 -- ---------------------------------------------------------------------------