;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: LKB -*-

;;; Copyright (c) 2026
;;;   John Carroll, Ann Copestake, Robert Malouf, Stephan Oepen;
;;;   see `LICENSE' for conditions.
;;;
;;; Initial implementation by John Carroll, July 2026

(in-package :lkb)

;;; Loading grammars using the proposed, TDL-inspired DELPH-IN configuration file format

;;; Environments and :include are implemented as in TdlRFC, and Sub-Proposal 1 Conditionals
;;; "Another possible syntax ..." in GrammarConfigurationRfc
;;;
;;; Two further status values have been added for instance_env: label and root
;;;
;;; Further parameters have been added extending those at AceConfiguration, including:
;;; load-lkb-preferences, and preload-lisp-files / postload-lisp-files (inspired by
;;; similar parameters in PET)
;;;
;;; NB In this implementation and in ACE, feature paths are whitespace-separated sequences
;;; of identifiers, e.g.
;;;   lexicon-tokens-path     := TOKENS +LIST.
;;; whereas PET uses TDL dot notation in a string, e.g.
;;;   mrs-path := "SYNSEM.LOCAL.CONT".
;;;
;;; Question: how to specify an empty list of values, given that there has to be at least
;;; one token after the `:='? PET seems to support the following:
;;;   preload-files := "".
;;;
;;; References:
;;;
;;; https://github.com/delph-in/docs/wiki/TdlRFC
;;; https://github.com/delph-in/docs/wiki/GrammarConfigurationRfc
;;; https://github.com/delph-in/docs/wiki/AceConfiguration

