;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2018 David Mullen. All Rights Reserved. Origin: <https://cl-pdx.com/kira/>

(in-package :kira)

(defmacro eval-always (&body body)
  "eval-when (:compile-toplevel :load-toplevel :execute)"
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     ,@body))

(defun macro-eval (form &optional env)
  (prog ((expansion form) expanded-p)
   macro-eval-1
    (when (self-evaluating-p expansion)
      (return (values expansion t)))
    (when (quoted-form-p expansion)
      (return (values (cadr expansion) t)))
    (multiple-value-setq (expansion expanded-p)
      (macroexpand-1 expansion env))
    (when expanded-p (go macro-eval-1))
    (let ((value-available-p (and (symbolp expansion) (constantp expansion) (boundp expansion))))
      (return-from macro-eval (if value-available-p (values (symbol-value expansion) t) form)))))

(eval-always
  (defmacro with-gensyms (variables &body body)
    (loop for var in variables as name = (string var)
          collect `(,var (gensym ',name)) into bindings
          finally (return `(let ,bindings ,@body)))))

(eval-always
  (defmacro rebinding (variables &body body)
    (loop for var in variables as name = (symbol-name var) as temp = (gensym name)
          collect ``(,',temp ,,var) into temps collect `(,var ',temp) into renames
          finally (return ``(let (,,.temps) ,(let (,.renames) ,@body))))))

(eval-always
  (defmacro whereas (bindings &body body)
    (flet ((make-single-level (var val x) `(let ((,var ,val)) (when ,var ,x))))
      (let ((function #'(lambda (a b) (make-single-level (car a) (cadr a) b))))
        (reduce function bindings :from-end t :initial-value `(locally ,@body))))))

(defun ensure-list (thing)
  (unless (eq thing nil)
    (if (atom thing)
        (list thing)
        thing)))

