Tricu 2.0.0

Sorry for squashing all of this but 🤷

lib/views/catalog.tri

@@ -0,0 +1,267 @@
+!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))]