~subsetpark/ec

bd73813f66ec440d293ebe5a8f1e3237343c5ab0 — Zach Smith 9 months ago c27b383
Introduce vectors and .[] syntax
M main.janet => main.janet +33 -27
@@ 2,37 2,42 @@
(import /src/print)
(import /src/parser)

(defn display
(defn handle-signal
  [input]
  (let [str (string input)]
    (when (= str "") (os/exit 0))
    str))

(defn- display
  [data]
  (print (print/p data))
  "")

(defn display-all
(defn- display-all
  [stack]
  (let [inner (map print/p stack)]
    (print (string/join inner " ")))
  "")

(defn display-help
(defn- display-help
  []
  (each [k v] (pairs parser/dictionary)
    (printf "%s: %s" k (string (v :type))))
  "")

(defn describe
  [elem]
  (printf "%s\n\n%s: %s"
          (print/p elem)
          (string (elem :type))
          (elem :doc)))

(defn describe-all
(defn- describe-all
  [q]
  (defn- describe
    [elem]
    (printf "%s\n\n%s: %s"
            (print/p elem)
            (string (elem :type))
            (elem :doc)))
  (each item (q :data)
    (describe item))
  "")

(defn handle-special
(defn- handle-special
  [s special]
  (case (freeze (string/trim special))
    "." (display (calc/peek s))


@@ 43,32 48,33 @@

(defn handle-commands
  [s input]
  (when (= (string input) "") (os/exit 0))
  
  (each token input
    (match token
      @[:special patt] (handle-special s patt)
      _ (calc/push s token))))

(defn- prompt
  [s]
  (->> s
       (calc/peek)
       (print/p)
       (string/format "(%s)> ")))

(defn repl
  []
  (def s (:new calc/Stack))
  (while true
    (def bak (array/slice (s :data)))
    (try (as-> s _
               (calc/peek _)
               (print/p _)
               (string/format "(%s)> " _)
               (getline _ @"" parser/dictionary)
               (parser/parse _)
               (handle-commands s _))
         
         ([err fib]
          (eprint err)
          (if (os/getenv "EC_TRACEBACK")
            (propagate err fib)
            (put s :data bak))))))
    (try (->> (getline (prompt s) @"" parser/dictionary)
              (handle-signal)
              (parser/parse)
              (handle-commands s))

      ([err fib]
        (eprint err)
        (if (os/getenv "EC_TRACEBACK")
          (propagate err fib)
          (put s :data bak))))))

(defn handle-line
  [line]

M src/adverbs.janet => src/adverbs.janet +33 -23
@@ 15,7 15,7 @@
  `1 1 [+] apply` is equivalent to `1 1 +`.
  ```
  (let [quotation (calc/pop stack)]
    (if (calc/Quotation? quotation)
    (if (calc/Quotation*? quotation)
      (do (calc/check-arity stack quotation)
        (each elem (calc/data quotation)
          (calc/push stack elem)))


@@ 28,23 28,23 @@
  `v`. If `v` is not a quotation, then `distribute` is equivalent to
  `apply`.
  ```
  (let [quotation (calc/pop stack)
        object (calc/pop stack)]

    (unless (calc/Quotation? quotation)
      (error "Distribute error: top argument must be a quotation"))
  (let [q (calc/pop stack)
        quotation (if (calc/Quotation*? q)
                    q
                    (calc/quote-wrap q))
        v (calc/pop stack)]

    (defn push-verb []
      (calc/check-arity stack quotation)
      (each verb-elem (calc/data quotation)
        (calc/push stack verb-elem)))

    (if (calc/Quotation? object)
      (each elem (calc/data object)
    (if (calc/Quotation*? v)
      (each elem (calc/data v)
        (calc/push stack elem)
        (push-verb))
      (do
        (calc/push stack object)
        (calc/push stack v)
        (push-verb)))))

(defadv wrap-stack 0


@@ 91,11 91,11 @@
  quotation.
  ```
  (let [elem (calc/pop stack)
        quotation (calc/pop stack)
        new-quotation (if (calc/Quotation? quotation)
                        (calc/wrap ;(quotation :data) elem)
                        (calc/wrap quotation elem))]
    (calc/push stack new-quotation)))
        vector (calc/pop stack)
        new-vector (if (calc/Vector? vector)
                     (calc/wrap ;(vector :data) elem)
                     (calc/wrap vector elem))]
    (calc/push stack new-vector)))

(defadv slurp-left 2
  ```


@@ 106,12 106,12 @@
  If either element is a quotation, wraps the two top elements in a
  quotation.
  ```
  (let [quotation (calc/pop stack)
  (let [vector (calc/pop stack)
        elem (calc/pop stack)
        new-quotation (if (calc/Quotation? quotation)
                        (calc/wrap elem ;(quotation :data))
                        (calc/wrap elem quotation))]
    (calc/push stack new-quotation)))
        new-vector (if (calc/Vector? vector)
                     (calc/wrap elem ;(vector :data))
                     (calc/wrap elem vector))]
    (calc/push stack new-vector)))

(defadv fill 2
  ```


@@ 135,7 135,17 @@
  Returns the number of stack elements that `a` would consume if it
  were pushed to the stack.
  ```
  (let [elem (calc/pop stack)]
    (let [arity (calc/get-arity elem)
          new-elem (calc/make-element arity)]
      (calc/push stack new-elem))))
  (let [elem (calc/pop stack)
        arity (calc/get-arity elem)
        new-elem (calc/make-element arity)]
    (calc/push stack new-elem)))

(defadv shape 1
  ```
  v -- w
  Returns the shape of the vector `v`.
  ```
  (let [v (calc/pop stack)
        shape (calc/get-shape v)
        new-elem (calc/wrap ;(map calc/make-element shape))]
    (calc/push stack new-elem)))

M src/calc.janet => src/calc.janet +24 -14
@@ 28,13 28,19 @@
  out-arity {})

(defproto Quotation Element
  shape {:default [] :init? true}
  out-arity {:allocate-value 1}
  data {:init? true}
  type {:allocate-value :quotation})

(defgeneric get-shape [_] [])
(defmethod get-shape Quotation [self] (self :shape))
(defproto Vector Quotation
  shape {:default [] :init? true}
  data {:init? true}
  type {:allocate-value :vector})

(defmethod get-shape Number [self] [])
(defmethod get-shape Vector [self] (self :shape))
(defmethod get-shape Quotation [_]
  (error "Shape error: attempted vector operation on a quotation"))

(defgeneric get-arity [_] 0)
(defmethod get-arity Adverb [a] (a :arity))


@@ 50,16 56,16 @@
                        (((q :data) (dec i)) :out-arity))))))
  (max ;arities))

(defgeneric fill
(defmethod fill Number
  [element shape-to-fill]
  (if (empty? shape-to-fill)
    element
    (let [y (array ;shape-to-fill)
          yi (last y)
          v (:new Quotation [yi] (array/new-filled yi element))]
          v (:new Vector [yi] (array/new-filled yi element))]
      (fill v y))))

(defmethod fill Quotation
(defmethod fill Vector
  [self shape-to-fill]
  (let [x (array ;(shape self))
        y (array ;shape-to-fill)]


@@ 68,13 74,13 @@
      (let [xi (array/pop x)
            yi (array/pop y)]
        (unless (= xi yi)
          (errorf "Shape error: can't fill quotation with shape %q to %q"
          (errorf "Shape error: can't fill vector with shape %q to %q"
                  (shape self) shape-to-fill))))

    (reduce (fn [acc length]
              (let [new-shape (tuple length ;(shape acc))
                    new-data (array/new-filled length acc)]
                (:new Quotation new-shape new-data)))
                (:new Vector new-shape new-data)))
            self
            (reverse y))))



@@ 86,8 92,8 @@
(defn- inner-apply
  [op & args]
  (let [x (first args)]
    (if (Quotation? x)
      (:new Quotation
    (if (Vector? x)
      (:new Vector
            (x :shape)
            (map (partial inner-apply op) ;(map |($ :data) args)))
      (let [f (op :fun-ref)


@@ 102,16 108,20 @@
        filled (map |(fill $ largest) args)]
    (inner-apply op ;filled)))

(defn quote-wrap
  [& data]
  (:new Quotation data))

(defn wrap
  [& data]
  (let [hd (first data)
        inner-shape (get-shape hd)]
        inner-shape (if hd (get-shape hd) ())]
    (each datum data
      (unless (deep= (get-shape datum) inner-shape)
        (errorf "Quotation error: can't wrap heterogeneous data. Expected %j, got %j."
        (errorf "Vector error: can't wrap heterogeneous data. Expected %j, got %j."
                inner-shape
                (get-shape datum))))
    (:new Quotation (tuple (length data) ;inner-shape) data)))
    (:new Vector (tuple (length data) ;inner-shape) data)))

(defmethod pop Stack
  [self]


@@ 157,4 167,4 @@

(defn shape?
  [obj]
  (and (Quotation? obj) (all Number*? (obj :data))))
  (and (Vector? obj) (all Number*? (obj :data))))

M src/parser.janet => src/parser.janet +17 -11
@@ 30,6 30,7 @@
                 "fill" adverbs/fill
                 "dup" adverbs/dup
                 "arity" adverbs/arity
                 "shape" adverbs/shape

                 "sqr" compose/square})



@@ 39,6 40,10 @@

(defn handle-brackets
  [& patt]
  (calc/quote-wrap ;patt))

(defn handle-vbrackets
  [& patt]
  (calc/wrap ;patt))

(defn handle-float


@@ 54,19 59,20 @@
(defn handle-word
  [patt]
  (cond (index-of patt ["." "p" "s" "?" "??"])
        [:special patt]
        true
        (or (dictionary patt)
            (errorf "syntax error: unknown word %s" patt))))
    [:special patt]
    true
    (or (dictionary patt)
        (errorf "syntax error: unknown word %s" patt))))

(def- peg (peg/compile
           ~{:main (any (+ :s+ :brackets :token))
             :brackets (cmt (* "[" :main "]") ,handle-brackets)
             :number-part (some (+ :d "_"))
             :float (cmt (<- (* (? "-") :number-part "." :number-part)) ,handle-float)
             :int (cmt (<- (* (? "-") :number-part)) ,handle-int)
             :word (cmt (<- (some (if-not (+ :s (set "()[]")) 1))) ,handle-word)
             :token (+ :float :int :word)}))
            ~{:main (any (+ :s+ :vbrackets :brackets :token))
              :vbrackets (cmt (* ".[" :main "]") ,handle-vbrackets)
              :brackets (cmt (* "[" :main "]") ,handle-brackets)
              :number-part (some (+ :d "_"))
              :float (cmt (<- (* (? "-") :number-part "." :number-part)) ,handle-float)
              :int (cmt (<- (* (? "-") :number-part)) ,handle-int)
              :word (cmt (<- (some (if-not (+ :s (set "()[]")) 1))) ,handle-word)
              :token (+ :float :int :word)}))

(defn parse
  [str]

M src/print.janet => src/print.janet +19 -11
@@ 2,22 2,30 @@

(import /src/calc)

(defgeneric p
  [val] (describe val))

(defmethod p calc/Int
(defmulti p [calc/Int]
  [n] (string (n :value)))

(defmethod p calc/Float
(defmulti p [calc/Float]
  [n] (string (n :value)))

(defmethod p calc/Operation
(defmulti p [calc/Operation]
  [o] (string (o :type)))

(defmethod p calc/Adverb
(defmulti p [calc/Adverb]
  [a] (string (a :type)))

(defmethod p calc/Quotation
  [v]
  (let [inner (map p (v :data))]
    (string "[" (string/join inner " ") "]")))
(varfn join [q] nil)

(defmulti p [calc/Quotation] [q] (join q "[" "]"))

(defmulti p [calc/Vector] [v] (join v ".[" "]"))

(varfn join
  [q l r]
  (let [inner (map p (q :data))]
    (string l (string/join inner " ") r)))

(defmulti p [:nil] [_] "")

(defmulti p [_]
  [val] (describe val))

M test-support.janet => test-support.janet +12 -5
@@ 12,16 12,23 @@
  [val obj]
  (is (== val (unwrap obj))))

(defn- make-element
  [x]
  (if (number? x) (:new calc/Int x) x))

(defn wrap
  [& args]
  (calc/wrap ;(map |(if (number? $)
                      (:new calc/Int $)
                      $)
                   args)))
  (calc/wrap ;(map make-element args)))

(defn quote-wrap
  [& args]
  (calc/quote-wrap ;(map make-element args)))

(defn pop-and-compare
  [val s]
  (is (= val (calc/value (calc/pop s)))))
  (let [found (match (calc/pop s)
                {:value value} value)]
    (is (== val found))))

(defn push-all
  [stack args]

M test/calc.janet => test/calc.janet +20 -11
@@ 6,7 6,7 @@
(use testament)
(use /test-support)

(deftest quotations
(deftest vectors
  (def v (wrap 1 2 3))
  (def v2 (wrap 2 5 10))



@@ 36,7 36,7 @@
        filled)

  (is (thrown? (calc/fill m [2 3 3]))
      "Quotations can be filled into shapes that share a suffix")
      "Vectors can be filled into shapes that share a suffix")

  (vec= @[@[@[2 4 6]
            @[8 10 12]]


@@ 51,7 51,7 @@
  # Operands
  (calc/push s (wrap 1 2 3))
  # Operator
  (calc/push s (wrap o/add))
  (calc/push s (quote-wrap o/add))
  (calc/push s a/distribute)
  (pop-and-compare 6 s))



@@ 59,12 59,21 @@
  (def s (:new calc/Stack))
  (calc/push s (:new calc/Int 0))
  (calc/push s (wrap 1 2 3))
  (calc/push s (wrap 3 o/mul o/add))
  (calc/push s (quote-wrap 3 o/mul o/add))
  (calc/push s a/distribute)
  (pop-and-compare 18 s))

(deftest apply-quotation
  (def s (:new calc/Stack))
  (calc/push s (quote-wrap 1 2 3))
  (calc/push s a/apply-quotation)
  (pop-and-compare 3 s)
  (pop-and-compare 2 s)
  (pop-and-compare 1 s)
  (is (empty? (s :data))))

(deftest apply-vector
  (def s (:new calc/Stack))
  (calc/push s (wrap 1 2 3))
  (calc/push s a/apply-quotation)
  (pop-and-compare 3 s)


@@ 76,7 85,7 @@
  (def s (:new calc/Stack))
  (calc/push s (:new calc/Int 3))
  (calc/push s (:new calc/Int 5))
  (calc/push s (wrap o/add))
  (calc/push s (quote-wrap o/add))
  (calc/push s a/apply-quotation)
  (pop-and-compare 8 s)
  (is (empty? (s :data))))


@@ 110,23 119,23 @@
      "Wrapping a stack requires homogeneous data"))

(deftest get-arity
  (is (= 2 (calc/get-arity (wrap o/add)))
  (is (= 2 (calc/get-arity (quote-wrap o/add)))
      "A quoted operation's arity is the operation's arity")
  (is (= 3 (calc/get-arity (wrap o/add o/add)))
  (is (= 3 (calc/get-arity (quote-wrap o/add o/add)))
      ```
      A composition of operations' arity is the greatest of the
      individual operations' arities, each adjusted for the out-arity
      of the one prior
      ```)
  (is (= 2 (calc/get-arity (wrap o/add 2 o/add)))
  (is (= 2 (calc/get-arity (quote-wrap o/add 2 o/add)))
      "Interposed numbers will reduce the arity of a quotation")
  (is (= 0 (calc/get-arity (:new calc/Int 2)))
      "A number's arity is 0")
  (is (= 0 (calc/get-arity (wrap 2)))
  (is (= 0 (calc/get-arity (quote-wrap 2)))
      "A quoted number's arity is 0")
  (is (= 0 (calc/get-arity (wrap 2 2 2 2)))
  (is (= 0 (calc/get-arity (quote-wrap 2 2 2 2)))
      "A quoted sequence of numbers is 0")
  (is (= 0 (calc/get-arity (wrap 2 2 o/add)))
  (is (= 0 (calc/get-arity (quote-wrap 2 2 o/add)))
      "A quoted operation is 0 if the quote enough values to fulfill it"))

(run-tests!)

M test/parser.janet => test/parser.janet +5 -0
@@ 9,6 9,11 @@

(deftest brackets
  (let [[parsed] (parser/parse "[]")]
    (is (== nil (parsed :shape)))
    (is (== [] (parsed :data)))))

(deftest vector
  (let [[parsed] (parser/parse ".[]")]
    (is (== [0] (parsed :shape)))
    (is (== [] (parsed :data)))))


M test/regressions.janet => test/regressions.janet +4 -4
@@ 10,7 10,7 @@
(deftest regression1
  # [1] 1 + 1 +
  (def s (:new calc/Stack))
  (let [in (parser/parse "[1] 1 + 1 +")]
  (let [in (parser/parse ".[1] 1 + 1 +")]
    (calc/push s (in 0))
    (vec= [1] (calc/peek s))
    (calc/push s (in 1))


@@ 27,7 27,7 @@
(deftest regression2
  # [4 5] 6 +  8 +
  (def s (:new calc/Stack))
  (let [in (parser/parse "[4 5] 6 + 8 +")]
  (let [in (parser/parse ".[4 5] 6 + 8 +")]
    (push-all s in))

  (def res (calc/pop s))


@@ 36,7 36,7 @@
(deftest regression3
  # [2 3 4] 1 -
  (def s (:new calc/Stack))
  (let [in (parser/parse "[2 3 4] 1 -")]
  (let [in (parser/parse ".[2 3 4] 1 -")]
    (push-all s in))

  (def res (calc/pop s))


@@ 46,7 46,7 @@
  # ([[1] [2] [3]])> !
  #could not find method :- for 0, or :r- for nil
  (def s (:new calc/Stack))
  (let [in (parser/parse "[[1][2]] !")]
  (let [in (parser/parse ".[.[1].[2]] !")]
    (push-all s in))
  (while ((complement empty?) (s :data))
    (def inner-q (calc/pop s))