1561 lines
52 KiB
Plaintext
1561 lines
52 KiB
Plaintext
!import "prelude" !Local
|
|
!import "patterns" !Local
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- View Contract core, validation kernel
|
|
--
|
|
-- This layer validates typed/checkable program trees: executable payload slots
|
|
-- and view-flow structure travel together in one portable value. Executable
|
|
-- payloads remain opaque to metadata validation until a checker/interpreter
|
|
-- explicitly chooses to run or rewrite them.
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
-- Generic tagged records / fields. Constructors use field sentinels; accessors
|
|
-- for fixed-format records use finite positional destructuring to avoid driving
|
|
-- recursive field lookup while top-level definitions normalize.
|
|
record = (tag fields : pair tag fields)
|
|
recordTag = fst
|
|
recordFields = snd
|
|
|
|
field = (tag value : pair tag value)
|
|
fieldTag = fst
|
|
fieldValue = snd
|
|
|
|
field0 = (fields : fieldValue (head fields))
|
|
field1 = (fields : fieldValue (head (tail fields)))
|
|
field2 = (fields : fieldValue (head (tail (tail fields))))
|
|
field3 = (fields : fieldValue (head (tail (tail (tail fields)))))
|
|
field4 = (fields : fieldValue (head (tail (tail (tail (tail fields))))))
|
|
|
|
field0Tag? = (fields tag : equal? (fieldTag (head fields)) tag)
|
|
field1Tag? = (fields tag : equal? (fieldTag (head (tail fields))) tag)
|
|
field2Tag? = (fields tag : equal? (fieldTag (head (tail (tail fields)))) tag)
|
|
field3Tag? = (fields tag : equal? (fieldTag (head (tail (tail (tail fields))))) tag)
|
|
|
|
fields1? = (fields tag0 :
|
|
and?
|
|
(field0Tag? fields tag0)
|
|
(emptyList? (tail fields)))
|
|
|
|
fields2? = (fields tag0 tag1 :
|
|
and?
|
|
(and? (field0Tag? fields tag0) (field1Tag? fields tag1))
|
|
(emptyList? (tail (tail fields))))
|
|
|
|
fields3? = (fields tag0 tag1 tag2 :
|
|
and?
|
|
(and? (fields2Prefix fields tag0 tag1) (field2Tag? fields tag2))
|
|
(emptyList? (tail (tail (tail fields)))))
|
|
|
|
fields4? = (fields tag0 tag1 tag2 tag3 :
|
|
and?
|
|
(and? (fields2Prefix fields tag0 tag1) (and? (field2Tag? fields tag2) (field3Tag? fields tag3)))
|
|
(emptyList? (tail (tail (tail (tail fields))))))
|
|
|
|
fields2Prefix = (fields tag0 tag1 :
|
|
and? (field0Tag? fields tag0) (field1Tag? fields tag1))
|
|
|
|
-- View tags / fields
|
|
viewTagAny = 0
|
|
viewTagFn = 1
|
|
viewTagRef = 2
|
|
viewTagList = 3
|
|
viewTagMaybe = 4
|
|
viewTagPair = 5
|
|
viewTagResult = 6
|
|
viewTagGuarded = 7
|
|
viewFieldArgs = 0
|
|
viewFieldResult = 1
|
|
viewFieldRef = 2
|
|
viewFieldElem = 3
|
|
viewFieldLeft = 4
|
|
viewFieldRight = 5
|
|
viewFieldErr = 6
|
|
viewFieldOk = 7
|
|
viewFieldBase = 8
|
|
viewFieldGuard = 9
|
|
|
|
-- Evidence tags
|
|
evidenceTagTrusted = 0
|
|
evidenceTagInferred = 1
|
|
evidenceTagRequired = 2
|
|
|
|
-- Boundary strategies / policy
|
|
boundaryStrategyError = 0
|
|
boundaryStrategyTrust = 1
|
|
policyStrict = pair boundaryStrategyError t
|
|
policyGradual = pair boundaryStrategyTrust t
|
|
policyBoundaryStrategy = fst
|
|
|
|
-- Structured checker error tags. Result payloads remain strings for compatibility;
|
|
-- these numeric tags give portable tests and frontends a stable diagnostic API.
|
|
errorTagOk = 0
|
|
errorTagMalformedPolicy = 1
|
|
errorTagMalformedProgram = 2
|
|
errorTagUnknownNode = 3
|
|
errorTagMissingRequiredView = 4
|
|
errorTagMissingFunctionArgumentView = 5
|
|
errorTagZeroArityFunction = 6
|
|
errorTagGuardFailed = 7
|
|
errorTagMalformedGuardResult = 8
|
|
errorTagUnknown = 99
|
|
|
|
diagnosticFieldSymbol = 0
|
|
diagnosticFieldExpectedView = 1
|
|
diagnosticFieldActualView = 2
|
|
diagnosticFieldActualTag = 3
|
|
diagnosticFieldGuardContext = 4
|
|
|
|
diagnostic = (tag fields : record tag fields)
|
|
diagnosticTag = recordTag
|
|
diagnosticPayload = recordFields
|
|
diagnosticSymbol = (diag : field0 (diagnosticPayload diag))
|
|
diagnosticExpectedView = (diag : field1 (diagnosticPayload diag))
|
|
diagnosticActualView = (diag : field2 (diagnosticPayload diag))
|
|
|
|
diagnosticMessage = (diag :
|
|
let tag = diagnosticTag diag in
|
|
lazyBool
|
|
(_ : "malformed view policy")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "malformed view program")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "unknown typed node tag")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "required view is not known")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "function argument view is not known")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "cannot apply zero-arity Fn view")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "guard failed")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "malformed guard result")
|
|
(_ : "unknown checker error")
|
|
(equal? tag errorTagMalformedGuardResult))
|
|
(equal? tag errorTagGuardFailed))
|
|
(equal? tag errorTagZeroArityFunction))
|
|
(equal? tag errorTagMissingFunctionArgumentView))
|
|
(equal? tag errorTagMissingRequiredView))
|
|
(equal? tag errorTagUnknownNode))
|
|
(equal? tag errorTagMalformedProgram))
|
|
(equal? tag errorTagMalformedPolicy))
|
|
|
|
-- Environment tags / fields
|
|
viewFactTagKnown = 0
|
|
viewFactFieldView = 0
|
|
viewFactFieldEvidence = 1
|
|
envEntryTagViews = 0
|
|
|
|
contractExprTagValue = 0
|
|
contractExprTagFn = 1
|
|
contractExprTagCall = 2
|
|
contractExprTagRequire = 3
|
|
contractExprFieldView = 0
|
|
contractExprFieldArgs = 0
|
|
contractExprFieldResult = 1
|
|
contractExprFieldFn = 0
|
|
contractExprFieldArg = 1
|
|
contractExprFieldExpr = 0
|
|
contractExprFieldRequired = 1
|
|
|
|
-- View-tree checker artifact tags / fields. A view tree is the durable
|
|
-- checker input: executable payloads and checking structure travel together.
|
|
-- Term fields are opaque executable trees; View validation must not recurse
|
|
-- into them as metadata.
|
|
typedProgramTag = 20
|
|
typedNodeTagValue = 21
|
|
typedNodeTagApply = 22
|
|
typedNodeTagRequire = 23
|
|
typedProgramFieldRoot = 0
|
|
typedProgramFieldNodes = 1
|
|
typedNodeFieldSymbol = 0
|
|
typedNodeFieldView = 1
|
|
typedNodeFieldTerm = 2
|
|
typedNodeFieldCallee = 3
|
|
typedNodeFieldArg = 4
|
|
|
|
-- Checked-exec / runtime guard protocol tags. Successful checker results always
|
|
-- carry checked-exec artifacts; unguarded roots are represented as checkedPure.
|
|
guardResultTagOk = 30
|
|
guardResultTagFail = 31
|
|
guardResultFieldValue = 0
|
|
|
|
checkedExecTagPure = 40
|
|
checkedExecTagFail = 41
|
|
checkedExecTagGuard = 42
|
|
checkedExecTagBind = 43
|
|
checkedExecFieldValue = 0
|
|
checkedExecFieldDiagnostic = 1
|
|
checkedExecFieldView = 2
|
|
checkedExecFieldGuard = 3
|
|
checkedExecFieldContinuation = 4
|
|
checkedExecFieldGuardContext = 5
|
|
|
|
guardContextTagRootValue = 50
|
|
guardContextTagRootRequire = 51
|
|
guardContextTagSymbolValue = 52
|
|
guardContextTagSymbolRequire = 53
|
|
guardContextTagFunctionArgument = 54
|
|
guardContextTagFunctionResult = 55
|
|
guardContextTagUnknown = 59
|
|
guardContextFieldSymbol = 0
|
|
guardContextFieldApplication = 1
|
|
guardContextFieldCallee = 2
|
|
guardContextFieldArg = 3
|
|
guardContextFieldArgIndex = 4
|
|
|
|
envEntryFieldSymbol = 0
|
|
envEntryFieldViews = 1
|
|
|
|
viewAny = record viewTagAny t
|
|
viewFn args result =
|
|
record viewTagFn [(field viewFieldArgs args) (field viewFieldResult result)]
|
|
viewRef symbol = record viewTagRef [(field viewFieldRef symbol)]
|
|
viewList elem = record viewTagList [(field viewFieldElem elem)]
|
|
viewMaybe elem = record viewTagMaybe [(field viewFieldElem elem)]
|
|
viewPair left right =
|
|
record viewTagPair [(field viewFieldLeft left) (field viewFieldRight right)]
|
|
viewResult errView okView =
|
|
record viewTagResult [(field viewFieldErr errView) (field viewFieldOk okView)]
|
|
viewGuarded baseView guard =
|
|
record viewTagGuarded [(field viewFieldBase baseView) (field viewFieldGuard guard)]
|
|
|
|
viewTag = recordTag
|
|
viewPayload = recordFields
|
|
fnArgs = (view : field0 (viewPayload view))
|
|
fnResult = (view : field1 (viewPayload view))
|
|
|
|
fnResidual = (restArgs result :
|
|
lazyList
|
|
(_ : result)
|
|
(_ _ : viewFn restArgs result)
|
|
restArgs)
|
|
|
|
anyView? = (view : equal? view viewAny)
|
|
fnView? = (view : equal? (viewTag view) viewTagFn)
|
|
refView? = (view : equal? (viewTag view) viewTagRef)
|
|
listView? = (view : equal? (viewTag view) viewTagList)
|
|
maybeView? = (view : equal? (viewTag view) viewTagMaybe)
|
|
pairView? = (view : equal? (viewTag view) viewTagPair)
|
|
resultView? = (view : equal? (viewTag view) viewTagResult)
|
|
guardedView? = (view : equal? (viewTag view) viewTagGuarded)
|
|
guardedViewBase = (view : field0 (viewPayload view))
|
|
guardedViewGuard = (view : field1 (viewPayload view))
|
|
|
|
viewFact = (view evidence :
|
|
record viewFactTagKnown
|
|
[(field viewFactFieldView view)
|
|
(field viewFactFieldEvidence evidence)])
|
|
viewFactView = (fact : field0 (recordFields fact))
|
|
viewFactEvidence = (fact : field1 (recordFields fact))
|
|
|
|
envEntry = (symbol viewSet :
|
|
record envEntryTagViews
|
|
[(field envEntryFieldSymbol symbol)
|
|
(field envEntryFieldViews viewSet)])
|
|
envEntrySymbol = (entry : field0 (recordFields entry))
|
|
envEntryViews = (entry : field1 (recordFields entry))
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Well-formed metadata checks. This is the first point where the checker starts
|
|
-- protecting itself: every typed node is shape-checked before flow interpretation.
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
validEvidence? = (e :
|
|
or?
|
|
(equal? e evidenceTagTrusted)
|
|
(or? (equal? e evidenceTagInferred) (equal? e evidenceTagRequired)))
|
|
|
|
validBoundaryStrategy? = (strategy :
|
|
or?
|
|
(equal? strategy boundaryStrategyError)
|
|
(equal? strategy boundaryStrategyTrust))
|
|
|
|
wellFormedPolicy? = (policy :
|
|
validBoundaryStrategy? (policyBoundaryStrategy policy))
|
|
|
|
wellFormedFnArgs_ self viewSelf views =
|
|
lazyList
|
|
(_ : true)
|
|
(view rest :
|
|
lazyBool
|
|
(_ : self viewSelf rest)
|
|
(_ : false)
|
|
(viewSelf view))
|
|
views
|
|
|
|
wellFormedFnView? = (view :
|
|
fields2? (viewPayload view) viewFieldArgs viewFieldResult)
|
|
|
|
wellFormedAnyView? = (view :
|
|
equal? (viewPayload view) t)
|
|
|
|
wellFormedRefView? = (view :
|
|
fields1? (viewPayload view) viewFieldRef)
|
|
|
|
wellFormedUnaryView? = (view fieldTag :
|
|
fields1? (viewPayload view) fieldTag)
|
|
|
|
wellFormedPairView? = (view :
|
|
fields2? (viewPayload view) viewFieldLeft viewFieldRight)
|
|
|
|
wellFormedResultView? = (view :
|
|
fields2? (viewPayload view) viewFieldErr viewFieldOk)
|
|
|
|
wellFormedGuardedView? = (view :
|
|
fields2? (viewPayload view) viewFieldBase viewFieldGuard)
|
|
|
|
wellFormedView_ self view =
|
|
lazyBool
|
|
(_ : wellFormedAnyView? view)
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : self (fnResult view))
|
|
(_ : false)
|
|
(y wellFormedFnArgs_ self (fnArgs view)))
|
|
(_ :
|
|
lazyBool
|
|
(_ : wellFormedRefView? view)
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : self (field0 (viewPayload view)))
|
|
(_ : false)
|
|
(wellFormedUnaryView? view viewFieldElem))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : self (field1 (viewPayload view)))
|
|
(_ : false)
|
|
(self (field0 (viewPayload view))))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : self (field1 (viewPayload view)))
|
|
(_ : false)
|
|
(self (field0 (viewPayload view))))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : self (guardedViewBase view))
|
|
(_ : false)
|
|
(wellFormedGuardedView? view))
|
|
(_ : false)
|
|
(guardedView? view))
|
|
(and? (resultView? view) (wellFormedResultView? view)))
|
|
(and? (pairView? view) (wellFormedPairView? view)))
|
|
(or? (listView? view) (maybeView? view)))
|
|
(refView? view))
|
|
(and? (fnView? view) (wellFormedFnView? view)))
|
|
(anyView? view)
|
|
|
|
wellFormedView? = (view :
|
|
y wellFormedView_ view)
|
|
|
|
wellFormedViews_ self views =
|
|
lazyList
|
|
(_ : true)
|
|
(view rest :
|
|
lazyBool
|
|
(_ : self rest)
|
|
(_ : false)
|
|
(wellFormedView? view))
|
|
views
|
|
|
|
wellFormedViews? = (views :
|
|
y wellFormedViews_ views)
|
|
|
|
wellFormedViewFact? = (fact :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
and?
|
|
(wellFormedView? (viewFactView fact))
|
|
(validEvidence? (viewFactEvidence fact)))
|
|
(_ : false)
|
|
(fields2? (recordFields fact) viewFactFieldView viewFactFieldEvidence))
|
|
(_ : false)
|
|
(equal? (recordTag fact) viewFactTagKnown))
|
|
|
|
wellFormedViewSet_ self viewSet =
|
|
lazyList
|
|
(_ : true)
|
|
(fact rest :
|
|
lazyBool
|
|
(_ : self rest)
|
|
(_ : false)
|
|
(wellFormedViewFact? fact))
|
|
viewSet
|
|
|
|
wellFormedViewSet? = (viewSet :
|
|
y wellFormedViewSet_ viewSet)
|
|
|
|
wellFormedEnvEntry? = (entry :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : wellFormedViewSet? (envEntryViews entry))
|
|
(_ : false)
|
|
(fields2? (recordFields entry) envEntryFieldSymbol envEntryFieldViews))
|
|
(_ : false)
|
|
(equal? (recordTag entry) envEntryTagViews))
|
|
|
|
wellFormedEnv_ self env =
|
|
lazyList
|
|
(_ : true)
|
|
(entry rest :
|
|
lazyBool
|
|
(_ : self rest)
|
|
(_ : false)
|
|
(wellFormedEnvEntry? entry))
|
|
env
|
|
|
|
wellFormedEnv? = (env :
|
|
y wellFormedEnv_ env)
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Flow environment
|
|
-- env = listOf tagged envEntry
|
|
-- viewSet = listOf tagged viewFact
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
lookupViews_ self symbol env =
|
|
lazyList
|
|
(_ : nothing)
|
|
(entry rest :
|
|
lazyBool
|
|
(_ : just (envEntryViews entry))
|
|
(_ : self symbol rest)
|
|
(equal? symbol (envEntrySymbol entry)))
|
|
env
|
|
|
|
lookupViews = (symbol env :
|
|
y lookupViews_ symbol env)
|
|
|
|
viewSetHas_ self view viewSet =
|
|
lazyList
|
|
(_ : false)
|
|
(fact rest :
|
|
lazyBool
|
|
(_ : true)
|
|
(_ : self view rest)
|
|
(equal? view (viewFactView fact)))
|
|
viewSet
|
|
|
|
viewSetHas? = (view viewSet :
|
|
lazyBool
|
|
(_ : true)
|
|
(_ : y viewSetHas_ view viewSet)
|
|
(anyView? view))
|
|
|
|
hasView? = (symbol view env :
|
|
lazyMaybe
|
|
(_ : anyView? view)
|
|
(viewSet : viewSetHas? view viewSet)
|
|
(lookupViews symbol env))
|
|
|
|
addViewToSet = (view evidence viewSet :
|
|
lazyBool
|
|
(_ : viewSet)
|
|
(_ : pair (viewFact view evidence) viewSet)
|
|
(viewSetHas? view viewSet))
|
|
|
|
extendEnv_ self symbol view evidence env =
|
|
lazyList
|
|
(_ : [(envEntry symbol [(viewFact view evidence)])])
|
|
(entry rest :
|
|
lazyBool
|
|
(_ :
|
|
pair
|
|
(envEntry symbol (addViewToSet view evidence (envEntryViews entry)))
|
|
rest)
|
|
(_ : pair entry (self symbol view evidence rest))
|
|
(equal? symbol (envEntrySymbol entry)))
|
|
env
|
|
|
|
extendEnv = (symbol view evidence env :
|
|
y extendEnv_ symbol view evidence env)
|
|
|
|
findFnView_ self viewSet =
|
|
lazyList
|
|
(_ : nothing)
|
|
(fact rest :
|
|
let view = viewFactView fact in
|
|
lazyBool
|
|
(_ : just view)
|
|
(_ : self rest)
|
|
(fnView? view))
|
|
viewSet
|
|
|
|
findFnView = (viewSet :
|
|
y findFnView_ viewSet)
|
|
|
|
firstKnownView = (viewSet :
|
|
lazyList
|
|
(_ : viewAny)
|
|
(fact rest : viewFactView fact)
|
|
viewSet)
|
|
|
|
actualViewFor = (symbol env :
|
|
lazyMaybe
|
|
(_ : viewAny)
|
|
(viewSet : firstKnownView viewSet)
|
|
(lookupViews symbol env))
|
|
|
|
checkerErr = (tag fields env : err (diagnostic tag fields) env)
|
|
checkerOk = (env : ok env t)
|
|
|
|
missingRequiredView = (policy symbol view env :
|
|
lazyBool
|
|
(_ :
|
|
checkerErr
|
|
errorTagMissingRequiredView
|
|
[(field diagnosticFieldSymbol symbol)
|
|
(field diagnosticFieldExpectedView view)
|
|
(field diagnosticFieldActualView (actualViewFor symbol env))]
|
|
env)
|
|
(_ : checkerOk (extendEnv symbol view evidenceTagTrusted env))
|
|
(equal? (policyBoundaryStrategy policy) boundaryStrategyError))
|
|
|
|
missingArgumentView = (policy symbol view env :
|
|
lazyBool
|
|
(_ :
|
|
checkerErr
|
|
errorTagMissingFunctionArgumentView
|
|
[(field diagnosticFieldSymbol symbol)
|
|
(field diagnosticFieldExpectedView view)
|
|
(field diagnosticFieldActualView (actualViewFor symbol env))]
|
|
env)
|
|
(_ : checkerOk (extendEnv symbol view evidenceTagTrusted env))
|
|
(equal? (policyBoundaryStrategy policy) boundaryStrategyError))
|
|
|
|
checkApplicationSymbols = (policy argSymbol outSymbol env fnView :
|
|
lazyList
|
|
(_ : checkerErr errorTagZeroArityFunction t env)
|
|
(argView restArgs :
|
|
let resultView = fnResidual restArgs (fnResult fnView) in
|
|
lazyBool
|
|
(_ : checkerOk (extendEnv outSymbol resultView evidenceTagInferred env))
|
|
(_ :
|
|
lazyResult
|
|
(diag envAtError : err diag envAtError)
|
|
(nextEnv _ : checkerOk (extendEnv outSymbol resultView evidenceTagInferred nextEnv))
|
|
(missingArgumentOrGuardedBase policy argSymbol argView env))
|
|
(hasView? argSymbol argView env))
|
|
(fnArgs fnView))
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- View-tree checker artifact
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
typedProgram = (root nodes :
|
|
record typedProgramTag
|
|
[(field typedProgramFieldRoot root)
|
|
(field typedProgramFieldNodes nodes)])
|
|
|
|
typedProgramRoot = (program : field0 (recordFields program))
|
|
typedProgramNodes = (program : field1 (recordFields program))
|
|
|
|
typedValue = (symbol view term :
|
|
record typedNodeTagValue
|
|
[(field typedNodeFieldSymbol symbol)
|
|
(field typedNodeFieldView view)
|
|
(field typedNodeFieldTerm term)])
|
|
|
|
typedApply = (symbol callee arg term :
|
|
record typedNodeTagApply
|
|
[(field typedNodeFieldSymbol symbol)
|
|
(field typedNodeFieldCallee callee)
|
|
(field typedNodeFieldArg arg)
|
|
(field typedNodeFieldTerm term)])
|
|
|
|
typedRequire = (symbol view term :
|
|
record typedNodeTagRequire
|
|
[(field typedNodeFieldSymbol symbol)
|
|
(field typedNodeFieldView view)
|
|
(field typedNodeFieldTerm term)])
|
|
|
|
typedNodeSymbol = (node : field0 (recordFields node))
|
|
typedNodeView = (node : field1 (recordFields node))
|
|
typedNodeTerm = (node : field2 (recordFields node))
|
|
typedApplyCallee = (node : field1 (recordFields node))
|
|
typedApplyArg = (node : field2 (recordFields node))
|
|
typedApplyTerm = (node : field0 (tail (tail (tail (recordFields node)))))
|
|
|
|
wellFormedTypedValue? = (node :
|
|
lazyBool
|
|
(_ : wellFormedView? (typedNodeView node))
|
|
(_ : false)
|
|
(fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm))
|
|
|
|
wellFormedTypedApply? = (node :
|
|
fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldCallee typedNodeFieldArg)
|
|
|
|
wellFormedTypedApplyPayload? = (node :
|
|
and?
|
|
(fields2Prefix (recordFields node) typedNodeFieldSymbol typedNodeFieldCallee)
|
|
(and?
|
|
(field2Tag? (recordFields node) typedNodeFieldArg)
|
|
(and?
|
|
(field0Tag? (tail (tail (tail (recordFields node)))) typedNodeFieldTerm)
|
|
(emptyList? (tail (tail (tail (tail (recordFields node)))))))))
|
|
|
|
wellFormedTypedRequire? = (node :
|
|
lazyBool
|
|
(_ : wellFormedView? (typedNodeView node))
|
|
(_ : false)
|
|
(fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm))
|
|
|
|
wellFormedTypedNode? = (node :
|
|
let tag = recordTag node in
|
|
lazyBool
|
|
(_ : wellFormedTypedValue? node)
|
|
(_ :
|
|
lazyBool
|
|
(_ : wellFormedTypedApplyPayload? node)
|
|
(_ :
|
|
lazyBool
|
|
(_ : wellFormedTypedRequire? node)
|
|
(_ : false)
|
|
(equal? tag typedNodeTagRequire))
|
|
(equal? tag typedNodeTagApply))
|
|
(equal? tag typedNodeTagValue))
|
|
|
|
wellFormedTypedNodes_ self nodes =
|
|
lazyList
|
|
(_ : true)
|
|
(node rest :
|
|
lazyBool
|
|
(_ : self rest)
|
|
(_ : false)
|
|
(wellFormedTypedNode? node))
|
|
nodes
|
|
|
|
wellFormedTypedNodes? = (nodes : y wellFormedTypedNodes_ nodes)
|
|
|
|
wellFormedTypedProgram? = (program :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : wellFormedTypedNodes? (typedProgramNodes program))
|
|
(_ : false)
|
|
(fields2? (recordFields program) typedProgramFieldRoot typedProgramFieldNodes))
|
|
(_ : false)
|
|
(equal? (recordTag program) typedProgramTag))
|
|
|
|
checkTypedValueNode = (node env :
|
|
let symbol = typedNodeSymbol node in
|
|
let view = typedNodeView node in
|
|
lazyBool
|
|
(_ :
|
|
checkerOk
|
|
(extendEnv
|
|
symbol
|
|
view
|
|
evidenceTagTrusted
|
|
(extendEnv symbol (guardedViewBase view) evidenceTagTrusted env)))
|
|
(_ : checkerOk (extendEnv symbol view evidenceTagTrusted env))
|
|
(guardedView? view))
|
|
|
|
checkTypedRequireNode = (policy node env :
|
|
let symbol = typedNodeSymbol node in
|
|
let view = typedNodeView node in
|
|
lazyBool
|
|
(_ : checkerOk env)
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : checkerOk (extendEnv symbol view evidenceTagRequired env))
|
|
(_ : missingRequiredView policy symbol view env)
|
|
(hasView? symbol (guardedViewBase view) env))
|
|
(_ : missingRequiredView policy symbol view env)
|
|
(guardedView? view))
|
|
(hasView? symbol view env))
|
|
|
|
missingArgumentOrGuardedBase = (policy symbol view env :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : checkerOk (extendEnv symbol view evidenceTagRequired env))
|
|
(_ : missingArgumentView policy symbol view env)
|
|
(hasView? symbol (guardedViewBase view) env))
|
|
(_ : missingArgumentView policy symbol view env)
|
|
(guardedView? view))
|
|
|
|
checkTypedApplyNode = (policy node env :
|
|
lazyMaybe
|
|
(_ : checkerOk env)
|
|
(calleeViews :
|
|
lazyMaybe
|
|
(_ : checkerOk env)
|
|
(fnView : checkApplicationSymbols policy (typedApplyArg node) (typedNodeSymbol node) env fnView)
|
|
(findFnView calleeViews))
|
|
(lookupViews (typedApplyCallee node) env))
|
|
|
|
checkTypedNode = (policy node env :
|
|
let tag = recordTag node in
|
|
lazyBool
|
|
(_ : checkTypedValueNode node env)
|
|
(_ :
|
|
lazyBool
|
|
(_ : checkTypedApplyNode policy node env)
|
|
(_ : checkTypedRequireNode policy node env)
|
|
(equal? tag typedNodeTagApply))
|
|
(equal? tag typedNodeTagValue))
|
|
|
|
flowCheckTypedNodes_ self nodes policy env =
|
|
lazyList
|
|
(_ : checkerOk env)
|
|
(node rest :
|
|
lazyResult
|
|
(diag envAtError : err diag envAtError)
|
|
(nextEnv _ : self rest policy nextEnv)
|
|
(checkTypedNode policy node env))
|
|
nodes
|
|
|
|
flowCheckTypedNodes = (policy nodes :
|
|
y flowCheckTypedNodes_ nodes policy t)
|
|
|
|
lookupTypedTerm_ self symbol nodes =
|
|
lazyList
|
|
(_ : nothing)
|
|
(node rest :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : just (typedApplyTerm node))
|
|
(_ : just (typedNodeTerm node))
|
|
(equal? (recordTag node) typedNodeTagApply))
|
|
(_ : self symbol rest)
|
|
(equal? symbol (typedNodeSymbol node)))
|
|
nodes
|
|
|
|
lookupTypedTerm = (symbol program :
|
|
y lookupTypedTerm_ symbol (typedProgramNodes program))
|
|
|
|
lookupTypedView_ self symbol nodes =
|
|
lazyList
|
|
(_ : nothing)
|
|
(node rest :
|
|
let tag = recordTag node in
|
|
lazyBool
|
|
(_ : just (typedNodeView node))
|
|
(_ : self symbol rest)
|
|
(and?
|
|
(or? (equal? tag typedNodeTagValue) (equal? tag typedNodeTagRequire))
|
|
(equal? symbol (typedNodeSymbol node))))
|
|
nodes
|
|
|
|
lookupTypedView = (symbol program :
|
|
y lookupTypedView_ symbol (typedProgramNodes program))
|
|
|
|
lookupApplyDefinition_ self symbol nodes =
|
|
lazyList
|
|
(_ : nothing)
|
|
(node rest :
|
|
lazyBool
|
|
(_ : just node)
|
|
(_ : self symbol rest)
|
|
(and?
|
|
(equal? (recordTag node) typedNodeTagApply)
|
|
(equal? symbol (typedNodeSymbol node))))
|
|
nodes
|
|
|
|
lookupApplyDefinition = (symbol program :
|
|
y lookupApplyDefinition_ symbol (typedProgramNodes program))
|
|
|
|
firstFnArgView = (view :
|
|
lazyBool
|
|
(_ :
|
|
lazyList
|
|
(_ : nothing)
|
|
(arg rest : just arg)
|
|
(fnArgs view))
|
|
(_ : nothing)
|
|
(fnView? view))
|
|
|
|
appliedFnResultView = (view :
|
|
lazyBool
|
|
(_ :
|
|
lazyList
|
|
(_ : nothing)
|
|
(arg rest : just (fnResidual rest (fnResult view)))
|
|
(fnArgs view))
|
|
(_ : nothing)
|
|
(fnView? view))
|
|
|
|
lookupSymbolView_ self symbol program =
|
|
lazyMaybe
|
|
(_ :
|
|
lazyMaybe
|
|
(_ : nothing)
|
|
(applyNode :
|
|
lazyMaybe
|
|
(_ : nothing)
|
|
(calleeView : appliedFnResultView calleeView)
|
|
(self (typedApplyCallee applyNode) program))
|
|
(lookupApplyDefinition symbol program))
|
|
(view : just view)
|
|
(lookupTypedView symbol program)
|
|
|
|
lookupSymbolView = (symbol program :
|
|
y lookupSymbolView_ symbol program)
|
|
|
|
guardContextUnknown = record guardContextTagUnknown t
|
|
|
|
guardContextRootValue = (symbol :
|
|
record guardContextTagRootValue [(field guardContextFieldSymbol symbol)])
|
|
guardContextRootRequire = (symbol :
|
|
record guardContextTagRootRequire [(field guardContextFieldSymbol symbol)])
|
|
guardContextSymbolValue = (symbol :
|
|
record guardContextTagSymbolValue [(field guardContextFieldSymbol symbol)])
|
|
guardContextSymbolRequire = (symbol :
|
|
record guardContextTagSymbolRequire [(field guardContextFieldSymbol symbol)])
|
|
guardContextFunctionArgument = (application callee arg argIndex :
|
|
record guardContextTagFunctionArgument
|
|
[(field guardContextFieldApplication application)
|
|
(field guardContextFieldCallee callee)
|
|
(field guardContextFieldArg arg)
|
|
(field guardContextFieldArgIndex argIndex)])
|
|
guardContextFunctionResult = (application callee arg :
|
|
record guardContextTagFunctionResult
|
|
[(field guardContextFieldApplication application)
|
|
(field guardContextFieldCallee callee)
|
|
(field guardContextFieldArg arg)])
|
|
|
|
guardContextObservation = (root symbol nodeTag :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ : guardContextRootValue symbol)
|
|
(_ : guardContextRootRequire symbol)
|
|
(equal? nodeTag typedNodeTagValue))
|
|
(_ :
|
|
lazyBool
|
|
(_ : guardContextSymbolValue symbol)
|
|
(_ : guardContextSymbolRequire symbol)
|
|
(equal? nodeTag typedNodeTagValue))
|
|
(equal? root symbol))
|
|
|
|
applySymbolGuardedObservations_ self root symbol nodes exec =
|
|
lazyList
|
|
(_ : exec)
|
|
(node rest :
|
|
let tag = recordTag node in
|
|
lazyBool
|
|
(_ :
|
|
let view = typedNodeView node in
|
|
lazyBool
|
|
(_ :
|
|
self
|
|
root
|
|
symbol
|
|
rest
|
|
(checkedBind
|
|
exec
|
|
(value : checkedGuardWithContext (guardContextObservation root symbol tag) view (guardedViewGuard view) value (checkedValue : checkedPure checkedValue))))
|
|
(_ : self root symbol rest exec)
|
|
(guardedView? view))
|
|
(_ : self root symbol rest exec)
|
|
(and?
|
|
(or? (equal? tag typedNodeTagValue) (equal? tag typedNodeTagRequire))
|
|
(equal? symbol (typedNodeSymbol node))))
|
|
nodes
|
|
|
|
applySymbolGuardedObservations = (program symbol exec :
|
|
y applySymbolGuardedObservations_ (typedProgramRoot program) symbol (typedProgramNodes program) exec)
|
|
|
|
compileApplyExec = (self program applyNode :
|
|
let calleeSym = typedApplyCallee applyNode in
|
|
let argSym = typedApplyArg applyNode in
|
|
let calleeExec = self program calleeSym in
|
|
let argExec = self program argSym in
|
|
lazyMaybe
|
|
(_ :
|
|
checkedBind
|
|
calleeExec
|
|
(calleeValue :
|
|
checkedBind
|
|
argExec
|
|
(argValue : checkedPure (calleeValue argValue))))
|
|
(calleeView :
|
|
let applicationExec =
|
|
lazyMaybe
|
|
(_ :
|
|
checkedBind
|
|
calleeExec
|
|
(calleeValue :
|
|
checkedBind
|
|
argExec
|
|
(argValue : checkedPure (calleeValue argValue))))
|
|
(argView :
|
|
lazyBool
|
|
(_ :
|
|
checkedBind
|
|
calleeExec
|
|
(calleeValue :
|
|
checkedBind
|
|
argExec
|
|
(argValue :
|
|
checkedBind
|
|
(checkedGuardWithContext (guardContextFunctionArgument (typedNodeSymbol applyNode) calleeSym argSym 0) argView (guardedViewGuard argView) argValue (checkedValue : checkedPure checkedValue))
|
|
(checkedValue : checkedPure (calleeValue checkedValue)))))
|
|
(_ :
|
|
checkedBind
|
|
calleeExec
|
|
(calleeValue :
|
|
checkedBind
|
|
argExec
|
|
(argValue : checkedPure (calleeValue argValue))))
|
|
(guardedView? argView))
|
|
(firstFnArgView calleeView) in
|
|
lazyMaybe
|
|
(_ : applicationExec)
|
|
(resultView :
|
|
lazyBool
|
|
(_ :
|
|
checkedBind
|
|
applicationExec
|
|
(value : checkedGuardWithContext (guardContextFunctionResult (typedNodeSymbol applyNode) calleeSym argSym) resultView (guardedViewGuard resultView) value (checkedValue : checkedPure checkedValue)))
|
|
(_ : applicationExec)
|
|
(guardedView? resultView))
|
|
(appliedFnResultView calleeView))
|
|
(lookupSymbolView calleeSym program))
|
|
|
|
compileSymbol_ self program symbol =
|
|
lazyMaybe
|
|
(_ :
|
|
lazyMaybe
|
|
(_ : checkedPure t)
|
|
(term : applySymbolGuardedObservations program symbol (checkedPure term))
|
|
(lookupTypedTerm symbol program))
|
|
(applyNode : applySymbolGuardedObservations program symbol (compileApplyExec self program applyNode))
|
|
(lookupApplyDefinition symbol program)
|
|
|
|
compileSymbol = (program symbol :
|
|
y compileSymbol_ program symbol)
|
|
|
|
checkedExecForRootTerm = (program term :
|
|
compileSymbol program (typedProgramRoot program))
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Checked execution / runtime guard protocol
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
guardOk = (value :
|
|
record guardResultTagOk [(field guardResultFieldValue value)])
|
|
guardFail = record guardResultTagFail t
|
|
|
|
guardResultOk? = (result : equal? (recordTag result) guardResultTagOk)
|
|
guardResultFail? = (result : equal? (recordTag result) guardResultTagFail)
|
|
guardResultValue = (result : field0 (recordFields result))
|
|
|
|
checkedPure = (value :
|
|
record checkedExecTagPure [(field checkedExecFieldValue value)])
|
|
checkedFail = (diag :
|
|
record checkedExecTagFail [(field checkedExecFieldDiagnostic diag)])
|
|
checkedGuardWithContext = (context view guard value continuation :
|
|
record checkedExecTagGuard
|
|
[(field checkedExecFieldView view)
|
|
(field checkedExecFieldGuard guard)
|
|
(field checkedExecFieldValue value)
|
|
(field checkedExecFieldContinuation continuation)
|
|
(field checkedExecFieldGuardContext context)])
|
|
checkedGuard = (view guard value continuation :
|
|
checkedGuardWithContext guardContextUnknown view guard value continuation)
|
|
checkedBind = (exec continuation :
|
|
record checkedExecTagBind
|
|
[(field checkedExecFieldValue exec)
|
|
(field checkedExecFieldContinuation continuation)])
|
|
|
|
checkedExecValue = (exec : field0 (recordFields exec))
|
|
checkedExecDiagnostic = (exec : field0 (recordFields exec))
|
|
checkedExecView = (exec : field0 (recordFields exec))
|
|
checkedExecGuard = (exec : field1 (recordFields exec))
|
|
checkedExecGuardValue = (exec : field2 (recordFields exec))
|
|
checkedExecContinuation = (exec : field3 (recordFields exec))
|
|
checkedExecGuardContext = (exec : field4 (recordFields exec))
|
|
checkedExecBindExec = (exec : field0 (recordFields exec))
|
|
checkedExecBindContinuation = (exec : field1 (recordFields exec))
|
|
|
|
checkedRuntimeOk = (value : ok value t)
|
|
checkedRuntimeFail = (diag : err diag t)
|
|
|
|
diagnosticGuardContext = (diag : field3 (diagnosticPayload diag))
|
|
|
|
checkedGuardFailedDiagnostic = (context view :
|
|
diagnostic
|
|
errorTagGuardFailed
|
|
[(field diagnosticFieldSymbol 0)
|
|
(field diagnosticFieldExpectedView view)
|
|
(field diagnosticFieldActualView viewAny)
|
|
(field diagnosticFieldGuardContext context)])
|
|
|
|
malformedGuardResultDiagnostic = (context view actual :
|
|
diagnostic
|
|
errorTagMalformedGuardResult
|
|
[(field diagnosticFieldSymbol 0)
|
|
(field diagnosticFieldExpectedView view)
|
|
(field diagnosticFieldActualTag (recordTag actual))
|
|
(field diagnosticFieldGuardContext context)])
|
|
|
|
runChecked_ self exec =
|
|
let tag = recordTag exec in
|
|
lazyBool
|
|
(_ : checkedRuntimeOk (checkedExecValue exec))
|
|
(_ :
|
|
lazyBool
|
|
(_ : checkedRuntimeFail (checkedExecDiagnostic exec))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
let view = checkedExecView exec in
|
|
let guard = checkedExecGuard exec in
|
|
let value = checkedExecGuardValue exec in
|
|
let continuation = checkedExecContinuation exec in
|
|
let context = checkedExecGuardContext exec in
|
|
let guardResult = guard value in
|
|
lazyBool
|
|
(_ : self (continuation (guardResultValue guardResult)))
|
|
(_ :
|
|
lazyBool
|
|
(_ : checkedRuntimeFail (checkedGuardFailedDiagnostic context view))
|
|
(_ : checkedRuntimeFail (malformedGuardResultDiagnostic context view guardResult))
|
|
(guardResultFail? guardResult))
|
|
(guardResultOk? guardResult))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
lazyResult
|
|
(diag runtimeEnv : checkedRuntimeFail diag)
|
|
(value runtimeEnv : self ((checkedExecBindContinuation exec) value))
|
|
(self (checkedExecBindExec exec)))
|
|
(_ : checkedRuntimeFail (malformedGuardResultDiagnostic guardContextUnknown viewAny exec))
|
|
(equal? tag checkedExecTagBind))
|
|
(equal? tag checkedExecTagGuard))
|
|
(equal? tag checkedExecTagFail))
|
|
(equal? tag checkedExecTagPure)
|
|
|
|
runChecked = (exec : y runChecked_ exec)
|
|
|
|
checkTypedProgramWith = (policy program :
|
|
lazyBool
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
lazyResult
|
|
(diag env : err diag env)
|
|
(env rest :
|
|
lazyMaybe
|
|
(_ : checkerErr errorTagMalformedProgram t env)
|
|
(term : ok (checkedExecForRootTerm program term) env)
|
|
(lookupTypedTerm (typedProgramRoot program) program))
|
|
(flowCheckTypedNodes policy (typedProgramNodes program)))
|
|
(_ : checkerErr errorTagMalformedProgram t t)
|
|
(wellFormedTypedProgram? program))
|
|
(_ : checkerErr errorTagMalformedPolicy t t)
|
|
(wellFormedPolicy? policy))
|
|
|
|
checkTypedProgram = (program :
|
|
checkTypedProgramWith policyGradual program)
|
|
|
|
checkedProgramTree = (result :
|
|
matchResult
|
|
(diag env : t)
|
|
(exec env :
|
|
matchResult
|
|
(runtimeDiag runtimeEnv : t)
|
|
(value runtimeEnv : value)
|
|
(runChecked exec))
|
|
result)
|
|
|
|
checkerResultErrorTag = (result :
|
|
matchResult
|
|
(diag env : diagnosticTag diag)
|
|
(env rest : errorTagOk)
|
|
result)
|
|
|
|
-- ---------------------------------------------------------------------------
|
|
-- Portable contract examples / self-tests. These are plain tricu values that
|
|
-- travel with the checker and exercise the same validators used by clients.
|
|
-- ---------------------------------------------------------------------------
|
|
|
|
viewBool = viewRef 0
|
|
viewString = viewRef 1
|
|
viewByte = viewRef 2
|
|
viewUnit = viewRef 3
|
|
|
|
renderViewArgs_ self viewSelf views =
|
|
lazyList
|
|
(_ : "")
|
|
(view rest :
|
|
lazyBool
|
|
(_ : viewSelf view)
|
|
(_ : append (viewSelf view) (append ", " (self viewSelf rest)))
|
|
(emptyList? rest))
|
|
views
|
|
|
|
renderView_ self view =
|
|
lazyBool
|
|
(_ : "Bool")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "String")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "Byte")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "Unit")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "Any")
|
|
(_ :
|
|
lazyBool
|
|
(_ : append "Ref " (showNumber (field0 (viewPayload view))))
|
|
(_ :
|
|
lazyBool
|
|
(_ : append "List " (self (field0 (viewPayload view))))
|
|
(_ :
|
|
lazyBool
|
|
(_ : append "Maybe " (self (field0 (viewPayload view))))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
append
|
|
"Pair "
|
|
(append
|
|
(self (field0 (viewPayload view)))
|
|
(append " " (self (field1 (viewPayload view))))))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
append
|
|
"Result "
|
|
(append
|
|
(self (field0 (viewPayload view)))
|
|
(append " " (self (field1 (viewPayload view))))))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
append
|
|
"Fn ["
|
|
(append
|
|
(y renderViewArgs_ self (fnArgs view))
|
|
(append "] " (self (fnResult view)))))
|
|
(_ :
|
|
lazyBool
|
|
(_ : append "Guarded " (self (guardedViewBase view)))
|
|
(_ : "View")
|
|
(guardedView? view))
|
|
(fnView? view))
|
|
(resultView? view))
|
|
(pairView? view))
|
|
(maybeView? view))
|
|
(listView? view))
|
|
(refView? view))
|
|
(anyView? view))
|
|
(equal? view viewUnit))
|
|
(equal? view viewByte))
|
|
(equal? view viewString))
|
|
(equal? view viewBool)
|
|
|
|
renderView = (view :
|
|
y renderView_ view)
|
|
|
|
append3 = (a b c : append a (append b c))
|
|
append4 = (a b c d : append a (append b (append c d)))
|
|
|
|
guardContextSymbol = (context : field0 (recordFields context))
|
|
guardContextApplication = (context : field0 (recordFields context))
|
|
guardContextCallee = (context : field1 (recordFields context))
|
|
guardContextArg = (context : field2 (recordFields context))
|
|
guardContextArgIndex = (context : field3 (recordFields context))
|
|
|
|
renderGuardContext = (context :
|
|
let tag = recordTag context in
|
|
lazyBool
|
|
(_ : append " at root typedValue symbol " (showNumber (guardContextSymbol context)))
|
|
(_ :
|
|
lazyBool
|
|
(_ : append " at root typedRequire symbol " (showNumber (guardContextSymbol context)))
|
|
(_ :
|
|
lazyBool
|
|
(_ : append " at typedValue symbol " (showNumber (guardContextSymbol context)))
|
|
(_ :
|
|
lazyBool
|
|
(_ : append " at typedRequire symbol " (showNumber (guardContextSymbol context)))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
append4
|
|
" at argument "
|
|
(showNumber (guardContextArgIndex context))
|
|
" of application symbol "
|
|
(append
|
|
(showNumber (guardContextApplication context))
|
|
(append
|
|
" (callee symbol "
|
|
(append
|
|
(showNumber (guardContextCallee context))
|
|
(append ", arg symbol " (append (showNumber (guardContextArg context)) ")"))))))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
append
|
|
" at result of application symbol "
|
|
(append
|
|
(showNumber (guardContextApplication context))
|
|
(append
|
|
" (callee symbol "
|
|
(append
|
|
(showNumber (guardContextCallee context))
|
|
(append ", arg symbol " (append (showNumber (guardContextArg context)) ")"))))))
|
|
(_ : "")
|
|
(equal? tag guardContextTagFunctionResult))
|
|
(equal? tag guardContextTagFunctionArgument))
|
|
(equal? tag guardContextTagSymbolRequire))
|
|
(equal? tag guardContextTagSymbolValue))
|
|
(equal? tag guardContextTagRootRequire))
|
|
(equal? tag guardContextTagRootValue))
|
|
|
|
renderDiagnostic = (diag :
|
|
let tag = diagnosticTag diag in
|
|
lazyBool
|
|
(_ : "malformed view policy")
|
|
(_ :
|
|
lazyBool
|
|
(_ : "malformed view program")
|
|
(_ :
|
|
lazyBool
|
|
(_ : append "unknown typed node tag " (showNumber (field0 (diagnosticPayload diag))))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
append
|
|
"symbol "
|
|
(append
|
|
(showNumber (diagnosticSymbol diag))
|
|
(append
|
|
" expected "
|
|
(append
|
|
(renderView (diagnosticExpectedView diag))
|
|
(append " but got " (renderView (diagnosticActualView diag)))))))
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
append
|
|
"symbol "
|
|
(append
|
|
(showNumber (diagnosticSymbol diag))
|
|
(append
|
|
" expected "
|
|
(append
|
|
(renderView (diagnosticExpectedView diag))
|
|
(append " but got " (renderView (diagnosticActualView diag)))))))
|
|
(_ :
|
|
lazyBool
|
|
(_ : "cannot apply zero-arity Fn view")
|
|
(_ :
|
|
lazyBool
|
|
(_ : append (append "guard failed" (renderGuardContext (diagnosticGuardContext diag))) (append " for " (renderView (diagnosticExpectedView diag))))
|
|
(_ :
|
|
lazyBool
|
|
(_ : append (append "malformed guard result" (renderGuardContext (diagnosticGuardContext diag))) (append " for " (renderView (diagnosticExpectedView diag))))
|
|
(_ : "unknown checker error")
|
|
(equal? tag errorTagMalformedGuardResult))
|
|
(equal? tag errorTagGuardFailed))
|
|
(equal? tag errorTagZeroArityFunction))
|
|
(equal? tag errorTagMissingFunctionArgumentView))
|
|
(equal? tag errorTagMissingRequiredView))
|
|
(equal? tag errorTagUnknownNode))
|
|
(equal? tag errorTagMalformedProgram))
|
|
(equal? tag errorTagMalformedPolicy))
|
|
|
|
viewContractProbe = (condition :
|
|
matchBool "ok" "fail" condition)
|
|
|
|
viewContractExpectResult = (expected result :
|
|
matchResult
|
|
(diag env : viewContractProbe (equal? (diagnosticMessage diag) expected))
|
|
(env rest : viewContractProbe (equal? "ok" expected))
|
|
result)
|
|
|
|
viewContractExpectErrorTag = (expected result :
|
|
viewContractProbe (equal? (checkerResultErrorTag result) expected))
|
|
|
|
viewContractExpectDiagnostic = (tag symbol expectedView result :
|
|
matchResult
|
|
(diag env :
|
|
viewContractProbe
|
|
(and?
|
|
(equal? (diagnosticTag diag) tag)
|
|
(and?
|
|
(equal? (diagnosticSymbol diag) symbol)
|
|
(equal? (diagnosticExpectedView diag) expectedView))))
|
|
(env rest : "fail")
|
|
result)
|
|
|
|
viewContractExpectDiagnosticActual = (tag symbol expectedView actualView result :
|
|
matchResult
|
|
(diag env :
|
|
viewContractProbe
|
|
(and?
|
|
(equal? (diagnosticTag diag) tag)
|
|
(and?
|
|
(equal? (diagnosticSymbol diag) symbol)
|
|
(and?
|
|
(equal? (diagnosticExpectedView diag) expectedView)
|
|
(equal? (diagnosticActualView diag) actualView)))))
|
|
(env rest : "fail")
|
|
result)
|
|
|
|
-- Small typed-program builder layer. These aliases make hand-written
|
|
-- contracts look like source-level declarations while emitting typed nodes.
|
|
typedDeclareFn = (symbol args result term :
|
|
typedValue symbol (viewFn args result) term)
|
|
|
|
viewUnary = (arg result :
|
|
viewFn [(arg)] result)
|
|
|
|
viewBinary = (left right result :
|
|
viewFn [(left) (right)] result)
|
|
|
|
viewTernary = (first second third result :
|
|
viewFn [(first) (second) (third)] result)
|
|
|
|
typedDeclareUnary = (symbol arg result term :
|
|
typedDeclareFn symbol [(arg)] result term)
|
|
|
|
typedDeclareBinary = (symbol left right result term :
|
|
typedDeclareFn symbol [(left) (right)] result term)
|
|
|
|
typedDeclareTernary = (symbol first second third result term :
|
|
typedDeclareFn symbol [(first) (second) (third)] result term)
|
|
|
|
typedUseUnary = (arg result fnSym argSym outSym :
|
|
typedProgram
|
|
outSym
|
|
[(typedDeclareUnary fnSym arg result t)
|
|
(typedValue argSym arg t)
|
|
(typedApply outSym fnSym argSym t)
|
|
(typedRequire outSym result t)])
|
|
|
|
typedUseBinary = (left right result fnSym leftSym rightSym partialSym outSym :
|
|
typedProgram
|
|
outSym
|
|
[(typedDeclareBinary fnSym left right result t)
|
|
(typedValue leftSym left t)
|
|
(typedValue rightSym right t)
|
|
(typedApply partialSym fnSym leftSym t)
|
|
(typedApply outSym partialSym rightSym t)
|
|
(typedRequire outSym result t)])
|
|
|
|
typedUseTernary = (first second third result fnSym firstSym secondSym thirdSym partial1Sym partial2Sym outSym :
|
|
typedProgram
|
|
outSym
|
|
[(typedDeclareTernary fnSym first second third result t)
|
|
(typedValue firstSym first t)
|
|
(typedValue secondSym second t)
|
|
(typedValue thirdSym third t)
|
|
(typedApply partial1Sym fnSym firstSym t)
|
|
(typedApply partial2Sym partial1Sym secondSym t)
|
|
(typedApply outSym partial2Sym thirdSym t)
|
|
(typedRequire outSym result t)])
|
|
|
|
cValue = (view :
|
|
record contractExprTagValue [(field contractExprFieldView view)])
|
|
|
|
cFn = (args result :
|
|
record contractExprTagFn
|
|
[(field contractExprFieldArgs args) (field contractExprFieldResult result)])
|
|
|
|
cCall = (fn arg :
|
|
record contractExprTagCall
|
|
[(field contractExprFieldFn fn) (field contractExprFieldArg arg)])
|
|
|
|
cApply = (arg fn : cCall fn arg)
|
|
|
|
cRequire = (view expr :
|
|
record contractExprTagRequire
|
|
[(field contractExprFieldExpr expr) (field contractExprFieldRequired view)])
|
|
|
|
cCompiledSymbol = fst
|
|
cCompiledNext = (compiled : fst (snd compiled))
|
|
cCompiledNodes = (compiled : snd (snd compiled))
|
|
cCompiled = (symbol next nodes : pair symbol (pair next nodes))
|
|
|
|
cCompile_ self base expr =
|
|
let tag = recordTag expr in
|
|
let fields = recordFields expr in
|
|
lazyBool
|
|
(_ :
|
|
cCompiled
|
|
base
|
|
(succ base)
|
|
[(typedValue base (field0 fields) t)])
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
cCompiled
|
|
base
|
|
(succ base)
|
|
[(typedDeclareFn base (field0 fields) (field1 fields) t)])
|
|
(_ :
|
|
lazyBool
|
|
(_ :
|
|
let fnCompiled = self base (field0 fields) in
|
|
let argCompiled = self (cCompiledNext fnCompiled) (field1 fields) in
|
|
let outSym = cCompiledNext argCompiled in
|
|
cCompiled
|
|
outSym
|
|
(succ outSym)
|
|
(append
|
|
(cCompiledNodes fnCompiled)
|
|
(append
|
|
(cCompiledNodes argCompiled)
|
|
[(typedApply outSym (cCompiledSymbol fnCompiled) (cCompiledSymbol argCompiled) t)])))
|
|
(_ :
|
|
let innerCompiled = self base (field0 fields) in
|
|
cCompiled
|
|
(cCompiledSymbol innerCompiled)
|
|
(cCompiledNext innerCompiled)
|
|
(append
|
|
(cCompiledNodes innerCompiled)
|
|
[(typedRequire (cCompiledSymbol innerCompiled) (field1 fields) t)]))
|
|
(equal? tag contractExprTagCall))
|
|
(equal? tag contractExprTagFn))
|
|
(equal? tag contractExprTagValue)
|
|
|
|
cCompile = (base expr : y cCompile_ base expr)
|
|
|
|
cCompileAt = (base expr :
|
|
let compiled = cCompile base expr in
|
|
typedProgram (cCompiledSymbol compiled) (cCompiledNodes compiled))
|
|
|
|
typedContractCheck = (program :
|
|
viewContractExpectResult "ok" (checkTypedProgram program))
|
|
|
|
viewContractSelfTests = [
|
|
(viewContractProbe (wellFormedView? viewAny))
|
|
(viewContractProbe (wellFormedView? (viewRef 10)))
|
|
(viewContractProbe (wellFormedView? (viewList viewBool)))
|
|
(viewContractProbe (wellFormedView? (viewMaybe viewString)))
|
|
(viewContractProbe (wellFormedView? (viewPair viewBool viewString)))
|
|
(viewContractProbe (wellFormedView? (viewResult viewString viewBool)))
|
|
(viewContractProbe (wellFormedView? (viewGuarded viewString (x : x))))
|
|
(viewContractProbe (equal? (renderView viewBool) "Bool"))
|
|
(viewContractProbe (equal? (renderView (viewList viewBool)) "List Bool"))
|
|
(viewContractProbe (equal? (renderView (viewMaybe viewString)) "Maybe String"))
|
|
(viewContractProbe (equal? (renderView (viewPair viewBool viewString)) "Pair Bool String"))
|
|
(viewContractProbe (equal? (renderView (viewResult viewString viewBool)) "Result String Bool"))
|
|
(viewContractProbe (equal? (renderView (viewGuarded viewString (x : x))) "Guarded String"))
|
|
(viewContractProbe (equal? (renderView (viewFn [(viewBool) (viewString)] viewUnit)) "Fn [Bool, String] Unit"))
|
|
(viewContractProbe (not? (wellFormedView? 10)))
|
|
(viewContractProbe (not? (wellFormedView? (record viewTagList [(field 99 viewBool)]))))
|
|
(viewContractExpectResult
|
|
"ok"
|
|
(checkTypedProgram
|
|
(typedProgram
|
|
0
|
|
[(typedValue 0 viewBool t)
|
|
(typedRequire 0 viewBool t)])))
|
|
(viewContractExpectResult
|
|
"ok"
|
|
(checkTypedProgram
|
|
(typedProgram
|
|
2
|
|
[(typedValue 0 (viewFn [(viewBool)] viewString) t)
|
|
(typedValue 1 viewBool t)
|
|
(typedApply 2 0 1 t)
|
|
(typedRequire 2 viewString t)])))
|
|
(typedContractCheck (typedUseUnary viewBool viewString 20 21 22))
|
|
(typedContractCheck (typedUseBinary viewBool viewString viewUnit 30 31 32 33 34))
|
|
(typedContractCheck (typedUseTernary viewBool viewString viewByte viewUnit 40 41 42 43 44 45 46))
|
|
(typedContractCheck
|
|
(cCompileAt
|
|
50
|
|
(cRequire viewString (cApply (cValue viewBool) (cFn [(viewBool)] viewString)))))
|
|
(typedContractCheck
|
|
(cCompileAt
|
|
60
|
|
(cRequire
|
|
(viewList viewString)
|
|
(cApply
|
|
(cValue (viewList viewBool))
|
|
(cApply
|
|
(cFn [(viewBool)] viewString)
|
|
(cFn [(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)))))))
|
|
(viewContractExpectResult
|
|
"function argument view is not known"
|
|
(checkTypedProgramWith
|
|
policyStrict
|
|
(typedProgram
|
|
2
|
|
[(typedValue 0 (viewFn [(viewBool)] viewString) t)
|
|
(typedApply 2 0 1 t)])))
|
|
(viewContractExpectResult
|
|
"ok"
|
|
(checkTypedProgramWith
|
|
policyGradual
|
|
(typedProgram
|
|
0
|
|
[(typedRequire 0 viewBool t)])))
|
|
(viewContractExpectResult
|
|
"malformed view program"
|
|
(checkTypedProgram (record 99 t)))
|
|
(viewContractExpectResult
|
|
"ok"
|
|
(checkTypedProgram
|
|
(typedProgram
|
|
2
|
|
[(typedValue 0 (viewFn [(viewBool)] viewString) t)
|
|
(typedValue 1 viewBool t)
|
|
(typedApply 2 0 1 (t t))
|
|
(typedRequire 2 viewString (t t))])))
|
|
(viewContractProbe
|
|
(equal?
|
|
(checkedProgramTree
|
|
(checkTypedProgram
|
|
(typedProgram
|
|
2
|
|
[(typedValue 0 (viewFn [(viewBool)] viewString) t)
|
|
(typedValue 1 viewBool t)
|
|
(typedApply 2 0 1 (t t))
|
|
(typedRequire 2 viewString (t t))])))
|
|
(t t)))
|
|
(viewContractExpectErrorTag
|
|
errorTagMissingFunctionArgumentView
|
|
(checkTypedProgramWith
|
|
policyStrict
|
|
(typedProgram
|
|
2
|
|
[(typedValue 0 (viewFn [(viewBool)] viewString) t)
|
|
(typedApply 2 0 1 (t t))])))
|
|
(viewContractExpectErrorTag
|
|
errorTagMalformedProgram
|
|
(checkTypedProgram
|
|
(typedProgram 0 [(record typedNodeTagValue t)])))
|
|
(viewContractExpectErrorTag
|
|
errorTagMalformedPolicy
|
|
(checkTypedProgramWith (pair 99 t) (typedProgram 0 t)))
|
|
(viewContractExpectErrorTag
|
|
errorTagMalformedProgram
|
|
(checkTypedProgram (record 99 t)))]
|