;;; bitbake.el --- Running bitbake from emacs  -*- lexical-binding: t; -*-

;; Author: Damien Merenne
;; URL: https://github.com/canatella/bitbake-el
;; Created: 2014-02-11
;; Keywords: convenience
;; Package-Version: 20260712.1615
;; Package-Revision: f626d37727df
;; Package-Requires: ((emacs "25") (dash "2.6.0") (polymode "20260505.1803") (s "1.10.0"))

;; This file is NOT part of GNU Emacs.

;;; Commentary:

;; This package provides integration of the Yocto Bitbake tool with
;; Emacs.  Its main features are:
;;
;; - interacting with the bitbake script so that you can run bitbake
;;   seamlessly from Emacs.  If your editing a recipe, recompiling is
;;   just one M-x bitbake-recompile command away,
;; - deploying recipes output directly to your target device over ssh
;;   for direct testing (if your image supports read-write mode),
;; - generating wic images,
;; - a global minor mode providing menu and shortcuts,
;; - a major mode for editing recipes, using `polymode' to support
;;   Python and shell syntax.


;;; License:

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:

(require 'ansi-color)
(require 'comint)
(require 'polymode)
(require 's)
(require 'dash)

;;; User customizable variables
(defgroup bitbake nil
  "Run bitbake commands from Emacs."
  :group 'processes)

(defcustom bitbake-poky-directory "/opt/poky"
  "The default yocto poky directory."
  :type '(directory)
  :group 'bitbake)

(defcustom bitbake-build-directory ""
  "The default yocto build directory."
  :type '(directory)
  :group 'bitbake)

(defcustom bitbake-bin-directory "bitbake/bin"
  "The directory of the bitbake executables in `bitbake-poky-directory'."
  :type '(directory)
  :group 'bitbake)

(defcustom bitbake-script-directory "scripts"
  "The name of the scripts directory in `bitbake-poky-directory'."
  :type '(directory)
  :group 'bitbake)

(defcustom bitbake-server-host nil
  "The name or IP address to use as host address of the server process.
If set, the server accepts remote connections; otherwise it is local."
  :type '(choice
          (string :tag "Name or IP address")
          (const :tag "Local" nil))
  :group 'bitbake)

;;;###autoload
(put 'bitbake-server-host 'risky-local-variable t)

(defcustom bitbake-server-port nil
  "The port number that the server process should listen on.
A nil value means to use a random port number."
  :group 'bitbake
  :type '(choice
          (string :tag "Port number")
          (const :tag "Random" nil))
  :version "24.1")
;;;###autoload
(put 'server-port 'risky-local-variable t)

(defcustom bitbake-deploy-ssh-host nil
  "The host where to deploy package over ssh."
  :group 'bitbake
  :type '(string)
  :version "24.1")

(defcustom bitbake-wic-definition-file nil
  "Path the wic definition file (wks file) to use for creating hdd image.

If a relative path is used, it will be relative to the poky directory."
  :group 'bitbake
  :type '(string)
  :version "24.1")

(defcustom bitbake-flash-device nil
  "The device file where to dd the hdd image.

If using a USB stick to boot the target platform, use a udev rule
to create a link to that disk and use the link name
here.  Calling bitbake-flash will copy the hdd image on the usb disk if present."
  :group 'bitbake
  :type '(string)
  :version "24.1")

