PasteRack.org
Paste # 3252
2023-10-30 21:40:43

Forked from paste # 21026.

Fork as a new paste.

Paste viewed 531 times.


Embed:

  1. #lang racket
  2.  
  3. (require (for-syntax syntax/parse))
  4.  
  5. ; now, with derivations!
  6.  
  7. (begin-for-syntax
  8.   (define-splicing-syntax-class node
  9.     #:datum-literals (-- = $)
  10.  
  11.     (pattern {~seq lhs*:id --}
  12.       #:with rhs #'lhs*
  13.       #:with lhs #''lhs*)
  14.  
  15.     (pattern {~seq lhs*:id (~optional {~seq = rhs*:expr})}
  16.       #:with rhs #'(~? rhs* _)
  17.       #:with lhs #''lhs*)
  18.  
  19.     (pattern {~seq $ lhs*:expr (~optional {~seq = rhs*:expr})}
  20.       #:with rhs #'(~? rhs* _)
  21.       #:with lhs #'lhs*))
  22.  
  23.   (define-splicing-syntax-class nest
  24.     #:datum-literals (:)
  25.     (pattern {~seq node:node}
  26.       #:with norm #'(node.lhs node.rhs))
  27.  
  28.     (pattern {~seq node:node : nodes-or-conj:nest->hash}
  29.       #:with norm #'(node.lhs (and node.rhs nodes-or-conj.norm))))
  30.  
  31.   (define-splicing-syntax-class nest->hash
  32.     (pattern nest:nest
  33.       #:with ooo  #'(... ...)
  34.       #:with norm #'(hash-table nest.norm _ ooo))
  35.  
  36.     (pattern nest:conj
  37.       #:with norm #'(extract (~@ . nest))))
  38.  
  39.   ; not being used yet
  40.   (define-splicing-syntax-class ellipsis
  41.     #:datum-literals (each some with))
  42.  
  43.   (define-splicing-syntax-class conj
  44.     #:datum-literals (× @)
  45.     (pattern {~seq [nest0:nest {~seq × nest:nest} ... (~optional {~seq @ rest*:expr})]
  46.                    (~optional {~seq #:derive [pat* exp*] ...})}
  47.       #:with norm             #'(nest0.norm nest.norm  ...)
  48.       #:with rest             #'(~? rest* _)
  49.       #:with (derive-pat ...) #'(~? (pat* ...) ())
  50.       #:with (derive-exp ...) #'(~? (exp* ...) ()))))
  51.  
  52. (define-match-expander filter*
  53.   (lambda (stx)
  54.     (syntax-parse stx
  55.       [(_ pattern* (~optional {~seq #:rest rest}))
  56.        #:with ooo      #'(... ...)
  57.        #'(app (lambda (lst)
  58.                 (for/fold ([matched (list)]
  59.                            [ignored (list)]
  60.                            #:result (values (reverse matched) (reverse ignored)))
  61.                           ([element (in-list lst)])
  62.                   (match element
  63.                     [pattern*
  64.                      (values (cons element matched) ignored)]
  65.                     [_
  66.                      (values matched (cons element ignored))])))
  67.               (list pattern* ooo) (~? rest _))])))
  68.  
  69. (define-match-expander extract
  70.   (lambda (stx)
  71.     (syntax-parse stx
  72.       [(_ conj*:conj)
  73.        #:with ooo       #'(... ...)
  74.        #:with (exp ...) #'(conj*.derive-exp ...)
  75.        #:with (pat ...) #'(conj*.derive-pat ...)
  76.        #:with (ph  ...) (generate-temporaries #'(exp ...))
  77.        #'(app (match-lambda
  78.                 [(and hash (hash-table (~@ . conj*.norm) (k v) ooo))
  79.                  (match-let* ([(and ph pat) exp] ...)
  80.                    (list hash (make-hash (map cons k v)) ph ...))] [_ #f])
  81.               (list (hash-table (~@ . conj*.norm) _ ooo) conj*.rest pat ...))])))
  82.  
  83. (define-match-expander replace
  84.   (lambda (stx)
  85.     (syntax-parse stx
  86.       [(_)
  87.        #'(list)])))
  88.  
  89. (define T 'h)
  90.  
  91. (match (list #hash((windows . #hash((wash  . #hash((john . #hash((4 . h)))
  92.                                                    (mary . #hash((1 . h)))))))
  93.                    (veranda . #hash((scrub . #hash((john . #hash((3 . h)))))))
  94.                    (cellars . #hash((scrub . #hash((john . #hash((3 . h)))))))
  95.                    (day     . (#hash((date . "1896-02-03"))
  96.                                #hash((date . "1896-02-04"))
  97.                                #hash((date . "1896-02-05")))))
  98.  
  99.              #hash((windows . #hash((wash  . #hash((jill . #hash((3   . h)))
  100.                                                    (jack . #hash((2   . h)))))))
  101.                    (veranda . #hash((scrub . #hash((jess . #hash((1   . h)))))))
  102.                    (cellars . #hash((scrub . #hash((jess . #hash((0.5 . h)))))))
  103.                    (day     . (#hash((date . "1896-02-10")))))
  104.  
  105.              #hash((windows . #hash((wash  . #hash((jill . #hash((3 . h)))
  106.                                                    (jack . #hash((2 . h)))))))
  107.                    (veranda . #hash((scrub . #hash((jess . #hash((5 . h)))))))
  108.                    (cellars . #hash((scrub . #hash((jess . #hash((2 . h)))))))
  109.                    (day     . (#hash((date . "1896-02-17"))))))
  110.   [(filter*
  111.     (extract
  112.      [ windows
  113.      : wash --
  114.      : [ $ (or 'jill 'mary)
  115.        : $ time-jill+mary = (== T)
  116.  
  117.        × $ (or 'jack 'john)
  118.        : $ time-jack+john = 'h]
  119.        #:derive
  120.        [time-jill+mary-minutes (* 60 time-jill+mary)]
  121.        [time-jack+john-minutes (* 60 time-jack+john)]
  122.     × veranda = (and veranda (extract [scrub = veranda-scrub]))
  123.     × cellars
  124.     : scrub   = cellars-scrub
  125.     × day     = (list (extract [date = "1896-02-10"]) ...)
  126.     @ hash-rest])
  127.     #:rest list-rest)
  128.    ;---
  129.    (displayln wash)
  130.    (displayln time-jill+mary)
  131.    (displayln time-jill+mary-minutes)
  132.  
  133.    (displayln time-jack+john)
  134.    (displayln time-jack+john-minutes)
  135.  
  136.    (displayln veranda-scrub)
  137.    (displayln cellars-scrub)
  138.    (displayln veranda)]
  139.   [_ #f])

=>