;;; This defines all core symbols.

;;; Core symbols are stored in global variables.  The core-symbol
;;; macro just turns a string into a variable name.

(define-syntax (core-symbol str)
  (make-core-symbol-name str))

(define (make-core-symbol-name str)
  (string->symbol (string-append "*core-" str "*")))

(define (symbol->core-var name)
  (make-core-symbol-name (symbol->string name)))

(define (get-core-var-names vars type)
  (let ((res (assq type vars)))
    (if (eq? res '#f)
	'()
	(map (function string->symbol) (tuple-2-2 res)))))

;;; This is just used to create a define for each var without a
;;; value.

(define-syntax (define-core-variables)
  `(begin
     ,@(define-core-variables-1 *haskell-prelude-vars*)
     ,@(define-core-variables-1 *haskell-noncore-vars*)))

(define (define-core-variables-1 vars)
  (concat (map (lambda (ty)
		 (map (function init-core-symbol)
		      (get-core-var-names vars ty)))
	       '(classes methods types constructors synonyms values))))

(define (init-core-symbol sym)
  `(define ,(symbol->core-var sym) '()))

(define-syntax (create-core-globals)
  `(begin
     (begin ,@(create-core-defs *haskell-prelude-vars* '#t))
     (begin ,@(create-core-defs *haskell-noncore-vars* '#f))))

(define (create-core-defs defs prelude-core?)
  `(,@(map (lambda (x) (define-core-value x prelude-core?))
	   (get-core-var-names defs 'values))
     ,@(map (lambda (x) (define-core-method x prelude-core?))
	   (get-core-var-names defs 'methods))
     ,@(map (lambda (x) (define-core-synonym x prelude-core?))
	   (get-core-var-names defs 'synonyms))
     ,@(map (lambda (x) (define-core-class x prelude-core?))
	   (get-core-var-names defs 'classes))
     ,@(map (lambda (x) (define-core-type x prelude-core?))
	    (get-core-var-names defs 'types))
     ,@(map (lambda (x) (define-core-constr x prelude-core?))
	    (get-core-var-names defs 'constructors))))


(define (define-core-value name pc?)
    `(setf ,(symbol->core-var name)
	   (make-core-value-definition ',name ',pc?)))

(define (make-core-value-definition name pc?)
  (install-core-sym
    (make var (name name) (module '|*Core|) (unit '|*Core|))
    name
    pc?))

(define (define-core-method name pc?)
    `(setf ,(symbol->core-var name)
	   (make-core-method-definition ',name ',pc?)))

(define (make-core-method-definition name pc?)
  (install-core-sym
    (make method-var (name name) (module '|*Core|) (unit '|*Core|))
    name
    pc?))

(define (define-core-class name pc?)
    `(setf ,(symbol->core-var name)
	   (make-core-class-definition ',name ',pc?)))

(define (make-core-class-definition name pc?)
  (install-core-sym
    (make class (name name) (module '|*Core|) (unit '|*Core|))
    name
    pc?))

(define (define-core-synonym name pc?)
    `(setf ,(symbol->core-var name)
	   (make-core-synonym-definition ',name ',pc?)))

(define (make-core-synonym-definition name pc?)
  (install-core-sym
    (make synonym (name name) (module '|*Core|) (unit '|*Core|))
    name
    pc?))

(define (define-core-type name pc?)
    `(setf ,(symbol->core-var name)
	   (make-core-type-definition ',name ',pc?)))

(define (make-core-type-definition name pc?)
  (install-core-sym
    (make algdata (name name) (module '|*Core|) (unit '|*Core|))
    name
    pc?))

(define (define-core-constr name pc?)
    `(setf ,(symbol->core-var name)
	   (make-core-constr-definition ',name ',pc?)))

(define (make-core-constr-definition name pc?)
  (setf name (add-con-prefix/symbol name))
  (install-core-sym
    (make con (name name) (module '|*Core|) (unit '|*Core|))
    name
    pc?))

(define (install-core-sym def name preludecore?)
  (setf (def-core? def) '#t)
  (when preludecore? 
    (setf (def-prelude? def) '#t))
  (setf (table-entry (dynamic *core-symbols*) name) def)
  (when preludecore?
    (setf (table-entry (dynamic *prelude-core-symbols*) name) def))
  def)