Tricu 2.0.0

Sorry for squashing all of this but 🤷

lib/arboricx/arboricx.tri

@@ -1,4 +1,7 @@
-!import "manifest.tri" !Local
+!import "prelude"           !Local
+!import "arboricx.common"   !Local
+!import "arboricx.manifest" !Local
+!import "arboricx.nodes"    !Local
 
 -- Read and validate a full Arboricx bundle.
 -- Returns (pair validManifest afterContainer).

lib/arboricx/common.tri

@@ -1,6 +1,6 @@
-!import "../prelude.tri" !Local
-!import "../bytes.tri"   !Local
-!import "../binary.tri"  !Local
+!import "prelude" !Local
+!import "binary"  !Local
+
 
 arboricxMagic = [(65) (82) (66) (79) (82) (73) (67) (88)]
 arboricxMajorVersion = [(0) (1)]

lib/arboricx/dispatch.tri

@@ -1,4 +1,5 @@
-!import "arboricx.tri" !Local
+!import "prelude"  !Local
+!import "arboricx" !Local
 
 -- Multi-purpose kernel dispatch.
 -- runArboricxTyped tag bundleBytes args

lib/arboricx/manifest.tri

@@ -1,4 +1,7 @@
-!import "nodes.tri" !Local
+!import "prelude"         !Local
+!import "binary"          !Local
+!import "arboricx.common" !Local
+!import "arboricx.nodes"  !Local
 
 readManifestMagic = (bs :
   expectBytes arboricxManifestMagic bs)

lib/arboricx/nodes.tri

@@ -1,4 +1,6 @@
-!import "common.tri" !Local
+!import "prelude"         !Local
+!import "binary"          !Local
+!import "arboricx.common" !Local
 
 -- Indexed Arboricx node section reader.
 --

lib/arboricx/server.tri

@@ -1,8 +1,9 @@
-!import "../io.tri"        !Local
-!import "../http.tri"      !Local
-!import "../socket.tri"    !Local
-!import "../patterns.tri"  !Local
-!import "arboricx.tri"     !Local
+!import "prelude"  !Local
+!import "io"       !Local
+!import "http"     !Local
+!import "socket"   !Local
+!import "patterns" !Local
+!import "arboricx" !Local
 
 -- ---------------------------------------------------------------------------
 -- Store layout helpers

lib/binary.tri

@@ -1,6 +1,4 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
-!import "bytes.tri" !Local
+!import "prelude" !Local
 
 errUnexpectedEof = 1
 errUnexpectedBytes = 2

lib/bytes.tri

@@ -1,5 +1,5 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
+!import "base" !Local
+!import "list" !Local
 
 bytesNil? = emptyList?
 

lib/conversions.tri

@@ -1,5 +1,5 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
+!import "base" !Local
+!import "list" !Local
 
 incDecRev = y (self : matchList
   "1"

lib/http.tri

@@ -1,6 +1,7 @@
-!import "prelude.tri"     !Local
-!import "io.tri"          !Local
-!import "socket.tri"      !Local
+!import "prelude"  !Local
+!import "io"       !Local
+!import "patterns" !Local
+!import "socket"   !Local
 
 -- ---------------------------------------------------------------------------
 --  Constants

lib/io.tri

@@ -1,6 +1,5 @@
-!import "base.tri"        !Local
-!import "list.tri"        !Local
-!import "conversions.tri" !Local
+!import "prelude"  !Local
+!import "patterns" !Local
 
 -- IO constructors for host-interpreted interaction trees.
 -- Free-monad style: Bind is the single sequencing mechanism.

lib/lazy.tri

@@ -1,5 +1,5 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
+!import "base" !Local
+!import "list" !Local
 
 lazyBool = (thenK elseK cond :
   ((chosen : chosen t)

lib/list.tri

@@ -1,4 +1,4 @@
-!import "base.tri" !Local
+!import "base" !Local
 
 _ = t
 

lib/patterns.tri

@@ -1,6 +1,4 @@
-!import "base.tri" !Local
-!import "list.tri" !Local
-!import "lazy.tri" !Local
+!import "prelude" !Local
 
 match_ = y (self value patterns :
   triage

lib/prelude.tri

@@ -1,7 +1,7 @@
 -- Standard tricu prelude.
 
-!import "base.tri"        !Local
-!import "list.tri"        !Local
-!import "bytes.tri"       !Local
-!import "lazy.tri"        !Local
-!import "conversions.tri" !Local
+!import "base"        !Local
+!import "list"        !Local
+!import "bytes"       !Local
+!import "lazy"        !Local
+!import "conversions" !Local

lib/socket.tri

@@ -1,5 +1,5 @@
-!import "base.tri"      !Local
-!import "io.tri"        !Local
+!import "prelude" !Local
+!import "io"      !Local
 
 -- Socket primitives for the IO driver.
 --   ok value t  -- pair true (pair value t)

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))]