;; Copyright (c) 2001 -- 2006
;;;   Ben Waldron, John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen;
;;;   see `LICENSE' for conditions.

(in-package :lkb)

(defmacro with-dropped-lex-key-indices ((lex) &body body)
  `(progn
     (drop-lex-key-indices ,lex)
     ,@body
     (create-lex-key-indices ,lex)))

;(defmethod close-lex ((lex psql-lex-database) &key in-isolation delete)
;  (declare (ignore in-isolation delete))
;  (with-slots (semi dbname host user connection) lex
;    (if (next-method-p) (call-next-method))))


;; close lex if nec
;; set name
;; connect (why is this not in open for psql-database?
(defmethod open-lex ((lex psql-lex-database) &key name parameters)
  (declare (ignore parameters)) 
  (with-slots (dbname host user connection) lex
    (close-lex lex)    ;; is this necessary?
    (force-output) ;; move to close-lex?
    (setf (name lex) name) ;; set lex name to lexdb name
    (cond
     ((connect lex)
      (setf (name lex) (format nil "LexDB:~a" dbname)))
     (t
      (format t "~&unable to open connection to lexical database ~a(~a)@~a:~a (~a)" 
	      dbname user host (true-port lex)
	      (error-msg connection))))))

;; check that server version + lexdb version are acceptable
;; unless user is lexdb owner... (should use sepratae mechanism!)
;; let user know we have connection
;; check everything is up to date
(defmethod open-lex :after ((lex mu-psql-lex-database) &key name parameters)
  (declare (ignore name parameters))
  (with-slots (dbname user host) lex
    (when (connection lex)
      (check-psql-server-version lex)
      (check-lexdb-version lex)
      ;; if not db owner, check user schema is up-to-date
      (unless
	  (sql-get-bool lex "SELECT user_is_db_owner_p()")
	(format t "~&(LexDB) connection opened to ~a LexDB ~a@~a:~a (database user ~a)" 
		(string-downcase (string (psql-lex-database-type lex)))
		dbname host (true-port lex) user)
	(get-fields lex) ;; initialize on request?
	(get-dfn lex) ;; initialize on request?
	(new-user-schema-if-nec lex) ;; create private space if nec
	(build-lex-if-nec lex) ;; update lexicon if necessary
	(let ((size (count-lex lex)) ;; size of lexicon -> property?
	      (rev-size (count-rev-all lex))) ;; size of repos -> property?
	  
	  (format t "~&(LexDB) total revision entries available: ~a" rev-size)
	  ;; warn user if repos empty
	  (when (= 0 rev-size)
	    (format t " !!! PLEASE LOAD REV ENTRIES !!!")
	    (lkb-beep))
	  
	  (format t "~&(LexDB) active entries in lexicon: ~a" size)
	  ;; warn user if lexicon empty
	  (when (= 0 size)
	    (format t " !!! PLEASE SET FILTER !!!")
	    (lkb-beep))
	  (format t "~&(LexDB) filter: ~a " (filter lex))
	  ;; warn user if filter unset
	  (when (string= "NULL" (string-upcase (filter lex)))
	    (format t "!!! PLEASE SET FILTER !!!")
	    (lkb-beep))))
      (empty-cache lex)))) ;; build-lex-if-nec / close-lex should take care of this

;; let user knwo we have connection
(defmethod open-lex :after ((lex su-psql-lex-database) &key name parameters)
  (declare (ignore name parameters))
  (when (connection lex)
    (with-slots (dbname user host) lex
      (format t "~&(LexDB) connected to ~a LexDB ~a@~a:~a (database user ~a)" 
	      (string-downcase (string (psql-lex-database-type lex)))
	      dbname host (true-port lex) user))
    (get-fields lex) ;; -> cached property?
    (get-dfn lex) ;; -> cached property?
    (let ((size (count-lex lex))) ;; -> property?
      (format t "~&(LexDB) total 'lex' entries available: ~a" size)
      ;; warn user if lexicon empty
      (when (= 0 size)
	(format t " !!! PLEASE LOAD LEX ENTRIES !!!")
	(lkb-beep)))
    (empty-cache lex))) ;; close-lex should take care of this

;;
;;

;; field names in dfn table
(defmethod grammar-fields ((lex psql-lex-database)) ;; -> cached property!
  (unless (dfn lex)
    (complain-no-dfn lex)
    (error "operation aborted"))
  (let ((g-fields
	 (remove-duplicates 
	  (mapcar #'second (dfn lex)))))
    (when (member :|_tdl| (fields lex)) ;; should go in DFN if used?
      (pushnew :|_tdl| g-fields))
    g-fields))

;; WORD -> IDS

;; cache in lexical-entries
(defmethod lookup-word ((lex psql-lex-database) orth &key (cache *lexicon-lexical-entries-cache-p*)) ;; remove/rename global flag?
  ;; CASE no cache
  (unless cache
    (return-from lookup-word 
      (lookup-word-no-cache lex orth)))
  ;; CASE cache
  (with-slots (lexical-entries) lex ;; lexical entries stores cached entries
    (let* ((cached-raw (gethash orth lexical-entries))
	   (cached (if (eq cached-raw :EMPTY) nil cached-raw))
	   (value (if (not cached) (lookup-word-no-cache lex orth))))
      (cond
       (cached cached)
       (t
	;; update cache, and return value
	(setf (gethash orth lexical-entries) 
	  (or value :EMPTY))
	value)))))

;; orthkey must be mapped to normalized form before entering PSQL universe
(defmethod lookup-word-no-cache ((lex psql-lex-database) orth)
  ;(if (connection lex)
  (let* ((key (normalize-orthkey orth))
	 (fields (fields-str lex (grammar-fields lex))) ;;-> cached property?
	 ;; retrieve all grammar fields for matching entries!
	 (table (get-records lex (lookup-word-no-cache-SQL lex key fields)))
	 ;; return simply the ids (but cache the rest)
	 (ids (cache-records-and-return-ids lex table)))
    ids))
;)

;; ALWAYS (!) cache retrieved records (and psorts!)
;; ??? allow caching to be disabled???
(defmethod cache-records-and-return-ids ((lex psql-lex-database) table)
  (with-slots (psorts record-cache dfn) lex
    (let ((name-field (second (assoc :ID dfn)))) ;; -> cached property?
      (loop
	  with cols = (cols table)
	  for rec in (recs table)
	  for id = (str-2-symb (get-val name-field rec cols)) ;; -> get-val-symb ?
	  do
	    ;; cache record
	    (unless (gethash id record-cache)
	      (setf (gethash id record-cache) 
		rec))
	    ;; cache psort (!)
	    (unless (gethash id psorts) ;; caching of psorts is not necssary!
	      (setf (gethash id psorts) 
		(make-psort-struct lex rec cols)))
	    
	  collect id)))) ;; return ids

;(defmethod lookup-word ((lex psql-lex-database) orth &key (cache *lexicon-lexical-entries-cache-p*)) ;; remove/rename global flag?
;  (with-slots (lexical-entries) lex
;  (let ((hashed (gethash orth lexical-entries))) ;; lexical entries stores cached entries
;    (cond 
;     (hashed
;      (if (eq hashed :EMPTY) ;; :EMPTY means not in lexicon
;	  (setf hashed nil)
;	hashed))
;     (t 
;      (let ((value (lookup-word-no-cache lex orth)))
;	;;if caching, add entry to cache...
;	(when cache
;	  (setf (gethash orth lexical-entries) 
;	    (if value value :EMPTY)))
;	value))))))

;; ALL WORDS INDEXED

;; returns all KEYS (= indexed words) [UPCASED!]
(defmethod lex-words ((lex psql-lex-database))
  (loop 
      for raw-record in (get-raw-records lex "select distinct key from lex_key")
      for key = (car raw-record)
      collect (string-upcase key)))

;(defmethod lex-words ((lex psql-lex-database))
;  (mapcar #'(lambda (x) (string-upcase (car x)))
;	  (get-raw-records lex "select distinct key from lex_key")))


;; ORTH KEYS

;; write normalized keys to database
(defmethod put-normalized-lex-keys ((lex psql-lex-database) recs)
  ;; nothing to do if no recs
  (when recs
    (with-slots (connection) lex
      ;; ensure indices are dropped in table
      (with-dropped-lex-key-indices (lex)
	;; prepare to listen on STDIN
	(pq:exec connection "COPY lex_key FROM stdin")
	(loop
	    for rec in recs
		       ;; send each indivdual record
	    do 
	      (with-lexdb-locale 
		  (pq:putline connection (to-psql-copy-rec2 rec))))
	;; end of data
	(with-lexdb-locale 
	    (putline connection "\\."))
	;; stop listening on STDIN
	(endcopy connection)))))

;; retrieve contents of lex-keys
(defmethod get-unnormalized-lex-keys ((lex psql-lex-database))
  (recs
   (get-records lex "SELECT name,userid,modstamp,key FROM lex_key")))

;; NEW table LEX-KEY
(defmethod new-lex-key-table ((lex psql-lex-database))
  (empty-cache lex)
  (kill-lex-key-table lex)
  (create-lex-key-table lex)
  (create-lex-key-indices lex)
  (regenerate-orthkeys lex))

;; KILL table LEX-KEY
(defmethod kill-lex-key-table ((lex psql-lex-database))
  (with-lexdb-client-min-messages (lex "error")
    (run-command lex "DROP TABLE lex_key CASCADE" :ignore-errors t)))

;; kill all lex-key entries, then regenerate them
(defmethod regenerate-orthkeys ((lex psql-lex-database))
  (lexdb-time ("regenerating lex_key entries" "done regenerating lex_key entries")
	      (with-dropped-lex-key-indices (lex)
		(run-command lex "DELETE FROM lex_key"))
	      (generate-missing-orthkeys lex)))
  
(defmethod generate-missing-orthkeys ((lex psql-lex-database))
  (put-normalized-lex-keys 
   lex
   (normalize-orthkeys lex
			(create-unnormalized-missing-lex-keys lex))))

(defmethod normalize-orthkeys ((lex mu-psql-lex-database) recs)
  (normalize-orthkeys-ith recs 3))

(defmethod normalize-orthkeys ((lex su-psql-lex-database) recs)
  (normalize-orthkeys-ith recs 1))

(defun normalize-orthkeys-ith (recs i)
  (loop
      for rec in recs
      do (setf (nth i rec) (normalize-orthkey! (nth i rec))))
  recs)

;;; ALL IDS

(defmethod collect-psort-ids ((lex psql-lex-database) &key (cache t) (recurse t))
  (declare (ignore recurse))
  (with-slots (cache-lex-list) 
      lex
    (let ((lex-list cache-lex-list))
      (when (null cache-lex-list)
	(setf lex-list 
	  (collect-psort-ids-aux lex))
	(if (null lex-list)
	    (setf lex-list :empty))
	(if cache 
	    (setf cache-lex-list lex-list)))
      (case lex-list
	(:empty nil)
	(otherwise lex-list)))))

;; ALL AVAILABLE RECORDS

(defmethod retrieve-all-records ((lex psql-lex-database) &optional (reqd-fields '("*")))
  (cond
   ((connection lex)
    (let* ((reqd-fields (fields-str lex reqd-fields))
	  (recs (get-records lex (format nil "SELECT ~a FROM lex" reqd-fields))))
      recs))
   (t
    (format t "~&(LexDB) WARNING: no connection to psql-lex-database"))))

;; RECORD BY ID

(defmethod retrieve-raw-record ((lex psql-lex-database) id &key (cache t) (reqd-fields '("*")))
  (with-slots (record-cache) lex
    (let ((hashed (gethash id record-cache)))
      (cond (hashed
	     (unless (eq hashed :EMPTY)
	       hashed))
	    (t
	     (let* ((record (car (recs (retrieve-raw-record-no-cache lex id reqd-fields)))))
	       (when cache
		 (setf (gethash id record-cache)
		   (or record :EMPTY)))
	       record))))))

(defmethod retrieve-raw-record-no-cache ((lex psql-lex-database) id &optional (reqd-fields '("*")))
  (unless (connection lex)
    (format t "~&(LexDB) WARNING:  no connection to psql-lex-database")
    (return-from retrieve-raw-record-no-cache))
  (retrieve-entry2 lex (2-str id) :reqd-fields reqd-fields))

;; ID -> ENTRY

(defmethod read-psort ((lex psql-lex-database) id &key (cache t) (recurse t) (new-instance nil))
  (declare (ignore recurse))
  (with-slots (psorts) lex
    (let ((hashed (and (not new-instance) (gethash id psorts))))
      (cond (hashed
	     (unless (eq hashed :EMPTY) hashed))
	    (t
	     (let ((entry (read-psort-aux lex id :cache cache)))
	       (when cache
		 (setf (gethash id psorts)
		   (or entry :EMPTY)))
	       entry))))))

(defmethod read-psort-aux ((lex psql-lex-database) id &key (cache t))
  (with-slots (psorts) lex
    (let* ((cols (grammar-fields lex))
	   (raw-record 
	    (retrieve-raw-record 
	     lex id 
	     :reqd-fields cols
	     :cache cache)))
      (if raw-record 
	  (make-psort-struct lex raw-record cols)))))

(defmethod make-psort-struct ((lex psql-lex-database) raw-record cols)
  (apply #'make-lex-entry 
	 (make-strucargs2 raw-record cols 
			  :dfn (dfn lex)
			  :fields (fields lex))
			  ))

;; RECORD -> TDL

(defmethod record-to-tdl ((lex psql-lex-database) record)
  (let ((cols (mapcar #'car record))
	(rec (mapcar #'cdr record)))
    (raw-record-to-tdl lex rec cols)))
  
(defmethod raw-record-to-tdl ((lex psql-lex-database) rec cols)
  (to-tdl (make-psort-struct lex rec cols)))

;;
;;
;;

;; lex is open
(defmethod load-lex-from-files ((lex psql-lex-database) file-names syntax)
  (setf *ordered-lex-list* nil) ;;fix_me
  (cond
   ((check-load-names file-names 'lexical)
    (let ((*lexicon-in* lex)) ;; *lexicon-in* is needed deep inside read-...-file-aux
      (dolist (file-name file-names)
	(ecase syntax
	  (:tdl (read-tdl-lex-file-aux-internal file-name))
	  (:path (read-lex-file-aux-internal file-name)))))
    t)
   (t
    (cerror "Continue" "Lexicon file not found")
    nil)))

;; CACHING

(defmethod cache-all-lex-records ((lex psql-lex-database))
  (let* ((table (retrieve-all-records lex 
				      (grammar-fields lex)))
	 (recs (recs table))
	 (cols (cols table)))
    (with-slots (record-cache) lex
      (clrhash record-cache)
      (mapc
       #'(lambda (rec)  
	   (setf (gethash (record-id rec cols lex) record-cache) 
	     rec))
       recs))))

(defmethod cache-all-lex-records-orth ((lex psql-lex-database))
  (let ((table (retrieve-all-records lex (grammar-fields lex))))
    (with-slots (recs cols) table
      (with-slots (record-cache lexical-entries) lex
	;; clear cache
	(clrhash lexical-entries)
	(clrhash record-cache)
	;; for each record...
	(mapc
	 #'(lambda (rec)
	     (let* ((id (record-id rec cols lex))
		    (orth (record-orth rec cols lex)))
	       ;; update cache for each component word...
	       (mapc
		#'(lambda (y)
		    (setf (gethash y lexical-entries) 
		      (cons id (gethash y lexical-entries))))
		(split-into-words orth))
	       ;; update record cache
	       (setf (gethash id record-cache)
		 rec)))
	 recs)))))

;;
;;

(defun convert-obsolete-dfn-type-if-nec (l-type)
  (let* ((type (car l-type))
	 (x (cdr (assoc type *lexdb-fmtype-alt*))))
    (when x
      (format t "~%;;; Warning: (LexDB) DFN type '~S' is obsolete" type)
      (format t "~%;;;                  (please use '~S' instead)" x)
      (setf (car l-type) x))))

#+:null
(defmethod make-field-map-slot ((lex psql-lex-database))
  (get-fields lex)
  (get-dfn lex))

(defmethod get-dfn ((lex psql-lex-database))
  (with-slots (dfn) lex
    (setf dfn
      (sort
       (mapcar 
	#'(lambda (x) 
	    (let* ((slot (str-2-keyword (string-upcase (first x))))
		   (field (str-2-keyword (second x)))
		   (path (third x))
		   (type2 (2-symb-or-list (fourth x)))
		   (type (if (listp type2) type2 (list type2))))
	      ;; correct any obsolete types
	      (convert-obsolete-dfn-type-if-nec type)
	      (list slot field path type)))
	(get-raw-records lex (format nil "SELECT slot,field,path,type FROM dfn")))
;	(get-raw-records lex (format nil "SELECT slot,field,path,type FROM dfn WHERE mode='~a' OR mode = ''" (fields-tb lex))))
       #'(lambda (x y) (declare (ignore y)) (eq (car x) :UNIFS))))
    (if (null dfn)
	(complain-no-dfn lex))
    dfn))

(defmethod complain-no-dfn ((lex psql-lex-database))
  (error "~&(LexDB) no DFN entries in lexical database ~a" (dbname lex)))

(defmethod get-field-size-map ((lex psql-lex-database))
  (let* ((table (get-internal-table-dfn lex))
	(recs (recs table))
	 (cols (cols table)))
    (mapcar 
     #'(lambda (x) (field-size-elt x cols)) 
     recs)))

;; used by Emacs interface

(defmethod complete ((lex psql-lex-database) field-kw val-str)
  (let ((qi-field (quote-ident lex (symb-2-str field-kw)))
	(ql-val (psql-quote-literal (format nil "~a%" val-str))))
    (mapcar #'car
	    (get-raw-records lex
			     (format nil
				     "SELECT DISTINCT ~a AS field FROM lex WHERE ~a ILIKE ~a"
				     qi-field qi-field ql-val)))))

(defmethod current-timestamp ((lex psql-lex-database))
  (caar (get-raw-records lex "SELECT current_timestamp")))

;;;
;;; postgres interface
;;;

	     
(defmethod set-lex-entry-from-record ((lex psql-lex-database) fv-pairs)
  (set-lex-entry lex (make-instance 'psql-lex-entry :fv-pairs fv-pairs)))

;;; insert lex entry into db
(defmethod set-lex-entry ((lex psql-lex-database) (psql-le psql-lex-entry) &key (gen-key t))
  (set-val psql-le :|orthkey| (lexicon-le-orthkey lex psql-le))
  (set-val psql-le :|modstamp| "NOW")
  (set-val psql-le :|userid| (user lex))
  (set-lex-entry-aux lex psql-le :gen-key gen-key))
  
(defmethod set-lex-entry-aux ((lex psql-lex-database) (psql-le psql-lex-entry) &key (gen-key t) )
  (let* ((symb-list (copy-list (fields lex)))
	 (symb-list (remove-duplicates symb-list))
	 (symb-list (remove-if 
		     #'(lambda (x) (or (null x) 
				       (and (stringp x)
					    (string= x ""))))
		     symb-list
		     :key #'(lambda (x) (retr-val psql-le x))))
	 (name (retr-val psql-le :|name|))
	 (lexid (str-2-symb name)))
    (unless (string= name (symb-2-str lexid))
      (format t "(LexDB) WARNING: lex id ~a should be written ~a" 
	      name (symb-2-str (str-2-symb name)))
      (lkb-beep)
      (setf name (symb-2-str (str-2-symb name))))
    (update-entry lex symb-list psql-le)
    (empty-cache lex)
    (when gen-key 
      (generate-missing-orthkeys lex))
    
    (mrs::delete-lexid-from-generator-indices lexid)
    (if (read-psort lex lexid) 
	(if (check-lex-entry lexid lex)
	    (progn
	      (add-lexid-to-generator-indices lex lexid)
	      t)
	  (error "Invalid lexical entry ~a -- see Lisp buffer output" lexid))
      t)))

;;
;; DATABASE SEMI
;;

(defmethod new-semi ((lex psql-lex-database))
  (kill-semi lex)
  (create-semi-tables lex)
  (create-semi-indices lex))

(defmethod kill-semi ((lex psql-lex-database))
  (with-lexdb-client-min-messages (lex "error")
    (run-command lex "DROP TABLE semi_pred CASCADE" :ignore-errors t))
  (with-lexdb-client-min-messages (lex "error")
    (run-command lex "DROP TABLE semi_frame CASCADE" :ignore-errors t))
  (with-lexdb-client-min-messages (lex "error")
    (run-command lex "DROP TABLE semi_var CASCADE" :ignore-errors t))
  (with-lexdb-client-min-messages (lex "error")
    (run-command lex "DROP TABLE semi_extra CASCADE" :ignore-errors t))
  (with-lexdb-client-min-messages (lex "error")
    (run-command lex "DROP TABLE semi_mod CASCADE" :ignore-errors t))
  (with-lexdb-client-min-messages (lex "error")
    (run-command lex "DROP TABLE semi_obj CASCADE" :ignore-errors t)))

(defmethod semi-p ((lex psql-lex-database))
  (not (typep (get-records lex "select count(*) from semi_pred where null" :ignore-errors t) 'sql-error)))

(defmethod create-skeletal-db-semi ((lex psql-lex-database))
  (create-semi-tables lex)
  (create-semi-indices lex))

(defmethod create-semi-tables ((lex psql-lex-database))
  (run-command lex "
CREATE TABLE semi_pred (
lex_id text NOT NULL,
pred_id text NOT NULL,
frame_id int NOT NULL,
pred_txt text NOT NULL,
string_p boolean NOT NULL
);

CREATE TABLE semi_frame (
frame_id int NOT NULL,
slot text NOT NULL,
str text,
symb text,
var_id int,
type text
);

CREATE TABLE semi_var (
var_id int NOT NULL,
extra_id int NOT NULL
);

CREATE TABLE semi_extra (
extra_id int NOT NULL,
feat text NOT NULL,
val text NOT NULL
);

CREATE TABLE semi_mod (
name text,
userid text,
modstamp TIMESTAMP WITH TIME ZONE,
modstamp0 TIMESTAMP WITH TIME ZONE
);
	
CREATE OR REPLACE VIEW semi_obj AS
SELECT lex_id,pred_id, slot, str, type, feat, val FROM
semi_pred NATURAL JOIN
semi_frame NATURAL LEFT JOIN
semi_var NATURAL LEFT JOIN
semi_extra;
"))
  
(defmethod create-semi-indices ((lex psql-lex-database))
  (run-command lex "
CREATE INDEX semi_pred_lex_id ON semi_pred (lex_id);
CREATE INDEX semi_pred_pred_id ON semi_pred (pred_id);
CREATE INDEX semi_frame_frame_id ON semi_frame (frame_id);
CREATE INDEX semi_frame_var_id ON semi_frame (var_id);
CREATE INDEX semi_var_var_id ON semi_var (var_id);
CREATE INDEX semi_extra_extra_id ON semi_extra (extra_id);
CREATE UNIQUE INDEX semi_mod_name_userid_modstamp ON semi_mod (name,userid,modstamp);
"))
  
(defmethod drop-semi-indices ((lex psql-lex-database))
  (run-command-coe lex "DROP INDEX semi_pred_lex_id CASCADE")
  (run-command-coe lex "DROP INDEX semi_pred_pred_id CASCADE")
  (run-command-coe lex "DROP INDEX semi_frame_frame_id CASCADE")
  (run-command-coe lex "DROP INDEX semi_frame_var_id CASCADE")
  (run-command-coe lex "DROP INDEX semi_var_var_id CASCADE")
  (run-command-coe lex "DROP INDEX semi_extra_extra_id CASCADE")
  (run-command-coe lex "DROP INDEX semi_mod_name_userid_modstamp CASCADE"))

(defmethod index-new-lex-entries ((lex psql-lex-database))
  (let ((semi-out-of-date (semi-out-of-date lex)))
    (format t "~&(LexDB) indexing ~a entries" (length semi-out-of-date))
    (when semi-out-of-date
      (loop for x in semi-out-of-date
	  do (update-lisp-semi-entry lex x))
      #+:null ;; fix_me (avoid duplicate sdb rows)
      (mrs::update-psql-semi semi-out-of-date 
			     :lex lex
			     :semantic-table mrs::*semantic-table*))))
  
(defmethod update-lisp-semi-entry ((lex psql-lex-database) lexid)
  (mrs::delete-lexid-from-generator-indices lexid) ;!!
  (add-lexid-to-generator-indices lex lexid))

(defmethod add-lexid-to-generator-indices ((lex psql-lex-database) lexid)
  (let* ((entry (read-psort lex lexid :cache nil))
	 (new-fs (and
		  entry
		  (expand-psort-entry entry)
		  (lex-entry-full-fs entry))))
    (cond
     ((null entry)
      (format t "~&WARNING: No lexical entry named ~a" lexid))
     ((and new-fs 
	   (not (eq new-fs :fail)))
      (mrs::extract-lexical-relations entry)) ; <-- efficiency problem originates in here
     (t
      (format t "~&WARNING: No feature structure for ~a~%" lexid))))
    (forget-psort lex lexid))

(defmethod semi-up-to-date-p ((lex psql-lex-database))
 (not (semi-out-of-date lex)))

;;; LEX KEY TABLE
;
;(defmethod index-lex-key ((lex psql-lex-database))
;  (run-command lex "CREATE INDEX lex_key_key ON lex_key (key)"))
;
;(defmethod deindex-lex-key ((lex psql-lex-database))
;  (run-command lex "DROP INDEX lex_key_key" :ignore-errors t))

;;

;;;
;;;
;;;

(defmethod get-fields ((lex psql-lex-database))
  (setf (fields lex)
    (mapcar 
     #'(lambda (x) (intern x :keyword))
     (list-fld lex))))

(defmethod vacuum ((lex psql-lex-database))
  (let (time)
    (format t "~&(LexDB) performing vacuum/analyze on database (as user ~a)..." (user lex))
    (force-output)
    (setf time (get-internal-real-time))
    (with-lexdb-client-min-messages (lex "error")
      (run-command lex "vacuum full analyze"))
    (format t "~&(LexDB) vacuum/analyze complete [~F sec]" 
	    (/ (- (get-internal-real-time) time) internal-time-units-per-second))))

(defmethod db-owner ((lex psql-lex-database))
  (let* ((uid (sql-get-val lex "SELECT datdba FROM pg_catalog.pg_database WHERE datname=current_database()"))
	 (uname (sql-get-val lex 
			     (concatenate 'string
			       "SELECT usename FROM pg_catalog.pg_user WHERE usesysid=" (psql-quote-literal uid)))))
    uname))

(defmethod get-field-vals ((x lex-entry) (lex psql-lex-database))
  (with-slots (dfn) lex
    (let* (;; copy slots as we will destructively delete during processing
	   (s (copy-slots x dfn))
	   ;; perhaps should warn about duplicates?
	   (extraction-fields 
	    (remove :|_tdl|
		    (remove-duplicates
		     (cons :|name| (grammar-fields lex)))))
	   ;; extract field values from tdl structure 
	   ;; and remove unifs as they are found
	   (extraction-field-vals (mapcar 
			 #'(lambda (x) 
			     (cons x
				   (extract-field s x dfn)))
			 extraction-fields))
	   ;; convert any remaining unifs into raw tdl fragment
	   (skip (unifs-to-tdl-body (cdr (assoc :UNIFS s))))
	   (skip (if (string= skip "") nil skip))
	   ;; necessary fields
	   (hard-coded-field-vals (list
				   (cons :|userid| *lexdb-dump-user*)
				   (cons :|modstamp| *lexdb-dump-timestamp*)
				   (cons :|dead| "f")
				   (cons :|_tdl| skip)))
	   ;; additional (useful) fields
	   ;; if not all fields occur in LexDB they will be silently ignored
	   (other-field-vals (list
			      (cons :|lang| *lexdb-dump-lang*)
			      (cons :|country| *lexdb-dump-country*)
			      (cons :|confidence| 1)
			      (cons :|source| *lexdb-dump-source*)))
	   ;; combine all field values
	   (field-vals (append extraction-field-vals
			       hard-coded-field-vals
			       other-field-vals)))
      ;; construct ordered a-list of field values
      ;; fields not in LexDB silently ignored
      field-vals)))
  

;; keys must be updated after set of calls to this fn
(defmethod to-db ((x lex-entry) (lex psql-lex-database))
  "insert lex-entry into lex db (user scratch space)"
  (let* (;;ordered a-list of field values
	 (field-vals (get-field-vals x lex))
	 (skip (cdr (assoc :|_tdl| field-vals)))
	 (name (cdr (assoc :|name| field-vals)))
	 (ordered-field-vals (ordered-symb-val-list (fields lex) field-vals))
	 (psql-le (make-instance 'psql-lex-entry :fv-pairs ordered-field-vals)))	 
    (cond
     ;; no components of lex entry skipped
     ((null skip)
      (set-lex-entry lex psql-le :gen-key nil)
      (empty-cache lex))
     ;; component(s) skipped, but :skip field available in db
     ((member :|_tdl| (fields lex))
      (format t "~&;; (LexDB) Unhandled TDL fragment in ~a placed in _tdl field as unstructured text" name)
      (set-lex-entry lex psql-le :gen-key nil)
      (empty-cache lex))
     ;; component(s) skipped and no :skip field in db
     (t
      (format t "~&~%(LexDB) Lex entry ~a skipped due to unhandled TDL fragment: ~%~t~a~%" name skip)
      nil))))

;; NOTE: not suited to batch import
;; import lex to LexDB
(defmethod export-to-db ((lex lex-database) (lexdb psql-lex-database))
  (mapc
   #'(lambda (x) 
       (to-db (read-psort lex x :recurse nil :new-instance t) 
	      lexdb))
   (collect-psort-ids lex :recurse nil))
  (generate-missing-orthkeys lexdb)
  (build-lex-if-nec lexdb))

(defmethod record-id (raw-record cols (lex psql-lex-database))
  (str-2-symb (get-val :|name| raw-record cols)))  

(defmethod record-orth (raw-record cols (lex psql-lex-database))
  (get-val (second (assoc :ORTH (dfn lex))) raw-record cols))

(defmethod table-size ((lex psql-lex-database) table)
  (let ((table-str (format nil "~a" table)))
    (cond
     ((string= (string-downcase table-str) "rev-all")
      (count-rev-all lex))
     ((string= (string-downcase table-str) "lex")
      (count-lex lex))
     (t
      (sql-get-num lex 
		   (format nil "SELECT count(*) FROM ~a" table))))))

(defmethod orth-field ((lex psql-lex-database))
  (quote-ident lex (orth-field-kw lex)))

(defmethod orth-field-kw ((lex psql-lex-database))
  (second (assoc :ORTH (dfn lex))))

;(defmethod update-lex ((lex psql-lex-database))
;  (update-lex-aux lex)
;  lex)

(defmethod to-db-dump-rev ((x lex-entry) (lex psql-lex-database) &key (skip-stream t))
  "provide line entry for lex db import file"
  (let* (;;ordered a-list of field values
	 (field-vals (get-field-vals x lex))
	 (skip (cdr (assoc :|_tdl| field-vals)))
	 (name (cdr (assoc :|name| field-vals)))
	 (ordered-field-vals (ordered-symb-val-list (fields lex) field-vals))
	 ;; construct CVS copy line
	 (line 
	  (format nil "~a~%" 
		  (str-list-2-line
		   (mapcar
		    #'(lambda (x)
			(let ((val (cdr x)))
			  (if val
			      (2-str val)
			    nil)))
		    ordered-field-vals)
		   :sep-c #\tab
		   :null-str "\\N"))))
    (cond
     ;; no components of lex entry skipped
     ((null skip)
      line)
     ;; component(s) skipped, but :skip field available in db
     ((member :|_tdl| (fields lex))
      (format t "~&(LexDB) Unhandled TDL fragment in lexical entry ~a: ~%~t~a~%~%" name skip)
      (format t "~&;; (LexDB) Unhandled TDL fragment in ~a placed in _tdl field as unstructured text" name)
	line)
     ;; component(s) skipped and no :skip field in db
     (t
      (format t "~&~%(LexDB) Lex entry ~a skipped due to unhandled TDL fragment: ~%~t~a~%" name skip)
      (format skip-stream "~a" (to-tdl x))
      ""))))


;; todo: this is very inefficient
(defmethod import-tdl-file ((lex psql-lex-database) filename)
  (catch 'abort 
    (unless lex
      (error "~%lex is NULL"))
    (let ((lexicon (load-scratch-lex :filename filename)))
      (query-for-meta-fields)
      (reconnect lex);; work around server bug
      (time 
       (export-to-db lexicon lex))
      (close-lex lexicon)
      ))
  ;(if (next-method-p) (call-next-method))
  )

(defmethod dump-generator-indices-to-psql ((lex psql-lex-database))
  (lexdb-time 
   ("dumping object SEMI to LexDB" "done dumping object SEMI to LexDB")
   (mrs::sdb-to-psql 
    lex (mrs::populate-sdb :semantic-table mrs::*semantic-table*))
   (populate-semi-mod lex)
   
   (let ((not-indexed mrs::*empty-semantics-lexical-entries*))
     (when not-indexed
       (populate-semi-mod-EMPTY-SEM lex not-indexed)
       ))
   ;; semi_mod indexes should be created after this call
   (run-command lex "SET ENABLE_HASHJOIN TO false")
   ))

(defmethod collect-psort-ids-aux ((lex psql-lex-database))
  (let ((query-res 
	 (get-raw-records lex (collect-psort-ids-SQL lex))))
    (mapcar 
     #'(lambda (x) 
	 (str-2-symb (car x)))
     query-res)))

;;!
;; DOT: select FIELDS for lexicon entry ID
(defmethod get-dot-lex-record ((lex psql-lex-database) id &optional (fields '("*")))
  (let ((table (retrieve-raw-record-no-cache lex id fields)))
    (dot (cols table) (car (recs table)))))