!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 viewTagVar = 8 viewTagForall = 9 viewTagExists = 10 viewFieldArgs = 0 viewFieldResult = 1 viewFieldRef = 2 viewFieldElem = 3 viewFieldLeft = 4 viewFieldRight = 5 viewFieldErr = 6 viewFieldOk = 7 viewFieldBase = 8 viewFieldGuard = 9 viewFieldVar = 10 viewFieldBinders = 11 viewFieldBody = 12 -- 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 typedNodeFieldProvenance = 5 viewProvenanceChecked = 0 viewProvenanceTrusted = 1 viewProvenanceUnchecked = 2 -- 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)] viewVar name = record viewTagVar [(field viewFieldVar name)] viewForall binders body = record viewTagForall [(field viewFieldBinders binders) (field viewFieldBody body)] viewExists binders body = record viewTagExists [(field viewFieldBinders binders) (field viewFieldBody body)] 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) varView? = (view : equal? (viewTag view) viewTagVar) forallView? = (view : equal? (viewTag view) viewTagForall) existsView? = (view : equal? (viewTag view) viewTagExists) guardedViewBase = (view : field0 (viewPayload view)) guardedViewGuard = (view : field1 (viewPayload view)) viewVarName = (view : field0 (viewPayload view)) viewBinderNames = (view : field0 (viewPayload view)) viewQuantifiedBody = (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) wellFormedVarView? = (view : fields1? (viewPayload view) viewFieldVar) wellFormedQuantifiedView? = (view : fields2? (viewPayload view) viewFieldBinders viewFieldBody) 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)) (_ : lazyBool (_ : wellFormedVarView? view) (_ : lazyBool (_ : lazyBool (_ : self (viewQuantifiedBody view)) (_ : false) (wellFormedQuantifiedView? view)) (_ : lazyBool (_ : self (viewQuantifiedBody view)) (_ : false) (wellFormedQuantifiedView? view)) (forallView? view)) (varView? view)) (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)) viewSetHasCompatible_ self namespace expected viewSet = lazyList (_ : false) (fact rest : lazyMaybe (_ : self namespace expected rest) (_ : true) (matchView expected (instantiateView namespace (viewFactView fact)) t)) viewSet viewSetHasCompatible? = (namespace expected viewSet : lazyBool (_ : true) (_ : y viewSetHasCompatible_ namespace expected viewSet) (anyView? expected)) hasCompatibleView? = (symbol view env : lazyMaybe (_ : anyView? view) (viewSet : viewSetHasCompatible? symbol 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) instantiateVarId = (namespace localId : pair namespace localId) instantiateBinders_ self namespace binders subst = lazyList (_ : subst) (binder rest : self namespace rest (pair (pair binder (viewVar (instantiateVarId namespace binder))) subst)) binders instantiateBinders = (namespace binders subst : y instantiateBinders_ namespace binders subst) instantiateView = (namespace view : lazyBool (_ : substituteView (instantiateBinders namespace (viewBinderNames view) t) (viewQuantifiedBody view)) (_ : view) (forallView? view)) viewAsFn = (namespace view : let instantiated = instantiateView namespace view in lazyBool (_ : just instantiated) (_ : nothing) (fnView? instantiated)) findFnView_ self namespace viewSet = lazyList (_ : nothing) (fact rest : lazyMaybe (_ : self rest) (fnView : just fnView) (viewAsFn namespace (viewFactView fact))) viewSet findFnView = (namespace viewSet : y findFnView_ namespace viewSet) firstKnownView = (viewSet : lazyList (_ : viewAny) (fact rest : viewFactView fact) viewSet) actualViewFor = (symbol env : lazyMaybe (_ : viewAny) (viewSet : firstKnownView viewSet) (lookupViews symbol env)) substLookup_ self name subst = lazyList (_ : nothing) (entry rest : lazyBool (_ : just (snd entry)) (_ : self name rest) (equal? name (fst entry))) subst substLookup = (name subst : y substLookup_ name subst) substBind = (name actual subst : lazyBool (_ : just subst) (_ : lazyBool (_ : just subst) (_ : lazyMaybe (_ : just (pair (pair name actual) subst)) (existing : lazyBool (_ : just subst) (_ : nothing) (equal? existing actual)) (substLookup name subst)) (varView? actual)) (equal? actual (viewVar name))) substituteView_ self subst view = lazyBool (_ : lazyMaybe (_ : view) (bound : self subst bound) (substLookup (viewVarName view) subst)) (_ : lazyBool (_ : viewFn (y substituteViews_ self subst (fnArgs view)) (self subst (fnResult view))) (_ : lazyBool (_ : viewList (self subst (field0 (viewPayload view)))) (_ : lazyBool (_ : viewMaybe (self subst (field0 (viewPayload view)))) (_ : lazyBool (_ : viewPair (self subst (field0 (viewPayload view))) (self subst (field1 (viewPayload view)))) (_ : lazyBool (_ : viewResult (self subst (field0 (viewPayload view))) (self subst (field1 (viewPayload view)))) (_ : lazyBool (_ : viewGuarded (self subst (guardedViewBase view)) (guardedViewGuard view)) (_ : view) (guardedView? view)) (resultView? view)) (pairView? view)) (maybeView? view)) (listView? view)) (fnView? view)) (varView? view) substituteViews_ self viewSelf subst views = lazyList (_ : t) (view rest : pair (viewSelf subst view) (self viewSelf subst rest)) views substituteView = (subst view : y substituteView_ subst view) matchViewList_ self matchSelf expected actual subst = lazyList (_ : lazyList (_ : just subst) (_ _ : nothing) actual) (expectedHead expectedRest : lazyList (_ : nothing) (actualHead actualRest : lazyMaybe (_ : nothing) (nextSubst : self matchSelf expectedRest actualRest nextSubst) (matchSelf expectedHead actualHead subst)) actual) expected matchView_ self expected actual subst = lazyBool (_ : just subst) (_ : lazyBool (_ : substBind (viewVarName expected) actual subst) (_ : lazyBool (_ : substBind (viewVarName actual) expected subst) (_ : lazyBool (_ : just subst) (_ : lazyBool (_ : lazyMaybe (_ : nothing) (argSubst : self (fnResult expected) (fnResult actual) argSubst) (y matchViewList_ self (fnArgs expected) (fnArgs actual) subst)) (_ : lazyBool (_ : self (field0 (viewPayload expected)) (field0 (viewPayload actual)) subst) (_ : lazyBool (_ : self (field0 (viewPayload expected)) (field0 (viewPayload actual)) subst) (_ : lazyBool (_ : lazyMaybe (_ : nothing) (leftSubst : self (field1 (viewPayload expected)) (field1 (viewPayload actual)) leftSubst) (self (field0 (viewPayload expected)) (field0 (viewPayload actual)) subst)) (_ : lazyBool (_ : lazyMaybe (_ : nothing) (errSubst : self (field1 (viewPayload expected)) (field1 (viewPayload actual)) errSubst) (self (field0 (viewPayload expected)) (field0 (viewPayload actual)) subst)) (_ : lazyBool (_ : self (guardedViewBase expected) actual subst) (_ : lazyBool (_ : self expected (guardedViewBase actual) subst) (_ : nothing) (guardedView? actual)) (guardedView? expected)) (and? (resultView? expected) (resultView? actual))) (and? (pairView? expected) (pairView? actual))) (and? (maybeView? expected) (maybeView? actual))) (and? (listView? expected) (listView? actual))) (and? (fnView? expected) (fnView? actual))) (equal? expected actual)) (varView? actual)) (varView? expected)) (anyView? expected) matchView = (expected actual subst : y matchView_ expected actual subst) 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 actualView = instantiateView argSymbol (actualViewFor argSymbol env) in lazyMaybe (_ : lazyResult (diag envAtError : err diag envAtError) (nextEnv _ : checkerOk (extendEnv outSymbol (fnResidual restArgs (fnResult fnView)) evidenceTagInferred nextEnv)) (missingArgumentOrGuardedBase policy argSymbol argView env)) (subst : let nextEnv = lazyBool (_ : extendEnv argSymbol argView evidenceTagRequired env) (_ : env) (guardedView? argView) in checkerOk (extendEnv outSymbol (substituteView subst (fnResidual restArgs (fnResult fnView))) evidenceTagInferred nextEnv)) (matchView argView actualView t)) (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)) typedValueWithProvenance = (symbol view term provenance : record typedNodeTagValue [(field typedNodeFieldSymbol symbol) (field typedNodeFieldView view) (field typedNodeFieldTerm term) (field typedNodeFieldProvenance provenance)]) 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)]) typedRequireWithProvenance = (symbol view term provenance : record typedNodeTagRequire [(field typedNodeFieldSymbol symbol) (field typedNodeFieldView view) (field typedNodeFieldTerm term) (field typedNodeFieldProvenance provenance)]) 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))))) wellFormedViewProvenance? = (provenance : or? (or? (equal? provenance viewProvenanceChecked) (equal? provenance viewProvenanceTrusted)) (equal? provenance viewProvenanceUnchecked)) wellFormedTypedViewFactFields? = (fields : or? (fields3? fields typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm) (and? (fields4? fields typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm typedNodeFieldProvenance) (wellFormedViewProvenance? (field3 fields)))) wellFormedTypedValue? = (node : lazyBool (_ : wellFormedView? (typedNodeView node)) (_ : false) (wellFormedTypedViewFactFields? (recordFields node))) 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) (wellFormedTypedViewFactFields? (recordFields node))) 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)) (hasCompatibleView? 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 (typedApplyCallee node) 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 renderBinders_ self binders = lazyList (_ : "") (binder rest : lazyBool (_ : binder) (_ : append binder (append ", " (self rest))) (emptyList? rest)) binders renderBinders = (binders : y renderBinders_ binders) 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))) (_ : lazyBool (_ : append "$" (showNumber (viewVarName view))) (_ : lazyBool (_ : append "forall [" (append (renderBinders (viewBinderNames view)) (append "] " (self (viewQuantifiedBody view)))) ) (_ : lazyBool (_ : append "exists [" (append (renderBinders (viewBinderNames view)) (append "] " (self (viewQuantifiedBody view)))) ) (_ : "View") (existsView? view)) (forallView? view)) (varView? 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 (wellFormedView? (viewVar 0))) (viewContractProbe (wellFormedView? (viewForall [(0)] (viewFn [(viewVar 0)] (viewVar 0))))) (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 (viewVar 0)) "$0")) (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)))]