268 lines
9.6 KiB
Plaintext
268 lines
9.6 KiB
Plaintext
!import "prelude" !Local
|
|
!import "view" !Local
|
|
|
|
-- Stdlib-shaped typed-program catalog. These helpers are stable lowering
|
|
-- targets for frontend-emitted API contracts. They are monomorphic
|
|
-- instantiations of familiar polymorphic shapes.
|
|
listMapUseContract = (elemIn elemOut mapSym fnSym xsSym partialSym outSym :
|
|
typedProgram
|
|
outSym
|
|
[(typedDeclareFn
|
|
mapSym
|
|
[(viewFn [(elemIn)] elemOut) (viewList elemIn)]
|
|
(viewList elemOut)
|
|
t)
|
|
(typedDeclareFn fnSym [(elemIn)] elemOut t)
|
|
(typedValue xsSym (viewList elemIn) t)
|
|
(typedApply partialSym mapSym fnSym t)
|
|
(typedApply outSym partialSym xsSym t)
|
|
(typedRequire outSym (viewList elemOut) t)])
|
|
|
|
headMaybeUseContract = (elem headSym xsSym outSym :
|
|
typedProgram
|
|
outSym
|
|
[(typedDeclareFn headSym [(viewList elem)] (viewMaybe elem) t)
|
|
(typedValue xsSym (viewList elem) t)
|
|
(typedApply outSym headSym xsSym t)
|
|
(typedRequire outSym (viewMaybe elem) t)])
|
|
|
|
listFilterUseContract = (elem filterSym predSym xsSym partialSym outSym :
|
|
typedProgram
|
|
outSym
|
|
[(typedDeclareFn
|
|
filterSym
|
|
[(viewFn [(elem)] viewBool) (viewList elem)]
|
|
(viewList elem)
|
|
t)
|
|
(typedDeclareFn predSym [(elem)] viewBool t)
|
|
(typedValue xsSym (viewList elem) t)
|
|
(typedApply partialSym filterSym predSym t)
|
|
(typedApply outSym partialSym xsSym t)
|
|
(typedRequire outSym (viewList elem) t)])
|
|
|
|
listFoldUseContract = (acc elem foldSym fnSym initSym xsSym partialFnSym partialInitSym outSym :
|
|
typedProgram
|
|
outSym
|
|
[(typedDeclareFn
|
|
foldSym
|
|
[(viewFn [(acc) (elem)] acc) acc (viewList elem)]
|
|
acc
|
|
t)
|
|
(typedDeclareFn fnSym [(acc) (elem)] acc t)
|
|
(typedValue initSym acc t)
|
|
(typedValue xsSym (viewList elem) t)
|
|
(typedApply partialFnSym foldSym fnSym t)
|
|
(typedApply partialInitSym partialFnSym initSym t)
|
|
(typedApply outSym partialInitSym xsSym t)
|
|
(typedRequire outSym acc t)])
|
|
|
|
listMapMaybeUseContract = (elemIn elemOut mapMaybeSym fnSym xsSym partialSym outSym :
|
|
typedProgram
|
|
outSym
|
|
[(typedDeclareFn
|
|
mapMaybeSym
|
|
[(viewFn [(elemIn)] (viewMaybe elemOut)) (viewList elemIn)]
|
|
(viewList elemOut)
|
|
t)
|
|
(typedDeclareFn fnSym [(elemIn)] (viewMaybe elemOut) t)
|
|
(typedValue xsSym (viewList elemIn) t)
|
|
(typedApply partialSym mapMaybeSym fnSym t)
|
|
(typedApply outSym partialSym xsSym t)
|
|
(typedRequire outSym (viewList elemOut) t)])
|
|
|
|
-- Concrete stdlib-shaped typed programs. These are deliberately monomorphic
|
|
-- examples of the shapes a frontend can emit for polymorphic library functions.
|
|
listMapBoolStringExpr = cFn <|
|
|
[(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)
|
|
|> cApply (cFn [(viewBool)] viewString)
|
|
|> cApply (cValue (viewList viewBool))
|
|
|> cRequire (viewList viewString)
|
|
|
|
headMaybeBoolExpr = cFn <|
|
|
[(viewList viewBool)] (viewMaybe viewBool)
|
|
|> cApply (cValue (viewList viewBool))
|
|
|> cRequire (viewMaybe viewBool)
|
|
|
|
listFilterBoolExpr = cFn <|
|
|
[(viewFn [(viewBool)] viewBool) (viewList viewBool)] (viewList viewBool)
|
|
|> cApply (cFn [(viewBool)] viewBool)
|
|
|> cApply (cValue (viewList viewBool))
|
|
|> cRequire (viewList viewBool)
|
|
|
|
listFoldStringBoolExpr = cFn <|
|
|
[(viewFn [(viewString) (viewBool)] viewString) viewString (viewList viewBool)] viewString
|
|
|> cApply (cFn [(viewString) (viewBool)] viewString)
|
|
|> cApply (cValue viewString)
|
|
|> cApply (cValue (viewList viewBool))
|
|
|> cRequire viewString
|
|
|
|
listMapMaybeBoolStringExpr = cFn <|
|
|
[(viewFn [(viewBool)] (viewMaybe viewString)) (viewList viewBool)] (viewList viewString)
|
|
|> cApply (cFn [(viewBool)] (viewMaybe viewString))
|
|
|> cApply (cValue (viewList viewBool))
|
|
|> cRequire (viewList viewString)
|
|
|
|
-- Keep catalog exports as explicit finite typed-programs. `cCompileAt` is useful
|
|
-- as a frontend-emission helper, but forcing generated node lists at module
|
|
-- import time can violate top-level normalization discipline.
|
|
listMapBoolStringContract =
|
|
listMapUseContract viewBool viewString 100 101 102 103 104
|
|
headMaybeBoolContract =
|
|
headMaybeUseContract viewBool 110 111 112
|
|
listFilterBoolContract =
|
|
listFilterUseContract viewBool 120 121 122 123 124
|
|
listFoldStringBoolContract =
|
|
listFoldUseContract viewString viewBool 130 131 132 133 134 135 136
|
|
listMapMaybeBoolStringContract =
|
|
listMapMaybeUseContract viewBool viewString 140 141 142 143 144
|
|
|
|
listMapWrongFunctionArgContract =
|
|
typedProgram
|
|
152
|
|
[(typedDeclareFn
|
|
150
|
|
[(viewFn [(viewBool)] viewString) (viewList viewBool)]
|
|
(viewList viewString)
|
|
t)
|
|
(typedDeclareFn 151 [(viewString)] viewString t)
|
|
(typedApply 152 150 151 t)]
|
|
|
|
listMapWrongListArgContract =
|
|
typedProgram
|
|
164
|
|
[(typedDeclareFn
|
|
160
|
|
[(viewFn [(viewBool)] viewString) (viewList viewBool)]
|
|
(viewList viewString)
|
|
t)
|
|
(typedDeclareFn 161 [(viewBool)] viewString t)
|
|
(typedValue 162 (viewList viewString) t)
|
|
(typedApply 163 160 161 t)
|
|
(typedApply 164 163 162 t)]
|
|
|
|
listMapWrongOutputContract =
|
|
typedProgram
|
|
174
|
|
[(typedDeclareFn
|
|
170
|
|
[(viewFn [(viewBool)] viewString) (viewList viewBool)]
|
|
(viewList viewString)
|
|
t)
|
|
(typedDeclareFn 171 [(viewBool)] viewString t)
|
|
(typedValue 172 (viewList viewBool) t)
|
|
(typedApply 173 170 171 t)
|
|
(typedApply 174 173 172 t)
|
|
(typedRequire 174 (viewList viewBool) t)]
|
|
|
|
listFilterWrongPredicateContract =
|
|
typedProgram
|
|
182
|
|
[(typedDeclareFn
|
|
180
|
|
[(viewFn [(viewBool)] viewBool) (viewList viewBool)]
|
|
(viewList viewBool)
|
|
t)
|
|
(typedDeclareFn 181 [(viewBool)] viewString t)
|
|
(typedApply 182 180 181 t)]
|
|
|
|
listMapWrongListArgExpr = cFn <|
|
|
[(viewFn [(viewBool)] viewString) (viewList viewBool)] (viewList viewString)
|
|
|> cApply (cFn [(viewBool)] viewString)
|
|
|> cApply (cValue (viewList viewString))
|
|
|> cRequire (viewList viewString)
|
|
|
|
listMapWrongListArgExprContract =
|
|
typedProgram
|
|
194
|
|
[(typedDeclareFn
|
|
190
|
|
[(viewFn [(viewBool)] viewString) (viewList viewBool)]
|
|
(viewList viewString)
|
|
t)
|
|
(typedDeclareFn 191 [(viewBool)] viewString t)
|
|
(typedValue 193 (viewList viewString) t)
|
|
(typedApply 192 190 191 t)
|
|
(typedApply 194 192 193 t)
|
|
(typedRequire 194 (viewList viewString) t)]
|
|
|
|
viewCatalogSelfTests =
|
|
append
|
|
viewContractSelfTests
|
|
[ (typedContractCheck listMapBoolStringContract)
|
|
(typedContractCheck headMaybeBoolContract)
|
|
(typedContractCheck listFilterBoolContract)
|
|
(typedContractCheck listFoldStringBoolContract)
|
|
(typedContractCheck listMapMaybeBoolStringContract)
|
|
(viewContractExpectResult
|
|
"function argument view is not known"
|
|
(checkTypedProgramWith policyStrict listMapWrongFunctionArgContract))
|
|
(viewContractExpectResult
|
|
"function argument view is not known"
|
|
(checkTypedProgramWith policyStrict listMapWrongListArgContract))
|
|
(viewContractExpectResult
|
|
"required view is not known"
|
|
(checkTypedProgramWith policyStrict listMapWrongOutputContract))
|
|
(viewContractExpectResult
|
|
"function argument view is not known"
|
|
(checkTypedProgramWith policyStrict listFilterWrongPredicateContract))
|
|
(viewContractExpectResult
|
|
"function argument view is not known"
|
|
(checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
|
|
(viewContractExpectErrorTag
|
|
errorTagOk
|
|
(checkTypedProgram listMapBoolStringContract))
|
|
(viewContractExpectErrorTag
|
|
errorTagMissingFunctionArgumentView
|
|
(checkTypedProgramWith policyStrict listMapWrongFunctionArgContract))
|
|
(viewContractExpectErrorTag
|
|
errorTagMissingFunctionArgumentView
|
|
(checkTypedProgramWith policyStrict listMapWrongListArgContract))
|
|
(viewContractExpectErrorTag
|
|
errorTagMissingFunctionArgumentView
|
|
(checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
|
|
(viewContractExpectErrorTag
|
|
errorTagMissingRequiredView
|
|
(checkTypedProgramWith policyStrict listMapWrongOutputContract))
|
|
(viewContractExpectDiagnostic
|
|
errorTagMissingFunctionArgumentView
|
|
162
|
|
(viewList viewBool)
|
|
(checkTypedProgramWith policyStrict listMapWrongListArgContract))
|
|
(viewContractExpectDiagnostic
|
|
errorTagMissingRequiredView
|
|
174
|
|
(viewList viewBool)
|
|
(checkTypedProgramWith policyStrict listMapWrongOutputContract))
|
|
(viewContractExpectDiagnosticActual
|
|
errorTagMissingFunctionArgumentView
|
|
162
|
|
(viewList viewBool)
|
|
(viewList viewString)
|
|
(checkTypedProgramWith policyStrict listMapWrongListArgContract))
|
|
(viewContractExpectDiagnosticActual
|
|
errorTagMissingFunctionArgumentView
|
|
193
|
|
(viewList viewBool)
|
|
(viewList viewString)
|
|
(checkTypedProgramWith policyStrict listMapWrongListArgExprContract))
|
|
(viewContractExpectDiagnosticActual
|
|
errorTagMissingRequiredView
|
|
174
|
|
(viewList viewBool)
|
|
(viewList viewString)
|
|
(checkTypedProgramWith policyStrict listMapWrongOutputContract))
|
|
(viewContractExpectDiagnosticActual
|
|
errorTagMissingFunctionArgumentView
|
|
181
|
|
(viewFn [(viewBool)] viewBool)
|
|
(viewFn [(viewBool)] viewString)
|
|
(checkTypedProgramWith policyStrict listFilterWrongPredicateContract))
|
|
(matchResult
|
|
(diag env :
|
|
viewContractProbe
|
|
(equal?
|
|
(renderDiagnostic diag)
|
|
"symbol 162 expected List Bool but got List String"))
|
|
(env rest : "fail")
|
|
(checkTypedProgramWith policyStrict listMapWrongListArgContract))]
|