ide/emacs/bg-build-util.el

   1 ;; Copyright (C) 2007 Vesa Karvonen
   2 ;;
   3 ;; MLton is released under a BSD-style license.
   4 ;; See the file MLton-LICENSE for details.
   5
   6 (require 'cl)
   7 (require 'compat)
   8
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10 ;; Utils
  11
  12 (defun bg-build-cons-once (entry list)
  13   (cons entry (remove* entry list :test (function equal))))
  14
  15 (defun bg-build-flatmap (fn list)
  16   (apply (function append) (mapcar fn list)))
  17
  18 (defun bg-build-remove-from-assoc (alist key)
  19   (remove*
  20    nil alist
  21    :test (function
  22           (lambda (_ key-value)
  23             (equal key (car key-value))))))
  24
  25 (defun bg-build-replace-in-assoc (alist key value)
  26   (cons (cons key value)
  27         (bg-build-remove-from-assoc alist key)))
  28
  29 (defun bg-build-assoc-cdr (key alist)
  30   "Same as (cdr (assoc key alist)) except that doesn't attempt to call cdr
  31 on nil."
  32   (let ((key-value (assoc key alist)))
  33     (when key-value
  34       (cdr key-value))))
  35
  36 (defun bg-build-const (value)
  37   "Returns a function that returns the given value."
  38   (lexical-let ((value value))
  39     (lambda (&rest _)
  40       value)))
  41
  42 (defun bg-build-kill-current-buffer ()
  43   "Kills the current buffer."
  44   (interactive)
  45   (kill-buffer (current-buffer)))
  46
  47 (defun bg-build-make-hash-table ()
  48   "Makes a hash table with `equal' semantics."
  49   (make-hash-table :test 'equal :size 1))
  50
  51 (defun bg-build-point-at-current-line ()
  52   "Returns point at the beginning of the current line."
  53   (save-excursion
  54     (beginning-of-line)
  55     (point)))
  56
  57 (defun bg-build-current-line ()
  58   "Returns the current line number counting from 1."
  59   (+ 1 (count-lines 1 (bg-build-point-at-current-line))))
  60
  61 (defun bg-build-time-to-double (time)
  62   "Converts a time to a double."
  63   (+ (* (car time) 65536.0)
  64      (cadr time)
  65      (if (cddr time) (* (caddr time) 1e-06) 0)))
  66
  67 (defun bg-build-attr-newer? (attr1 attr2)
  68   "Returns non-nil iff the modification time of `attr1' is later than the
  69 modification time of `attr2'.  Note that this also returns nil when either
  70 one of the modification times is nil."
  71   (and attr1 attr2
  72        (> (bg-build-time-to-double (nth 5 attr1))
  73           (bg-build-time-to-double (nth 5 attr2)))))
  74
  75 (defun bg-build-pos-to-point (pos)
  76   "Returns the value of point in the current buffer at the position given
  77 as a (line . col) pair."
  78   (save-excursion
  79     (goto-line (car pos))
  80     (+ (point) (cdr pos))))
  81
  82 (defun bg-build-point-to-pos (point)
  83   "Returns the position as a (line . col) pair corresponding to the
  84 specified point in the current buffer."
  85   (save-excursion
  86     (goto-char point)
  87     (beginning-of-line)
  88     (let ((line (+ (count-lines 1 (point)) 1))
  89           (col (- point (point))))
  90       (cons line col))))
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93
  94 (provide 'bg-build-util)