(in-package #:safer-lisp)

(defvar *safer-packages* (make-hash-table :test #'equalp)
  "A hashtable of safer-package objects.")

(defclass safer-package ()
  ((%cl-package :reader %cl-package
                :initarg :cl-package)
   (%use-list :accessor %safer-package-use-list
              :initform nil)
   (%use-safely-list :accessor %safer-package-use-safely-list
                     :initform nil)
   (%export-list :accessor %safer-package-export-list
                 :initform nil)))

(define-condition safer-package-error (safer-lisp-error) ())

(defun %defpackage-compare (a b)
  "Compares symbols to sort them in the defpackage evaluation order.  Also
accounts for safe-package options.
:shadow :shadowing-import-from | :safely-shadow :safe-shadowing-import-from
:use                           | :safely-use
:import-from :intern           | :safely-import-from :safely-intern
:export                        | :safely-export
"
  (let ((order '((:shadow :shadowing-import-from
                   :safely-shadow :safe-shadowing-import-from)
                 (:use :safely-use)
                 (:import-from :intern
                  :safely-import-from :safely-intern)
                 (:export :safely-export))))
    (flet ((within (sym) (lambda (list) (member sym list))))
      (< (position-if (within a) order)
         (position-if (within b) order)))))

(defun %find-symbols (source-package symbol-names)
  (let ((source-package (find-package source-package)))
    (mapcar (lambda (s) (find-symbol (string s) source-package)) symbol-names)))
(defun %shadowing-import-from (source-package symbol-names &optional (dest-package *package*))
  (shadowing-import (%find-symbols source-package symbol-names)
                    dest-package))
(defun %import-from (source-package symbol-names &optional (dest-package *package*))
  (import (%find-symbols source-package symbol-names)
          dest-package))
(defun %export (symbol-names &optional (package *package*))
  (let ((package (find-package package)))
    (export (mapcar (lambda (s) (intern (string s) package)) symbol-names) package)))
(defun %intern (symbol-names &optional (package *package*))
  (let ((package (find-package package)))
    (mapcar (lambda (s) (intern s package)) symbol-names)))

