stoe/core/utils.lisp

#|
  This file is a part of stoe project.
  Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|#

(uiop:define-package :stoe/core/utils
  (:export #:safe-first #:safe-list
           #:group #:ret
           #:restartable
           #:progress-step
           #:loop-with-progress
           #:add-hook #:remove-hook #:run-hook
           #:shared-object #:refcount #:inc-ref #:dec-ref
           #:extend-array #:shrink-array
           #:error-implementation-unsupported
           #:get-command-line-option
           #:get-command-line-option-number
           #:pathname-path
           #:name #:id #:parent #:size
           #:raw-data))
(in-package :stoe/core/utils)

(defun safe-first (x)
  "Return the first element of `x' if it is a list, return `x' otherwise."
  (if (listp x) (first x) x))

(defun safe-list (x)
  "Return `x' if it is a list, return '(x) otherwise."
  (if (listp x) x (list x)))

(defun group (source &optional (n 2))
  "Regroup the list `source' elements by n."
  (when (zerop n)
    (error "zero length"))
  (labels ((rec (source acc)
             (let ((rest (nthcdr n source)))
               (if (consp rest)
                   (rec rest (cons (subseq source 0 n) acc))
                   (nreverse (cons source acc))))))
    (if source (rec source nil) nil)))

(defmacro ret (var val &body body)
  `(let ((,var ,val))
     ,@body
     ,var))

(defmacro restartable (&body body)
  "Provide a Continue restart."
  `(restart-case
       (progn
         ,@body)
     (continue () :report "Continue")))

(defmacro loop-with-progress (msg &body body)
  "Allow a looping process to display feedback."
  `(let ((progress-max-columns 80))
     (symbol-macrolet ((progress-step
                        (progn
                          (when (> progress-index progress-max-columns)
                            (format t "~%")
                            (setf progress-index 0))
                          (format t "."))))
       (format t ,msg)
       (loop for progress-index upfrom ,(length msg)
            ,@body)
       (format t "~%"))))

(defmacro add-hook (hook fun &optional append)
  "Setup `fun' to be called within specified `hook'."
  `(unless (member ,fun ,hook)
     ,(if append
          `(setf ,hook (append ,hook (list ,fun)))
          `(push ,fun ,hook))))

(defmacro remove-hook (hook fun)
  "Remove `fun' from `hook'."
  `(setf ,hook (delete ,fun ,hook)))

(defun run-hook (hook &rest args)
  "Apply all functions attached to `hook' with specified `args' if any."
  (let (result)
    (mapc (lambda (fun)
            (setf result (apply fun args)))
          hook)
    result))

(defclass shared-object ()
  ((refcount :initform 0 :reader refcount)))

(defgeneric inc-ref (obj))
(defmethod inc-ref ((obj shared-object))
  (with-slots (refcount) obj
    (incf refcount)))

(defgeneric dec-ref (obj))
(defmethod dec-ref ((obj shared-object))
  (with-slots (refcount) obj
    (when (> refcount 0)
      (decf refcount))))

(let ((extend-ratio 1.5))
  (defun extend-array (array)
    "Extend an array to extend-ratio coefficient."
    (when (= (fill-pointer array) (array-total-size array))
      (adjust-array array (floor (* (array-total-size array) extend-ratio))))
    (prog1
        (fill-pointer array)
      (incf (fill-pointer array))))

  (defun shrink-array (array new-fill-pointer)
    "Shrink an array to its fill-pointer."
    (setf (fill-pointer array) new-fill-pointer)))

(defun error-implementation-unsupported ()
  "Return an error specifying the current lisp implementation is not supported."
  (error "For now, only sbcl is supported."))

(defun get-command-line-option (argv optname &optional default)
  "Return the option designated by `optname' from the command-line `argv'."
  (let ((opt (member optname argv :test #'equal)))
    (or (and (cdr opt) (second opt)) default)))

(defun get-command-line-option-number (argv optname &optional default)
  "Return the option designated by `optname' from the command-line `argv' as a number."
  (let ((opt (get-command-line-option argv optname)))
    (if opt
        (let ((value (with-input-from-string (in opt)
                       (read in))))
          (assert (numberp value))
          value)
        default)))

(defun pathname-path (path)
  (with-output-to-string (s)
    (format s "~{~a/~}~a~@[.~a~]" (cdr (pathname-directory path))
            (pathname-name path) (pathname-type path))))

(defgeneric name (obj)
  (:documentation "Return the name of an object."))
(defgeneric id (obj)
  (:documentation "Return the id of an object."))
(defgeneric size (obj)
  (:documentation "Return the size of an object."))
(defgeneric raw-data (obj)
  (:documentation "Return the raw data contained in an object."))