James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Useful but limited polymorphism

Browse Source
This commit is contained in:
James Eversole
2026-05-25 17:54:04 -05:00
parent fdebb6c13d
commit a4fcc1cb36
18 changed files with 1781 additions and 130 deletions
Download Patch File Download Diff File Expand all files Collapse all files

341
lib/view.tri
View File

@@ -64,6 +64,9 @@ viewTagMaybe = 4
viewTagPair = 5
viewTagResult = 6
viewTagGuarded = 7
viewTagVar = 8
viewTagForall = 9
viewTagExists = 10
viewFieldArgs = 0
viewFieldResult = 1
viewFieldRef = 2
@@ -74,6 +77,9 @@ viewFieldErr = 6
viewFieldOk = 7
viewFieldBase = 8
viewFieldGuard = 9
viewFieldVar = 10
viewFieldBinders = 11
viewFieldBody = 12
-- Evidence tags
evidenceTagTrusted = 0
@@ -181,6 +187,11 @@ 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.
@@ -227,6 +238,11 @@ 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
@@ -247,8 +263,14 @@ 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
@@ -313,6 +335,12 @@ wellFormedResultView? = (view :
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)
@@ -354,7 +382,23 @@ wellFormedView_ self view =
(_ : self (guardedViewBase view))
(_ : false)
(wellFormedGuardedView? view))
(_ : false)
(_ :
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)))
@@ -469,6 +513,28 @@ hasView? = (symbol view env :
(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)
@@ -491,19 +557,44 @@ extendEnv_ self symbol view evidence env =
extendEnv = (symbol view evidence env :
y extendEnv_ symbol view evidence env)
findFnView_ self viewSet =
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 :
let view = viewFactView fact in
lazyBool
(_ : just view)
lazyMaybe
(_ : self rest)
(fnView? view))
(fnView : just fnView)
(viewAsFn namespace (viewFactView fact)))
viewSet
findFnView = (viewSet :
y findFnView_ viewSet)
findFnView = (namespace viewSet :
y findFnView_ namespace viewSet)
firstKnownView = (viewSet :
lazyList
@@ -517,6 +608,156 @@ actualViewFor = (symbol env :
(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)
@@ -548,15 +789,26 @@ 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))
let actualView = instantiateView argSymbol (actualViewFor argSymbol env) in
lazyMaybe
(_ :
lazyResult
(diag envAtError : err diag envAtError)
(nextEnv _ : checkerOk (extendEnv outSymbol resultView evidenceTagInferred nextEnv))
(nextEnv _ : checkerOk (extendEnv outSymbol (fnResidual restArgs (fnResult fnView)) evidenceTagInferred nextEnv))
(missingArgumentOrGuardedBase policy argSymbol argView env))
(hasView? 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))
-- ---------------------------------------------------------------------------
@@ -571,6 +823,13 @@ typedProgram = (root 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)
@@ -584,6 +843,13 @@ typedApply = (symbol callee arg term :
(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)
@@ -597,11 +863,23 @@ 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)
(fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm))
(wellFormedTypedViewFactFields? (recordFields node)))
wellFormedTypedApply? = (node :
fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldCallee typedNodeFieldArg)
@@ -619,7 +897,7 @@ wellFormedTypedRequire? = (node :
lazyBool
(_ : wellFormedView? (typedNodeView node))
(_ : false)
(fields3? (recordFields node) typedNodeFieldSymbol typedNodeFieldView typedNodeFieldTerm))
(wellFormedTypedViewFactFields? (recordFields node)))
wellFormedTypedNode? = (node :
let tag = recordTag node in
@@ -686,7 +964,7 @@ checkTypedRequireNode = (policy node env :
(hasView? symbol (guardedViewBase view) env))
(_ : missingRequiredView policy symbol view env)
(guardedView? view))
(hasView? symbol view env))
(hasCompatibleView? symbol view env))
missingArgumentOrGuardedBase = (policy symbol view env :
lazyBool
@@ -705,7 +983,7 @@ checkTypedApplyNode = (policy node env :
lazyMaybe
(_ : checkerOk env)
(fnView : checkApplicationSymbols policy (typedApplyArg node) (typedNodeSymbol node) env fnView)
(findFnView calleeViews))
(findFnView (typedApplyCallee node) calleeViews))
(lookupViews (typedApplyCallee node) env))
checkTypedNode = (policy node env :
@@ -1111,6 +1389,18 @@ renderViewArgs_ self viewSelf views =
(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")
@@ -1162,7 +1452,19 @@ renderView_ self view =
(_ :
lazyBool
(_ : append "Guarded " (self (guardedViewBase view)))
(_ : "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))
@@ -1460,12 +1762,15 @@ viewContractSelfTests = [
(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)]))))