complete.el 78 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162
  1. ;;; semantic/complete.el --- Routines for performing tag completion
  2. ;; Copyright (C) 2003-2005, 2007-2012 Free Software Foundation, Inc.
  3. ;; Author: Eric M. Ludlam <zappo@gnu.org>
  4. ;; Keywords: syntax
  5. ;; This file is part of GNU Emacs.
  6. ;; GNU Emacs is free software: you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation, either version 3 of the License, or
  9. ;; (at your option) any later version.
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13. ;; GNU General Public License for more details.
  14. ;; You should have received a copy of the GNU General Public License
  15. ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
  16. ;;; Commentary:
  17. ;;
  18. ;; Completion of tags by name using tables of semantic generated tags.
  19. ;;
  20. ;; While it would be a simple matter of flattening all tag known
  21. ;; tables to perform completion across them using `all-completions',
  22. ;; or `try-completion', that process would be slow. In particular,
  23. ;; when a system database is included in the mix, the potential for a
  24. ;; ludicrous number of options becomes apparent.
  25. ;;
  26. ;; As such, dynamically searching across tables using a prefix,
  27. ;; regular expression, or other feature is needed to help find symbols
  28. ;; quickly without resorting to "show me every possible option now".
  29. ;;
  30. ;; In addition, some symbol names will appear in multiple locations.
  31. ;; If it is important to distinguish, then a way to provide a choice
  32. ;; over these locations is important as well.
  33. ;;
  34. ;; Beyond brute force offers for completion of plain strings,
  35. ;; using the smarts of semantic-analyze to provide reduced lists of
  36. ;; symbols, or fancy tabbing to zoom into files to show multiple hits
  37. ;; of the same name can be provided.
  38. ;;
  39. ;;; How it works:
  40. ;;
  41. ;; There are several parts of any completion engine. They are:
  42. ;;
  43. ;; A. Collection of possible hits
  44. ;; B. Typing or selecting an option
  45. ;; C. Displaying possible unique completions
  46. ;; D. Using the result
  47. ;;
  48. ;; Here, we will treat each section separately (excluding D)
  49. ;; They can then be strung together in user-visible commands to
  50. ;; fulfill specific needs.
  51. ;;
  52. ;; COLLECTORS:
  53. ;;
  54. ;; A collector is an object which represents the means by which tags
  55. ;; to complete on are collected. It's first job is to find all the
  56. ;; tags which are to be completed against. It can also rename
  57. ;; some tags if needed so long as `semantic-tag-clone' is used.
  58. ;;
  59. ;; Some collectors will gather all tags to complete against first
  60. ;; (for in buffer queries, or other small list situations). It may
  61. ;; choose to do a broad search on each completion request. Built in
  62. ;; functionality automatically focuses the cache in as the user types.
  63. ;;
  64. ;; A collector choosing to create and rename tags could choose a
  65. ;; plain name format, a postfix name such as method:class, or a
  66. ;; prefix name such as class.method.
  67. ;;
  68. ;; DISPLAYORS
  69. ;;
  70. ;; A displayor is in charge if showing the user interesting things
  71. ;; about available completions, and can optionally provide a focus.
  72. ;; The simplest display just lists all available names in a separate
  73. ;; window. It may even choose to show short names when there are
  74. ;; many to choose from, or long names when there are fewer.
  75. ;;
  76. ;; A complex displayor could opt to help the user 'focus' on some
  77. ;; range. For example, if 4 tags all have the same name, subsequent
  78. ;; calls to the displayor may opt to show each tag one at a time in
  79. ;; the buffer. When the user likes one, selection would cause the
  80. ;; 'focus' item to be selected.
  81. ;;
  82. ;; CACHE FORMAT
  83. ;;
  84. ;; The format of the tag lists used to perform the completions are in
  85. ;; semanticdb "find" format, like this:
  86. ;;
  87. ;; ( ( DBTABLE1 TAG1 TAG2 ...)
  88. ;; ( DBTABLE2 TAG1 TAG2 ...)
  89. ;; ... )
  90. ;;
  91. ;; INLINE vs MINIBUFFER
  92. ;;
  93. ;; Two major ways completion is used in Emacs is either through a
  94. ;; minibuffer query, or via completion in a normal editing buffer,
  95. ;; encompassing some small range of characters.
  96. ;;
  97. ;; Structure for both types of completion are provided here.
  98. ;; `semantic-complete-read-tag-engine' will use the minibuffer.
  99. ;; `semantic-complete-inline-tag-engine' will complete text in
  100. ;; a buffer.
  101. (eval-when-compile (require 'cl))
  102. (require 'semantic)
  103. (require 'eieio-opt)
  104. (require 'semantic/analyze)
  105. (require 'semantic/ctxt)
  106. (require 'semantic/decorate)
  107. (require 'semantic/format)
  108. (eval-when-compile
  109. ;; For the semantic-find-tags-for-completion macro.
  110. (require 'semantic/find))
  111. ;;; Code:
  112. (defvar semantic-complete-inline-overlay nil
  113. "The overlay currently active while completing inline.")
  114. (defun semantic-completion-inline-active-p ()
  115. "Non-nil if inline completion is active."
  116. (when (and semantic-complete-inline-overlay
  117. (not (semantic-overlay-live-p semantic-complete-inline-overlay)))
  118. (semantic-overlay-delete semantic-complete-inline-overlay)
  119. (setq semantic-complete-inline-overlay nil))
  120. semantic-complete-inline-overlay)
  121. ;;; ------------------------------------------------------------
  122. ;;; MINIBUFFER or INLINE utils
  123. ;;
  124. (defun semantic-completion-text ()
  125. "Return the text that is currently in the completion buffer.
  126. For a minibuffer prompt, this is the minibuffer text.
  127. For inline completion, this is the text wrapped in the inline completion
  128. overlay."
  129. (if semantic-complete-inline-overlay
  130. (semantic-complete-inline-text)
  131. (minibuffer-contents)))
  132. (defun semantic-completion-delete-text ()
  133. "Delete the text that is actively being completed.
  134. Presumably if you call this you will insert something new there."
  135. (if semantic-complete-inline-overlay
  136. (semantic-complete-inline-delete-text)
  137. (delete-minibuffer-contents)))
  138. (defun semantic-completion-message (fmt &rest args)
  139. "Display the string FMT formatted with ARGS at the end of the minibuffer."
  140. (if semantic-complete-inline-overlay
  141. (apply 'message fmt args)
  142. (message (concat (buffer-string) (apply 'format fmt args)))))
  143. ;;; ------------------------------------------------------------
  144. ;;; MINIBUFFER: Option Selection harnesses
  145. ;;
  146. (defvar semantic-completion-collector-engine nil
  147. "The tag collector for the current completion operation.
  148. Value should be an object of a subclass of
  149. `semantic-completion-engine-abstract'.")
  150. (defvar semantic-completion-display-engine nil
  151. "The tag display engine for the current completion operation.
  152. Value should be a ... what?")
  153. (defvar semantic-complete-key-map
  154. (let ((km (make-sparse-keymap)))
  155. (define-key km " " 'semantic-complete-complete-space)
  156. (define-key km "\t" 'semantic-complete-complete-tab)
  157. (define-key km "\C-m" 'semantic-complete-done)
  158. (define-key km "\C-g" 'abort-recursive-edit)
  159. (define-key km "\M-n" 'next-history-element)
  160. (define-key km "\M-p" 'previous-history-element)
  161. (define-key km "\C-n" 'next-history-element)
  162. (define-key km "\C-p" 'previous-history-element)
  163. ;; Add history navigation
  164. km)
  165. "Keymap used while completing across a list of tags.")
  166. (defvar semantic-completion-default-history nil
  167. "Default history variable for any unhistoried prompt.
  168. Keeps STRINGS only in the history.")
  169. (defun semantic-complete-read-tag-engine (collector displayor prompt
  170. default-tag initial-input
  171. history)
  172. "Read a semantic tag, and return a tag for the selection.
  173. Argument COLLECTOR is an object which can be used to calculate
  174. a list of possible hits. See `semantic-completion-collector-engine'
  175. for details on COLLECTOR.
  176. Argument DISPLAYOR is an object used to display a list of possible
  177. completions for a given prefix. See`semantic-completion-display-engine'
  178. for details on DISPLAYOR.
  179. PROMPT is a string to prompt with.
  180. DEFAULT-TAG is a semantic tag or string to use as the default value.
  181. If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
  182. HISTORY is a symbol representing a variable to story the history in."
  183. (let* ((semantic-completion-collector-engine collector)
  184. (semantic-completion-display-engine displayor)
  185. (semantic-complete-active-default nil)
  186. (semantic-complete-current-matched-tag nil)
  187. (default-as-tag (semantic-complete-default-to-tag default-tag))
  188. (default-as-string (when (semantic-tag-p default-as-tag)
  189. (semantic-tag-name default-as-tag)))
  190. )
  191. (when default-as-string
  192. ;; Add this to the prompt.
  193. ;;
  194. ;; I really want to add a lookup of the symbol in those
  195. ;; tags available to the collector and only add it if it
  196. ;; is available as a possibility, but I'm too lazy right
  197. ;; now.
  198. ;;
  199. ;; @todo - move from () to into the editable area
  200. (if (string-match ":" prompt)
  201. (setq prompt (concat
  202. (substring prompt 0 (match-beginning 0))
  203. " (default " default-as-string ")"
  204. (substring prompt (match-beginning 0))))
  205. (setq prompt (concat prompt " (" default-as-string "): "))))
  206. ;;
  207. ;; Perform the Completion
  208. ;;
  209. (unwind-protect
  210. (read-from-minibuffer prompt
  211. initial-input
  212. semantic-complete-key-map
  213. nil
  214. (or history
  215. 'semantic-completion-default-history)
  216. default-tag)
  217. (semantic-collector-cleanup semantic-completion-collector-engine)
  218. (semantic-displayor-cleanup semantic-completion-display-engine)
  219. )
  220. ;;
  221. ;; Extract the tag from the completion machinery.
  222. ;;
  223. semantic-complete-current-matched-tag
  224. ))
  225. ;;; Util for basic completion prompts
  226. ;;
  227. (defvar semantic-complete-active-default nil
  228. "The current default tag calculated for this prompt.")
  229. (defun semantic-complete-default-to-tag (default)
  230. "Convert a calculated or passed in DEFAULT into a tag."
  231. (if (semantic-tag-p default)
  232. ;; Just return what was passed in.
  233. (setq semantic-complete-active-default default)
  234. ;; If none was passed in, guess.
  235. (if (null default)
  236. (setq default (semantic-ctxt-current-thing)))
  237. (if (null default)
  238. ;; Do nothing
  239. nil
  240. ;; Turn default into something useful.
  241. (let ((str
  242. (cond
  243. ;; Semantic-ctxt-current-symbol will return a list of
  244. ;; strings. Technically, we should use the analyzer to
  245. ;; fully extract what we need, but for now, just grab the
  246. ;; first string
  247. ((and (listp default) (stringp (car default)))
  248. (car default))
  249. ((stringp default)
  250. default)
  251. ((symbolp default)
  252. (symbol-name default))
  253. (t
  254. (signal 'wrong-type-argument
  255. (list default 'semantic-tag-p)))))
  256. (tag nil))
  257. ;; Now that we have that symbol string, look it up using the active
  258. ;; collector. If we get a match, use it.
  259. (save-excursion
  260. (semantic-collector-calculate-completions
  261. semantic-completion-collector-engine
  262. str nil))
  263. ;; Do we have the perfect match???
  264. (let ((ml (semantic-collector-current-exact-match
  265. semantic-completion-collector-engine)))
  266. (when ml
  267. ;; We don't care about uniqueness. Just guess for convenience
  268. (setq tag (semanticdb-find-result-nth-in-buffer ml 0))))
  269. ;; save it
  270. (setq semantic-complete-active-default tag)
  271. ;; Return it.. .whatever it may be
  272. tag))))
  273. ;;; Prompt Return Value
  274. ;;
  275. ;; Getting a return value out of this completion prompt is a bit
  276. ;; challenging. The read command returns the string typed in.
  277. ;; We need to convert this into a valid tag. We can exit the minibuffer
  278. ;; for different reasons. If we purposely exit, we must make sure
  279. ;; the focused tag is calculated... preferably once.
  280. (defvar semantic-complete-current-matched-tag nil
  281. "Variable used to pass the tags being matched to the prompt.")
  282. ;; semantic-displayor-focus-abstract-child-p is part of the
  283. ;; semantic-displayor-focus-abstract class, defined later in this
  284. ;; file.
  285. (declare-function semantic-displayor-focus-abstract-child-p "semantic/complete"
  286. t t)
  287. (defun semantic-complete-current-match ()
  288. "Calculate a match from the current completion environment.
  289. Save this in our completion variable. Make sure that variable
  290. is cleared if any other keypress is made.
  291. Return value can be:
  292. tag - a single tag that has been matched.
  293. string - a message to show in the minibuffer."
  294. ;; Query the environment for an active completion.
  295. (let ((collector semantic-completion-collector-engine)
  296. (displayor semantic-completion-display-engine)
  297. (contents (semantic-completion-text))
  298. matchlist
  299. answer)
  300. (if (string= contents "")
  301. ;; The user wants the defaults!
  302. (setq answer semantic-complete-active-default)
  303. ;; This forces a full calculation of completion on CR.
  304. (save-excursion
  305. (semantic-collector-calculate-completions collector contents nil))
  306. (semantic-complete-try-completion)
  307. (cond
  308. ;; Input match displayor focus entry
  309. ((setq answer (semantic-displayor-current-focus displayor))
  310. ;; We have answer, continue
  311. )
  312. ;; One match from the collector
  313. ((setq matchlist (semantic-collector-current-exact-match collector))
  314. (if (= (semanticdb-find-result-length matchlist) 1)
  315. (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0))
  316. (if (semantic-displayor-focus-abstract-child-p displayor)
  317. ;; For focusing displayors, we can claim this is
  318. ;; not unique. Multiple focuses can choose the correct
  319. ;; one.
  320. (setq answer "Not Unique")
  321. ;; If we don't have a focusing displayor, we need to do something
  322. ;; graceful. First, see if all the matches have the same name.
  323. (let ((allsame t)
  324. (firstname (semantic-tag-name
  325. (car
  326. (semanticdb-find-result-nth matchlist 0)))
  327. )
  328. (cnt 1)
  329. (max (semanticdb-find-result-length matchlist)))
  330. (while (and allsame (< cnt max))
  331. (if (not (string=
  332. firstname
  333. (semantic-tag-name
  334. (car
  335. (semanticdb-find-result-nth matchlist cnt)))))
  336. (setq allsame nil))
  337. (setq cnt (1+ cnt))
  338. )
  339. ;; Now we know if they are all the same. If they are, just
  340. ;; accept the first, otherwise complain.
  341. (if allsame
  342. (setq answer (semanticdb-find-result-nth-in-buffer
  343. matchlist 0))
  344. (setq answer "Not Unique"))
  345. ))))
  346. ;; No match
  347. (t
  348. (setq answer "No Match")))
  349. )
  350. ;; Set it into our completion target.
  351. (when (semantic-tag-p answer)
  352. (setq semantic-complete-current-matched-tag answer)
  353. ;; Make sure it is up to date by clearing it if the user dares
  354. ;; to touch the keyboard.
  355. (add-hook 'pre-command-hook
  356. (lambda () (setq semantic-complete-current-matched-tag nil)))
  357. )
  358. ;; Return it
  359. answer
  360. ))
  361. ;;; Keybindings
  362. ;;
  363. ;; Keys are bound to perform completion using our mechanisms.
  364. ;; Do that work here.
  365. (defun semantic-complete-done ()
  366. "Accept the current input."
  367. (interactive)
  368. (let ((ans (semantic-complete-current-match)))
  369. (if (stringp ans)
  370. (semantic-completion-message (concat " [" ans "]"))
  371. (exit-minibuffer)))
  372. )
  373. (defun semantic-complete-complete-space ()
  374. "Complete the partial input in the minibuffer."
  375. (interactive)
  376. (semantic-complete-do-completion t))
  377. (defun semantic-complete-complete-tab ()
  378. "Complete the partial input in the minibuffer as far as possible."
  379. (interactive)
  380. (semantic-complete-do-completion))
  381. ;;; Completion Functions
  382. ;;
  383. ;; Thees routines are functional entry points to performing completion.
  384. ;;
  385. (defun semantic-complete-hack-word-boundaries (original new)
  386. "Return a string to use for completion.
  387. ORIGINAL is the text in the minibuffer.
  388. NEW is the new text to insert into the minibuffer.
  389. Within the difference bounds of ORIGINAL and NEW, shorten NEW
  390. to the nearest word boundary, and return that."
  391. (save-match-data
  392. (let* ((diff (substring new (length original)))
  393. (end (string-match "\\>" diff))
  394. (start (string-match "\\<" diff)))
  395. (cond
  396. ((and start (> start 0))
  397. ;; If start is greater than 0, include only the new
  398. ;; white-space stuff
  399. (concat original (substring diff 0 start)))
  400. (end
  401. (concat original (substring diff 0 end)))
  402. (t new)))))
  403. (defun semantic-complete-try-completion (&optional partial)
  404. "Try a completion for the current minibuffer.
  405. If PARTIAL, do partial completion stopping at spaces."
  406. (let ((comp (semantic-collector-try-completion
  407. semantic-completion-collector-engine
  408. (semantic-completion-text))))
  409. (cond
  410. ((null comp)
  411. (semantic-completion-message " [No Match]")
  412. (ding)
  413. )
  414. ((stringp comp)
  415. (if (string= (semantic-completion-text) comp)
  416. (when partial
  417. ;; Minibuffer isn't changing AND the text is not unique.
  418. ;; Test for partial completion over a word separator character.
  419. ;; If there is one available, use that so that SPC can
  420. ;; act like a SPC insert key.
  421. (let ((newcomp (semantic-collector-current-whitespace-completion
  422. semantic-completion-collector-engine)))
  423. (when newcomp
  424. (semantic-completion-delete-text)
  425. (insert newcomp))
  426. ))
  427. (when partial
  428. (let ((orig (semantic-completion-text)))
  429. ;; For partial completion, we stop and step over
  430. ;; word boundaries. Use this nifty function to do
  431. ;; that calculation for us.
  432. (setq comp
  433. (semantic-complete-hack-word-boundaries orig comp))))
  434. ;; Do the replacement.
  435. (semantic-completion-delete-text)
  436. (insert comp))
  437. )
  438. ((and (listp comp) (semantic-tag-p (car comp)))
  439. (unless (string= (semantic-completion-text)
  440. (semantic-tag-name (car comp)))
  441. ;; A fully unique completion was available.
  442. (semantic-completion-delete-text)
  443. (insert (semantic-tag-name (car comp))))
  444. ;; The match is complete
  445. (if (= (length comp) 1)
  446. (semantic-completion-message " [Complete]")
  447. (semantic-completion-message " [Complete, but not unique]"))
  448. )
  449. (t nil))))
  450. (defun semantic-complete-do-completion (&optional partial inline)
  451. "Do a completion for the current minibuffer.
  452. If PARTIAL, do partial completion stopping at spaces.
  453. if INLINE, then completion is happening inline in a buffer."
  454. (let* ((collector semantic-completion-collector-engine)
  455. (displayor semantic-completion-display-engine)
  456. (contents (semantic-completion-text))
  457. (ans nil))
  458. (save-excursion
  459. (semantic-collector-calculate-completions collector contents partial))
  460. (let* ((na (semantic-complete-next-action partial)))
  461. (cond
  462. ;; We're all done, but only from a very specific
  463. ;; area of completion.
  464. ((eq na 'done)
  465. (semantic-completion-message " [Complete]")
  466. (setq ans 'done))
  467. ;; Perform completion
  468. ((or (eq na 'complete)
  469. (eq na 'complete-whitespace))
  470. (semantic-complete-try-completion partial)
  471. (setq ans 'complete))
  472. ;; We need to display the completions.
  473. ;; Set the completions into the display engine
  474. ((or (eq na 'display) (eq na 'displayend))
  475. (semantic-displayor-set-completions
  476. displayor
  477. (or
  478. ;; For the below - This caused problems for Chong Yidong
  479. ;; when experimenting with the completion engine. I don't
  480. ;; remember what the problem was though, and I wasn't sure why
  481. ;; the below two lines were there since they obviously added
  482. ;; some odd behavior. -EML
  483. ;; (and (not (eq na 'displayend))
  484. ;; (semantic-collector-current-exact-match collector))
  485. (semantic-collector-all-completions collector contents))
  486. contents)
  487. ;; Ask the displayor to display them.
  488. (semantic-displayor-show-request displayor))
  489. ((eq na 'scroll)
  490. (semantic-displayor-scroll-request displayor)
  491. )
  492. ((eq na 'focus)
  493. (semantic-displayor-focus-next displayor)
  494. (semantic-displayor-focus-request displayor)
  495. )
  496. ((eq na 'empty)
  497. (semantic-completion-message " [No Match]"))
  498. (t nil)))
  499. ans))
  500. ;;; ------------------------------------------------------------
  501. ;;; INLINE: tag completion harness
  502. ;;
  503. ;; Unlike the minibuffer, there is no mode nor other traditional
  504. ;; means of reading user commands in completion mode. Instead
  505. ;; we use a pre-command-hook to inset in our commands, and to
  506. ;; push ourselves out of this mode on alternate keypresses.
  507. (defvar semantic-complete-inline-map
  508. (let ((km (make-sparse-keymap)))
  509. (define-key km "\C-i" 'semantic-complete-inline-TAB)
  510. (define-key km "\M-p" 'semantic-complete-inline-up)
  511. (define-key km "\M-n" 'semantic-complete-inline-down)
  512. (define-key km "\C-m" 'semantic-complete-inline-done)
  513. (define-key km "\C-\M-c" 'semantic-complete-inline-exit)
  514. (define-key km "\C-g" 'semantic-complete-inline-quit)
  515. (define-key km "?"
  516. (lambda () (interactive)
  517. (describe-variable 'semantic-complete-inline-map)))
  518. km)
  519. "Keymap used while performing Semantic inline completion.")
  520. (defface semantic-complete-inline-face
  521. '((((class color) (background dark))
  522. (:underline "yellow"))
  523. (((class color) (background light))
  524. (:underline "brown")))
  525. "*Face used to show the region being completed inline.
  526. The face is used in `semantic-complete-inline-tag-engine'."
  527. :group 'semantic-faces)
  528. (defun semantic-complete-inline-text ()
  529. "Return the text that is being completed inline.
  530. Similar to `minibuffer-contents' when completing in the minibuffer."
  531. (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
  532. (e (semantic-overlay-end semantic-complete-inline-overlay)))
  533. (if (= s e)
  534. ""
  535. (buffer-substring-no-properties s e ))))
  536. (defun semantic-complete-inline-delete-text ()
  537. "Delete the text currently being completed in the current buffer."
  538. (delete-region
  539. (semantic-overlay-start semantic-complete-inline-overlay)
  540. (semantic-overlay-end semantic-complete-inline-overlay)))
  541. (defun semantic-complete-inline-done ()
  542. "This completion thing is DONE, OR, insert a newline."
  543. (interactive)
  544. (let* ((displayor semantic-completion-display-engine)
  545. (tag (semantic-displayor-current-focus displayor)))
  546. (if tag
  547. (let ((txt (semantic-completion-text)))
  548. (insert (substring (semantic-tag-name tag)
  549. (length txt)))
  550. (semantic-complete-inline-exit))
  551. ;; Get whatever binding RET usually has.
  552. (let ((fcn
  553. (condition-case nil
  554. (lookup-key (current-active-maps) (this-command-keys))
  555. (error
  556. ;; I don't know why, but for some reason the above
  557. ;; throws an error sometimes.
  558. (lookup-key (current-global-map) (this-command-keys))
  559. ))))
  560. (when fcn
  561. (funcall fcn)))
  562. )))
  563. (defun semantic-complete-inline-quit ()
  564. "Quit an inline edit."
  565. (interactive)
  566. (semantic-complete-inline-exit)
  567. (keyboard-quit))
  568. (defun semantic-complete-inline-exit ()
  569. "Exit inline completion mode."
  570. (interactive)
  571. ;; Remove this hook FIRST!
  572. (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
  573. (condition-case nil
  574. (progn
  575. (when semantic-completion-collector-engine
  576. (semantic-collector-cleanup semantic-completion-collector-engine))
  577. (when semantic-completion-display-engine
  578. (semantic-displayor-cleanup semantic-completion-display-engine))
  579. (when semantic-complete-inline-overlay
  580. (let ((wc (semantic-overlay-get semantic-complete-inline-overlay
  581. 'window-config-start))
  582. (buf (semantic-overlay-buffer semantic-complete-inline-overlay))
  583. )
  584. (semantic-overlay-delete semantic-complete-inline-overlay)
  585. (setq semantic-complete-inline-overlay nil)
  586. ;; DONT restore the window configuration if we just
  587. ;; switched windows!
  588. (when (eq buf (current-buffer))
  589. (set-window-configuration wc))
  590. ))
  591. (setq semantic-completion-collector-engine nil
  592. semantic-completion-display-engine nil))
  593. (error nil))
  594. ;; Remove this hook LAST!!!
  595. ;; This will force us back through this function if there was
  596. ;; some sort of error above.
  597. (remove-hook 'post-command-hook 'semantic-complete-post-command-hook)
  598. ;;(message "Exiting inline completion.")
  599. )
  600. (defun semantic-complete-pre-command-hook ()
  601. "Used to redefine what commands are being run while completing.
  602. When installed as a `pre-command-hook' the special keymap
  603. `semantic-complete-inline-map' is queried to replace commands normally run.
  604. Commands which edit what is in the region of interest operate normally.
  605. Commands which would take us out of the region of interest, or our
  606. quit hook, will exit this completion mode."
  607. (let ((fcn (lookup-key semantic-complete-inline-map
  608. (this-command-keys) nil)))
  609. (cond ((commandp fcn)
  610. (setq this-command fcn))
  611. (t nil)))
  612. )
  613. (defun semantic-complete-post-command-hook ()
  614. "Used to determine if we need to exit inline completion mode.
  615. If completion mode is active, check to see if we are within
  616. the bounds of `semantic-complete-inline-overlay', or within
  617. a reasonable distance."
  618. (condition-case nil
  619. ;; Exit if something bad happened.
  620. (if (not semantic-complete-inline-overlay)
  621. (progn
  622. ;;(message "Inline Hook installed, but overlay deleted.")
  623. (semantic-complete-inline-exit))
  624. ;; Exit if commands caused us to exit the area of interest
  625. (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
  626. (e (semantic-overlay-end semantic-complete-inline-overlay))
  627. (b (semantic-overlay-buffer semantic-complete-inline-overlay))
  628. (txt nil)
  629. )
  630. (cond
  631. ;; EXIT when we are no longer in a good place.
  632. ((or (not (eq b (current-buffer)))
  633. (< (point) s)
  634. (> (point) e))
  635. ;;(message "Exit: %S %S %S" s e (point))
  636. (semantic-complete-inline-exit)
  637. )
  638. ;; Exit if the user typed in a character that is not part
  639. ;; of the symbol being completed.
  640. ((and (setq txt (semantic-completion-text))
  641. (not (string= txt ""))
  642. (and (/= (point) s)
  643. (save-excursion
  644. (forward-char -1)
  645. (not (looking-at "\\(\\w\\|\\s_\\)")))))
  646. ;;(message "Non symbol character.")
  647. (semantic-complete-inline-exit))
  648. ((lookup-key semantic-complete-inline-map
  649. (this-command-keys) nil)
  650. ;; If the last command was one of our completion commands,
  651. ;; then do nothing.
  652. nil
  653. )
  654. (t
  655. ;; Else, show completions now
  656. (semantic-complete-inline-force-display)
  657. ))))
  658. ;; If something goes terribly wrong, clean up after ourselves.
  659. (error (semantic-complete-inline-exit))))
  660. (defun semantic-complete-inline-force-display ()
  661. "Force the display of whatever the current completions are.
  662. DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE."
  663. (condition-case e
  664. (save-excursion
  665. (let ((collector semantic-completion-collector-engine)
  666. (displayor semantic-completion-display-engine)
  667. (contents (semantic-completion-text)))
  668. (when collector
  669. (semantic-collector-calculate-completions
  670. collector contents nil)
  671. (semantic-displayor-set-completions
  672. displayor
  673. (semantic-collector-all-completions collector contents)
  674. contents)
  675. ;; Ask the displayor to display them.
  676. (semantic-displayor-show-request displayor))
  677. ))
  678. (error (message "Bug Showing Completions: %S" e))))
  679. (defun semantic-complete-inline-tag-engine
  680. (collector displayor buffer start end)
  681. "Perform completion based on semantic tags in a buffer.
  682. Argument COLLECTOR is an object which can be used to calculate
  683. a list of possible hits. See `semantic-completion-collector-engine'
  684. for details on COLLECTOR.
  685. Argument DISPLAYOR is an object used to display a list of possible
  686. completions for a given prefix. See`semantic-completion-display-engine'
  687. for details on DISPLAYOR.
  688. BUFFER is the buffer in which completion will take place.
  689. START is a location for the start of the full symbol.
  690. If the symbol being completed is \"foo.ba\", then START
  691. is on the \"f\" character.
  692. END is at the end of the current symbol being completed."
  693. ;; Set us up for doing completion
  694. (setq semantic-completion-collector-engine collector
  695. semantic-completion-display-engine displayor)
  696. ;; Create an overlay
  697. (setq semantic-complete-inline-overlay
  698. (semantic-make-overlay start end buffer nil t))
  699. (semantic-overlay-put semantic-complete-inline-overlay
  700. 'face
  701. 'semantic-complete-inline-face)
  702. (semantic-overlay-put semantic-complete-inline-overlay
  703. 'window-config-start
  704. (current-window-configuration))
  705. ;; Install our command hooks
  706. (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
  707. (add-hook 'post-command-hook 'semantic-complete-post-command-hook)
  708. ;; Go!
  709. (semantic-complete-inline-force-display)
  710. )
  711. ;;; Inline Completion Keymap Functions
  712. ;;
  713. (defun semantic-complete-inline-TAB ()
  714. "Perform inline completion."
  715. (interactive)
  716. (let ((cmpl (semantic-complete-do-completion nil t)))
  717. (cond
  718. ((eq cmpl 'complete)
  719. (semantic-complete-inline-force-display))
  720. ((eq cmpl 'done)
  721. (semantic-complete-inline-done))
  722. ))
  723. )
  724. (defun semantic-complete-inline-down()
  725. "Focus forwards through the displayor."
  726. (interactive)
  727. (let ((displayor semantic-completion-display-engine))
  728. (semantic-displayor-focus-next displayor)
  729. (semantic-displayor-focus-request displayor)
  730. ))
  731. (defun semantic-complete-inline-up ()
  732. "Focus backwards through the displayor."
  733. (interactive)
  734. (let ((displayor semantic-completion-display-engine))
  735. (semantic-displayor-focus-previous displayor)
  736. (semantic-displayor-focus-request displayor)
  737. ))
  738. ;;; ------------------------------------------------------------
  739. ;;; Interactions between collection and displaying
  740. ;;
  741. ;; Functional routines used to help collectors communicate with
  742. ;; the current displayor, or for the previous section.
  743. (defun semantic-complete-next-action (partial)
  744. "Determine what the next completion action should be.
  745. PARTIAL is non-nil if we are doing partial completion.
  746. First, the collector can determine if we should perform a completion or not.
  747. If there is nothing to complete, then the displayor determines if we are
  748. to show a completion list, scroll, or perhaps do a focus (if it is capable.)
  749. Expected return values are:
  750. done -> We have a singular match
  751. empty -> There are no matches to the current text
  752. complete -> Perform a completion action
  753. complete-whitespace -> Complete next whitespace type character.
  754. display -> Show the list of completions
  755. scroll -> The completions have been shown, and the user keeps hitting
  756. the complete button. If possible, scroll the completions
  757. focus -> The displayor knows how to shift focus among possible completions.
  758. Let it do that.
  759. displayend -> Whatever options the displayor had for repeating options, there
  760. are none left. Try something new."
  761. (let ((ans1 (semantic-collector-next-action
  762. semantic-completion-collector-engine
  763. partial))
  764. (ans2 (semantic-displayor-next-action
  765. semantic-completion-display-engine))
  766. )
  767. (cond
  768. ;; No collector answer, use displayor answer.
  769. ((not ans1)
  770. ans2)
  771. ;; Displayor selection of 'scroll, 'display, or 'focus trumps
  772. ;; 'done
  773. ((and (eq ans1 'done) ans2)
  774. ans2)
  775. ;; Use ans1 when we have it.
  776. (t
  777. ans1))))
  778. ;;; ------------------------------------------------------------
  779. ;;; Collection Engines
  780. ;;
  781. ;; Collection engines can scan tags from the current environment and
  782. ;; provide lists of possible completions.
  783. ;;
  784. ;; General features of the abstract collector:
  785. ;; * Cache completion lists between uses
  786. ;; * Cache itself per buffer. Handle reparse hooks
  787. ;;
  788. ;; Key Interface Functions to implement:
  789. ;; * semantic-collector-next-action
  790. ;; * semantic-collector-calculate-completions
  791. ;; * semantic-collector-try-completion
  792. ;; * semantic-collector-all-completions
  793. (defvar semantic-collector-per-buffer-list nil
  794. "List of collectors active in this buffer.")
  795. (make-variable-buffer-local 'semantic-collector-per-buffer-list)
  796. (defvar semantic-collector-list nil
  797. "List of global collectors active this session.")
  798. (defclass semantic-collector-abstract ()
  799. ((buffer :initarg :buffer
  800. :type buffer
  801. :documentation "Originating buffer for this collector.
  802. Some collectors use a given buffer as a starting place while looking up
  803. tags.")
  804. (cache :initform nil
  805. :type (or null semanticdb-find-result-with-nil)
  806. :documentation "Cache of tags.
  807. These tags are re-used during a completion session.
  808. Sometimes these tags are cached between completion sessions.")
  809. (last-all-completions :initarg nil
  810. :type semanticdb-find-result-with-nil
  811. :documentation "Last result of `all-completions'.
  812. This result can be used for refined completions as `last-prefix' gets
  813. closer to a specific result.")
  814. (last-prefix :type string
  815. :protection :protected
  816. :documentation "The last queried prefix.
  817. This prefix can be used to cache intermediate completion offers.
  818. making the action of homing in on a token faster.")
  819. (last-completion :type (or null string)
  820. :documentation "The last calculated completion.
  821. This completion is calculated and saved for future use.")
  822. (last-whitespace-completion :type (or null string)
  823. :documentation "The last whitespace completion.
  824. For partial completion, SPC will disambiguate over whitespace type
  825. characters. This is the last calculated version.")
  826. (current-exact-match :type list
  827. :protection :protected
  828. :documentation "The list of matched tags.
  829. When tokens are matched, they are added to this list.")
  830. )
  831. "Root class for completion engines.
  832. The baseclass provides basic functionality for interacting with
  833. a completion displayor object, and tracking the current progress
  834. of a completion."
  835. :abstract t)
  836. (defmethod semantic-collector-cleanup ((obj semantic-collector-abstract))
  837. "Clean up any mess this collector may have."
  838. nil)
  839. (defmethod semantic-collector-next-action
  840. ((obj semantic-collector-abstract) partial)
  841. "What should we do next? OBJ can predict a next good action.
  842. PARTIAL indicates if we are doing a partial completion."
  843. (if (and (slot-boundp obj 'last-completion)
  844. (string= (semantic-completion-text) (oref obj last-completion)))
  845. (let* ((cem (semantic-collector-current-exact-match obj))
  846. (cemlen (semanticdb-find-result-length cem))
  847. (cac (semantic-collector-all-completions
  848. obj (semantic-completion-text)))
  849. (caclen (semanticdb-find-result-length cac)))
  850. (cond ((and cem (= cemlen 1)
  851. cac (> caclen 1)
  852. (eq last-command this-command))
  853. ;; Defer to the displayor...
  854. nil)
  855. ((and cem (= cemlen 1))
  856. 'done)
  857. ((and (not cem) (not cac))
  858. 'empty)
  859. ((and partial (semantic-collector-try-completion-whitespace
  860. obj (semantic-completion-text)))
  861. 'complete-whitespace)))
  862. 'complete))
  863. (defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract)
  864. last-prefix)
  865. "Return non-nil if OBJ's prefix matches PREFIX."
  866. (and (slot-boundp obj 'last-prefix)
  867. (string= (oref obj last-prefix) last-prefix)))
  868. (defmethod semantic-collector-get-cache ((obj semantic-collector-abstract))
  869. "Get the raw cache of tags for completion.
  870. Calculate the cache if there isn't one."
  871. (or (oref obj cache)
  872. (semantic-collector-calculate-cache obj)))
  873. (defmethod semantic-collector-calculate-completions-raw
  874. ((obj semantic-collector-abstract) prefix completionlist)
  875. "Calculate the completions for prefix from completionlist.
  876. Output must be in semanticdb Find result format."
  877. ;; Must output in semanticdb format
  878. (let ((table (with-current-buffer (oref obj buffer)
  879. semanticdb-current-table))
  880. (result (semantic-find-tags-for-completion
  881. prefix
  882. ;; To do this kind of search with a pre-built completion
  883. ;; list, we need to strip it first.
  884. (semanticdb-strip-find-results completionlist)))
  885. )
  886. (if result
  887. (list (cons table result)))))
  888. (defmethod semantic-collector-calculate-completions
  889. ((obj semantic-collector-abstract) prefix partial)
  890. "Calculate completions for prefix as setup for other queries."
  891. (let* ((case-fold-search semantic-case-fold)
  892. (same-prefix-p (semantic-collector-last-prefix= obj prefix))
  893. (completionlist
  894. (if (or same-prefix-p
  895. (and (slot-boundp obj 'last-prefix)
  896. (eq (compare-strings (oref obj last-prefix) 0 nil
  897. prefix 0 (length prefix))
  898. t)))
  899. ;; New prefix is subset of old prefix
  900. (oref obj last-all-completions)
  901. (semantic-collector-get-cache obj)))
  902. ;; Get the result
  903. (answer (if same-prefix-p
  904. completionlist
  905. (semantic-collector-calculate-completions-raw
  906. obj prefix completionlist))
  907. )
  908. (completion nil)
  909. (complete-not-uniq nil)
  910. )
  911. ;;(semanticdb-find-result-test answer)
  912. (when (not same-prefix-p)
  913. ;; Save results if it is interesting and beneficial
  914. (oset obj last-prefix prefix)
  915. (oset obj last-all-completions answer))
  916. ;; Now calculate the completion.
  917. (setq completion (try-completion
  918. prefix
  919. (semanticdb-strip-find-results answer)))
  920. (oset obj last-whitespace-completion nil)
  921. (oset obj current-exact-match nil)
  922. ;; Only do this if a completion was found. Letting a nil in
  923. ;; could cause a full semanticdb search by accident.
  924. (when completion
  925. (oset obj last-completion
  926. (cond
  927. ;; Unique match in AC. Last completion is a match.
  928. ;; Also set the current-exact-match.
  929. ((eq completion t)
  930. (oset obj current-exact-match answer)
  931. prefix)
  932. ;; It may be complete (a symbol) but still not unique.
  933. ;; We can capture a match
  934. ((setq complete-not-uniq
  935. (semanticdb-find-tags-by-name
  936. prefix
  937. answer))
  938. (oset obj current-exact-match
  939. complete-not-uniq)
  940. prefix
  941. )
  942. ;; Non unique match, return the string that handles
  943. ;; completion
  944. (t (or completion prefix))
  945. )))
  946. ))
  947. (defmethod semantic-collector-try-completion-whitespace
  948. ((obj semantic-collector-abstract) prefix)
  949. "For OBJ, do whitespace completion based on PREFIX.
  950. This implies that if there are two completions, one matching
  951. the test \"prefix\\>\", and one not, the one matching the full
  952. word version of PREFIX will be chosen, and that text returned.
  953. This function requires that `semantic-collector-calculate-completions'
  954. has been run first."
  955. (let* ((ac (semantic-collector-all-completions obj prefix))
  956. (matchme (concat "^" prefix "\\>"))
  957. (compare (semanticdb-find-tags-by-name-regexp matchme ac))
  958. (numtag (semanticdb-find-result-length compare))
  959. )
  960. (if compare
  961. (let* ((idx 0)
  962. (cutlen (1+ (length prefix)))
  963. (twws (semanticdb-find-result-nth compare idx)))
  964. ;; Is our tag with whitespace a match that has whitespace
  965. ;; after it, or just an already complete symbol?
  966. (while (and (< idx numtag)
  967. (< (length (semantic-tag-name (car twws))) cutlen))
  968. (setq idx (1+ idx)
  969. twws (semanticdb-find-result-nth compare idx)))
  970. (when (and twws (car-safe twws))
  971. ;; If COMPARE has succeeded, then we should take the very
  972. ;; first match, and extend prefix by one character.
  973. (oset obj last-whitespace-completion
  974. (substring (semantic-tag-name (car twws))
  975. 0 cutlen))))
  976. )))
  977. (defmethod semantic-collector-current-exact-match ((obj semantic-collector-abstract))
  978. "Return the active valid MATCH from the semantic collector.
  979. For now, just return the first element from our list of available
  980. matches. For semanticdb based results, make sure the file is loaded
  981. into a buffer."
  982. (when (slot-boundp obj 'current-exact-match)
  983. (oref obj current-exact-match)))
  984. (defmethod semantic-collector-current-whitespace-completion ((obj semantic-collector-abstract))
  985. "Return the active whitespace completion value."
  986. (when (slot-boundp obj 'last-whitespace-completion)
  987. (oref obj last-whitespace-completion)))
  988. (defmethod semantic-collector-get-match ((obj semantic-collector-abstract))
  989. "Return the active valid MATCH from the semantic collector.
  990. For now, just return the first element from our list of available
  991. matches. For semanticdb based results, make sure the file is loaded
  992. into a buffer."
  993. (when (slot-boundp obj 'current-exact-match)
  994. (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0)))
  995. (defmethod semantic-collector-all-completions
  996. ((obj semantic-collector-abstract) prefix)
  997. "For OBJ, retrieve all completions matching PREFIX.
  998. The returned list consists of all the tags currently
  999. matching PREFIX."
  1000. (when (slot-boundp obj 'last-all-completions)
  1001. (oref obj last-all-completions)))
  1002. (defmethod semantic-collector-try-completion
  1003. ((obj semantic-collector-abstract) prefix)
  1004. "For OBJ, attempt to match PREFIX.
  1005. See `try-completion' for details on how this works.
  1006. Return nil for no match.
  1007. Return a string for a partial match.
  1008. For a unique match of PREFIX, return the list of all tags
  1009. with that name."
  1010. (if (slot-boundp obj 'last-completion)
  1011. (oref obj last-completion)))
  1012. (defmethod semantic-collector-calculate-cache
  1013. ((obj semantic-collector-abstract))
  1014. "Calculate the completion cache for OBJ."
  1015. nil
  1016. )
  1017. (defmethod semantic-collector-flush ((this semantic-collector-abstract))
  1018. "Flush THIS collector object, clearing any caches and prefix."
  1019. (oset this cache nil)
  1020. (slot-makeunbound this 'last-prefix)
  1021. (slot-makeunbound this 'last-completion)
  1022. (slot-makeunbound this 'last-all-completions)
  1023. (slot-makeunbound this 'current-exact-match)
  1024. )
  1025. ;;; PER BUFFER
  1026. ;;
  1027. (defclass semantic-collector-buffer-abstract (semantic-collector-abstract)
  1028. ()
  1029. "Root class for per-buffer completion engines.
  1030. These collectors track themselves on a per-buffer basis."
  1031. :abstract t)
  1032. (defmethod constructor :STATIC ((this semantic-collector-buffer-abstract)
  1033. newname &rest fields)
  1034. "Reuse previously created objects of this type in buffer."
  1035. (let ((old nil)
  1036. (bl semantic-collector-per-buffer-list))
  1037. (while (and bl (null old))
  1038. (if (eq (object-class (car bl)) this)
  1039. (setq old (car bl))))
  1040. (unless old
  1041. (let ((new (call-next-method)))
  1042. (add-to-list 'semantic-collector-per-buffer-list new)
  1043. (setq old new)))
  1044. (slot-makeunbound old 'last-completion)
  1045. (slot-makeunbound old 'last-prefix)
  1046. (slot-makeunbound old 'current-exact-match)
  1047. old))
  1048. ;; Buffer specific collectors should flush themselves
  1049. (defun semantic-collector-buffer-flush (newcache)
  1050. "Flush all buffer collector objects.
  1051. NEWCACHE is the new tag table, but we ignore it."
  1052. (condition-case nil
  1053. (let ((l semantic-collector-per-buffer-list))
  1054. (while l
  1055. (if (car l) (semantic-collector-flush (car l)))
  1056. (setq l (cdr l))))
  1057. (error nil)))
  1058. (add-hook 'semantic-after-toplevel-cache-change-hook
  1059. 'semantic-collector-buffer-flush)
  1060. ;;; DEEP BUFFER SPECIFIC COMPLETION
  1061. ;;
  1062. (defclass semantic-collector-buffer-deep
  1063. (semantic-collector-buffer-abstract)
  1064. ()
  1065. "Completion engine for tags in the current buffer.
  1066. When searching for a tag, uses semantic deep searche functions.
  1067. Basics search only in the current buffer.")
  1068. (defmethod semantic-collector-calculate-cache
  1069. ((obj semantic-collector-buffer-deep))
  1070. "Calculate the completion cache for OBJ.
  1071. Uses `semantic-flatten-tags-table'"
  1072. (oset obj cache
  1073. ;; Must create it in SEMANTICDB find format.
  1074. ;; ( ( DBTABLE TAG TAG ... ) ... )
  1075. (list
  1076. (cons semanticdb-current-table
  1077. (semantic-flatten-tags-table (oref obj buffer))))))
  1078. ;;; PROJECT SPECIFIC COMPLETION
  1079. ;;
  1080. (defclass semantic-collector-project-abstract (semantic-collector-abstract)
  1081. ((path :initarg :path
  1082. :initform nil
  1083. :documentation "List of database tables to search.
  1084. At creation time, it can be anything accepted by
  1085. `semanticdb-find-translate-path' as a PATH argument.")
  1086. )
  1087. "Root class for project wide completion engines.
  1088. Uses semanticdb for searching all tags in the current project."
  1089. :abstract t)
  1090. ;;; Project Search
  1091. (defclass semantic-collector-project (semantic-collector-project-abstract)
  1092. ()
  1093. "Completion engine for tags in a project.")
  1094. (defmethod semantic-collector-calculate-completions-raw
  1095. ((obj semantic-collector-project) prefix completionlist)
  1096. "Calculate the completions for prefix from completionlist."
  1097. (semanticdb-find-tags-for-completion prefix (oref obj path)))
  1098. ;;; Brutish Project search
  1099. (defclass semantic-collector-project-brutish (semantic-collector-project-abstract)
  1100. ()
  1101. "Completion engine for tags in a project.")
  1102. (declare-function semanticdb-brute-deep-find-tags-for-completion
  1103. "semantic/db-find")
  1104. (defmethod semantic-collector-calculate-completions-raw
  1105. ((obj semantic-collector-project-brutish) prefix completionlist)
  1106. "Calculate the completions for prefix from completionlist."
  1107. (require 'semantic/db-find)
  1108. (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))
  1109. ;;; Current Datatype member search.
  1110. (defclass semantic-collector-local-members (semantic-collector-project-abstract)
  1111. ((scope :initform nil
  1112. :type (or null semantic-scope-cache)
  1113. :documentation
  1114. "The scope the local members are being completed from."))
  1115. "Completion engine for tags in a project.")
  1116. (defmethod semantic-collector-calculate-completions-raw
  1117. ((obj semantic-collector-local-members) prefix completionlist)
  1118. "Calculate the completions for prefix from completionlist."
  1119. (let* ((scope (or (oref obj scope)
  1120. (oset obj scope (semantic-calculate-scope))))
  1121. (localstuff (oref scope scope)))
  1122. (list
  1123. (cons
  1124. (oref scope :table)
  1125. (semantic-find-tags-for-completion prefix localstuff)))))
  1126. ;(semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path))))
  1127. ;;; Smart completion collector
  1128. (defclass semantic-collector-analyze-completions (semantic-collector-abstract)
  1129. ((context :initarg :context
  1130. :type semantic-analyze-context
  1131. :documentation "An analysis context.
  1132. Specifies some context location from whence completion lists will be drawn."
  1133. )
  1134. (first-pass-completions :type list
  1135. :documentation "List of valid completion tags.
  1136. This list of tags is generated when completion starts. All searches
  1137. derive from this list.")
  1138. )
  1139. "Completion engine that uses the context analyzer to provide options.
  1140. The only options available for completion are those which can be logically
  1141. inserted into the current context.")
  1142. (defmethod semantic-collector-calculate-completions-raw
  1143. ((obj semantic-collector-analyze-completions) prefix completionlist)
  1144. "calculate the completions for prefix from completionlist."
  1145. ;; if there are no completions yet, calculate them.
  1146. (if (not (slot-boundp obj 'first-pass-completions))
  1147. (oset obj first-pass-completions
  1148. (semantic-analyze-possible-completions (oref obj context))))
  1149. ;; search our cached completion list. make it look like a semanticdb
  1150. ;; results type.
  1151. (list (cons (with-current-buffer (oref (oref obj context) buffer)
  1152. semanticdb-current-table)
  1153. (semantic-find-tags-for-completion
  1154. prefix
  1155. (oref obj first-pass-completions)))))
  1156. ;;; ------------------------------------------------------------
  1157. ;;; Tag List Display Engines
  1158. ;;
  1159. ;; A typical displayor accepts a pre-determined list of completions
  1160. ;; generated by a collector. This format is in semanticdb search
  1161. ;; form. This vaguely standard form is a bit challenging to navigate
  1162. ;; because the tags do not contain buffer info, but the file associated
  1163. ;; with the tags precedes the tag in the list.
  1164. ;;
  1165. ;; Basic displayors don't care, and can strip the results.
  1166. ;; Advanced highlighting displayors need to know when they need
  1167. ;; to load a file so that the tag in question can be highlighted.
  1168. ;;
  1169. ;; Key interface methods to a displayor are:
  1170. ;; * semantic-displayor-next-action
  1171. ;; * semantic-displayor-set-completions
  1172. ;; * semantic-displayor-current-focus
  1173. ;; * semantic-displayor-show-request
  1174. ;; * semantic-displayor-scroll-request
  1175. ;; * semantic-displayor-focus-request
  1176. (defclass semantic-displayor-abstract ()
  1177. ((table :type (or null semanticdb-find-result-with-nil)
  1178. :initform nil
  1179. :protection :protected
  1180. :documentation "List of tags this displayor is showing.")
  1181. (last-prefix :type string
  1182. :protection :protected
  1183. :documentation "Prefix associated with slot `table'")
  1184. )
  1185. "Abstract displayor baseclass.
  1186. Manages the display of some number of tags.
  1187. Provides the basics for a displayor, including interacting with
  1188. a collector, and tracking tables of completion to display."
  1189. :abstract t)
  1190. (defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract))
  1191. "Clean up any mess this displayor may have."
  1192. nil)
  1193. (defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract))
  1194. "The next action to take on the minibuffer related to display."
  1195. (if (and (slot-boundp obj 'last-prefix)
  1196. (string= (oref obj last-prefix) (semantic-completion-text))
  1197. (eq last-command this-command))
  1198. 'scroll
  1199. 'display))
  1200. (defmethod semantic-displayor-set-completions ((obj semantic-displayor-abstract)
  1201. table prefix)
  1202. "Set the list of tags to be completed over to TABLE."
  1203. (oset obj table table)
  1204. (oset obj last-prefix prefix))
  1205. (defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract))
  1206. "A request to show the current tags table."
  1207. (ding))
  1208. (defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract))
  1209. "A request to for the displayor to focus on some tag option."
  1210. (ding))
  1211. (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-abstract))
  1212. "A request to for the displayor to scroll the completion list (if needed)."
  1213. (scroll-other-window))
  1214. (defmethod semantic-displayor-focus-previous ((obj semantic-displayor-abstract))
  1215. "Set the current focus to the previous item."
  1216. nil)
  1217. (defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract))
  1218. "Set the current focus to the next item."
  1219. nil)
  1220. (defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract))
  1221. "Return a single tag currently in focus.
  1222. This object type doesn't do focus, so will never have a focus object."
  1223. nil)
  1224. ;; Traditional displayor
  1225. (defcustom semantic-completion-displayor-format-tag-function
  1226. #'semantic-format-tag-name
  1227. "*A Tag format function to use when showing completions."
  1228. :group 'semantic
  1229. :type semantic-format-tag-custom-list)
  1230. (defclass semantic-displayor-traditional (semantic-displayor-abstract)
  1231. ()
  1232. "Display options in *Completions* buffer.
  1233. Traditional display mechanism for a list of possible completions.
  1234. Completions are showin in a new buffer and listed with the ability
  1235. to click on the items to aid in completion.")
  1236. (defmethod semantic-displayor-show-request ((obj semantic-displayor-traditional))
  1237. "A request to show the current tags table."
  1238. ;; NOTE TO SELF. Find the character to type next, and emphasize it.
  1239. (with-output-to-temp-buffer "*Completions*"
  1240. (display-completion-list
  1241. (mapcar semantic-completion-displayor-format-tag-function
  1242. (semanticdb-strip-find-results (oref obj table))))
  1243. )
  1244. )
  1245. ;;; Abstract baseclass for any displayor which supports focus
  1246. (defclass semantic-displayor-focus-abstract (semantic-displayor-abstract)
  1247. ((focus :type number
  1248. :protection :protected
  1249. :documentation "A tag index from `table' which has focus.
  1250. Multiple calls to the display function can choose to focus on a
  1251. given tag, by highlighting its location.")
  1252. (find-file-focus
  1253. :allocation :class
  1254. :initform nil
  1255. :documentation
  1256. "Non-nil if focusing requires a tag's buffer be in memory.")
  1257. )
  1258. "Abstract displayor supporting `focus'.
  1259. A displayor which has the ability to focus in on one tag.
  1260. Focusing is a way of differentiating among multiple tags
  1261. which have the same name."
  1262. :abstract t)
  1263. (defmethod semantic-displayor-next-action ((obj semantic-displayor-focus-abstract))
  1264. "The next action to take on the minibuffer related to display."
  1265. (if (and (slot-boundp obj 'last-prefix)
  1266. (string= (oref obj last-prefix) (semantic-completion-text))
  1267. (eq last-command this-command))
  1268. (if (and
  1269. (slot-boundp obj 'focus)
  1270. (slot-boundp obj 'table)
  1271. (<= (semanticdb-find-result-length (oref obj table))
  1272. (1+ (oref obj focus))))
  1273. ;; We are at the end of the focus road.
  1274. 'displayend
  1275. ;; Focus on some item.
  1276. 'focus)
  1277. 'display))
  1278. (defmethod semantic-displayor-set-completions ((obj semantic-displayor-focus-abstract)
  1279. table prefix)
  1280. "Set the list of tags to be completed over to TABLE."
  1281. (call-next-method)
  1282. (slot-makeunbound obj 'focus))
  1283. (defmethod semantic-displayor-focus-previous ((obj semantic-displayor-focus-abstract))
  1284. "Set the current focus to the previous item.
  1285. Not meaningful return value."
  1286. (when (and (slot-boundp obj 'table) (oref obj table))
  1287. (with-slots (table) obj
  1288. (if (or (not (slot-boundp obj 'focus))
  1289. (<= (oref obj focus) 0))
  1290. (oset obj focus (1- (semanticdb-find-result-length table)))
  1291. (oset obj focus (1- (oref obj focus)))
  1292. )
  1293. )))
  1294. (defmethod semantic-displayor-focus-next ((obj semantic-displayor-focus-abstract))
  1295. "Set the current focus to the next item.
  1296. Not meaningful return value."
  1297. (when (and (slot-boundp obj 'table) (oref obj table))
  1298. (with-slots (table) obj
  1299. (if (not (slot-boundp obj 'focus))
  1300. (oset obj focus 0)
  1301. (oset obj focus (1+ (oref obj focus)))
  1302. )
  1303. (if (<= (semanticdb-find-result-length table) (oref obj focus))
  1304. (oset obj focus 0))
  1305. )))
  1306. (defmethod semantic-displayor-focus-tag ((obj semantic-displayor-focus-abstract))
  1307. "Return the next tag OBJ should focus on."
  1308. (when (and (slot-boundp obj 'table) (oref obj table))
  1309. (with-slots (table) obj
  1310. (semanticdb-find-result-nth table (oref obj focus)))))
  1311. (defmethod semantic-displayor-current-focus ((obj semantic-displayor-focus-abstract))
  1312. "Return the tag currently in focus, or call parent method."
  1313. (if (and (slot-boundp obj 'focus)
  1314. (slot-boundp obj 'table)
  1315. ;; Only return the current focus IFF the minibuffer reflects
  1316. ;; the list this focus was derived from.
  1317. (slot-boundp obj 'last-prefix)
  1318. (string= (semantic-completion-text) (oref obj last-prefix))
  1319. )
  1320. ;; We need to focus
  1321. (if (oref obj find-file-focus)
  1322. (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj focus))
  1323. ;; result-nth returns a cons with car being the tag, and cdr the
  1324. ;; database.
  1325. (car (semanticdb-find-result-nth (oref obj table) (oref obj focus))))
  1326. ;; Do whatever
  1327. (call-next-method)))
  1328. ;;; Simple displayor which performs traditional display completion,
  1329. ;; and also focuses with highlighting.
  1330. (defclass semantic-displayor-traditional-with-focus-highlight
  1331. (semantic-displayor-focus-abstract semantic-displayor-traditional)
  1332. ((find-file-focus :initform t))
  1333. "Display completions in *Completions* buffer, with focus highlight.
  1334. A traditional displayor which can focus on a tag by showing it.
  1335. Same as `semantic-displayor-traditional', but with selection between
  1336. multiple tags with the same name done by 'focusing' on the source
  1337. location of the different tags to differentiate them.")
  1338. (defmethod semantic-displayor-focus-request
  1339. ((obj semantic-displayor-traditional-with-focus-highlight))
  1340. "Focus in on possible tag completions.
  1341. Focus is performed by cycling through the tags and highlighting
  1342. one in the source buffer."
  1343. (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
  1344. (focus (semantic-displayor-focus-tag obj))
  1345. ;; Raw tag info.
  1346. (rtag (car focus))
  1347. (rtable (cdr focus))
  1348. ;; Normalize
  1349. (nt (semanticdb-normalize-one-tag rtable rtag))
  1350. (tag (cdr nt))
  1351. (table (car nt))
  1352. )
  1353. ;; If we fail to normalize, reset.
  1354. (when (not tag) (setq table rtable tag rtag))
  1355. ;; Do the focus.
  1356. (let ((buf (or (semantic-tag-buffer tag)
  1357. (and table (semanticdb-get-buffer table)))))
  1358. ;; If no buffer is provided, then we can make up a summary buffer.
  1359. (when (not buf)
  1360. (with-current-buffer (get-buffer-create "*Completion Focus*")
  1361. (erase-buffer)
  1362. (insert "Focus on tag: \n")
  1363. (insert (semantic-format-tag-summarize tag nil t) "\n\n")
  1364. (when table
  1365. (insert "From table: \n")
  1366. (insert (object-name table) "\n\n"))
  1367. (when buf
  1368. (insert "In buffer: \n\n")
  1369. (insert (format "%S" buf)))
  1370. (setq buf (current-buffer))))
  1371. ;; Show the tag in the buffer.
  1372. (if (get-buffer-window buf)
  1373. (select-window (get-buffer-window buf))
  1374. (switch-to-buffer-other-window buf t)
  1375. (select-window (get-buffer-window buf)))
  1376. ;; Now do some positioning
  1377. (unwind-protect
  1378. (if (semantic-tag-with-position-p tag)
  1379. ;; Full tag positional information available
  1380. (progn
  1381. (goto-char (semantic-tag-start tag))
  1382. ;; This avoids a dangerous problem if we just loaded a tag
  1383. ;; from a file, but the original position was not updated
  1384. ;; in the TAG variable we are currently using.
  1385. (semantic-momentary-highlight-tag (semantic-current-tag))
  1386. ))
  1387. (select-window (minibuffer-window)))
  1388. ;; Calculate text difference between contents and the focus item.
  1389. (let* ((mbc (semantic-completion-text))
  1390. (ftn (semantic-tag-name tag))
  1391. (diff (substring ftn (length mbc))))
  1392. (semantic-completion-message
  1393. (format "%s [%d of %d matches]" diff (1+ (oref obj focus)) tablelength)))
  1394. )))
  1395. ;;; Tooltip completion lister
  1396. ;;
  1397. ;; Written and contributed by Masatake YAMATO <jet@gyve.org>
  1398. ;;
  1399. ;; Modified by Eric Ludlam for
  1400. ;; * Safe compatibility for tooltip free systems.
  1401. ;; * Don't use 'avoid package for tooltip positioning.
  1402. (defclass semantic-displayor-tooltip (semantic-displayor-traditional)
  1403. ((max-tags :type integer
  1404. :initarg :max-tags
  1405. :initform 5
  1406. :custom integer
  1407. :documentation
  1408. "Max number of tags displayed on tooltip at once.
  1409. If `force-show' is 1, this value is ignored with typing tab or space twice continuously.
  1410. if `force-show' is 0, this value is always ignored.")
  1411. (force-show :type integer
  1412. :initarg :force-show
  1413. :initform 1
  1414. :custom (choice (const
  1415. :tag "Show when double typing"
  1416. 1)
  1417. (const
  1418. :tag "Show always"
  1419. 0)
  1420. (const
  1421. :tag "Show if the number of tags is less than `max-tags'."
  1422. -1))
  1423. :documentation
  1424. "Control the behavior of the number of tags is greater than `max-tags'.
  1425. -1 means tags are never shown.
  1426. 0 means the tags are always shown.
  1427. 1 means tags are shown if space or tab is typed twice continuously.")
  1428. (typing-count :type integer
  1429. :initform 0
  1430. :documentation
  1431. "Counter holding how many times the user types space or tab continuously before showing tags.")
  1432. (shown :type boolean
  1433. :initform nil
  1434. :documentation
  1435. "Flag representing whether tags is shown once or not.")
  1436. )
  1437. "Display completions options in a tooltip.
  1438. Display mechanism using tooltip for a list of possible completions.")
  1439. (defmethod initialize-instance :AFTER ((obj semantic-displayor-tooltip) &rest args)
  1440. "Make sure we have tooltips required."
  1441. (condition-case nil
  1442. (require 'tooltip)
  1443. (error nil))
  1444. )
  1445. (defmethod semantic-displayor-show-request ((obj semantic-displayor-tooltip))
  1446. "A request to show the current tags table."
  1447. (if (or (not (featurep 'tooltip)) (not tooltip-mode))
  1448. ;; If we cannot use tooltips, then go to the normal mode with
  1449. ;; a traditional completion buffer.
  1450. (call-next-method)
  1451. (let* ((tablelong (semanticdb-strip-find-results (oref obj table)))
  1452. (table (semantic-unique-tag-table-by-name tablelong))
  1453. (l (mapcar semantic-completion-displayor-format-tag-function table))
  1454. (ll (length l))
  1455. (typing-count (oref obj typing-count))
  1456. (force-show (oref obj force-show))
  1457. (matchtxt (semantic-completion-text))
  1458. msg)
  1459. (if (or (oref obj shown)
  1460. (< ll (oref obj max-tags))
  1461. (and (<= 0 force-show)
  1462. (< (1- force-show) typing-count)))
  1463. (progn
  1464. (oset obj typing-count 0)
  1465. (oset obj shown t)
  1466. (if (eq 1 ll)
  1467. ;; We Have only one possible match. There could be two cases.
  1468. ;; 1) input text != single match.
  1469. ;; --> Show it!
  1470. ;; 2) input text == single match.
  1471. ;; --> Complain about it, but still show the match.
  1472. (if (string= matchtxt (semantic-tag-name (car table)))
  1473. (setq msg (concat "[COMPLETE]\n" (car l)))
  1474. (setq msg (car l)))
  1475. ;; Create the long message.
  1476. (setq msg (mapconcat 'identity l "\n"))
  1477. ;; If there is nothing, say so!
  1478. (if (eq 0 (length msg))
  1479. (setq msg "[NO MATCH]")))
  1480. (semantic-displayor-tooltip-show msg))
  1481. ;; The typing count determines if the user REALLY REALLY
  1482. ;; wanted to show that much stuff. Only increment
  1483. ;; if the current command is a completion command.
  1484. (if (and (stringp (this-command-keys))
  1485. (string= (this-command-keys) "\C-i"))
  1486. (oset obj typing-count (1+ typing-count)))
  1487. ;; At this point, we know we have too many items.
  1488. ;; Let's be brave, and truncate l
  1489. (setcdr (nthcdr (oref obj max-tags) l) nil)
  1490. (setq msg (mapconcat 'identity l "\n"))
  1491. (cond
  1492. ((= force-show -1)
  1493. (semantic-displayor-tooltip-show (concat msg "\n...")))
  1494. ((= force-show 1)
  1495. (semantic-displayor-tooltip-show (concat msg "\n(TAB for more)")))
  1496. )))))
  1497. ;;; Compatibility
  1498. ;;
  1499. (eval-and-compile
  1500. (if (fboundp 'window-inside-edges)
  1501. ;; Emacs devel.
  1502. (defalias 'semantic-displayor-window-edges
  1503. 'window-inside-edges)
  1504. ;; Emacs 21
  1505. (defalias 'semantic-displayor-window-edges
  1506. 'window-edges)
  1507. ))
  1508. (defun semantic-displayor-point-position ()
  1509. "Return the location of POINT as positioned on the selected frame.
  1510. Return a cons cell (X . Y)"
  1511. (let* ((frame (selected-frame))
  1512. (left (frame-parameter frame 'left))
  1513. (top (frame-parameter frame 'top))
  1514. (point-pix-pos (posn-x-y (posn-at-point)))
  1515. (edges (window-inside-pixel-edges (selected-window))))
  1516. (cons (+ (car point-pix-pos) (car edges) left)
  1517. (+ (cdr point-pix-pos) (cadr edges) top))))
  1518. (defun semantic-displayor-tooltip-show (text)
  1519. "Display a tooltip with TEXT near cursor."
  1520. (let ((point-pix-pos (semantic-displayor-point-position))
  1521. (tooltip-frame-parameters
  1522. (append tooltip-frame-parameters nil)))
  1523. (push
  1524. (cons 'left (+ (car point-pix-pos) (frame-char-width)))
  1525. tooltip-frame-parameters)
  1526. (push
  1527. (cons 'top (+ (cdr point-pix-pos) (frame-char-height)))
  1528. tooltip-frame-parameters)
  1529. (tooltip-show text)))
  1530. (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip))
  1531. "A request to for the displayor to scroll the completion list (if needed)."
  1532. ;; Do scrolling in the tooltip.
  1533. (oset obj max-tags 30)
  1534. (semantic-displayor-show-request obj)
  1535. )
  1536. ;; End code contributed by Masatake YAMATO <jet@gyve.org>
  1537. ;;; Ghost Text displayor
  1538. ;;
  1539. (defclass semantic-displayor-ghost (semantic-displayor-focus-abstract)
  1540. ((ghostoverlay :type overlay
  1541. :documentation
  1542. "The overlay the ghost text is displayed in.")
  1543. (first-show :initform t
  1544. :documentation
  1545. "Non nil if we have not seen our first show request.")
  1546. )
  1547. "Cycle completions inline with ghost text.
  1548. Completion displayor using ghost chars after point for focus options.
  1549. Whichever completion is currently in focus will be displayed as ghost
  1550. text using overlay options.")
  1551. (defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost))
  1552. "The next action to take on the inline completion related to display."
  1553. (let ((ans (call-next-method))
  1554. (table (when (slot-boundp obj 'table)
  1555. (oref obj table))))
  1556. (if (and (eq ans 'displayend)
  1557. table
  1558. (= (semanticdb-find-result-length table) 1)
  1559. )
  1560. nil
  1561. ans)))
  1562. (defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost))
  1563. "Clean up any mess this displayor may have."
  1564. (when (slot-boundp obj 'ghostoverlay)
  1565. (semantic-overlay-delete (oref obj ghostoverlay)))
  1566. )
  1567. (defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost)
  1568. table prefix)
  1569. "Set the list of tags to be completed over to TABLE."
  1570. (call-next-method)
  1571. (semantic-displayor-cleanup obj)
  1572. )
  1573. (defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost))
  1574. "A request to show the current tags table."
  1575. ; (if (oref obj first-show)
  1576. ; (progn
  1577. ; (oset obj first-show nil)
  1578. (semantic-displayor-focus-next obj)
  1579. (semantic-displayor-focus-request obj)
  1580. ; )
  1581. ;; Only do the traditional thing if the first show request
  1582. ;; has been seen. Use the first one to start doing the ghost
  1583. ;; text display.
  1584. ; (call-next-method)
  1585. ; )
  1586. )
  1587. (defmethod semantic-displayor-focus-request
  1588. ((obj semantic-displayor-ghost))
  1589. "Focus in on possible tag completions.
  1590. Focus is performed by cycling through the tags and showing a possible
  1591. completion text in ghost text."
  1592. (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
  1593. (focus (semantic-displayor-focus-tag obj))
  1594. (tag (car focus))
  1595. )
  1596. (if (not tag)
  1597. (semantic-completion-message "No tags to focus on.")
  1598. ;; Display the focus completion as ghost text after the current
  1599. ;; inline text.
  1600. (when (or (not (slot-boundp obj 'ghostoverlay))
  1601. (not (semantic-overlay-live-p (oref obj ghostoverlay))))
  1602. (oset obj ghostoverlay
  1603. (semantic-make-overlay (point) (1+ (point)) (current-buffer) t)))
  1604. (let* ((lp (semantic-completion-text))
  1605. (os (substring (semantic-tag-name tag) (length lp)))
  1606. (ol (oref obj ghostoverlay))
  1607. )
  1608. (put-text-property 0 (length os) 'face 'region os)
  1609. (semantic-overlay-put
  1610. ol 'display (concat os (buffer-substring (point) (1+ (point)))))
  1611. )
  1612. ;; Calculate text difference between contents and the focus item.
  1613. (let* ((mbc (semantic-completion-text))
  1614. (ftn (concat (semantic-tag-name tag)))
  1615. )
  1616. (put-text-property (length mbc) (length ftn) 'face
  1617. 'bold ftn)
  1618. (semantic-completion-message
  1619. (format "%s [%d of %d matches]" ftn (1+ (oref obj focus)) tablelength)))
  1620. )))
  1621. ;;; ------------------------------------------------------------
  1622. ;;; Specific queries
  1623. ;;
  1624. (defvar semantic-complete-inline-custom-type
  1625. (append '(radio)
  1626. (mapcar
  1627. (lambda (class)
  1628. (let* ((C (intern (car class)))
  1629. (doc (documentation-property C 'variable-documentation))
  1630. (doc1 (car (split-string doc "\n")))
  1631. )
  1632. (list 'const
  1633. :tag doc1
  1634. C)))
  1635. (eieio-build-class-alist semantic-displayor-abstract t))
  1636. )
  1637. "Possible options for inline completion displayors.
  1638. Use this to enable custom editing.")
  1639. (defcustom semantic-complete-inline-analyzer-displayor-class
  1640. 'semantic-displayor-traditional
  1641. "*Class for displayor to use with inline completion."
  1642. :group 'semantic
  1643. :type semantic-complete-inline-custom-type
  1644. )
  1645. (defun semantic-complete-read-tag-buffer-deep (prompt &optional
  1646. default-tag
  1647. initial-input
  1648. history)
  1649. "Ask for a tag by name from the current buffer.
  1650. Available tags are from the current buffer, at any level.
  1651. Completion options are presented in a traditional way, with highlighting
  1652. to resolve same-name collisions.
  1653. PROMPT is a string to prompt with.
  1654. DEFAULT-TAG is a semantic tag or string to use as the default value.
  1655. If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
  1656. HISTORY is a symbol representing a variable to store the history in."
  1657. (semantic-complete-read-tag-engine
  1658. (semantic-collector-buffer-deep prompt :buffer (current-buffer))
  1659. (semantic-displayor-traditional-with-focus-highlight "simple")
  1660. ;;(semantic-displayor-tooltip "simple")
  1661. prompt
  1662. default-tag
  1663. initial-input
  1664. history)
  1665. )
  1666. (defun semantic-complete-read-tag-local-members (prompt &optional
  1667. default-tag
  1668. initial-input
  1669. history)
  1670. "Ask for a tag by name from the local type members.
  1671. Available tags are from the current scope.
  1672. Completion options are presented in a traditional way, with highlighting
  1673. to resolve same-name collisions.
  1674. PROMPT is a string to prompt with.
  1675. DEFAULT-TAG is a semantic tag or string to use as the default value.
  1676. If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
  1677. HISTORY is a symbol representing a variable to store the history in."
  1678. (semantic-complete-read-tag-engine
  1679. (semantic-collector-local-members prompt :buffer (current-buffer))
  1680. (semantic-displayor-traditional-with-focus-highlight "simple")
  1681. ;;(semantic-displayor-tooltip "simple")
  1682. prompt
  1683. default-tag
  1684. initial-input
  1685. history)
  1686. )
  1687. (defun semantic-complete-read-tag-project (prompt &optional
  1688. default-tag
  1689. initial-input
  1690. history)
  1691. "Ask for a tag by name from the current project.
  1692. Available tags are from the current project, at the top level.
  1693. Completion options are presented in a traditional way, with highlighting
  1694. to resolve same-name collisions.
  1695. PROMPT is a string to prompt with.
  1696. DEFAULT-TAG is a semantic tag or string to use as the default value.
  1697. If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
  1698. HISTORY is a symbol representing a variable to store the history in."
  1699. (semantic-complete-read-tag-engine
  1700. (semantic-collector-project-brutish prompt
  1701. :buffer (current-buffer)
  1702. :path (current-buffer)
  1703. )
  1704. (semantic-displayor-traditional-with-focus-highlight "simple")
  1705. prompt
  1706. default-tag
  1707. initial-input
  1708. history)
  1709. )
  1710. (defun semantic-complete-inline-tag-project ()
  1711. "Complete a symbol name by name from within the current project.
  1712. This is similar to `semantic-complete-read-tag-project', except
  1713. that the completion interaction is in the buffer where the context
  1714. was calculated from.
  1715. Customize `semantic-complete-inline-analyzer-displayor-class'
  1716. to control how completion options are displayed.
  1717. See `semantic-complete-inline-tag-engine' for details on how
  1718. completion works."
  1719. (let* ((collector (semantic-collector-project-brutish
  1720. "inline"
  1721. :buffer (current-buffer)
  1722. :path (current-buffer)))
  1723. (sbounds (semantic-ctxt-current-symbol-and-bounds))
  1724. (syms (car sbounds))
  1725. (start (car (nth 2 sbounds)))
  1726. (end (cdr (nth 2 sbounds)))
  1727. (rsym (reverse syms))
  1728. (thissym (nth 1 sbounds))
  1729. (nextsym (car-safe (cdr rsym)))
  1730. (complst nil))
  1731. (when (and thissym (or (not (string= thissym ""))
  1732. nextsym))
  1733. ;; Do a quick calcuation of completions.
  1734. (semantic-collector-calculate-completions
  1735. collector thissym nil)
  1736. ;; Get the master list
  1737. (setq complst (semanticdb-strip-find-results
  1738. (semantic-collector-all-completions collector thissym)))
  1739. ;; Shorten by name
  1740. (setq complst (semantic-unique-tag-table-by-name complst))
  1741. (if (or (and (= (length complst) 1)
  1742. ;; Check to see if it is the same as what is there.
  1743. ;; if so, we can offer to complete.
  1744. (let ((compname (semantic-tag-name (car complst))))
  1745. (not (string= compname thissym))))
  1746. (> (length complst) 1))
  1747. ;; There are several options. Do the completion.
  1748. (semantic-complete-inline-tag-engine
  1749. collector
  1750. (funcall semantic-complete-inline-analyzer-displayor-class
  1751. "inline displayor")
  1752. ;;(semantic-displayor-tooltip "simple")
  1753. (current-buffer)
  1754. start end))
  1755. )))
  1756. (defun semantic-complete-read-tag-analyzer (prompt &optional
  1757. context
  1758. history)
  1759. "Ask for a tag by name based on the current context.
  1760. The function `semantic-analyze-current-context' is used to
  1761. calculate the context. `semantic-analyze-possible-completions' is used
  1762. to generate the list of possible completions.
  1763. PROMPT is the first part of the prompt. Additional prompt
  1764. is added based on the contexts full prefix.
  1765. CONTEXT is the semantic analyzer context to start with.
  1766. HISTORY is a symbol representing a variable to store the history in.
  1767. usually a default-tag and initial-input are available for completion
  1768. prompts. these are calculated from the CONTEXT variable passed in."
  1769. (if (not context) (setq context (semantic-analyze-current-context (point))))
  1770. (let* ((syms (semantic-ctxt-current-symbol (point)))
  1771. (inp (car (reverse syms))))
  1772. (setq syms (nreverse (cdr (nreverse syms))))
  1773. (semantic-complete-read-tag-engine
  1774. (semantic-collector-analyze-completions
  1775. prompt
  1776. :buffer (oref context buffer)
  1777. :context context)
  1778. (semantic-displayor-traditional-with-focus-highlight "simple")
  1779. (with-current-buffer (oref context buffer)
  1780. (goto-char (cdr (oref context bounds)))
  1781. (concat prompt (mapconcat 'identity syms ".")
  1782. (if syms "." "")
  1783. ))
  1784. nil
  1785. inp
  1786. history)))
  1787. (defun semantic-complete-inline-analyzer (context)
  1788. "Complete a symbol name by name based on the current context.
  1789. This is similar to `semantic-complete-read-tag-analyze', except
  1790. that the completion interaction is in the buffer where the context
  1791. was calculated from.
  1792. CONTEXT is the semantic analyzer context to start with.
  1793. Customize `semantic-complete-inline-analyzer-displayor-class'
  1794. to control how completion options are displayed.
  1795. See `semantic-complete-inline-tag-engine' for details on how
  1796. completion works."
  1797. (if (not context) (setq context (semantic-analyze-current-context (point))))
  1798. (if (not context) (error "Nothing to complete on here"))
  1799. (let* ((collector (semantic-collector-analyze-completions
  1800. "inline"
  1801. :buffer (oref context buffer)
  1802. :context context))
  1803. (syms (semantic-ctxt-current-symbol (point)))
  1804. (rsym (reverse syms))
  1805. (thissym (car rsym))
  1806. (nextsym (car-safe (cdr rsym)))
  1807. (complst nil))
  1808. (when (and thissym (or (not (string= thissym ""))
  1809. nextsym))
  1810. ;; Do a quick calcuation of completions.
  1811. (semantic-collector-calculate-completions
  1812. collector thissym nil)
  1813. ;; Get the master list
  1814. (setq complst (semanticdb-strip-find-results
  1815. (semantic-collector-all-completions collector thissym)))
  1816. ;; Shorten by name
  1817. (setq complst (semantic-unique-tag-table-by-name complst))
  1818. (if (or (and (= (length complst) 1)
  1819. ;; Check to see if it is the same as what is there.
  1820. ;; if so, we can offer to complete.
  1821. (let ((compname (semantic-tag-name (car complst))))
  1822. (not (string= compname thissym))))
  1823. (> (length complst) 1))
  1824. ;; There are several options. Do the completion.
  1825. (semantic-complete-inline-tag-engine
  1826. collector
  1827. (funcall semantic-complete-inline-analyzer-displayor-class
  1828. "inline displayor")
  1829. ;;(semantic-displayor-tooltip "simple")
  1830. (oref context buffer)
  1831. (car (oref context bounds))
  1832. (cdr (oref context bounds))
  1833. ))
  1834. )))
  1835. (defcustom semantic-complete-inline-analyzer-idle-displayor-class
  1836. 'semantic-displayor-ghost
  1837. "*Class for displayor to use with inline completion at idle time."
  1838. :group 'semantic
  1839. :type semantic-complete-inline-custom-type
  1840. )
  1841. (defun semantic-complete-inline-analyzer-idle (context)
  1842. "Complete a symbol name by name based on the current context for idle time.
  1843. CONTEXT is the semantic analyzer context to start with.
  1844. This function is used from `semantic-idle-completions-mode'.
  1845. This is the same as `semantic-complete-inline-analyzer', except that
  1846. it uses `semantic-complete-inline-analyzer-idle-displayor-class'
  1847. to control how completions are displayed.
  1848. See `semantic-complete-inline-tag-engine' for details on how
  1849. completion works."
  1850. (let ((semantic-complete-inline-analyzer-displayor-class
  1851. semantic-complete-inline-analyzer-idle-displayor-class))
  1852. (semantic-complete-inline-analyzer context)
  1853. ))
  1854. ;;;###autoload
  1855. (defun semantic-complete-jump-local ()
  1856. "Jump to a local semantic symbol."
  1857. (interactive)
  1858. (let ((tag (semantic-complete-read-tag-buffer-deep "Jump to symbol: ")))
  1859. (when (semantic-tag-p tag)
  1860. (push-mark)
  1861. (goto-char (semantic-tag-start tag))
  1862. (semantic-momentary-highlight-tag tag)
  1863. (message "%S: %s "
  1864. (semantic-tag-class tag)
  1865. (semantic-tag-name tag)))))
  1866. ;;;###autoload
  1867. (defun semantic-complete-jump ()
  1868. "Jump to a semantic symbol."
  1869. (interactive)
  1870. (let* ((tag (semantic-complete-read-tag-project "Jump to symbol: ")))
  1871. (when (semantic-tag-p tag)
  1872. (push-mark)
  1873. (semantic-go-to-tag tag)
  1874. (switch-to-buffer (current-buffer))
  1875. (semantic-momentary-highlight-tag tag)
  1876. (message "%S: %s "
  1877. (semantic-tag-class tag)
  1878. (semantic-tag-name tag)))))
  1879. ;;;###autoload
  1880. (defun semantic-complete-jump-local-members ()
  1881. "Jump to a semantic symbol."
  1882. (interactive)
  1883. (let* ((tag (semantic-complete-read-tag-local-members "Jump to symbol: ")))
  1884. (when (semantic-tag-p tag)
  1885. (let ((start (condition-case nil (semantic-tag-start tag)
  1886. (error nil))))
  1887. (unless start
  1888. (error "Tag %s has no location" (semantic-format-tag-prototype tag)))
  1889. (push-mark)
  1890. (goto-char start)
  1891. (semantic-momentary-highlight-tag tag)
  1892. (message "%S: %s "
  1893. (semantic-tag-class tag)
  1894. (semantic-tag-name tag))))))
  1895. ;;;###autoload
  1896. (defun semantic-complete-analyze-and-replace ()
  1897. "Perform prompt completion to do in buffer completion.
  1898. `semantic-analyze-possible-completions' is used to determine the
  1899. possible values.
  1900. The minibuffer is used to perform the completion.
  1901. The result is inserted as a replacement of the text that was there."
  1902. (interactive)
  1903. (let* ((c (semantic-analyze-current-context (point)))
  1904. (tag (save-excursion (semantic-complete-read-tag-analyzer "" c))))
  1905. ;; Take tag, and replace context bound with its name.
  1906. (goto-char (car (oref c bounds)))
  1907. (delete-region (point) (cdr (oref c bounds)))
  1908. (insert (semantic-tag-name tag))
  1909. (message "%S" (semantic-format-tag-summarize tag))))
  1910. ;;;###autoload
  1911. (defun semantic-complete-analyze-inline ()
  1912. "Perform prompt completion to do in buffer completion.
  1913. `semantic-analyze-possible-completions' is used to determine the
  1914. possible values.
  1915. The function returns immediately, leaving the buffer in a mode that
  1916. will perform the completion.
  1917. Configure `semantic-complete-inline-analyzer-displayor-class' to change
  1918. how completion options are displayed."
  1919. (interactive)
  1920. ;; Only do this if we are not already completing something.
  1921. (if (not (semantic-completion-inline-active-p))
  1922. (semantic-complete-inline-analyzer
  1923. (semantic-analyze-current-context (point))))
  1924. ;; Report a message if things didn't startup.
  1925. (if (and (called-interactively-p 'any)
  1926. (not (semantic-completion-inline-active-p)))
  1927. (message "Inline completion not needed.")
  1928. ;; Since this is most likely bound to something, and not used
  1929. ;; at idle time, throw in a TAB for good measure.
  1930. (semantic-complete-inline-TAB)))
  1931. ;;;###autoload
  1932. (defun semantic-complete-analyze-inline-idle ()
  1933. "Perform prompt completion to do in buffer completion.
  1934. `semantic-analyze-possible-completions' is used to determine the
  1935. possible values.
  1936. The function returns immediately, leaving the buffer in a mode that
  1937. will perform the completion.
  1938. Configure `semantic-complete-inline-analyzer-idle-displayor-class'
  1939. to change how completion options are displayed."
  1940. (interactive)
  1941. ;; Only do this if we are not already completing something.
  1942. (if (not (semantic-completion-inline-active-p))
  1943. (semantic-complete-inline-analyzer-idle
  1944. (semantic-analyze-current-context (point))))
  1945. ;; Report a message if things didn't startup.
  1946. (if (and (called-interactively-p 'interactive)
  1947. (not (semantic-completion-inline-active-p)))
  1948. (message "Inline completion not needed.")))
  1949. ;;;###autoload
  1950. (defun semantic-complete-self-insert (arg)
  1951. "Like `self-insert-command', but does completion afterwards.
  1952. ARG is passed to `self-insert-command'. If ARG is nil,
  1953. use `semantic-complete-analyze-inline' to complete."
  1954. (interactive "p")
  1955. ;; If we are already in a completion scenario, exit now, and then start over.
  1956. (semantic-complete-inline-exit)
  1957. ;; Insert the key
  1958. (self-insert-command arg)
  1959. ;; Prepare for doing completion, but exit quickly if there is keyboard
  1960. ;; input.
  1961. (when (save-window-excursion
  1962. (save-excursion
  1963. (and (not (semantic-exit-on-input 'csi
  1964. (semantic-fetch-tags)
  1965. (semantic-throw-on-input 'csi)
  1966. nil))
  1967. (= arg 1)
  1968. (not (semantic-exit-on-input 'csi
  1969. (semantic-analyze-current-context)
  1970. (semantic-throw-on-input 'csi)
  1971. nil)))))
  1972. (condition-case nil
  1973. (semantic-complete-analyze-inline)
  1974. ;; Ignore errors. Seems likely that we'll get some once in a while.
  1975. (error nil))
  1976. ))
  1977. (provide 'semantic/complete)
  1978. ;; Local variables:
  1979. ;; generated-autoload-file: "loaddefs.el"
  1980. ;; generated-autoload-load-name: "semantic/complete"
  1981. ;; End:
  1982. ;;; semantic/complete.el ends here