Make precedence lists printable

content-addressing.ss

@@ -58,11 +58,11 @@
  (digest<-bytes (read-file-u8vector path) digesting))
 
 ;; trait for digestability in a given content-addressing context
-(.def (Digestable @ [] .bytes<- .digesting)
+(define-type (Digestable @ [] .bytes<- .digesting)
  .digest<-: (lambda (v (digesting .digesting)) (digest<-bytes (.bytes<- v) digesting)))
 
 ;; Non-functor function
-(.def (DigestWrapper^ @ [])
+(define-type (DigestWrapper^ @ [])
  .tap: (lambda (t) (Digesting-Digest (.@ t .digesting)))
  .ap^: (cut .call <> .digest<- <>)
  .unap^: invalid
@@ -74,14 +74,14 @@
 ;; This allows you to define all your interfaces independently from which digest function will be used,
 ;; but a given poo interface should be used in one context only, they should be initialized together,
 ;; you may want to statically clone and override in some cases, etc.
-(.def (CurrentDigesting @ [Digestable])
+(define-type (CurrentDigesting @ [Digestable])
  .digesting: (current-content-addressing))
 
 ;; : Bytes <- Digest ?ContentAddressing
 (def (content-addressing-key digest (content-addressing (current-content-addressing)))
  (u8vector-append (ContentAddressing-key-prefix content-addressing) digest))
 
-(.def (ContentAddressable @ [] sexp .digesting .digest<- .<-bytes .bytes<-)
+(define-type (ContentAddressable @ [] sexp .digesting .digest<- .<-bytes .bytes<-)
  ;; CAVEAT EMPTOR: The application developers must ensure there are no collisions
  ;; with respect to sexp for types stored in a given content-addressable context.
  .content-cache: (make-hash-table weak-values: #t)
@@ -119,8 +119,7 @@
 (def (dv<-digest t d) (DV t (lazy (.call t .<-digest d)) (lazy d) #t))
 
 ;; ContentAddressed
-(.def (ContentAddressed. @ [ContentAddressable] T .digesting)
- sexp: `(ContentAddressed ,(.@ T sexp))
+(define-type (ContentAddressed. @ [ContentAddressable] T .digesting)
  Wrapper: {(:: @ [Wrapper.])
  .ap: (lambda (v) (dv T v))
  .unap: value<-dv}
@@ -152,7 +151,9 @@
  (make-dependencies-persistent T v tx)
  (db-put! k (bytes<- T v) tx)))))))
 
-(def (ContentAddressed t) {(:: @ ContentAddressed.) t})
+(def (ContentAddressed T)
+ {(:: @ ContentAddressed.) T
+ sexp: `(ContentAddressed ,(.@ T sexp))})
 
 (def (digest<-marshal marshal (digesting (current-content-addressing)))
  (digest<-bytes (call-with-output-u8vector marshal) digesting))

merkle-trie.ss

@@ -13,8 +13,7 @@
 ;; TODO: support remember the current skip info in DigestedTrie, so you can properly simulate
 ;; .make-branch and .make-skip when re-digesting a trie with a leaf removed.
 
-(.def (DigestedTrie. @ [Trie.] Key Height Value .digesting T Step .wrap)
- sexp: `(DigestedTrie ,(.@ Key sexp) ,(.@ Height sexp) ,(.@ Value sexp) ,(Digesting-sexp .digesting))
+(define-type (DigestedTrie. @ [Trie.] Key Height Value .digesting T Step .wrap)
  Digest: (Digesting-Digest .digesting)
  .validate: (.@ Digest .validate)
  .sexp<-: (.@ Digest .sexp<-)
@@ -34,34 +33,36 @@
  .up: (let (up (.@ Unstep .up)) (lambda (t path) (.op up t path)))})
 
 (def (DigestedTrie Key Height Value .digesting)
- {(:: @ DigestedTrie.) Key Height Value .digesting})
+ {(:: @ DigestedTrie.) Key Height Value .digesting
+ sexp: `(DigestedTrie ,(.@ Key sexp) ,(.@ Height sexp)
+ ,(.@ Value sexp) ,(Digesting-sexp .digesting))})
 
-(.def (MerkleTrie. @ [ContentAddressed. Trie.]
- Key Height Value .wrap .unwrap .refocus .zipper<- Path
- .digesting .digest<-)
- sexp: `(MerkleTrie Key: ,(.@ Key sexp) Height: ,(.@ Height sexp) Value: ,(.@ Value sexp)
- Digesting: ,(Digesting-sexp .digesting))
- T: =>.+ { .walk-dependencies:
- (lambda (f t) (match t
- ((Empty) (void))
- ((Leaf v) (f Value v))
- ((Branch _ l r) (f @ l) (f @ r))
- ((Skip _ _ _ c) (f @ c)))) }
- Digested: {(:: @D [DigestedTrie.]) Key Height Value .digesting}
- .proof<-: (lambda (trie key)
+(define-type (MerkleTrie. @ [ContentAddressed. Trie.]
+ Key Height Value .wrap .unwrap .refocus .zipper<- Path
+ .digesting .digest<-)
+ T: =>.+ { .walk-dependencies:
+ (lambda (f t) (match t
+ ((Empty) (void))
+ ((Leaf v) (f Value v))
+ ((Branch _ l r) (f @ l) (f @ r))
+ ((Skip _ _ _ c) (f @ c)))) }
+ Digested: {(:: @D [DigestedTrie.]) Key Height Value .digesting}
+ .proof<-: (lambda (trie key)
  (match (.refocus ($Costep -1 key) (.zipper<- trie))
  ([sub . up] (cons sub (.call Path .map .digest<- up)))))
-  .validate-proof:
-  (lambda (trie-digest sub up)
-  (match (.unwrap sub)
-  ((Leaf v)
-  (validate Value v)
-  (let (digest (car ((.@ Digested Path .up) (.call Digested .leaf v) up)))
-  (unless (equal? trie-digest digest)
-  (let (D (Digesting-Digest .digesting))
-  (raise-type-error "Digest doesn't match: " D trie-digest D digest up)))))
-  ;; TODO: support negative proofs
-  (_ (raise-type-error "No leaf" sub up)))))
+ .validate-proof:
+ (lambda (trie-digest sub up)
+ (match (.unwrap sub)
+ ((Leaf v)
+ (validate Value v)
+ (let (digest (car ((.@ Digested Path .up) (.call Digested .leaf v) up)))
+ (unless (equal? trie-digest digest)
+ (let (D (Digesting-Digest .digesting))
+ (raise-type-error "Digest doesn't match: " D trie-digest D digest up)))))
+ ;; TODO: support negative proofs
+ (_ (raise-type-error "No leaf" sub up)))))
 (def (MerkleTrie Key: (Key Nat) Height: (Height Nat)
  Value: (Value Any) Digesting: (.digesting keccak-addressing))
- {(:: @ [MerkleTrie.]) Key Height Value .digesting})
+ {(:: @ [MerkleTrie.]) Key Height Value .digesting
+ sexp: `(MerkleTrie Key: ,(.@ Key sexp) Height: ,(.@ Height sexp) Value: ,(.@ Value sexp)
+ Digesting: ,(Digesting-sexp .digesting))})

persist.ss

@@ -22,17 +22,14 @@
 (.defgeneric (make-persistent type x tx)
  slot: .make-persistent default: void)
 
-(.def (Port @ Type.) sexp: 'Port .element?: port?)
-(.def (Thread @ Type.) sexp: 'Thread .element?: thread?)
-(.def (Completion @ Type.) sexp: 'Completion .element?: completion?)
+(define-type (Port @ Type.) .element?: port?)
+(define-type (Thread @ Type.) .element?: thread?)
+(define-type (Completion @ Type.) .element?: completion?)
 
-(.def (TX @ Type.)
- sexp: 'TX
- .element?: DbTransaction?)
+(define-type (TX @ Type.) .element?: DbTransaction?)
 
 ;; Persistent objects, whether passive data or activities.
-(.def (Persistent. @ Type.
- sexp ;; : Any
+(define-type (Persistent. @ Type.
  ;; Prefix for keys in database. In a relational DB, that would be the name of the table.
  key-prefix ;; : u8vector
  ;; Type descriptor for keys (to be serialized as DB key)
@@ -132,8 +129,8 @@
 ;; that will provide a transaction as a context to read of modify the data.
 ;; In case they may be borrowed, they must provide some mutual exclusion mechanism
 ;; that the borrowing activity will use to ensure data consistency.
-(.def (PersistentData @ Persistent.
- Key loaded resume-from-db db-key<- sexp)
+(define-type (PersistentData @ Persistent.
+  Key loaded resume-from-db db-key<-)
  ;; Read the object from its key, given a context.
  ;; For activities, this is an internal function that should only be called via get.
  ;; For passive data, this is a function that borrowers may use after they ensure mutual exclusion.
@@ -151,8 +148,8 @@
 ;; they may create transactions when they need to and borrow persistent data;
 ;; they may synchronize to I/O (including the DB) though outside transactions.
 ;; Activities communicate with each other using asynchronous messages.
-(.def (PersistentActivity @ Persistent.
- Key loaded resume-from-db db-key<- sexp)
+(define-type (PersistentActivity @ Persistent.
+  Key loaded resume-from-db db-key<-)
  ;; Get the activity by its key.
  ;; No transaction is provided: the activity will make its own if needed.
  <-key: (validate (Fun @ <- Key) .<-key)
@@ -176,12 +173,12 @@
  (accessor get-state set-state!)))))
 
 ;; Persistent actor that has a persistent queue
-(.def (PersistentQueueActor @ PersistentActivity
- Key State sexp <-key db-key<-
- ;; type of messages sent to the actor
- Message ;; : Type
- ;; function to process a message
- process) ;; : <- Message (State <-) (<- State) TX
+(define-type (PersistentQueueActor @ PersistentActivity
+  Key State sexp <-key db-key<-
+  ;; type of messages sent to the actor
+  Message ;; : Type
+  ;; function to process a message
+  process) ;; : <- Message (State <-) (<- State) TX
  .restore: ;; Provide the interface function declared above.
  (lambda (key save! state tx)
  (def name [sexp (sexp<- Key key)])
@@ -215,8 +212,8 @@
 ;; in case the process is halted before the message was fully processed.
 ;; Sometimes, you may have to pre-allocate a ticket/nonce/serial-number, save it,
 ;; so that you can feed the actor an idempotent message.
-(.def (PersistentActor @ [Thread PersistentActivity]
- Key State sexp <-key)
+(define-type (PersistentActor @ [Thread PersistentActivity]
+  Key State <-key)
  .restore: ;; Provide the interface function declared above.
  (lambda (key save! state tx)
  (def name [sexp (sexp<- Key key)])
@@ -278,7 +275,7 @@
  ((thread-specific (<-key key)))))
 
 ;; TODO: handle mixin inheritance graph so we can make this a mixin rather than an alternative superclass
-(.def (SavingDebug @ [] Key State sexp key-prefix)
+(define-type (SavingDebug @ [] Key State key-prefix)
  saving: =>
  (lambda (super)
  (fun (saving db-key state tx)
@@ -291,7 +288,7 @@
  ;;(printf "RESUME ~s ~s => ~s\n" sexp (sexp<- Key key) (sexp<- State state))
  (super key state tx))))
 
-(.def (DebugPersistentActivity @ [SavingDebug PersistentActivity]))
+(define-type (DebugPersistentActivity @ [SavingDebug PersistentActivity]))
 
 (def (ensure-db-key key)
  (cond