120 lines
3.5 KiB
Plaintext
120 lines
3.5 KiB
Plaintext
!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)]
|