Begin removing view related code and docs

lib/contracts.tri

@@ -0,0 +1,240 @@
+!import "base" !Local
+!import "list" !Local
+
+-- ---------------------------------------------------------------------------
+-- Core contract type
+--
+-- A contract is an ordinary tricu function: Tree -> Tree -> Result Tree Tree.
+-- 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.
+-- ---------------------------------------------------------------------------
+
+contractOk = (value : (rest : ok value rest))
+contractErr = (msg : (rest : err msg rest))
+
+-- 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 :
+  matchResult
+    (msg _ : onFail msg)
+    (checked _ : onOk checked)
+    (contract value t))
+
+-- ---------------------------------------------------------------------------
+-- Basic contracts
+-- ---------------------------------------------------------------------------
+
+-- Any value passes.
+anyC = (value : contractOk value)
+
+-- Always fails with the supplied message.
+neverC = (msg : (value : contractErr msg))
+
+-- Build a contract from a predicate that inspects only the value.
+guardC = (msg predicate value rest :
+  lazyBool
+    (_ : contractOk value rest)
+    (_ : contractErr msg rest)
+    (predicate value))
+
+-- Natural number contract.
+nat? = guardC "not a natural number" (n : gte? n 0)
+
+-- Non-zero number contract.
+nonZero? = guardC "non-zero" (n : not? (isZero? n))
+
+-- Boolean contract.
+bool? = guardC "not a boolean" (b : or? (equal? b true) (equal? b false))
+
+-- ---------------------------------------------------------------------------
+-- Contract combinators
+-- ---------------------------------------------------------------------------
+
+andC = (c1 c2 value rest :
+  matchResult
+    (msg _ : contractErr msg rest)
+    (v _ : c2 v rest)
+    (c1 value rest))
+
+orC = (c1 c2 value rest :
+  matchResult
+    (msg _ : c2 value rest)
+    (v _ : contractOk v rest)
+    (c1 value rest))
+
+notC = (c value rest :
+  matchResult
+    (msg _ : contractOk value rest)
+    (_ _ : contractErr "notC: predicate succeeded" rest)
+    (c value rest))
+
+mapC = (f c value rest :
+  matchResult
+    (msg _ : contractErr msg rest)
+    (v _ : contractOk (f v) rest)
+    (c value rest))
+
+bindC = (c f value rest :
+  matchResult
+    (msg _ : contractErr msg rest)
+    (v _ : f v value rest)
+    (c value rest))
+
+-- ---------------------------------------------------------------------------
+-- Collection contracts
+-- ---------------------------------------------------------------------------
+
+listOf = (c value rest :
+  y (self orig xs :
+    matchList
+      (contractOk orig rest)
+      (h r :
+        matchResult
+          (msg _ : contractErr msg rest)
+          (_ _ : self orig r)
+          (c h rest))
+      xs) value value)
+
+nonEmptyListOf = (c :
+  andC (guardC "empty list" (xs : not? (emptyList? xs))) (listOf c))
+
+pairOf = (c1 c2 p rest :
+  matchPair
+    (a b :
+      matchResult
+        (msg _ : contractErr msg rest)
+        (a' _ :
+          matchResult
+            (msg _ : contractErr msg rest)
+            (b' _ : contractOk (pair a' b') rest)
+            (c2 b rest))
+        (c1 a rest))
+    p)
+
+-- ---------------------------------------------------------------------------
+-- Higher-order function contracts
+--
+-- These return a Result-wrapped proxy. The proxy itself is a contract: it
+-- checks arguments on the way in and results on the way out.
+-- ---------------------------------------------------------------------------
+
+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)))
+    rest)
+
+fn2 = (arg1C arg2C resC f rest :
+  contractOk
+    (x : (rest1 :
+      withContract arg1C x
+        (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)))
+            rest1)
+        (msg : contractErr msg rest1)))
+    rest)
+
+-- ---------------------------------------------------------------------------
+-- Interaction-tree effect layer
+--
+-- These constructors and combinators layer catchable, composable failures on
+-- top of the core Result contracts. They reuse the same tags as tricu IO:
+--   0 = pureE
+--   1 = bindE
+--   2 = exceptE
+-- ---------------------------------------------------------------------------
+
+pureE = (value : pair 0 value)
+bindE = (action k : pair 1 (pair action k))
+exceptE = (tag value k : pair 2 (pair tag (pair value k)))
+
+pureM = pureE
+bindM = bindE
+
+-- Lift a contract failure into an interaction tree.
+checkM = (contract value :
+  matchResult
+    (msg _ : exceptE "contract" msg (_ : pureE t))
+    (checked _ : pureE checked)
+    (contract value t))
+
+-- Lift a pure function into the interaction tree.
+liftM = (f : (x : pureE (f x)))
+
+-- Interpret a pure interaction tree into a Result.
+runM = (tree :
+  run tree
+  where run =
+          y (self tree :
+            matchPair
+              (op payload :
+                matchBool
+                  -- pureE
+                  (contractOk (snd tree) t)
+                  (matchBool
+                    -- bindE
+                    (matchPair
+                      (action k :
+                        matchResult
+                          (msg _ : contractErr msg t)
+                          (v _ : self (k v))
+                          (self action))
+                      payload)
+                    -- exceptE
+                    (matchPair
+                      (tag pair :
+                        matchPair
+                          (value k :
+                            contractErr value t)
+                          pair)
+                      payload)
+                    (equal? op 1))
+                  (equal? op 0))
+              tree))
+
+-- Handle matching exceptE nodes by applying the handler to the value and the
+-- resumption continuation. Non-matching exceptions are left in place.
+handleM = (tag handler tree :
+  handle tree
+  where handle =
+          y (self tree :
+            matchPair
+              (op payload :
+                matchBool
+                  -- pureE
+                  tree
+                  (matchBool
+                    -- bindE
+                    (matchPair
+                      (action k :
+                        bindE (self action) (v : self (k v)))
+                      payload)
+                    -- exceptE
+                    (matchPair
+                      (et pair :
+                        matchPair
+                          (value k :
+                            matchBool
+                              (self (handler value k))
+                              tree
+                              (equal? et tag))
+                          pair)
+                      payload)
+                    (equal? op 1))
+                  (equal? op 0))
+              tree))