false = t
_     = t
true  = t t
id a@_a =@_a a
const a@_a b@_b =@_a 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@(Fn [_b] _c) g@(Fn [_a] _b) x@_a =@_c f (g x)

triage leaf stem fork = t (t leaf stem) fork
test   = triage "Leaf" (_ : "Stem") (_ _ : "Fork")

matchBool = (ot of : triage
  of
  (_ : ot)
  (_ _ : ot)
)

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 (err rest : false) (val rest : true) result

resultIsErr result =
  matchResult (err 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@(Fn [_a] _b) m@(Maybe _a) =@(Maybe _b) matchMaybe nothing (compose just f) m
maybeBind m@(Maybe _a) f@(Fn [_a] (Maybe _b)) =@(Maybe _b) matchMaybe nothing f m
maybeOr default@_a m@(Maybe _a) =@_a matchMaybe default id m
maybe? = matchMaybe false (_ : true)

-- ---------------------------------------------------------------------------
-- 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 :
    matchBool
      (matchBool
        0
        (pair 0 rest)
        (equal? rest 0))
      (matchBool
        0
        (pair 1 (self rest))
        (equal? rest 0))
      bit))

isZero? = triage true (_ : false) (_ _ : false)

add = y (self x y :
  triage
    y
    (_ : succ y)
    (_ _ : succ (self (pred x) y))
    x)

sub = 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))))

gte? = a b :
  lte? b a

lt? = a b :
  and? (lte? a b) (not? (equal? a b))

gt? = a b :
  lt? b a

mul = y (self a b :
  ifLazy
    (isZero? b)
    (_ : 0)
    (_ : add a (self a (pred b))))

-- ---------------------------------------------------------------------------
-- 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)

-- ---------------------------------------------------------------------------
-- View facts
-- ---------------------------------------------------------------------------

factsFact name provenance view = pair name (pair provenance view)
factsChecked = 0
factsTrusted = 1
factsUnchecked = 2
factsField tag value = pair tag value
factsRecord tag fields = pair tag fields
factsVar id = factsRecord 8 [(factsField 10 id)]
factsForall binders body =
  factsRecord 9 [(factsField 11 binders) (factsField 12 body)]
factsFn args result =
  factsRecord 1 [(factsField 0 args) (factsField 1 result)]
factsAny = factsRecord 0 []
factsRef symbol = factsRecord 2 [(factsField 2 symbol)]
factsBool = factsRef 0
factsString = factsRef 1
factsByte = factsRef 2
factsUnit = factsRef 3
factsMaybe elem = factsRecord 4 [(factsField 3 elem)]
factsList elem = factsRecord 3 [(factsField 3 elem)]
factsPair left right = factsRecord 5 [(factsField 4 left) (factsField 5 right)]
factsResult err ok = factsRecord 6 [(factsField 6 err) (factsField 7 ok)]

