pass-the-hash.rkt

#lang racket

(require (for-syntax syntax/parse
                     racket/syntax))

; I "needed" a distinct `none` value
(define none (string->uninterned-symbol "none"))
(define (none? x) (eq? none x))

;-----------------------------------------------------------------------------------
; return a new `hash-zipper` procedure, which allows for the access and modification
; of a hash table in a flat[ter], command-by-command style.
;-----------------------------------------
; head × [keys '()] × [path '()] -> zipper
(define (hash-zipper
         ; the "focus" of the zipper.
         head
         ; the `keys` which resolve to the value of `head` from the root of `path`.
         [keys '()]
         ; the hashes which contain the `keys` leading to `head`, from the root of `path`.
         [path '()])
  ;----------------------------------
  ; are we at the root of the zipper?
  (define (root?) (empty? path))
  ;-------------
  (match-lambda*
    ;-------------------
    ; return the `head`.
    ; *out of focus*.
    ;---------------
    ; zipper -> head
    ['(#:pop)  head]

    ;-------------------
    ; return the `keys`.
    ; *out of focus*.
    ;---------------
    ; zipper -> head
    ['(#:keys) keys]

    ;-------------------
    ; return the `path`.
    ; *out of focus*.
    ;---------------
    ; zipper -> head
    ['(#:path) path]

    ;-------------------------------------
    ; replace the `head` with a new value.
    ; *focused* on `head`.
    ;------------------------
    ; zipper × head -> zipper
    [`(#:put ,head)
     (hash-zipper head keys path)]

    ;--------------------------------------------------------------------------------------
    ; update the value for the most recent key in `keys` in the most recent hash in `path`,
    ; depending on the value of `choice`.
    ;-------------------------------------
    ; zipper × none | boolean -> error | zipper
    [`(#:push ,choice)
     (cond [(root?)
            (error 'hash-zipper
                   (string-append
                    "attempted to push `~a`\n"
                    "at the root of the zipper.")
                   choice)]
           [else
            (define updated
              (match choice
                [#true
                 ;---------------------------------------------------------------
                 ; set the `head` as the value for the most recent key in `keys`,
                 ; in the most recent hash in `path`.
                 (define pushed (hash-set (first path) (first keys) head))
                 pushed]
                [#false
                 ;-------------------------------------------------------------------
                 ; forget the current `head` and remove the most recent key in `keys`
                 ; and its value from the most recent hash in `path`.
                 (define dropped (hash-remove (first path) (first keys)))
                 dropped]
                [(? none?)
                 ;--------------------------------------------------------------------
                 ; forget the current `head` and go to the most recent hash in `path`.
                 (define forget (first path))
                 forget]))
            ; *focused* on the `updated` hash.
            (hash-zipper updated (rest keys) (rest path))])]

    ;-----------------------------------------------------------
    ; replace the `head` with the value in `head` for the `key`,
    ; and add `key` and `head` to the `keys` and `path` respectively.
    ; *focused* on the value for `key`.
    ;-------------------------------
    ; zipper × key -> error | zipper
    [`(#:pull ,key)
     (cond [(not (hash? head))
            (error 'hash-zipper
                   (string-append
                    "attempted to pull `~a`\n"
                    "from `~a`:\n"
                    "which is not a hash-table.")
                   key head)]
           [else
            (define pulled (hash-ref head key none))
            (hash-zipper pulled (cons key keys) (cons head path))])]))

(define-syntax (hash-zipper-send stx)
  ;----------------------------------------------
  ; syntax for an atomic command to the `zipper`.
  (define-syntax-class mono-word
    (pattern (~or* #:pop #:keys #:path)))
  ;---------------------------------------------------
  ; syntax for a command-and-argument to the `zipper`.
  (define-syntax-class dual-word
    (pattern (~or* #:put #:push #:pull)))
  ;----------------------------------------------------
  ; basic syntax for sending a command to the `zipper`,
  ; i.e., a keyword and possibly an argument expression.
  (define-splicing-syntax-class send-word
    #:attributes ([cmd 1])
    (pattern {~seq word:mono-word}
      #:with (cmd ...) #'('word))
    (pattern {~seq word:dual-word arg:expr}
      #:with (cmd ...) #'('word arg)))

  ;-----------------------------------------------------------------------------------
  ; syntax for defining a "lexical" identifier for one of the `views` of the `zipper`.
  (define-splicing-syntax-class view-word
    #:attributes (name view)
    
    #:datum-literals (VIEW)
    (pattern {~seq VIEW [name*:id view*:mono-word]}
      #:with name #'name*
      #:with view #''view*))

  ;-----------------------------------------------------------------------------------
  ; utility syntax for sending one of the three push command variants to the `zipper`.
  (define-syntax-class push-word
    #:attributes ([cmd 1])
    
    #:datum-literals (SAVE DROP BACK)
    (pattern SAVE #:with (cmd ...) #'('#:push #true))
    (pattern DROP #:with (cmd ...) #'('#:push #false))
    (pattern BACK #:with (cmd ...) #'('#:push none)))

  ;-----------------------------------------------------------------------
  ; utility syntax for sending common multi-word commands to the `zipper`.
  (define-splicing-syntax-class compound-word
    #:attributes ([words 1])

    #:datum-literals (LOAD SYNC GRAB PEEK WIPE)
    ; singular (compound) words?
    (pattern {~seq LOAD [key val]}
      #:with (words ...)
      #'(#:pull key #:put val))
    
    ; plural (compound) words?
    (pattern {~seq SYNC ([key val] ...)}
      #:with (words ...)
      #'((~@ LOAD [key val] SAVE) ...))

    (pattern {~seq GRAB [key name]}
      #:with (words ...)
      #'(#:pull key VIEW [name #:pop]))

    (pattern {~seq PEEK ([key name] ...)}
      #:with (words ...)
      #'((~@ GRAB [key name] BACK) ...))

    (pattern {~seq WIPE [key ...]}
      #:with (words ...)
      #'((~@ #:pull key DROP) ...)))

  ;------------------------------------------------------------------------
  ; syntax for adding a `meta word` to the context of the `zipper` in-line,
  ; which is a "lexically" defined procedure.
  ; the `meta word` can be called during the execution of further commands.
  (define-splicing-syntax-class meta-word
    #:attributes (name proc)
    
    #:datum-literals (DEFN)
    (pattern {~seq DEFN (word:id arg ...)
                   [body ...+]}
      #:with name #'word
      #:with proc
      #'(lambda (arg ...)
          (lambda (zipper*)
            (hash-zipper-send
             zipper* body ...)))))

  ;-------------------------------------------------------------------------
  ; syntax for recognizing a `cond` or `match` style `FORK`-word expression.
  (define-splicing-syntax-class cond-mode
    #:attributes (type uses else)
    #:datum-literals (.ON)
    (pattern {~seq .ON uses*:expr}
      #:with type #'match
      #:with uses #'(uses*)
      #:with else #'_)

    (pattern {~seq}
      #:with type #'cond
      #:with uses #'()
      #:with else #'else))

  ;----------------------------------------------------------------
  ; syntax for a conditional-branch expression, one branch of which
  ; may be executed, before continuing with the rest of the commands to the `zipper`.
  (define-splicing-syntax-class cond-word
    #:attributes
    (type uses else [cond? 1] [branch 2] [ifelse 1])

    #:datum-literals (FORK .IN .OR WHEN UNLESS)
    (pattern {~seq FORK mode:cond-mode
                   {~seq {~seq .IN [cond?* branch* ...]}
                         ...+
                         (~optional
                          {~seq .OR [else* ...]})}}
      ;------------------------
      #:with type #'mode.type
      #:with uses #'mode.uses
      #:with else #'mode.else
      ;---------------------------------------
      #:with (cond? ...)        #'(cond?* ...)
      #:with ((branch ...) ...) #'((branch* ...) ...)
      #:with (ifelse ...)       #'(~? (else* ...) ()))

    (pattern {~seq WHEN state:expr
                   [body* ...+]}
      ;------------------------
      #:with type #'cond
      #:with uses #'()
      #:with else #'else
      ;---------------------------------------
      #:with (cond? ...)        #'(state)
      #:with ((branch ...) ...) #'((body* ...))
      #:with (ifelse ...)       #'())

    (pattern {~seq UNLESS state:expr
                   [body* ...+]}
      ;------------------------
      #:with type #'cond
      #:with uses #'()
      #:with else #'else
      ;---------------------------------------
      #:with (cond? ...)        #'((not state))
      #:with ((branch ...) ...) #'((body* ...))
      #:with (ifelse ...)       #'()))

  (define-syntax-class fold-body
    (pattern (~not (~literal .VALS))))

  (define-splicing-syntax-class fold-head
    #:attributes ([loop 1] [each 1])
    #:datum-literals (FOLD .LOOP .EACH EACH)
    
    (pattern {~seq FOLD
                   .LOOP (loop* ...+)
                   .EACH (each* ...+)}
      #:with (loop ...) #'(loop* ...)
      #:with (each ...) #'(each* ...))

    (pattern {~seq EACH (each* ...+)}
      #:with (loop ...) #'()
      #:with (each ...) #'(each* ...)))

  (define-splicing-syntax-class fold-word
    #:attributes
    ([loop 1] [each 1] [body 1] [vals 1] [last 1])

    #:datum-literals (.VALS .LAST)
    (pattern {~seq head:fold-head
                   [body*:fold-body ...+
                    (~optional
                     {~seq .VALS [vals* ...+]})]
                   (~optional
                     {~seq .LAST {last* ...+}})}
      #:with (loop ...) #'(head.loop ...)
      #:with (each ...) #'(head.each ...)
      #:with (body ...) #'(body* ...)
      #:with (vals ...) #'(~? (vals* ...) ())
      #:with (last ...) #'(~? (last* ...) ())))

  (define-splicing-syntax-class loop-word
    #:attributes (name proc [with 1])

    #:datum-literals (ONCE .WITH)
    (pattern {~seq ONCE (name* args ...)
                   [body ...+]
                   (~optional
                    {~seq .WITH (with* ...)})}
      #:with name #'name*
      #:with proc
      #'(lambda (args ...)
          (lambda (zipper*)
            (hash-zipper-send
             zipper* body ...)))
      #:with (with ...) #'(~? (with* ...) ())))

  (define-splicing-syntax-class then-word
    #:attributes ([body 1])

    #:datum-literals (THEN .DO .THEN)
    (pattern .THEN
      #:with (body ...) #'())
    
    (pattern {~seq THEN .DO times:nat
                   [body* ...+]}
      #:with (body ...)
      (for*/list ([_    (in-range (syntax-e #'times))]
                  [part (in-list (syntax->list #'(body* ...)))])
        part))

    (pattern {~seq THEN .DO times:expr
                   [body* ...+]}
      #:with (body ...)
      #'(EACH ([_ (in-range times)])
         [body* ...]))

    (pattern {~seq THEN [body* ...+]}
      #:with (body ...) #'(body* ...)))
  
  (syntax-parse stx
    #:datum-literals (CALL)
    ;------------------------------------
    ; do nothing and return the `zipper`.
    ;-----------------
    ; zipper -> zipper
    [(_ zipper) #'zipper]

    [(_ zipper
        word:then-word
        rest ...)
     #'(hash-zipper-send
        zipper word.body ...
        rest ...)]
    
    ;----------------------------------------------------------
    ; replace the `zipper` with the application of `proc` to it
    ; and continue with the rest of the commands.
    ;-------------------------------------------------------
    ; zipper × {proc cmds ...} -> (proc zipper) × {cmds ...}
    [(_ zipper
        CALL proc
        rest ...)
     #'(hash-zipper-send
        (proc zipper) rest ...)]

    [(_ zipper
        word:fold-word
        rest ...)
     #'(hash-zipper-send
        (for/fold (word.loop ...
                   [zipper* zipper]
                   #:result
                   (hash-zipper-send
                    zipper* word.last ...))
                  (word.each ...)
          (values
           word.vals ...
           (hash-zipper-send
            zipper* word.body ...)))
        rest ...)]

    ; very similar to the `meta words`, except for the "lifetime" of the closure
    [(_ zipper
        word:loop-word
        rest ...)
     #'(hash-zipper-send
        (letrec ([word.name word.proc])
          ((word.name word.with ...)
           zipper))
        rest ...)]
    
    ;------------------------------------------------------------------------
    ; send an abbreviated form of common multi-word commands to the `zipper`,
    ; and continue with the rest of the commands.
    ;----------------------------------------------------------
    ; zipper × {comp cmds ...} -> zipper × {words ... cmds ...}
    [(_ zipper
        word:compound-word
        rest ...)
     #'(hash-zipper-send
        zipper word.words ...
        rest ...)]

    ;----------------------------------------------------------------------
    ; define a "lexical" identifier for the current `view` of the `zipper`,
    ; i.e., the `head`, `keys`, or `path` of the `zipper`,
    ; and continue with the rest of the commands.
    ;---------------------------------------------------------------------
    ; zipper × {view cmds ...} -> (let (... view ...) zipper × {cmds ...})
    [(_ zipper
        word:view-word
        rest ...)
     #'(let ([word.name (zipper word.view)])
         (hash-zipper-send
          zipper rest ...))]

    ;------------------------------------------------------------------------------------
    ; send an abbreviated form of one of the three push command variants to the `zipper`,
    ; and continue with the rest of the commands.
    ;-------------------------------------------------------------
    ; zipper × {push* cmds ...} -> zipper × {push choice cmds ...}
    [(_ zipper
        word:push-word
        rest ...)
     #'(hash-zipper-send
        (zipper word.cmd ...)
        rest ...)]
    
    ;----------------------------------------------------------------------------
    ; follow one of a given number of conditional branches, depending on `cond?`,
    ; and possibly an optional `.ON uses`, indicating a pattern matching expression,
    ; and continue with the rest of the commands to the `zipper`.
    ;-------------------------------------------------------
    ; zipper × {cond cmds ...} -> zipper × {branch cmds ...}
    [(_ zipper
        word:cond-word
        rest ...)
     #'(hash-zipper-send
        (word.type (~@ . word.uses)
         [word.cond?
          (hash-zipper-send
           zipper word.branch ...)]
         ...
         [word.else
          (hash-zipper-send
           zipper word.ifelse ...)])
        rest ...)]
    
    ;---------------------------------------------------------------------
    ; define a "lexical" `meta word` which can be called as a procedure to
    ; send commands to the `zipper`,
    ; and continue with the rest of the commands to the `zipper`.
    ;------------------------------------------------------------------------
    ; zipper × {meta cmds ...} -> (letrec (... meta ...) zipper × {cmds ...})
    [(_ zipper
        word:meta-word
        rest ...)
     #'(letrec ([word.name word.proc])
         (hash-zipper-send
          zipper rest ...))]
    
    ;----------------------------------------------------------------------------------
    ; send a command to the `zipper` consisting of a quoted keyword, and the arguments,
    ; and continue with the rest of the commands.
    ;-------------------------------------------------------
    ; zipper × {send cmds ...} -> (zipper send) × {cmds ...}
    [(_ zipper
        word:send-word
        rest ...)
     #'(hash-zipper-send
        (zipper word.cmd ...)
        rest ...)]))

;----------------
; a fresh zipper.
;---------------
; void -> zipper
(define (<#>) (hash-zipper #hash()))

(hash-zipper-send
 (<#>)
 SYNC (['a 1] ['b 2])
 
 DEFN (A x)
 [FORK
  .IN [(list? x) #:put x]
  .OR [#:put (list x)]
  .THEN
  SAVE]
 THEN
 {GRAB ['x x]
  CALL (A x)}
 
 DEFN (B x)
 [FORK .ON x .IN [`(,y) #:put y] .OR [#:put x] .THEN SAVE]
 THEN
 {GRAB ['x x] CALL (B x)}
 #:pop)

(hash-zipper-send
 (<#>)
 FOLD .LOOP ([num 0])
      .EACH ([key (in-list '(a b c d))])
 [LOAD [key #hash()]
  .VALS
  [(+ num 1)]]
 .LAST
 [#:put 'e
  THEN
  {EACH ([_ (in-range num)])
   [SAVE]}]
 #:pop)

(define lst '(x y z))

(hash-zipper-send
 (<#>)
 DEFN (nest n key val)
 [THEN
  {DEFN (save* n)
   [FORK
    .IN
    [(< 0 n) SAVE CALL (save* (- n 1))]]}
  THEN
  {DEFN (load* n key val)
   [FORK .ON n
    .IN [1
         LOAD [key val]]
    .OR [LOAD [key #hash()]
         CALL (load* (- n 1) key val)]]}
  THEN
  {CALL (load* n key val)
   CALL (save* n)}]
 THEN
 {FOLD
  .LOOP ([state #false])
  .EACH ([k '(x y z)]
         [v '(X Y Z)])
  [THEN
   {CALL (nest 3 k (cons v state))}
   .VALS
   [(not state)]]}
 
 VIEW [old #:pop]
 SYNC (['old old])
 
 EACH ([key (in-list lst)])
 [THEN .DO 3
  {#:pull key}
  THEN
  {VIEW [head #:pop]}
  THEN
  {FORK .ON head
   .IN [`(,sym . #f) #:put (symbol->string sym)]
   .IN [`(,sym . #t) #:put sym]}
  THEN .DO 3
  {SAVE}]
 #:pop)

(hash-zipper-send
 (<#>)
 ONCE (loop n [n* n])
 [FORK .ON n
  .IN [10
       THEN .DO (- 10 n*)
       {SAVE}]
  .IN [09
       LOAD [n (+ n 1)]
       CALL (loop (+ n 1) n*)]
  .OR [LOAD [n #hash()]
       CALL (loop (+ n 1) n*)]]
 .WITH (0)
 #:pop)

; let's try to capitalize each of the string keys and add 1 to the associated value,
; or turn the key into a string if it is a symbol and subtract 1 from the associated value,
; and then swap the keys and values (if one of these two cases), in a hash-table of k -> v
; string | symbol -> integer | hash
(hash-zipper-send
 (hash-zipper #hash(("x" . 0)
                    ("y" . 1)
                    ("z" . 2)
                    ( a  . 5)
                    ( b  . 6)
                    ( c  . #hash(("x" . 0)
                                 ("y" . 1)
                                 ("z" . 2)
                                 ( a  . #hash(("x" . #hash(("x" . 0)
                                                           ("y" . 1)
                                                           ("z" . 2)
                                                           ( a  . 5)
                                                           ( b  . 6)
                                                           ( c  . 7)))
                                              ("y" . 1)
                                              ("z" . 2)
                                              ( a  . 5)
                                              ( b  . 6)
                                              ( c  . 7)))
                                 ( b  . 6)
                                 ( c  . 7)))))
 ONCE (loop root?)
 ;---------------------
 [VIEW [the-hash #:pop]
  EACH ([(key val) (in-hash the-hash)])
  ;----
  [FORK
   .ON `(,key ,val)
   ;--------------------------------
   .IN [`(,(? string?) ,(? number?))
        WIPE [key]
        SYNC ([(+ val 1)
               (string-upcase key)])]
   ;--------------------------------
   .IN [`(,(? symbol?) ,(? number?))
        WIPE [key]
        SYNC ([(- val 1)
               (symbol->string key)])]
   ;--------------------
   .IN [`(,_ ,(? hash?))
        #:pull key
        CALL (loop #false)]]
  ;-------------------
  UNLESS root? [SAVE]]
 .WITH (#true)
 #:pop)

Probably not a very good example, in general, but after starting to work with Git once again, the terminology seemed liked a natural fit for a "zipper" like this.

Renamed some things, the originals were "catalytic", but I think these make more sense.

Even more fun, now with lambdas (and what I hope to be more "idiomatic" names).

Slightly broken now, but time for bed.

Now, with loops!

Redid a couple of things. I feel like there is an interesting parallel to Forth, here (see specifically Dawn).

for/fold is really useful. Chef's kiss.

At this point, I feel like the amount of "copying" of Racket into the macro is a good indicator that I am doing too much. I think I'll consider a parameter, next.