From 99fd3546be6db746fad678a35cefa5a46a730d44 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Tue, 26 Jul 2011 08:22:06 -0400
Subject: [PATCH] Adding serialization of theories

---
 collects/datalog/main.rkt                 |  2 ++
 collects/datalog/scribblings/racket.scrbl |  3 ++
 collects/datalog/serialize.rkt            | 37 +++++++++++++++++++++++
 collects/tests/datalog/racket.rkt         | 17 ++++++++++-
 4 files changed, 58 insertions(+), 1 deletion(-)
 create mode 100644 collects/datalog/serialize.rkt

diff --git a/collects/datalog/main.rkt b/collects/datalog/main.rkt
index 7f8a65359c..4c8161cff3 100644
--- a/collects/datalog/main.rkt
+++ b/collects/datalog/main.rkt
@@ -1,6 +1,8 @@
 #lang racket
 (require "runtime.rkt"
+         "serialize.rkt"
          "stx.rkt")
 (provide make-theory
          theory/c
+         (all-from-out "serialize.rkt")
          (all-from-out "stx.rkt"))
diff --git a/collects/datalog/scribblings/racket.scrbl b/collects/datalog/scribblings/racket.scrbl
index 9c53c8f426..1904cd24ae 100644
--- a/collects/datalog/scribblings/racket.scrbl
+++ b/collects/datalog/scribblings/racket.scrbl
@@ -54,6 +54,9 @@ The Datalog database can be directly used by Racket programs through this API.
 
 @defproc[(make-theory) theory/c]{ Creates a theory for use with @racket[datalog]. }
 
+@defproc[(write-theory [t theory/c]) void]{ Writes a theory to the current output port. Source location information is lost. }
+@defproc[(read-theory) theory/c]{ Reads a theory from the current input port. }
+
 @defform[(datalog thy-expr
                   stmt ...)
          #:contracts ([thy-expr theory/c])]{ Executes the statements on the theory given by @racket[thy-expr]. Returns the answers to the final query as a list of substitution dictionaries or returns @racket[empty]. }
diff --git a/collects/datalog/serialize.rkt b/collects/datalog/serialize.rkt
new file mode 100644
index 0000000000..1ebb48a968
--- /dev/null
+++ b/collects/datalog/serialize.rkt
@@ -0,0 +1,37 @@
+#lang racket/base
+(require racket/contract
+         racket/match
+         racket/list
+         "runtime.rkt")
+
+(define remove-stx-objs
+  (match-lambda
+    [(? hash? ht)
+     (for/hash ([(k v) (in-hash ht)])
+       (values k (remove-stx-objs v)))]
+    [(? cons? c)
+     (cons (remove-stx-objs (car c))
+           (remove-stx-objs (cdr c)))]
+    [(? prefab-struct-key s)
+     (apply make-prefab-struct
+            (prefab-struct-key s)
+            (remove-stx-objs (rest (vector->list (struct->vector s)))))]
+    [(? syntax? s)
+     #f]
+    [x x]))
+
+(define (write-theory t)
+  (write (remove-stx-objs t)))
+
+(define (hash->hash! ht)
+  (define ht! (make-hash))
+  (for ([(k v) (in-hash ht)])
+    (hash-set! ht! k v))
+  ht!)
+
+(define (read-theory)
+  (hash->hash! (read)))
+
+(provide/contract
+ [write-theory (-> theory/c void)]
+ [read-theory (-> theory/c)])
\ No newline at end of file
diff --git a/collects/tests/datalog/racket.rkt b/collects/tests/datalog/racket.rkt
index 5245122291..bca96bbd4b 100644
--- a/collects/tests/datalog/racket.rkt
+++ b/collects/tests/datalog/racket.rkt
@@ -2,7 +2,7 @@
 (require datalog tests/eli-tester)
 
 (define parent (make-theory))
-
+ 
 (test
  (datalog parent
           (! (parent joseph2 joseph1))
@@ -59,6 +59,21 @@
  =>
  (list (hasheq 'X 2))
  
+ (let ()
+   (define new-parent
+     (with-input-from-bytes 
+         (with-output-to-bytes (λ () (write-theory parent)))
+       (λ () (read-theory))))
+   (test
+    (datalog new-parent
+             (? (ancestor A B)))
+    =>
+    (list (hasheq 'A 'joseph3 'B 'joseph2)
+          (hasheq 'A 'joseph2 'B 'lucy)
+          (hasheq 'A 'joseph2 'B 'joseph1)
+          (hasheq 'A 'joseph3 'B 'lucy)
+          (hasheq 'A 'joseph3 'B 'joseph1))))
+ 
  (local [(local-require tests/datalog/examples/ancestor)]
    (datalog theory
             (? (ancestor A B))))