12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162 |
- (eval-when-compile (require 'cl))
- (require 'semantic)
- (require 'eieio-opt)
- (require 'semantic/analyze)
- (require 'semantic/ctxt)
- (require 'semantic/decorate)
- (require 'semantic/format)
- (eval-when-compile
-
- (require 'semantic/find))
- (defvar semantic-complete-inline-overlay nil
- "The overlay currently active while completing inline.")
- (defun semantic-completion-inline-active-p ()
- "Non-nil if inline completion is active."
- (when (and semantic-complete-inline-overlay
- (not (semantic-overlay-live-p semantic-complete-inline-overlay)))
- (semantic-overlay-delete semantic-complete-inline-overlay)
- (setq semantic-complete-inline-overlay nil))
- semantic-complete-inline-overlay)
- (defun semantic-completion-text ()
- "Return the text that is currently in the completion buffer.
- For a minibuffer prompt, this is the minibuffer text.
- For inline completion, this is the text wrapped in the inline completion
- overlay."
- (if semantic-complete-inline-overlay
- (semantic-complete-inline-text)
- (minibuffer-contents)))
- (defun semantic-completion-delete-text ()
- "Delete the text that is actively being completed.
- Presumably if you call this you will insert something new there."
- (if semantic-complete-inline-overlay
- (semantic-complete-inline-delete-text)
- (delete-minibuffer-contents)))
- (defun semantic-completion-message (fmt &rest args)
- "Display the string FMT formatted with ARGS at the end of the minibuffer."
- (if semantic-complete-inline-overlay
- (apply 'message fmt args)
- (message (concat (buffer-string) (apply 'format fmt args)))))
- (defvar semantic-completion-collector-engine nil
- "The tag collector for the current completion operation.
- Value should be an object of a subclass of
- `semantic-completion-engine-abstract'.")
- (defvar semantic-completion-display-engine nil
- "The tag display engine for the current completion operation.
- Value should be a ... what?")
- (defvar semantic-complete-key-map
- (let ((km (make-sparse-keymap)))
- (define-key km " " 'semantic-complete-complete-space)
- (define-key km "\t" 'semantic-complete-complete-tab)
- (define-key km "\C-m" 'semantic-complete-done)
- (define-key km "\C-g" 'abort-recursive-edit)
- (define-key km "\M-n" 'next-history-element)
- (define-key km "\M-p" 'previous-history-element)
- (define-key km "\C-n" 'next-history-element)
- (define-key km "\C-p" 'previous-history-element)
-
- km)
- "Keymap used while completing across a list of tags.")
- (defvar semantic-completion-default-history nil
- "Default history variable for any unhistoried prompt.
- Keeps STRINGS only in the history.")
- (defun semantic-complete-read-tag-engine (collector displayor prompt
- default-tag initial-input
- history)
- "Read a semantic tag, and return a tag for the selection.
- Argument COLLECTOR is an object which can be used to calculate
- a list of possible hits. See `semantic-completion-collector-engine'
- for details on COLLECTOR.
- Argument DISPLAYOR is an object used to display a list of possible
- completions for a given prefix. See`semantic-completion-display-engine'
- for details on DISPLAYOR.
- PROMPT is a string to prompt with.
- DEFAULT-TAG is a semantic tag or string to use as the default value.
- If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
- HISTORY is a symbol representing a variable to story the history in."
- (let* ((semantic-completion-collector-engine collector)
- (semantic-completion-display-engine displayor)
- (semantic-complete-active-default nil)
- (semantic-complete-current-matched-tag nil)
- (default-as-tag (semantic-complete-default-to-tag default-tag))
- (default-as-string (when (semantic-tag-p default-as-tag)
- (semantic-tag-name default-as-tag)))
- )
- (when default-as-string
-
-
-
-
-
-
-
-
- (if (string-match ":" prompt)
- (setq prompt (concat
- (substring prompt 0 (match-beginning 0))
- " (default " default-as-string ")"
- (substring prompt (match-beginning 0))))
- (setq prompt (concat prompt " (" default-as-string "): "))))
-
-
-
- (unwind-protect
- (read-from-minibuffer prompt
- initial-input
- semantic-complete-key-map
- nil
- (or history
- 'semantic-completion-default-history)
- default-tag)
- (semantic-collector-cleanup semantic-completion-collector-engine)
- (semantic-displayor-cleanup semantic-completion-display-engine)
- )
-
-
-
- semantic-complete-current-matched-tag
- ))
- (defvar semantic-complete-active-default nil
- "The current default tag calculated for this prompt.")
- (defun semantic-complete-default-to-tag (default)
- "Convert a calculated or passed in DEFAULT into a tag."
- (if (semantic-tag-p default)
-
- (setq semantic-complete-active-default default)
-
- (if (null default)
- (setq default (semantic-ctxt-current-thing)))
- (if (null default)
-
- nil
-
- (let ((str
- (cond
-
-
-
-
- ((and (listp default) (stringp (car default)))
- (car default))
- ((stringp default)
- default)
- ((symbolp default)
- (symbol-name default))
- (t
- (signal 'wrong-type-argument
- (list default 'semantic-tag-p)))))
- (tag nil))
-
-
- (save-excursion
- (semantic-collector-calculate-completions
- semantic-completion-collector-engine
- str nil))
-
- (let ((ml (semantic-collector-current-exact-match
- semantic-completion-collector-engine)))
- (when ml
-
- (setq tag (semanticdb-find-result-nth-in-buffer ml 0))))
-
- (setq semantic-complete-active-default tag)
-
- tag))))
- (defvar semantic-complete-current-matched-tag nil
- "Variable used to pass the tags being matched to the prompt.")
- (declare-function semantic-displayor-focus-abstract-child-p "semantic/complete"
- t t)
- (defun semantic-complete-current-match ()
- "Calculate a match from the current completion environment.
- Save this in our completion variable. Make sure that variable
- is cleared if any other keypress is made.
- Return value can be:
- tag - a single tag that has been matched.
- string - a message to show in the minibuffer."
-
- (let ((collector semantic-completion-collector-engine)
- (displayor semantic-completion-display-engine)
- (contents (semantic-completion-text))
- matchlist
- answer)
- (if (string= contents "")
-
- (setq answer semantic-complete-active-default)
-
- (save-excursion
- (semantic-collector-calculate-completions collector contents nil))
- (semantic-complete-try-completion)
- (cond
-
- ((setq answer (semantic-displayor-current-focus displayor))
-
- )
-
- ((setq matchlist (semantic-collector-current-exact-match collector))
- (if (= (semanticdb-find-result-length matchlist) 1)
- (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0))
- (if (semantic-displayor-focus-abstract-child-p displayor)
-
-
-
- (setq answer "Not Unique")
-
-
- (let ((allsame t)
- (firstname (semantic-tag-name
- (car
- (semanticdb-find-result-nth matchlist 0)))
- )
- (cnt 1)
- (max (semanticdb-find-result-length matchlist)))
- (while (and allsame (< cnt max))
- (if (not (string=
- firstname
- (semantic-tag-name
- (car
- (semanticdb-find-result-nth matchlist cnt)))))
- (setq allsame nil))
- (setq cnt (1+ cnt))
- )
-
-
- (if allsame
- (setq answer (semanticdb-find-result-nth-in-buffer
- matchlist 0))
- (setq answer "Not Unique"))
- ))))
-
- (t
- (setq answer "No Match")))
- )
-
- (when (semantic-tag-p answer)
- (setq semantic-complete-current-matched-tag answer)
-
-
- (add-hook 'pre-command-hook
- (lambda () (setq semantic-complete-current-matched-tag nil)))
- )
-
- answer
- ))
- (defun semantic-complete-done ()
- "Accept the current input."
- (interactive)
- (let ((ans (semantic-complete-current-match)))
- (if (stringp ans)
- (semantic-completion-message (concat " [" ans "]"))
- (exit-minibuffer)))
- )
- (defun semantic-complete-complete-space ()
- "Complete the partial input in the minibuffer."
- (interactive)
- (semantic-complete-do-completion t))
- (defun semantic-complete-complete-tab ()
- "Complete the partial input in the minibuffer as far as possible."
- (interactive)
- (semantic-complete-do-completion))
- (defun semantic-complete-hack-word-boundaries (original new)
- "Return a string to use for completion.
- ORIGINAL is the text in the minibuffer.
- NEW is the new text to insert into the minibuffer.
- Within the difference bounds of ORIGINAL and NEW, shorten NEW
- to the nearest word boundary, and return that."
- (save-match-data
- (let* ((diff (substring new (length original)))
- (end (string-match "\\>" diff))
- (start (string-match "\\<" diff)))
- (cond
- ((and start (> start 0))
-
-
- (concat original (substring diff 0 start)))
- (end
- (concat original (substring diff 0 end)))
- (t new)))))
- (defun semantic-complete-try-completion (&optional partial)
- "Try a completion for the current minibuffer.
- If PARTIAL, do partial completion stopping at spaces."
- (let ((comp (semantic-collector-try-completion
- semantic-completion-collector-engine
- (semantic-completion-text))))
- (cond
- ((null comp)
- (semantic-completion-message " [No Match]")
- (ding)
- )
- ((stringp comp)
- (if (string= (semantic-completion-text) comp)
- (when partial
-
-
-
-
- (let ((newcomp (semantic-collector-current-whitespace-completion
- semantic-completion-collector-engine)))
- (when newcomp
- (semantic-completion-delete-text)
- (insert newcomp))
- ))
- (when partial
- (let ((orig (semantic-completion-text)))
-
-
-
- (setq comp
- (semantic-complete-hack-word-boundaries orig comp))))
-
- (semantic-completion-delete-text)
- (insert comp))
- )
- ((and (listp comp) (semantic-tag-p (car comp)))
- (unless (string= (semantic-completion-text)
- (semantic-tag-name (car comp)))
-
- (semantic-completion-delete-text)
- (insert (semantic-tag-name (car comp))))
-
- (if (= (length comp) 1)
- (semantic-completion-message " [Complete]")
- (semantic-completion-message " [Complete, but not unique]"))
- )
- (t nil))))
- (defun semantic-complete-do-completion (&optional partial inline)
- "Do a completion for the current minibuffer.
- If PARTIAL, do partial completion stopping at spaces.
- if INLINE, then completion is happening inline in a buffer."
- (let* ((collector semantic-completion-collector-engine)
- (displayor semantic-completion-display-engine)
- (contents (semantic-completion-text))
- (ans nil))
- (save-excursion
- (semantic-collector-calculate-completions collector contents partial))
- (let* ((na (semantic-complete-next-action partial)))
- (cond
-
-
- ((eq na 'done)
- (semantic-completion-message " [Complete]")
- (setq ans 'done))
-
- ((or (eq na 'complete)
- (eq na 'complete-whitespace))
- (semantic-complete-try-completion partial)
- (setq ans 'complete))
-
-
- ((or (eq na 'display) (eq na 'displayend))
- (semantic-displayor-set-completions
- displayor
- (or
-
-
-
-
-
-
-
- (semantic-collector-all-completions collector contents))
- contents)
-
- (semantic-displayor-show-request displayor))
- ((eq na 'scroll)
- (semantic-displayor-scroll-request displayor)
- )
- ((eq na 'focus)
- (semantic-displayor-focus-next displayor)
- (semantic-displayor-focus-request displayor)
- )
- ((eq na 'empty)
- (semantic-completion-message " [No Match]"))
- (t nil)))
- ans))
- (defvar semantic-complete-inline-map
- (let ((km (make-sparse-keymap)))
- (define-key km "\C-i" 'semantic-complete-inline-TAB)
- (define-key km "\M-p" 'semantic-complete-inline-up)
- (define-key km "\M-n" 'semantic-complete-inline-down)
- (define-key km "\C-m" 'semantic-complete-inline-done)
- (define-key km "\C-\M-c" 'semantic-complete-inline-exit)
- (define-key km "\C-g" 'semantic-complete-inline-quit)
- (define-key km "?"
- (lambda () (interactive)
- (describe-variable 'semantic-complete-inline-map)))
- km)
- "Keymap used while performing Semantic inline completion.")
- (defface semantic-complete-inline-face
- '((((class color) (background dark))
- (:underline "yellow"))
- (((class color) (background light))
- (:underline "brown")))
- "*Face used to show the region being completed inline.
- The face is used in `semantic-complete-inline-tag-engine'."
- :group 'semantic-faces)
- (defun semantic-complete-inline-text ()
- "Return the text that is being completed inline.
- Similar to `minibuffer-contents' when completing in the minibuffer."
- (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
- (e (semantic-overlay-end semantic-complete-inline-overlay)))
- (if (= s e)
- ""
- (buffer-substring-no-properties s e ))))
- (defun semantic-complete-inline-delete-text ()
- "Delete the text currently being completed in the current buffer."
- (delete-region
- (semantic-overlay-start semantic-complete-inline-overlay)
- (semantic-overlay-end semantic-complete-inline-overlay)))
- (defun semantic-complete-inline-done ()
- "This completion thing is DONE, OR, insert a newline."
- (interactive)
- (let* ((displayor semantic-completion-display-engine)
- (tag (semantic-displayor-current-focus displayor)))
- (if tag
- (let ((txt (semantic-completion-text)))
- (insert (substring (semantic-tag-name tag)
- (length txt)))
- (semantic-complete-inline-exit))
-
- (let ((fcn
- (condition-case nil
- (lookup-key (current-active-maps) (this-command-keys))
- (error
-
-
- (lookup-key (current-global-map) (this-command-keys))
- ))))
- (when fcn
- (funcall fcn)))
- )))
- (defun semantic-complete-inline-quit ()
- "Quit an inline edit."
- (interactive)
- (semantic-complete-inline-exit)
- (keyboard-quit))
- (defun semantic-complete-inline-exit ()
- "Exit inline completion mode."
- (interactive)
-
- (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
- (condition-case nil
- (progn
- (when semantic-completion-collector-engine
- (semantic-collector-cleanup semantic-completion-collector-engine))
- (when semantic-completion-display-engine
- (semantic-displayor-cleanup semantic-completion-display-engine))
- (when semantic-complete-inline-overlay
- (let ((wc (semantic-overlay-get semantic-complete-inline-overlay
- 'window-config-start))
- (buf (semantic-overlay-buffer semantic-complete-inline-overlay))
- )
- (semantic-overlay-delete semantic-complete-inline-overlay)
- (setq semantic-complete-inline-overlay nil)
-
-
- (when (eq buf (current-buffer))
- (set-window-configuration wc))
- ))
- (setq semantic-completion-collector-engine nil
- semantic-completion-display-engine nil))
- (error nil))
-
-
-
- (remove-hook 'post-command-hook 'semantic-complete-post-command-hook)
-
- )
- (defun semantic-complete-pre-command-hook ()
- "Used to redefine what commands are being run while completing.
- When installed as a `pre-command-hook' the special keymap
- `semantic-complete-inline-map' is queried to replace commands normally run.
- Commands which edit what is in the region of interest operate normally.
- Commands which would take us out of the region of interest, or our
- quit hook, will exit this completion mode."
- (let ((fcn (lookup-key semantic-complete-inline-map
- (this-command-keys) nil)))
- (cond ((commandp fcn)
- (setq this-command fcn))
- (t nil)))
- )
- (defun semantic-complete-post-command-hook ()
- "Used to determine if we need to exit inline completion mode.
- If completion mode is active, check to see if we are within
- the bounds of `semantic-complete-inline-overlay', or within
- a reasonable distance."
- (condition-case nil
-
- (if (not semantic-complete-inline-overlay)
- (progn
-
- (semantic-complete-inline-exit))
-
- (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
- (e (semantic-overlay-end semantic-complete-inline-overlay))
- (b (semantic-overlay-buffer semantic-complete-inline-overlay))
- (txt nil)
- )
- (cond
-
- ((or (not (eq b (current-buffer)))
- (< (point) s)
- (> (point) e))
-
- (semantic-complete-inline-exit)
- )
-
-
- ((and (setq txt (semantic-completion-text))
- (not (string= txt ""))
- (and (/= (point) s)
- (save-excursion
- (forward-char -1)
- (not (looking-at "\\(\\w\\|\\s_\\)")))))
-
- (semantic-complete-inline-exit))
- ((lookup-key semantic-complete-inline-map
- (this-command-keys) nil)
-
-
- nil
- )
- (t
-
- (semantic-complete-inline-force-display)
- ))))
-
- (error (semantic-complete-inline-exit))))
- (defun semantic-complete-inline-force-display ()
- "Force the display of whatever the current completions are.
- DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE."
- (condition-case e
- (save-excursion
- (let ((collector semantic-completion-collector-engine)
- (displayor semantic-completion-display-engine)
- (contents (semantic-completion-text)))
- (when collector
- (semantic-collector-calculate-completions
- collector contents nil)
- (semantic-displayor-set-completions
- displayor
- (semantic-collector-all-completions collector contents)
- contents)
-
- (semantic-displayor-show-request displayor))
- ))
- (error (message "Bug Showing Completions: %S" e))))
- (defun semantic-complete-inline-tag-engine
- (collector displayor buffer start end)
- "Perform completion based on semantic tags in a buffer.
- Argument COLLECTOR is an object which can be used to calculate
- a list of possible hits. See `semantic-completion-collector-engine'
- for details on COLLECTOR.
- Argument DISPLAYOR is an object used to display a list of possible
- completions for a given prefix. See`semantic-completion-display-engine'
- for details on DISPLAYOR.
- BUFFER is the buffer in which completion will take place.
- START is a location for the start of the full symbol.
- If the symbol being completed is \"foo.ba\", then START
- is on the \"f\" character.
- END is at the end of the current symbol being completed."
-
- (setq semantic-completion-collector-engine collector
- semantic-completion-display-engine displayor)
-
- (setq semantic-complete-inline-overlay
- (semantic-make-overlay start end buffer nil t))
- (semantic-overlay-put semantic-complete-inline-overlay
- 'face
- 'semantic-complete-inline-face)
- (semantic-overlay-put semantic-complete-inline-overlay
- 'window-config-start
- (current-window-configuration))
-
- (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
- (add-hook 'post-command-hook 'semantic-complete-post-command-hook)
-
- (semantic-complete-inline-force-display)
- )
- (defun semantic-complete-inline-TAB ()
- "Perform inline completion."
- (interactive)
- (let ((cmpl (semantic-complete-do-completion nil t)))
- (cond
- ((eq cmpl 'complete)
- (semantic-complete-inline-force-display))
- ((eq cmpl 'done)
- (semantic-complete-inline-done))
- ))
- )
- (defun semantic-complete-inline-down()
- "Focus forwards through the displayor."
- (interactive)
- (let ((displayor semantic-completion-display-engine))
- (semantic-displayor-focus-next displayor)
- (semantic-displayor-focus-request displayor)
- ))
- (defun semantic-complete-inline-up ()
- "Focus backwards through the displayor."
- (interactive)
- (let ((displayor semantic-completion-display-engine))
- (semantic-displayor-focus-previous displayor)
- (semantic-displayor-focus-request displayor)
- ))
- (defun semantic-complete-next-action (partial)
- "Determine what the next completion action should be.
- PARTIAL is non-nil if we are doing partial completion.
- First, the collector can determine if we should perform a completion or not.
- If there is nothing to complete, then the displayor determines if we are
- to show a completion list, scroll, or perhaps do a focus (if it is capable.)
- Expected return values are:
- done -> We have a singular match
- empty -> There are no matches to the current text
- complete -> Perform a completion action
- complete-whitespace -> Complete next whitespace type character.
- display -> Show the list of completions
- scroll -> The completions have been shown, and the user keeps hitting
- the complete button. If possible, scroll the completions
- focus -> The displayor knows how to shift focus among possible completions.
- Let it do that.
- displayend -> Whatever options the displayor had for repeating options, there
- are none left. Try something new."
- (let ((ans1 (semantic-collector-next-action
- semantic-completion-collector-engine
- partial))
- (ans2 (semantic-displayor-next-action
- semantic-completion-display-engine))
- )
- (cond
-
- ((not ans1)
- ans2)
-
-
- ((and (eq ans1 'done) ans2)
- ans2)
-
- (t
- ans1))))
- (defvar semantic-collector-per-buffer-list nil
- "List of collectors active in this buffer.")
- (make-variable-buffer-local 'semantic-collector-per-buffer-list)
- (defvar semantic-collector-list nil
- "List of global collectors active this session.")
- (defclass semantic-collector-abstract ()
- ((buffer :initarg :buffer
- :type buffer
- :documentation "Originating buffer for this collector.
- Some collectors use a given buffer as a starting place while looking up
- tags.")
- (cache :initform nil
- :type (or null semanticdb-find-result-with-nil)
- :documentation "Cache of tags.
- These tags are re-used during a completion session.
- Sometimes these tags are cached between completion sessions.")
- (last-all-completions :initarg nil
- :type semanticdb-find-result-with-nil
- :documentation "Last result of `all-completions'.
- This result can be used for refined completions as `last-prefix' gets
- closer to a specific result.")
- (last-prefix :type string
- :protection :protected
- :documentation "The last queried prefix.
- This prefix can be used to cache intermediate completion offers.
- making the action of homing in on a token faster.")
- (last-completion :type (or null string)
- :documentation "The last calculated completion.
- This completion is calculated and saved for future use.")
- (last-whitespace-completion :type (or null string)
- :documentation "The last whitespace completion.
- For partial completion, SPC will disambiguate over whitespace type
- characters. This is the last calculated version.")
- (current-exact-match :type list
- :protection :protected
- :documentation "The list of matched tags.
- When tokens are matched, they are added to this list.")
- )
- "Root class for completion engines.
- The baseclass provides basic functionality for interacting with
- a completion displayor object, and tracking the current progress
- of a completion."
- :abstract t)
- (defmethod semantic-collector-cleanup ((obj semantic-collector-abstract))
- "Clean up any mess this collector may have."
- nil)
- (defmethod semantic-collector-next-action
- ((obj semantic-collector-abstract) partial)
- "What should we do next? OBJ can predict a next good action.
- PARTIAL indicates if we are doing a partial completion."
- (if (and (slot-boundp obj 'last-completion)
- (string= (semantic-completion-text) (oref obj last-completion)))
- (let* ((cem (semantic-collector-current-exact-match obj))
- (cemlen (semanticdb-find-result-length cem))
- (cac (semantic-collector-all-completions
- obj (semantic-completion-text)))
- (caclen (semanticdb-find-result-length cac)))
- (cond ((and cem (= cemlen 1)
- cac (> caclen 1)
- (eq last-command this-command))
-
- nil)
- ((and cem (= cemlen 1))
- 'done)
- ((and (not cem) (not cac))
- 'empty)
- ((and partial (semantic-collector-try-completion-whitespace
- obj (semantic-completion-text)))
- 'complete-whitespace)))
- 'complete))
- (defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract)
- last-prefix)
- "Return non-nil if OBJ's prefix matches PREFIX."
- (and (slot-boundp obj 'last-prefix)
- (string= (oref obj last-prefix) last-prefix)))
- (defmethod semantic-collector-get-cache ((obj semantic-collector-abstract))
- "Get the raw cache of tags for completion.
- Calculate the cache if there isn't one."
- (or (oref obj cache)
- (semantic-collector-calculate-cache obj)))
- (defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-abstract) prefix completionlist)
- "Calculate the completions for prefix from completionlist.
- Output must be in semanticdb Find result format."
-
- (let ((table (with-current-buffer (oref obj buffer)
- semanticdb-current-table))
- (result (semantic-find-tags-for-completion
- prefix
-
-
- (semanticdb-strip-find-results completionlist)))
- )
- (if result
- (list (cons table result)))))
- (defmethod semantic-collector-calculate-completions
- ((obj semantic-collector-abstract) prefix partial)
- "Calculate completions for prefix as setup for other queries."
- (let* ((case-fold-search semantic-case-fold)
- (same-prefix-p (semantic-collector-last-prefix= obj prefix))
- (completionlist
- (if (or same-prefix-p
- (and (slot-boundp obj 'last-prefix)
- (eq (compare-strings (oref obj last-prefix) 0 nil
- prefix 0 (length prefix))
- t)))
-
- (oref obj last-all-completions)
- (semantic-collector-get-cache obj)))
-
- (answer (if same-prefix-p
- completionlist
- (semantic-collector-calculate-completions-raw
- obj prefix completionlist))
- )
- (completion nil)
- (complete-not-uniq nil)
- )
-
- (when (not same-prefix-p)
-
- (oset obj last-prefix prefix)
- (oset obj last-all-completions answer))
-
- (setq completion (try-completion
- prefix
- (semanticdb-strip-find-results answer)))
- (oset obj last-whitespace-completion nil)
- (oset obj current-exact-match nil)
-
-
- (when completion
- (oset obj last-completion
- (cond
-
-
- ((eq completion t)
- (oset obj current-exact-match answer)
- prefix)
-
-
- ((setq complete-not-uniq
- (semanticdb-find-tags-by-name
- prefix
- answer))
- (oset obj current-exact-match
- complete-not-uniq)
- prefix
- )
-
-
- (t (or completion prefix))
- )))
- ))
- (defmethod semantic-collector-try-completion-whitespace
- ((obj semantic-collector-abstract) prefix)
- "For OBJ, do whitespace completion based on PREFIX.
- This implies that if there are two completions, one matching
- the test \"prefix\\>\", and one not, the one matching the full
- word version of PREFIX will be chosen, and that text returned.
- This function requires that `semantic-collector-calculate-completions'
- has been run first."
- (let* ((ac (semantic-collector-all-completions obj prefix))
- (matchme (concat "^" prefix "\\>"))
- (compare (semanticdb-find-tags-by-name-regexp matchme ac))
- (numtag (semanticdb-find-result-length compare))
- )
- (if compare
- (let* ((idx 0)
- (cutlen (1+ (length prefix)))
- (twws (semanticdb-find-result-nth compare idx)))
-
-
- (while (and (< idx numtag)
- (< (length (semantic-tag-name (car twws))) cutlen))
- (setq idx (1+ idx)
- twws (semanticdb-find-result-nth compare idx)))
- (when (and twws (car-safe twws))
-
-
- (oset obj last-whitespace-completion
- (substring (semantic-tag-name (car twws))
- 0 cutlen))))
- )))
- (defmethod semantic-collector-current-exact-match ((obj semantic-collector-abstract))
- "Return the active valid MATCH from the semantic collector.
- For now, just return the first element from our list of available
- matches. For semanticdb based results, make sure the file is loaded
- into a buffer."
- (when (slot-boundp obj 'current-exact-match)
- (oref obj current-exact-match)))
- (defmethod semantic-collector-current-whitespace-completion ((obj semantic-collector-abstract))
- "Return the active whitespace completion value."
- (when (slot-boundp obj 'last-whitespace-completion)
- (oref obj last-whitespace-completion)))
- (defmethod semantic-collector-get-match ((obj semantic-collector-abstract))
- "Return the active valid MATCH from the semantic collector.
- For now, just return the first element from our list of available
- matches. For semanticdb based results, make sure the file is loaded
- into a buffer."
- (when (slot-boundp obj 'current-exact-match)
- (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0)))
- (defmethod semantic-collector-all-completions
- ((obj semantic-collector-abstract) prefix)
- "For OBJ, retrieve all completions matching PREFIX.
- The returned list consists of all the tags currently
- matching PREFIX."
- (when (slot-boundp obj 'last-all-completions)
- (oref obj last-all-completions)))
- (defmethod semantic-collector-try-completion
- ((obj semantic-collector-abstract) prefix)
- "For OBJ, attempt to match PREFIX.
- See `try-completion' for details on how this works.
- Return nil for no match.
- Return a string for a partial match.
- For a unique match of PREFIX, return the list of all tags
- with that name."
- (if (slot-boundp obj 'last-completion)
- (oref obj last-completion)))
- (defmethod semantic-collector-calculate-cache
- ((obj semantic-collector-abstract))
- "Calculate the completion cache for OBJ."
- nil
- )
- (defmethod semantic-collector-flush ((this semantic-collector-abstract))
- "Flush THIS collector object, clearing any caches and prefix."
- (oset this cache nil)
- (slot-makeunbound this 'last-prefix)
- (slot-makeunbound this 'last-completion)
- (slot-makeunbound this 'last-all-completions)
- (slot-makeunbound this 'current-exact-match)
- )
- (defclass semantic-collector-buffer-abstract (semantic-collector-abstract)
- ()
- "Root class for per-buffer completion engines.
- These collectors track themselves on a per-buffer basis."
- :abstract t)
- (defmethod constructor :STATIC ((this semantic-collector-buffer-abstract)
- newname &rest fields)
- "Reuse previously created objects of this type in buffer."
- (let ((old nil)
- (bl semantic-collector-per-buffer-list))
- (while (and bl (null old))
- (if (eq (object-class (car bl)) this)
- (setq old (car bl))))
- (unless old
- (let ((new (call-next-method)))
- (add-to-list 'semantic-collector-per-buffer-list new)
- (setq old new)))
- (slot-makeunbound old 'last-completion)
- (slot-makeunbound old 'last-prefix)
- (slot-makeunbound old 'current-exact-match)
- old))
- (defun semantic-collector-buffer-flush (newcache)
- "Flush all buffer collector objects.
- NEWCACHE is the new tag table, but we ignore it."
- (condition-case nil
- (let ((l semantic-collector-per-buffer-list))
- (while l
- (if (car l) (semantic-collector-flush (car l)))
- (setq l (cdr l))))
- (error nil)))
- (add-hook 'semantic-after-toplevel-cache-change-hook
- 'semantic-collector-buffer-flush)
- (defclass semantic-collector-buffer-deep
- (semantic-collector-buffer-abstract)
- ()
- "Completion engine for tags in the current buffer.
- When searching for a tag, uses semantic deep searche functions.
- Basics search only in the current buffer.")
- (defmethod semantic-collector-calculate-cache
- ((obj semantic-collector-buffer-deep))
- "Calculate the completion cache for OBJ.
- Uses `semantic-flatten-tags-table'"
- (oset obj cache
-
-
- (list
- (cons semanticdb-current-table
- (semantic-flatten-tags-table (oref obj buffer))))))
- (defclass semantic-collector-project-abstract (semantic-collector-abstract)
- ((path :initarg :path
- :initform nil
- :documentation "List of database tables to search.
- At creation time, it can be anything accepted by
- `semanticdb-find-translate-path' as a PATH argument.")
- )
- "Root class for project wide completion engines.
- Uses semanticdb for searching all tags in the current project."
- :abstract t)
- (defclass semantic-collector-project (semantic-collector-project-abstract)
- ()
- "Completion engine for tags in a project.")
- (defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-project) prefix completionlist)
- "Calculate the completions for prefix from completionlist."
- (semanticdb-find-tags-for-completion prefix (oref obj path)))
- (defclass semantic-collector-project-brutish (semantic-collector-project-abstract)
- ()
- "Completion engine for tags in a project.")
- (declare-function semanticdb-brute-deep-find-tags-for-completion
- "semantic/db-find")
- (defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-project-brutish) prefix completionlist)
- "Calculate the completions for prefix from completionlist."
- (require 'semantic/db-find)
- (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))
- (defclass semantic-collector-local-members (semantic-collector-project-abstract)
- ((scope :initform nil
- :type (or null semantic-scope-cache)
- :documentation
- "The scope the local members are being completed from."))
- "Completion engine for tags in a project.")
- (defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-local-members) prefix completionlist)
- "Calculate the completions for prefix from completionlist."
- (let* ((scope (or (oref obj scope)
- (oset obj scope (semantic-calculate-scope))))
- (localstuff (oref scope scope)))
- (list
- (cons
- (oref scope :table)
- (semantic-find-tags-for-completion prefix localstuff)))))
-
- (defclass semantic-collector-analyze-completions (semantic-collector-abstract)
- ((context :initarg :context
- :type semantic-analyze-context
- :documentation "An analysis context.
- Specifies some context location from whence completion lists will be drawn."
- )
- (first-pass-completions :type list
- :documentation "List of valid completion tags.
- This list of tags is generated when completion starts. All searches
- derive from this list.")
- )
- "Completion engine that uses the context analyzer to provide options.
- The only options available for completion are those which can be logically
- inserted into the current context.")
- (defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-analyze-completions) prefix completionlist)
- "calculate the completions for prefix from completionlist."
-
- (if (not (slot-boundp obj 'first-pass-completions))
- (oset obj first-pass-completions
- (semantic-analyze-possible-completions (oref obj context))))
-
-
- (list (cons (with-current-buffer (oref (oref obj context) buffer)
- semanticdb-current-table)
- (semantic-find-tags-for-completion
- prefix
- (oref obj first-pass-completions)))))
- (defclass semantic-displayor-abstract ()
- ((table :type (or null semanticdb-find-result-with-nil)
- :initform nil
- :protection :protected
- :documentation "List of tags this displayor is showing.")
- (last-prefix :type string
- :protection :protected
- :documentation "Prefix associated with slot `table'")
- )
- "Abstract displayor baseclass.
- Manages the display of some number of tags.
- Provides the basics for a displayor, including interacting with
- a collector, and tracking tables of completion to display."
- :abstract t)
- (defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract))
- "Clean up any mess this displayor may have."
- nil)
- (defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract))
- "The next action to take on the minibuffer related to display."
- (if (and (slot-boundp obj 'last-prefix)
- (string= (oref obj last-prefix) (semantic-completion-text))
- (eq last-command this-command))
- 'scroll
- 'display))
- (defmethod semantic-displayor-set-completions ((obj semantic-displayor-abstract)
- table prefix)
- "Set the list of tags to be completed over to TABLE."
- (oset obj table table)
- (oset obj last-prefix prefix))
- (defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract))
- "A request to show the current tags table."
- (ding))
- (defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract))
- "A request to for the displayor to focus on some tag option."
- (ding))
- (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-abstract))
- "A request to for the displayor to scroll the completion list (if needed)."
- (scroll-other-window))
- (defmethod semantic-displayor-focus-previous ((obj semantic-displayor-abstract))
- "Set the current focus to the previous item."
- nil)
- (defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract))
- "Set the current focus to the next item."
- nil)
- (defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract))
- "Return a single tag currently in focus.
- This object type doesn't do focus, so will never have a focus object."
- nil)
- (defcustom semantic-completion-displayor-format-tag-function
- #'semantic-format-tag-name
- "*A Tag format function to use when showing completions."
- :group 'semantic
- :type semantic-format-tag-custom-list)
- (defclass semantic-displayor-traditional (semantic-displayor-abstract)
- ()
- "Display options in *Completions* buffer.
- Traditional display mechanism for a list of possible completions.
- Completions are showin in a new buffer and listed with the ability
- to click on the items to aid in completion.")
- (defmethod semantic-displayor-show-request ((obj semantic-displayor-traditional))
- "A request to show the current tags table."
-
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list
- (mapcar semantic-completion-displayor-format-tag-function
- (semanticdb-strip-find-results (oref obj table))))
- )
- )
- (defclass semantic-displayor-focus-abstract (semantic-displayor-abstract)
- ((focus :type number
- :protection :protected
- :documentation "A tag index from `table' which has focus.
- Multiple calls to the display function can choose to focus on a
- given tag, by highlighting its location.")
- (find-file-focus
- :allocation :class
- :initform nil
- :documentation
- "Non-nil if focusing requires a tag's buffer be in memory.")
- )
- "Abstract displayor supporting `focus'.
- A displayor which has the ability to focus in on one tag.
- Focusing is a way of differentiating among multiple tags
- which have the same name."
- :abstract t)
- (defmethod semantic-displayor-next-action ((obj semantic-displayor-focus-abstract))
- "The next action to take on the minibuffer related to display."
- (if (and (slot-boundp obj 'last-prefix)
- (string= (oref obj last-prefix) (semantic-completion-text))
- (eq last-command this-command))
- (if (and
- (slot-boundp obj 'focus)
- (slot-boundp obj 'table)
- (<= (semanticdb-find-result-length (oref obj table))
- (1+ (oref obj focus))))
-
- 'displayend
-
- 'focus)
- 'display))
- (defmethod semantic-displayor-set-completions ((obj semantic-displayor-focus-abstract)
- table prefix)
- "Set the list of tags to be completed over to TABLE."
- (call-next-method)
- (slot-makeunbound obj 'focus))
- (defmethod semantic-displayor-focus-previous ((obj semantic-displayor-focus-abstract))
- "Set the current focus to the previous item.
- Not meaningful return value."
- (when (and (slot-boundp obj 'table) (oref obj table))
- (with-slots (table) obj
- (if (or (not (slot-boundp obj 'focus))
- (<= (oref obj focus) 0))
- (oset obj focus (1- (semanticdb-find-result-length table)))
- (oset obj focus (1- (oref obj focus)))
- )
- )))
- (defmethod semantic-displayor-focus-next ((obj semantic-displayor-focus-abstract))
- "Set the current focus to the next item.
- Not meaningful return value."
- (when (and (slot-boundp obj 'table) (oref obj table))
- (with-slots (table) obj
- (if (not (slot-boundp obj 'focus))
- (oset obj focus 0)
- (oset obj focus (1+ (oref obj focus)))
- )
- (if (<= (semanticdb-find-result-length table) (oref obj focus))
- (oset obj focus 0))
- )))
- (defmethod semantic-displayor-focus-tag ((obj semantic-displayor-focus-abstract))
- "Return the next tag OBJ should focus on."
- (when (and (slot-boundp obj 'table) (oref obj table))
- (with-slots (table) obj
- (semanticdb-find-result-nth table (oref obj focus)))))
- (defmethod semantic-displayor-current-focus ((obj semantic-displayor-focus-abstract))
- "Return the tag currently in focus, or call parent method."
- (if (and (slot-boundp obj 'focus)
- (slot-boundp obj 'table)
-
-
- (slot-boundp obj 'last-prefix)
- (string= (semantic-completion-text) (oref obj last-prefix))
- )
-
- (if (oref obj find-file-focus)
- (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj focus))
-
-
- (car (semanticdb-find-result-nth (oref obj table) (oref obj focus))))
-
- (call-next-method)))
- (defclass semantic-displayor-traditional-with-focus-highlight
- (semantic-displayor-focus-abstract semantic-displayor-traditional)
- ((find-file-focus :initform t))
- "Display completions in *Completions* buffer, with focus highlight.
- A traditional displayor which can focus on a tag by showing it.
- Same as `semantic-displayor-traditional', but with selection between
- multiple tags with the same name done by 'focusing' on the source
- location of the different tags to differentiate them.")
- (defmethod semantic-displayor-focus-request
- ((obj semantic-displayor-traditional-with-focus-highlight))
- "Focus in on possible tag completions.
- Focus is performed by cycling through the tags and highlighting
- one in the source buffer."
- (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
- (focus (semantic-displayor-focus-tag obj))
-
- (rtag (car focus))
- (rtable (cdr focus))
-
- (nt (semanticdb-normalize-one-tag rtable rtag))
- (tag (cdr nt))
- (table (car nt))
- )
-
- (when (not tag) (setq table rtable tag rtag))
-
- (let ((buf (or (semantic-tag-buffer tag)
- (and table (semanticdb-get-buffer table)))))
-
- (when (not buf)
- (with-current-buffer (get-buffer-create "*Completion Focus*")
- (erase-buffer)
- (insert "Focus on tag: \n")
- (insert (semantic-format-tag-summarize tag nil t) "\n\n")
- (when table
- (insert "From table: \n")
- (insert (object-name table) "\n\n"))
- (when buf
- (insert "In buffer: \n\n")
- (insert (format "%S" buf)))
- (setq buf (current-buffer))))
-
- (if (get-buffer-window buf)
- (select-window (get-buffer-window buf))
- (switch-to-buffer-other-window buf t)
- (select-window (get-buffer-window buf)))
-
- (unwind-protect
- (if (semantic-tag-with-position-p tag)
-
- (progn
- (goto-char (semantic-tag-start tag))
-
-
-
- (semantic-momentary-highlight-tag (semantic-current-tag))
- ))
- (select-window (minibuffer-window)))
-
- (let* ((mbc (semantic-completion-text))
- (ftn (semantic-tag-name tag))
- (diff (substring ftn (length mbc))))
- (semantic-completion-message
- (format "%s [%d of %d matches]" diff (1+ (oref obj focus)) tablelength)))
- )))
- (defclass semantic-displayor-tooltip (semantic-displayor-traditional)
- ((max-tags :type integer
- :initarg :max-tags
- :initform 5
- :custom integer
- :documentation
- "Max number of tags displayed on tooltip at once.
- If `force-show' is 1, this value is ignored with typing tab or space twice continuously.
- if `force-show' is 0, this value is always ignored.")
- (force-show :type integer
- :initarg :force-show
- :initform 1
- :custom (choice (const
- :tag "Show when double typing"
- 1)
- (const
- :tag "Show always"
- 0)
- (const
- :tag "Show if the number of tags is less than `max-tags'."
- -1))
- :documentation
- "Control the behavior of the number of tags is greater than `max-tags'.
- -1 means tags are never shown.
- 0 means the tags are always shown.
- 1 means tags are shown if space or tab is typed twice continuously.")
- (typing-count :type integer
- :initform 0
- :documentation
- "Counter holding how many times the user types space or tab continuously before showing tags.")
- (shown :type boolean
- :initform nil
- :documentation
- "Flag representing whether tags is shown once or not.")
- )
- "Display completions options in a tooltip.
- Display mechanism using tooltip for a list of possible completions.")
- (defmethod initialize-instance :AFTER ((obj semantic-displayor-tooltip) &rest args)
- "Make sure we have tooltips required."
- (condition-case nil
- (require 'tooltip)
- (error nil))
- )
- (defmethod semantic-displayor-show-request ((obj semantic-displayor-tooltip))
- "A request to show the current tags table."
- (if (or (not (featurep 'tooltip)) (not tooltip-mode))
-
-
- (call-next-method)
- (let* ((tablelong (semanticdb-strip-find-results (oref obj table)))
- (table (semantic-unique-tag-table-by-name tablelong))
- (l (mapcar semantic-completion-displayor-format-tag-function table))
- (ll (length l))
- (typing-count (oref obj typing-count))
- (force-show (oref obj force-show))
- (matchtxt (semantic-completion-text))
- msg)
- (if (or (oref obj shown)
- (< ll (oref obj max-tags))
- (and (<= 0 force-show)
- (< (1- force-show) typing-count)))
- (progn
- (oset obj typing-count 0)
- (oset obj shown t)
- (if (eq 1 ll)
-
-
-
-
-
- (if (string= matchtxt (semantic-tag-name (car table)))
- (setq msg (concat "[COMPLETE]\n" (car l)))
- (setq msg (car l)))
-
- (setq msg (mapconcat 'identity l "\n"))
-
- (if (eq 0 (length msg))
- (setq msg "[NO MATCH]")))
- (semantic-displayor-tooltip-show msg))
-
-
-
- (if (and (stringp (this-command-keys))
- (string= (this-command-keys) "\C-i"))
- (oset obj typing-count (1+ typing-count)))
-
-
- (setcdr (nthcdr (oref obj max-tags) l) nil)
- (setq msg (mapconcat 'identity l "\n"))
- (cond
- ((= force-show -1)
- (semantic-displayor-tooltip-show (concat msg "\n...")))
- ((= force-show 1)
- (semantic-displayor-tooltip-show (concat msg "\n(TAB for more)")))
- )))))
- (eval-and-compile
- (if (fboundp 'window-inside-edges)
-
- (defalias 'semantic-displayor-window-edges
- 'window-inside-edges)
-
- (defalias 'semantic-displayor-window-edges
- 'window-edges)
- ))
- (defun semantic-displayor-point-position ()
- "Return the location of POINT as positioned on the selected frame.
- Return a cons cell (X . Y)"
- (let* ((frame (selected-frame))
- (left (frame-parameter frame 'left))
- (top (frame-parameter frame 'top))
- (point-pix-pos (posn-x-y (posn-at-point)))
- (edges (window-inside-pixel-edges (selected-window))))
- (cons (+ (car point-pix-pos) (car edges) left)
- (+ (cdr point-pix-pos) (cadr edges) top))))
- (defun semantic-displayor-tooltip-show (text)
- "Display a tooltip with TEXT near cursor."
- (let ((point-pix-pos (semantic-displayor-point-position))
- (tooltip-frame-parameters
- (append tooltip-frame-parameters nil)))
- (push
- (cons 'left (+ (car point-pix-pos) (frame-char-width)))
- tooltip-frame-parameters)
- (push
- (cons 'top (+ (cdr point-pix-pos) (frame-char-height)))
- tooltip-frame-parameters)
- (tooltip-show text)))
- (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip))
- "A request to for the displayor to scroll the completion list (if needed)."
-
- (oset obj max-tags 30)
- (semantic-displayor-show-request obj)
- )
- (defclass semantic-displayor-ghost (semantic-displayor-focus-abstract)
- ((ghostoverlay :type overlay
- :documentation
- "The overlay the ghost text is displayed in.")
- (first-show :initform t
- :documentation
- "Non nil if we have not seen our first show request.")
- )
- "Cycle completions inline with ghost text.
- Completion displayor using ghost chars after point for focus options.
- Whichever completion is currently in focus will be displayed as ghost
- text using overlay options.")
- (defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost))
- "The next action to take on the inline completion related to display."
- (let ((ans (call-next-method))
- (table (when (slot-boundp obj 'table)
- (oref obj table))))
- (if (and (eq ans 'displayend)
- table
- (= (semanticdb-find-result-length table) 1)
- )
- nil
- ans)))
- (defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost))
- "Clean up any mess this displayor may have."
- (when (slot-boundp obj 'ghostoverlay)
- (semantic-overlay-delete (oref obj ghostoverlay)))
- )
- (defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost)
- table prefix)
- "Set the list of tags to be completed over to TABLE."
- (call-next-method)
- (semantic-displayor-cleanup obj)
- )
- (defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost))
- "A request to show the current tags table."
- (semantic-displayor-focus-next obj)
- (semantic-displayor-focus-request obj)
-
-
-
- )
- (defmethod semantic-displayor-focus-request
- ((obj semantic-displayor-ghost))
- "Focus in on possible tag completions.
- Focus is performed by cycling through the tags and showing a possible
- completion text in ghost text."
- (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
- (focus (semantic-displayor-focus-tag obj))
- (tag (car focus))
- )
- (if (not tag)
- (semantic-completion-message "No tags to focus on.")
-
-
- (when (or (not (slot-boundp obj 'ghostoverlay))
- (not (semantic-overlay-live-p (oref obj ghostoverlay))))
- (oset obj ghostoverlay
- (semantic-make-overlay (point) (1+ (point)) (current-buffer) t)))
- (let* ((lp (semantic-completion-text))
- (os (substring (semantic-tag-name tag) (length lp)))
- (ol (oref obj ghostoverlay))
- )
- (put-text-property 0 (length os) 'face 'region os)
- (semantic-overlay-put
- ol 'display (concat os (buffer-substring (point) (1+ (point)))))
- )
-
- (let* ((mbc (semantic-completion-text))
- (ftn (concat (semantic-tag-name tag)))
- )
- (put-text-property (length mbc) (length ftn) 'face
- 'bold ftn)
- (semantic-completion-message
- (format "%s [%d of %d matches]" ftn (1+ (oref obj focus)) tablelength)))
- )))
- (defvar semantic-complete-inline-custom-type
- (append '(radio)
- (mapcar
- (lambda (class)
- (let* ((C (intern (car class)))
- (doc (documentation-property C 'variable-documentation))
- (doc1 (car (split-string doc "\n")))
- )
- (list 'const
- :tag doc1
- C)))
- (eieio-build-class-alist semantic-displayor-abstract t))
- )
- "Possible options for inline completion displayors.
- Use this to enable custom editing.")
- (defcustom semantic-complete-inline-analyzer-displayor-class
- 'semantic-displayor-traditional
- "*Class for displayor to use with inline completion."
- :group 'semantic
- :type semantic-complete-inline-custom-type
- )
- (defun semantic-complete-read-tag-buffer-deep (prompt &optional
- default-tag
- initial-input
- history)
- "Ask for a tag by name from the current buffer.
- Available tags are from the current buffer, at any level.
- Completion options are presented in a traditional way, with highlighting
- to resolve same-name collisions.
- PROMPT is a string to prompt with.
- DEFAULT-TAG is a semantic tag or string to use as the default value.
- If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
- HISTORY is a symbol representing a variable to store the history in."
- (semantic-complete-read-tag-engine
- (semantic-collector-buffer-deep prompt :buffer (current-buffer))
- (semantic-displayor-traditional-with-focus-highlight "simple")
-
- prompt
- default-tag
- initial-input
- history)
- )
- (defun semantic-complete-read-tag-local-members (prompt &optional
- default-tag
- initial-input
- history)
- "Ask for a tag by name from the local type members.
- Available tags are from the current scope.
- Completion options are presented in a traditional way, with highlighting
- to resolve same-name collisions.
- PROMPT is a string to prompt with.
- DEFAULT-TAG is a semantic tag or string to use as the default value.
- If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
- HISTORY is a symbol representing a variable to store the history in."
- (semantic-complete-read-tag-engine
- (semantic-collector-local-members prompt :buffer (current-buffer))
- (semantic-displayor-traditional-with-focus-highlight "simple")
-
- prompt
- default-tag
- initial-input
- history)
- )
- (defun semantic-complete-read-tag-project (prompt &optional
- default-tag
- initial-input
- history)
- "Ask for a tag by name from the current project.
- Available tags are from the current project, at the top level.
- Completion options are presented in a traditional way, with highlighting
- to resolve same-name collisions.
- PROMPT is a string to prompt with.
- DEFAULT-TAG is a semantic tag or string to use as the default value.
- If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
- HISTORY is a symbol representing a variable to store the history in."
- (semantic-complete-read-tag-engine
- (semantic-collector-project-brutish prompt
- :buffer (current-buffer)
- :path (current-buffer)
- )
- (semantic-displayor-traditional-with-focus-highlight "simple")
- prompt
- default-tag
- initial-input
- history)
- )
- (defun semantic-complete-inline-tag-project ()
- "Complete a symbol name by name from within the current project.
- This is similar to `semantic-complete-read-tag-project', except
- that the completion interaction is in the buffer where the context
- was calculated from.
- Customize `semantic-complete-inline-analyzer-displayor-class'
- to control how completion options are displayed.
- See `semantic-complete-inline-tag-engine' for details on how
- completion works."
- (let* ((collector (semantic-collector-project-brutish
- "inline"
- :buffer (current-buffer)
- :path (current-buffer)))
- (sbounds (semantic-ctxt-current-symbol-and-bounds))
- (syms (car sbounds))
- (start (car (nth 2 sbounds)))
- (end (cdr (nth 2 sbounds)))
- (rsym (reverse syms))
- (thissym (nth 1 sbounds))
- (nextsym (car-safe (cdr rsym)))
- (complst nil))
- (when (and thissym (or (not (string= thissym ""))
- nextsym))
-
- (semantic-collector-calculate-completions
- collector thissym nil)
-
- (setq complst (semanticdb-strip-find-results
- (semantic-collector-all-completions collector thissym)))
-
- (setq complst (semantic-unique-tag-table-by-name complst))
- (if (or (and (= (length complst) 1)
-
-
- (let ((compname (semantic-tag-name (car complst))))
- (not (string= compname thissym))))
- (> (length complst) 1))
-
- (semantic-complete-inline-tag-engine
- collector
- (funcall semantic-complete-inline-analyzer-displayor-class
- "inline displayor")
-
- (current-buffer)
- start end))
- )))
- (defun semantic-complete-read-tag-analyzer (prompt &optional
- context
- history)
- "Ask for a tag by name based on the current context.
- The function `semantic-analyze-current-context' is used to
- calculate the context. `semantic-analyze-possible-completions' is used
- to generate the list of possible completions.
- PROMPT is the first part of the prompt. Additional prompt
- is added based on the contexts full prefix.
- CONTEXT is the semantic analyzer context to start with.
- HISTORY is a symbol representing a variable to store the history in.
- usually a default-tag and initial-input are available for completion
- prompts. these are calculated from the CONTEXT variable passed in."
- (if (not context) (setq context (semantic-analyze-current-context (point))))
- (let* ((syms (semantic-ctxt-current-symbol (point)))
- (inp (car (reverse syms))))
- (setq syms (nreverse (cdr (nreverse syms))))
- (semantic-complete-read-tag-engine
- (semantic-collector-analyze-completions
- prompt
- :buffer (oref context buffer)
- :context context)
- (semantic-displayor-traditional-with-focus-highlight "simple")
- (with-current-buffer (oref context buffer)
- (goto-char (cdr (oref context bounds)))
- (concat prompt (mapconcat 'identity syms ".")
- (if syms "." "")
- ))
- nil
- inp
- history)))
- (defun semantic-complete-inline-analyzer (context)
- "Complete a symbol name by name based on the current context.
- This is similar to `semantic-complete-read-tag-analyze', except
- that the completion interaction is in the buffer where the context
- was calculated from.
- CONTEXT is the semantic analyzer context to start with.
- Customize `semantic-complete-inline-analyzer-displayor-class'
- to control how completion options are displayed.
- See `semantic-complete-inline-tag-engine' for details on how
- completion works."
- (if (not context) (setq context (semantic-analyze-current-context (point))))
- (if (not context) (error "Nothing to complete on here"))
- (let* ((collector (semantic-collector-analyze-completions
- "inline"
- :buffer (oref context buffer)
- :context context))
- (syms (semantic-ctxt-current-symbol (point)))
- (rsym (reverse syms))
- (thissym (car rsym))
- (nextsym (car-safe (cdr rsym)))
- (complst nil))
- (when (and thissym (or (not (string= thissym ""))
- nextsym))
-
- (semantic-collector-calculate-completions
- collector thissym nil)
-
- (setq complst (semanticdb-strip-find-results
- (semantic-collector-all-completions collector thissym)))
-
- (setq complst (semantic-unique-tag-table-by-name complst))
- (if (or (and (= (length complst) 1)
-
-
- (let ((compname (semantic-tag-name (car complst))))
- (not (string= compname thissym))))
- (> (length complst) 1))
-
- (semantic-complete-inline-tag-engine
- collector
- (funcall semantic-complete-inline-analyzer-displayor-class
- "inline displayor")
-
- (oref context buffer)
- (car (oref context bounds))
- (cdr (oref context bounds))
- ))
- )))
- (defcustom semantic-complete-inline-analyzer-idle-displayor-class
- 'semantic-displayor-ghost
- "*Class for displayor to use with inline completion at idle time."
- :group 'semantic
- :type semantic-complete-inline-custom-type
- )
- (defun semantic-complete-inline-analyzer-idle (context)
- "Complete a symbol name by name based on the current context for idle time.
- CONTEXT is the semantic analyzer context to start with.
- This function is used from `semantic-idle-completions-mode'.
- This is the same as `semantic-complete-inline-analyzer', except that
- it uses `semantic-complete-inline-analyzer-idle-displayor-class'
- to control how completions are displayed.
- See `semantic-complete-inline-tag-engine' for details on how
- completion works."
- (let ((semantic-complete-inline-analyzer-displayor-class
- semantic-complete-inline-analyzer-idle-displayor-class))
- (semantic-complete-inline-analyzer context)
- ))
- (defun semantic-complete-jump-local ()
- "Jump to a local semantic symbol."
- (interactive)
- (let ((tag (semantic-complete-read-tag-buffer-deep "Jump to symbol: ")))
- (when (semantic-tag-p tag)
- (push-mark)
- (goto-char (semantic-tag-start tag))
- (semantic-momentary-highlight-tag tag)
- (message "%S: %s "
- (semantic-tag-class tag)
- (semantic-tag-name tag)))))
- (defun semantic-complete-jump ()
- "Jump to a semantic symbol."
- (interactive)
- (let* ((tag (semantic-complete-read-tag-project "Jump to symbol: ")))
- (when (semantic-tag-p tag)
- (push-mark)
- (semantic-go-to-tag tag)
- (switch-to-buffer (current-buffer))
- (semantic-momentary-highlight-tag tag)
- (message "%S: %s "
- (semantic-tag-class tag)
- (semantic-tag-name tag)))))
- (defun semantic-complete-jump-local-members ()
- "Jump to a semantic symbol."
- (interactive)
- (let* ((tag (semantic-complete-read-tag-local-members "Jump to symbol: ")))
- (when (semantic-tag-p tag)
- (let ((start (condition-case nil (semantic-tag-start tag)
- (error nil))))
- (unless start
- (error "Tag %s has no location" (semantic-format-tag-prototype tag)))
- (push-mark)
- (goto-char start)
- (semantic-momentary-highlight-tag tag)
- (message "%S: %s "
- (semantic-tag-class tag)
- (semantic-tag-name tag))))))
- (defun semantic-complete-analyze-and-replace ()
- "Perform prompt completion to do in buffer completion.
- `semantic-analyze-possible-completions' is used to determine the
- possible values.
- The minibuffer is used to perform the completion.
- The result is inserted as a replacement of the text that was there."
- (interactive)
- (let* ((c (semantic-analyze-current-context (point)))
- (tag (save-excursion (semantic-complete-read-tag-analyzer "" c))))
-
- (goto-char (car (oref c bounds)))
- (delete-region (point) (cdr (oref c bounds)))
- (insert (semantic-tag-name tag))
- (message "%S" (semantic-format-tag-summarize tag))))
- (defun semantic-complete-analyze-inline ()
- "Perform prompt completion to do in buffer completion.
- `semantic-analyze-possible-completions' is used to determine the
- possible values.
- The function returns immediately, leaving the buffer in a mode that
- will perform the completion.
- Configure `semantic-complete-inline-analyzer-displayor-class' to change
- how completion options are displayed."
- (interactive)
-
- (if (not (semantic-completion-inline-active-p))
- (semantic-complete-inline-analyzer
- (semantic-analyze-current-context (point))))
-
- (if (and (called-interactively-p 'any)
- (not (semantic-completion-inline-active-p)))
- (message "Inline completion not needed.")
-
-
- (semantic-complete-inline-TAB)))
- (defun semantic-complete-analyze-inline-idle ()
- "Perform prompt completion to do in buffer completion.
- `semantic-analyze-possible-completions' is used to determine the
- possible values.
- The function returns immediately, leaving the buffer in a mode that
- will perform the completion.
- Configure `semantic-complete-inline-analyzer-idle-displayor-class'
- to change how completion options are displayed."
- (interactive)
-
- (if (not (semantic-completion-inline-active-p))
- (semantic-complete-inline-analyzer-idle
- (semantic-analyze-current-context (point))))
-
- (if (and (called-interactively-p 'interactive)
- (not (semantic-completion-inline-active-p)))
- (message "Inline completion not needed.")))
- (defun semantic-complete-self-insert (arg)
- "Like `self-insert-command', but does completion afterwards.
- ARG is passed to `self-insert-command'. If ARG is nil,
- use `semantic-complete-analyze-inline' to complete."
- (interactive "p")
-
- (semantic-complete-inline-exit)
-
- (self-insert-command arg)
-
-
- (when (save-window-excursion
- (save-excursion
- (and (not (semantic-exit-on-input 'csi
- (semantic-fetch-tags)
- (semantic-throw-on-input 'csi)
- nil))
- (= arg 1)
- (not (semantic-exit-on-input 'csi
- (semantic-analyze-current-context)
- (semantic-throw-on-input 'csi)
- nil)))))
- (condition-case nil
- (semantic-complete-analyze-inline)
-
- (error nil))
- ))
- (provide 'semantic/complete)
|