;; -*-theme-d-*-

;; Copyright (C) 2015  Tommi Höynälänmaa

(define-body (standard-library hash-table)

  (import (standard-library list-utilities))
  
  (define make-raw-hash-table
    (prim-proc make-hash-table () <raw-hash-table> pure))

  (define make-raw-hash-table-with-size
    (prim-proc make-hash-table-with-size (<integer>) <raw-hash-table> pure))

  (define-param-proc make-hash-table (%key %value)
		     (((proc-hash (:hash-proc %key))
		       (proc-assoc (:assoc-proc %key %value)))
		      (:hash-table %key %value)
		      pure)
    (make (:hash-table %key %value)
	  (make-raw-hash-table) proc-hash proc-assoc))

  (define-param-proc make-hash-table-with-size (%key %value)
		     (((proc-hash (:hash-proc %key))
		       (proc-assoc (:assoc-proc %key %value))
		       (i-size <integer>))
		      (:hash-table %key %value)
		      pure)
    (make (:hash-table %key %value)
	  (make-raw-hash-table-with-size i-size)
	  proc-hash proc-assoc))

  (define-param-proc make-object-hash-table (%value)
		     (() (:object-hash-table %value) pure)
    (make-hash-table object-hash
		     (param-proc-instance assoc-objects1 <object> %value)))

  (define-param-proc make-object-hash-table-with-size (%value)
		     (((i-size <integer>)) (:object-hash-table %value) pure)
    (make-hash-table-with-size
     object-hash
     (param-proc-instance assoc-objects1 <object> %value)
     i-size))

  (define-param-proc make-string-hash-table (%value)
		     (() (:string-hash-table %value) pure)
    (make-hash-table string-hash
		     (param-proc-instance assoc-contents1 <string> %value)))

  (define-param-proc make-string-hash-table-with-size (%value)
		     (((i-size <integer>)) (:string-hash-table %value) pure)
    (make-hash-table-with-size
     string-hash
     (param-proc-instance assoc-contents1 <string> %value)
     i-size))

  (define-param-proc make-symbol-hash-table (%value)
		     (() (:symbol-hash-table %value) pure)
    (make-hash-table
     (static-cast (:hash-proc <symbol>) hashq)
     (param-proc-instance assoc-values1 <symbol> %value)))

  (define-param-proc make-symbol-hash-table-with-size (%value)
		     (((i-size <integer>)) (:symbol-hash-table %value) pure)
    (make-hash-table-with-size
     (static-cast (:hash-proc <symbol>) hashq)
     (param-proc-instance assoc-values1 <symbol> %value)
     i-size))

  (define-param-proc-alt hashx-ref (%key %value %default)
    (unchecked-prim-proc
     theme-hashx-ref
     ((:hash-proc %key) (:assoc-proc %key %value) <raw-hash-table>
      %key %default)
     (:union %value %default)
     pure))

  (define-param-proc-alt hashx-exists? (%key %value)
    (unchecked-prim-proc
     theme-hashx-exists?
     ((:hash-proc %key) (:assoc-proc %key %value) <raw-hash-table>
      %key)
     <boolean>
     pure))

  (define-param-proc-alt hashx-set! (%key %value)
    (prim-proc theme-hashx-set!
	       ((:hash-proc %key) (:assoc-proc %key %value) <raw-hash-table>
		%key %value)
	       <none> nonpure))

  (define-param-proc-alt hashx-remove! (%key %value)
    (prim-proc theme-hashx-remove!
	       ((:hash-proc %key) (:assoc-proc %key %value) <raw-hash-table>
		%key)
	       <none> nonpure))

  (define-param-proc hash-ref (%key %value %default)
		     (((ht (:hash-table %key %value)) (o-key %key)
		       (o-default %default))
		      (:union %value %default) pure)
    (hashx-ref
     (field-ref ht 'proc-hash)
     (field-ref ht 'proc-assoc)
     (field-ref ht 'rawht)
     o-key
     o-default))

  (define-param-proc hash-exists? (%key %value)
		     (((ht (:hash-table %key %value)) (o-key %key))
		      <boolean> pure)
    (hashx-exists?
     (field-ref ht 'proc-hash)
     (field-ref ht 'proc-assoc)
     (field-ref ht 'rawht)
     o-key))

  (define-param-proc hash-set! (%key %value)
		     (((ht (:hash-table %key %value))
		       (o-key %key)
		       (o-value %value))
		      <none> nonpure)
    (hashx-set!
     (field-ref ht 'proc-hash)
     (field-ref ht 'proc-assoc)
     (field-ref ht 'rawht)
     o-key
     o-value))

  (define-param-proc hash-remove! (%key %value)
		     (((ht (:hash-table %key %value)) (o-key %key))
		      <none> nonpure)
    (hashx-remove!
     (field-ref ht 'proc-hash)
     (field-ref ht 'proc-assoc)
     (field-ref ht 'rawht)
     o-key))

  (define _hash-count-elements
    (prim-proc hash-count-elements (<raw-hash-table>) <integer> pure))

  (define _hash-clear!
    (unchecked-prim-proc hash-clear! (<raw-hash-table>) <none> nonpure))
  
  (define-param-proc hash-count-elements (%key %value)
		     (((ht (:hash-table %key %value)))
		      <integer> pure)
    (_hash-count-elements (field-ref ht 'rawht)))

  (define hashq
    (unchecked-prim-proc hashq (<object> <integer>) <integer> pure))
    
  (define hashv
    (unchecked-prim-proc hashv (<object> <integer>) <integer> pure))

  (define hash-contents
    (unchecked-prim-proc hash (<object> <integer>) <integer> pure))

  (define object-hash
    (unchecked-prim-proc hashv (<object> <integer>) <integer> pure))

  (define string-hash
    (unchecked-prim-proc string-hash (<string> <integer>) <integer> pure))

  (define-param-proc assoc1
      (%type1 %type2)
      (((key %type1)
	(lst (:alist %type1 %type2)))
       (:union (:pair %type1 %type2) <boolean>)
       pure)
    (assoc key lst #f))

  (define-param-proc assoc-values1
      (%type1 %type2)
      (((key %type1)
	(lst (:alist %type1 %type2)))
       (:union (:pair %type1 %type2) <boolean>)
       pure)
    (assoc-values key lst #f))
  
  (define-param-proc assoc-objects1
      (%type1 %type2)
      (((key %type1)
	(lst (:alist %type1 %type2)))
       (:union (:pair %type1 %type2) <boolean>)
       pure)
    (assoc-objects key lst #f))

  (define-param-proc assoc-contents1
      (%type1 %type2)
      (((key %type1)
	(lst (:alist %type1 %type2)))
       (:union (:pair %type1 %type2) <boolean>)
       pure)
    (assoc-contents key lst #f))

  (define-param-proc-alt hash-for-each-x (%key %value)
    (prim-proc
     theme-hash-for-each
     ((:procedure (%key %value) <none> nonpure)
      <raw-hash-table>)
     <none>
     nonpure))

  (define-param-proc hash-for-each (%key %value)
		     (((pc (:procedure (%key %value) <none> nonpure))
		       (ht (:hash-table %key %value)))
		      <none>
		      nonpure)
    (hash-for-each-x pc (field-ref ht 'rawht)))

  (define-param-proc hash-clear! (%key %value)
		     (((ht (:hash-table %key %value))) <none> nonpure)
    (_hash-clear! (field-ref ht 'rawht))))
