/src/library/slix/ced/doclib.clj

  1;; %! Copyright (C) 2011 Kei Suzuki  All rights reserved. !%
  2;; 
  3;; This file is part of Sevenri, a Clojure environment ("This Software").
  4;; 
  5;; The use and distribution terms for this software are covered by the Eclipse
  6;; Public License version 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
  7;; which can be found in the COPYING at the root of this distribution.
  8;; By using this software in any fashion, you are agreeing to be bound by the
  9;; terms of this license.
 10;; You must not remove this notice, or any other, from this software.
 11
 12(ns library.slix.ced.doclib
 13  (:use [sevenri log])
 14  (:import (javax.swing.text Segment)))
 15
 16;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 17
 18(def *dcntxt* nil)
 19(def *txtseg* nil)
 20
 21(def *open-close-pairs* {\( [\( \)]
 22                         \{ [\{ \}]
 23                         \[ [\[ \]]
 24                         \) [\) \(]
 25                         \} [\} \{]
 26                         \] [\] \[]})
 27
 28(def *open-close-pairs-s* {"(" ["(" ")"]
 29                           "{" ["{" "}"]
 30                           "[" ["[" "]"]
 31                           ")" [")" "("]
 32                           "}" ["}" "{"]
 33                           "]" ["]" "["]})
 34
 35;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 36
 37(defn create-doc-context
 38  [ced]
 39  (let [doc (.getDocument ced)
 40        doc-elm (.getDefaultRootElement doc)]
 41    {:ced ced
 42     :doc doc
 43     :pos (.getCaretPosition ced)
 44     :min-pos 0
 45     :max-pos (dec (.getLength doc))
 46     :doc-elm doc-elm
 47     :doc-ect (.getElementCount doc-elm)}))
 48
 49(defmacro setup-doc-context
 50  [ced dcntxt & body]
 51  `(binding [~'*dcntxt* (merge (create-doc-context ~ced) ~dcntxt)]
 52     ~@body))
 53
 54(defmacro get-doc-context
 55  ([]
 56     `~'*dcntxt*)
 57  ([kwd]
 58     `(~kwd ~'*dcntxt*)))
 59
 60(defmacro update-doc-context
 61  [dcntxt & body]
 62  `(binding [~'*dcntxt* (merge (get-doc-context) ~dcntxt)]
 63     ~@body))
 64
 65(defmacro do-assert
 66  [x]
 67  ;;`(#_(assert ~x)))
 68  `(assert ~x))
 69
 70;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 71
 72(defmacro partial-segment
 73  ([]
 74     `(.setPartialReturn ~'*txtseg* true))
 75  ([seg]
 76     `(.setPartialReturn ~seg true)))
 77
 78(defmacro get-partial-txtseg
 79  [beg len]
 80  `(let [seg# (Segment.)]
 81     (partial-segment seg#)
 82     (.getText (get-doc-context :doc) ~beg ~len seg#)
 83     seg#))
 84
 85(defmacro exact-segment
 86  ([]
 87     `(.setPartialReturn ~'*txtseg* false))
 88  ([seg]
 89     `(.setPartialReturn ~seg false)))
 90
 91(defmacro get-exact-txtseg
 92  [beg len]
 93  `(let [seg# (Segment.)]
 94     (exact-segment seg#)
 95     (.getText (get-doc-context :doc) ~beg ~len seg#)
 96     seg#))
 97
 98(defmacro get-txtseg-begin-end
 99  ([]
100     `(let [seg# ~'*txtseg*]
101       [(.getBeginIndex seg#) (.getEndIndex seg#)]))
102  ([seg]
103     `[(.getBeginIndex ~seg) (.getEndIndex ~seg)]))
104
105(defmacro get-txtseg-begin-len
106  ([]
107     `(let [seg# ~'*txtseg*]
108        [(.getBeginIndex seg#) (.length seg#)]))
109  ([seg]
110     `[(.getBeginIndex ~seg) (.length ~seg)]))
111
112(defn get-txtseg
113  [beg len]
114  (let [seg (get-partial-txtseg beg len)
115        [_ slen] (get-txtseg-begin-len seg)]
116    (if (= len slen)
117      seg
118      (let [seg (get-exact-txtseg beg len)]
119        (do-assert (= len (.length seg)))
120        #_(lg "exact seg for beg:" beg "len:" len)
121        seg))))
122
123(defmacro setup-txt-segment
124  [beg len & body]
125  `(binding [~'*txtseg* (get-txtseg ~beg ~len)]
126     ~@body))
127
128(defmacro txtseg-char-at
129  ([off]
130     `(.charAt ~'*txtseg* ~off))
131  ([seg off]
132     `(.carAt ~seg ~off)))
133
134;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
135
136(defmacro str-at
137  ([pos]
138     `(.getText (get-doc-context :doc) ~pos 1))
139  ([pos len]
140     `(.getText (get-doc-context :doc) ~pos ~len)))
141
142(defmacro line-index
143  [pos]
144  `(.getElementIndex (get-doc-context :doc-elm) ~pos))
145
146(defmacro line-index-to-start-pos
147  [lindex]
148  `(.getStartOffset (.getElement (get-doc-context :doc-elm) ~lindex)))
149
150(defmacro line-index-to-end-pos
151  [lindex]
152  `(.getEndOffset (.getElement (get-doc-context :doc-elm) ~lindex)))
153
154(defmacro start-of-line
155  [pos]
156  `(.getStartOffset (.getParagraphElement (get-doc-context :doc) ~pos)))
157  
158(defmacro end-of-line
159  [pos]
160  `(dec (.getEndOffset (.getParagraphElement (get-doc-context :doc) ~pos))))
161
162(defmacro start-and-end-line
163  [pos]
164  `(let [e# (.getParagraphElement (get-doc-context :doc) ~pos)]
165     [(.getStartOffset e#) (.getEndOffset e#)]))
166
167(defmacro start-and-len-line
168  [pos]
169  `(let [e# (.getParagraphElement (get-doc-context :doc) ~pos)
170         s# (.getStartOffset e#)]
171     [s# (- (.getEndOffset e#) s#)]))
172
173(defmacro pos-to-col
174  [pos]
175  `(- ~pos (start-of-line ~pos)))
176
177(defn start-of-prev-line
178  [pos]
179  (let [doc-elm (get-doc-context :doc-elm)
180        idx (.getElementIndex doc-elm pos)]
181    (when (< (get-doc-context :min-pos) idx)
182      (.getStartOffset (.getElement doc-elm (dec idx))))))
183
184(defn end-of-prev-line
185  [pos]
186  (let [doc-elm (get-doc-context :doc-elm)
187        idx (.getElementIndex doc-elm pos)]
188    (when (< (get-doc-context :min-pos) idx)
189      (dec (.getEndOffset (.getElement doc-elm (dec idx)))))))
190
191(defmacro newline?
192  [c]
193  `(= ~c \newline))
194
195(defmacro newline-s?
196  [s]
197  `(= ~s "\n"))
198
199(defmacro space?
200  [c]
201  `(or (= ~c \space) (= ~c \tab) (= ~c \newline)))
202
203(defmacro space-s?
204  [s]
205  `(or (= ~s " ") (= ~s "\t") (= ~s "\n")))
206
207(defmacro escape?
208  [c]
209  `(= ~c \\))
210
211(defmacro escape-s?
212  [s]
213  `(= ~s "\\"))
214
215(defmacro comment?
216  [c]
217  `(= ~c \;))
218
219(defmacro comment-s?
220  [s]
221  `(= ~s ";"))
222
223(defmacro dquote?
224  [c]
225  `(= ~c \"))
226
227(defmacro dquote-s?
228  [s]
229  `(= ~s "\""))
230
231(defmacro opening?
232  [c]
233  `(or (= ~c \() (= ~c \{) (= ~c \[)))
234
235(defmacro opening-s?
236  [s]
237  `(or (= ~s "(") (= ~s "{") (= ~s "[")))
238
239(defmacro closing?
240  [c]
241  `(or (= ~c \]) (= ~c \}) (= ~c \))))
242
243(defmacro closing-s?
244  [s]
245  `(or (= ~s "]") (= ~s "}") (= ~s ")")))
246
247(defmacro opening-or-closing?
248  [c]
249  `(get *open-close-pairs* ~c))
250
251(defmacro opening-or-closing-s?
252  [s]
253  `(get *open-close-pairs-s* ~s))
254
255(defmacro matching-paren-of
256  [c]
257  `(second (get *open-close-pairs* ~c)))
258
259(defmacro matching-paren-of-s
260  [s]
261  `(second (get *open-close-pairs-s* ~s)))
262
263;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
264
265(defn first-char
266  "Returns [pos beg seg] or nil"
267  ([pos]
268     (let [[s l] (start-and-len-line pos)]
269       (first-char (get-txtseg s l) s 0 l)))
270  ([seg beg off len]
271     (when (< off len)
272       (if (space? (.charAt seg off))
273         (recur seg beg (inc off) len)
274         [(+ beg off) beg seg]))))
275
276(defn last-char
277  "Returns [pos beg seg first] or nil"
278  [pos]
279  (when-let [a (first-char pos)]
280    (let [[first beg seg] a
281          len (.length seg)]
282      (loop [lof (- first beg)
283             off lof]
284        (if (= off len)
285          [(+ beg lof) beg seg first]
286          (recur (if (space? (.charAt seg off)) lof off) (inc off)))))))
287
288(defn last-code-char
289  "Returns [pos beg seg first] or nil"
290  [pos]
291  (when-let [a (first-char pos)]
292    (let [[first beg seg] a
293          len (.length seg)]
294      (loop [lof nil
295             off (- first beg)
296             lc 0
297             ins? false]
298        (if (= off len)
299          (when lof
300            [(+ beg lof) beg seg first])
301          (let [c (.charAt seg off)]
302            (if ins?
303              (if (dquote? c)
304                (recur off (inc off) c (if (escape? lc) true false))
305                (recur off (inc off) c true))
306              (if (and (comment? c)
307                       (or (zero? off)
308                           (and (pos? off) (not (escape? (.charAt seg (dec off)))))))
309                (when lof
310                  [(+ beg lof) beg seg first])
311                (if (dquote? c)
312                  (recur off (inc off) c (if (escape? lc) false true))
313                  (recur (if (space? c) lof off) (inc off) c false))))))))))
314
315;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
316
317(defn top-level-form
318  "Return pos or nil. All top level forms should start at the first column
319   after a blank line, except at the beginning of the document."
320  [pos]
321  (letfn [(abl [p]
322            (if (= p (get-doc-context :min-pos))
323              p
324              (when-not (last-code-char (dec p))
325                p)))
326          (tlf [p l]
327            (let [s (str-at p)]
328              (if (= s "(")
329                (abl p)
330                (when (and (= s "#")
331                           (re-matches #"^(#_\s*)?\(.*\n$" (str-at p l)))
332                    (abl p)))))]
333    (if-let [p (apply tlf (start-and-len-line pos))]
334      p
335      (loop [pos (start-of-prev-line pos)]
336        (when pos
337          (if-let [p (apply tlf (start-and-len-line pos))]
338            p
339            (recur (start-of-prev-line pos))))))))
340
341;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
342
343(defn fetch-symbol
344  ([ced]
345     (setup-doc-context ced nil
346      (let [pos (get-doc-context :pos)
347            [s l] (start-and-len-line pos)
348            off (- pos s)]
349        (setup-txt-segment s l
350          (if (space? (txtseg-char-at off))
351            (when (pos? off)
352              (when-not (space? (txtseg-char-at (dec off)))
353                (fetch-symbol ced s l (dec off))))
354            (fetch-symbol ced s l off))))))
355  ([ced start len off]
356     (loop [off off]
357       (if (and (pos? off)
358                (not (space? (txtseg-char-at off))))
359         (recur (dec off))
360         (when-let [match (re-matches #"[^\w\*\+\!\-\_\?\.]*([\w\*\+\!\-\_\?\.\$]+).*\n$"
361                                      (.toString (.subSequence *txtseg* off len)))]
362           #_(lg "fetched symbol:" (second match))
363           (second match))))))