Back out the worst of the unsound nonsense
This commit is contained in:
251
lib/view.tri
251
lib/view.tri
@@ -335,11 +335,12 @@ wellFormedResultView? = (view :
|
||||
wellFormedGuardedView? = (view :
|
||||
fields2? (viewPayload view) viewFieldBase viewFieldGuard)
|
||||
|
||||
wellFormedVarView? = (view :
|
||||
fields1? (viewPayload view) viewFieldVar)
|
||||
-- Tags 8-10 remain reserved so old artifacts decode deterministically, but
|
||||
-- quantified/variable Views are no longer accepted by the checker. They
|
||||
-- implied abstraction and parametricity that raw Tree Calculus cannot enforce.
|
||||
wellFormedVarView? = (_ : false)
|
||||
|
||||
wellFormedQuantifiedView? = (view :
|
||||
fields2? (viewPayload view) viewFieldBinders viewFieldBody)
|
||||
wellFormedQuantifiedView? = (_ : false)
|
||||
|
||||
wellFormedView_ self view =
|
||||
lazyBool
|
||||
@@ -513,28 +514,6 @@ 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)
|
||||
@@ -557,44 +536,19 @@ extendEnv_ self symbol view evidence 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 =
|
||||
findFnView_ self viewSet =
|
||||
lazyList
|
||||
(_ : nothing)
|
||||
(fact rest :
|
||||
lazyMaybe
|
||||
let view = viewFactView fact in
|
||||
lazyBool
|
||||
(_ : just view)
|
||||
(_ : self rest)
|
||||
(fnView : just fnView)
|
||||
(viewAsFn namespace (viewFactView fact)))
|
||||
(fnView? view))
|
||||
viewSet
|
||||
|
||||
findFnView = (namespace viewSet :
|
||||
y findFnView_ namespace viewSet)
|
||||
findFnView = (viewSet :
|
||||
y findFnView_ viewSet)
|
||||
|
||||
firstKnownView = (viewSet :
|
||||
lazyList
|
||||
@@ -607,157 +561,6 @@ actualViewFor = (symbol env :
|
||||
(_ : 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)
|
||||
|
||||
@@ -789,28 +592,16 @@ checkApplicationSymbols = (policy argSymbol outSymbol env fnView :
|
||||
lazyList
|
||||
(_ : checkerErr errorTagZeroArityFunction t env)
|
||||
(argView restArgs :
|
||||
let actualView = instantiateView argSymbol (actualViewFor argSymbol env) in
|
||||
lazyMaybe
|
||||
let resultView = fnResidual restArgs (fnResult fnView) in
|
||||
lazyBool
|
||||
(_ : checkerOk (extendEnv outSymbol resultView evidenceTagInferred env))
|
||||
(_ :
|
||||
lazyResult
|
||||
(diag envAtError : err diag envAtError)
|
||||
(nextEnv _ : checkerOk (extendEnv outSymbol (fnResidual restArgs (fnResult fnView)) evidenceTagInferred nextEnv))
|
||||
(nextEnv _ : checkerOk (extendEnv outSymbol resultView 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))
|
||||
(hasView? argSymbol argView env))
|
||||
(fnArgs fnView))
|
||||
|
||||
-- ---------------------------------------------------------------------------
|
||||
-- View-tree checker artifact
|
||||
-- ---------------------------------------------------------------------------
|
||||
@@ -964,7 +755,7 @@ checkTypedRequireNode = (policy node env :
|
||||
(hasView? symbol (guardedViewBase view) env))
|
||||
(_ : missingRequiredView policy symbol view env)
|
||||
(guardedView? view))
|
||||
(hasCompatibleView? symbol view env))
|
||||
(hasView? symbol view env))
|
||||
|
||||
missingArgumentOrGuardedBase = (policy symbol view env :
|
||||
lazyBool
|
||||
@@ -983,7 +774,7 @@ checkTypedApplyNode = (policy node env :
|
||||
lazyMaybe
|
||||
(_ : checkerOk env)
|
||||
(fnView : checkApplicationSymbols policy (typedApplyArg node) (typedNodeSymbol node) env fnView)
|
||||
(findFnView (typedApplyCallee node) calleeViews))
|
||||
(findFnView calleeViews))
|
||||
(lookupViews (typedApplyCallee node) env))
|
||||
|
||||
checkTypedNode = (policy node env :
|
||||
@@ -1762,8 +1553,8 @@ 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 (not? (wellFormedView? (viewVar 0))))
|
||||
(viewContractProbe (not? (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"))
|
||||
|
||||
Reference in New Issue
Block a user