path: root/vim/bundle/slimv/swank-clojure/swank/commands/contrib/swank_fuzzy.clj

;;; swank_fuzzy.clj --- fuzzy symbol completion, Clojure implementation.

;; Original CL implementation authors (from swank-fuzzy.lisp) below,
;; Authors: Brian Downing <bdowning@lavos.net>
;;          Tobias C. Rittweiler <tcr@freebits.de>
;;          and others

;; This progam is based on the swank-fuzzy.lisp.
;; Thanks the CL implementation authors for that useful software.

(ns swank.commands.contrib.swank-fuzzy
  (:use (swank util core commands))
  (:use (swank.util clojure)))

(def #^{:dynamic true} *fuzzy-recursion-soft-limit* 30)
(defn- compute-most-completions [short full]
  (let [collect-chunk (fn [[pcur [[pa va] ys]] [pb vb]]
                        (let [xs (if (= (dec pb) pcur)
                                   [[pa (str va vb)]]
                                   [[pb vb] [pa va]])]
                          [pb (if ys (conj xs ys) xs)]))
        step (fn step [short full pos chunk seed limit?]
               (cond
                 (and (empty? full) (not (empty? short)))
                 nil
                 (or (empty? short) limit?)
                 (if chunk
                   (conj seed
                         (second (reduce collect-chunk
                                         [(ffirst chunk) [(first chunk)]]
                                         (rest chunk))))
                   seed)
                 (= (first short) (first full))
                 (let [seed2
                       (step short (rest full) (inc pos) chunk seed
                             (< *fuzzy-recursion-soft-limit* (count seed)))]
                   (recur (rest short) (rest full) (inc pos)
                          (conj chunk [pos (str (first short))])
                          (if (and seed2 (not (empty? seed2)))
                            seed2
                            seed)
                          false))
                 :else
                 (recur short (rest full) (inc pos) chunk seed false)))]
    (map reverse (step short full 0 [] () false))))

(def fuzzy-completion-symbol-prefixes "*+-%&?<")
(def fuzzy-completion-word-separators "-/.")
(def fuzzy-completion-symbol-suffixes "*+->?!")
(defn- score-completion [completion short full]
  (let [find1
        (fn [c s]
          (re-find (re-pattern (java.util.regex.Pattern/quote (str c))) s))
        at-beginning? zero?
        after-prefix?
        (fn [pos]
          (and (= pos 1)
               (find1 (nth full 0) fuzzy-completion-symbol-prefixes)))
        word-separator?
        (fn [pos]
          (find1 (nth full pos) fuzzy-completion-word-separators))
        after-word-separator?
        (fn [pos]
          (find1 (nth full (dec pos)) fuzzy-completion-word-separators))
        at-end?
        (fn [pos]
          (= pos (dec (count full))))
        before-suffix?
        (fn [pos]
          (and (= pos (- (count full) 2))
               (find1 (nth full (dec (count full)))
                      fuzzy-completion-symbol-suffixes)))]
    (letfn [(score-or-percentage-of-previous
             [base-score pos chunk-pos]
             (if (zero? chunk-pos)
               base-score
               (max base-score
                    (+ (* (score-char (dec pos) (dec chunk-pos)) 0.85)
                       (Math/pow 1.2 chunk-pos)))))
            (score-char
             [pos chunk-pos]
             (score-or-percentage-of-previous
              (cond (at-beginning? pos)         10
                    (after-prefix? pos)         10
                    (word-separator? pos)       1
                    (after-word-separator? pos) 8
                    (at-end? pos)               6
                    (before-suffix? pos)        6
                    :else                       1)
              pos chunk-pos))
            (score-chunk
             [chunk]
             (let [chunk-len (count (second chunk))]
               (apply +
                      (map score-char
                           (take chunk-len (iterate inc (first chunk)))
                           (reverse (take chunk-len
                                          (iterate dec (dec chunk-len))))))))]
      (let [chunk-scores (map score-chunk completion)
            length-score (/ 10.0 (inc (- (count full) (count short))))]
        [(+ (apply + chunk-scores) length-score)
         (list (map list chunk-scores completion) length-score)]))))

(defn- compute-highest-scoring-completion [short full]
  (let [scored-results
        (map (fn [result]
               [(first (score-completion result short full))
                result])
             (compute-most-completions short full))
        winner (first (sort (fn [[av _] [bv _]] (> av bv))
                            scored-results))]
    [(second winner) (first winner)]))

(defn- call-with-timeout [time-limit-in-msec proc]
  "Create a thunk that returns true if given time-limit-in-msec has been
  elapsed and calls proc with the thunk as an argument. Returns a 3 elements
  vec: A proc result, given time-limit-in-msec has been elapsed or not,
  elapsed time in millisecond."
  (let [timed-out (atom false)
        start! (fn []
                 (future (do
                           (Thread/sleep time-limit-in-msec)
                           (swap! timed-out (constantly true)))))
        timed-out? (fn [] @timed-out)
        started-at (System/nanoTime)]
    (start!)
    [(proc timed-out?)
     @timed-out
     (/ (double (- (System/nanoTime) started-at)) 1000000.0)]))

(defmacro with-timeout
  "Create a thunk that returns true if given time-limit-in-msec has been
  elapsed and bind it to timed-out?. Then execute body."
  #^{:private true}
  [[timed-out? time-limit-in-msec] & body]
  `(call-with-timeout ~time-limit-in-msec (fn [~timed-out?] ~@body)))

(defstruct fuzzy-matching
  :var :ns :symbol :ns-name :score :ns-chunks :var-chunks)

(defn- fuzzy-extract-matching-info [matching string]
  (let [[user-ns-name _] (symbol-name-parts string)]
    (cond
      (:var matching)
      [(str (:symbol matching))
       (cond (nil? user-ns-name) nil
             :else (:ns-name matching))]
      :else
      [""
       (str (:symbol matching))])))

(defn- fuzzy-find-matching-vars
  [string ns var-filter external-only?]
  (let [compute (partial compute-highest-scoring-completion string)
        ns-maps (cond
                  external-only? ns-publics
                  (= ns *ns*)    ns-map
                  :else          ns-interns)]
    (map (fn [[match-result score var sym]]
           (if (var? var)
             (struct fuzzy-matching
                     var nil (or (:name (meta var))
                                 (symbol (pr-str var)))
                     nil
                     score nil match-result)
             (struct fuzzy-matching
                     nil nil sym
                     nil
                     score nil match-result)))
         (filter (fn [[match-result & _]]
                   (or (= string "")
                       (not-empty match-result)))
                 (map (fn [[k v]]
                        (if (= string "")
                          (conj [nil 0.0] v k)
                          (conj (compute (.toLowerCase (str k))) v k)))
                      (filter var-filter (seq (ns-maps ns))))))))
(defn- fuzzy-find-matching-nss
  [string]
  (let [compute (partial compute-highest-scoring-completion string)]
    (map (fn [[match-result score ns ns-sym]]
           (struct fuzzy-matching nil ns ns-sym (str ns-sym)
                   score match-result nil))
         (filter (fn [[match-result & _]] (not-empty match-result))
                 (map (fn [[ns-sym ns]]
                        (conj (compute (str ns-sym)) ns ns-sym))
                      (concat
                       (map (fn [ns] [(symbol (str ns)) ns]) (all-ns))
                       (ns-aliases *ns*)))))))

(defn- fuzzy-generate-matchings
  [string default-ns timed-out?]
  (let [take* (partial take-while (fn [_] (not (timed-out?))))
        [parsed-ns-name parsed-symbol-name] (symbol-name-parts string)
        find-vars
        (fn find-vars
          ([designator ns]
             (find-vars designator ns identity))
          ([designator ns var-filter]
             (find-vars designator ns var-filter nil))
          ([designator ns var-filter external-only?]
             (take* (fuzzy-find-matching-vars designator
                                              ns
                                              var-filter
                                              external-only?))))
        find-nss (comp take* fuzzy-find-matching-nss)
        make-duplicate-var-filter
        (fn [fuzzy-ns-matchings]
          (let [nss (set (map :ns-name fuzzy-ns-matchings))]
            (comp not nss str :ns meta second)))
        matching-greater
        (fn [a b]
          (cond
            (> (:score a) (:score b)) -1
            (< (:score a) (:score b)) 1
            :else (compare (:symbol a) (:symbol b))))
        fix-up
        (fn [matchings parent-package-matching]
          (map (fn [m]
                 (assoc m
                   :ns-name (:ns-name parent-package-matching)
                   :ns-chunks (:ns-chunks parent-package-matching)
                   :score (if (= parsed-ns-name "")
                            (/ (:score parent-package-matching) 100)
                            (+ (:score parent-package-matching)
                               (:score m)))))
               matchings))]
    (sort matching-greater
          (cond
            (nil? parsed-ns-name)
            (concat
             (find-vars parsed-symbol-name (maybe-ns default-ns))
             (find-nss parsed-symbol-name))
            ;; (apply concat
            ;;        (let [ns *ns*]
            ;;          (pcalls #(binding [*ns* ns]
            ;;                     (find-vars parsed-symbol-name
            ;;                                (maybe-ns default-ns)))
            ;;                  #(binding [*ns* ns]
            ;;                     (find-nss parsed-symbol-name)))))
            (= "" parsed-ns-name)
            (find-vars parsed-symbol-name (maybe-ns default-ns))
            :else
            (let [found-nss (find-nss parsed-ns-name)
                  find-vars1 (fn [ns-matching]
                               (fix-up
                                (find-vars parsed-symbol-name
                                           (:ns ns-matching)
                                           (make-duplicate-var-filter
                                            (filter (partial = ns-matching)
                                                    found-nss))
                                           true)
                                ns-matching))]
              (concat
               (apply concat
                      (map find-vars1 (sort matching-greater found-nss)))
               found-nss))))))

(defn- fuzzy-format-matching [string matching]
  (let [[symbol package] (fuzzy-extract-matching-info matching string)
        result (str package (when package "/") symbol)]
    [result (.indexOf #^String result #^String symbol)]))

(defn- classify-matching [m]
  (let [make-var-meta (fn [m]
                        (fn [key]
                          (when-let [var (:var m)]
                            (when-let [var-meta (meta var)]
                              (get var-meta key)))))
        vm (make-var-meta m)]
    (set
     (filter
      identity
      [(when-not (or (vm :macro) (vm :arglists))
         :boundp)
       (when (vm :arglists) :fboundp)
       ;; (:typespec)
       ;; (:class)
       (when (vm :macro)    :macro)
       (when (special-symbol? (:symbol m)) :special-operator)
       (when (:ns-name m)   :package)
       (when (= clojure.lang.MultiFn (vm :tag))
         :generic-function)]))))
(defn- classification->string [flags]
  (format (apply str (replicate 8 "%s"))
          (if (or (:boundp flags)
                  (:constant flags)) "b" "-")
          (if (:fboundp flags) "f" "-")
          (if (:generic-function flags) "g" "-")
          (if (:class flags) "c" "-")
          (if (:typespec flags) "t" "-")
          (if (:macro flags) "m" "-")
          (if (:special-operator flags) "s" "-")
          (if (:package flags) "p" "-")))

(defn- fuzzy-convert-matching-for-emacs [string matching]
  (let [[name added-length] (fuzzy-format-matching string matching)]
    [name
     (format "%.2f" (:score matching))
     (concat (:ns-chunks matching)
             (map (fn [[offset string]] [(+ added-length offset) string])
                  (:var-chunks matching)))
     (classification->string (classify-matching matching))
     ]))

(defn- fuzzy-completion-set
  [string default-ns limit time-limit-in-msec]
  (let [[matchings interrupted? _]
        (with-timeout [timed-out? time-limit-in-msec]
          (vec (fuzzy-generate-matchings string default-ns timed-out?)))
        subvec1 (if (and limit
                         (> limit 0)
                         (< limit (count matchings)))
                  (fn [v] (subvec v 0 limit))
                  identity)]
    [(subvec1 (vec (map (partial fuzzy-convert-matching-for-emacs string)
                        matchings)))
     interrupted?]))

(defslimefn fuzzy-completions
  [string default-package-name
   _limit limit _time-limit-in-msec time-limit-in-msec]
  (let [[xs x] (fuzzy-completion-set string default-package-name
                                     limit time-limit-in-msec)]
    (list
     (map (fn [[symbol score chunks class]]
            (list symbol score (map (partial apply list) chunks) class))
          xs)
     (when x 't))))

(defslimefn fuzzy-completion-selected [_ _] nil)

(comment
  (do
    (use '[clojure.test])

    (is (= '(([0 "m"] [9 "v"] [15 "b"]))
           (compute-most-completions "mvb" "multiple-value-bind")))
    (is (= '(([0 "zz"]) ([0 "z"] [2 "z"]) ([1 "zz"]))
           (compute-most-completions "zz" "zzz")))
    (is (= 103
           (binding [*fuzzy-recursion-soft-limit* 2]
             (count
              (compute-most-completions "ZZZZZZ" "ZZZZZZZZZZZZZZZZZZZZZZZ")))))

    (are [x p s] (= x (score-completion [[p s]] s "*multiple-value+"))
         '[10.625 (((10 [0 "*"])) 0.625)] 0  "*"  ;; at-beginning
         '[10.625 (((10 [1 "m"])) 0.625)] 1  "m"  ;; after-prefix
         '[1.625 (((1 [9 "-"])) 0.625)]   9  "-"  ;; word-sep
         '[8.625 (((8 [10 "v"])) 0.625)]  10 "v"  ;; after-word-sep
         '[6.625 (((6 [15 "+"])) 0.625)]  15 "+"  ;; at-end
         '[6.625 (((6 [14 "e"])) 0.625)]  14 "e"  ;; before-suffix
         '[1.625 (((1 [2 "u"])) 0.625)]   2  "u"  ;; other
         )
    (is (= (+ 10 ;; m's score
              (+ (* 10 0.85) (Math/pow 1.2 1))) ;; u's score
           (let [[_ x]
                 (score-completion [[1 "mu"]] "mu" "*multiple-value+")]
             ((comp first ffirst) x)))
        "`m''s score + `u''s score (percentage of previous which is 'm''s)")

    (is (= '[([0 "zz"]) 24.7]
           (compute-highest-scoring-completion "zz" "zzz")))

    (are [to? ret to proc] (= [ret to?]
                              (let [[x y _] (call-with-timeout to proc)]
                                [x y]))
         false "r" 10 (fn [_] "r")
         true  nil 1 (fn [_] (Thread/sleep 10) nil))

    (are [symbol package input] (= [symbol package]
                                   (fuzzy-extract-matching-info
                                    (struct fuzzy-matching
                                            true nil
                                            "symbol" "ns-name"
                                            nil nil nil)
                                    input))
         "symbol" "ns-name" "p/*"
         "symbol" nil "*")
    (is (= ["" "ns-name"]
           (fuzzy-extract-matching-info
            (struct fuzzy-matching
                    nil nil
                    "ns-name" ""
                    nil nil nil)
            "")))

    (defmacro try! #^{:private true}
      [& body]
      `(do
         ~@(map (fn [x] `(try ~x (catch Throwable ~'_ nil)))
                body)))

    (try
     (def testing-testing0 't)
     (def #^{:private true} testing-testing1 't)
     (are [x external-only?] (= x
                                (vec
                                 (sort
                                  (map (comp str :symbol)
                                       (fuzzy-find-matching-vars
                                        "testing" *ns*
                                        (fn [[k v]]
                                          (and (= ((comp :ns meta) v) *ns*)
                                               (re-find #"^testing-"
                                                        (str k))))
                                        external-only?)))))
          ["testing-testing0" "testing-testing1"] nil
          ["testing-testing0"] true)
     (finally
      (try!
        (ns-unmap *ns* 'testing-testing0)
        (ns-unmap *ns* 'testing-testing1))))

    (try
     (create-ns 'testing-testing0)
     (create-ns 'testing-testing1)
     (is (= '["testing-testing0" "testing-testing1"]
            (vec
             (sort
              (map (comp str :symbol)
                   (fuzzy-find-matching-nss "testing-"))))))
     (finally
      (try!
        (remove-ns 'testing-testing0)
        (remove-ns 'testing-testing1))))
    )
  )