elisp/geiser-base.el

   1 ;;; geiser-base.el --- shared bits
   2
   3 ;; Copyright (C) 2009, 2010, 2012, 2013, 2015, 2016, 2019  Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Settings and vars shared by all geiser modules, including little
  11 ;; utilities and emacsen compatibility bits.
  12
  13 \f
  14 ;;; Code:
  15 ;;; Emacs compatibility:
  16
  17 (require 'ring)
  18
  19 (eval-after-load "ring"
  20   '(when (not (fboundp 'ring-member))
  21      (defun ring-member (ring item)
  22        (catch 'found
  23          (dotimes (ind (ring-length ring) nil)
  24            (when (equal item (ring-ref ring ind))
  25              (throw 'found ind)))))))
  26
  27 (when (not (fboundp 'looking-at-p))
  28   (defsubst looking-at-p (regexp)
  29     (let ((inhibit-changing-match-data t))
  30       (looking-at regexp))))
  31
  32 (defalias 'geiser--font-lock-ensure
  33   (if (fboundp 'font-lock-ensure)
  34       #'font-lock-ensure
  35     (with-no-warnings
  36       (lambda (&optional _beg _end)
  37         (when font-lock-mode
  38           (font-lock-fontify-buffer))))))
  39
  40 ;;; Utilities:
  41
  42 (defsubst geiser--chomp (str)
  43   (if (string-match-p ".*\n$" str) (substring str 0 -1) str))
  44
  45 (defun geiser--shorten-str (str len &optional sep)
  46   (let ((str-len (length str)))
  47     (if (<= str-len len)
  48         str
  49       (let* ((sep (or sep " ... "))
  50              (sep-len (length sep))
  51              (prefix-len (/ (- str-len sep-len) 2))
  52              (prefix (substring str 0 prefix-len))
  53              (suffix (substring str (- str-len prefix-len))))
  54         (format "%s%s%s" prefix sep suffix)))))
  55
  56 (defun geiser--region-to-string (begin &optional end)
  57   (let ((end (or end (point))))
  58     (when (< begin end)
  59       (let* ((str (buffer-substring-no-properties begin end))
  60              (pieces (split-string str nil t)))
  61         (mapconcat 'identity pieces " ")))))
  62
  63 (defun geiser--insert-with-face (str face)
  64   (let ((p (point)))
  65     (insert str)
  66     (put-text-property p (point) 'face face)))
  67
  68
  69 (defmacro geiser--save-msg (&rest body)
  70   (let ((msg (make-symbol "msg")))
  71     `(let ((,msg (current-message)))
  72        ,@body
  73        (message ,msg))))
  74
  75 (put 'geiser--save-msg 'lisp-indent-function 0)
  76
  77 (defun geiser--del-dups (lst)
  78   (let (result)
  79     (dolist (e lst (nreverse result))
  80       (unless (member e result) (push e result)))))
  81
  82 (defsubst geiser--symbol-at-point ()
  83   (let ((thing (thing-at-point 'symbol)))
  84     (and thing (make-symbol thing))))
  85
  86 (defun geiser--cut-version (v)
  87   (when (string-match "\\([0-9]+\\(?:\\.[0-9]+\\)*\\).*" v)
  88     (match-string 1 v)))
  89
  90 (defun geiser--version< (v1 v2)
  91   (let ((v1 (geiser--cut-version v1))
  92         (v2 (geiser--cut-version v2)))
  93     (and v1 v2 (version< v1 v2))))
  94
  95 (provide 'geiser-base)