!import "prelude" !Local
!import "view" !Local

-- Complete explicit View Contract demo.
-- Run with: tricu eval demos/viewContracts/complete.tri -f decode
--
-- This file uses the low-level portable typed-program builders directly. It is
-- useful for understanding what source annotations lower to. For the end-user
-- guide, see demos/viewContracts.tri.

requireNonEmpty = (xs :
  lazyBool
    (_ : guardFail)
    (_ : guardOk xs)
    (emptyList? xs))

NonEmptyList = (elemView :
  viewGuarded (viewList elemView) requireNonEmpty)

checkedResult = (result :
  matchResult
    (diag env : renderDiagnostic diag)
    (exec env :
      matchResult
        (runtimeDiag runtimeEnv : renderDiagnostic runtimeDiag)
        (value runtimeEnv : value)
        (runChecked exec))
    result)

checkedContract = (program :
  checkedResult (checkTypedProgramWith policyStrict program))

plainViewFailure =
  matchResult
    (diag env : renderDiagnostic diag)
    (exec env : "unexpected-ok")
    (checkTypedProgramWith
      policyStrict
      (typedProgram
        0
        [(typedValue 0 (viewList viewString) [("Ada")])
         (typedRequire 0 (viewList viewBool) t)]))

nonEmptyRootSuccess =
  matchBool
    "ok"
    "unexpected-value"
    (equal?
      (checkedContract
        (typedProgram
          0
          [(typedValue 0 (NonEmptyList viewString) [("Ada") ("Grace")])]))
      [("Ada") ("Grace")])

nonEmptyRootFailure =
  checkedContract
    (typedProgram
      0
      [(typedValue 0 (viewList viewString) [])
       (typedRequire 0 (NonEmptyList viewString) [])])

firstNameSuccess =
  checkedContract
    (typedProgram
      2
      [(typedValue 0 (viewFn [(NonEmptyList viewString)] viewString) (xs : head xs))
       (typedValue 1 (viewList viewString) [("Ada") ("Grace")])
       (typedApply 2 0 1 "Ada")
       (typedRequire 2 viewString "Ada")])

firstNameFailure =
  checkedContract
    (typedProgram
      2
      [(typedValue 0 (viewFn [(NonEmptyList viewString)] viewString) (xs : head xs))
       (typedValue 1 (viewList viewString) [])
       (typedApply 2 0 1 t)
       (typedRequire 2 viewString t)])

resultGuardFailure =
  checkedContract
    (typedProgram
      2
      [(typedValue 0 (viewFn [(viewString)] (NonEmptyList viewString)) (name : []))
       (typedValue 1 viewString "Ada")
       (typedApply 2 0 1 [])])

observationComposition =
  checkedContract
    (typedProgram
      0
      [(typedValue 0 viewString "Ada")
       (typedRequire 0 (viewGuarded viewString (x : guardOk (append x " Lovelace"))) "Ada")
       (typedRequire 0 (viewGuarded viewString (x : guardOk (append x "!"))) "Ada")])

unreachableGuard =
  checkedContract
    (typedProgram
      0
      [(typedValue 0 viewString "only the root is checked")
       (typedValue 1 (viewList viewString) [])
       (typedRequire 1 (NonEmptyList viewString) [])])

malformedGuard =
  checkedContract
    (typedProgram
      0
      [(typedValue 0 (viewGuarded viewString (x : record 99 t)) "bad guard")])

main = [
  (append "plain View structural failure: " plainViewFailure)
  (append "NonEmptyList root success: " nonEmptyRootSuccess)
  (append "NonEmptyList root failure: " nonEmptyRootFailure)
  (append "NonEmptyList function argument success: " firstNameSuccess)
  (append "NonEmptyList function argument failure: " firstNameFailure)
  (append "NonEmptyList function result failure: " resultGuardFailure)
  (append "guard observations compose: " observationComposition)
  (append "unreachable guard does not run: " unreachableGuard)
  (append "malformed guard result: " malformedGuard)]