kosh04 · October 20, 2015 13:54 · Oct 20, 2015
diff --git a/dotassoc.lsp b/dotassoc.lsp
@@ -0,0 +1,58 @@
+;;; dotassoc.lsp
+
+;; 連想リストの Key-Value 参照をドット記法で
+
+;;; Example:
+
+;; (let ((student '((id 1332412)
+;;                  (name ((first "Student")
+;;                         (last  "Example"))))))
+;;   (with-dotassoc
+;;     (upper-case student.name.first)))
+;;=> "STUDENT"
+
+;; 読取り時に変換する (リーダマクロのようなもの)
+;; (reader-event 'dotassoc-transform)
+
+;; student.name.first
+;;  ~> (lookup 'first (lookup 'name student))
+;;  => "Student"
+
+;; (setq json (json-parse (get-url "http://httpbin.org/get")))
+;;
+;; json.headers.User-Agent
+;;=> "newLISP v10603"
+;;
+;; setf による代入も一応可能
+;; (setf json.headers.Host "localhost")
+;;=> "localhost"
+
+;; Original (emacs-lisp):
+;;   - https://gist.github.com/skeeto/7edbedfdec3444925451
+
+;;; Code:
+
+(define (dotassoc-transform-symbol symbol)
+  (let ((names (parse (term symbol) ".")))
+    (if (= 1 (length names))
+        symbol
+        (let (reduce (lambda (f seq)
+                       (apply f seq 2)))
+          (reduce (lambda (obj key)
+                    (letex (~obj obj ~key key ~strkey (string key))
+                      '(or (lookup '~key ~obj)
+                           (lookup '~strkey ~obj))))
+                  (map sym names))))))
+
+(define (dotassoc-transform expr)
+  ;;(println ";;=> " expr)
+  (cond
+   ((list? expr)   (map dotassoc-transform expr))
+   ((symbol? expr) (dotassoc-transform-symbol expr))
+   (true expr)))
+
+;; @syntax (with-dotassoc BODY*)
+(define-macro (with-dotassoc)
+  (eval (cons 'begin (dotassoc-transform (args)))))
+
+;;; eof