syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Tries and patches to and from jsexpr

This commit is contained in:
Tony Garnock-Jones 2016-04-19 18:52:49 -04:00
parent d033c69083
commit 839818f8e4
2 changed files with 84 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
racket/syndicate/patch.rkt
View File

@ -37,7 +37,10 @@
patch-project/set/single
pretty-print-patch
patch->pretty-string)
patch->pretty-string
patch->jsexpr
jsexpr->patch)
(require racket/set)
(require racket/match)
@ -271,6 +274,21 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (patch->jsexpr p success->jsexpr #:serialize-atom [serialize-atom values])
(match-define (patch in out) p)
(list (trie->jsexpr in success->jsexpr #:serialize-atom serialize-atom)
(trie->jsexpr out success->jsexpr #:serialize-atom serialize-atom)))
(define (jsexpr->patch pj
jsexpr->success
[lookup-struct-type (lambda (t) #f)]
#:deserialize-atom [deserialize-atom values])
(match-define (list ij oj) pj)
(patch (jsexpr->trie ij jsexpr->success lookup-struct-type #:deserialize-atom deserialize-atom)
(jsexpr->trie oj jsexpr->success lookup-struct-type #:deserialize-atom deserialize-atom)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(define (set->trie label xs)
(for/fold [(acc trie-empty)] [(x (in-set xs))]

66
racket/syndicate/trie.rkt
View File

@ -66,7 +66,10 @@
trie->pretty-string
trie->abstract-graph
abstract-graph->dot
trie->dot)
trie->dot
trie->jsexpr
jsexpr->trie)
(require racket/set)
(require racket/match)
@ -1016,6 +1019,67 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ParenType -> String
(define (paren-type->string type)
(match type
['list "L"]
['vector "V"]
[(? struct-type?)
(string-append ":" (symbol->string (struct-type-name type)))]))
;; String (String -> (Option struct-type)) -> ParenType
(define (string->paren-type s lookup-struct-type)
(match s
["L" 'list]
["V" 'vector]
[_ (if (char=? (string-ref s 0) #\:)
(or (lookup-struct-type (substring s 1))
(error 'string->paren-type "Unexpected struct type name ~v" (substring s 1)))
(error 'string->paren-type "Invalid paren-type string representation ~v" s))]))
;; Trie (Any -> JSExpr) [#:serialize-atom (Any -> JSExpr)] -> JSExpr
(define (trie->jsexpr m success->jsexpr #:serialize-atom [serialize-atom values])
(let walk ((m m))
(match m
[(? trie-empty?) '()]
[(success v) (list (success->jsexpr v))]
[(branch opens wild sigmas)
(list (for/list [(kv (treap-to-alist opens))]
(match-define (cons (open-parenthesis arity type) v) kv)
(list arity
(paren-type->string type)
(walk v)))
(walk wild)
(for/list [(kv (treap-to-alist sigmas))]
(match-define (cons k v) kv)
(list (serialize-atom k)
(walk v))))])))
;; JSExpr (JSExpr -> Any) [String -> (Option struct-type)] [#:deserialize-atom (JSExpr -> Any)]
;; -> Trie
;; Deserializes a matcher from a JSON expression.
(define (jsexpr->trie j
jsexpr->success
[lookup-struct-type (lambda (t) #f)]
#:deserialize-atom [deserialize-atom values])
(let walk ((j j))
(match j
['() #f]
[(list vj) (rsuccess (jsexpr->success vj))]
[(list jopens jwild jsigmas)
(canonicalize
(collapse
(branch (for/fold [(acc empty-omap)] [(jopen (in-list jopens))]
(match-define (list arity type-str vj) jopen)
(define type (string->paren-type type-str lookup-struct-type))
(treap-insert acc (canonical-open-parenthesis arity type) (walk vj)))
(walk jwild)
(for/fold [(acc empty-smap)] [(jsigma (in-list jsigmas))]
(match-define (list atom vj) jsigma)
(treap-insert acc (deserialize-atom atom) (walk vj))))))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(struct test-foo (bar) #:transparent)
(struct test-bar (zot quux) #:transparent)