@@ -2,17 +2,18 @@

 (in-package :asdf-user)

 (defsystem :cl-edn 

-    :description ""

-    :author "Ed L <edward@elangley.org>"

-    :license "MIT"

-    :depends-on (#:alexandria

-                 #:uiop

-                 #:serapeum

-                 #:smug)

-    :serial t

-    :in-order-to ((test-op (test-op :cl-edn/test)))

-    :components ((:file "edn")

-                 ))

+  :description ""

+  :author "Ed L <edward@elangley.org>"

+  :license "MIT"

+  :depends-on (#:alexandria

+               #:uiop

+               #:serapeum

+               #:smug)

+  :serial t

+  :in-order-to ((test-op (test-op :cl-edn/test)))

+  :components ((:file "package")

+               (:file "edn")

+               (:file "synthesize")))

 (defsystem :cl-edn/fset

   :depends-on (#:cl-edn

@@ -20,9 +21,17 @@

                #:fwoar.lisputils)

   :components ((:file "fset-synthesize")))

+(defsystem :cl-edn/fset-lossy

+  :depends-on (#:cl-edn

+               #:cl-edn/fset

+               #:fset

+               #:fwoar.lisputils)

+  :components ((:file "fset-lossy-synthesize")))

+

 (defsystem :cl-edn/test

   :depends-on (#:should-test)

   :perform (test-op (o s)

                     (uiop:symbol-call :st '#:test

                                       :package :edn-test))

-  :components ((:file "test")))

+  :components ((:file "package")

+               (:file "test")))

@@ -1,14 +1,3 @@

-(defpackage :edn

-  (:use :cl :smug)

-  (:export ))

-(defpackage :edn-primitives

-  (:use)

-  (:export :nil :true :false))

-

-(defconstant edn-primitives:nil 'edn-primitives:nil)

-(defconstant edn-primitives:true 'edn-primitives:true)

-(defconstant edn-primitives:false 'edn-primitives:false)

-

 (in-package :edn)

 (defun .satisfies (predicate &rest args)

@@ -63,6 +52,27 @@

 (defun .alt (&rest r)

   (reduce '.plus r))

+(defun .compound-element-start ()

+  (.or (.string= "#{")

+       (.char= #\{)

+       (.char= #\[)

+       (.char= #\()

+       (.char= #\{)))

+

+(defun .compound-element-finish (closing)

+  (lambda ()

+    (.prog1 (.first (.elements))

+            (.s)

+            (.char= closing))))

+

+(defun .map-element ()

+  (.prog2 (.char= #\{)

+          (.progn (.s)

+                  (.zero-or-more (.let* ((first (.prog1 (.element) (.s)))

+                                         (second (.prog1 (.element) (.s))))

+                                   (.identity (list :pair first second)))))

+          (.char= #\})))

+

 (defun .element ()

   (.or (.or (.nil)

             (.boolean))

@@ -73,28 +83,23 @@

              (.string)

              (.let* ((pairs

-                      (.prog2 (.char= #\{)

-                              (.progn (.s)

-                                      (.zero-or-more (.let* ((first (.prog1 (.element) (.s)))

-                                                             (second (.prog1 (.element) (.s))))

-                                                       (.identity (list :pair first second)))))

-                              (.char= #\}))))

+                      (.map-element)))

                (.identity (cons :map pairs)))

              (.let* ((pairs

                       (.prog2 (.string= "#{")

-                              (.elements)

+                              (.first (.elements))

                               (.s)

                               (.char= #\}))))

                (.identity (cons :set pairs)))

              (.let* ((pairs

                       (.prog2 (.char= #\[)

-                              (.elements)

+                              (.first (.elements))

                               (.s)

                               (.char= #\]))))

                (.identity (cons :vector pairs)))

              (.let* ((pairs

                       (.prog2 (.char= #\()

-                              (.elements)

+                              (.first (.elements))

                               (.s)

                               (.char= #\)))))

                (.identity (cons :list pairs)))

@@ -164,10 +169,6 @@

        (.satisfies (lambda (x)

                      (or (digit-char-p x)

                          (member x '(#\# #\:)))))))

-(defun .number ()

-  (.or (.float)

-       (.integer)))

-

 (defun apply-sign (sign num)

   (if sign

       (ecase sign

@@ -175,27 +176,6 @@

         (#\- (* -1 num)))

       num))

-(defun .integer ()

-  (.let* ((sign (.optional

-                 (.or (.char= #\+)

-                      (.char= #\-))))

-          (num (.cardinal))

-          (flag (.optional (.char= #\N))))

-    flag

-    (.identity (apply-sign sign num))))

-

-(defun .float ()

-  (.let* ((sign (.optional

-                 (.or (.char= #\+)

-                      (.char= #\-))))

-          (num (.cardinal))

-          (frac (.frac-exp)))

-    (destructuring-bind (mant exp) frac

-      (.identity (apply-sign sign (* (+ num mant)

-                                     (if exp

-                                         (expt 10 exp)

-                                         1)))))))

-

 (defun .frac-exp ()

   (.alt (.let* ((frac (.frac))

                 (exp (.optional (.exp)))

@@ -225,9 +205,50 @@

                                 (floor

                                  (1+ (log num

                                           10))))))

-                   'float))

+                   'double-float))

          0))))

+(defun .one-of (items &optional (test 'eql))

+  (.satisfies

+   (serapeum:op

+     (member _ items :test test))))

+

+(defun interpret-number (parts)

+  (destructuring-bind (sign radix float-info flag) parts

+    (let* ((base-value (if float-info

+                           (destructuring-bind (mantissa exp) float-info

+                             (coerce (* (+ radix

+                                           (or mantissa 0))

+                                        (if exp

+                                            (expt 10 exp)

+                                            1))

+                                     'double-float))

+                           radix))

+           (signed (case sign

+                     ((#\+ nil) base-value)

+                     (#\- (- base-value)))))

+      (typecase signed

+        (integer (if (member flag '(nil #\N))

+                     (.identity signed)

+                     (.fail)))

+        (float (if (member flag '(nil #\M))

+                   (.identity signed)

+                   (.fail)))))))

+

+(defun .number ()

+  (flet ((.sign () (.one-of '(#\+ #\-))))

+    (.let* ((sign (.optional (.sign)))

+            (num (.cardinal))

+            (frac (.optional (.frac)))

+            (exp (.optional (.exp)))

+            (flag (.optional (.one-of '(#\N #\M)))))

+      (interpret-number

+       (list sign

+             num

+             (when (or frac exp)

+               (list frac exp))

+             flag)))))

+

 (defun .exp ()

   (.progn (.char-equal #\e)

           (.let* ((sign (.optional

@@ -237,12 +258,13 @@

             (.identity (apply-sign sign num)))))

 (defun .cardinal ()

-  (.let* ((nums (.first

-                 (.or (.let* ((first (.non-zero-digit))

-                              (rest (.zero-or-more (.digit))))

-                        (.identity (list* first rest)))

-                      (.let* ((c (.digit)))

-                        (.identity (list c)))))))

+  (.let* ((nums (.or (.first

+                      (.let* ((first (.non-zero-digit))

+                              (rest (.zero-or-more

+                                     (.digit))))

+                        (.identity (list* first rest))))

+                     (.let* ((c (.digit)))

+                       (.identity (list c))))))

     (.identity (parse-integer (coerce nums 'string)))))

 (defun .digit ()

@@ -255,7 +277,7 @@

 (defun .printable-character ()

   (.or (.satisfies (lambda (x) (char>= #\~ x #\!)))

-       (.satisfies (lambda (x) (>= (char-code x) #xA1)))))

+       (.satisfies (lambda (x) (char<= #\space x)))))

 (defun .character-name ()

   (.or (.string= "newline")

@@ -298,5 +320,13 @@

                           (.char= #\"))))

     (.identity (list :string (combine string)))))

-(defgeneric synthesize-compound (implementation discriminator args))

-(defgeneric synthesize (implementation args))

+(defun read-edn (s)

+  (car

+   (smug:parse (.prog1 (.elements)

+                       (.s)

+                       (.not (.item)))

+               s)))

+

+(defun parse (input &optional (realizer 'fset))

+  (synthesize realizer

+              (read-edn input)))

new file mode 100644

@@ -0,0 +1,39 @@

+;; capitalizes symbols ---- possible information loss

+(in-package :edn)

+

+(defclass fset-lossy (fset)

+  ()

+  (:documentation "An eden synthesizer that applies semantic

+  transformations that could lose information: in particular, when

+  it's translating a keyword or symbol, it uppercases the namespace

+  and name to match CL's symbol behavior"))

+

+

+(defmethod synthesize ((implementation (eql 'fset-lossy)) thing)

+  (typecase thing

+    (list (synthesize-compound implementation (car thing) (cdr thing)))

+    (t thing)))

+

+

+(defmethod synthesize-compound ((implementation fset-lossy) (discriminator (eql :list)) args)

+  (mapcar (lambda (a)

+            (synthesize implementation a))

+          args))

+

+(defmethod synthesize-compound :around ((implementation fset-lossy) (discriminator (eql :keyword)) args)

+  (destructuring-bind (ns name) args

+    (call-next-method implementation

+                      discriminator

+                      (list (when ns (string-upcase ns))

+                            (string-upcase name)))))

+

+(defmethod synthesize-compound (implementation (discriminator (eql :string)) args)

+  (car args))

+

+(defmethod synthesize-compound :around ((implementation fset-lossy) (discriminator (eql :symbol)) args)

+  (destructuring-bind (ns name) args

+    (call-next-method implementation

+                      discriminator

+                      (list (when ns (string-upcase ns))

+                            (string-upcase name)))))

+

@@ -1,12 +1,16 @@

 (in-package :edn)

+(defclass fset ()

+  ()

+  (:documentation "An EDN synthesizer that produces fset datastructures"))

-(defmethod synthesize ((implementation (eql 'fset)) thing)

+

+(defmethod synthesize ((implementation fset) thing)

   (typecase thing

     (list (synthesize-compound implementation (car thing) (cdr thing)))

     (t thing)))

-(defmethod synthesize-compound ((implementation (eql 'fset)) (discriminator (eql :map)) args)

+(defmethod synthesize-compound ((implementation fset) (discriminator (eql :map)) args)

   (fset:convert 'fset:map

                 (mapcar (fw.lu:destructuring-lambda ((p k v))

                           (declare (ignore p))

@@ -14,39 +18,20 @@

                                 (synthesize implementation v)))

                         args)))

-(defmethod synthesize-compound ((implementation (eql 'fset)) (discriminator (eql :set)) args)

+(defmethod synthesize-compound ((implementation fset) (discriminator (eql :set)) args)

   (fset:convert 'fset:set

                 (mapcar (lambda (a)

                           (synthesize implementation a))

                         args)))

-(defmethod synthesize-compound ((implementation (eql 'fset)) (discriminator (eql :vector)) args)

+(defmethod synthesize-compound ((implementation fset) (discriminator (eql :vector)) args)

   (fset:convert 'fset:seq

                 (mapcar (lambda (a)

                           (synthesize implementation a))

                         args)))

-(defmethod synthesize-compound ((implementation (eql 'fset)) (discriminator (eql :list)) args)

+(defmethod synthesize-compound ((implementation fset) (discriminator (eql :list)) args)

   (mapcar (lambda (a)

             (synthesize implementation a))

           args))

-(defmethod synthesize-compound (implementation (discriminator (eql :keyword)) args)

-  (destructuring-bind (ns name) args

-    (alexandria:make-keyword (if ns

-                                 (format nil "~a/~a" ns name)

-                                 (format nil "~a" name)))))

-

-(defmethod synthesize-compound (implementation (discriminator (eql :string)) args)

-  (car args))

-

-(defmethod synthesize-compound (implementation (discriminator (eql :symbol)) args)

-  (destructuring-bind (ns name) args

-    (make-symbol (if ns

-                     (format nil "~a/~a" ns name)

-                     (format nil "~a" name)))))

-

-(defmethod synthesize-compound (implementation (discriminator (eql :tagged)) args)

-  (destructuring-bind (sym obj) args

-    (list :tagged (synthesize-compound implementation (car sym) (cdr sym))

-          (synthesize implementation obj))))

new file mode 100644

@@ -0,0 +1,167 @@

+(in-package :edn.generate)

+

+(defun generate-edn ()

+  (case (random 3)

+    (0 (generate-map))

+    (1 (generate-set))

+    (2 (generate-vect))))

+

+(defun generate-nil ()

+  "nil")

+

+(defun prim-generate-char ()

+  (code-char (+ 32 (random #.(- 128 32)))))

+

+(defun generate-string ()

+  (loop with limit = (random 25)

+     repeat limit

+     collect (prim-generate-char) into chars

+     finally (return (format nil "\"~a\""

+                             (serapeum:string-replace-all "\""

+                                                          (serapeum:string-replace-all

+                                                           "\\"

+                                                           (coerce chars 'string)

+                                                           "\\\\")

+                                                          "\\\"")))))

+

+(defun generate-int ()

+  (princ-to-string (- (random 20000)

+                      10000)))

+

+(defun flip-coin ()

+  (= 1 (random 2)))

+

+(defun generate-float ()

+  (format nil "~[~;-~;+~]~a.~:[~;~:*~a~]~:[~;e~:*~a~]"

+          (random 3)

+          (if (flip-coin)

+              (random 10000)

+              0)

+          (when (flip-coin)

+            (random 10000))

+          (when (flip-coin)

+            (- (random 100)

+               50))))

+

+(defun generate-character ()

+  (format nil "\\~c" (prim-generate-char)))

+

+(defun generate-bool ()

+  (if (flip-coin)

+      "true"

+      "false"))

+

+(defmacro comment (&body b)

+  (declare (ignore b))

+  (values))

+

+(comment

+  (or (alpha-char-p x)

+      (member x '(#\! #\* #\? #\_ #\$ #\% #\& #\=))))

+

+(defun generate-capital ()

+  (code-char

+   (+ #.(char-code #\A)

+      (random 26))))

+

+(defun generate-lower ()

+  (code-char

+   (+ #.(char-code #\a)

+      (random 26))))

+

+(defun generate-initial-char ()

+  (case (random 2)

+    (0 (generate-capital))

+    (1 (generate-lower))))

+

+(defun generate-middle-char ()

+  (case (random 5)

+    (0 (generate-capital))

+    (1 (generate-lower))

+    (2 (generate-capital))

+    (3 (generate-lower))

+    (4 (elt #(#\- #\_) (random 2)))))

+

+(defun generate-name (&optional (length 20))

+  (loop repeat (+ 2 (random length))

+     for char = (generate-initial-char) then (generate-middle-char)

+     collect char into chars

+     finally (return (coerce chars 'string))))

+

+(defun generate-symbol ()

+  (let ((ns (generate-name 5))

+        (name (generate-name 20)))

+    (if (flip-coin)

+        name

+        (format nil "~a/~a" ns name))))

+

+(defun generate-keyword ()

+  (format nil ":~a" (generate-symbol)))

+

+(defun generate-primitive ()

+  (case (random 8)

+    (0 (generate-string))

+    (1 (generate-int))

+    (2 (generate-bool))

+    (3 (generate-float))

+    (4 (generate-nil))

+    (5 (generate-character))

+    (6 (generate-keyword))

+    (7 (generate-symbol))))

+

+(defun compound-or-primitive (&optional (primitive-func 'generate-primitive))

+    (case (random 10)

+      (0 (generate-edn))

+      (1 (funcall primitive-func))

+      (2 (funcall primitive-func))

+      (3 (funcall primitive-func))

+      (4 (funcall primitive-func))

+      (5 (funcall primitive-func))

+      (6 (funcall primitive-func))

+      (7 (funcall primitive-func))

+      (8 (funcall primitive-func))

+      (9 (funcall primitive-func))))

+

+(defun not-float ()

+  (compound-or-primitive

+   (lambda ()

+     (case (random 5)

+       (0 (generate-string))

+       (1 (generate-int))

+       (2 (generate-bool))

+       (3 (generate-nil))

+       (4 (generate-character))))))

+

+(defun generate-map (&optional (key-func 'not-float) (value-func 'compound-or-primitive))

+  (loop

+     with keys = (fset:set)

+     repeat (random 10)

+     for key = (loop for next = (funcall key-func)

+                  until (not (fset:contains? keys next))

+                  finally

+                    (fset:includef keys next)

+                    (return next))

+     for value = (funcall value-func)

+     collect (format nil "~a ~a" key value) into res

+     finally (return (format nil "{~{~{~a~^~[ ~;, ~;,~; ,~]~}~}}"

+                             (mapcar (serapeum:op (list _1 (random 3)))

+                                     (remove-duplicates res :test 'equal))))))

+

+

+(defun generate-set (&optional (value-func 'not-float))

+  (loop

+     repeat (random 19)

+     for value = (funcall value-func)

+     collect value into res

+     finally (return (format nil "#{~{~{~a~^~[ ~;, ~;,~; ,~]~}~}}"

+                             (mapcar (serapeum:op (list _1 (random 3)))

+                                     (remove-duplicates res :test 'equal))))))

+

+(defun generate-vect (&optional (value-func 'compound-or-primitive))

+  (loop

+     repeat (random 19)

+     for value = (funcall value-func)

+     collect value into res

+     finally (return (format nil "[~{~{~a~^~[ ~;, ~;,~; ,~]~}~}]"

+                             (mapcar (serapeum:op (list _1 (random 3)))

+                                     res)))))

new file mode 100644

@@ -0,0 +1,20 @@

+(defpackage :edn

+  (:use :cl :smug)

+  (:shadow :parse)

+  (:export :read-edn

+           :synthesize

+           :fset

+           :fset-lossy

+           :convert-primitive))

+

+(defpackage :edn.generate

+  (:use :cl)

+  (:export :generate-edn))

+

+(defpackage :edn-primitives

+  (:use)

+  (:export :nil :true :false))

+

+(defconstant edn-primitives:nil 'edn-primitives:nil)

+(defconstant edn-primitives:true 'edn-primitives:true)

+(defconstant edn-primitives:false 'edn-primitives:false)

new file mode 100644

@@ -0,0 +1,39 @@

+(in-package :edn)

+

+

+(defgeneric convert-primitive (implementation primitive))

+

+(defgeneric synthesize (implementation args))

+(defgeneric synthesize-compound (implementation discriminator args))

+

+(defmethod synthesize ((implementation symbol) discriminator)

+  (synthesize (make-instance 'implementation) discriminator))

+

+(defmethod synthesize-compound (implementation (discriminator (eql :keyword)) args)

+  (destructuring-bind (ns name) args

+    (alexandria:make-keyword (if ns

+                                 (format nil "~a/~a" ns name)

+                                 (format nil "~a" name)))))

+

+(defmethod synthesize-compound (implementation (discriminator (eql :string)) args)

+  (car args))

+

+(defmethod synthesize-compound (implementation (discriminator (eql :symbol)) args)

+  (destructuring-bind (ns name) args

+    (make-symbol (if ns

+                     (format nil "~a/~a" ns name)

+                     (format nil "~a" name)))))

+

+(defmethod synthesize-compound (implementation (discriminator (eql :tagged)) args)

+  (destructuring-bind (sym obj) args

+    (list :tagged

+          (synthesize-compound implementation (car sym) (cdr sym))

+          (synthesize implementation obj))))

+

+(defmethod synthesize-compound (implementation (discriminator (eql :character)) args)

+  (car args))

+

+(defmethod synthesize-compound (implementation (discriminator (eql :tagged)) args)

+  (destructuring-bind (sym obj) args

+    (list :tagged (synthesize-compound implementation (car sym) (cdr sym))

+          (synthesize implementation obj))))

@@ -3,25 +3,59 @@

   (:export ))

 (in-package :edn-test)

+(defun float-equal (a b)

+  (> 0.00001

+     (abs (- a b))))

+

+(deftest floating ()

+  (should be float-equal

+          0.1

+          (edn:read-edn "0.1"))

+  (should be float-equal

+          0.1

+          (edn:read-edn "+0.1"))

+  (should be float-equal

+          -0.1

+          (edn:read-edn "-0.1"))

+  (should be float-equal

+          1

+          (edn:read-edn "0.1e1"))

+  (should be float-equal

+          1

+          (edn:read-edn "0.1e+1"))

+  (should be float-equal

+          0.01

+          (edn:read-edn "0.1e-1"))

+  (should be float-equal

+          -0.01

+          (edn:read-edn "-0.1e-1"))

+  (should be float-equal

+          -0.01

+          (edn:read-edn "-0.1e-1M"))

+  (should be float-equal

+          -0.0

+          (edn:read-edn "-0.e-1M")))

+

 (deftest edn-parser ()

   (should be equal

-          '((:map (:pair 1 1)))

-          (smug:parse (edn::.elements) "{ 1 1 }"))

+          '(:list)

+          (edn:read-edn (format nil "()~%")))

+  (should be equal

+          '(:map (:pair 1 1))

+          (edn:read-edn "{ 1 1 }"))

   (should be equal

-          '((:vector 1 1))

-          (smug:parse (edn::.elements) "[ 1 1 ]"))

+          '(:vector 1 1)

+          (edn:read-edn "[ 1 1 ]"))

   (should be equal

-          '((:set 1 1))

-          (smug:parse (edn::.elements) "#{ 1   1 }"))

+          '(:set 1 1)

+          (edn:read-edn "#{ 1   1 }"))

   (should be equal

-          '((:tagged (:symbol nil "foobar") (:vector 1 1)))

-          (smug:parse (edn::.elements) "#foobar [ 1 1 ]"))

+          '(:tagged (:symbol nil "foobar") (:vector 1 1))

+          (edn:read-edn "#foobar [ 1 1 ]"))

   (should be equal

           '(:list

             (:set

              (:vector

               (:map (:pair edn-primitives:nil edn-primitives:true)

                     (:pair edn-primitives:false edn-primitives:nil)))))

-          (car (smug:parse (smug:.prog1 (edn::.elements) (smug:.not (smug:.item)))

-                           "(#{[{nil true,false nil}]})")))

-  )

+          (edn:read-edn "(#{[{nil true,false nil}]})")))