piplin/src/piplin/types/bundle.clj at 4755d209644ed00dadae7bd825b22b4a9474e125 · dgrnbrg/piplin · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
(ns piplin.types.bundle
  "This namespaces provides an implementation of bundles, which
  are piplin's record type. It provides `assoc`, `assoc-in`, and `get`
  that are compatible with bundles and clojure maps."
  (:refer-clojure :exclude [cast])
  (:require [clojure.core :as clj])
  (:require [piplin.util :as util])
  (:use [slingshot.slingshot])
  (:use [piplin protocols types])
  (:use [piplin.types.bits]))

(defmethod piplin.types/assoc-multi
  :bundle
  [bund k v]
  (let [schema (:schema (typeof bund))
        v-type (clj/get schema k)
        v (cast v-type v)]
    (if (pipinst? bund)
      ((typeof bund) (clj/assoc (value bund) k v))
      (mkast (typeof bund)
             :bundle-assoc
             [bund k v]
             assoc))))

(defmethod piplin.types/valAt-multi
  :bundle
  ([bundle key]
   (piplin.types/valAt-multi bundle key nil))
  ([bundle key notfound]
   (if (pipinst? bundle)
     (clj/get (value bundle) key)
     (mkast (get-in (typeof bundle) [:schema key])
            :bundle-key
            [bundle key]
            get))))

(defmethod piplin.types/count-multi
  :bundle
  [bundle]
  (count (:schema (typeof bundle))))

(defpiplintype Bundle [schema])
(defn bundle
  "Takes a map of keys to types and returns
  a bundle type with that schema."
  [schema]
  (clj/cond
    (not (map? schema))
    (throw+ (error "Schema must be a map"))
    (some (comp not keyword?) (keys schema))
    (throw+ (error "keys must be keywords"))
    (some #(not (or (:kind %) (class? %))) (vals schema))
    (throw+ (error "values must be piplin or java types:" schema))
    :else
    (merge (Bundle. schema)
           {:kind :bundle})))


(defmethod promote
  :bundle
  [type obj]
  (clj/cond
    (clj/= (typeof obj) type) obj
    (map? obj)
    (let  [schema (:schema type)]
      (when-let [bad (seq (util/sym-diff (set (keys schema))
                                    (set (keys obj))))]
        (throw+ (error "These keys either didn't have a value"
                       "or aren't part of the schema:" bad)))
      (let [casted-obj (into {}
                             (map (fn [[k v]]
                                    [k (cast v (get obj k))])
                                   schema))]
        (if (every? pipinst? (vals obj))
          (instance type casted-obj :constrain)
          (mkast-explicit-keys type :make-bundle
                               (keys obj) casted-obj
                               (fn [& args]
                                 (promote type
                                          (zipmap (keys obj)
                                                  args)))))))
    :else
    (throw+ (error "Cannot promote" obj "to" type))))

(defmethod bit-width-of
  :bundle
  [type]
  (->> type
    :schema
    vals
    (map bit-width-of)
    (reduce +)))

(defmethod get-bits
  :bundle
  [expr]
  (let [schema-ks (keys (:schema (typeof expr)))
        bundle-inst (value expr)
        ordered-vals (map (partial get bundle-inst)
                          schema-ks)]
    (->> ordered-vals
      (map serialize)
      (apply bit-cat)
      value)))

(defmethod from-bits
  :bundle
  [type bs]
  (let [schema (:schema type)
        subtypes (vals schema)
        sizes (map bit-width-of subtypes)
        offsets (reductions + 0 sizes)
        slice (partial subvec bs)
        slices (map slice offsets (map + sizes offsets))
        insts (map from-bits subtypes slices)]
    (zipmap (keys schema) insts)))

(defmethod constrain
  :bundle
  [type val]
  (let [schema (:schema type)]
    (->> val
      (mapcat (fn [[k v]]
                [k (instance (k schema) (value v) :constrain)]))
      (apply hash-map))))

(defmethod check
  :bundle
  [inst]
  (let [schema (:schema (typeof inst))
        correct (map (fn [[k v]]
                       (and (isa-type? (k schema)
                                       (typeof v))
                            (pipinst? v)))
                         (value inst))]
    (when-let [bad (seq (util/sym-diff (set (keys schema))
                                  (set (keys (value inst)))))]
      (throw+ (error "These keys either didn't have a value"
                     "or aren't part of the schema")))
    (when-not (every? identity correct)
      (throw+ (error (value inst)
                     "doesn't match schema"
                     schema))))
  inst)