viewFacts =
  [ (factsFact "pair" factsTrusted
      (factsForall [0]
        (factsFn
          [(factsVar 0) (factsList (factsVar 0))]
          (factsList (factsVar 0)))))
    (factsFact "nothing" factsTrusted
      (factsForall [0]
        (factsMaybe (factsVar 0))))
    (factsFact "just" factsTrusted
      (factsForall [0]
        (factsFn [(factsVar 0)] (factsMaybe (factsVar 0)))))
    (factsFact "false" factsTrusted factsBool)
    (factsFact "true" factsTrusted factsBool)
    (factsFact "if" factsTrusted
      (factsForall [0]
        (factsFn [factsBool (factsVar 0) (factsVar 0)] (factsVar 0))))
    (factsFact "triage" factsTrusted
      (factsForall [0]
        (factsFn [factsAny factsAny factsAny factsAny] (factsVar 0))))
    (factsFact "test" factsTrusted factsString)
    (factsFact "matchBool" factsTrusted
      (factsForall [0]
        (factsFn
          [(factsVar 0) (factsVar 0) factsBool]
          (factsVar 0))))
    (factsFact "lAnd" factsTrusted
      (factsFn [factsBool factsBool] factsBool))
    (factsFact "lOr" factsTrusted
      (factsFn [factsBool factsBool] factsBool))
    (factsFact "matchPair" factsTrusted
      (factsForall [0 1 2]
        (factsFn
          [(factsFn [(factsVar 0) (factsVar 1)] (factsVar 2))
           (factsPair (factsVar 0) (factsVar 1))]
          (factsVar 2))))
    (factsFact "fst" factsTrusted
      (factsForall [0 1]
        (factsFn [(factsPair (factsVar 0) (factsVar 1))] (factsVar 0))))
    (factsFact "snd" factsTrusted
      (factsForall [0 1]
        (factsFn [(factsPair (factsVar 0) (factsVar 1))] (factsVar 1))))
    (factsFact "not?" factsTrusted
      (factsFn [factsBool] factsBool))
    (factsFact "and?" factsTrusted
      (factsFn [factsBool factsBool] factsBool))
    (factsFact "or?" factsTrusted
      (factsFn [factsBool factsBool] factsBool))
    (factsFact "xor?" factsTrusted
      (factsFn [factsBool factsBool] factsBool))
    (factsFact "equal?" factsTrusted
      (factsForall [0]
        (factsFn [(factsVar 0) (factsVar 0)] factsBool)))
    (factsFact "succ" factsTrusted
      (factsFn [factsByte] factsByte))
    (factsFact "pred" factsTrusted
      (factsFn [factsByte] factsByte))
    (factsFact "isZero?" factsTrusted
      (factsFn [factsByte] factsBool))
    (factsFact "add" factsTrusted
      (factsFn [factsByte factsByte] factsByte))
    (factsFact "sub" factsTrusted
      (factsFn [factsByte factsByte] factsByte))
    (factsFact "lte?" factsTrusted
      (factsFn [factsByte factsByte] factsBool))
    (factsFact "gte?" factsTrusted
      (factsFn [factsByte factsByte] factsBool))
    (factsFact "lt?" factsTrusted
      (factsFn [factsByte factsByte] factsBool))
    (factsFact "gt?" factsTrusted
      (factsFn [factsByte factsByte] factsBool))
    (factsFact "mul" factsTrusted
      (factsFn [factsByte factsByte] factsByte))
    (factsFact "matchMaybe" factsTrusted
      (factsForall [0 1]
        (factsFn
          [(factsVar 1)
           (factsFn [(factsVar 0)] (factsVar 1))
           (factsMaybe (factsVar 0))]
          (factsVar 1))))
    (factsFact "maybe" factsTrusted
      (factsForall [0 1]
        (factsFn
          [(factsVar 1)
           (factsFn [(factsVar 0)] (factsVar 1))
           (factsMaybe (factsVar 0))]
          (factsVar 1))))
    (factsFact "maybe?" factsTrusted
      (factsForall [0]
        (factsFn [(factsMaybe (factsVar 0))] factsBool)))
    (factsFact "ifLazy" factsTrusted
      (factsForall [0]
        (factsFn
          [factsBool
           (factsFn [factsUnit] (factsVar 0))
           (factsFn [factsUnit] (factsVar 0))]
          (factsVar 0))))
    (factsFact "andLazy?" factsTrusted
      (factsFn [factsBool (factsFn [factsUnit] factsBool)] factsBool))
    (factsFact "ok" factsTrusted
      (factsForall [0 1]
        (factsFn [(factsVar 1) factsAny] (factsResult (factsVar 0) (factsVar 1)))))
    (factsFact "err" factsTrusted
      (factsForall [0 1]
        (factsFn [(factsVar 0) factsAny] (factsResult (factsVar 0) (factsVar 1)))))
    (factsFact "matchResult" factsTrusted
      (factsForall [0 1 2]
        (factsFn
          [(factsFn [(factsVar 0) factsAny] (factsVar 2))
           (factsFn [(factsVar 1) factsAny] (factsVar 2))
           (factsResult (factsVar 0) (factsVar 1))]
          (factsVar 2))))
    (factsFact "resultIsOk" factsTrusted
      (factsForall [0 1]
        (factsFn [(factsResult (factsVar 0) (factsVar 1))] factsBool)))
    (factsFact "resultIsErr" factsTrusted
      (factsForall [0 1]
        (factsFn [(factsResult (factsVar 0) (factsVar 1))] factsBool)))
    (factsFact "mapResult" factsTrusted
      (factsForall [0 1 2]
        (factsFn
          [(factsFn [(factsVar 1)] (factsVar 2))
           (factsResult (factsVar 0) (factsVar 1))]
          (factsResult (factsVar 0) (factsVar 2)))))
    (factsFact "bindResult" factsTrusted
      (factsForall [0 1 2]
        (factsFn
          [(factsResult (factsVar 0) (factsVar 1))
           (factsFn [(factsVar 1)] (factsResult (factsVar 0) (factsVar 2)))]
          (factsResult (factsVar 0) (factsVar 2)))))
    (factsFact "resultOr" factsTrusted
      (factsForall [0 1]
        (factsFn [(factsVar 1) (factsResult (factsVar 0) (factsVar 1))] (factsVar 1))))
    (factsFact "resultMapErr" factsTrusted
      (factsForall [0 1 2]
        (factsFn
          [(factsFn [(factsVar 0)] (factsVar 2))
           (factsResult (factsVar 0) (factsVar 1))]
          (factsResult (factsVar 2) (factsVar 1)))))]