Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Misc changes

  • Loading branch information...
commit 61e89969738624b94a4234a656e3279142761e2b 1 parent c88df7d
John Wiegley authored
16 gnus-settings.el
View
@@ -13,11 +13,13 @@
'(gnus-agent-mark-unread-after-downloaded nil)
'(gnus-agent-synchronize-flags t)
'(gnus-alias-default-identity "Gmail")
- '(gnus-alias-identity-alist (quote (("Gmail" "" "\"John Wiegley\" <jwiegley@gmail.com>" "" nil "" "") ("BoostPro" "" "\"John Wiegley\" <johnw@boostpro.com>" "BoostPro Computing" nil "" "John Wiegley
+ '(gnus-alias-identity-alist (quote (("Gmail" "" "\"John Wiegley\" <jwiegley@gmail.com>" "" nil "" "") ("FPComplete" "" "\"John Wiegley\" <johnw@fpcomplete.com>" "FP Complete Corp." nil "" "John Wiegley
+FP Complete Haskell tools, training and consulting
+http://fpcomplete.com johnw on #haskell/irc.freenode.net") ("BoostPro" "" "\"John Wiegley\" <johnw@boostpro.com>" "BoostPro Computing" nil "" "John Wiegley
BoostPro Computing Software Development Training
http://www.boostpro.com Clang/LLVM/EDG Compilers C++ Boost") ("NewArtisans" "" "\"John Wiegley\" <johnw@newartisans.com>" "New Artisans LLC" nil "" "") ("Assembly" "" "\"John Wiegley\" <jwiegley@gmail.com>" "Spiritual Assembly of the Bahá'ís of Peoria" nil "" "Spiritual Assembly of the Bahá'ís of Peoria
John Wiegley, Chairperson"))))
- '(gnus-alias-identity-rules (quote (("Ledger Mailing List" ("To" "ledger-cli@googlegroups\\.com" current) "NewArtisans") ("Emacs Mailing Lists" ("To" "emacs" current) "NewArtisans") ("Emacs Newsgroups" ("Newsgroups" "emacs" current) "NewArtisans") ("BoostPro Mail" ("From" "@boostpro\\.com" current) "BoostPro") ("BoostPro Clients" ("To" "@\\(ti\\)\\.com" current) "BoostPro") ("BoostPro Clients (Copied)" ("Cc" "@\\(ti\\)\\.com" current) "BoostPro") ("C++, LLVM, Boost, and Clang Groups" ("Newsgroups" "\\(c\\+\\+\\|clang\\|llvm\\|[Bb]oost\\|[Rr]yppl\\)" current) "BoostPro") ("C++, LLVM, Boost, and Clang Mailing Lists" ("To" "\\(c\\+\\+\\|clang\\|llvm\\|[Bb]oost\\|[Rr]yppl\\|llvm\\|cfe\\)" current) "BoostPro"))))
+ '(gnus-alias-identity-rules (quote (("Ledger Mailing List" ("To" "ledger-cli@googlegroups\\.com" current) "NewArtisans") ("Emacs Mailing Lists" ("To" "emacs" current) "NewArtisans") ("Emacs Newsgroups" ("Newsgroups" "emacs" current) "NewArtisans") ("FP Complete Mail" ("From" "@fpcomplete\\.com" current) "FPComplete") ("FP Complete Clients" ("To" "@someone\\.com" current) "FPComplete") ("FP Complete Clients (copied)" ("Cc" "@someone\\.com" current) "FPComplete") ("Haskell Groups" ("Newsgroups" "\\(haskell\\|ghc\\)" current) "FPComplete") ("Haskell Mailing Lists" ("To" "\\(haskell\\|ghc\\)" current) "FPComplete") ("BoostPro Mail" ("From" "@boostpro\\.com" current) "BoostPro") ("BoostPro Clients" ("To" "@\\(ti\\)\\.com" current) "BoostPro") ("BoostPro Clients (Copied)" ("Cc" "@\\(ti\\)\\.com" current) "BoostPro") ("C++, LLVM, Boost, and Clang Groups" ("Newsgroups" "\\(c\\+\\+\\|clang\\|llvm\\|[Bb]oost\\|[Rr]yppl\\)" current) "BoostPro") ("C++, LLVM, Boost, and Clang Mailing Lists" ("To" "\\(c\\+\\+\\|clang\\|llvm\\|[Bb]oost\\|[Rr]yppl\\|llvm\\|cfe\\)" current) "BoostPro"))))
'(gnus-alias-override-user-mail-address t)
'(gnus-alias-unknown-identity-rule (quote error))
'(gnus-always-read-dribble-file t)
@@ -35,20 +37,20 @@ John Wiegley, Chairperson"))))
")
'(gnus-group-mode-hook (quote (gnus-topic-mode gnus-agent-mode hl-line-mode)))
'(gnus-group-use-permanent-levels t)
- '(gnus-harvest-sender-alist (quote ((".*@\\(boostpro\\|boost-consulting\\|ti\\)\\.com" . johnw@boostpro\.com) (".*@gnu\\.org" . johnw@gnu\.org))))
+ '(gnus-harvest-sender-alist (quote ((".*@fpcomplete\\.com" . johnw@fpcomplete\.com) (".*@\\(boostpro\\|boost-consulting\\|ti\\)\\.com" . johnw@boostpro\.com) (".*@gnu\\.org" . johnw@gnu\.org))))
'(gnus-home-directory "~/Messages/Gnus/")
- '(gnus-ignored-from-addresses "\\(johnw\\|jwiegley\\)\\(-[^@]+\\)?@\\(gnu\\.org\\|\\(forumjobs\\|3dex\\|gmail\\|hotmail\\|newartisans\\|boostpro\\)\\.com\\|public\\.gmane\\.org\\)")
+ '(gnus-ignored-from-addresses "\\(johnw\\|jwiegley\\)\\(-[^@]+\\)?@\\(gnu\\.org\\|\\(forumjobs\\|3dex\\|gmail\\|hotmail\\|newartisans\\|fpcomplete\\|boostpro\\)\\.com\\|public\\.gmane\\.org\\)")
'(gnus-ignored-mime-types (quote ("application/x-pkcs7-signature" "application/ms-tnef" "text/x-vcard")))
'(gnus-interactive-exit (quote quiet))
'(gnus-large-newsgroup 4000)
- '(gnus-local-domain "boostpro.com")
+ '(gnus-local-domain "fpcomplete.com")
'(gnus-mailing-list-groups "\\`\\(list\\|wg21\\)\\.")
'(gnus-mark-unpicked-articles-as-read t)
'(gnus-message-archive-group (quote ((format-time-string "sent.%Y"))))
'(gnus-message-replyencrypt nil)
'(gnus-novice-user nil)
'(gnus-parameters (quote (("list\\.haskell\\.ghc" (to-address . "glasgow-haskell-users@haskell.org") (to-list . "glasgow-haskell-users@haskell.org") (list-identifier . "\\[Haskell\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "glasgow-haskell-users@haskell.org") (header :contains "list-id" "<glasgow-haskell-users.haskell.org>")))) ("\\`gmane\\." (spam-process gnus-group-spam-exit-processor-report-gmane)) ("mail\\.spam" (total-expire . t) (expiry-wait . 28) (expiry-target . delete) (gnus-article-sort-functions gnus-article-sort-by-chars) (ham-process-destination . "INBOX") (spam-contents gnus-group-spam-classification-spam) (spam-process ((spam spam-use-spamassassin) (ham spam-use-spamassassin)))) ("list\\." (subscribed . t) (gcc-self . t)) ("list\\.wg21\\.\\(.*\\)" (to-address . "c++std-\\1@accu.org") (to-list . "c++std-\\1@accu.org") (gcc-self . t) (gnus-list-identifiers "\\[c\\+\\+std-.+?\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "c++std-\\1@accu.org") (header :contains "list-id" "<c++std-\\1.accu.org>")))) ("INBOX" (total-expire . t) (expiry-wait . 14) (expiry-target . "mail.archive") (spam-process-destination . "mail.spam") (spam-contents gnus-group-spam-classification-ham) (spam-process ((spam spam-use-spamassassin) (ham spam-use-spamassassin)))) ("\\(mail\\.\\|INBOX\\)" (gnus-use-scoring nil)) ("mail\\.archive" (gnus-summary-line-format "%«%U%R %uS %ur %»%(%*%-14,14f %4u&size; %1«%B%s%»%)
-")) ("list\\.ledger\\.devel" (to-address . "ledger-cli@googlegroups.com") (to-list . "ledger-cli@googlegroups.com") (gcc-self . t) (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "ledger-cli@googlegroups.com") (header :contains "list-id" "<ledger-cli.googlegroups.com>")))) ("list\\.bahai\\.tarjuman" (to-address . "TARJUMAN-LIST@listserv.buffalo.edu") (to-list . "TARJUMAN-LIST@listserv.buffalo.edu") (sieve header :contains ("To" "From" "Cc" "Sender") "TARJUMAN-LIST@LISTSERV.BUFFALO.EDU")) ("list\\.emacs\\.devel" (to-address . "emacs-devel@gnu.org") (to-list . "emacs-devel@gnu.org") (total-expire . t) (expiry-wait . 90) (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-devel@gnu.org") (header :contains "list-id" "<emacs-devel.gnu.org>")))) ("list\\.emacs\\.help" (to-address . "help-gnu-emacs@gnu.org") (to-list . "help-gnu-emacs@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "help-gnu-emacs@gnu.org") (header :contains "list-id" "<help-gnu-emacs.gnu.org>")))) ("list\\.emacs\\.bugs" (to-list . "bug-gnu-emacs@gnu.org") (sieve anyof ((header :matches ("To" "From" "Cc" "Sender") "*@debbugs.gnu.org") (header :contains ("To" "From" "Cc" "Sender") "bug-gnu-emacs@gnu.org") (header :contains "list-id" "<bug-gnu-emacs.gnu.org>")))) ("list\\.emacs\\.diffs" (to-address . "emacs-diffs@gnu.org") (to-list . "emacs-diffs@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-diffs@gnu.org") (header :contains "list-id" "<emacs-diffs.gnu.org>")))) ("list\\.emacs\\.elpa\\.diffs" (to-address . "emacs-elpa-diffs@gnu.org") (to-list . "emacs-diffs@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-elpa-diffs@gnu.org") (header :contains "list-id" "<emacs-elpa-diffs.gnu.org>")))) ("list\\.emacs\\.buildstatus" (to-address . "emacs-buildstatus@gnu.org") (to-list . "emacs-buildstatus@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-buildstatus@gnu.org") (header :contains "list-id" "<emacs-buildstatus.gnu.org>")))) ("list\\.emacs\\.sources" (to-address . "gnu-emacs-sources@gnu.org") (to-list . "gnu-emacs-sources@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "gnu-emacs-sources@gnu.org") (header :contains "list-id" "<gnu-emacs-sources.gnu.org>")))) ("list\\.emacs\\.orgmode" (to-address . "emacs-orgmode@gnu.org") (to-list . "emacs-orgmode@gnu.org") (list-identifier . "\\[O\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-orgmode@gnu.org") (header :contains "list-id" "<emacs-orgmode.gnu.org>")))) ("list\\.emacs\\.diffs" (list-identifier . "\\[Emacs-diffs\\] /srv/bzr/emacs/")) ("list\\.boost\\.cppnow" (to-address . "boostcon-plan@googlegroups.com") (to-list . "boostcon-plan@googlegroups.com") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "boostcon-plan@googlegroups.com") (header :contains "list-id" "<boostcon-plan.googlegroups.com>")))) ("list\\.boost\\.ryppl" (to-address . "ryppl-dev@googlegroups.com") (to-list . "ryppl-dev@googlegroups.com") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "ryppl-dev@googlegroups.com") (header :contains "list-id" "<ryppl-dev.googlegroups.com>")))) ("list\\.boost\\.devel" (to-address . "boost@lists.boost.org") (to-list . "boost@lists.boost.org") (list-identifier . "\\[boost\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "boost@lists.boost.org") (header :contains "list-id" "<boost.lists.boost.org>")))) ("list\\.boost\\.\\(users\\|announce\\)" (to-address . "boost-\\1@lists.boost.org") (to-list . "boost-\\1@lists.boost.org") (list-identifier . "\\\\[Boost-\\1\\\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "boost-\\1@lists.boost.org") (header :contains "list-id" "<boost-\\1.lists.boost.org>")))) ("list\\.isocpp\\.\\(proposals\\|discussion\\)" (to-address . "std-\\1@isocpp.org") (to-list . "std-\\1@isocpp.org") (list-identifier . "\\\\[\\\\(lang\\\\|lib\\\\|std\\\\)-\\1\\\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "std-\\1@isocpp.org") (header :contains "list-id" "<std-\\1.isocpp.org>")))) ("list\\.clang\\.devel" (to-address . "cfe-dev@cs.uiuc.edu") (to-list . "cfe-dev@cs.uiuc.edu") (list-identifier . "\\[\\(cfe-dev\\|LLVMdev\\)\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "cfe-dev@cs.uiuc.edu") (header :contains "list-id" "<cfe-dev.cs.uiuc.edu>")))) ("list\\.llvm\\.devel" (to-address . "llvmdev@cs.uiuc.edu") (to-list . "llvmdev@cs.uiuc.edu") (list-identifier . "\\[\\(cfe-dev\\|LLVMdev\\)]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "llvmdev@cs.uiuc.edu") (header :contains "list-id" "<llvmdev.cs.uiuc.edu>")))) ("list\\.nix\\.devel" (to-address . "nix-dev@lists.science.uu.nl") (to-list . "nix-dev@lists.science.uu.nl") (list-identifier . "\\[Nix-dev\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "nix-dev@lists.science.uu.nl") (header :contains "list-id" "<nix-dev.lists.science.uu.nl>")))) ("list\\.haskell\\.cafe" (to-address . "haskell-cafe@haskell.org") (to-list . "haskell-cafe@haskell.org") (list-identifier . "\\[Haskell-cafe\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "haskell-cafe@haskell.org") (header :contains "list-id" "<haskell-cafe.haskell.org>")))) ("list\\.haskell\\.beginners" (to-address . "beginners@haskell.org") (to-list . "beginners@haskell.org") (list-identifier . "\\[Haskell-beginners\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "beginners@haskell.org") (header :contains "list-id" "<beginners.haskell.org>")))) ("list\\.haskell\\.infrastructure" (to-address . "haskell-infrastructure@community.galois.com") (to-list . "haskell-infrastructure@community.galois.com") (list-identifier . "\\[Haskell-infrastructure\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "haskell-infrastructure@community.galois.com") (header :contains "list-id" "<haskell-infrastructure.community.galois.com>")))) ("list\\.haskell\\.announce" (to-address . "haskell@haskell.org") (to-list . "haskell@haskell.org") (list-identifier . "\\[Haskell\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "haskell@haskell.org") (header :contains "list-id" "<haskell.haskell.org>")))) ("list\\.haskell\\.cabal" (to-address . "cabal-devel@haskell.org") (to-list . "cabal-devel@haskell.org") (list-identifier . "\\[Haskell\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "cabal-devel@haskell.org") (header :contains "list-id" "<cabal-devel.haskell.org>")))))))
+")) ("list\\.ledger\\.devel" (to-address . "ledger-cli@googlegroups.com") (to-list . "ledger-cli@googlegroups.com") (gcc-self . t) (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "ledger-cli@googlegroups.com") (header :contains "list-id" "<ledger-cli.googlegroups.com>")))) ("list\\.bahai\\.tarjuman" (to-address . "TARJUMAN-LIST@listserv.buffalo.edu") (to-list . "TARJUMAN-LIST@listserv.buffalo.edu") (sieve header :contains ("To" "From" "Cc" "Sender") "TARJUMAN-LIST@LISTSERV.BUFFALO.EDU")) ("list\\.emacs\\.devel" (to-address . "emacs-devel@gnu.org") (to-list . "emacs-devel@gnu.org") (total-expire . t) (expiry-wait . 90) (expiry-target . "archive.emacs.devel") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-devel@gnu.org") (header :contains "list-id" "<emacs-devel.gnu.org>")))) ("list\\.emacs\\.help" (to-address . "help-gnu-emacs@gnu.org") (to-list . "help-gnu-emacs@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "help-gnu-emacs@gnu.org") (header :contains "list-id" "<help-gnu-emacs.gnu.org>")))) ("list\\.emacs\\.bugs" (to-list . "bug-gnu-emacs@gnu.org") (sieve anyof ((header :matches ("To" "From" "Cc" "Sender") "*@debbugs.gnu.org") (header :contains ("To" "From" "Cc" "Sender") "bug-gnu-emacs@gnu.org") (header :contains "list-id" "<bug-gnu-emacs.gnu.org>")))) ("list\\.emacs\\.diffs" (to-address . "emacs-diffs@gnu.org") (to-list . "emacs-diffs@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-diffs@gnu.org") (header :contains "list-id" "<emacs-diffs.gnu.org>")))) ("list\\.emacs\\.elpa\\.diffs" (to-address . "emacs-elpa-diffs@gnu.org") (to-list . "emacs-diffs@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-elpa-diffs@gnu.org") (header :contains "list-id" "<emacs-elpa-diffs.gnu.org>")))) ("list\\.emacs\\.buildstatus" (to-address . "emacs-buildstatus@gnu.org") (to-list . "emacs-buildstatus@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-buildstatus@gnu.org") (header :contains "list-id" "<emacs-buildstatus.gnu.org>")))) ("list\\.emacs\\.sources" (to-address . "gnu-emacs-sources@gnu.org") (to-list . "gnu-emacs-sources@gnu.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "gnu-emacs-sources@gnu.org") (header :contains "list-id" "<gnu-emacs-sources.gnu.org>")))) ("list\\.emacs\\.orgmode" (to-address . "emacs-orgmode@gnu.org") (to-list . "emacs-orgmode@gnu.org") (list-identifier . "\\[O\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "emacs-orgmode@gnu.org") (header :contains "list-id" "<emacs-orgmode.gnu.org>")))) ("list\\.emacs\\.diffs" (list-identifier . "\\[Emacs-diffs\\] /srv/bzr/emacs/")) ("list\\.boost\\.cppnow" (to-address . "boostcon-plan@googlegroups.com") (to-list . "boostcon-plan@googlegroups.com") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "boostcon-plan@googlegroups.com") (header :contains "list-id" "<boostcon-plan.googlegroups.com>")))) ("list\\.boost\\.ryppl" (to-address . "ryppl-dev@googlegroups.com") (to-list . "ryppl-dev@googlegroups.com") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "ryppl-dev@googlegroups.com") (header :contains "list-id" "<ryppl-dev.googlegroups.com>")))) ("list\\.boost\\.devel" (to-address . "boost@lists.boost.org") (to-list . "boost@lists.boost.org") (list-identifier . "\\[boost\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "boost@lists.boost.org") (header :contains "list-id" "<boost.lists.boost.org>")))) ("list\\.boost\\.\\(users\\|announce\\)" (to-address . "boost-\\1@lists.boost.org") (to-list . "boost-\\1@lists.boost.org") (list-identifier . "\\\\[Boost-\\1\\\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "boost-\\1@lists.boost.org") (header :contains "list-id" "<boost-\\1.lists.boost.org>")))) ("list\\.isocpp\\.\\(proposals\\|discussion\\)" (to-address . "std-\\1@isocpp.org") (to-list . "std-\\1@isocpp.org") (list-identifier . "\\\\[\\\\(lang\\\\|lib\\\\|std\\\\)-\\1\\\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "std-\\1@isocpp.org") (header :contains "list-id" "<std-\\1.isocpp.org>")))) ("list\\.clang\\.devel" (to-address . "cfe-dev@cs.uiuc.edu") (to-list . "cfe-dev@cs.uiuc.edu") (list-identifier . "\\[\\(cfe-dev\\|LLVMdev\\)\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "cfe-dev@cs.uiuc.edu") (header :contains "list-id" "<cfe-dev.cs.uiuc.edu>")))) ("list\\.llvm\\.devel" (to-address . "llvmdev@cs.uiuc.edu") (to-list . "llvmdev@cs.uiuc.edu") (list-identifier . "\\[\\(cfe-dev\\|LLVMdev\\)]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "llvmdev@cs.uiuc.edu") (header :contains "list-id" "<llvmdev.cs.uiuc.edu>")))) ("list\\.nix\\.devel" (to-address . "nix-dev@lists.science.uu.nl") (to-list . "nix-dev@lists.science.uu.nl") (list-identifier . "\\[Nix-dev\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "nix-dev@lists.science.uu.nl") (header :contains "list-id" "<nix-dev.lists.science.uu.nl>")))) ("list\\.haskell\\.cafe" (to-address . "haskell-cafe@haskell.org") (to-list . "haskell-cafe@haskell.org") (total-expire . t) (expiry-wait . 90) (expiry-target . "archive.haskell.cafe") (list-identifier . "\\[Haskell-cafe\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "haskell-cafe@haskell.org") (header :contains "list-id" "<haskell-cafe.haskell.org>")))) ("list\\.haskell\\.libraries" (to-address . "libraries@haskell.org") (to-list . "libraries@haskell.org") (total-expire . t) (expiry-wait . 90) (expiry-target . "archive.haskell.libraries") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "libraries@haskell.org") (header :contains "list-id" "<libraries.haskell.org>")))) ("list\\.haskell\\.prime" (to-address . "haskell-prime@haskell.org") (to-list . "haskell-prime@haskell.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "haskell-prime@haskell.org") (header :contains "list-id" "<haskell-prime.haskell.org>")))) ("list\\.haskell\\.template-haskell" (to-address . "template-haskell@haskell.org") (to-list . "template-haskell@haskell.org") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "template-haskell@haskell.org") (header :contains "list-id" "<template-haskell.haskell.org>")))) ("list\\.haskell\\.beginners" (to-address . "beginners@haskell.org") (to-list . "beginners@haskell.org") (list-identifier . "\\[Haskell-beginners\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "beginners@haskell.org") (header :contains "list-id" "<beginners.haskell.org>")))) ("list\\.haskell\\.infrastructure" (to-address . "haskell-infrastructure@community.galois.com") (to-list . "haskell-infrastructure@community.galois.com") (list-identifier . "\\[Haskell-infrastructure\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "haskell-infrastructure@community.galois.com") (header :contains "list-id" "<haskell-infrastructure.community.galois.com>")))) ("list\\.haskell\\.announce" (to-address . "haskell@haskell.org") (to-list . "haskell@haskell.org") (list-identifier . "\\[Haskell\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "haskell@haskell.org") (header :contains "list-id" "<haskell.haskell.org>")))) ("list\\.haskell\\.cabal" (to-address . "cabal-devel@haskell.org") (to-list . "cabal-devel@haskell.org") (list-identifier . "\\[Haskell\\]") (sieve anyof ((header :contains ("To" "From" "Cc" "Sender") "cabal-devel@haskell.org") (header :contains "list-id" "<cabal-devel.haskell.org>")))))))
'(gnus-permanently-visible-groups "INBOX")
'(gnus-read-active-file nil)
'(gnus-read-newsrc-file nil)
@@ -106,7 +108,7 @@ John Wiegley, Chairperson"))))
'(mail-sources (quote ((file :path "/var/mail/johnw"))))
'(mail-specify-envelope-from t)
'(mail-user-agent (quote gnus-user-agent))
- '(message-alternative-emails "\\(johnw?\\|jwiegley\\)@\\(gmail\\|newartisans\\|boostpro\\).com")
+ '(message-alternative-emails "\\(johnw?\\|jwiegley\\)@\\(gmail\\|newartisans\\|fpcomplete\\|boostpro\\).com")
'(message-directory "~/Messages/Gnus/Mail/")
'(message-fill-column 78)
'(message-interactive t)
62 init.el
View
@@ -1067,6 +1067,13 @@
(use-package ace-jump-mode
:bind ("C-. C-s" . ace-jump-mode))
+
+;;;_ , agda
+
+(use-package agda2-mode
+ :mode ("\\.agda\\'" . agda2-mode)
+ :init
+ (use-package agda-input))
;;;_ , allout
@@ -1093,10 +1100,6 @@
(unbind-key "C-k" allout-mode-map)))
(add-hook 'allout-mode-hook 'my-allout-mode-hook)))
-
-;;;_ , apl-ascii
-
-(use-package apl)
;;;_ , archive-region
@@ -1161,13 +1164,18 @@
"site-lisp/ac/ac-source-semantic"
"site-lisp/ac/ac-yasnippet"
"site-lisp/ac/fuzzy-el"
- "site-lisp/ac/popup-el")
"site-lisp/ac/popup-el")
+ :diminish auto-complete-mode
+ :init
+ (progn
+ (use-package pos-tip)
+ (ac-config-default))
:config
(progn
(ac-set-trigger-key "TAB")
(setq ac-use-menu-map t)
+
(bind-key "A-M-?" 'ac-last-help)
(unbind-key "C-s" ac-completing-map)))
@@ -1409,6 +1417,15 @@
(use-package copy-code
:bind ("A-M-W" . copy-code-as-rtf))
+
+;;;_ , coq
+
+(if nil
+ (use-package coq-mode
+ :mode ("\\.v\\'" . coq-mode))
+ (use-package proof-site
+ :command proofgeneral
+ :load-path "site-lisp/proofgeneral/generic/"))
;;;_ , crosshairs
@@ -1419,6 +1436,14 @@
(use-package css-mode
:mode ("\\.css\\'" . css-mode))
+
+;;;_ , cursor-chg
+
+(use-package cursor-chg
+ :init
+ (progn
+ (change-cursor-mode 1)
+ (toggle-cursor-type-when-idle 1)))
;;;_ , ibuffer
@@ -1718,8 +1743,26 @@ The output appears in the buffer `*Async Shell Command*'."
;; :commands erc
:if running-alternate-emacs
:init
+ (progn
+ (defun setup-irc-environment ()
+ (interactive)
+ (set-input-method "Agda")
+ (set-frame-font
+ "-*-Lucida Grande-normal-normal-normal-*-*-*-*-*-p-0-iso10646-1" nil
+ nil)
+ (set-frame-parameter (selected-frame) 'width 90)
+ (setq erc-timestamp-only-if-changed-flag nil
+ erc-timestamp-format "%H:%M "
+ erc-fill-prefix " "
+ erc-fill-column 88
+ erc-insert-timestamp-function 'erc-insert-timestamp-left)
+ (custom-set-faces
+ '(erc-timestamp-face ((t (:foreground "dark violet"))))))
+
+ (add-hook 'erc-mode-hook 'setup-irc-environment)
(defun irc ()
+ (interactive)
(erc-tls :server "irc.freenode.net"
:port 6697
@@ -1730,10 +1773,11 @@ The output appears in the buffer `*Async Shell Command*'."
:user "johnw"
:type 'netrc
:port 6667))
- :secret)))
- ;(erc-tls :server "irc.oftc.net"
- ; :port 6697
- ; :nick "johnw")
+ :secret)))
+
+ (erc :server "irc.well-typed.com"
+ :port 6665
+ :nick "johnw")
)
(defun im ()
2  lisp/haskell-config
@@ -1 +1 @@
-Subproject commit 628860180c61a7ac44dddfa9137f670891b4d873
+Subproject commit 3f57bdbb522d6a1d5c9732e7f89dfa3656d09d6b
16 settings.el
View
@@ -10,7 +10,7 @@
'(TeX-view-program-list (quote (("Skim" ("osascript" " ~/bin/skim-gotopage.script" " %O" (mode-io-correlate " %(outpage)"))))))
'(TeX-view-program-selection (quote (((output-dvi style-pstricks) "dvips and gv") (output-dvi "xdvi") (output-pdf "Skim") (output-html "xdg-open"))))
'(abbrev-file-name "~/.emacs.d/abbrevs")
- '(ac-auto-show-menu nil)
+ '(ac-auto-show-menu 1.0)
'(ac-auto-start 3)
'(ac-comphist-file "/Users/johnw/.emacs.d/data/ac-comphist.dat")
'(ac-dwim nil)
@@ -101,11 +101,11 @@
'(enable-recursive-minibuffers t)
'(erc-auto-query (quote window-noselect))
'(erc-autoaway-message "I'm away (after %i seconds of idle-time)")
- '(erc-autojoin-channels-alist (quote (("localhost" "&bitlbee") ("freenode.net" "#emacs" "#haskell" "#haskell-in-depth" "#haskell-overflow" "#haskell-blah" "#ledger" "##categorytheory") ("oftc.net" "#llvm"))))
+ '(erc-autojoin-channels-alist (quote (("localhost" "&bitlbee") ("freenode.net" "#emacs-ops" "#haskell" "#haskell-in-depth" "#haskell-overflow" "#haskell-blah" "#haskell-ops" "#haskell-lens" "#scannedinavian" "#ledger" "##categorytheory" "#agda") ("well-typed.com" "#fpcomplete") ("oftc.net" "#llvm"))))
'(erc-autojoin-mode t)
'(erc-fill-function (quote erc-fill-variable))
'(erc-fill-static-center 12)
- '(erc-fools (quote ("JordiGH")))
+ '(erc-fools (quote ("JordiGH" "nyc")))
'(erc-generate-log-file-name-function (quote erc-generate-log-file-name-short))
'(erc-header-line-format nil)
'(erc-hide-list (quote ("JOIN" "NICK" "PART" "QUIT" "MODE")))
@@ -113,7 +113,7 @@
'(erc-keywords (quote ("wiegley" "ledger" "eshell")))
'(erc-log-channels-directory "~/Messages/ERC")
'(erc-log-write-after-send t)
- '(erc-modules (quote (autojoin button completion dcc fill identd irccontrols list log match menu move-to-prompt netsplit networks noncommands readonly replace ring scrolltobottom services smiley stamp spelling track highlight-nicknames)))
+ '(erc-modules (quote (autojoin button completion dcc fill identd irccontrols list log match menu move-to-prompt netsplit networks noncommands readonly replace ring scrolltobottom services smiley stamp spelling track truncate highlight-nicknames)))
'(erc-nick "johnw")
'(erc-port 6667)
'(erc-priority-people-regexp "\\`[^#].+")
@@ -153,12 +153,13 @@
'(gc-cons-threshold 3500000)
'(gdb-find-source-frame t)
'(gdb-same-frame nil)
+ '(global-auto-complete-mode t)
'(global-font-lock-mode t nil (font-lock))
'(haskell-check-command "hlintall")
'(haskell-config-use-unicode-symbols t)
'(haskell-doc-use-inf-haskell t)
'(haskell-hoogle-command nil)
- '(haskell-mode-hook (quote (turn-on-haskell-indentation turn-on-font-lock turn-on-eldoc-mode turn-on-haskell-doc-mode turn-on-haskell-decl-scan ghc-init my-haskell-mode-hook)))
+ '(haskell-mode-hook (quote (turn-on-haskell-indentation turn-on-font-lock turn-on-haskell-decl-scan ghc-init my-haskell-mode-hook)))
'(haskell-program-name "ghci")
'(haskell-saved-check-command "~/.cabal/bin/hlint" t)
'(hippie-expand-try-functions-list (quote (yas/hippie-try-expand try-complete-file-name-partially try-complete-file-name try-expand-all-abbrevs try-expand-list try-expand-line try-expand-dabbrev try-expand-dabbrev-all-buffers try-expand-dabbrev-from-kill try-complete-lisp-symbol-partially try-complete-lisp-symbol)))
@@ -268,7 +269,7 @@
'(slime-kill-without-query-p t)
'(slime-repl-history-file "~/.emacs.d/data/slime-history.eld")
'(slime-startup-animation nil)
- '(smart-compile-alist (quote (((lambda (buf) (let ((case-fold-search t)) (and (string-match "/ansi/" (buffer-file-name buf)) (string-match "/opencl" (shell-command-to-string "git symbolic-ref HEAD"))))) . "cd ~/Contracts/TI/src/c60_iaansi ; ~/Contracts/TI/bin/build.sh c60") ((lambda (buf) (let ((case-fold-search t)) (and (string-match "/\\(src/ansi\\|src/.*?ansi\\)/" (buffer-file-name buf)) (string-match "/merge_4_2" (shell-command-to-string "git symbolic-ref HEAD"))))) . "cd ~/Contracts/TI/src/msp_iaansi ; ~/Contracts/TI/bin/build.sh msp") ((lambda (buf) (string-match "/\\(\\(src\\|Projects\\)/ledger\\)/" (buffer-file-name buf))) . "cd ~/src/ledger ; ~/src/ledger/tools/build.sh debug") ((lambda (buf) (string-match "/emacs/" (buffer-file-name buf))) . "emacs-build release macport opt make") (emacs-lisp-mode emacs-lisp-byte-compile-and-load) ((lambda (buf) (string-match "/\\(cree\\|EDG/Projects/edg\\)/" (buffer-file-name buf))) . "cd ~/Products/cree/edg && (ninja -j$(ncpu) && ctest -j$(ncpu)) & (cd ~/src/cree; mktags src ext/llvm) & wait"))))
+ '(smart-compile-alist (quote (((lambda (buf) (let ((case-fold-search t)) (and (string-match "/ansi/" (buffer-file-name buf)) (string-match "/opencl" (shell-command-to-string "git symbolic-ref HEAD"))))) . "cd ~/Contracts/TI/src/c60_iaansi ; ~/Contracts/TI/bin/build.sh c60") ((lambda (buf) (let ((case-fold-search t)) (and (string-match "/\\(src/ansi\\|src/.*?ansi\\)/" (buffer-file-name buf)) (string-match "/merge_4_2" (shell-command-to-string "git symbolic-ref HEAD"))))) . "cd ~/Contracts/TI/src/msp_iaansi ; ~/Contracts/TI/bin/build.sh msp") ((lambda (buf) (string-match "/\\(\\(src\\|Projects\\)/ledger\\)/" (buffer-file-name buf))) . "cd ~/src/ledger ; ~/src/ledger/tools/build.sh debug") ((lambda (buf) (string-match "/emacs/" (buffer-file-name buf))) . "emacs-build release macport opt make") (emacs-lisp-mode emacs-lisp-byte-compile-and-load) ((lambda (buf) (string-match "/\\(cree\\|EDG/Projects/edg\\)/" (buffer-file-name buf))) . "cd ~/Products/cree/edg && (ninja && ctest -j$(ncpu)) & (cd ~/src/cree; mktags src ext/llvm) & wait"))))
'(sql-sqlite-program "sqlite3")
'(sr-attributes-display-mask (quote (nil nil t nil nil nil)))
'(sr-autoload-extensions nil)
@@ -347,13 +348,14 @@
'(diff-added2 ((t (:foreground "SeaGreen"))))
'(diff-changed ((t (:foreground "MediumBlue"))))
'(diff-context ((t (:foreground "Black"))))
- '(diff-file-header ((t (:background "grey90" :foreground "Red"))))
+ '(diff-file-header ((t (:background "plum" :foreground "Black"))))
'(diff-header ((t (:background "grey85" :foreground "red"))))
'(diff-hunk-header ((t (:background "grey90" :foreground "black"))))
'(diff-index ((t (:foreground "Green"))))
'(diff-nonexistent ((t (:foreground "DarkBlue"))))
'(diff-removed ((t (:foreground "firebrick"))))
'(diff-removed2 ((t (:foreground "Orange"))))
+ '(erc-timestamp-face ((t (:foreground "olive drab"))))
'(font-lock-comment-face ((((class color)) (:foreground "firebrick"))))
'(helm-M-x-key ((t (:foreground "dark red" :underline t))))
'(helm-candidate-number ((t (:background "#faffb5" :foreground "black"))))
460 site-lisp/gtags.el
View
@@ -1,8 +1,9 @@
;;; gtags.el --- gtags facility for Emacs
+;(setq debug-on-error t)
;;
;; Copyright (c) 1997, 1998, 1999, 2000, 2006, 2007, 2008, 2009, 2010
-;; 2011
+;; 2011, 2012
;; Tama Communications Corporation
;;
;; This file is part of GNU GLOBAL.
@@ -23,9 +24,8 @@
;; GLOBAL home page is at: http://www.gnu.org/software/global/
;; Author: Tama Communications Corporation
-;; Version: 3.0
+;; Version: 3.6
;; Keywords: tools
-;; Required version: GLOBAL 5.9.7 or later
;; Gtags-mode is implemented as a minor mode so that it can work with any
;; other major modes. Gtags-select mode is implemented as a major mode.
@@ -47,12 +47,12 @@
;; There are two hooks, gtags-mode-hook and gtags-select-mode-hook.
;; The usage of the hook is shown as follows.
;;
-;; [Setting to reproduce old 'Gtags mode']
+;; [Setting to use vi style scroll key]
;;
;; (add-hook 'gtags-mode-hook
;; '(lambda ()
-;; (setq gtags-pop-delete t)
-;; (setq gtags-path-style 'absolute)
+;; (define-key gtags-mode-map "\C-f" 'scroll-up)
+;; (define-key gtags-mode-map "\C-b" 'scroll-down)
;; ))
;;
;; [Setting to make 'Gtags select mode' easy to see]
@@ -62,6 +62,11 @@
;; (setq hl-line-face 'underline)
;; (hl-line-mode 1)
;; ))
+;;
+;; (Policy of key mapping)
+;; If 'gtags-suggested-key-mapping' is not set, any key mapping is not done.
+;; If 'gtags-disable-pushy-mouse-mapping' is set, any mouse mapping is not done.
+;;
;;; Code
@@ -84,6 +89,13 @@
(const :tag "Absolute" absolute))
:group 'gtags)
+(defcustom gtags-ignore-case 'follow-case-fold-search
+ "*Controls whether or not ignore case in each search."
+ :type '(choice (const :tag "Follows case-fold-search variable" follow-case-fold-search)
+ (const :tag "Ignore case" t)
+ (const :tag "Distinguish case" nil))
+ :group 'gtags)
+
(defcustom gtags-read-only nil
"Gtags read only mode"
:type 'boolean
@@ -99,7 +111,6 @@
:group 'gtags
:type 'boolean)
-; This has not been used any longer.
(defcustom gtags-disable-pushy-mouse-mapping nil
"*If non-nil, mouse key mapping is disabled."
:group 'gtags
@@ -110,6 +121,26 @@
:group 'gtags
:type 'boolean)
+(defcustom gtags-use-old-key-map nil
+ "*If non-nil, old key mapping is enabled."
+ :group 'gtags
+ :type 'boolean)
+
+(defcustom gtags-grep-all-text-files nil
+ "*If non-nil, gtags-find-with-grep command searchs all text files."
+ :group 'gtags
+ :type 'boolean)
+
+(defcustom gtags-prefix-key "\C-c"
+ "*If non-nil, it is used for the prefix key of gtags-xxx command."
+ :group 'gtags
+ :type 'string)
+
+(defcustom gtags-auto-update nil
+ "*If non-nil, tag files are updated whenever a file is saved."
+ :type 'boolean
+ :group 'gtags)
+
;; Variables
(defvar gtags-current-buffer nil
"Current buffer.")
@@ -125,80 +156,206 @@
"Regexp matching tag definition name.")
(defvar gtags-mode-map (make-sparse-keymap)
"Keymap used in gtags mode.")
+(defvar gtags-select-mode-map (make-sparse-keymap)
+ "Keymap used in gtags select mode.")
(defvar gtags-running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
"Whether we are running XEmacs/Lucid Emacs")
(defvar gtags-rootdir nil
"Root directory of source tree.")
-;
-; New key assignment to avoid conflicting with ordinary assignments.
-;
-(define-key gtags-mode-map "\e*" 'gtags-pop-stack)
-(define-key gtags-mode-map "\e." 'gtags-find-tag)
-(define-key gtags-mode-map "\C-x4." 'gtags-find-tag-other-window)
-;
-; You can make key mappings using 'gtags-mode-hook in your $HOME/.emacs:
-; The following two brings the same result.
-;
-; (add-hook 'gtags-mode-hook
-; '(lambda ()
-; (setq gtags-suggested-key-mapping t)
-; ))
-; (add-hook 'gtags-mode-hook
-; '(lambda ()
-; (define-key gtags-mode-map "\eh" 'gtags-display-browser)
-; (define-key gtags-mode-map "\C-]" 'gtags-find-tag-from-here)
-; (define-key gtags-mode-map "\C-t" 'gtags-pop-stack)
-; (define-key gtags-mode-map "\eP" 'gtags-find-file)
-; (define-key gtags-mode-map "\ef" 'gtags-parse-file)
-; (define-key gtags-mode-map "\eg" 'gtags-find-with-grep)
-; (define-key gtags-mode-map "\eI" 'gtags-find-with-idutils)
-; (define-key gtags-mode-map "\es" 'gtags-find-symbol)
-; (define-key gtags-mode-map "\er" 'gtags-find-rtag)
-; (define-key gtags-mode-map "\et" 'gtags-find-tag)
-; (define-key gtags-mode-map "\ev" 'gtags-visit-rootdir)
-; ))
+(defvar gtags-global-command nil
+ "Command name of global.")
+
+;; Set global's command name
+(setq gtags-global-command (getenv "GTAGSGLOBAL"))
+(if (or (not gtags-global-command) (equal gtags-global-command ""))
+ (setq gtags-global-command "global"))
+
+;; Key mapping of gtags-mode.
+(if gtags-suggested-key-mapping
+ (progn
+ ; Current key mapping.
+ (define-key gtags-mode-map (concat gtags-prefix-key "h") 'gtags-display-browser)
+ (define-key gtags-mode-map "\C-]" 'gtags-find-tag-from-here)
+ (define-key gtags-mode-map "\C-t" 'gtags-pop-stack)
+ (define-key gtags-mode-map (concat gtags-prefix-key "P") 'gtags-find-file)
+ (define-key gtags-mode-map (concat gtags-prefix-key "f") 'gtags-parse-file)
+ (define-key gtags-mode-map (concat gtags-prefix-key "g") 'gtags-find-with-grep)
+ (define-key gtags-mode-map (concat gtags-prefix-key "I") 'gtags-find-with-idutils)
+ (define-key gtags-mode-map (concat gtags-prefix-key "s") 'gtags-find-symbol)
+ (define-key gtags-mode-map (concat gtags-prefix-key "r") 'gtags-find-rtag)
+ (define-key gtags-mode-map (concat gtags-prefix-key "t") 'gtags-find-tag)
+ (define-key gtags-mode-map (concat gtags-prefix-key "d") 'gtags-find-tag)
+ (define-key gtags-mode-map (concat gtags-prefix-key "v") 'gtags-visit-rootdir)
+ ; common
+ (define-key gtags-mode-map "\e*" 'gtags-pop-stack)
+ (define-key gtags-mode-map "\e." 'gtags-find-tag)
+ (define-key gtags-mode-map "\C-x4." 'gtags-find-tag-other-window)
+ (if gtags-disable-pushy-mouse-mapping nil
+ (define-key gtags-mode-map [mouse-3] 'gtags-pop-stack)
+ (define-key gtags-mode-map [mouse-2] 'gtags-find-tag-by-event)))
+)
+;; Key mapping of old gtags-mode (obsoleted)
+(if (and gtags-suggested-key-mapping gtags-use-old-key-map)
+ (progn
+ ; Old key mapping
+ (define-key gtags-mode-map "\eh" 'gtags-display-browser)
+ (define-key gtags-mode-map "\C-]" 'gtags-find-tag-from-here)
+ (define-key gtags-mode-map "\C-t" 'gtags-pop-stack)
+ (define-key gtags-mode-map "\eP" 'gtags-find-file)
+ (define-key gtags-mode-map "\ef" 'gtags-parse-file)
+ (define-key gtags-mode-map "\eg" 'gtags-find-with-grep)
+ (define-key gtags-mode-map "\eI" 'gtags-find-with-idutils)
+ (define-key gtags-mode-map "\es" 'gtags-find-symbol)
+ (define-key gtags-mode-map "\er" 'gtags-find-rtag)
+ (define-key gtags-mode-map "\et" 'gtags-find-tag)
+ (define-key gtags-mode-map "\ev" 'gtags-visit-rootdir)
+ ; common
+ (define-key gtags-mode-map "\e*" 'gtags-pop-stack)
+ (define-key gtags-mode-map "\e." 'gtags-find-tag)
+ (define-key gtags-mode-map "\C-x4." 'gtags-find-tag-other-window)
+ (if gtags-disable-pushy-mouse-mapping nil
+ (define-key gtags-mode-map [mouse-3] 'gtags-pop-stack)
+ (define-key gtags-mode-map [mouse-2] 'gtags-find-tag-by-event)))
+)
-(defvar gtags-select-mode-map (make-sparse-keymap)
- "Keymap used in gtags select mode.")
-(define-key gtags-select-mode-map "\e*" 'gtags-pop-stack)
-(define-key gtags-select-mode-map "\^?" 'scroll-down)
-(define-key gtags-select-mode-map " " 'scroll-up)
-(define-key gtags-select-mode-map "\C-b" 'scroll-down)
-(define-key gtags-select-mode-map "\C-f" 'scroll-up)
-(define-key gtags-select-mode-map "k" 'previous-line)
-(define-key gtags-select-mode-map "j" 'next-line)
-(define-key gtags-select-mode-map "p" 'previous-line)
-(define-key gtags-select-mode-map "n" 'next-line)
-(define-key gtags-select-mode-map "q" 'gtags-pop-stack)
-(define-key gtags-select-mode-map "u" 'gtags-pop-stack)
+;; Key mapping of gtags-select-mode.
+; The map of key "\C-t" and "\C-m" is always carried out..
(define-key gtags-select-mode-map "\C-t" 'gtags-pop-stack)
(define-key gtags-select-mode-map "\C-m" 'gtags-select-tag)
-(define-key gtags-select-mode-map "\C-o" 'gtags-select-tag-other-window)
-(define-key gtags-select-mode-map "\e." 'gtags-select-tag)
+(if gtags-suggested-key-mapping
+ (progn
+ (define-key gtags-select-mode-map "\e*" 'gtags-pop-stack)
+ (define-key gtags-select-mode-map "\^?" 'scroll-down)
+ (define-key gtags-select-mode-map " " 'scroll-up)
+ (define-key gtags-select-mode-map "\C-b" 'scroll-down)
+ (define-key gtags-select-mode-map "\C-f" 'scroll-up)
+ (define-key gtags-select-mode-map "k" 'previous-line)
+ (define-key gtags-select-mode-map "j" 'next-line)
+ (define-key gtags-select-mode-map "p" 'previous-line)
+ (define-key gtags-select-mode-map "n" 'next-line)
+ (define-key gtags-select-mode-map "q" 'gtags-pop-stack)
+ (define-key gtags-select-mode-map "u" 'gtags-pop-stack)
+ (define-key gtags-select-mode-map "\C-o" 'gtags-select-tag-other-window)
+ (define-key gtags-select-mode-map "\e." 'gtags-select-tag)
+ (if gtags-disable-pushy-mouse-mapping nil
+ (define-key gtags-select-mode-map [mouse-3] 'gtags-pop-stack)
+ (define-key gtags-select-mode-map [mouse-2] 'gtags-select-tag-by-event)))
+)
+
+;;
+;; TRAMP support
+;;
+;
+; TRAMP style default-directory.
+; /<method>:[<user id>@]<host name>:<directory>
+; Ex: /ssh:remoteuser@remotehost:/usr/src/sys/
+;
+(defconst gtags-tramp-path-regexp "^/\\([^:]+\\):\\([^:]+\\):\\(.*\\)"
+ "Regexp matching tramp path name.")
+(defconst gtags-tramp-user-host-regexp "^\\([^@]+\\)@\\(.*\\)"
+ "Regexp matching tramp user@host name.")
+(defvar gtags-tramp-active nil
+ "TRAMP activity.")
+(defvar gtags-tramp-saved-global-command nil
+ "Save area of the command name of global.")
+
+; The substitute of buffer-file-name
+(defun gtags-buffer-file-name ()
+ (if buffer-file-name
+ (if (string-match gtags-tramp-path-regexp buffer-file-name)
+ (match-string 3 buffer-file-name)
+ buffer-file-name)
+ nil))
+(defun gtags-push-tramp-environment ()
+ (let ((tramp-path default-directory))
+ (if (string-match gtags-tramp-path-regexp tramp-path)
+ (let ((shell (match-string 1 tramp-path))
+ (user-and-host (match-string 2 tramp-path))
+ (cwd (match-string 3 tramp-path)))
+ ;
+ ; Server side GLOBAL cannot treat other than rsh and ssh.
+ ;
+ (cond
+ ((equal shell "rsh"))
+ ((equal shell "ssh"))
+ ((equal shell "rcp")
+ (setq shell "rsh"))
+ ((equal shell "scp")
+ (setq shell "ssh"))
+ (t
+ (setq shell "ssh")))
+ (let (host user)
+ (if (string-match gtags-tramp-user-host-regexp user-and-host)
+ (progn
+ (setq user (match-string 1 user-and-host))
+ (setq host (match-string 2 user-and-host)))
+ (progn
+ (setq user nil)
+ (setq host user-and-host)))
+ ;
+ ; Move to tramp mode only when all the items are assembled.
+ ;
+ (if (and shell host cwd)
+ (progn
+ (setq gtags-tramp-active t)
+ (setq gtags-tramp-saved-global-command gtags-global-command)
+ ; Use 'global-client even if environment variable GTAGSGLOBAL is set.
+ ;(setq gtags-global-command (getenv "GTAGSGLOBAL"))
+ ;(if (or (not gtags-global-command) (equal gtags-global-command ""))
+ (setq gtags-global-command "global-client")
+ ;)
+ (push (concat "GTAGSREMOTESHELL=" shell) process-environment)
+ (push (concat "GTAGSREMOTEHOST=" host) process-environment)
+ (push (concat "GTAGSREMOTEUSER=" user) process-environment)
+ (push (concat "GTAGSREMOTECWD=" cwd) process-environment))))))))
+
+(defun gtags-pop-tramp-environment ()
+ (if gtags-tramp-active
+ (progn
+ (setq gtags-tramp-active nil)
+ (setq gtags-global-command gtags-tramp-saved-global-command)
+ (pop process-environment)
+ (pop process-environment)
+ (pop process-environment)
+ (pop process-environment))))
+
+;; End of TRAMP support
;;
+;; Invoked on saving a file.
+;;
+(defun gtags-auto-update ()
+ (if (and gtags-mode gtags-auto-update buffer-file-name)
+ (progn
+ (gtags-push-tramp-environment)
+ (call-process gtags-global-command nil nil nil "-u" (concat "--single-update=" (gtags-buffer-file-name)))
+ (gtags-pop-tramp-environment))))
+;;
;; utility
;;
+;; Ignore case or not.
+(defun gtags-ignore-casep ()
+ (if (equal gtags-ignore-case 'follow-case-fold-search)
+ case-fold-search
+ gtags-ignore-case))
+
(defun gtags-match-string (n)
(buffer-substring (match-beginning n) (match-end n)))
;; Return a default tag to search for, based on the text at point.
(defun gtags-current-token ()
- (save-excursion
- (cond
- ((or (looking-at "[0-9A-Za-z_]")
- (looking-back "[0-9A-Za-z_]"))
- (forward-char -1)
- (while (and (not (bolp)) (looking-at "[0-9A-Za-z_]"))
- (forward-char -1))
- (if (not (looking-at "[0-9A-Za-z_]")) (forward-char 1)))
- (t
- (while (looking-at "[ \t]")
- (forward-char 1))))
- (if (and (bolp) (looking-at gtags-definition-regexp))
- (goto-char (match-end 0)))
- (if (looking-at gtags-symbol-regexp)
- (gtags-match-string 0) nil)))
+ (cond
+ ((looking-at "[0-9A-Za-z_]")
+ (while (and (not (bolp)) (looking-at "[0-9A-Za-z_]"))
+ (forward-char -1))
+ (if (not (looking-at "[0-9A-Za-z_]")) (forward-char 1)))
+ (t
+ (while (looking-at "[ \t]")
+ (forward-char 1))))
+ (if (and (bolp) (looking-at gtags-definition-regexp))
+ (goto-char (match-end 0)))
+ (if (looking-at gtags-symbol-regexp)
+ (gtags-match-string 0) nil))
;; push current context to stack
(defun gtags-push-context ()
@@ -232,6 +389,8 @@
;; completsion function for completing-read.
(defun gtags-completing-gtags (string predicate code)
(gtags-completing 'gtags string predicate code))
+(defun gtags-completing-grtags (string predicate code)
+ (gtags-completing 'grtags string predicate code))
(defun gtags-completing-gsyms (string predicate code)
(gtags-completing 'gsyms string predicate code))
(defun gtags-completing-files (string predicate code)
@@ -244,14 +403,19 @@
; The purpose of using the -n option for the -P command is to exclude
; dependence on the execution directory.
(let ((option (cond ((eq flag 'files) "-cPo")
+ ((eq flag 'grtags) "-cr")
((eq flag 'gsyms) "-cs")
((eq flag 'idutils) "-cI")
(t "-c")))
(complete-list (make-vector 63 0))
(prev-buffer (current-buffer)))
+ (if (gtags-ignore-casep)
+ (setq option (concat option "i")))
; build completion list
(set-buffer (generate-new-buffer "*Completions*"))
- (call-process "global" nil t nil option string)
+ (gtags-push-tramp-environment)
+ (call-process gtags-global-command nil t nil option string)
+ (gtags-pop-tramp-environment)
(goto-char (point-min))
;
; The specification of the completion for files is different from that for symbols.
@@ -279,7 +443,7 @@
(save-excursion
(setq buffer (generate-new-buffer (generate-new-buffer-name "*rootdir*")))
(set-buffer buffer)
- (setq n (call-process "global" nil t nil "-pr"))
+ (setq n (call-process gtags-global-command nil t nil "-pr"))
(if (= n 0)
(setq path (file-name-as-directory (buffer-substring (point-min)(1- (point-max))))))
(kill-buffer buffer))
@@ -303,11 +467,11 @@
"Tell tags commands the root directory of source tree."
(interactive)
(let (path input n)
- (if gtags-rootdir
- (setq path gtags-rootdir)
- (setq path (gtags-get-rootpath))
- (if (equal path nil)
- (setq path default-directory)))
+ (setq path gtags-rootdir)
+ (if (not path)
+ (setq path (gtags-get-rootpath)))
+ (if (not path)
+ (setq insert-default-directory (if (string-match gtags-tramp-path-regexp default-directory) nil t)))
(setq input (read-file-name "Visit root directory: " path path t))
(if (equal "" input) nil
(if (not (file-directory-p input))
@@ -343,7 +507,7 @@
(if tagname
(setq prompt (concat "Find tag (reference): (default " tagname ") "))
(setq prompt "Find tag (reference): "))
- (setq input (completing-read prompt 'gtags-completing-gtags
+ (setq input (completing-read prompt 'gtags-completing-grtags
nil nil nil gtags-history-list))
(if (not (equal "" input))
(setq tagname input))
@@ -380,7 +544,7 @@
(setq input (read-from-minibuffer prompt nil nil nil gtags-history-list))
(if (not (equal "" input)) (setq tagname input))
(gtags-push-context)
- (gtags-goto-tag tagname "g")))
+ (gtags-goto-tag tagname (if gtags-grep-all-text-files "go" "g"))))
(defun gtags-find-with-idutils ()
"Input pattern, search with idutils(1) and move to the locations."
@@ -412,7 +576,7 @@
(interactive)
(let (tagname prompt input)
(setq prompt "Parse file: ")
- (setq input (read-file-name prompt buffer-file-name buffer-file-name t))
+ (setq input (read-file-name prompt (gtags-buffer-file-name) (gtags-buffer-file-name) t))
(if (or (equal "" input) (not (file-regular-p input)))
(message "Please specify an existing source file.")
(setq tagname input)
@@ -425,7 +589,7 @@
(let (tagname flag)
(setq tagname (gtags-current-token))
(if (not tagname)
- (call-interactively 'gtags-find-tag)
+ nil
(gtags-push-context)
(gtags-goto-tag tagname "C"))))
@@ -434,7 +598,11 @@
(defun gtags-display-browser ()
"Display current screen on hypertext browser."
(interactive)
- (call-process "gozilla" nil nil nil (concat "+" (number-to-string (gtags-current-lineno))) buffer-file-name))
+ (if (= (gtags-current-lineno) 0)
+ (message "This is a null file.")
+ (if (not buffer-file-name)
+ (message "This buffer doesn't have the file name.")
+ (call-process "gozilla" nil nil nil (concat "+" (number-to-string (gtags-current-lineno))) (gtags-buffer-file-name)))))
; Private event-point
; (If there is no event-point then we use this version.
@@ -516,8 +684,10 @@
(setq flag-char (string-to-char flag))
; Use always ctags-x format.
(setq option "-x")
+ (if (gtags-ignore-casep)
+ (setq option (concat option "i")))
(if (char-equal flag-char ?C)
- (setq context (concat "--from-here=" (number-to-string (gtags-current-lineno)) ":" buffer-file-name))
+ (setq context (concat "--from-here=" (number-to-string (gtags-current-lineno)) ":" (gtags-buffer-file-name)))
(setq option (concat option flag)))
(cond
((char-equal flag-char ?C)
@@ -525,8 +695,7 @@
((char-equal flag-char ?P)
(setq prefix "(P)"))
((char-equal flag-char ?f)
- (setq prefix "(F)")
- (setq option (concat option "q")))
+ (setq prefix "(F)"))
((char-equal flag-char ?g)
(setq prefix "(GREP)"))
((char-equal flag-char ?I)
@@ -564,53 +733,58 @@
(setq now-buffer-list (cdr now-buffer-list))))))
(setq buffer (generate-new-buffer (generate-new-buffer-name (concat "*GTAGS SELECT* " prefix tagname))))
(set-buffer buffer)
- ;
- ; Path style is defined in gtags-path-style:
- ; root: relative from the root of the project (Default)
- ; relative: relative from the current directory
- ; absolute: absolute (relative from the system root directory)
- ;
- (cond
- ((equal gtags-path-style 'absolute)
- (setq option (concat option "a")))
- ((equal gtags-path-style 'root)
- (let (rootdir)
- (if gtags-rootdir
- (setq rootdir gtags-rootdir)
- (setq rootdir (gtags-get-rootpath)))
- (if rootdir (cd rootdir)))))
(message "Searching %s ..." tagname)
- (if (not (= 0 (if (equal flag "C")
- (call-process "global" nil t nil option "--encode-path=\" \t\"" context tagname)
- (call-process "global" nil t nil option "--encode-path=\" \t\"" tagname))))
- (progn (message (buffer-substring (point-min)(1- (point-max))))
- (gtags-pop-context))
- (goto-char (point-min))
- (setq lines (count-lines (point-min) (point-max)))
+ (let (status)
+ (gtags-push-tramp-environment)
+ ;
+ ; Path style is defined in gtags-path-style:
+ ; root: relative from the root of the project (Default)
+ ; relative: relative from the current directory
+ ; absolute: absolute (relative from the system root directory)
+ ; In TRAMP mode, 'root' is automatically converted to 'relative'.
+ ;
(cond
- ((= 0 lines)
- (cond
- ((char-equal flag-char ?P)
- (message "%s: path not found" tagname))
- ((char-equal flag-char ?g)
- (message "%s: pattern not found" tagname))
- ((char-equal flag-char ?I)
- (message "%s: token not found" tagname))
- ((char-equal flag-char ?s)
- (message "%s: symbol not found" tagname))
- (t
- (message "%s: tag not found" tagname)))
- (gtags-pop-context)
- (kill-buffer buffer)
- (set-buffer save))
- ((= 1 lines)
- (message "Searching %s ... Done" tagname)
- (gtags-select-it t other-win))
- (t
- (if (null other-win)
- (switch-to-buffer buffer)
- (switch-to-buffer-other-window buffer))
- (gtags-select-mode))))))
+ ((equal gtags-path-style 'absolute)
+ (setq option (concat option "a")))
+ ((and (not gtags-tramp-active) (equal gtags-path-style 'root))
+ (let (rootdir)
+ (if gtags-rootdir
+ (setq rootdir gtags-rootdir)
+ (setq rootdir (gtags-get-rootpath)))
+ (if rootdir (cd rootdir)))))
+ (setq status (if (equal flag "C")
+ (call-process gtags-global-command nil t nil option "--encode-path=\" \t\"" context tagname)
+ (call-process gtags-global-command nil t nil option "--encode-path=\" \t\"" tagname)))
+ (gtags-pop-tramp-environment)
+ (if (not (= 0 status))
+ (progn (message (buffer-substring (point-min)(1- (point-max))))
+ (gtags-pop-context))
+ (goto-char (point-min))
+ (setq lines (count-lines (point-min) (point-max)))
+ (cond
+ ((= 0 lines)
+ (cond
+ ((char-equal flag-char ?P)
+ (message "%s: path not found" tagname))
+ ((char-equal flag-char ?g)
+ (message "%s: pattern not found" tagname))
+ ((char-equal flag-char ?I)
+ (message "%s: token not found" tagname))
+ ((char-equal flag-char ?s)
+ (message "%s: symbol not found" tagname))
+ (t
+ (message "%s: tag not found" tagname)))
+ (gtags-pop-context)
+ (kill-buffer buffer)
+ (set-buffer save))
+ ((= 1 lines)
+ (message "Searching %s ... Done" tagname)
+ (gtags-select-it t other-win))
+ (t
+ (if (null other-win)
+ (switch-to-buffer buffer)
+ (switch-to-buffer-other-window buffer))
+ (gtags-select-mode)))))))
;; select a tag line from lines
(defun gtags-select-it (delete &optional other-win)
@@ -691,30 +865,10 @@ with no args, if that value is non-nil."
(setq gtags-mode
(if (null forces) (not gtags-mode)
(> (prefix-numeric-value forces) 0)))
+ (if gtags-mode
+ (add-hook 'after-save-hook 'gtags-auto-update)
+ (remove-hook 'after-save-hook 'gtags-auto-update))
(run-hooks 'gtags-mode-hook)
- ; Suggested key mapping
- (if gtags-suggested-key-mapping
- (progn
- ; Key mapping.
- (define-key gtags-mode-map "\eh" 'gtags-display-browser)
- (define-key gtags-mode-map "\C-]" 'gtags-find-tag-from-here)
- (define-key gtags-mode-map "\C-t" 'gtags-pop-stack)
- (define-key gtags-mode-map "\eP" 'gtags-find-file)
- (define-key gtags-mode-map "\ef" 'gtags-parse-file)
- (define-key gtags-mode-map "\eg" 'gtags-find-with-grep)
- (define-key gtags-mode-map "\eI" 'gtags-find-with-idutils)
- (define-key gtags-mode-map "\es" 'gtags-find-symbol)
- (define-key gtags-mode-map "\er" 'gtags-find-rtag)
- (define-key gtags-mode-map "\et" 'gtags-find-tag)
- (define-key gtags-mode-map "\ev" 'gtags-visit-rootdir)
- ; Mouse key mapping
- (if (not gtags-running-xemacs) nil
- (define-key gtags-mode-map 'button3 'gtags-pop-stack)
- (define-key gtags-mode-map 'button2 'gtags-find-tag-by-event))
- (if gtags-running-xemacs nil
- (define-key gtags-mode-map [mouse-3] 'gtags-pop-stack)
- (define-key gtags-mode-map [mouse-2] 'gtags-find-tag-by-event)))
- )
)
;; make gtags select-mode
@@ -741,16 +895,6 @@ Turning on Gtags-Select mode calls the value of the variable
(goto-char (point-min))
(message "[GTAGS SELECT MODE] %d lines" (count-lines (point-min) (point-max)))
(run-hooks 'gtags-select-mode-hook)
- ; Mouse key mapping
- (if gtags-suggested-key-mapping
- (progn
- (if (not gtags-running-xemacs) nil
- (define-key gtags-select-mode-map 'button3 'gtags-pop-stack)
- (define-key gtags-select-mode-map 'button2 'gtags-select-tag-by-event))
- (if gtags-running-xemacs nil
- (define-key gtags-select-mode-map [mouse-3] 'gtags-pop-stack)
- (define-key gtags-select-mode-map [mouse-2] 'gtags-select-tag-by-event)))
- )
)
(provide 'gtags)
2  site-lisp/hsenv.el
View
935 site-lisp/pos-tip.el
View
@@ -0,0 +1,935 @@
+;;; pos-tip.el -- Show tooltip at point -*- coding: utf-8 -*-
+
+;; Copyright (C) 2010 S. Irie
+
+;; Author: S. Irie
+;; Maintainer: S. Irie
+;; Keywords: Tooltip
+
+(defconst pos-tip-version "0.4.5")
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+
+;; It is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
+;; License for more details.
+
+;; You should have received a copy of the GNU General Public
+;; License along with this program; if not, write to the Free
+;; Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+;; MA 02110-1301 USA
+
+;;; Commentary:
+
+;; The standard library tooltip.el provides the function for displaying
+;; a tooltip at mouse position which allows users to easily show it.
+;; However, locating tooltip at arbitrary buffer position in window
+;; is not easy. This program provides such function to be used by other
+;; frontend programs.
+
+;; This program is tested on GNU Emacs 22, 23 under X window system and
+;; Emacs 23 for MS-Windows.
+
+;;
+;; Installation:
+;;
+;; First, save this file as pos-tip.el and byte-compile in
+;; a directory that is listed in load-path.
+;;
+;; Put the following in your .emacs file:
+;;
+;; (require 'pos-tip)
+;;
+;; To use the full features of this program on MS-Windows,
+;; put the additional setting in .emacs file:
+;;
+;; (pos-tip-w32-max-width-height) ; Maximize frame temporarily
+;;
+;; or
+;;
+;; (pos-tip-w32-max-width-height t) ; Keep frame maximized
+
+;;
+;; Examples:
+;;
+;; We can display a tooltip at the current position by the following:
+;;
+;; (pos-tip-show "foo bar")
+;;
+;; If you'd like to specify the tooltip color, use an expression as:
+;;
+;; (pos-tip-show "foo bar" '("white" . "red"))
+;;
+;; Here, "white" and "red" are the foreground color and background
+;; color, respectively.
+
+
+;;; History:
+;; 2010-09-27 S. Irie
+;; * Simplified implementation of `pos-tip-window-system'
+;; * Version 0.4.5
+;;
+;; 2010-08-20 S. Irie
+;; * Changed to use `window-line-height' to calculate tooltip position
+;; * Changed `pos-tip-string-width-height' to ignore last empty line
+;; * Version 0.4.4
+;;
+;; 2010-07-25 S. Irie
+;; * Bug fix
+;; * Version 0.4.3
+;;
+;; 2010-06-09 S. Irie
+;; * Bug fix
+;; * Version 0.4.2
+;;
+;; 2010-06-04 S. Irie
+;; * Added support for text-scale-mode
+;; * Version 0.4.1
+;;
+;; 2010-05-04 S. Irie
+;; * Added functions:
+;; `pos-tip-x-display-width', `pos-tip-x-display-height'
+;; `pos-tip-normalize-natnum', `pos-tip-frame-relative-position'
+;; * Fixed the supports for multi-displays and multi-frames
+;; * Version 0.4.0
+;;
+;; 2010-04-29 S. Irie
+;; * Modified to avoid byte-compile warning
+;; * Bug fix
+;; * Version 0.3.6
+;;
+;; 2010-04-29 S. Irie
+;; * Renamed argument MAX-HEIGHT of `pos-tip-fill-string' to MAX-ROWS
+;; * Modified old FSF address
+;; * Version 0.3.5
+;;
+;; 2010-04-29 S. Irie
+;; * Modified `pos-tip-show' to truncate string exceeding display size
+;; * Added function `pos-tip-truncate-string'
+;; * Added optional argument MAX-ROWS to `pos-tip-split-string'
+;; * Added optional argument MAX-HEIGHT to `pos-tip-fill-string'
+;; * Version 0.3.4
+;;
+;; 2010-04-16 S. Irie
+;; * Changed `pos-tip-show' not to fill paragraph unless exceeding WIDTH
+;; * Version 0.3.3
+;;
+;; 2010-04-08 S. Irie
+;; * Bug fix
+;; * Version 0.3.2
+;;
+;; 2010-03-31 S. Irie
+;; * Bug fix
+;; * Version 0.3.1
+;;
+;; 2010-03-30 S. Irie
+;; * Added support for MS-Windows
+;; * Added option `pos-tip-use-relative-coordinates'
+;; * Bug fixes
+;; * Version 0.3.0
+;;
+;; 2010-03-23 S. Irie
+;; * Changed argument WORD-WRAP to JUSTIFY
+;; * Added optional argument SQUEEZE
+;; * Added function `pos-tip-fill-string'
+;; * Added option `pos-tip-tab-width' used to expand tab characters
+;; * Bug fixes
+;; * Version 0.2.0
+;;
+;; 2010-03-22 S. Irie
+;; * Added optional argument WORD-WRAP to `pos-tip-split-string'
+;; * Changed `pos-tip-show' to perform word wrap or kinsoku shori
+;; * Version 0.1.8
+;;
+;; 2010-03-20 S. Irie
+;; * Added optional argument DY
+;; * Bug fix
+;; * Modified docstrings
+;; * Version 0.1.7
+;;
+;; 2010-03-18 S. Irie
+;; * Added/modifed docstrings
+;; * Changed working buffer name to " *xwininfo*"
+;; * Version 0.1.6
+;;
+;; 2010-03-17 S. Irie
+;; * Fixed typos in docstrings
+;; * Version 0.1.5
+;;
+;; 2010-03-16 S. Irie
+;; * Added support for multi-display environment
+;; * Bug fix
+;; * Version 0.1.4
+;;
+;; 2010-03-16 S. Irie
+;; * Bug fix
+;; * Changed calculation for `x-max-tooltip-size'
+;; * Modified docstring
+;; * Version 0.1.3
+;;
+;; 2010-03-11 S. Irie
+;; * Modified commentary
+;; * Version 0.1.2
+;;
+;; 2010-03-11 S. Irie
+;; * Re-implemented `pos-tip-string-width-height'
+;; * Added indicator variable `pos-tip-upperside-p'
+;; * Version 0.1.1
+;;
+;; 2010-03-09 S. Irie
+;; * Re-implemented `pos-tip-show' (*incompatibly changed*)
+;; - Use frame default font
+;; - Automatically calculate tooltip pixel size
+;; - Added optional arguments: TIP-COLOR, MAX-WIDTH
+;; * Added utility functions:
+;; `pos-tip-split-string', `pos-tip-string-width-height'
+;; * Bug fixes
+;; * Version 0.1.0
+;;
+;; 2010-03-08 S. Irie
+;; * Added optional argument DX
+;; * Version 0.0.4
+;;
+;; 2010-03-08 S. Irie
+;; * Bug fix
+;; * Version 0.0.3
+;;
+;; 2010-03-08 S. Irie
+;; * Modified to move out mouse pointer
+;; * Version 0.0.2
+;;
+;; 2010-03-07 S. Irie
+;; * First release
+;; * Version 0.0.1
+
+;; ToDo:
+
+;;; Code:
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Settings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar pos-tip-border-width 1
+ "Outer border width of pos-tip's tooltip.")
+
+(defvar pos-tip-internal-border-width 2
+ "Text margin of pos-tip's tooltip.")
+
+(defvar pos-tip-foreground-color "black"
+ "Default foreground color of pos-tip's tooltip.")
+
+(defvar pos-tip-background-color "lightyellow"
+ "Default background color of pos-tip's tooltip.")
+
+(defvar pos-tip-tab-width nil
+ "Tab width used for `pos-tip-split-string' and `pos-tip-fill-string'
+to expand tab characters. nil means use default value of `tab-width'.")
+
+(defvar pos-tip-use-relative-coordinates nil
+ "Non-nil means tooltip location is calculated as a coordinates
+relative to the top left corner of frame. In this case the tooltip
+will always be displayed within the frame.
+
+Note that this variable is automatically set to non-nil if absolute
+coordinates can't be obtained by `pos-tip-compute-pixel-position'.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun pos-tip-window-system (&optional frame)
+ "The name of the window system that FRAME is displaying through.
+The value is a symbol---for instance, 'x' for X windows.
+The value is nil if Emacs is using a text-only terminal.
+
+FRAME defaults to the currently selected frame."
+ (let ((type (framep (or frame (selected-frame)))))
+ (if type
+ (and (not (eq type t))
+ type)
+ (signal 'wrong-type-argument (list 'framep frame)))))
+
+(defun pos-tip-normalize-natnum (object &optional n)
+ "Return a Nth power of 2 if OBJECT is a positive integer.
+Otherwise return 0. Omitting N means return 1 for a positive integer."
+ (ash (if (and (natnump object) (> object 0)) 1 0)
+ (or n 0)))
+
+(defvar pos-tip-saved-frame-coordinates '(0 . 0)
+ "The latest result of `pos-tip-frame-top-left-coordinates'.")
+
+(defvar pos-tip-frame-offset nil
+ "The latest result of `pos-tip-calibrate-frame-offset'. This value
+is used for non-X graphical environment.")
+
+(defvar pos-tip-frame-offset-array [nil nil nil nil]
+ "Array of the results of `pos-tip-calibrate-frame-offset'. They are
+recorded only when `pos-tip-frame-top-left-coordinates' is called for a
+non-X but graphical frame.
+
+The 2nd and 4th elements are the values for frames having a menu bar.
+The 3rd and 4th elements are the values for frames having a tool bar.")
+
+(defun pos-tip-frame-top-left-coordinates (&optional frame)
+ "Return the pixel coordinates of FRAME as a cons cell (LEFT . TOP),
+which are relative to top left corner of screen.
+
+Return nil if failing to acquire the coordinates.
+
+If FRAME is omitted, use selected-frame.
+
+Users can also get the frame coordinates by referring the variable
+`pos-tip-saved-frame-coordinates' just after calling this function."
+ (let ((winsys (pos-tip-window-system frame)))
+ (cond
+ ((null winsys)
+ (error "text-only frame: %S" frame))
+ ((eq winsys 'x)
+ (condition-case nil
+ (with-current-buffer (get-buffer-create " *xwininfo*")
+ (let ((case-fold-search nil))
+ (buffer-disable-undo)
+ (erase-buffer)
+ (call-process shell-file-name nil t nil shell-command-switch
+ (format "xwininfo -display %s -id %s"
+ (frame-parameter frame 'display)
+ (frame-parameter frame 'window-id)))
+ (goto-char (point-min))
+ (search-forward "\n Absolute")
+ (setq pos-tip-saved-frame-coordinates
+ (cons (string-to-number (buffer-substring-no-properties
+ (search-forward "X: ")
+ (line-end-position)))
+ (string-to-number (buffer-substring-no-properties
+ (search-forward "Y: ")
+ (line-end-position)))))))
+ (error nil)))
+ (t
+ (let* ((index (+ (pos-tip-normalize-natnum
+ (frame-parameter frame 'menu-bar-lines) 0)
+ (pos-tip-normalize-natnum
+ (frame-parameter frame 'tool-bar-lines) 1)))
+ (offset (or (aref pos-tip-frame-offset-array index)
+ (aset pos-tip-frame-offset-array index
+ (pos-tip-calibrate-frame-offset frame)))))
+ (if offset
+ (setq pos-tip-saved-frame-coordinates
+ (cons (+ (eval (frame-parameter frame 'left))
+ (car offset))
+ (+ (eval (frame-parameter frame 'top))
+ (cdr offset))))))))))
+
+(defun pos-tip-frame-relative-position
+ (frame1 frame2 &optional w32-frame frame-coord1 frame-coord2)
+ "Return the pixel coordinates of FRAME1 relative to FRAME2
+as a cons cell (LEFT . TOP).
+
+W32-FRAME non-nil means both of frames are under `w32' window system.
+
+FRAME-COORD1 and FRAME-COORD2, if given, specify the absolute
+coordinates of FRAME1 and FRAME2, respectively, which make the
+calculations faster if the frames have different heights of menu bars
+and tool bars."
+ (if (and (eq (pos-tip-normalize-natnum
+ (frame-parameter frame1 'menu-bar-lines))
+ (pos-tip-normalize-natnum
+ (frame-parameter frame2 'menu-bar-lines)))
+ (or w32-frame
+ (eq (pos-tip-normalize-natnum
+ (frame-parameter frame1 'tool-bar-lines))
+ (pos-tip-normalize-natnum
+ (frame-parameter frame2 'tool-bar-lines)))))
+ (cons (- (eval (frame-parameter frame1 'left))
+ (eval (frame-parameter frame2 'left)))
+ (- (eval (frame-parameter frame1 'top))
+ (eval (frame-parameter frame2 'top))))
+ (unless frame-coord1
+ (setq frame-coord1 (let (pos-tip-saved-frame-coordinates)
+ (pos-tip-frame-top-left-coordinates frame1))))
+ (unless frame-coord2
+ (setq frame-coord2 (let (pos-tip-saved-frame-coordinates)
+ (pos-tip-frame-top-left-coordinates frame2))))
+ (cons (- (car frame-coord1) (car frame-coord2))
+ (- (cdr frame-coord1) (cdr frame-coord2)))))
+
+(defvar pos-tip-upperside-p nil
+ "Non-nil indicates the latest result of `pos-tip-compute-pixel-position'
+was upper than the location specified by the arguments.")
+
+(defvar pos-tip-w32-saved-max-width-height nil
+ "Display pixel size effective for showing tooltip in MS-Windows desktop.
+This doesn't include the taskbar area, so isn't same as actual display size.")
+
+(defun pos-tip-compute-pixel-position
+ (&optional pos window pixel-width pixel-height frame-coordinates dx dy)
+ "Return pixel position of POS in WINDOW like (X . Y), which indicates
+the absolute or relative coordinates of bottom left corner of the object.
+
+Omitting POS and WINDOW means use current position and selected window,
+respectively.
+
+If PIXEL-WIDTH and PIXEL-HEIGHT are given, this function assumes these
+values as the size of small window like tooltip which is located around the
+object at POS. These values are used to adjust the location in order that
+the tooltip won't disappear by sticking out of the display. By referring
+the variable `pos-tip-upperside-p' after calling this function, user can
+examine whether the tooltip will be located above the specified position.
+
+If FRAME-COORDINATES is omitted or nil, automatically obtain the absolute
+coordinates of the top left corner of frame which WINDOW is on. Here,
+`top left corner of frame' represents the origin of `window-pixel-edges'
+and its coordinates are essential for calculating the return value as
+absolute coordinates. If a cons cell like (LEFT . TOP), specifies the
+frame absolute location and makes the calculation slightly faster, but can
+be used only when it's clear that frame is in the specified position. Users
+can get the latest values of frame coordinates for using in the next call
+by referring the variable `pos-tip-saved-frame-coordinates' just after
+calling this function. Otherwise, FRAME-COORDINATES `relative' means return
+pixel coordinates of the object relative to the top left corner of the frame.
+This is the same effect as `pos-tip-use-relative-coordinates' is non-nil.
+
+DX specifies horizontal offset in pixel.
+
+DY specifies vertical offset in pixel. This makes the calculations done
+without considering the height of object at POS, so the object might be
+hidden by the tooltip."
+ (let* ((frame (window-frame (or window (selected-window))))
+ (w32-frame (eq (pos-tip-window-system frame) 'w32))
+ (relative (or pos-tip-use-relative-coordinates
+ (eq frame-coordinates 'relative)
+ (and w32-frame
+ (null pos-tip-w32-saved-max-width-height))))
+ (frame-coord (or (and relative '(0 . 0))
+ frame-coordinates
+ (pos-tip-frame-top-left-coordinates frame)
+ (progn
+ (setq relative t
+ pos-tip-use-relative-coordinates t)
+ '(0 . 0))))
+ (posn (posn-at-point (or pos (window-point window)) window))
+ (line (cdr (posn-actual-col-row posn)))
+ (line-height (and line
+ (or (window-line-height line window)
+ (and (redisplay t)
+ (window-line-height line window)))))
+ (x-y (or (posn-x-y posn)
+ (let ((geom (pos-visible-in-window-p
+ (or pos (window-point window)) window t)))
+ (and geom (cons (car geom) (cadr geom))))
+ '(0 . 0)))
+ (x (+ (car frame-coord)
+ (car (window-inside-pixel-edges window))
+ (car x-y)
+ (or dx 0)))
+ (y0 (+ (cdr frame-coord)
+ (cadr (window-pixel-edges window))
+ (or (nth 2 line-height) (cdr x-y))))
+ (y (+ y0
+ (or dy
+ (car line-height)
+ (with-current-buffer (window-buffer window)
+ (cond
+ ;; `posn-object-width-height' returns an incorrect value
+ ;; when the header line is displayed (Emacs bug #4426).
+ ((and posn
+ (null header-line-format))
+ (cdr (posn-object-width-height posn)))
+ ((and (bound-and-true-p text-scale-mode)
+ (not (zerop (with-no-warnings
+ text-scale-mode-amount))))
+ (round (* (frame-char-height frame)
+ (with-no-warnings
+ (expt text-scale-mode-step
+ text-scale-mode-amount)))))
+ (t
+ (frame-char-height frame)))))))
+ xmax ymax)
+ (cond
+ (relative
+ (setq xmax (frame-pixel-width frame)
+ ymax (frame-pixel-height frame)))
+ (w32-frame
+ (setq xmax (car pos-tip-w32-saved-max-width-height)
+ ymax (cdr pos-tip-w32-saved-max-width-height)))
+ (t
+ (setq xmax (x-display-pixel-width frame)
+ ymax (x-display-pixel-height frame))))
+ (setq pos-tip-upperside-p (> (+ y (or pixel-height 0))
+ ymax))
+ (cons (max 0 (min x (- xmax (or pixel-width 0))))
+ (max 0 (if pos-tip-upperside-p
+ (- (if dy ymax y0) (or pixel-height 0))
+ y)))))
+
+(defun pos-tip-cancel-timer ()
+ "Cancel timeout of tooltip."
+ (mapc (lambda (timer)
+ (if (eq (aref timer 5) 'x-hide-tip)
+ (cancel-timer timer)))
+ timer-list))
+
+(defun pos-tip-avoid-mouse (left right top bottom &optional frame)
+ "Move out mouse pointer if it is inside region (LEFT RIGHT TOP BOTTOM)
+in FRAME. Return new mouse position like (FRAME . (X . Y))."
+ (unless frame
+ (setq frame (selected-frame)))
+ (let* ((mpos (with-selected-window (frame-selected-window frame)
+ (mouse-pixel-position)))
+ (mframe (pop mpos))
+ (mx (car mpos))
+ (my (cdr mpos)))
+ (when (and (eq mframe frame)
+ (numberp mx))
+ (let* ((large-number (+ (frame-pixel-width frame) (frame-pixel-height frame)))
+ (dl (if (> left 2)
+ (1+ (- mx left))
+ large-number))
+ (dr (if (< (1+ right) (frame-pixel-width frame))
+ (- right mx)
+ large-number))
+ (dt (if (> top 2)
+ (1+ (- my top))
+ large-number))
+ (db (if (< (1+ bottom) (frame-pixel-height frame))
+ (- bottom my)
+ large-number))
+ (d (min dl dr dt db)))
+ (when (> d -2)
+ (cond
+ ((= d dl)
+ (setq mx (- left 2)))
+ ((= d dr)
+ (setq mx (1+ right)))
+ ((= d dt)
+ (setq my (- top 2)))
+ (t
+ (setq my (1+ bottom))))
+ (set-mouse-pixel-position frame mx my)
+ (sit-for 0.0001))))
+ (cons mframe (and mpos (cons mx my)))))
+
+(defun pos-tip-show-no-propertize
+ (string &optional tip-color pos window timeout pixel-width pixel-height frame-coordinates dx dy)
+ "Show STRING in a tooltip at POS in WINDOW.
+Analogous to `pos-tip-show' except don't propertize STRING by `pos-tip' face.
+
+PIXEL-WIDTH and PIXEL-HEIGHT specify the size of tooltip, if given. These
+are used to adjust the tooltip position in order that it doesn't disappear by
+sticking out of the display, and also used to prevent it from vanishing by
+overlapping with mouse pointer.
+
+Note that this function itself doesn't calculate tooltip size because the
+character width and height specified by faces are unknown. So users should
+calculate PIXEL-WIDTH and PIXEL-HEIGHT by using `pos-tip-tooltip-width' and
+`pos-tip-tooltip-height', or use `pos-tip-show' instead, which can
+automatically calculate tooltip size.
+
+See `pos-tip-show' for details.
+
+Example:
+
+\(defface my-tooltip
+ '((t
+ :background \"gray85\"
+ :foreground \"black\"
+ :inherit variable-pitch))
+ \"Face for my tooltip.\")
+
+\(defface my-tooltip-highlight
+ '((t
+ :background \"blue\"
+ :foreground \"white\"
+ :inherit my-tooltip))
+ \"Face for my tooltip highlighted.\")
+
+\(let ((str (propertize \" foo \\n bar \\n baz \" 'face 'my-tooltip)))
+ (put-text-property 6 11 'face 'my-tooltip-highlight str)
+ (pos-tip-show-no-propertize str 'my-tooltip))"
+ (unless window
+ (setq window (selected-window)))
+ (let* ((frame (window-frame window))
+ (winsys (pos-tip-window-system frame))
+ (x-frame (eq winsys 'x))
+ (w32-frame (eq winsys 'w32))
+ (relative (or pos-tip-use-relative-coordinates
+ (eq frame-coordinates 'relative)
+ (and w32-frame
+ (null pos-tip-w32-saved-max-width-height))))
+ (x-y (prog1
+ (pos-tip-compute-pixel-position pos window
+ pixel-width pixel-height
+ frame-coordinates dx dy)
+ (if pos-tip-use-relative-coordinates
+ (setq relative t))))
+ (ax (car x-y))
+ (ay (cdr x-y))
+ (rx (if relative ax (- ax (car pos-tip-saved-frame-coordinates))))
+ (ry (if relative ay (- ay (cdr pos-tip-saved-frame-coordinates))))
+ (retval (cons rx ry))
+ (fg (or (and (facep tip-color)
+ (face-attribute tip-color :foreground))
+ (car-safe tip-color)
+ pos-tip-foreground-color))
+ (bg (or (and (facep tip-color)
+ (face-attribute tip-color :background))
+ (cdr-safe tip-color)
+ pos-tip-background-color))
+ (use-dxdy (or relative
+ (not x-frame)))
+ (spacing (frame-parameter frame 'line-spacing))
+ (border (ash (+ pos-tip-border-width
+ pos-tip-internal-border-width)
+ 1))
+ (x-max-tooltip-size
+ (cons (+ (if x-frame 1 0)
+ (/ (- (or pixel-width
+ (cond
+ (relative
+ (frame-pixel-width frame))
+ (w32-frame
+ (car pos-tip-w32-saved-max-width-height))
+ (t
+ (x-display-pixel-width frame))))
+ border)
+ (frame-char-width frame)))
+ (/ (- (or pixel-height
+ (x-display-pixel-height frame))
+ border)
+ (frame-char-height frame))))
+ (mpos (with-selected-window window (mouse-pixel-position)))
+ (mframe (car mpos))
+ default-frame-alist)
+ (if (or relative
+ (and use-dxdy
+ (null (cadr mpos))))
+ (unless (and (cadr mpos)
+ (eq mframe frame))
+ (let* ((edges (window-inside-pixel-edges (cadr (window-list frame))))
+ (mx (ash (+ (pop edges) (cadr edges)) -1))
+ (my (ash (+ (pop edges) (cadr edges)) -1)))
+ (setq mframe frame)
+ (set-mouse-pixel-position mframe mx my)
+ (sit-for 0.0001)))
+ (when (and (cadr mpos)
+ (not (eq mframe frame)))
+ (let ((rel-coord (pos-tip-frame-relative-position frame mframe w32-frame
+ frame-coordinates)))
+ (setq rx (+ rx (car rel-coord))
+ ry (+ ry (cdr rel-coord))))))
+ (and pixel-width pixel-height
+ (setq mpos (pos-tip-avoid-mouse rx (+ rx pixel-width
+ (if w32-frame 3 0))
+ ry (+ ry pixel-height)
+ mframe)))
+ (x-show-tip string mframe
+ `((border-width . ,pos-tip-border-width)
+ (internal-border-width . ,pos-tip-internal-border-width)
+ ,@(and (not use-dxdy) `((left . ,ax)
+ (top . ,ay)))
+ (font . ,(frame-parameter frame 'font))
+ ,@(and spacing `((line-spacing . ,spacing)))
+ ,@(and (stringp fg) `((foreground-color . ,fg)))
+ ,@(and (stringp bg) `((background-color . ,bg))))
+ (and timeout (> timeout 0) timeout)
+ (and use-dxdy (- rx (cadr mpos)))
+ (and use-dxdy (- ry (cddr mpos))))
+ (if (and timeout (<= timeout 0))
+ (pos-tip-cancel-timer))
+ retval))
+
+(defun pos-tip-split-string (string &optional width margin justify squeeze max-rows)
+ "Split STRING into fixed width strings. Return a list of these strings.
+
+WIDTH specifies the width of filling each paragraph. WIDTH nil means use
+the width of currently selected frame. Note that this function doesn't add any
+padding characters at the end of each row.
+
+MARGIN, if non-nil, specifies left margin width which is the number of spece
+characters to add at the beginning of each row.
+
+The optional fourth argument JUSTIFY specifies which kind of justification
+to do: `full', `left', `right', `center', or `none'. A value of t means handle
+each paragraph as specified by its text properties. Omitting JUSTIFY means
+don't perform justification, word wrap and kinsoku shori (禁則処理).
+
+SQUEEZE nil means leave whitespaces other than line breaks untouched.
+
+MAX-ROWS, if given, specifies maximum number of elements of return value.
+The elements exceeding this number are discarded."
+ (with-temp-buffer
+ (let* ((tab-width (or pos-tip-tab-width tab-width))
+ (fill-column (or width (frame-width)))
+ (left-margin (or margin 0))
+ (kinsoku-limit 1)
+ indent-tabs-mode
+ row rows)
+ (insert string)
+ (untabify (point-min) (point-max))
+ (if justify
+ (fill-region (point-min) (point-max) justify (not squeeze))
+ (setq margin (make-string left-margin ?\s)))
+ (goto-char (point-min))
+ (while (prog2
+ (let ((line (buffer-substring
+ (point) (progn (end-of-line) (point)))))
+ (if justify
+ (push line rows)
+ (while (progn
+ (setq line (concat margin line)
+ row (truncate-string-to-width line fill-column))
+ (push row rows)
+ (if (not (= (length row) (length line)))
+ (setq line (substring line (length row))))))))
+ (< (point) (point-max))
+ (beginning-of-line 2)))
+ (nreverse (if max-rows
+ (last rows max-rows)
+ rows)))))
+
+(defun pos-tip-fill-string (string &optional width margin justify squeeze max-rows)
+ "Fill each of the paragraphs in STRING.
+
+WIDTH specifies the width of filling each paragraph. WIDTH nil means use
+the width of currently selected frame. Note that this function doesn't add any
+padding characters at the end of each row.
+
+MARGIN, if non-nil, specifies left margin width which is the number of spece
+characters to add at the beginning of each row.
+
+The optional fourth argument JUSTIFY specifies which kind of justification
+to do: `full', `left', `right', `center', or `none'. A value of t means handle
+each paragraph as specified by its text properties. Omitting JUSTIFY means
+don't perform justification, word wrap and kinsoku shori (禁則処理).
+
+SQUEEZE nil means leave whitespaces other than line breaks untouched.
+
+MAX-ROWS, if given, specifies maximum number of rows. The rows exceeding
+this number are discarded."
+ (if justify
+ (with-temp-buffer
+ (let* ((tab-width (or pos-tip-tab-width tab-width))
+ (fill-column (or width (frame-width)))
+ (left-margin (or margin 0))
+ (kinsoku-limit 1)
+ indent-tabs-mode)
+ (insert string)
+ (untabify (point-min) (point-max))
+ (fill-region (point-min) (point-max) justify (not squeeze))
+ (if max-rows
+ (buffer-substring (goto-char (point-min))
+ (line-end-position max-rows))
+ (buffer-string))))
+ (mapconcat 'identity
+ (pos-tip-split-string string width margin nil nil max-rows)
+ "\n")))
+
+(defun pos-tip-truncate-string (string width height)
+ "Truncate each line of STRING to WIDTH and discard lines exceeding HEIGHT."
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (let ((nrow 0)
+ rows)
+ (while (and (< nrow height)
+ (prog2
+ (push (truncate-string-to-width
+ (buffer-substring (point) (progn (end-of-line) (point)))
+ width)
+ rows)
+ (< (point) (point-max))
+ (beginning-of-line 2)
+ (setq nrow (1+ nrow)))))
+ (mapconcat 'identity (nreverse rows) "\n"))))
+
+(defun pos-tip-string-width-height (string)
+ "Count columns and rows of STRING. Return a cons cell like (WIDTH . HEIGHT).
+The last empty line of STRING is ignored.
+
+Example:
+
+\(pos-tip-string-width-height \"abc\\nあいう\\n123\")
+;; => (6 . 3)"
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (end-of-line)
+ (let ((width (current-column))
+ (height (if (eq (char-before (point-max)) ?\n) 0 1)))
+ (while (< (point) (point-max))
+ (end-of-line 2)
+ (setq width (max (current-column) width)
+ height (1+ height)))
+ (cons width height))))
+
+(defun pos-tip-x-display-width (&optional frame)
+ "Return maximum column number in tooltip which occupies the full width
+of display. Omitting FRAME means use display that selected frame is in."
+ (1+ (/ (x-display-pixel-width frame) (frame-char-width frame))))
+
+(defun pos-tip-x-display-height (&optional frame)
+ "Return maximum row number in tooltip which occupies the full height
+of display. Omitting FRAME means use display that selected frame is in."
+ (1+ (/ (x-display-pixel-height frame) (frame-char-height frame))))
+
+(defun pos-tip-tooltip-width (width char-width)
+ "Calculate tooltip pixel width."
+ (+ (* width char-width)
+ (ash (+ pos-tip-border-width
+ pos-tip-internal-border-width)
+ 1)))
+
+(defun pos-tip-tooltip-height (height char-height &optional frame)
+ "Calculate tooltip pixel height."
+ (let ((spacing (or (default-value 'line-spacing)
+ (frame-parameter frame 'line-spacing))))
+ (+ (* height (+ char-height
+ (cond
+ ((integerp spacing)
+ spacing)
+ ((floatp spacing)
+ (truncate (* (frame-char-height frame)
+ spacing)))
+ (t 0))))
+ (ash (+ pos-tip-border-width
+ pos-tip-internal-border-width)
+ 1))))
+
+(make-face 'pos-tip-temp)
+
+(defun pos-tip-show
+ (string &optional tip-color pos window timeout width frame-coordinates dx dy)
+ "Show STRING in a tooltip, which is a small X window, at POS in WINDOW
+using frame's default font with TIP-COLOR.
+
+Return pixel position of tooltip relative to top left corner of frame as
+a cons cell like (X . Y).
+
+TIP-COLOR is a face or a cons cell like (FOREGROUND-COLOR . BACKGROUND-COLOR)
+used to specify *only* foreground-color and background-color of tooltip.
+If omitted, use `pos-tip-foreground-color' and `pos-tip-background-color'
+instead.
+
+Omitting POS and WINDOW means use current position and selected window,
+respectively.
+
+Automatically hide the tooltip after TIMEOUT seconds. Omitting TIMEOUT means
+use the default timeout of 5 seconds. Non-positive TIMEOUT means don't hide
+tooltip automatically.
+
+WIDTH, if non-nil, specifies the width of filling each paragraph.
+
+If FRAME-COORDINATES is omitted or nil, automatically obtain the absolute
+coordinates of the top left corner of frame which WINDOW is on. Here,
+`top left corner of frame' represents the origin of `window-pixel-edges'
+and its coordinates are essential for calculating the absolute coordinates
+of the tooltip. If a cons cell like (LEFT . TOP), specifies the frame
+absolute location and makes the calculation slightly faster, but can be
+used only when it's clear that frame is in the specified position. Users
+can get the latest values of frame coordinates for using in the next call
+by referring the variable `pos-tip-saved-frame-coordinates' just after
+calling this function. Otherwise, FRAME-COORDINATES `relative' means use
+the pixel coordinates relative to the top left corner of the frame for
+displaying the tooltip. This is the same effect as
+`pos-tip-use-relative-coordinates' is non-nil.
+
+DX specifies horizontal offset in pixel.
+
+DY specifies vertical offset in pixel. This makes the calculations done
+without considering the height of object at POS, so the object might be
+hidden by the tooltip.
+
+See also `pos-tip-show-no-propertize'."
+ (unless window
+ (setq window (selected-window)))
+ (let* ((frame (window-frame window))
+ (max-width (pos-tip-x-display-width frame))
+ (max-height (pos-tip-x-display-height frame))
+ (w-h (pos-tip-string-width-height string)))
+ (cond
+ ((and width
+ (> (car w-h) width))
+ (setq string (pos-tip-fill-string string width nil 'none nil max-height)
+ w-h (pos-tip-string-width-height string)))
+ ((or (> (car w-h) max-width)
+ (> (cdr w-h) max-height))
+ (setq string (pos-tip-truncate-string string max-width max-height)
+ w-h (pos-tip-string-width-height string))))
+ (face-spec-reset-face 'pos-tip-temp)
+ (with-selected-window window
+ (set-face-font 'pos-tip-temp (frame-parameter frame 'font)))
+ (pos-tip-show-no-propertize
+ (propertize string 'face 'pos-tip-temp)
+ tip-color pos window timeout
+ (pos-tip-tooltip-width (car w-h) (frame-char-width frame))
+ (pos-tip-tooltip-height (cdr w-h) (frame-char-height frame) frame)
+ frame-coordinates dx dy)))
+
+(defalias 'pos-tip-hide 'x-hide-tip
+ "Hide pos-tip's tooltip.")
+
+(defun pos-tip-calibrate-frame-offset (&optional frame)
+ "Return coordinates of FRAME orign relative to the top left corner of
+the FRAME extent, like (LEFT . TOP). The return value is recorded to
+`pos-tip-frame-offset'.
+
+Note that this function does't correctly work for X frame and Emacs 22."
+ (setq pos-tip-frame-offset nil)
+ (let* ((window (frame-first-window frame))
+ (delete-frame-functions
+ '((lambda (frame)
+ (if (equal (frame-parameter frame 'name) "tooltip")
+ (setq pos-tip-frame-offset
+ (cons (eval (frame-parameter frame 'left))
+ (eval (frame-parameter frame 'top))))))))
+ (pos-tip-border-width 0)
+ (pos-tip-internal-border-width 1)
+ (rpos (pos-tip-show ""
+ '(nil . (frame-parameter frame 'background-color))
+ (window-start window) window
+ nil nil 'relative nil 0)))
+ (sit-for 0)
+ (pos-tip-hide)
+ (and pos-tip-frame-offset
+ (setq pos-tip-frame-offset
+ (cons (- (car pos-tip-frame-offset)
+ (car rpos)
+ (eval (frame-parameter frame 'left)))
+ (- (cdr pos-tip-frame-offset)
+ (cdr rpos)
+ (eval (frame-parameter frame 'top))))))))
+
+(defun pos-tip-w32-max-width-height (&optional keep-maximize)
+ "Maximize the currently selected frame temporarily and set
+`pos-tip-w32-saved-max-width-height' the effective display size in order
+to become possible to calculate the absolute location of tooltip.
+
+KEEP-MAXIMIZE non-nil means leave the frame maximized.
+
+Note that this function is usable only in Emacs 23 for MS-Windows."
+ (interactive)
+ (unless (eq window-system 'w32)
+ (error "`pos-tip-w32-max-width-height' can be used only in w32 frame."))
+ ;; Maximize frame
+ (with-no-warnings (w32-send-sys-command 61488))
+ (sit-for 0)
+ (let ((offset (pos-tip-calibrate-frame-offset)))
+ (prog1
+ (setq pos-tip-w32-saved-max-width-height
+ (cons (frame-pixel-width)
+ (+ (frame-pixel-height)
+ (- (cdr offset) (car offset)))))
+ (if (interactive-p)
+ (message "%S" pos-tip-w32-saved-max-width-height))
+ (unless keep-maximize
+ ;; Restore frame
+ (with-no-warnings (w32-send-sys-command 61728))))))
+
+
+(provide 'pos-tip)
+
+;;;
+;;; pos-tip.el ends here
2  snippets/org-mode/src
View
@@ -1,4 +1,4 @@
#binding : C-c C-e C-s
# --
-#+begin_src ledger
+#+begin_src haskell
$0#+end_src
Please sign in to comment.
Something went wrong with that request. Please try again.