;  Copyright (c) 2014 Edward Langley
 ;  All rights reserved.
 
 ;  Redistribution and use in source and binary forms, with or without
 ;  modification, are permitted provided that the following conditions
 ;  are met:
 
 ;  Redistributions of source code must retain the above copyright notice,
 ;  this list of conditions and the following disclaimer.
 
 ;  Redistributions in binary form must reproduce the above copyright
 ;  notice, this list of conditions and the following disclaimer in the
 ;  documentation and/or other materials provided with the distribution.
 
 ;  Neither the name of the project's author nor the names of its
 ;  contributors may be used to endorse or promote products derived from
 ;  this software without specific prior written permission.
 
 ;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 ;  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 ;  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
 ;  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 ;  HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 ;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
 ;  TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
 ;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
 ;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 ;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 ;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 (require 'asdf)
 (asdf:load-system 'quicklisp)

 
 (asdf:load-system :cl-cffi-gtk)

 (ql:quickload :cl-fad)
 (ql:quickload :x.let-star)

 (defpackage :notes-app

   (:use :gtk :gdk :gdk-pixbuf :gobject

         :glib :gio :pango :cairo :common-lisp
         :cl-fad :x.let-star)
   (:shadowing-import-from x.let-star let*)
   (:export main))

 (in-package :notes-app)

 
 ;(macroexpand-1 '(on (clicked button) (__)
 ;                    (declare (ignore __))
 ;                    (format t "Button 1 was pressed")))
 
 (defmacro on ((sig target) bind &body body)

   "Bind a signal handler: note that this intentionally shadows whatever
    the 'bind' argument is"

   `(g-signal-connect ,target ,(string-downcase (symbol-name sig))
                      (lambda ,bind
                        ,@body)))
 

 
 
 (defmacro thread-signal ((sig target) bind callback)
   "Bind a signal handler: note that this intentionally shadows whatever
    the 'bind' argument is"
   `(g-signal-connect ,target ,(string-downcase (symbol-name sig)) ,callback))
 

 (defmacro mainloop (fname winvar title width height &body body)
   `(defun ,fname ()
      (within-main-loop
        (let ((,winvar (make-instance 'gtk-window
                                      :title ,title
                                      :type :toplevel
                                      :default-width ,width
                                      :default-height ,height)))
 
          (on (destroy ,winvar) (widget)
            (declare (ignore widget))
            (leave-gtk-main))
 
          ,@body
 

          (gtk-widget-show-all ,winvar)))
      (join-gtk-main)))

 
 ;(macroexpand-1
 ;  (quote
 ;    (declare-paned-widget (:orientation :vertical)
 ;      (declare-scroll-window () list-view)
 ;      (declare-scroll-window (:wrap-mode :word) text-view))))
 
 ;(let ((paned (make-instance 'gtk :orientation :vertical)))
 ;  (let ((scroller (make-instance 'gtk-scroll-window)))
 ;    (gtk-container-add list-view))
 ;  (let ((scroller (make-instance 'gtk-scroll-window :wrap-mode :word)))
 ;    (gtk-container-add text-view)))
 
 (defmacro declare-scroll-window (initializers child)
   (let ((sw-sym (gensym)))
     `(let ((,sw-sym (make-instance 'gtk-scrolled-window ,@initializers)))
        (gtk-container-add ,sw-sym ,child)
        ,sw-sym)))
 
 (defmacro declare-paned-widget (initializers child1 child2)
   (let ((paned-sym (gensym)))
     `(let ((,paned-sym (make-instance 'gtk-paned ,@initializers)))
        (gtk-paned-add1 ,paned-sym ,child1)
        (gtk-paned-add2 ,paned-sym ,child2)
        ,paned-sym)))

 (labels ((process-child (child box-sym)
            (if (listp child)
              (let* ((_initializers
                       (if (< 2 (length child)) (cddr child) ()))
                     (initializers (apply #'append _initializers))
                     (widget (second child)))
                (ecase  (first child)
                  (:start `(gtk-box-pack-start ,box-sym
                                               ,widget
                                               ,@initializers))
 
                  (:end   `(gtk-box-pack-end   ,box-sym
                                               ,widget
                                               ,@initializers)))))))
 
   (defmacro declare-box (initializers &body children)
     (let ((box-sym (gensym)))
       `(let ((,box-sym (make-instance 'gtk-box ,@initializers)))
          ,@(loop for child in children collect (process-child child box-sym))
          ,box-sym))))
 
 (defmacro declare-toolbar (initializers &body children)
   (let ((toolbar-sym (gensym)))
     `(let ((,toolbar-sym (gtk-toolbar-new)))
        ,@(loop for button in children collect
                `(gtk-toolbar-insert ,toolbar-sym
                                     (make-instance 'gtk-tool-button ,@button)
                                     -1))
        ,toolbar-sym)))

 
 (defun make-list-view (display-list)
   (let ((store (make-instance 'gtk-list-store :column-types '("gchararray")))
         (list-view (make-instance 'gtk-tree-view :headers-visible nil)))
 
     (gtk-tree-view-set-model list-view store)
 
     (loop for fn in display-list
           do (gtk-list-store-set store
                                  (gtk-list-store-append store)
                                  (file-namestring fn)))
 
     (let* ((renderer (make-instance 'gtk-cell-renderer-text))
            (column
              (gtk-tree-view-column-new-with-attributes "Filename" renderer "text" 0)))
       (gtk-tree-view-append-column list-view column))
     (values store list-view)))
 
 (defun make-text-view (text)
   (let* ((text-view (make-instance 'gtk-text-view :wrap-mode :word))
          (buffer (gtk-text-view-get-buffer text-view)))
     (gtk-text-buffer-set-text buffer text)
     (values buffer text-view)))
 

 (defun get-list-at-path (list-model path)
   (let* ((iter (gtk-tree-model-get-iter list-model path)))
     (selected (gtk-tree-model-get-value list-model iter 0))) )
 
 (defvar *note-dir* "/home/edwlan/Dropbox/Notes/")

 (mainloop main window "test" 200 200

   (let* (((:mval list-model list-view) (make-list-view
                                          (cl-fad:list-directory *note-dir*)))

          ((:mval text-buffer text-view) (make-text-view "")))
 

     (on (row-activated list-view) (tree-view path column)

       (let* ((selected (get-list-at-path list-model path))

              (file-contents

                (with-open-file (fd (merge-pathnames-as-file *note-dir* selected))

                  (let ((seq (make-string (file-length fd))))
                    (read-sequence seq fd)
                    seq))))
         (gtk-text-buffer-set-text text-buffer file-contents)))
 
     (gtk-container-add window
                        (declare-paned-widget (:orientation :vertical)

                                              (declare-box
                                                (:orientation :vertical)
                                                (:end
                                                  (declare-box
                                                    (:orientation :horizontal)
                                                    (:start (gtk-entry-new) (:fill t))
                                                    (:end
                                                      (make-instance 'gtk-button 
                                                                     :use-stock t
                                                                     :label "gtk-add")
                                                      (:expand nil)))
                                                  (:expand nil))
                                                (:start
                                                  (declare-scroll-window
                                                        (:height-request 400)
                                                        list-view)
                                                  (:fill t)))
                                              (declare-scroll-window
                                                (:wrap-mode :word)
                                                text-view)))))

 
 ;(main)
 

 (labels

   ((slot-function (descriptor)
      (ecase descriptor
        (:start 'gtk-box-pack-start)
        (:end   'gtk-box-pack-end)))
    (proc-slot (box from-object slot)
      (if (equal (first slot) 'QUOTE)

        `(gtk-box-pack-start ,box (slot-value ,from-object ,slot))

        (ecase (length slot)
          (1 `(gtk-box-pack-start ,box (slot-value ,from-object ,(first slot))))
          (2 `(,(slot-function (second slot)) ,box (slot-value ,from-object ,(first slot))))))))
 
   (defmacro renderwin (window box from-object &body slots)
     (let ((window-sym (gensym))
           (box-sym (gensym))
           (from-obj-sym (gensym)))
       `(let ((,window-sym ,window)
              (,box-sym ,box)
              (,from-obj-sym ,from-object))
          ,@(loop for slot in slots collect (proc-slot box-sym from-obj-sym slot))
          (gtk-container-add ,window-sym ,box-sym)))))
 
 (defclass mainwin nil
   ((file-view :initarg :file-view)
    (file-list :initarg :file-list)))
 
 
 (defun wrap-with-scrollwindow (widg &key (hscrpolicy :automatic) (vscrpolicy :automatic))
   (let ((scroller (make-instance 'gtk-scrolled-window
                                  :hscrollbar-policy hscrpolicy
                                  :vscrollbar-policy vscrpolicy)))
     (gtk-container-add scroller widg)
     scroller))