(defun sans (plist &rest keys &aux (sans '()))
  "Return PLIST with the given properties removed non-destructively."
  (loop (let ((tail (nth-value 2 (get-properties plist keys))))
          (cond ((null tail) (return (nreconc sans plist)))
                (t (loop until (eq plist tail)
                         do (push (pop plist) sans)
                            (push (pop plist) sans)
                         ;; Skip matching key and value.
                         finally (setq plist (cddr plist))))))))

(eval-always
  (defun get-removal-macro-expansion (item place options environment function-name)
    (multiple-value-bind (temps vals news writer reader) (get-setf-expansion place environment)
      (let ((modification-form `(,function-name ,item ,reader ,@options)) (new (car news)))
        (unless (endp (cdr news)) (error "Multiple values aren't supported."))
        `(let* (,.(mapcar #'list temps vals) (,new ,modification-form))
           ,writer)))))

(defmacro deletef (item place &rest options &environment environment)
  (get-removal-macro-expansion item place options environment 'delete))

(defmacro removef (item place &rest options &environment environment)
  (get-removal-macro-expansion item place options environment 'remove))

(eval-always
  (define-modify-macro coercef (&rest args) coerce)
  (define-modify-macro reversef (&rest args) reverse)
  (define-modify-macro nreversef (&rest args) nreverse)
  (define-modify-macro appendf (&rest args) append)
  (define-modify-macro nconcf (&rest args) nconc)
  (define-modify-macro butlastf (&rest args) butlast)
  (define-modify-macro nbutlastf (&rest args) nbutlast)
  (define-modify-macro logiorf (&rest args) logior)
  (define-modify-macro logxorf (&rest args) logxor)
  (define-modify-macro sortf (&rest args) sort)
  (define-modify-macro sansf (&rest args) sans)
  (define-modify-macro absf (&rest args) abs)
  (define-modify-macro maxf (&rest args) max)
  (define-modify-macro minf (&rest args) min)
  (define-modify-macro ashf (&rest args) ash))

(defmacro orf (place &rest forms &environment environment)
  (multiple-value-bind (temps vals news writer reader) (get-setf-expansion place environment)
    (unless (endp (cdr news)) (error "Multiple values aren't supported by the ~S macro." 'orf))
    (let* ((new (car news)) (new-form `(or ,@forms)) (set-form `(let ((,new ,new-form)) ,writer)))
      `(let* (,.(mapcar #'list temps vals)) (or ,reader ,set-form)))))

(defmacro %find-collection-context (name)
  (error "Can't collect into: ~S." name))

(defmacro collecting (lists &body body &environment environment)
  (let* ((list (if lists (car lists) (gensym (string 'anonymous-list))))
         (list-name (when lists (pop lists))) ; NIL => anonymous.
         (context `(,list ,(gensym (string 'tail)))))
    (unless list-name (setq body `(,@body ,list)))
    `(macrolet ((%find-collection-context (name)
                  (when (eq name ',list-name) ; Return our context.
                    (return-from %find-collection-context ',context))
                  ;; Grovel through the parent environment for another context.
                  (macroexpand-1 `(%find-collection-context ,name) ',environment)))
       ;; Recursively enact a COLLECTING environment for the LISTS.
       (let ,context ,@(if lists `((collecting ,lists ,@body)) body)))))

(defmacro collect (new-element &key into &environment environment)
  (destructuring-bind (list tail) (macroexpand-1 `(%find-collection-context ,into) environment)
    `(setq ,tail (if ,tail (setf (cdr ,tail) (list ,new-element)) (setq ,list (list ,new-element))))))

(eval-always
  (defun parse-binding (binding &optional default-form)
    (cond ((null binding) (values nil default-form))
          ((symbolp binding) (values binding default-form))
          ((cdr binding) (values (car binding) (cadr binding)))
          (t (values (car binding) default-form)))))

(deftype array-index ()
  `(integer 0 ,array-total-size-limit))

(defun check-vector-bounds (array start end &aux (rank (array-rank array)))
  (let ((length (if (= (the array-rank rank) 1) (length array) (array-total-size array))))
    (prog1 (prog1 (orf end length) (check-type start array-index) (check-type end array-index))
      (locally (declare (type array-index start end))
        (when (or (minusp start) (> start end) (> end (the array-index length)))
          (error "Invalid bounding indexes for ~S: ~D, ~D." array start end))))))

(defmacro with-array-data (((vector array) . optional-bindings) &body body)
  (destructuring-bind (&optional start-binding end-binding) optional-bindings
    (multiple-value-bind (body declarations) (parse-body body nil nil)
      (multiple-value-bind (start start-value) (parse-binding start-binding)
        (multiple-value-bind (end end-value) (parse-binding end-binding)
          (rebinding (array)
            (with-gensyms (offset)
              (let* ((optimize-settings '(declare (optimize (safety 0) (speed 3))))
                     (offset-specs `((type array-index ,offset) (ignorable ,offset)))
                     (bounds-check-form `(check-vector-bounds ,array ,start ,end))
                     (bounding-indexes (delete nil (list start end)))
                     (type-declaration `(declare (type array-index ,.bounding-indexes)))
                     (declarations `(,@declarations ,optimize-settings ,type-declaration))
                     (new-body `(,(if end `(setq ,end ,bounds-check-form) bounds-check-form))))
                (dolist (bx bounding-indexes) (push `(setq ,bx (+ ,bx ,offset)) body))
                (setq new-body (append new-body (list `(locally ,.declarations ,@body))))
                `(multiple-value-bind (,vector ,offset) (array-data-and-offset ,array)
                   (declare (type (simple-array * (*)) ,vector)) (declare ,@offset-specs)
                   (let* (,@(if start `((,start ,start-value))) ,@(if end `((,end ,end-value))))
                     ,@new-body))))))))))

(defun make-buffer (&optional (size 512) (element-type '(unsigned-byte 8)))
  (make-array size :fill-pointer 0 :adjustable t :element-type element-type))

(defun reset-buffer (buffer)
  "Zero fill-pointer and return BUFFER."
  (setf (fill-pointer buffer) 0) buffer)

(defun make-temporary-name (&aux (time (get-universal-time)) (random-part (random most-positive-fixnum)))
  (make-pathname :name (format nil "Kira-~36R~36R" time random-part) :type "tmp" :defaults #p"kira:data;"))

(defun open-temporary-file (&rest options)
  (appendf options '(:if-exists nil :direction :output))
  (loop thereis (let ((pathname (make-temporary-name)))
                  (apply #'open pathname options))))

(defmacro with-temporary-file ((stream . options) &body body)
  `(with-open-stream (,stream (open-temporary-file ,@options))
     ,@body))

(defun typed-pathname (pathname)
  (symbol-macrolet ((default (load-time-value (make-pathname :type :unspecific))))
    (if (pathname-type pathname) pathname (merge-pathnames pathname default))))

(defun open-log (pathname &rest options)
  (appendf options '(:if-exists :append :if-does-not-exist :create))
  (appendf options '(:direction :output :external-format :utf-8))
  (apply #'open pathname options))

(defmacro with-open-log ((stream pathname &rest options) &body body)
  `(with-open-stream (,stream (open-log ,pathname ,@options)) ,@body))

(defun type-equal (type1 type2)
  (and (subtypep type1 type2)
       (subtypep type2 type1)))

(defstaticvar *mmap-alist* '()
  "Alist of mapping -> truename.")

(defun mmap (pathname element-type &aux vector (truename (truename pathname)))
  (let ((upgraded-element-type (upgraded-array-element-type element-type)))
    (loop for mapping in *mmap-alist* when (equal (cdr mapping) truename)
          do (unless (type-equal (array-element-type (car mapping)) upgraded-element-type)
               (error "Existing vector ~S is incompatible with ~S." (car mapping) element-type))
             (return (setq vector (car mapping)))
          ;; No existing vector is available.
          finally (setq vector (map-file-to-ivector truename upgraded-element-type))
                  (return-from mmap (caar (push (cons vector truename) *mmap-alist*))))
    ;; MAP-FILE-TO-IVECTOR will make a new vector, but
    ;; we'll adjust the existing vector to be equivalent.
    (unmap-ivector vector)
    (let* ((new-displaced-vector
            (map-file-to-ivector truename upgraded-element-type))
           (size (array-total-size new-displaced-vector)))
      (declare (type array-index size) (type (vector unsigned-byte) new-displaced-vector))
      (multiple-value-bind (data offset) (array-displacement new-displaced-vector)
        (adjust-array vector size :displaced-to data :displaced-index-offset offset)))))

(defun munmap (vector &aux (mapping (assoc vector *mmap-alist*)))
  (unless mapping (error "Not mapped with ~S: ~S." 'mmap vector))
  (prog1 (unmap-ivector vector) (deletef mapping *mmap-alist*)))

(defun get-mmap-displaced-vector (vector &optional (start 0) end)
  (with-array-data ((underlying-data vector) (start start) (end end))
    (loop with resulting-vector-size of-type array-index = (- end start)
          with offset of-type array-index = 0 and data as (ivector) in *mmap-alist*
          do (multiple-value-setq (data offset) (array-data-and-offset ivector))
          when (eq data underlying-data)
          return (let ((displaced-index-offset (- start offset)))
                   (declare (type array-index displaced-index-offset))
                   (make-array resulting-vector-size :displaced-to ivector
                               :displaced-index-offset displaced-index-offset)))))

(defmacro fail-safe (attempt &rest failure-forms)
  (let* ((ok (gensym "OK")) (protected-form `(progn ,attempt (setq ,ok t))))
    `(let (,ok) (unwind-protect ,protected-form (unless ,ok ,@failure-forms)))))

(defstatic +content-external-format+
  '(:character-encoding :utf-8
    :line-termination :crlf))

(defun file-string (pathname &key (external-format +content-external-format+))
  (with-open-file (stream pathname :external-format external-format)
    (loop with buffer = (make-buffer (file-length stream) 'character)
          for start of-type array-index = (fill-pointer buffer)
          do (setf (fill-pointer buffer) (array-total-size buffer))
             (let ((end (read-sequence buffer stream :start start)))
               (setf (fill-pointer buffer) (the array-index end)))
             (unless (listen stream) (return-from file-string buffer))
             (when (= (fill-pointer buffer) (array-total-size buffer))
               (adjust-array buffer (ceiling (length buffer) 4/5))))))

(defmacro with-heap-ivector ((vector macptr size element-type) &body body)
  `(multiple-value-bind (,vector ,macptr) (make-heap-ivector ,size ,element-type)
     (unwind-protect (progn ,@body) (dispose-heap-ivector ,vector))))

(defun files-equal (pathname1 pathname2)
  "Return true if both files exist, and they have identical contents."
  (symbol-macrolet ((element-type '(unsigned-byte 8)) (buffer-size 8192))
    (let ((size1 (file-data-size pathname1)) (size2 (file-data-size pathname2)))
      (unless (and size1 size2 (eql size1 size2)) (return-from files-equal nil)))
    (with-open-file (stream1 pathname1 :direction :input :element-type element-type)
      (with-open-file (stream2 pathname2 :direction :input :element-type element-type)
        (with-heap-ivector (buffer1 buffer-memory-1 buffer-size element-type)
          (with-heap-ivector (buffer2 buffer-memory-2 buffer-size element-type)
            (loop for position1 of-type fixnum = (read-sequence buffer1 stream1)
                  for position2 of-type fixnum = (read-sequence buffer2 stream2)
                  until (= position1 position2 0)
                  always (and (= position1 position2)
                              (zerop (#_memcmp buffer-memory-1
                                               buffer-memory-2
                                               position1))))))))))