; C Library
;
; Copyright (C) 2025 Kestrel Institute (http://www.kestrel.edu)
;
; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2.
;
; Author: Grant Jurgensen (grant@kestrel.edu)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "C2C")

(include-book "std/util/bstar" :dir :system)
(include-book "std/util/define" :dir :system)
(include-book "xdoc/defxdoc-plus" :dir :system)
(include-book "xdoc/constructors" :dir :system)

(include-book "kestrel/utilities/messages" :dir :system)
(include-book "std/system/constant-value" :dir :system)
(include-book "std/util/error-value-tuples" :dir :system)

(include-book "../syntax/abstract-syntax-operations")
(include-book "../syntax/disambiguator")
(include-book "../syntax/validator")
(include-book "../syntax/code-ensembles")
(include-book "split-fn")
(include-book "utilities/fresh-ident")

(local (include-book "kestrel/built-ins/disable" :dir :system))
(local (acl2::disable-most-builtin-logic-defuns))
(local (acl2::disable-builtin-rewrite-rules-for-defaults))
(local (in-theory (disable (tau-system))))
(set-induction-depth-limit 0)

(local (include-book "kestrel/bv/unsigned-byte-p" :dir :system))
(local (include-book "kestrel/utilities/nfix" :dir :system))
(local (include-book "kestrel/utilities/ordinals" :dir :system))
(local (include-book "std/system/w" :dir :system))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(std::make-define-config
  :no-function t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(xdoc::evmac-topic-implementation split-fn-when
  :default-parent t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define block-item-triggerp
  ((item block-itemp)
   (triggers ident-setp))
  (declare (xargs :type-prescription
                  (booleanp (block-item-triggerp item triggers))))
  (block-item-case
   item
   ;; TODO: this should probably recurse down through statement.
   :stmt (stmt-case
           item.stmt
           :expr (and item.stmt.expr?
                      (expr-case
                        item.stmt.expr?
                        :funcall (expr-case
                                   item.stmt.expr?.fun
                                   :ident (in item.stmt.expr?.fun.ident
                                              triggers)
                                   :otherwise nil)
                        :otherwise nil))
           :otherwise nil)
   :otherwise nil))

(define block-item-list-try-split-fn-when-loop
  ((items block-item-listp)
   (triggers ident-setp)
   (position natp))
  (declare
   (xargs :type-prescription
          (or (natp (block-item-list-try-split-fn-when-loop items triggers position))
              (equal (block-item-list-try-split-fn-when-loop items triggers position) nil))))
  (cond ((endp items)
         nil)
        ((block-item-triggerp (first items) triggers)
         (mbe :logic (nfix position)
              :exec position))
        (t (block-item-list-try-split-fn-when-loop
             (rest items)
             triggers
             (+ position 1))))
  :guard-hints (("Goal" :in-theory (enable nfix))))

(define block-item-list-try-split-fn-when
  ((items block-item-listp)
   (triggers ident-setp))
  (declare
   (xargs :type-prescription
          (or (natp (block-item-list-try-split-fn-when items triggers))
              (equal (block-item-list-try-split-fn-when items triggers) nil))))
  (if (or (endp items)
          (endp (rest items)))
      nil
    (block-item-list-try-split-fn-when-loop (rest items) triggers 1)))

;; Note: This does *not* split if the trigger is the first statement. This
;; would be a loop.
;; Note: we split right *before* trigger (could be configured for after)
;; Only error on malformed syntax (I think)
(define fundef-try-split-fn-when
  ((fundef fundefp)
   ;; For now, the trigger is a function name.
   (triggers ident-setp)
   ;; To check for name freshness
   (trans-units trans-ensemblep))
  :returns (mv (er? maybe-msgp)
               (fundef1 fundefp)
               (fundef2 fundef-optionp))
  (b* (((reterr) (c$::irr-fundef) nil)
       (fundef (fundef-fix fundef))
       ((fundef fundef) fundef)
       ((declor fundef.declor) fundef.declor)
       (position?
        (block-item-list-try-split-fn-when (comp-stmt->items fundef.body) triggers))
       ((unless position?)
        (retok fundef nil))
       ((erp fun-name)
        (b* (((reterr) nil))
          (dirdeclor-case
           fundef.declor.direct
           :function-params
           (retok (c$::dirdeclor->ident fundef.declor.direct.declor))
           :function-names
           (retok (c$::dirdeclor->ident fundef.declor.direct.declor))
           :otherwise (retmsg$ "Malformed syntax.")))))
    (split-fn-fundef
     fun-name
     (trans-ensemble-fresh-ident fun-name trans-units)
     fundef
     position?)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define ext-declon-try-split-fn-when
  ((extdecl ext-declonp)
   (triggers ident-setp)
   (trans-units trans-ensemblep))
  :returns (mv (er? maybe-msgp)
               (found booleanp :rule-classes :type-prescription)
               (extdecls ext-declon-listp))
  (b* (((reterr) nil nil))
    (ext-declon-case
      extdecl
      :fundef (b* (((erp fundef1 fundef2)
                    (fundef-try-split-fn-when
                      extdecl.fundef
                      triggers
                      trans-units)))
                (fundef-option-case
                  fundef2
                  :some (retok t (list (ext-declon-fundef fundef1)
                                       (ext-declon-fundef fundef2.val)))
                  :none (retok nil (list (ext-declon-fundef fundef1)))))
      :otherwise (retok nil (list (ext-declon-fix extdecl)))))
  ///
  (more-returns
   (extdecls true-listp :rule-classes :type-prescription)))

(define trans-item-try-split-fn-when
  ((item trans-itemp)
   (triggers ident-setp)
   (trans-units trans-ensemblep))
  :returns (mv (er? maybe-msgp)
               (found booleanp :rule-classes :type-prescription)
               (items trans-item-listp))
  (b* (((reterr) nil nil))
    (trans-item-case
      item
      :declon (b* (((erp found extdecls)
                    (ext-declon-try-split-fn-when item.declon
                                                  triggers
                                                  trans-units)))
                (retok found (c$::trans-item-list-declon extdecls)))
      :include (retmsg$ "Unsupported #include directive.")
      :define (retmsg$ "Unsupported #define directive.")
      :undef (retmsg$ "Unsupported #undef directive.")
      :cond (retmsg$ "Unsupported conditional directive.")
      :line-comment (retok nil (list (trans-item-fix item)))))
  ///
  (more-returns
   (items true-listp :rule-classes :type-prescription)))

(define trans-item-list-try-split-fn-when
  ((items trans-item-listp)
   (triggers ident-setp)
   (trans-units trans-ensemblep))
  :returns (mv (er? maybe-msgp)
               (found booleanp :rule-classes :type-prescription)
               (items$ trans-item-listp))
  (b* (((reterr) nil nil)
       ((when (endp items))
        (retok nil nil))
       ((erp found items1)
        (trans-item-try-split-fn-when (first items) triggers trans-units))
       ((when found)
        (retok t (append items1 (trans-item-list-fix (rest items)))))
       ((erp found items2)
        (trans-item-list-try-split-fn-when (rest items) triggers trans-units)))
    (retok found (append items1 items2)))
  ///
  (more-returns
   (items$ true-listp :rule-classes :type-prescription)))

(define trans-unit-try-split-fn-when
  ((tunit trans-unitp)
   (triggers ident-setp)
   (trans-units trans-ensemblep))
  :returns (mv (er? maybe-msgp)
               (found booleanp :rule-classes :type-prescription)
               (tunit$ trans-unitp))
  (b* (((reterr) nil (c$::irr-trans-unit))
       ((trans-unit tunit) tunit)
       ((erp found items)
        (trans-item-list-try-split-fn-when tunit.items triggers trans-units)))
    (retok found
           (make-trans-unit :items items
                           :info tunit.info))))

(define filepath-trans-unit-map-try-split-fn-when
  ((map filepath-trans-unit-mapp)
   (triggers ident-setp)
   (trans-units trans-ensemblep))
  :returns (mv (er? maybe-msgp)
               (found booleanp :rule-classes :type-prescription)
               (map$ filepath-trans-unit-mapp))
  (b* (((reterr) nil nil)
       (map (c$::filepath-trans-unit-map-fix map))
       ((when (omap::emptyp map))
        (retok nil nil))
       ((mv path tunit) (omap::head map))
       ((erp found tunit$)
        (trans-unit-try-split-fn-when tunit triggers trans-units))
       ((when found)
        (retok found
               (omap::update path tunit$ (omap::tail map))))
       ((erp found map$)
        (filepath-trans-unit-map-try-split-fn-when
          (omap::tail map)
          triggers
          trans-units)))
    (retok found
           (omap::update path tunit$ map$)))
  :verify-guards :after-returns)

(define trans-ensemble-try-split-fn-when
  ((tunits trans-ensemblep)
   (triggers ident-setp))
  :returns (mv (er? maybe-msgp)
               (found booleanp :rule-classes :type-prescription)
               (tunits$ trans-ensemblep))
  (b* (((reterr) nil (irr-trans-ensemble))
       ((trans-ensemble tunits) tunits)
       ((erp found map)
        (filepath-trans-unit-map-try-split-fn-when tunits.units
                                                  triggers
                                                  tunits)))
    (retok found (c$::make-trans-ensemble :units map))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define trans-ensemble-split-fn-when
  ((tunits trans-ensemblep)
   (triggers ident-setp))
  :returns (mv (er? maybe-msgp)
               (tunits$ trans-ensemblep))
  (trans-ensemble-split-fn-when-loop
    tunits
    triggers
    (acl2::the-fixnat (- (expt 2 acl2::*fixnat-bits*) 1)))

  :prepwork
  ((define trans-ensemble-split-fn-when-loop
     ((tunits trans-ensemblep)
      (triggers ident-setp)
      (steps :type #.acl2::*fixnat-type*))
     :returns (mv (er? maybe-msgp)
                  (tunits$ trans-ensemblep))
     (b* (((reterr) (irr-trans-ensemble))
          ((when (= 0 (mbe :logic (nfix steps)
                           :exec (acl2::the-fixnat steps))))
           (retmsg$ "Out of steps."))
          ((erp found tunits$)
           (trans-ensemble-try-split-fn-when tunits triggers))
          ((unless found)
           (retok tunits$)))
       (trans-ensemble-split-fn-when-loop
         tunits$
         triggers
         (- steps 1)))
     :measure (nfix steps)
     :hints (("Goal" :in-theory (enable nfix))))))

(define code-ensemble-split-fn-when
  ((code code-ensemblep)
   (triggers ident-setp))
  :returns (mv (er? maybe-msgp)
               (code$ code-ensemblep))
  (b* (((code-ensemble code) code)
       ((reterr) (irr-code-ensemble))
       ((erp tunits) (trans-ensemble-split-fn-when code.trans-units
                                                   triggers)))
    (retok (change-code-ensemble code :trans-units tunits))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(xdoc::evmac-topic-input-processing split-fn-when)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define split-fn-when-process-inputs
  (const-old
   const-new
   triggers
   (wrld plist-worldp))
  :returns (mv (er? maybe-msgp)
               (code code-ensemblep)
               (const-new$ symbolp :rule-classes :type-prescription)
               (triggers string-listp))
  :short "Process the inputs."
  (b* (((reterr) (irr-code-ensemble) nil nil)
       ((unless (symbolp const-old))
        (retmsg$ "~x0 must be a symbol" const-old))
       (code (acl2::constant-value const-old wrld))
       ((unless (code-ensemblep code))
        (retmsg$ "~x0 must be a code ensemble." const-old))
       ((unless (code-ensemble-annop code))
        (retmsg$ "~x0 must be an annotated with validation information." const-old))
       ((unless (symbolp const-new))
        (retmsg$ "~x0 must be a symbol" const-new))
       (triggers (if (stringp triggers)
                     (list triggers)
                   triggers))
       ((unless (string-listp triggers))
        (retmsg$ "~x0 must be a string or string list" triggers))
       ((when (endp triggers))
        (retmsg$ "~x0 must be a list with at least one element" triggers)))
    (retok code const-new triggers))
  :guard-hints (("Goal" :in-theory (enable string-listp)))
  ///

  (defret code-ensemble-annop-of-split-fn-when-process-inputs.code
    (implies (not er?)
             (code-ensemble-annop code))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(xdoc::evmac-topic-event-generation split-fn-when)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define string-list-to-ident-set
  ((strings string-listp))
  :returns (idents ident-setp)
  (if (endp strings)
      nil
    (insert (ident (first strings))
            (string-list-to-ident-set (rest strings))))
  :guard-hints (("Goal" :in-theory (enable string-listp)))
  :verify-guards :after-returns)

(define split-fn-when-gen-everything
  ((code code-ensemblep)
   (const-new symbolp)
   (triggers string-listp))
  :guard (code-ensemble-annop code)
  :returns (mv (er? maybe-msgp)
               (event pseudo-event-formp))
  :short "Generate all the events."
  (b* (((reterr) '(_))
       ((erp code)
        (code-ensemble-split-fn-when code
                                     (string-list-to-ident-set triggers)))
       (defconst-event
         `(defconst ,const-new
            ',code)))
    (retok defconst-event)))

(define split-fn-when-process-inputs-and-gen-everything
  (const-old
   const-new
   triggers
   (wrld plist-worldp))
  :returns (mv (er? maybe-msgp)
               (event pseudo-event-formp))
  :short "Process the inputs and generate the events."
  (b* (((reterr) '(_))
       ((erp code const-new triggers)
        (split-fn-when-process-inputs const-old
                                      const-new
                                      triggers
                                      wrld))
       ((erp event)
        (split-fn-when-gen-everything code
                                      const-new
                                      triggers)))
    (retok event)))

(define split-fn-when-fn (const-old
                          const-new
                          triggers
                          (ctx ctxp)
                          state)
  :returns (mv (erp booleanp :rule-classes :type-prescription)
               (event pseudo-event-formp)
               state)
  :parents (split-fn-when-implementation)
  :short "Event expansion of @(tsee split-fn-when)."
  (b* (((mv erp event)
        (split-fn-when-process-inputs-and-gen-everything
          const-old
          const-new
          triggers
          (w state)))
       ((when erp) (er-soft+ ctx t '(_) "~@0" erp)))
    (value event)))

(defmacro split-fn-when
  (const-old
   const-new
   &key
   triggers)
  `(make-event (split-fn-when-fn ',const-old
                                 ',const-new
                                 ',triggers
                                 'split-fn-when
                                 state)))
