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
|
;;; adt.clj: Algebraic data type definition.
;;; Copyright (C) 2012 Stephen Compall
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(ns com.nocandysw.cloj-dummy.scala.adt
"Simple algebraic data type macros."
(:use [com.nocandysw.cloj-dummy.scala.tertiary
:only (compile-time-warning fnmatch illegal-arg!)]
[clojure.pprint :only (cl-format)])
(:require [clojure.set :as s]))
(defmacro defadt
"Define an algebraic data type, where data constructors are records
and the type forms a protocol gluing them together. Also define
TYPECTOR? and TYPECTOR-data-case."
{:arglists '([type-name (data-constructor value-name ...) ...])}
[typector & datactors]
(let [dccase (symbol (str (name typector) "-data-case"))
typector (vary-meta typector assoc
::adt (into {} (map (fn [[dc & vars]]
[(keyword dc)
(vec (map keyword vars))])
datactors))
::datacase `'~(symbol (-> *ns* ns-name name)
(name dccase)))
defaults `((~dccase [_#] nil))]
`(do (defprotocol ~typector
(~dccase [_#]))
(defn ~(symbol (str (name typector) \?))
[x#] (boolean (~dccase x#)))
(extend-protocol ~typector
nil ~@defaults
Object ~@defaults)
~@(map (fn [[dc & vals]]
`(defrecord ~dc [~@vals] ~typector
(~dccase [_#] ~(keyword dc))))
datactors))))
(defn- check-exhaustiveness
"Warn iff `cases' doesn't match `typename' exhaustively."
[form typename cases known]
(let [used-data-ctors (keep (fn [[dcn & data?]]
(if data? (keyword (first dcn)) nil))
cases)]
(when-let [missing (seq (s/difference
(set (keys known))
(set used-data-ctors)))]
(compile-time-warning
form
(cl-format nil "Nonexhaustive match of ~S; ~
missing cases: ~{~S~^, ~}"
typename (map (comp symbol name) missing))))))
(defmacro adt-case
"Match EXPR, of ADT type TYPENAME, against various DATA-CTORs,
binding constructor args positionally to VARS and yielding the
associated RESULT. If provided, OTHERWISE is a fallback."
{:arglists '([expr typename [(data-ctor vars ...) result] ...
otherwise?])}
[expr typename & cases]
(let [cases (partition-all 2 cases)
[known dccase] (-> typename resolve meta
((juxt ::adt ::datacase)))
vexpr `vexpr#]
(check-exhaustiveness &form typename cases known)
`(let [~vexpr ~expr]
(case (~dccase ~vexpr)
~@(mapcat
(fnmatch
[([else] :seq)] [else],
[([([dc & vars] :seq) conseq] :seq)]
(let [casename (keyword dc)
canon-keys (known casename)]
(cond (nil? canon-keys)
(illegal-arg! dc)
(not= (count vars) (count canon-keys))
(illegal-arg! (format "Need %s, got %s"
canon-keys vars))
:else
[casename
`(let [~(zipmap vars canon-keys) ~vexpr]
~conseq)])))
cases)))))
;;; adt.clj ends here
|