Add test.check generators to test the binary serialization roundtripping

project.clj

@@ -8,6 +8,7 @@
                  [org.clojure/spec.alpha "0.2.176"]
                  [org.clojure/tools.reader "1.3.0"]
                  [org.clojure/core.match "0.3.0-alpha5"]
+                 [org.clojure/test.check "0.10.0-alpha3"]
                  [me.raynes/fs "1.4.6"]
                  [digest "1.4.8"]
                  [lambdaisland/uri "1.1.0"]

src/dhall_clj/binary.clj

@@ -144,33 +144,33 @@
                 (decbor a)
                 (decbor b)))
           4  (let [[typ & elems] (rest e)]
-               (if (and (empty? elems) (not typ))
+               (if (and (not (seq elems)) (nil? typ))
                  (fail/empty-list-must-have-type! e)
                  (->ListLit (decbor typ) (mapv decbor (or elems [])))))
           5  (if (= (count e) 3)
                (let [[typ val] (rest e)]
                  (assert-present! val e)
-                 (if typ
-                   (->OptionalLit (decbor typ) (decbor val))
-                   (->Some (decbor val))))
+                 (if (nil? typ)
+                   (->Some (decbor val))
+                   (->OptionalLit (decbor typ) (decbor val))))
                (let [typ (second e)]
                  (assert-present! typ e)
                  (->OptionalLit (decbor typ) nil)))
           6  (let [[a b typ?] (rest e)
                    a' (decbor a)
                    b' (decbor b)]
                (assert-len! e 3)
-               (if typ?
+               (if (nil? typ?)
                  (->Merge a' b' (decbor typ?))
-                 (->Merge a' b' nil)))
+                 (->Merge a' b' (decbor typ?))))
           7  (->RecordT   (map-vals decbor (second e)))
           8  (->RecordLit (map-vals decbor (second e)))
           9  (let [[rec k] (rest e)]
                (assert-len! e 3)
                (->Field (decbor rec) k))
           10 (let [[rec & ks] (rest e)]
                (assert-len! e 3)
-               (->Project (decbor e) ks))
+               (->Project (decbor rec) ks))
           11 (->UnionT (map-vals decbor (second e)))
           12 (let [[k v kvs] (rest e)]
                (assert-len! e 4)
@@ -182,7 +182,18 @@
           15 (->NaturalLit (second e))
           16 (->IntegerLit (second e))
           17 (->DoubleLit (second e))
-          18 (->TextLit (mapv #(if (string? %) % (decbor %)) (rest e)))
+          18 (->TextLit
+               ;; Here we exploit the fact that Text literals always have an odd count
+               ;; and they alternate strings and exprs.
+               ;; So we get the first string and then loop until we don't have any more
+               ;; tuples of exprs and strings
+               (let [[str1 & chunks] (rest e)]
+                 (loop [res [str1]
+                        cs  chunks]
+                   (if (seq cs)
+                     (let [[e s & more] cs]
+                       (recur (conj res (decbor e) s) more))
+                     res))))
           ;; TODO imports
           25 (if (= 4 (count e))
                (let [[label body next] (rest e)]

src/dhall_clj/parse.clj

@@ -509,7 +509,7 @@
         ;; so that we collapse the contiguous strings in a single chunk,
         ;; while skipping the interpolation expressions
         (loop [children (-> children first :c rest butlast) ;; Skip the quotes
-               acc nil
+               acc ""
                chunks []]
           (if (seq children)
             (let [chunk (first children)
@@ -519,31 +519,27 @@
                        (str acc (apply str content))
                        chunks)
                 (recur (rest children)
-                       nil
-                       (conj chunks (or acc "") (expr (nth content 1))))))
+                       ""
+                       (conj chunks acc (expr (nth content 1))))))
             ;; If we have no children left to process,
             ;; we return the chunks we have, plus the accomulator
-            (if-not acc
-              chunks
-              (conj chunks acc))))
+            (conj chunks acc)))
         ;; Otherwise it's a single quote literal,
         ;; so we recur over the children until we find an ending literal.
         ;; As above, we make expressions out of interpolation syntax
         (loop [children (-> children first :c second :c)
-               acc nil
+               acc ""
                chunks []]
           (if (= children ["''"])
-            (if-not acc  ;; If we have chars left in acc
-              chunks
-              (conj chunks acc))
+            (conj chunks acc)
             (if (not= (first children) "${")  ;; Check if interpolation
               ;; If not we just add the string and recur
               (recur (-> children second :c)
                      (str acc (first children))
                      chunks)
               (recur (-> children (nth 3) :c)
-                     nil
-                     (conj chunks (or acc "") (expr (second children)))))))))))
+                     ""
+                     (conj chunks acc (expr (second children)))))))))))
 
 ;; Default case, we end up here when there is no matches
 (defmethod expr :default [e]

test/dhall_clj/binary_test.clj

@@ -0,0 +1,161 @@
+(ns dhall-clj.binary-test
+  (:require [clojure.test :as test]
+            [dhall-clj.ast :refer :all]
+            [dhall-clj.binary :as b]
+            [clojure.test.check :as tc]
+            [clojure.test.check.clojure-test :refer [defspec]]
+            [clojure.test.check.generators :as gen]
+            [clojure.test.check.properties :as prop]
+            [clojure.string :as str]))
+
+;; Utils
+
+(def label (gen/frequency
+             [[9 (gen/not-empty gen/string)]
+              [1 (gen/return "_")]]))
+(defn maybe [a] (gen/one-of [(gen/return nil) a]))
+(defn kvs [a] (gen/resize 5 (gen/map label a)))
+
+;; Leaves
+
+(def natural (gen/fmap ->NaturalLit gen/nat))
+(def integer (gen/fmap ->IntegerLit gen/int))
+(def bool    (gen/fmap ->BoolLit gen/boolean))
+(def double' (gen/fmap ->DoubleLit (gen/double* {:infinite? false :NaN? false})))
+(def const   (gen/fmap ->Const (gen/elements [:kind :type])))
+(def var     (gen/fmap (partial apply ->Var) (gen/tuple label gen/nat)))
+(def builtin (gen/elements
+               [(->BoolT)
+                (->NaturalT)
+                (->NaturalFold)
+                (->NaturalBuild)
+                (->NaturalEven)
+                (->NaturalOdd)
+                (->NaturalIsZero)
+                (->NaturalToInteger)
+                (->NaturalShow)
+                (->IntegerT)
+                (->IntegerShow)
+                (->IntegerToDouble)
+                (->DoubleT)
+                (->DoubleShow)
+                (->TextT)
+                (->ListT)
+                (->ListBuild)
+                (->ListFold)
+                (->ListLength)
+                (->ListHead)
+                (->ListLast)
+                (->ListIndexed)
+                (->ListReverse)
+                (->OptionalT)
+                (->None)
+                (->OptionalFold)
+                (->OptionalBuild)]))
+
+(def leaf (gen/one-of [natural integer bool double' const var builtin]))
+
+
+;; Nodes that  can contain other nodes
+
+(defn lam          [a b] (gen/fmap (partial apply ->Lam) (gen/tuple label a b)))
+(defn pi           [a b] (gen/fmap (partial apply ->Pi) (gen/tuple label a b)))
+(defn let'         [a b] (gen/fmap (partial apply ->Let) (gen/tuple label (maybe a) a b)))
+(defn bool-if      [a b] (gen/fmap (partial apply ->BoolIf) (gen/tuple a a b)))
+(defn text         [a b] (gen/fmap
+                           ->TextLit
+                           (gen/let [a-val a
+                                     b-val b
+                                     [s1 s2 s3] (gen/tuple gen/string gen/string gen/string)]
+                             (gen/elements [[s1] [s1 a-val s2] [s1 a-val s2 b-val s3]]))))
+(defn list'        [a b] (gen/fmap
+                           (partial apply ->ListLit)
+                           (gen/one-of
+                             [(gen/tuple (gen/return nil) (gen/not-empty (gen/resize 5 (gen/vector b))))
+                              (gen/tuple a (gen/return []))])))
+(defn optional     [a b] (gen/fmap (partial apply ->OptionalLit) (gen/tuple a (maybe b))))
+(defn some'        [a] (gen/fmap ->Some a))
+(defn record-type  [a] (gen/fmap ->RecordT (kvs a)))
+(defn record       [a] (gen/fmap ->RecordLit (kvs a)))
+(defn union-type   [a] (gen/fmap ->UnionT (kvs a)))
+(defn union        [a b] (gen/fmap (partial apply ->UnionLit) (gen/tuple label a (kvs b))))
+(defn merge'       [a b] (gen/fmap (partial apply ->Merge) (gen/tuple a b (maybe b))))
+(defn constructors [a] (gen/fmap ->Constructors a))
+(defn field        [a] (gen/fmap (partial apply ->Field) (gen/tuple a label)))
+(defn project      [a] (gen/fmap (partial apply ->Project) (gen/tuple a (gen/not-empty (gen/vector label)))))
+
+
+(defmacro defopgen
+  [op]
+  (let [fn-name (name op)
+        fn-sym (symbol fn-name)
+        sym (symbol (str "->"
+                         (condp = fn-name
+                           "bool-eq" "BoolEQ"
+                           "bool-ne" "BoolNE"
+                           (str/join (map str/capitalize (str/split fn-name #"-"))))))]
+    `(defn ~fn-sym [a# b#]
+       (gen/fmap (partial apply ~sym)
+                 (gen/tuple a# b#)))))
+
+(defopgen app)
+(defopgen annot)
+(defopgen bool-and)
+(defopgen bool-or)
+(defopgen bool-eq)
+(defopgen bool-ne)
+(defopgen natural-plus)
+(defopgen natural-times)
+(defopgen text-append)
+(defopgen list-append)
+(defopgen import-alt)
+(defopgen combine)
+(defopgen combine-types)
+(defopgen prefer)
+
+(defn expr
+  [depth]
+  (if (= depth 0)
+    leaf ;; If we shouldn't recur anymore, we return a leaf that doesn't contain more expr
+    (gen/let [new-depth (gen/return (dec depth))
+              depth-a   (gen/choose 0 new-depth)
+              depth-b   (gen/return (- new-depth depth-a))]
+      (let [a (gen/resize depth-a (gen/sized expr))
+            b (gen/resize depth-b (gen/sized expr))]
+        (gen/one-of
+          [(lam a b)
+           (pi a b)
+           (let' a b)
+           (bool-if a b)
+           (text a b)
+           (list' a b)
+           (optional a b)
+           (some' a)
+           (record-type a)
+           (record a)
+           (union-type a)
+           (union a b)
+           (merge' a b)
+           (constructors a)
+           (field a)
+           (project a)
+           (app a b)
+           (annot a b)
+           (bool-and a b)
+           (bool-or a b)
+           (bool-eq a b)
+           (bool-ne a b)
+           (natural-plus a b)
+           (natural-times a b)
+           (text-append a b)
+           (list-append a b)
+           (import-alt a b)
+           (combine a b)
+           (combine-types a b)
+           (prefer a b)])))))
+
+(def encoding-roundtrips
+  (prop/for-all [e (gen/sized expr)]
+    (= e (-> e b/encode b/decode))))
+
+(defspec binary-encoding-roundtrips-test 500 encoding-roundtrips)

test/dhall_clj/parse_test.clj

@@ -33,7 +33,7 @@
     (->TextLit ["ABC"])]
 
    ["\"\""
-    (->TextLit [])]
+    (->TextLit [""])]
 
    ["\"\\\"aaaa\""
     (->TextLit ["\\\"aaaa"])]
@@ -47,6 +47,9 @@
    ["''a${1}b''"
     (->TextLit ["a" (->NaturalLit 1) "b"])]
 
+   ["''${Bool}${Natural}''"
+    (->TextLit ["" (->BoolT) "" (->NaturalT) ""])]
+
    ["[1]"
     (->ListLit nil [(->NaturalLit 1)])]