#!/usr/bin/env sh
export GUILE_LOAD_COMPILED_PATH="/usr/share/lepton-eda/ccache:${GUILE_LOAD_COMPILED_PATH}"
exec /usr/bin/guile-2.2 -s "$0" "$@"
!#

;;; Lepton EDA attribute editor
;;; Copyright (C) 2003-2010 Stuart D. Brorson.
;;; Copyright (C) 2005-2016 gEDA Contributors
;;; Copyright (C) 2017-2020 Lepton EDA Contributors
;;;
;;; 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 2 of the License, 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 this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA


(use-modules (ice-9 getopt-long)
             (ice-9 match)
             (ice-9 receive)
             (srfi srfi-1)
             (system foreign))

;;; Load and initialize liblepton library.
(load-extension (or (getenv "LIBLEPTON") "/usr/lib/x86_64-linux-gnu/liblepton")
                "liblepton_init")

(define libgtk (dynamic-link "libgtk-x11-2.0"))
(define libleptonattrib (dynamic-link "libleptonattrib"))

(define gtk-init
  (pointer->procedure
   void
   (dynamic-func "gtk_init" libgtk)
   (list '* '*)))

(define gtk-main
  (pointer->procedure
   void
   (dynamic-func "gtk_main" libgtk)
   '()))

(define set-verbose-mode!
  (pointer->procedure
   void
   (dynamic-func "set_verbose_mode" libleptonattrib)
   '()))

(define fileselect-open
  (pointer->procedure
   '*
   (dynamic-func "x_fileselect_open" libleptonattrib)
   '()))

(define lepton-attrib-window
  (pointer->procedure
   void
   (dynamic-func "lepton_attrib_window" libleptonattrib)
   '()))

;;; Localization.
(define %textdomain "libleptonattrib")
(bindtextdomain %textdomain "/usr/share/locale")
(textdomain %textdomain)
(bind-textdomain-codeset %textdomain "UTF-8")
(setlocale LC_ALL "")
(setlocale LC_NUMERIC "C")

(define (G_ msg) (gettext msg %textdomain))

(primitive-eval '(use-modules (lepton core toplevel)
                              (lepton file-system)
                              (lepton log)
                              (lepton page)
                              (lepton rc)
                              (lepton version)))

(define* (lepton-attrib-version #:optional stdout)
  "Print lepton-attrib version."
  (define (version-msg . args)
    (apply format #f "Lepton EDA/lepton-attrib ~A~A.~A (git: ~A)\n" args))

  (define copyrights
    (G_ "Copyright (C) 1998-2016 gEDA developers
Copyright (C) 2017-2020 Lepton EDA developers
This is free software, and you are welcome to redistribute it
under certain conditions. For details, see the file `COPYING',
which is included in the Lepton EDA distribution.
There is NO WARRANTY, to the extent permitted by law.\n"))

  (match (lepton-version)
    ((prepend dotted date commit bugs url msg)
     (let ((version-message (version-msg prepend dotted date (string-take commit 7))))
       (if stdout
           (begin
             (display version-message)
             (display copyrights)
             (primitive-exit 0))
           (log! 'message (version-msg prepend dotted date (string-take commit 7))))))))


(define (usage)
  (match (lepton-version)
    ((prepend dotted date commit bugs url msg)
     (format #t
             (G_ "Usage: ~A [OPTIONS] filename1 ... filenameN

lepton-attrib: Lepton EDA attribute editor.
Presents schematic attributes in easy-to-edit spreadsheet format.

Options:
  -v, --verbose          Verbose mode on
  -V, --version          Show version information
  -h, --help             This help menu

FAQ:
  *  What do the colors of the cell text mean?
     The cell colors indicate the visibility of the attribute.
     Black = Visible attribute, value displayed only.
     Grey  = Invisible attribute.
     Red   = Visible attribute, name displayed only.
     Blue  = Visible attribute, both name and value displayed.

  *  What does the period (\".\") at the end of some component refdeses mean?
     The period is placed after the refdeses of slotted components.
     If slots are present on the component, then the different slots appear
     in different rows with the slot number after the period.  Example:  C101.2.

Copyright (C) 2003-2006 Stuart D. Brorson.
Copyright (C) 2007-2016 gEDA Contributors.
Copyright (C) 2017-2020 Lepton EDA Contributors.

Report bugs at ~S
Lepton EDA homepage: ~S
")
             (car (program-arguments))
             bugs
             url)))

  (primitive-exit 0))


(define (report-unreadable filename)
  (format (current-error-port)
          "Could not open file ~S.\n"
          filename))

(define (gslist->list gslist)
  (let loop ((gsls gslist)
             (ls '()))
    (if (null-pointer? gsls)
        ls
        (let* ((elem (parse-c-struct gsls (list '* '*)))
               (str (pointer->string (first elem)))
               (gsls (second elem)))
          (loop gsls (cons str ls))))))


(define (process-gafrc* name)
  (process-gafrc "lepton-attrib" name))


;;; Init logging.
(init-log "attrib")
(lepton-attrib-version)


(let* ((option-spec '((help (single-char #\h))
                      (verbose (single-char #\v))
                      (version (single-char #\V))))

       (options (getopt-long (program-arguments) option-spec))
       (help (option-ref options 'help #f))
       (version (option-ref options 'version #f))
       (files (option-ref options '() '()))
       (verbose? (option-ref options 'verbose #f)))

  (when help (usage))
  ;; Output version to stdout and exit, if requested.
  (when version (lepton-attrib-version 'stdout))
  (when verbose? (set-verbose-mode!))

  (receive (readable-files unreadable-files)
      (partition file-readable? files)
    (if (null? unreadable-files)
        ;; Main procedure.
        (begin
          ;; Initialize GTK.
          (gtk-init %null-pointer %null-pointer)
          (let ((files (if (null? readable-files)
                           ;; No files specified on the command
                           ;; line, pop up the File open dialog.
                           (gslist->list (fileselect-open))
                           readable-files)))
            (if (null? files)
                (primitive-exit 0)
                (%with-toplevel (%make-toplevel)
                 (lambda ()
                   (for-each process-gafrc* files)
                   ;; Open all files.
                   (for-each file->page files)
                   ;; Run attribute editor.
                   (lepton-attrib-window)
                   ;; Run main GTK loop.
                   (gtk-main)
                   (primitive-exit 0))))))
        ;; There are non-existing or unreadable files.  Report and
        ;; exit.
        (begin
          (for-each report-unreadable unreadable-files)
          (primitive-exit 1)))))
