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