;;; racket-logger.el -*- lexical-binding: t; -*-

;; Copyright (c) 2013-2016 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.

;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode

;; License:
;; This 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 2, or (at your option)
;; any later version. This 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. See
;; http://www.gnu.org/licenses/ for details.

(require 'easymenu)
(require 'rx)
(require 'racket-custom)
(require 'racket-repl)

;; Need to define this before racket-logger-mode
(defvar racket-logger-mode-map
  (racket--easy-keymap-define
   '(("l"       racket-logger-topic-level)
     ("w"       toggle-truncate-lines)
     ("n"       racket-logger-next-item)
     ("p"       racket-logger-previous-item)
     ("g"       racket-logger-clear)
     ("x"       racket-logger-exit)
     ("C-c C-z" racket-repl))))

(easy-menu-define racket-logger-mode-menu racket-logger-mode-map
  "Menu for Racket logger mode."
  '("Racket"
    ["Configure Topic and Level" racket-logger-topic-level]
    ["Toggle Truncate Lines" toggle-truncate-lines]
    "---"
    ["Switch to REPL" racket-repl]
    "---"
    ["Clear and Reconnect" racket-logger-clear]
    ["Exit Logger" racket-logger-exit]))

(defconst racket-logger-font-lock-keywords
  (eval-when-compile
    `((,#'racket--font-lock-config . racket-logger-config-face)
      (,(rx bol "[  fatal]")       . racket-logger-fatal-face)
      (,(rx bol "[  error]")       . racket-logger-error-face)
      (,(rx bol "[warning]")       . racket-logger-warning-face)
      (,(rx bol "[   info]")       . racket-logger-info-face)
      (,(rx bol "[  debug]")       . racket-logger-debug-face)
      (,(rx bol ?\[ (+? anything) ?\] space
            (group (+? anything) ?:) space)
       1 racket-logger-topic-face))))

(defconst racket-logger--print-config-prefix
  "racket-logger-config:\n")

(defun racket--font-lock-config (limit)
  "Handle multi-line font-lock of the configuration info."
  (ignore-errors
    (when (re-search-forward (concat "^" racket-logger--print-config-prefix) limit t)
      (let ((md (match-data)))
        (goto-char (match-end 0))
        (forward-sexp 1)
        (setf (elt md 1) (point)) ;; set (match-end 0)
        (set-match-data md)
        t))))

(define-derived-mode racket-logger-mode special-mode "Racket-Logger"
  "Major mode for Racket logger output.
\\<racket-logger-mode-map>

The customization variable `racket-logger-config' determines the
levels for topics. During a session you may change topic levels
using `racket-logger-topic-level'.

For more information see:
  <https://docs.racket-lang.org/reference/logging.html>

\\{racket-logger-mode-map}
"
  (setq-local font-lock-defaults (list racket-logger-font-lock-keywords))
  (setq-local truncate-lines t))

(defvar racket-logger--buffer-name "*Racket Logger*")
(defvar racket-logger--process nil)
(defvar racket-logger--connect-timeout 3)

(defun racket-logger--connect ()
  (unless racket-logger--process
   (with-temp-message "Connecting to logger process..."
     (with-timeout (racket-logger--connect-timeout
                    (error "Could not connect; try `racket-run' first"))
       (while (not racket-logger--process)
         (condition-case ()
             (setq racket-logger--process
                   (let ((process-connection-type nil)) ;use pipe not pty
                     (open-network-stream "racket-logger"
                                          (get-buffer-create racket-logger--buffer-name)
                                          "127.0.0.1"
                                          (1+ racket-command-port))))
           (error (sit-for 0.1)))))
     (process-send-string racket-logger--process
                          (format "%S\n" racket--cmd-auth))
     (racket-logger--activate-config)
     (set-process-sentinel racket-logger--process
                           #'racket-logger--process-sentinel))))

(defun racket-logger--process-sentinel (proc change)
  (funcall (process-filter proc) proc change) ;display in buffer
  (unless (memq (process-status proc) '(run open connect))
    (setq racket-logger--process nil)))

(defun racket-logger--disconnect ()
  (when racket-logger--process
    (with-temp-message "Disconnecting from logger process..."
      (set-process-sentinel racket-logger--process (lambda (_p _c)))
      (delete-process racket-logger--process)
      (setq racket-logger--process nil))))

(defun racket-logger--activate-config ()
  "Send config to Racket process, and, display it in the buffer."
  (process-send-string racket-logger--process
                       (format "%S" racket-logger-config))
  (funcall (process-filter racket-logger--process)
           racket-logger--process
           (propertize (concat racket-logger--print-config-prefix
                               (pp-to-string racket-logger-config))
                       'font-lock-multiline t)))

(defun racket-logger--set (topic level)
  (unless (symbolp topic) (error "TOPIC must be symbolp"))
  (unless (symbolp level) (error "LEVEL must be symbolp"))
  (pcase (assq topic racket-logger-config)
    (`() (add-to-list 'racket-logger-config (cons topic level)))
    (v   (setcdr v level)))
  (racket-logger--activate-config))

(defun racket-logger--unset (topic)
  (unless (symbolp topic) (error "TOPIC must be symbolp"))
  (when (eq topic '*)
    (user-error "Cannot unset the level for the '* topic"))
  (setq racket-logger-config
        (assq-delete-all topic racket-logger-config))
  (racket-logger--activate-config))

(defun racket-logger--topics ()
  "Effectively (sort (dict-keys racket-logger-config))."
  (sort (mapcar (lambda (x) (format "%s" (car x)))
                racket-logger-config)
        #'string<))

(defun racket-logger--topic-level (topic not-found)
  "Effectively (dict-ref racket-logger-config topic not-found)."
  (or (cdr (assq topic racket-logger-config))
      not-found))

;;; commands

(defun racket-logger ()
  "Create the `racket-logger-mode' buffer and connect to logger output.

If the `racket-repl-mode' buffer is displayed in a window, split
that window and put the logger in the bottom window. Otherwise,
use `pop-to-buffer'."
  (interactive)
  ;; Create buffer if necessary
  (unless (get-buffer racket-logger--buffer-name)
    (with-current-buffer (get-buffer-create racket-logger--buffer-name)
      (racket-logger-mode))
    (racket-logger--connect))
  ;; Give it a window if necessary
  (unless (get-buffer-window racket-logger--buffer-name)
    (pcase (get-buffer-window racket-repl-buffer-name)
      (`() (pop-to-buffer (get-buffer racket-logger--buffer-name)))
      (win (set-window-buffer (split-window win)
                              (get-buffer racket-logger--buffer-name)))))
  ;; Select the window
  (select-window (get-buffer-window racket-logger--buffer-name)))

(defun racket-logger-exit ()
  "Disconnect, kill the buffer, and delete the window."
  (interactive)
  (when (y-or-n-p "Disconnect and kill buffer? ")
    (racket-logger--disconnect)
    (kill-buffer)
    (delete-window)))

(defun racket-logger-clear ()
  "Clear the buffer and reconnect."
  (interactive)
  (when (y-or-n-p "Clear buffer and reconnect? ")
    (let ((inhibit-read-only t))
      (delete-region (point-min) (point-max)))
    (racket-logger--disconnect)
    (racket-logger--connect)))

(defconst racket-logger--item-rx
  (rx bol ?\[ (0+ space) (or "fatal" "error" "warning" "info" "debug") ?\] space))

(defun racket-logger-next-item (&optional count)
  "Move point N items forward.

An \"item\" is a line starting with a log level in brackets.

Interactively, N is the numeric prefix argument.
If N is omitted or nil, move point 1 item forward."
  (interactive "P")
  (forward-char 1)
  (if (re-search-forward racket-logger--item-rx nil t count)
      (beginning-of-line)
    (backward-char 1)))

(defun racket-logger-previous-item (&optional count)
  "Move point N items backward.

An \"item\" is a line starting with a log level in brackets.

Interactively, N is the numeric prefix argument.
If N is omitted or nil, move point 1 item backward."
  (interactive "P")
  (re-search-backward racket-logger--item-rx nil t count))

(defun racket-logger-topic-level ()
  "Set or unset the level for a topic.

For convenience, input choices using `ido-completing-read'.

The topic labeled \"*\" is the level to use for all topics not
specifically assigned a level.

The level choice \"*\" means the topic will no longer have its
own level, therefore will follow the level specified for the
\"*\" topic."
  (interactive)
  (let* ((topic  (ido-completing-read
                  "Topic: "
                  (racket-logger--topics)))
         (topic  (pcase topic
                   ("" "*")
                   (v  v)))
         (topic  (intern topic))
         (levels (list "fatal" "error" "warning" "info" "debug"))
         (levels (if (eq topic '*) levels (cons "*" levels)))
         (level  (ido-completing-read
                  (format "Level for topic `%s': " topic)
                  levels
                  nil t nil nil
                  (format "%s" (racket-logger--topic-level topic "*"))))
         (level  (pcase level
                   (""  nil)
                   ("*" nil)
                   (v   (intern v)))))
    (if level
        (racket-logger--set topic level)
      (racket-logger--unset topic))))

(provide 'racket-logger)

;;; racket-logger.el ends here