tricu

ece0fc4491038b19533f3eb18e9a039c4f23798e307a2c9edc90919a389697a3.tri (21471B)

---

 !export *
 -- 1.  t  t      a b       -> a
 -- 2.  t (t a)   b c       -> a c (b c)
 -- 3a. t (t a b) c t       -> a
 -- 3b. t (t a b) c (t u)   -> b u
 -- 3c. t (t a b) c (t u v) -> c u v
 
 false = t
 _     = t
 true  = t t
 id a = a
 const a b = a
 pair  = t
 if cond then else = t (t else (t t then)) t cond
 
 y = ((mut wait fun : wait mut (x : fun (wait mut x)))
      (x : x x)
      (a0 a1 a2 : t (t a0) (t t a2) a1))
 
 compose f g x = f (g x)
 
 triage leaf stem fork = t (t leaf stem) fork
 test   = triage "Leaf" (_ : "Stem") (_ _ : "Fork")
 
 matchBool = (onTrue onFalse : triage
   onFalse
   (_ : onTrue)
   (_ _ : onTrue)
 )
 
 lAnd = (triage
   (_     : false)
   (_ x   : x)
   (_ _ x : x))
 
 lOr = (triage
   (x     : x)
   (_ _   : true)
   (_ _ _ : true))
 
 matchPair a = triage _ _ a
 
 fst p = matchPair takeFirst p
   where takeFirst a b = a
 snd p = matchPair takeSecond p
   where takeSecond a b = b
 
 resultIsOk result =
   matchResult (errR rest : false) (val rest : true) result
 
 resultIsErr result =
   matchResult (errR rest : true) (val rest : false) result
 
 not? = matchBool false true
 and? = matchBool id (_ : false)
 
 or? = (x z : 
   matchBool 
     (matchBool true true z)
     (matchBool true false z)
     x)
 
 xor? = (x z : 
   matchBool 
     (matchBool false true z)
     (matchBool true false z)
     x)
 
 equal? = y (self : triage
   (triage
     true
     (_   : false)
     (_ _ : false))
   (ax :
     triage
       false
       (self ax)
       (_ _ : false))
   (ax ay :
     triage
       false
       (_ : false)
       (bx by : lAnd (self ax bx) (self ay by))))
 
 succ = y (self :
   triage
     1
     t
     (triage
       (t (t t))
       (_ tail : t t (self tail))
       t))
 
 ok value rest = pair true (pair value rest)
 err msg rest = pair false (pair msg rest)
 
 matchResult errCase okCase result =
   matchPair
     (tag payload :
       matchPair
         (value rest :
           matchBool
             (okCase value rest)
             (errCase value rest)
             tag)
         payload)
     result
 
 -- ---------------------------------------------------------------------------
 -- Maybe / Option type
 -- ---------------------------------------------------------------------------
 
 nothing = t
 just x = t x
 
 matchMaybe nothingCase justCase maybe =
   triage
     nothingCase
     justCase
     (_ _ : nothingCase)
     maybe
 
 maybe default f m = matchMaybe default f m
 maybeMap f m = matchMaybe nothing (x : just (f x)) m
 maybeBind m f = matchMaybe nothing f m
 maybeOr default m = matchMaybe default id m
 maybe? = matchMaybe false (_ : true)
 
 -- ---------------------------------------------------------------------------
 -- Lazy eliminators
 --
 -- A strict eliminator evaluates both branches because they are ordinary
 -- arguments. Give a branch that recurses, looks something up, or builds
 -- structure to one of these instead: it becomes a thunk and only the selected
 -- branch is ever applied.
 -- ---------------------------------------------------------------------------
 
 lazyBool = (thenK elseK cond :
   ((chosen : chosen t)
    (matchBool
      thenK
      elseK
      cond)))
 
 -- `triage` selects a thunk directly: a cons is a Fork, so the cons case sits
 -- in the fork slot, exactly as in `matchList` below.
 lazyList = (nilK consK xs :
   ((chosen : chosen t)
    (triage
      nilK
      _
      (h r : (_ : consK h r))
      xs)))
 
 lazyMaybe = (noneK someK m :
   ((chosen : chosen t)
    (matchMaybe
      noneK
      (x : (_ : someK x))
      m)))
 
 lazyResult = (errK okK result :
   ((chosen : chosen t)
    (matchResult
      (code rest : (_ : errK code rest))
      (value rest : (_ : okK value rest))
      result)))
 
 -- ---------------------------------------------------------------------------
 -- Basic arithmetic
 -- ---------------------------------------------------------------------------
 
 ifLazy = (cond thenK elseK :
   matchBool
     (thenK t)
     (elseK t)
     cond)
 
 andLazy? = (a bK :
   ifLazy
     a
     bK
     (_ : false))
 
 pred_ = y (self : triage
   0
   0
   (bit rest :
     ifLazy
       bit
       (_ : matchBool
         (t t rest)
         0
         rest)
       (_ : t (t t) (self rest))))
 
 pred @nat? =@nat? pred_
 
 isZero_? = triage true (_ : false) (_ _ : false)
 
 isZero? @nat? =@bool? isZero_?
 
 add @nat? @nat? =@nat? (y (self x y :
   triage
     y
     (_ : succ y)
     (_ _ : succ (self (pred_ x) y))
     x))
 
 sub @nat? @nat? =@nat? y (self a b :
   ifLazy
     (isZero_? b)
     (_ : a)
     (_ : self (pred_ a) (pred_ b)))
 
 lte_? = y (self a b :
   ifLazy
     (isZero_? a)
     (_ : true)
     (_ :
       ifLazy
         (isZero_? b)
         (_ : false)
         (_ : self (pred_ a) (pred_ b))))
 
 lte? @nat? @nat? =@bool? lte_?
 
 gte_? = a b : lte_? b a
 
 gte? @nat? @nat? =@bool? gte_?
 
 lt_? = a b : and? (lte_? a b) (not? (equal? a b))
 
 lt? @nat? @nat? =@bool? lt_?
 
 gt_? = a b : lt_? b a
 
 gt? @nat? @nat? =@bool? gt_?
 
 mul @nat? @nat? =@nat? y (self a b :
   ifLazy
     (isZero_? b)
     (_ : 0)
     (_ : add a (self a (pred_ b))))
 
 div @nat? @nat? =@nat? y (self a b :
   ifLazy
     (isZero_? b)
     (_ : 0)
     (_ : ifLazy
       (lt_? a b)
       (_ : 0)
       (_ : succ (self (sub a b) b))))
 
 mod @nat? @nat? =@nat? y (self a b :
   ifLazy
     (isZero_? b)
     (_ : 0)
     (_ : ifLazy
       (lt_? a b)
       (_ : a)
       (_ : self (sub a b) b)))
 
 pow @nat? @nat? =@nat? y (self a b :
   ifLazy
     (isZero_? b)
     (_ : 1)
     (_ : mul a (self a (pred_ b))))
 
 even? n = (triage
   true
   (_ : false)
   (bit _ : isZero_? bit)
   n)
 
 odd? = (n : not? (even? n))
 
 min @nat? @nat? =@nat? (a b : ifLazy (lte_? a b) (_ : a) (_ : b))
 
 max @nat? @nat? =@nat? (a b : ifLazy (lte_? a b) (_ : b) (_ : a))
 
 -- ---------------------------------------------------------------------------
 -- Result combinators
 -- ---------------------------------------------------------------------------
 
 mapResult = (f result :
   matchResult
     (code rest : err code rest)
     (value rest : ok (f value) rest)
     result)
 
 bindResult = (result f :
   matchResult
     (code rest : err code rest)
     (value rest : f value rest)
     result)
 
 resultOr = (default result :
   matchResult
     (_ _ : default)
     (value _ : value)
     result)
 
 resultMapErr = (f result :
   matchResult
     (code rest : err (f code) rest)
     (value rest : ok value rest)
     result)
 
 -- ---------------------------------------------------------------------------
 -- List
 -- ---------------------------------------------------------------------------
 
 matchList = a b : triage a _ b
 
 emptyList? = matchList true (_ _ : false)
 head xs@(nonEmptyListOf anyC) =@anyC matchList t (h _ : h) xs
 tail xs@(nonEmptyListOf anyC) =@(listOf anyC) matchList t (_ r : r) xs
 
 append_ self xs ys =
   matchList
     ys
     (h r : pair h (self r ys))
     xs
 append = xs ys : y append_ xs ys
 
 lExist?_ self x xs =
   matchList
     false
     (h r : or? (equal? x h) (self x r))
     xs
 lExist? = x xs : y lExist?_ x xs
 
 -- Keep these eliminators: patterned traversal has higher measured runtime and
 -- allocation costs here. Local workers capture callbacks rather than threading
 -- them through every recursive call.
 map f xs = (let rec
   walk remaining = (matchList
     t
     (h r : pair (f h) (walk r))
     remaining)
   in walk xs)
 
 filter f xs = (let rec
   walk remaining = (matchList
     t
     (h r : matchBool (pair h (walk r)) (walk r) (f h))
     remaining)
   in walk xs)
 
 foldl f initial xs = (let rec
   walk remaining acc = (matchList
     acc
     (h r : walk r (f acc h))
     remaining)
   in walk xs initial)
 
 foldr_ self l f x =
   matchList
     x
     (h r : f (self r f x) h)
     l
 foldr = f x l : y foldr_ l f x
 
 length_ self xs =
   matchList
     0
     (_ r : succ (self r))
     xs
 length @(listOf anyC) =@nat? y length_
 
 reverse xs = (let rec
   walk remaining acc = (matchList
     acc
     (h r : walk r (pair h acc))
     remaining)
   in walk xs t)
 
 snoc_ self x xs =
   matchList
     (pair x t)
     (h r : pair h (self x r))
     xs
 snoc = x xs : y snoc_ x xs
 
 count_ self x xs =
   matchList
     0
     (h r :
       matchBool
         (succ (self x r))
         (self x r)
         (equal? x h))
     xs
 count = x xs : y count_ x xs
 
 last_ self xs =
   matchList
     t
     (h r :
       matchBool
         h
         (self r)
         (emptyList? r))
     xs
 last @(nonEmptyListOf anyC) =@anyC y last_
 
 all?_ self pred xs =
   matchList
     true
     (h r : and? (pred h) (self pred r))
     xs
 all? = pred xs : y all?_ pred xs
 
 any?_ self pred xs =
   matchList
     false
     (h r : or? (pred h) (self pred r))
     xs
 any? = pred xs : y any?_ pred xs
 
 intersect = xs ys : filter (x : lExist? x ys) xs
 
 nth_ self xs n i =
   matchList
     t
     (h r :
       matchBool
         h
         (self r n (succ i))
         (equal? i n))
     xs
 nth = n xs : y nth_ xs n 0
 
 headMaybe = matchList nothing (h _ : just h)
 
 lastMaybe_ self xs =
   matchList
     nothing
     (h r :
       matchBool
         (just h)
         (self r)
         (emptyList? r))
     xs
 lastMaybe = xs : y lastMaybe_ xs
 
 nthMaybe_ self xs n i =
   matchList
     nothing
     (h r :
       matchBool
         (just h)
         (self r n (succ i))
         (equal? i n))
     xs
 nthMaybe = n xs : y nthMaybe_ xs n 0
 
 take_ self xs n i =
   matchList
     t
     (h r :
       matchBool
         t
         (pair h (self r n (succ i)))
         (equal? i n))
     xs
 take = n xs : y take_ xs n 0
 
 drop_ self xs n i =
   matchBool
     xs
     (matchList
       t
       (_ r : self r n (succ i))
       xs)
     (equal? i n)
 drop = n xs : y drop_ xs n 0
 
 splitAt = n xs : pair (take n xs) (drop n xs)
 
 concatMap_ self f xs =
   matchList
     t
     (h r : append (f h) (self f r))
     xs
 concatMap = f xs : y concatMap_ f xs
 
 find_ self pred xs =
   matchList
     nothing
     (h r :
       matchBool
         (just h)
         (self pred r)
         (pred h))
     xs
 find = pred xs : y find_ pred xs
 
 partition_ self pred xs trues falses =
   matchList
     (pair (reverse trues) (reverse falses))
     (h r :
       matchBool
         (self pred r (pair h trues) falses)
         (self pred r trues (pair h falses))
         (pred h))
     xs
 partition = pred xs : y partition_ pred xs t t
 
 strLength = length
 strAppend = append
 strEq? = equal?
 strEmpty? = emptyList?
 
 startsWith?_ self prefix input =
   matchList
     true
     (ph pr :
       matchList
         false
         (sh sr :
           matchBool
             (self pr sr)
             false
             (equal? ph sh))
         input)
     prefix
 startsWith? = prefix input : y startsWith?_ prefix input
 
 endsWith? = prefix str : startsWith? (reverse prefix) (reverse str)
 
 contains?_ self needle haystack =
   matchBool
     true
     (matchList
       false
       (_ r : self needle r)
       haystack)
     (startsWith? needle haystack)
 contains? = needle haystack : y contains?_ needle haystack
 
 sum @(listOf nat?) =@nat? foldl (acc x : add x acc) 0
 product @(listOf nat?) =@nat? foldl (acc x : mul x acc) 1
 
 -- ---------------------------------------------------------------------------
 -- Generic separators
 --
 -- `lines`, `unlines`, `words` and `unwords` at the bottom of this section are
 -- the byte-valued special cases of these primitives.
 --
 -- Joining takes any separator; splitting takes one byte. Separators are removed
 -- rather than kept, and empty fields are preserved.
 -- ---------------------------------------------------------------------------
 
 takeWhile f xs = (let rec
   walk remaining = (lazyList
     (_ : t)
     (h r : case f h of
       t = t
       _ = pair h (walk r))
     remaining)
   in walk xs)
 
 dropWhile f xs = (let rec
   walk remaining = (lazyList
     (_ : t)
     (h r : case f h of
       t = pair h r
       _ = walk r)
     remaining)
   in walk xs)
 
 -- Byte-level whitespace only: space and horizontal tab (HTTP OWS).
 spaceByte? = b : equal? b 32
 tabByte?   = b : equal? b 9
 trimByte?  = b : or? (spaceByte? b) (tabByte? b)
 
 trim = xs : dropWhile trimByte? (reverse (dropWhile trimByte? (reverse xs)))
 
 intercalate sep xs = (let rec
   walk remaining = (lazyList
     (_ : t)
     (h r : case emptyList? r of
       t = append h (append sep (walk r))
       _ = h)
     remaining)
   in walk xs)
 
 -- Separator after every field, including the last one. Line-oriented formats
 -- want this: `joinSuffix "\n" xs` terminates the final line while
 -- `intercalate "\n" xs` does not.
 joinSuffix sep xs = (let rec
   walk remaining = (lazyList
     (_ : t)
     (h r : append (append h sep) (walk r))
     remaining)
   in walk xs)
 
 -- Split on a single byte.
 -- Empty fields are preserved: `splitOnByte 58 "a::b"` is ["a" "" "b"].
 -- Keep the two small thunks here: case dispatch and extra local branch
 -- bindings both add measurable per-byte costs in the splitter.
 splitOnByte byte str = (let rec
   walk remaining reversedFields reversedField = (lazyList
     (_ : map reverse (reverse (pair reversedField reversedFields)))
     (h r : lazyBool
       (_ : walk r (pair reversedField reversedFields) t)
       (_ : walk r reversedFields (pair h reversedField))
       (equal? h byte))
     remaining)
   in walk str t t)
 
 -- Every one of these keeps its arguments bound: partially applying a
 -- multi-argument function at the top level leaves a fixed point exposed.
 lines   = str : splitOnByte 10 str
 unlines = xs : joinSuffix "\n" xs
 
 -- Runs of separators collapse: empty fields are dropped.
 words   = str : filter (w : not? (emptyList? w)) (splitOnByte 32 str)
 unwords = xs : intercalate " " xs
 
 zipWith_ self f xs ys =
   matchList
     t
     (xh xt :
       matchList
         t
         (yh yt : pair (f xh yh) (self f xt yt))
         ys)
     xs
 zipWith = f xs ys : y zipWith_ f xs ys
 
 -- ---------------------------------------------------------------------------
 -- 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.
 --
 -- 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))
 
 -- Default contract kernel. Return the contract Result unchanged.
 defaultKernel = (contract value result :
   matchResult
     (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
 -- ---------------------------------------------------------------------------
 
 -- 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 = case predicate value of
   t = contractErr msg rest
   _ = contractOk value rest
 
 -- Structural natural-number predicate.
 -- A natural is either Leaf (0) or Fork bit rest where bit is Leaf (even)
 -- or Stem Leaf (odd) and rest is itself a natural.
 isNat? = y (self n :
   triage
     true
     (_ : false)
     (bit r :
       triage
         (self r)
         (_ : self r)
         (_ _ : false)
         bit)
     n)
 
 -- Natural number contract.
 nat? = guardC "not a natural number" isNat?
 
 -- Non-zero natural number contract.
 nonZero? = guardC "non-zero" (n : and? (isNat? 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 :
       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 :
       matchResult
         (msg _ : contractErr msg rest1)
         (x' _ :
           contractOk
             (y : (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)
         (withContract arg1C x)))
     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 = (matchPair interpret tree
   where
     interpret op payload = case op of
       0 = contractOk payload t
       1 = (matchPair
         (action k : matchResult
           (msg _ : contractErr msg t)
           (value _ : runM (k value))
           (runM action))
         payload)
       _ = (matchPair
         (_ detail : matchPair (value _ : contractErr value t) detail)
         payload))
 
 -- 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 = (let rec
   handle current = (matchPair interpret current
     where
       choose exceptionTag value k = case equal? exceptionTag tag of
         t = current
         _ = handle (handler value k)
       handleException exceptionTag detail = matchPair (choose exceptionTag) detail
       interpret op payload = case op of
         0 = current
         1 = (matchPair
           (action k : bindE (handle action) (value : handle (k value)))
           payload)
         _ = matchPair handleException payload)
   in handle tree)