(defmacro define-safer-package (package &rest options)
  "Creates a CL package for use with safer-lisp.  Exactly like defpackage,
except supports additional :safely-* options which mark symbols as being safe.

For example,
    (define-safer-package #:my-safe-package
      (:use #:common-lisp)
      (:safely-export #:beef #:ham))
  defines a CL package MY-SAFE-PACKAGE which uses--by the standard CL definition
  of 'use'--the COMMON-LISP package, and exports the symbols BEEF and HAM for use
  in so-called 'safer lisp' programs, while
    (define-safer-package #:another-safe-package
      (:safely-use #:my-safe-package)
      (:safely-export #:sausage))
  defines a CL package ANOTHER-SAFE-PACKAGE which safely uses--that is, uses
  within the safer-lisp environment--the my-safe-package package, and exports for
  safe usage an additional symbol SAUSAGE.  (That is, BEEF, HAM, and SAUSAGE are
  all available unqualified when within safer-lisp and *safe-package* is set to
  ANOTHER-SAFE-PACKAGE.

  Note specially :use does NOT import symbols for safe use, so you can freely use
  unsafe packages to write safe functions.  (e.g., you can (:use :cl) without fear
  of making #'delete-file available to restricted code).
"
  (with-unique-names (safer-package cl-package)
    `(eval-when (:compile-toplevel :load-toplevel :execute)
      (let* ((,safer-package (make-safer-package ',package))
             (,cl-package (%cl-package ,safer-package)))
        ;; the following is macrolet instead of flet so we can handle quoting
        ;; FIXME: add safely-* options
        (macrolet
            ((:use (&rest packages)
               `(use-package ',packages ,',cl-package))
             (:safely-use (&rest packages)
               `(safer-use-package ',packages ,',safer-package))
             (:shadow (&rest symbol-names)
               `(shadow ',symbol-names ,',cl-package))
             (:shadowing-import-from (package-name &rest symbol-names)
               `(%shadowing-import-from ',package-name ',symbol-names ,',cl-package))
             (:import-from (package-name &rest symbol-names)
               `(%import-from ',package-name ',symbol-names ,',cl-package))
             (:safely-import-from (package-name &rest symbol-names)
               `(safer-import-from ',package-name ',symbol-names ,',cl-package))
             (:export (&rest symbol-names)
               `(%export ',symbol-names ,',cl-package))
             (:safely-export (&rest symbol-names)
               `(safer-export ',symbol-names ,',safer-package))
             (:intern (&rest symbol-names)
               `(%intern ',symbol-names ,',cl-package)))
          ,@(sort options #'%defpackage-compare :key #'car))
        ,safer-package))))

(defun make-safer-package (package-name &key nicknames use)
  "Analagous to cl:make-package, with one exception: the :use argument is
guaranteed to default to nil."
  (let ((package-name (or (ignore-errors
                            (package-name package-name))
                          (string package-name)))
        (package
         (make-instance 'safer-package
                        :cl-package (or (find-package package-name)
                                        (make-package package-name
                                                      :nicknames nicknames
                                                      :use use)))))
    (setf (gethash package-name *safer-packages*) package)
    package))

(defun find-safer-package (package-name)
  "CL's find-package, but for safer-packages."
  (cond
    ((subtypep (class-of package-name) 'safer-lisp:safer-package)
     package-name)
    ((or (packagep package-name)
         (and (stringp package-name)
              (find-package package-name)))
     (gethash (package-name package-name) *safer-packages*))
    (t
     (gethash (string package-name) *safer-packages*))))

(defmacro %with-safer-package ((package package-name) &body body)
  `(let ((,package (or (find-safer-package ,package-name)
                       (error 'safer-package-error
                              :format-control "Package name ~a does not designate a safer-package."
                              :format-arguments (list ,package-name)))))
    ,@body))
(defmacro %ensure-safer-package ((package package-name) &body body)
  `(let ((,package (or (find-safer-package ,package-name)
                       (make-safer-package ,package-name))))
    ,@body))

(defun safer-use-package (package-names package)
  (%with-safer-package (package package)
    (dolist (package-name package-names)
      (pushnew (find-safer-package package-name) (%safer-package-use-list package)))))

(defun safer-import-from (source-package symbol-names package)
  (%ensure-safer-package (source-package source-package)
    (%with-safer-package (package package)
      (let ((symbols (%find-symbols (%cl-package source-package) symbol-names)))
        (import symbols (%cl-package package))))
    (safer-export symbol-names source-package)))

(defun safer-export (symbol-names package)
  (%with-safer-package (package package)
    (dolist (symbol-name symbol-names)
      (let* ((cl-package (%cl-package package))
             (symbol (intern (string symbol-name) cl-package)))
        (pushnew symbol (%safer-package-export-list package))
        (export symbol cl-package)))))

(defun safer-find-symbol (string &optional (package *package*))
  "cl:find-symbol for safer-packages.  safe symbols will have a status of :safe."
  (%with-safer-package (package package)
    (multiple-value-bind (symbol status)
        (find-symbol string (%cl-package package))
      (cond
        ((and status
              (member symbol (%safer-package-export-list package) :test #'eq))
         (values symbol :safe))
        (status
         (values symbol status))
        (t
         (values nil nil))))))

(defun %symbol-is-safe-p (symbol)
  (handler-case
      (multiple-value-bind (symbol status)
          (safer-find-symbol (symbol-name symbol) (symbol-package symbol))
        (declare (ignore symbol))
        (eq status :safe))
    (safer-package-error () nil)))

(defun add-safe-keywords (&rest keywords)
  (let ((package (or (find-safer-package :keyword)
                     (make-safer-package :keyword))))
    (safer-export keywords package)))