100_line_lisp_reader.clj

(ns parenja.reader
  (:refer-clojure :rename {list    clj-list
                           symbol  clj-symbol
                           keyword clj-keyword
                           vector  clj-vector}
                  :exclude [unquote unquote-splicing read])
  (:use somnium.yap
        combinatrix.parser
        combinatrix.parser.text
        [combinatrix.util :only [definitions]]))

(defmulti call-reader-macro (fn [c] c))

(definitions
  ARROW    := (lexeme (sequence-of "->"))

  integer  := (parsing*
               a <- (one-or-more digit)
               (return (Integer/parseInt (apply str a))))

  decimal  := (parsing*
               a <- (one-or-more digit)
               b <- DOT
               c <- (one-or-more digit)
               (return (Float/parseFloat (str (apply str a) b (apply str c)))))
  
  symbolic := (any-of "+-/*&$#^%@?_!:.")
  
  symbol   := (parsing*
                 a <- (<!> SHARP (<> alpha symbolic))
                 b <- (zero-or-more (<> alpha digit symbolic))
                 (return (clj-symbol (apply str (cons a b)))))

  unquote  := (parsing*
               COMMA
               a <- value
               (return (clj-list 'unquote a)))

  splice   := (parsing*
               COMMA AT
               a <- value
               (return (clj-list 'unquote-splicing a)))

  quasiquote := (parsing*
                 BACKQUOTE
                 a <- value
                 (return (-quasi- a)))
  
  quoted   := (parsing*
               QUOTE
               a <- value
               (return (clj-list 'quote a)))
  
  list     := (parsing*
               PAREN_OPEN
               a <- (zero-or-more value)
               PAREN_CLOSE
               (return (seq a)))

  vector   := (parsing*
               BRACKET_OPEN
               a <- (zero-or-more value)
               BRACKET_CLOSE
               (return (list* 'Array a)))

  macro    := (parsing*
               SHARP
               dispatch <- any
               (<> (call-reader-macro dispatch)
                   (fail-with "read macro error")))

  value    := (parsing*
               (lexeme (<> string symbol macro quoted quasiquote
                           decimal integer splice unquote list vector)))

  -quasi- x :=
  (match x
    ['unquote x]          (clj-list 'list x)
    ['unquote-splicing x] x
    (? vector?)           (clj-list 'vec (-quasi- (seq x)))
    [& xs]                (clj-list 'seq (list* 'concat (map -quasi- xs)))
    otherwise             (clj-list 'list (clj-list 'quote x))))

(defmethod call-reader-macro :default
  [x]
  (parsing*
   i <- get-info
   (fail-with "unsupported reader macro character: #" x "\n" i)))

(defmacro define-reader-macro
  [dispatch-char parser]
  `(defmethod call-reader-macro ~dispatch-char [~'_] ~parser))

(defmacro define-reader-macros [& char-parsers]
  `(do ~@(for [[a b] (partition 2 char-parsers)]
           `(define-reader-macro ~a ~b))))

(define-reader-macros
  ;; anonymous function sugar
  \(  (parsing*
       a <- (zero-or-more (<!> ARROW (lexeme symbol)))
       ARROW
       b <- (zero-or-more value)
       PAREN_CLOSE
       (return (list* 'fn a (seq b))))

  ;; regex literals
  \" (parsing*
      (fail-with "regex literals not implemented")))

(defn read [s]
  (first (run-parser (one-or-more value) s)))