!import "prelude" !Local

-- ---------------------------------------------------------------------------
-- Contracts + interaction trees with `do` notation
--
-- The `do` keyword takes a monadic bind operator. Here we use `bindM` from
-- `lib/contracts.tri` to sequence pure, contract-checked computations.
--
--   checkM contract value     -- lift a contract failure into the tree
--   exceptE tag value k       -- a resumable failure carrying a continuation
--   handleM tag handler tree  -- rewrite matching exceptions
--   runM tree                 -- interpret the tree into a Result
--
-- A handler receives the exception value and the resumption continuation `k`.
-- It may resume by calling `k value`, or it may replace the failing action with
-- a new tree of its own.
-- ---------------------------------------------------------------------------

positive? = guardC "expected positive integer" (n : gte? n 1)
nonEmpty? = guardC "expected non-empty list" (xs : not? (emptyList? xs))

-- Average a list. Fails with a contract exception if the list is empty.
average = (xs :
  do bindM
    _ <- checkM nonEmpty? xs
    n <- pureM (length xs)
    _ <- checkM positive? n
    total <- pureM (sum xs)
    pureM (div total n))

-- A resumable config lookup. When the key is missing, callers can supply a
-- value by handling the "missing" exception.
lookupConfig = (key defaultValue :
  exceptE "missing" key (resume : pureM defaultValue))

-- A pipeline that averages a list and divides by a configured divisor.
pipeline = (xs :
  do bindM
    divisor <- lookupConfig "divisor" 1
    avg <- average xs
    scaled <- liftM (x : div x divisor) avg
    pureM scaled)

-- Without a handler the missing-key exception reaches runM.
unhandled = runM (pipeline [10 20 30])
-- < unhandled
-- > [t, "divisor"]

-- With a handler we replace the missing divisor with 2, so 20 / 2 = 10.
withHandler = runM (handleM "missing" (key k : pureM 2) (pipeline [10 20 30]))
-- < withHandler
-- > [t t, 10]

-- Handler can also use the original default by calling the resumption.
withResume = runM (handleM "missing" (key k : k 2) (pipeline [10 20 30]))
-- < withResume
-- > [t t, 20]

-- Contract failures still propagate through handlers for other tags.
bothFail = runM (handleM "missing" (key k : pureM 2) (pipeline []))
-- < bothFail
-- > [t, "expected non-empty list"]

main = withHandler