(defparameter *tdl-input-functions*
  `((:config
        read-tdl-config-stream .
        read-tdl-config-file)
    (:type ; NB type file :includes must be batched up so we know when to post-process type
           ; hierarchy to compute GLB types, inherit constraints, check consistency, etc
        read-tdl-type-includes .
        nil)
    (generic-lex-entry ; lexical entry file :includes must also be batched up
        ,#'(lambda (s) (read-tdl-lex-includes s 'generic-lex-entry)) .
        nil)
    (lex-entry ; :includes batched up
        ,#'(lambda (s) (read-tdl-lex-includes s 'lex-entry)) .
        nil)
    (lexical-filtering-rule
        ,#'(lambda (s) (read-chart-mapping-stream s :lfr)) .
        ,#'(lambda (f) (read-chart-mapping-file-aux f :lfr)))
    (lex-rule
        ,#'(lambda (s) (read-tdl-rule-stream s t)) .
        ,#'(lambda (f) (read-tdl-lex-or-grammar-rule-file f t)))
    (post-generation-mapping-rule
        ,#'(lambda (s) (read-chart-mapping-stream s :pgmr)) .
        ,#'(lambda (f) (read-chart-mapping-file-aux f :pgmr)))
    (rule
        ,#'(lambda (s) (read-tdl-rule-stream s nil)) .
        ,#'(lambda (f) (read-tdl-lex-or-grammar-rule-file f nil)))
    (token-mapping-rule
        ,#'(lambda (s) (read-chart-mapping-stream s :tmr)) .
        ,#'(lambda (f) (read-chart-mapping-file-aux f :tmr)))
    (label
        ,#'(lambda (s) (read-tdl-psort-stream s :nodes)) .
        read-tdl-parse-node-file-aux)
    (root
        ,#'(lambda (s) (read-tdl-psort-stream s :root)) .
        read-tdl-start-file-aux)
    (nil
        ,#'(lambda (s) (read-tdl-psort-stream s :root)) . ; default if instance status omitted
        read-tdl-psort-file-aux)))

(defvar *delayed-config-actions* nil)

;;; Main function, also called recursively for :include when in a :config environment. Not a
;;; standalone entry point - must be wrapped inside grammar initialisation and finalisation
;;; as in read-script-file-aux

(defun read-tdl-config-file (file)
  (with-open-file (istream file :direction :input)
    (let ((*default-pathname-defaults*
            (merge-pathnames (truename file) (make-pathname :type "tdl")))
          (*delayed-config-actions* nil))
      #+:cdebug (format t "~&*default-pathname-defaults* = ~A~%" *default-pathname-defaults*)
      (format t "~&Reading in config file ~A~%" (file-namestring file))
      (read-tdl-config-stream istream)
      (mapc #'funcall *delayed-config-actions*)
      nil)))

(defun read-tdl-config-stream (istream) 
  ;; tdl_file          : ... | configuration | ...
  ;; environment       : ... | BEGIN CONFIG system? DOT configuration_env END CONFIG DOT
  ;; configuration_env : ( environment | statement | configuration | SPACING )*
  ;; system            : IDENTIFIER SPACING  // LKB, ACE etc.
  (loop
    (let ((next-char (peek-with-comments istream)))
      (cond
        ((eql next-char 'eof)
          ;; implicit :begin at top level, or explicit :begin without a corresponding :end
          (return))
        ((eql next-char #\:) ; now expect :include, :begin or :end
          (when (eq (read-tdl-directive istream :config) :end) (return)))
        (t 
          (catch 'syntax-error
            (read-tdl-config-entry istream)))))))

(defun skip-tdl-config-stream (istream) 
  ;; _fix_me_ needs a more robust algorithm plus error checking
  (loop
    (when (search ":end :config." (read-line istream)) (return))))

(defun read-tdl-directive (istream env)
  ;; have just peeked a : character
  (let ((directive (read-dkey istream)))
    (peek-with-comments istream) ; consume whitespace/comments
    (ecase directive
      (:include
        (let ((file (read-filename istream)))
          (check-for #\. istream ":include")
          #+:cdebug (format t "~&(~A ~S)~%" (cddr (assoc env *tdl-input-functions*)) file)
          (funcall (cddr (assoc env *tdl-input-functions*)) file)
          nil))
      (:begin
        (let ((etype (read-dkey istream)))
          (ecase etype
            (:config
              (if (prog1 ; allow for optional `system' parameter
                    (or (eql (peek-with-comments istream) #\.)
                        (find (intern (string (lkb-read istream nil)) :keyword) *features*))
                    (check-for #\. istream ":begin :config"))
                  (progn
                    #+:cdebug (format t "~&(~A ~S)~%" 'read-tdl-config-stream istream)
                    (read-tdl-config-stream istream))
                  (progn
                    #+:cdebug (format t "~&(~A ~S)~%" 'skip-tdl-config-stream istream)
                    (skip-tdl-config-stream istream))))
            (:type
              (check-for #\. istream ":begin :type")
              #+:cdebug (format t "~&(~A ~S)~%" 'read-tdl-type-includes istream)
              (read-tdl-type-includes istream))
            (:instance
              (if (eql (peek-with-comments istream) #\:) ; :status specified?
                 (progn
                   (unless (eq (read-dkey istream) :status)
                     (error "Invalid :begin :instance environment"))
                   (let* ((env (lkb-read istream nil))
                          (fn (cadr (assoc env *tdl-input-functions*))))
                     (check-for #\. istream ":begin :instance :status")
                     (unless fn
                       (error "Invalid :instance :status ~(~A~)" env))
                     #+:cdebug (format t "~&(~A ~S)~%" fn istream)
                     (funcall fn istream)))
                 (let ((fn (cadr (assoc nil *tdl-input-functions*))))
                   (check-for #\. istream ":begin :instance")
                   #+:cdebug (format t "~&(~A ~S)~%" fn istream)
                   (funcall fn istream)))))
          nil))
      (:end 
        (let ((etype (read-dkey istream)))
          (cond
            ((member env '(:config :type)) (eq env etype))
            ((eq etype :instance))
            (t (error ":end ~(~S~) does not match :begin ~(~S~)" etype env))))
        (check-for #\. istream ":end")
        :end))))

(defun read-dkey (istream)
  ;; _fix_me_ ugly
  (read-char istream) ; colon
  (intern (string (lkb-read istream nil)) :keyword))

(defun read-filename (istream)
  (let ((x (read istream)))
    (etypecase x
      (string (merge-pathnames (pathname x))))))


;;; Configuration file entries

(defun read-tdl-config-entry (istream)
  ;; configuration : parameter DEFOP value+ DOT
  ;; parameter     : IDENTIFIER SPACING
  ;; value         : ( IDENTIFIER | DQSTRING ) SPACING
  (let ((param (lkb-read istream nil))
        (value nil))
    (check-for-string ":=" istream "parameter statement")
    (peek-with-comments istream)
    (loop
      (setq value (nconc value (list (lkb-read istream t))))
      (when (eql (peek-with-comments istream) #\.)
        (check-for #\. istream "parameter statement")
        (return)))
    (read-tdl-config-entry-aux param value)))

(defun read-tdl-config-entry-aux (param value &aux (v (car value)))
  ;; _fix_me_ add checks for malformed and inconsistent values
  ;; Also, possibly a declarative way of specifying mapping from TDL parameter names
  ;; to LKB variables / function calls, and for each parameter the Lisp type(s) of
  ;; its possible value(s)
  (declare (special *gen-filtering-p* cl-user::*grammar-version*))
  #+:cdebug (format t "~&~S ~S~%" param value)
  (flet ((delay (fn)
           (setq *delayed-config-actions* (nconc *delayed-config-actions* (list fn)))))
    (case param
      ;; as in GrammarConfigurationRfc
      (grammar-version ; PET has similar parameter `version-string'; also see `version' below
        (setq cl-user::*grammar-version* v))
      (character-encoding (eval `(set-coding-system ,v)))

      (grammar-top
        (delay #'(lambda () (read-tdl-config-file v))))
      (variable-property-mapping 
        (delay #'(lambda () (mt:read-vpm v :semi))))
      (maxent-model
        (delay
          #'(lambda ()
              (if (find-package :tsdb)
                  (funcall (intern (string 'read-model) :tsdb) v)
                  (error "maxent-model functionality not available")))))
      ;; !!! ACE has preprocessor with different interpretation - and also preprocessor-modules
      (preprocessor
        (delay #'(lambda () (load v :verbose t :print nil))))
      (generation-ignore-lexemes
        (delay
          #'(lambda () (setq *duplicate-lex-ids* (load-names-set-file v)))))
      (generation-ignore-rules
        (delay
          #'(lambda () (setq *gen-ignore-rules* (load-names-set-file v))))) 
      (parse-ignore-rules ; !!! not implemented in ACE
        (delay
          #'(lambda () (setq *parse-ignore-rules* (load-names-set-file v))))) 
      (parse-node-labels
        (delay #'(lambda () (read-tdl-parse-node-file-aux v))))
      (generation-trigger-rules
        (delay
          #'(lambda ()
              (mt:read-transfer-rules value "Generation Trigger Rules"
                :filter nil :task :trigger :recurse nil :edges 200 :subsume nil))))
      (version
        (load v :verbose t :print nil))

      (semantic-interface-2016
        (delay #'(lambda () (mt:read-semi v))))
      ;; !!! ACE also has semantic-interface-top-type

      (idiom-rules
        (delay
          #'(lambda ()
              (mt:read-transfer-rules value "Idiom Tests" :filter nil :task :idiom))))
      (non-idiom-root
        (setq *non-idiom-root* v))

      (irregular-forms
        (delay #'(lambda () (load-irregular-spellings value))))

      (quickcheck-code ; !!! different interpretation to ACE
        (lkb-load-lisp *default-pathname-defaults* v t nil))

      (load-lkb-preferences ; !!! LKB only, also below
        (load-lkb-preferences *default-pathname-defaults* v))
      (preload-lisp-files
        (loop for f in value do (lkb-load-lisp *default-pathname-defaults* f t nil)))
      (postload-lisp-files
        (delay
          #'(lambda () 
              (loop for f in value do (lkb-load-lisp *default-pathname-defaults* f t nil)))))

      (top-type (setq *toptype* v))
      (orth-path (setq *orth-path* value))
      (label-path (setq *label-path* value))
      (list-type (setq *list-type* v))
      (cons-type (setq *non-empty-list-type* v)) ; !!! not mentioned in LKB documentation
      (null-type (setq *empty-list-type* v))
      (diff-list-type (setq *diff-list-type* v))

      (parsing-roots (setq *start-symbol* value))
      (generation-roots (setq *gen-start-symbol* value))
      (deleted-daughters (setq *deleted-daughter-features* value))
      (parsing-packing-restrictor (setq *packing-restrictor* value))
      ;; !!! ACE also has generation-packing-restrictor, LKB just uses parsing-packing-restrictor
      (chart-dependencies
        (setq *chart-dependencies*
          (loop for p in value ; _fix_me_ check for malformed value
              collect (read-from-string (concatenate 'string "(" p ")")))))
      (spanning-only-rules (setq *spanning-only-rules* value))
      (index-accessibility-filtering
        (setq *gen-filtering-p* (if (eq v 'enabled) t nil)))
      (ortho-max-rules
        (setq *maximal-lex-rule-applications* (parse-integer (string v))))

      (token-type (setq *token-type* v))
      (token-form-path (setq *token-form-path* value))
      (token-id-path (setq *token-id-path* value))
      (token-from-path (setq *token-from-path* value))
      (token-to-path (setq *token-to-path* value))
      (token-postags-path (setq *token-postags-path* value))
      (token-posprobs-path (setq *token-posprobs-path* value))
      (lexicon-tokens-path (setq *lexicon-tokens-path* value))
      (lexicon-last-token-path (setq *lexicon-last-token-path* value))

      (lattice-mapping-input-path (setq *chart-mapping-input-path* value))
      (lattice-mapping-output-path (setq *chart-mapping-output-path* value))
      (lattice-mapping-context-path (setq *chart-mapping-context-path* value))
      (lattice-mapping-position-path (setq *chart-mapping-position-path* value))
      ;; !!! ACE cannot configure equivalent of *chart-mapping-jump-path*

      (t (warn "Unknown parameter ~A - ignored" param)))))


(defun load-names-set-file (file)
  ;; c.f. load-erg-settings-file but avoiding pitfalls
  (with-open-file (stream file :direction :input)
    (loop with s = nil
        for line = (read-line stream nil stream)
	until (eq line stream)
	do (setq s
             (string-trim '(#\space #\tab) (subseq line 0 (position #\; line))))
        unless (zerop (length s))
	collect (intern (string-upcase s) :lkb))))

;;; Reading TDL type and lex-entry/generic-lex-entry files where we need to batch up
;;; constructs and process them all together

(defun read-tdl-type-includes (istream &optional augment)
  (declare (ignore augment)) 
  ;; having just read ":begin :type."
  ;; only allow a sequence of (non-nested) :include
  (let ((filenames nil))
    (loop
      (case (peek-with-comments istream)
        (eof (return))
        (#\:
          (let ((directive (read-dkey istream)))
            (peek-with-comments istream)
            (ecase directive
              (:begin
                (error "Only :include is supported inside :begin :type"))
              (:include
                (let ((filename (read-filename istream)))
                  (check-for #\. istream ":include")
                  (setq filenames (nconc filenames (list filename)))))
              (:end 
                (let ((etype (read-dkey istream)))
                  (unless (eq etype :type)
                    (error ":end ~(~S~) does not match :begin :type" etype)))
                (check-for #\. istream ":end :type")
                (return)))))
        (t
          (error "Only :include is supported inside :begin :type"))))
    #+:cdebug (format t "~&(~A ~S)~%" 'read-tdl-type-files-aux filenames)
    (read-tdl-type-files-aux filenames)
    :end))

(defun read-tdl-lex-includes (istream env)
  ;; having just read ":begin :instance :status lex-entry/generic-lex-entry."
  ;; only allow a sequence of (non-nested) :include
  (let ((filenames nil))
    (loop
      (case (peek-with-comments istream)
        (eof (return))
        (#\:
          (let ((directive (read-dkey istream)))
            (peek-with-comments istream) ; consume whitespace/comments
            (ecase directive
              (:begin
                (error "Only :include is supported inside :begin :instance :status ~(~S~)" env))
              (:include
                (let ((filename (read-filename istream)))
                  (check-for #\. istream ":include")
                  (setq filenames (nconc filenames (list filename)))))
              (:end 
                (let ((etype (read-dkey istream)))
                  (unless (eq etype :instance)
                    (error istream ":end ~(~S~) does not match :begin :instance" etype)))
                (check-for #\. istream ":end :instance")
                (return)))))
        (t
          (error "Only :include is supported inside :begin :instance :status ~(~S~)" env))))
    (ecase env
      (lex-entry
        #+:cdebug (format t "~&(~A ~S)~%" 'read-cached-lex-if-available filenames)
        (read-cached-lex-if-available filenames))
      (generic-lex-entry
        #+:cdebug (format t "~&(~A ~S ~S)~%" 'read-cached-sublex-if-available "gle" filenames)
        (read-cached-sublex-if-available "gle" filenames)))
    :end))