Test version of a DSL for use with mfiano's parsley.clj

notes.clj

(ns notes
  (:refer-clojure
   :exclude [read])
  (:require
   [clojure.spec.alpha :as s]
   [mfiano.parsley.data-types :refer [read]]
   [mfiano.parsley.io :refer [open-file]]
   [net.cgrand.xforms :as xf]))

(s/def :entry/endian #{:endian/little :endian/big})

(s/def :entry/type keyword?)
(s/def :entry/id keyword?)

(s/def ::entry (s/keys :req [:entry/id :entry/type]
                       :opt [:entry/endian]))

(s/def :entry/size pos-int?)

(s/def :string/encoding #{:utf8 :utf16 :ascii :latin1})
(s/def :string/delimiter string?)
(s/def :entry.type/string (s/merge ::entry
                                   (s/keys :req [(or :entry/size
                                                     :string/delimiter)]
                                           :opt [:string/encoding])))

(s/def :integer/unsigned boolean?)
(s/def :entry.type/int (s/merge ::entry
                                (s/keys :req [:entry/size]
                                        :opt [:integer/unsigned])))

(s/def :block/type var?)
(s/def :entry.type/block (s/merge ::entry (s/keys :req [:block/type])))

(s/def ::block (s/coll-of ::entry))

(s/def ::root-block ::block)
(s/def ::spec (s/keys :req-un [::root-block]))

(defn endian->abbrev
  [endian]
  (case endian
    :endian/little :le
    :endian/big :be))

(defn abbrev->endian
  [endian]
  (case endian
    :le :endian/little
    :be :endian/big))

(defn- late-bind
  ""
  [parsed-block item]
  (if (instance? clojure.lang.AFn item)
    (item parsed-block)
    item))

(defn apply-keyword-args
  [f & args]
  (let [keyword-args (butlast args)
        map-args (into [] cat (last args))
        args (lazy-cat keyword-args map-args)]
    (apply f args)))

(defmulti parse-entry
  "Parses a single entry in a block.
  Takes the `file` to parse from, the `parsed-block` including each
  entry up to the current one, and the `entry` that you are parsing."
  (fn [file parsed-block entry]
    (:entry/type entry)))
(s/fdef parse-entry
  :args (s/cat :reader any?
               :parsed-block any?
               :entry ::entry))

(defn filter-map
  [pred]
  (fn [m k v]
    (if (pred v)
      (assoc m k v)
      m)))

(defmethod parse-entry :entry.type/string
  [file parsed-block entry]
  (let [args {:size (late-bind parsed-block (:entry/size entry))
              :endian (when-let [endian (late-bind parsed-block (:entry/endian entry))]
                        (endian->abbrev endian))
              :delimiter (late-bind parsed-block (:string/delimiter entry))
              :encoding (late-bind parsed-block (:string/encoding entry))}
        args (reduce-kv (filter-map identity) {} args)]
    (apply-keyword-args read :string file args)))

(defmethod parse-entry :entry.type/int
  [file parsed-block entry]
  (let [args {:size (late-bind parsed-block (:entry/size entry))
              :endian (when-let [endian (late-bind parsed-block (:entry/endian entry))]
                        (endian->abbrev endian))}
        args (reduce-kv (filter-map identity) {} args)]
    (apply-keyword-args read (if (late-bind parsed-block (:integer/unsigned entry))
                               :uint
                               :int)
                        file
                        args)))

(defmethod parse-entry :entry.type/block
  [file parsed-block entry]
  (reduce (fn [structure entry]
            (assoc structure
                   (:entry/id entry)
                   (parse-entry file
                                structure
                                entry)))
          {}
          @(late-bind parsed-block (:block/type entry))))

(defn- root-block
  "Creates a block to be parsed from a block structure."
  [block]
  {:entry/type :entry.type/block
   :entry/id :root
   :block/type block})

(defn parse-spec
  "Opens a file and parses binary data according to the spec."
  [spec file]
  (let [file (open-file spec file)]
    (parse-entry file {} (root-block (:root-block spec)))))
(s/fdef parse-spec
  :args (s/cat :spec ::spec
               :file string?))

(defmulti expand
  "Transforms a type expression into an appropriate map.
  The first element must be a symbol, and the rest should
  be keyword-value pairs."
  first)

(defmethod expand :default
  [[t & {:as opts}]]
  {:entry/type :entry.type/block
   :block/type `(resolve '~t)})

(defmethod expand 'int
  [[_ & {:keys [size endian]}]]
  (assert size "Integers must specify a size.")
  (let [ret {:entry/type :entry.type/int
             :entry/size size
             :integer/unsigned false}]
    (if-not (nil? endian)
      (assoc ret :entry/endian (abbrev->endian endian))
      ret)))

(defmethod expand 'string
  [[_ & {:keys [encoding size delimiter endian]}]]
  (assert (or size delimiter) "Strings must have either a size or a delimiter.")
  (let [ret {:entry/type :entry.type/string}
        ret (if-not (nil? encoding)
              (assoc ret :string/encoding encoding)
              ret)
        ret (if-not (nil? delimiter)
              (assoc ret :string/delimiter delimiter)
              ret)
        ret (if-not (nil? endian)
              (assoc ret :entry/endian (abbrev->endian endian))
              ret)]
    (if-not (nil? size)
      (assoc ret :entry/size size)
      ret)))

(defmacro defblock
  "Creates a new block definition for binary data."
  {:arglists '([name & clauses] [name docstring & clauses])}
  [name & clauses]
  (let [docstring (when (string? (first clauses))
                    (first clauses))
        xf (comp (xf/partition 2)
                 (map (fn [[id val]]
                        (merge {:entry/id id}
                               (expand val)))))
        maps (into [] xf (if-not docstring
                           clauses
                           (rest clauses)))]
    (if docstring
      `(def ~name ~docstring ~maps)
      `(def ~name ~maps))))
(s/fdef defblock
  :args (s/cat :name symbol?
               :docstring (s/? string?)
               :clauses (s/+
                         (s/cat
                          :id keyword?
                          :form (s/spec
                                 (s/cat
                                  :type symbol?
                                  :args (s/*
                                         (s/cat
                                          :key keyword?
                                          :arg any?))))))))

(defblock test-block
  :first-num (int :size 32)
  :string (string :delimiter "\0")
  :second-num (int :size 32))

(defblock test-block-two
  :block (test-block :endian :be)
  :string-size (int :size 32)
  :string (string :size #(:string-size %)))

(def test-spec
  {:desc "Free Lossless Audio Codec"
   :url "https://xiph.org/flac/format.html"
   ::root-block #'test-block})

(comment
  (ns-unmap *ns* 'test-block))

(comment
  (= [{:entry/id :first-num
       :entry/type :entry.type/int
       :entry/size 32
       :integer/unsigned false}
      {:entry/id :string
       :entry/type :entry.type/string
       :string/delimiter "\0"}
      {:entry/id :second-num
       :entry/type :entry.type/int
       :entry/size 32
       :integer/unsigned false}]
     test-block))

(comment
  "An example set of data after parsing test-spec would be this:"
  {:block {:first-num 5
           :string "Hello, world!"
           :second-num 7}
   :string-size 5
   :string "Hello"})

test_flac_spec.clj

(ns test-flac-spec
  (:require [notes :refer [defblock parse-spec]]))

(defblock data-stream
  :marker (string :size 32))

(def spec
  "Spec for fLaC audio"
  {:root-block #'data-stream
   :encoding :ascii})

(defn doit
  []
  (parse-spec spec "test.flac"))