(defcustom bitbake-open-devshell-in-emacs t
  "If true, arrange for devshell to open an Emacs shell buffer.

Otherwise, devshell will launch an external terminal app."
  :type '(boolean)
  :group 'bitbake)

(defcustom bitbake-devshell-function 'bitbake-devshell-shell
  "Function to call to run a devshell.

The function is called with two arguments: the title of a new buffer,
and an initial command to run. `default-directory' will be bound to the
intended working directory of the devshell."
  :type '(choice (function-item bitbake-devshell-shell)
                 (function-item bitbake-devshell-term)
                 (restricted-sexp :match-alternatives
                                  (functionp)))
  :group 'bitbake)

(defcustom bitbake-yocto-manual-url
  "https://docs.yoctoproject.org/ref-manual/variables.html#term-%s"
  "URL of the Yocto reference manual.

Should be a format string with one '\\=%s' directive for a variable name."
  :type '(string)
  :group 'bitbake)

;;; Local variables
(defvar bitbake-current-server-host nil "The actual host name or IP address of the bitbake server instance.")
(defvar bitbake-current-server-port nil "The actual port of the bitbake server instance.")
(defvar bitbake-current-poky-directory nil "The actual directory holding bitbake binaries.")
(defvar bitbake-current-build-directory nil "The actual build directory.")
(defvar bitbake-recipes-cache '() "Cache of bitbake recipes.")
(defvar bitbake-recipe-variables-cache '() "Cache of bitbake recipe variables.")
(defvar bitbake-recipe-tasks-cache '() "Cache of bitbake recipe variables.")
(defvar bitbake-recipe-history nil "History list of recipe names entered in the minibuffer.")
(defvar bitbake-image-history nil "History list of image names entered in the minibuffer.")
(defvar bitbake-task-history nil "History list of task names entered in the minibuffer.")
(defvar bitbake-task-queue nil "List of task left to execute.")
(defvar bitbake-current-task nil "The currently active task.")
(defvar bitbake-current-command nil "The running command.")
(defvar bitbake-last-disk-image nil "The last build disk image file.")
(defvar bitbake-buffer-prompt "/////---bitbake$ " "The prompt used in the bitbake buffer.")
(defvar bitbake-buffer-prompt-regexp (concat "^" (regexp-quote bitbake-buffer-prompt)) "A regexp matching the prompt.")
(defvar bitbake-layers-cache nil "Cache of bitbake layers.")
(defconst bitbake-load-base (file-name-directory load-file-name))
(defconst bitbake-devshell-fragment "bitbake-el-devshell.conf"
  "Config fragment to use emacsclient in devshell command.")
(defconst bitbake-devshell-launcher "devshell-launcher.sh"
  "Launcher script to run emacsclient in OE_TERMINAL_CUSTOMCMD.")
(make-variable-buffer-local 'bitbake-last-disk-image)

;;; Minor mode functions

(defun bitbake-read-poky-directory ()
  "Read the poky directory."
  (read-directory-name "Poky directory: " bitbake-poky-directory bitbake-poky-directory))

(defun bitbake-read-build-directory ()
  "Read the build directory."
  (read-directory-name "Build directory: " bitbake-build-directory bitbake-build-directory))

(defun bitbake-wait-for-prompt ()
  "Wait for BITBAKE-BUFFER-PROMPT to appear in current buffer."
  (let ((bol))
    (save-excursion
      (beginning-of-line)
      (setq bol (point)))
    (while (not (search-backward bitbake-buffer-prompt bol t))
      (sleep-for 0.3))
    (goto-char (process-mark (get-buffer-process (current-buffer))))))

(defun bitbake-buffer ()
  "Fetch or create the bitbake buffer."
  (let ((buffer-name "*bitbake*")
        (default-directory bitbake-build-directory))
    (or (get-buffer buffer-name)
        (progn
          (let ((buffer (shell buffer-name)))
            (with-current-buffer buffer
              (setq-local comint-move-point-for-output t)
              (setq-local comint-prompt-regexp bitbake-buffer-prompt-regexp)
              (process-send-string (current-buffer) (format "export PS1='%s' && cd %s\n" bitbake-buffer-prompt default-directory))
              (bitbake-wait-for-prompt)
              (comint-send-input nil t)
              (erase-buffer)
              (bitbake-wait-for-prompt)
              buffer))))))

(defun bitbake-capture-buffer ()
  "Fetch or create the bitbake capture buffer."
  (get-buffer-create "*bitbake-temp*"))

(defun bitbake-add-path (path)
  "Add PATH to the current path."
  (let ((components (s-split ":" (or (getenv "PATH") "") t)))
    (unless (member path components)
      (setenv "PATH" (s-join ":" (-distinct (cons path components)))))))

(defun bitbake-remove-path (path)
  "Remove PATH from the current path."
  (let ((components (s-split ":" (or (getenv "PATH") "") t)))
    (when (member path components)
      (setenv "PATH" (s-join ":" (delete path components))))))

(defun bitbake-setup-environment (poky-directory build-directory)
  "Add POKY-DIRECTORY to PATH environment variable and set BBPATH to BUILD-DIRECTORY."
  (setenv "BBPATH" build-directory)
  (setenv "BUILDDIR" build-directory)
  (setenv "EMACS_BITBAKE_DEVSHELL" (expand-file-name bitbake-devshell-launcher
                                                     bitbake-load-base))
  (bitbake-add-path (concat poky-directory
                            bitbake-script-directory))
  (bitbake-add-path (concat poky-directory
                            bitbake-bin-directory))
  (message "Bitbake: updated path to %s" (getenv "PATH")))

(defun bitbake-cleanup-environment (poky-directory)
  "Remove POKY-DIRECTORY from PATH environment variable and unset BBPATH."
  (setenv "BBPATH")
  (setenv "BUILDDIR")
  (setenv "EMACS_BITBAKE_DEVSHELL")
  (bitbake-remove-path (concat poky-directory
                               bitbake-script-directory))
  (bitbake-remove-path (concat poky-directory
                               bitbake-bin-directory)))

(defun bitbake-shell-command (command)
  "Run shell COMMAND in bitbake buffer.

Capture output in *bitbake-temp*."
  (with-current-buffer (bitbake-capture-buffer)
    (setq-local comint-prompt-regexp bitbake-buffer-prompt-regexp)
    (erase-buffer))
  (with-current-buffer (bitbake-buffer)
    (setq-local comint-prompt-regexp bitbake-buffer-prompt-regexp)
    (setq bitbake-current-command command)
    (comint-redirect-send-command (format "echo '%s' && %s 2>&1" command command) (bitbake-capture-buffer) t t)))

;;;###autoload
(defun bitbake-start-server (poky-directory build-directory)
  "Start a bitbake server instance.

Start a bitbake server using POKY-DIRECTORY to find the bitbake
binary and BUILD-DIRECTORY as the build directory."
  (interactive (let ((ask (consp current-prefix-arg)))
                 (list (if (or ask (not bitbake-poky-directory))
                           (bitbake-read-poky-directory)
                         bitbake-poky-directory)
                       (if (or ask (not bitbake-build-directory))
                           (bitbake-read-build-directory)
                         bitbake-build-directory))))

  ;; stop server if running
  (when (getenv "BBSERVER")
    (message "Stopping other instance of bitbake server")
    (bitbake-stop-server))

  ;; cleanup caches
  (setq bitbake-recipes-cache '()
        bitbake-recipe-variables-cache '()
        bitbake-recipe-tasks-cache '()
        bitbake-layers-cache '())

  ;; prepare environment
  (setq bitbake-current-server-host (or bitbake-server-host "localhost")
        bitbake-current-server-port (or bitbake-server-port (+ 1024 (random (- 65535 1024))))
        bitbake-current-poky-directory (file-name-as-directory poky-directory)
        bitbake-current-build-directory (file-name-as-directory build-directory))
  (bitbake-setup-environment  bitbake-current-poky-directory bitbake-current-build-directory)

  ;; start the server
  (shell-command (format "cd /tmp && bitbake -B %s:%s --server-only"
                         bitbake-current-server-host bitbake-current-server-port))

  (setenv "BBSERVER" (format "%s:%s" bitbake-current-server-host bitbake-current-server-port)))

(defun bitbake-stop-server ()
  "Stop the bitbake server instance."
  (interactive)
  (unless (getenv "BBSERVER")
    (user-error "No bitbake server running"))
  (message "Bitbake: stopping server")
  (call-process-shell-command (format "bitbake --kill-server --remote-server=%s" (getenv "BBSERVER")))
  (bitbake-cleanup-environment bitbake-current-poky-directory)
  (message "Bitbake: server is down, cleaning up")
  (setenv "BBSERVER")
  (setq bitbake-recipes-cache nil
        bitbake-recipe-variables-cache nil
        bitbake-recipe-tasks-cache nil
        bitbake-layers-cache nil
        bitbake-current-server-host nil
        bitbake-current-server-port nil
        bitbake-current-poky-directory nil
        bitbake-current-build-directory nil
        bitbake-current-task nil
        bitbake-task-queue nil)
  (setq-local kill-buffer-query-functions '())
  (let* ((buffer (get-buffer "*bitbake*"))
         (process (get-buffer-process buffer)))
    (when process (kill-process process))
    (when buffer (kill-buffer buffer))))

(defun bitbake-parse-recipes (buffer)
  "Parse recipes in BUFFER."
  (with-current-buffer buffer
    (let ((recipes))
      (while (re-search-forward "^\\([^[:blank:]]+\\) +\\([[:digit:]]*\\):\\([^[:blank:]]+\\)-\\([^[:blank:]]+\\)" nil t)
          (setq recipes (cons (list (match-string 1) (match-string 2) (match-string 3) (match-string 4)) recipes)))
        recipes)))

(defun bitbake-s-command (command message)
  "Run COMMAND synchronously, sending output to bitbake-capture-buffer.

If COMMAND fails, raise `user-error' with MESSAGE."
  (with-current-buffer (bitbake-capture-buffer)
    (goto-char (point-max))
    (let* ((p (point))
           (rc (call-process-shell-command
                command
                nil
                (list (current-buffer) t))))
      (if (not (equal 0 rc))
          (error "%s: %s"
                 message
                 (if (getenv "BBSERVER")
                     (format "see %s for details" (buffer-name))
                   "server is not started"))
        ;; Mark the output region for the parser function like
        ;; `shell-command' does.
        (set-mark (point))
        (goto-char p)))))

(defun bitbake-fetch-recipes ()
  "Fetch the availables bitbake recipes for the POKY-DIRECTORY and the BUILD-DIRECTORY."
  (message "Bitbake: fetching recipes")
  (bitbake-s-command "bitbake -s" "Unable to fetch recipes")
  (bitbake-parse-recipes (bitbake-capture-buffer)))

(defun bitbake-recipes (&optional fetch)
  "Return the bitbake recipes list.

If FETCH is non-nil, invalidate cache and fetch the recipes list again."
  (when (or fetch (not bitbake-recipes-cache))
    (setq bitbake-recipes-cache (bitbake-fetch-recipes)))
  bitbake-recipes-cache)

(defun bitbake-recipe-info (recipe)
  "Return the recipe list associated to RECIPE."
  (or (assoc recipe (bitbake-recipes)) (user-error "Unknown recipe %s" recipe)))

(defun bitbake-recipe-names ()
  "Return the list of available recipe names."
  (let (names)
    (dolist (recipe (bitbake-recipes) names)
      (setq names (cons (car recipe) names)))))

(defun bitbake-buffer-recipe (&optional buffer)
  "Return a recipe name for the current buffer or BUFFER if given."
  (setq buffer (or buffer (current-buffer)))
  (when (stringp (buffer-file-name buffer))
    (if (string-match "\\([^/_]+\\)\\(_[^_]+\\)?\\.bb\\(append\\)?\\'"
                      (buffer-file-name buffer))
        (match-string 1
                      (buffer-file-name buffer))
      (let ((bitbake-directory (locate-dominating-file (buffer-file-name buffer)
                                                       (lambda (dir)
                                                         (and (file-directory-p dir)
                                                             (directory-files dir t "\\.bb\\(append\\)?\\'"))))))
        (when bitbake-directory
          (let ((bitbake-file (car (directory-files bitbake-directory t "[^/_]+\\(_[^_]+\\)?\\.bb\\(append\\)?\\'"))))
            (with-temp-buffer
              (goto-char (point-min))
              (insert bitbake-file)
              (goto-char (point-min))
              (if (re-search-forward "\\([^/_]+\\)\\(_[^_]+\\)?\\.bb\\(append\\)?\\'" nil t)
                  (match-string 1)))))))))

(defun bitbake-read-recipe ()
  "Read a recipe name in the minibuffer, with completion."
  (let ((default (or (bitbake-buffer-recipe) (car-safe bitbake-recipe-history))))
    (completing-read "Recipe: " (bitbake-recipe-names) nil t default 'bitbake-recipe-history)))

(defun bitbake-image-names ()
  "Return the list of available image names."
  (let (names)
    (dolist (recipe (bitbake-recipes) names)
      (if (string-match ".*-image\\(-.*\\|$\\)" (car recipe))
          (setq names (cons (car recipe) names))))))

(defun bitbake-read-image ()
  "Read a image name in the minibuffer, with completion."
  (completing-read "Image: " (bitbake-image-names) nil t (car-safe bitbake-image-history) 'bitbake-image-history))

(defun bitbake-parse-recipe-tasks (buffer)
  "Parse the list of recipe tasks in BUFFER."
  (with-current-buffer buffer
    (let ((case-fold-search nil))
      (when (re-search-forward ".*ERROR.*: \\(\x1b\\[..?m\\)?\\(.*\\)\\(\x1b\\[..?m\\)?" nil t)
        (error (format "Bitbake: unable to fetch tasks - %s" (match-string 2)))))
    (let ((tasks))
      (while (re-search-forward "^do_\\([^[:blank:]\n]+\\)" nil t)
        (setq tasks (cons (match-string 1) tasks)))
      tasks)))

(defun bitbake-fetch-recipe-tasks (recipe)
  "Fetch the list of bitbake tasks for RECIPE."
  (message "Bitbake: fetching recipe %s tasks" recipe)
  (bitbake-s-command (format "bitbake %s -c listtasks" recipe) "Unable to fetch tasks")
  (bitbake-parse-recipe-tasks (bitbake-capture-buffer)))

(defun bitbake-recipe-tasks (recipe &optional fetch)
  "Return the bitbake tasks for RECIPE.

If FETCH is non-nil, invalidate cache and fetch the tasks again."
  (when (or fetch (not (assoc recipe bitbake-recipe-tasks-cache)))
    (setq bitbake-recipe-tasks-cache
          (cons (list recipe (bitbake-fetch-recipe-tasks recipe))
                (assq-delete-all recipe bitbake-recipe-tasks-cache))))
  (cadr (assoc recipe bitbake-recipe-tasks-cache)))

(defun bitbake-read-tasks (recipe)
  "Read a task name in the minibuffer, with completion for task RECIPE."
  (let ((tasks (bitbake-recipe-tasks recipe)))
    (completing-read "Task: " tasks nil t (car-safe bitbake-task-history) 'bitbake-task-history)))

(defun bitbake-parse-recipe-variables (buffer)
  "Parse bitbake variables BUFFER."
  (with-current-buffer buffer
    (let ((start (point))
          (limit (mark)))
      (re-search-forward "^[[:alnum:]_:]+()[[:space:]]+{")
      (beginning-of-line)
      (let ((variables))
        (goto-char start)
        (while (re-search-forward "^\\([[:alnum:]~+.${}/_:-]+\\)=\"\\([^\"]*\\)" limit t)
          (let ((name (substring-no-properties (match-string 1)))
                (value (substring-no-properties (match-string 2))))
            (while (equal (string (char-before)) "\\")
              (re-search-forward "\\(\"[^\"]*\\)" limit t)
              (setq value (concat (substring value 0 -1) (substring-no-properties (match-string 1)))))
            (setq variables (cons (cons name value) variables))))
        variables))))

(defun bitbake-fetch-recipe-variables (recipe)
  "Fetch bitbake variables for RECIPE."
  (message "Bitbake: fetching recipe %s variables" recipe)
  (bitbake-s-command (format "bitbake -e %s" recipe) "Unable to fetch variables")
  (bitbake-parse-recipe-variables (bitbake-capture-buffer)))

(defun bitbake-recipe-variables (recipe &optional fetch)
  "Return the bitbake variables for RECIPE.

If FETCH is non-nil, invalidate cache and fetch the variables again."
  (when (or fetch (not (assoc recipe bitbake-recipe-variables-cache)))
    (setq bitbake-recipe-variables-cache
          (cons (list recipe (bitbake-fetch-recipe-variables recipe))
                (assq-delete-all recipe bitbake-recipe-variables-cache))))
  (cadr (assoc recipe bitbake-recipe-variables-cache)))

(defun bitbake-recipe-variable (variable recipe &optional fetch)
  "Return the value of VARIABLE for RECIPE.

If FETCH is non-nil, invalidate cache and fetch the variables again."
  (cdr (assoc variable (bitbake-recipe-variables recipe fetch))))

(defun bitbake-uuid ()
  "Generate a random UUID."
  (format "%04x%04x-%04x-%04x-%04x-%06x%06x"
           (random (expt 16 4))
           (random (expt 16 4))
           (random (expt 16 4))
           (random (expt 16 4))
           (random (expt 16 4))
           (random (expt 16 6))
           (random (expt 16 6))))

(defun bitbake-recipe-taint-task (recipe task)
  "Taint RECIPE TASK as a workaround for bitbake -f not working in server mode."
  (let ((taint-file-name (format "%s.do_%s.taint" (bitbake-recipe-variable "STAMP" recipe) task)))
    (with-temp-file taint-file-name
      (insert (bitbake-uuid)))))

(defun bitbake-schedule-queue ()
  "Schedule the next task in queue."
  (when bitbake-current-command
    (message "Bitbake: command \"%s\" finished" bitbake-current-command)
    (with-current-buffer (bitbake-capture-buffer)
      (goto-char (point-min))
      (while (re-search-forward "^[| ]*ERROR: \\([^(]+\\)\\( (log file is located at \\(.*\\))\\)?$" nil t)
        (message "Bitbake: error - %s" (match-string 1))
        (let ((log-file (match-string 3)))
          (if log-file
              (find-file log-file)))))
    (setq bitbake-current-command nil))
  (message "Bitbake: scheduling queue")
  (with-current-buffer (bitbake-buffer)
    (let ((task (car bitbake-task-queue)))
      (when task
        (setq bitbake-task-queue (cdr bitbake-task-queue)
              bitbake-current-task task)
        (add-hook 'comint-redirect-hook 'bitbake-schedule-queue nil t)
        (message "Bitbake: running task")
        (run-at-time 0 nil task))
      (unless task
        (message "Bitbake: task queue empty")
        (setq bitbake-current-task nil)
        (remove-hook 'comint-redirect-hook 'bitbake-schedule-queue t)
        ))))

(defmacro bitbake-command (&rest body)
  "Create a command to execute BODY and put it in the queue."
  (declare (indent 0))
  `(bitbake-queue-command
    (lambda ()
      (with-current-buffer (bitbake-buffer)
        (condition-case err
            (progn
              (setq bitbake-current-command nil)
              (progn ,@body)
              (unless bitbake-current-command
                (bitbake-schedule-queue)))
          (error (bitbake-reset-queue)
                 (message "Bitbake: error - %s." (error-message-string err))))))))

(defun bitbake-run-queue ()
  "Maybe run next process in queue if no other task is active."
  (unless bitbake-current-task
    (message "Bitbake: no running tasks, scheduling queue")
    (bitbake-schedule-queue)))

(defun bitbake-queue-command (task)
  "Queue TASK for running in bitbake buffer."
  (message "Bitbake: queuing command")
  (setq bitbake-task-queue (append bitbake-task-queue (list task)))
  (bitbake-run-queue))

(defun bitbake-reset-queue ()
  "Reset task queue."
  (interactive)
  (setq bitbake-task-queue nil
        bitbake-current-task nil))

;;;###autoload
(defun bitbake-task (task recipe &optional force)
  "Run bitbake TASK on RECIPE.

If FORCE is non-nil, force running the task."
  (interactive (let* ((recipe (bitbake-read-recipe))
                      (task (bitbake-read-tasks recipe)))
                 (list task recipe (consp current-prefix-arg))))
  (bitbake-command
    (when force
      (bitbake-recipe-taint-task recipe task))
    (bitbake-shell-command (format "bitbake %s %s %s -c %s"
                                   recipe
                                   (if force "-f" "")
                                   (bitbake--devshell-argument)
                                   task))))

;;;###autoload
(defun bitbake-recipe (recipe)
  "Run bitbake RECIPE."
  (interactive (list (bitbake-read-recipe)))
  (bitbake-command
    (bitbake-shell-command (format "bitbake %s " recipe))))

;;;###autoload
(defun bitbake-clean (recipe)
  "Run bitbake clean on RECIPE."
  (interactive (list (bitbake-read-recipe)))
  (bitbake-task "clean" recipe t))

;;;###autoload
(defun bitbake-compile (recipe)
  "Run bitbake compile on RECIPE."
  (interactive (list (bitbake-read-recipe)))
  (bitbake-task "compile" recipe t))

;;;###autoload
(defun bitbake-install (recipe)
  "Run bitbake install on RECIPE."
  (interactive (list (bitbake-read-recipe)))
  (bitbake-task "install" recipe t))

;;;###autoload
(defun bitbake-fetch (recipe)
  "Run bitbake fetch on RECIPE."
  (interactive (list (bitbake-read-recipe)))
  (bitbake-task "fetch" recipe t))

;;;###autoload
(defun bitbake-recompile (recipe)
  "Run bitbake clean compile and install on RECIPE."
  (interactive (list (bitbake-read-recipe)))
  (bitbake-task "cleanall" recipe)
  (bitbake-task "fetch" recipe)
  (bitbake-recipe recipe))

;;;###autoload
(defun bitbake-deploy (recipe)
  "Deploy artifacts of RECIPE to bitbake-deploy-ssh host."
  (interactive (list (bitbake-read-recipe)))
  (bitbake-command
    (let ((image (bitbake-recipe-variable "D" recipe)))
      (message "Duma: deploying %s" recipe)
      (bitbake-shell-command (format "tar -C %s -cf - . | ssh %s tar -C / -xf -" image bitbake-deploy-ssh-host)))))

;;;###autoload
(defun bitbake-recompile-deploy (recipe)
  "Recompile RECIPE and deploy its artifacts."
  (interactive (list (bitbake-read-recipe)))
  (bitbake-recompile recipe)
  (bitbake-deploy recipe))

;;;###autoload
(defun bitbake-image (image &optional force)
  "Run bitbake IMAGE.

If FORCE is non-nil, force rebuild of image,"
  (interactive (list (bitbake-read-image) (consp current-prefix-arg)))
  (bitbake-command
    (when force
      (bitbake-recipe-taint-task image "rootfs"))
    (bitbake-shell-command (format "bitbake %s" image))))

(defun bitbake-workdir (recipe)
  "Open RECIPE workdir."
  (interactive (list (bitbake-read-recipe)))
  (find-file (bitbake-recipe-variable "WORKDIR" recipe)))

(defun bitbake-file (recipe)
  "Open RECIPE bitbake file."
  (interactive (list (bitbake-read-recipe)))
  (find-file (bitbake-recipe-variable "FILE" recipe)))

(defun bitbake-rootfs (image)
  "Open IMAGE root fs."
  (interactive (list (bitbake-read-image)))
  (find-file (bitbake-recipe-variable "IMAGE_ROOTFS" image)))

(defun wic-read-definition-file ()
  "Read path to a wic wks definition file."
  (if bitbake-wic-definition-file
      (if (file-name-absolute-p bitbake-wic-definition-file) bitbake-wic-definition-file
        (format "%s%s" bitbake-current-poky-directory bitbake-wic-definition-file))
    (read-file-name "Definition file: " bitbake-current-poky-directory nil t nil
                    (lambda (name)
                      (or (file-directory-p name)
                          (string-match "\\.wks\\'" name))))))

;;;###autoload
(defun bitbake-wic-create (wks image)
  "Run wic WKS -e IMAGE."
  (interactive (list (wic-read-definition-file)
                     (bitbake-read-image)))
  (let ((rootfs (bitbake-recipe-variable "IMAGE_ROOTFS" image))
        (kernel (bitbake-recipe-variable "STAGING_KERNEL_DIR" image))
        (_hdddir (bitbake-recipe-variable "HDDDIR" image))
        (staging-data (bitbake-recipe-variable "STAGING_DATADIR" image))
        (native-sysroot (bitbake-recipe-variable "STAGING_DIR_NATIVE" image))
        (deploy (bitbake-recipe-variable "DEPLOY_DIR_IMAGE" image)))
    (bitbake-command
      (bitbake-shell-command (format "wic create %s -r %s -b %s -k %s -n %s -o %s"
                                     wks rootfs staging-data kernel native-sysroot deploy)))
    (bitbake-command
      (let (disk-image)
        (with-current-buffer (bitbake-capture-buffer)
          (goto-char (point-min))
          (unless (re-search-forward "The new image(s) can be found here:\n *\\(.*\\)" nil t)
            (error "Unable to execute wic command, see *bitbake* for details"))
          (setq disk-image (match-string 1)))
        (message "Disk image %s created" disk-image)
        (setq bitbake-last-disk-image disk-image)))))

;;;###autoload
(defun bitbake-hdd-image (wks image)
  "Create an hdd image using wic based on WKS definition file and bitbake IMAGE."
  (interactive (list (wic-read-definition-file)
                     (bitbake-read-image)))
  (bitbake-image image)
  (bitbake-wic-create wks image))

;;;###autoload
(defun bitbake-flash-image (wks image)
  "Create an hdd image using wic and flash it on bitbake-flash-device.

The hdd image is based on WKS definition file and bitbake IMAGE, see `bitbake-hdd-image'."
  (interactive (list (wic-read-definition-file)
                     (bitbake-read-image)))
  (bitbake-hdd-image wks image)
  (bitbake-command
    (when (and (file-exists-p bitbake-flash-device) bitbake-last-disk-image)
      (message "Bitbake: copy image to %s" bitbake-flash-device)
      (bitbake-shell-command (format "dd if=%s of=%s bs=32M" bitbake-last-disk-image bitbake-flash-device)))))


(defun bitbake-create-bbappend (recipe layer)
  "Visit a .bbappend file for RECIPE in LAYER."
  (interactive
   (let ((recipe (bitbake-read-recipe)))
     (list recipe
           (bitbake-read-layer (format "Create %s.bbappend in layer: "
                                       recipe)))))
  (let* ((recipe-path (expand-file-name
                       (bitbake-recipe-variable "FILE" recipe)))
         (orig-layer (-find (lambda (l)
                              (let ((local-path (cadr l)))
                                (string-prefix-p local-path
                                                 recipe-path)))
                            (bitbake-layer-names)))
         (bbappend-path (concat (file-remote-p bitbake-current-poky-directory)
                                (cadr (assoc layer (bitbake-layer-names)))
                                (file-name-directory
                                 (string-remove-prefix (cadr orig-layer)
                                                       recipe-path)))))
    (make-directory bbappend-path t)
    (find-file (file-name-concat bbappend-path
                                 (format "%s_%%.bbappend"
                                        recipe)))))

;;; bitbake-layers

(defun bitbake-parse-layers (buffer)
  "Parse the list of layers in BUFFER."
  (with-current-buffer buffer
    (unless (re-search-forward "^=+$" nil t)
      (error "Unrecognized output from bitbake-layers"))
    (forward-line -1)
    (let* (layers
           (headers (let ((l (buffer-substring-no-properties
                              (line-beginning-position)
                              (line-end-position))))
                      (string-split l)))
           (path-i (-find-index (lambda (h) (string= h "path"))
                                headers)))
      (forward-line 2)
      (while (not (= (point) (point-max)))
        (let ((l (string-split
                  (buffer-substring-no-properties
                   (line-beginning-position)
                   (line-end-position)))))
          (when (= (length l) (length headers))
            ;; get rid of ../ and ./ path elements
            (setf (nth path-i l)
                  (expand-file-name (nth path-i l)))
            (push l layers))
          (forward-line 1)))
      (cons headers (nreverse layers)))))

(defun bitbake-fetch-layers ()
  "Fetch the list of layers."
  (message "Bitbake: fetching layers")
  (bitbake-s-command (format "bitbake-layers show-layers 2>&1")
                     "Unable to fetch layers")
  (bitbake-parse-layers (bitbake-capture-buffer)))

(defun bitbake-layer-names (&optional fetch)
  "Return a list of bitbake layers.

If FETCH is non-nil, invalidate cache and fetch the layers list again."
  (when (or fetch (not bitbake-layers-cache))
    (setq bitbake-layers-cache (bitbake-fetch-layers)))
  bitbake-layers-cache)

(defun bitbake-read-layer (&optional prompt default)
  "Read the name of a Bitbake layer from the minibuffer with completion."
  (completing-read prompt
                   (mapcar #'car (bitbake-layer-names))
                   nil
                   t
                   default
                   'bitbake-layer-history))

(defun bitbake-buffer-layer (&optional buffer)
  "Return the name of the layer containing the recipe in BUFFER.

Defaults to the current buffer."
  (setq buffer (or buffer (current-buffer)))
  (when-let* ((file (buffer-file-name buffer))
              (layer (-find (lambda (l)
                              (let ((local-path (cadr l)))
                                (string-prefix-p local-path
                                                 (string-remove-prefix
                                                  (file-remote-p file)
                                                  file))))
                            (bitbake-layer-names))))
    (car layer)))

(defun bitbake-add-layer (path &optional name)
  "Add PATH as a layer to the bitbake repo.

With a prefix arg, prompt for the layer name, defaulting to basename of PATH."
  (interactive
   (list (read-directory-name "New layer: "
                              (file-name-parent-directory
                               bitbake-current-poky-directory))))
  (unless name
    (setq name
          (if current-prefix-arg
              (read-string "Layer name: ")
            (file-name-base path))))
  (let* ((full-path (expand-file-name path))
         (local-path (if (file-remote-p bitbake-current-poky-directory)
                         (string-remove-prefix
                          (file-remote-p bitbake-current-poky-directory)
                          full-path)
                       full-path)))
    (unless (file-exists-p full-path)
      (message "bitbake-add-layer: Layer directory %s does not exist; creating it"
               full-path)
      (bitbake-s-command (format "bitbake-layers create-layer -i %s %s 2>&1"
                                 (shell-quote-argument name)
                                 (shell-quote-argument
                                  local-path))
                         "Error creating layer"))
    (bitbake-s-command (format "bitbake-layers add-layer %s 2>&1"
                               (shell-quote-argument
                                local-path))
                       "Unable to add layer"))
  (with-current-buffer "*bitbake-layers*"
    (tabulated-list-revert)))

(defun bitbake-remove-layer (layer)
  "Remove LAYER from the bitbake repo."
  (interactive
   (let ((default (and (eq major-mode 'bitbake-layers-mode)
                       (tabulated-list-get-entry))))
     (list (bitbake-read-layer "Remove layer: "
                               (and default
                                    (aref default 0))))))
  (pcase (assoc layer bitbake-layers-cache #'equal)
    (`(,_ ,path ,_priority)
     (bitbake-s-command (format "bitbake-layers remove-layer %s 2>&1"
                                (shell-quote-argument path))
                        "Unable to remove layer")
     (let ((remote-path (concat (file-remote-p bitbake-current-poky-directory)
                                path)))
       (when (yes-or-no-p (format "Delete %s?" remote-path))
         (delete-directory remote-path t)))
     (with-current-buffer "*bitbake-layers*"
       (tabulated-list-revert)))))

(defun bitbake--format-layer (l)
  (pcase-let ((`(,name ,path ,priority) l))
    (vector name
            (list path
                  'bitbake-layer-path (concat (file-remote-p bitbake-current-poky-directory)
                                              path)
                  'action 'bitbake--find-layer
                  'help-echo (format "Open %s" path))
            priority)))

(defun bitbake--find-layer (button)
  (find-file (button-get button 'bitbake-layer-path)))

(defun bitbake-layers-refresh ()
  "Refresh the contents of \"*bitbake-layers*\" buffer."
  (let* ((layers (bitbake-layer-names t))
         (headers (car layers))
         (rows (cdr layers))
         (widths (mapcar (lambda (col)
                           (seq-reduce (lambda (max-width x)
                                         (max max-width (length x)))
                                       col
                                       0))
                         (apply '-zip-lists rows))))
    (setq tabulated-list-entries
          (mapcar (lambda (l)
                    (list (car l)
                          (bitbake--format-layer l)))
                  rows)
          tabulated-list-sort-key '("priority" . t)
          tabulated-list-format (vconcat
                                 (cl-mapcar (lambda (label width)
                                              (list label width #'value<))
                                            headers
                                            widths)))))

(defvar-keymap bitbake-layers-mode-map
  "a" 'bitbake-add-layer
  "d" 'bitbake-remove-layer)

(define-derived-mode bitbake-layers-mode tabulated-list-mode "Bitbake Layers"
  :interactive nil
  "Major mode for displaying the output of bitbake-layers.
\\<bitbake-layers-mode-map>"
  (add-hook 'tabulated-list-revert-hook #'bitbake-layers-refresh nil t)
  (bitbake-layers-refresh)
  (tabulated-list-init-header))

;;;###autoload
(defun bitbake-layers ()
  "List all layers installed in the current Bitbake repo."
  (interactive)
  (pop-to-buffer "*bitbake-layers*")
  (bitbake-layers-mode)
  (tabulated-list-print))

;;; devshell backend.

(defvar-local bitbake-devshell-flag-file nil
  "The name of a file to delete when the current buffer is killed.")

(defun bitbake-devshell (flag-file)
  "Open a terminal buffer for the do_devshell task.

Expects three arguments in `server-eval-args-left': the buffer name; an
initial command to run; and a working directory. FLAG-FILE is a temp
file to delete, which signals bitbake that the shell is finished.

To specify which terminal mode to use (`shell-mode', `term-mode', etc.),
customize `bitbake-devshell-function'."
  (condition-case err
      (let* ((title (pop server-eval-args-left))
             (command (pop server-eval-args-left))
             (cwd (pop server-eval-args-left)))
        (unless (and title command cwd)
          (error "missing arguments"))
        (message "Bitbake: devshell '%s' in '%s'" title cwd)
        (let ((default-directory cwd))
          (funcall bitbake-devshell-function (format "*%s*" title) command)
          (setq-local bitbake-devshell-flag-file flag-file))
        (add-hook 'kill-buffer-hook 'bitbake-devshell-finish)
        (message "Bitbake: When finished, kill this buffer to complete the devshell task."))
    (error
     (delete-file flag-file)
     (signal (car err)
             (cons "Bitbake: error setting up devshell" (cdr err))))))

(defun bitbake-devshell-finish ()
  (when bitbake-devshell-flag-file
    (message "Bitbake: cleaning up devshell buffer '%s'" (buffer-name))
    (delete-file bitbake-devshell-flag-file)))

(defun bitbake--devshell-argument ()
  (when bitbake-open-devshell-in-emacs
    (format "-R %s" (expand-file-name bitbake-devshell-fragment
                                      bitbake-load-base))))

(defun bitbake-devshell-shell (title command)
  "Open a `shell-mode' buffer for the devshell task."
  (shell (get-buffer-create title))
  (comint-send-string (get-buffer-process (current-buffer))
                      (concat command "\n")))

(defun bitbake-devshell-term (title command)
  "Open a `term-mode' buffer for the devshell task."
  (term "bash")
  (term-send-string (get-buffer-process (current-buffer))
                    (concat command "\n"))
  (rename-buffer title))

;;; Mode definition

;;;###autoload
(defvar bitbake-minor-mode-map nil "Keymap for bitbake-host-mode.")

(setq bitbake-minor-mode-map nil)
(when (not bitbake-minor-mode-map)
  (setq bitbake-minor-mode-map (make-sparse-keymap))
  (define-key bitbake-minor-mode-map (kbd "C-c C-/ s") 'bitbake-start-server)
  (define-key bitbake-minor-mode-map (kbd "C-c C-/ k") 'bitbake-stop-server)
  (define-key bitbake-minor-mode-map (kbd "C-c C-/ r") 'bitbake-recompile)
  (define-key bitbake-minor-mode-map (kbd "C-c C-/ d") 'bitbake-recompile-deploy)
  (define-key bitbake-minor-mode-map (kbd "C-c C-/ f") 'bitbake-flash-image)
  (define-key bitbake-minor-mode-map (kbd "C-c C-/ t") 'bitbake-task)
  (easy-menu-define bitbake-menu bitbake-minor-mode-map
    "BitBake"
    '("BitBake"
      ["Start server"   bitbake-start-server]
      ["Stop server"    bitbake-stop-server ]
      ["Recipe"         bitbake-recipe]
      ["Task"           bitbake-task]
      ("Tasks"
       ["clean"         bitbake-clean]
       ["compile"       bitbake-compile]
       ["install"       bitbake-install]
       ["fetch"         bitbake-fetch]
       ["recompile"     bitbake-recompile]
       ["deploy"        bitbake-deploy]
       ["recompile, deploy" bitbake-recompile-deploy])
      ("Image"
       ["build"         bitbake-image]
       ["wic"           bitbake-wic-create]
       ["hdd"           bitbake-hdd-image]
       ["flash"         bitbake-flash-image]))))

(define-minor-mode bitbake-minor-mode
  "Toggle Bitake mode.

Interactively with no argument, this command toggles the mode.
A positive prefix argument enables the mode, any other prefix
argument disables it.  From Lisp, argument omitted or nil enables
the mode, `toggle' toggles the state."
  :init-value nil
  :lighter nil
  :keymap bitbake-minor-mode-map
  :group 'bitbake
  :global t)

(defun bitbake-comment-dwim (arg)
  "Comment or uncomment current line or region in a smart way.

For detail, see `comment-dwim'."
  (interactive "*P")
  (require 'newcomment)
  (let ((comment-start "#") (comment-end ""))
    (comment-dwim arg)))

(defvar bitbake-syntax-table
  (let ((table (make-syntax-table)))
    (modify-syntax-entry ?# "< b" table)
    (modify-syntax-entry ?\n "> b" table)
    table)
  "Syntax table used in `bitbake-host-mode'.")

(defvar bitbake-font-lock-defaults
  `((;; addtask x before y after z
     ("^\\(addtask\\)"
      (0 font-lock-keyword-face)
      ("\\_<\\(before\\|after\\)\\_>"
       nil nil (0 font-lock-keyword-face)))
     ;; anonymous python
     ("\\(python\\) *( *) *{"
      1 font-lock-keyword-face)
     ;; fakeroot python do_foo() {
     ("^\\(fakeroot *\\)?\\(python *\\)?\\([a-zA-Z0-9\-_+.${}/~:]+\\) *( *) *{"
      (1 '(face font-lock-keyword-face) nil t)
      (2 '(face font-lock-keyword-face) nil t)
      (3 '(face font-lock-function-name-face)))
     ;; other keywords
     ("^\\(include\\(_all\\)?\\|require\\|inherit\\(_defer\\)?\\|deltask\\|export\\|unset\\)\\_>" . font-lock-keyword-face)
     ;; do_deploy[depends] ??=
     ("^\\(export *\\)?\\([a-zA-Z0-9\-_+.${}/~]+\\(\\[[a-zA-Z0-9\-_+.${}/~]+\\]\\)?\\(:[a-zA-Z0-9\-_+.${}/~]+\\)*\\) *\\(=\\|\\?=\\|\\?\\?=\\|:=\\|+=\\|=+\\|.=\\|=.\\)" 2 font-lock-variable-name-face)
     )))

(defun bitbake-indent-line ()
  "Indent current line as bitbake code."
  (interactive)
  (beginning-of-line)
  (if (looking-back "\\\\\n")
      (indent-line-to tab-width)
    (indent-line-to 0)))

;; help

(defun bitbake-browse-variable-documentation (variable)
  "Browse Yocto reference manual for VARIABLE.

To use a specific version of the reference manual, customize `bitbake-yocto-manual-url'."
  (interactive (list (let ((var-at-point (save-excursion
                                           (save-match-data
                                             (re-search-backward "^\\|[[:space:]]")
                                             (and (looking-at "\\_<[_[:upper:]]+\\_>")
                                                  (match-string-no-properties 0))))))
                       (read-string (concat "Yocto/Bitbake variable"
                                            (if var-at-point
                                                (format " (default %s)" var-at-point)
                                              "")
                                            ": ")
                                    nil
                                    'bitbake-variable-documentation-history
                                    var-at-point))))
  (if (string-empty-p variable)
      (message "No variable specified.")
    (browse-url (format bitbake-yocto-manual-url variable))))

;;;###autoload
(define-derived-mode bitbake-host-mode prog-mode
  "A mode for editing bitbake recipe files."
  :syntax-table bitbake-syntax-table
  (setq font-lock-defaults bitbake-font-lock-defaults)
  (setq mode-name "BitBake")
  (set (make-local-variable 'indent-line-function) 'bitbake-indent-line)
  (define-key bitbake-host-mode-map [remap comment-dwim] 'bitbake-comment-dwim)
  (define-key bitbake-host-mode-map [(control c) (control f)] 'bitbake-browse-variable-documentation)
  (set (make-local-variable 'comment-start) "# ")
  (set (make-local-variable 'comment-end) "")
  )

(defconst bitbake-shell-regex "^\\(fakeroot[[:space:]]*\\)?\\([a-zA-Z0-9\-_+.${}/~:]+\\)[[:space:]]*([[:space:]]*)[[:space:]]*{")
(defconst bitbake-python-regex "^\\(fakeroot[[:space:]]*\\)?python[[:space:]]*\\([a-zA-Z0-9\-_+.${}/~:]+\\)?[[:space:]]*([[:space:]]*)[[:space:]]*{")
(defconst bitbake-python-def-regex "^def +[a-zA-Z0-9_]+[[:space:]]*([^)]*):")

(defconst bitbake-mode-file-regex "\\.\\(bb\\(append\\|class\\)?\\|inc\\)\\'")

(define-hostmode poly-bitbake-hostmode
  :name "bitbake"
  :mode 'bitbake-host-mode)

(define-innermode poly-bitbake-python-def-innermode
  :name "bitbake-python-def"
  :mode 'python-mode
  :head-mode 'body
  :head-matcher bitbake-python-def-regex
  :tail-matcher (cons "\\(\n\\)\\(^[^[:space:]\n]\\|\\'\\)" 1))

(define-innermode poly-bitbake-python-kw-innermode
  :name "bitbake-python-kw"
  :mode 'python-mode
  ; head and tail are not part of the body and an extra indentation
  ; level is needed
  :body-indent-offset 4
  :head-mode 'host
  :head-matcher bitbake-python-regex
  :tail-matcher "^}"
  :tail-mode 'host)

(define-innermode poly-bitbake-shell-innermode
  :name "bitbake-shell"
  :mode 'sh-mode
  :head-mode 'body
  :head-matcher bitbake-shell-regex
  :tail-matcher "^}")

(define-polymode bitbake-mode
  :hostmode 'poly-bitbake-hostmode
  ; NOTE: order matters; modes with most specific matchers are put first
  :innermodes '(poly-bitbake-python-def-innermode
                poly-bitbake-python-kw-innermode
                poly-bitbake-shell-innermode)
  :keymap bitbake-host-mode-map)

;; For compatibility with pre-polymode versions, and also because it's
;; the obvious name.
(defvaralias 'bitbake-mode-hook 'bitbake-host-mode-hook
  "Hook run after entering `bitbake-mode'.
Use this instead of `bitbake-host-mode-hook'.")

(add-to-list 'auto-mode-alist
             `(,bitbake-mode-file-regex . bitbake-mode))

(provide 'bitbake)

;;; bitbake.el ends here
