← Back to branch summary

~ubuntu-branches/ubuntu/lucid/sawfish/lucid-updates

« back to all changes in this revision

Viewing changes to lisp/sawfish/ui/layout.jl

  • Committer: Bazaar Package Importer
  • Author(s): Christian Marillat
  • Date: 2002-01-20 17:42:28 UTC
  • Revision ID: james.westby@ubuntu.com-20020120174228-4q1ydztbkvfq1ht2
Tags: upstream-1.0.1.20020116
Import upstream version 1.0.1.20020116

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/sawfish/ui/layout.jl
 
1
#| nokogiri-layout.jl -- arranging groups of slots
 
2
 
 
3
   $Id: layout.jl,v 1.8 2000/11/27 18:13:50 jsh Exp $
 
4
 
 
5
   Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
 
6
 
 
7
   This file is part of sawfish.
 
8
 
 
9
   sawfish is free software; you can redistribute it and/or modify it
 
10
   under the terms of the GNU General Public License as published by
 
11
   the Free Software Foundation; either version 2, or (at your option)
 
12
   any later version.
 
13
 
 
14
   sawfish is distributed in the hope that it will be useful, but
 
15
   WITHOUT ANY WARRANTY; without even the implied warranty of
 
16
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
17
   GNU General Public License for more details.
 
18
 
 
19
   You should have received a copy of the GNU General Public License
 
20
   along with sawfish; see the file COPYING.  If not, write to
 
21
   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
22
|#
 
23
 
 
24
(define-structure sawfish.ui.layout
 
25
 
 
26
    (export define-layout-type
 
27
            layout-slots
 
28
            document-slot
 
29
            remove-newlines
 
30
            make-label)
 
31
 
 
32
    ((open rep
 
33
           gui.gtk
 
34
           rep.regexp
 
35
           sawfish.ui.slot
 
36
           sawfish.gtk.widget)
 
37
     (access rep.structures))
 
38
 
 
39
  (define (define-layout-type name fun) (put name 'nokogiri-layout fun))
 
40
 
 
41
  (define (layout-type name)
 
42
    (or (get name 'nokogiri-layout)
 
43
        ;; try to dynamically load it
 
44
        (let ((module-name (intern (concat "sawfish.ui.layouts."
 
45
                                           (symbol-name name)))))
 
46
          (condition-case nil
 
47
              (progn
 
48
                (rep.structures#intern-structure module-name)
 
49
                (get name 'nokogiri-layout))
 
50
            (error (layout-type 'vbox))))))
 
51
 
 
52
  (define (layout-slots name slots)
 
53
    ((layout-type (or (car name) name)) name slots))
 
54
 
 
55
;;; basic layout styles
 
56
 
 
57
  (define (layout-single style slots)
 
58
    (cond ((null slots)
 
59
           (let ((placeholder (gtk-vbox-new nil 0)))
 
60
             (gtk-widget-show placeholder)
 
61
             placeholder))
 
62
          ((= (length slots) 1)
 
63
           (let ((w (document-slot (car slots))))
 
64
             (set-slot-layout (car slots) w)
 
65
             w))
 
66
          (t (error "Too many slots for `single' layout"))))
 
67
 
 
68
  (define-layout-type 'single layout-single)
 
69
 
 
70
  (define (layout-box style slots)
 
71
    (let ((box ((if (eq style 'hbox)
 
72
                    gtk-hbox-new
 
73
                  gtk-vbox-new) nil box-spacing)))
 
74
      (mapc (lambda (s)
 
75
              (let ((w (document-slot s)))
 
76
                (set-slot-layout s w)
 
77
                (if (memq 'expand-vertically (slot-flags s))
 
78
                    (gtk-box-pack-start box w t t)
 
79
                  (gtk-box-pack-start box w)))) slots)
 
80
      (gtk-widget-show box)
 
81
      box))
 
82
 
 
83
  (define-layout-type 'vbox layout-box)
 
84
  (define-layout-type 'hbox layout-box)
 
85
 
 
86
  (define (layout-frame style slots)
 
87
    (let ((frame (gtk-frame-new (cadr style)))
 
88
          (vbox (layout-slots 'vbox slots)))
 
89
      (gtk-container-border-width frame box-border)
 
90
      (gtk-container-add frame vbox)
 
91
      (gtk-widget-show frame)
 
92
      frame))
 
93
 
 
94
  (define-layout-type 'frame layout-frame)
 
95
 
 
96
;;; including doc strings alongside slot widgets
 
97
 
 
98
  (define (document-slot slot)
 
99
    (let ((doc (slot-doc slot)))
 
100
      (if (or (null doc) (string= doc ""))
 
101
          (slot-gtk-widget slot)
 
102
        (let ((split (tooltip-split doc)))
 
103
          (define (add-tooltip widget)
 
104
            (if (cdr split)
 
105
                ;; tooltips need a window to receive events..
 
106
                (let ((ebox (gtk-event-box-new)))
 
107
                  (gtk-container-add ebox widget)
 
108
                  (tooltip-set ebox (cdr split))
 
109
                  ebox)
 
110
              widget))
 
111
 
 
112
          (setq doc (remove-newlines (car split)))
 
113
          (if (memq 'framed (slot-flags slot))
 
114
              (let ((hbox (gtk-hbox-new nil 0))
 
115
                    (vbox (gtk-vbox-new nil 0)))
 
116
                (gtk-box-pack-start hbox (gtk-label-new doc))
 
117
                (gtk-box-pack-start vbox hbox)
 
118
                (gtk-box-pack-start vbox (slot-gtk-widget slot) t t)
 
119
                (setq vbox (add-tooltip vbox))
 
120
                (gtk-widget-show-all vbox)
 
121
                vbox)
 
122
            (let ((hbox (gtk-hbox-new nil box-spacing))
 
123
                  (break (if (string-match "\\\\w" doc)
 
124
                             (match-start)
 
125
                           -2)))
 
126
              (when (> break 0)
 
127
                (gtk-box-pack-start hbox (make-label (substring doc 0 break))))
 
128
              (if (memq 'expand-horizontally (slot-flags slot))
 
129
                  (gtk-box-pack-start hbox (slot-gtk-widget slot) t t)
 
130
                (gtk-box-pack-start hbox (slot-gtk-widget slot) nil nil))
 
131
              (when (< break (length doc))
 
132
                (gtk-box-pack-start
 
133
                 hbox (make-label (substring doc (+ break 2)))))
 
134
              (setq hbox (add-tooltip hbox))
 
135
              (gtk-widget-show-all hbox)
 
136
              hbox))))))
 
137
    
 
138
  (define (remove-newlines string)
 
139
    (let loop ((point 0)
 
140
               (out '()))
 
141
      (if (string-match "\n" string point)
 
142
          (loop (match-end)
 
143
                (list* #\space (substring string point (match-start)) out))
 
144
        (apply concat (nreverse (cons (substring string point) out))))))
 
145
  
 
146
  (define (make-label text)
 
147
    (let ((label (gtk-label-new text)))
 
148
      (gtk-label-set-justify label 'left)
 
149
      ;; XXX GtkLabel line wrapping sucks, but it stops the
 
150
      ;; XXX text disappearing..
 
151
      (gtk-label-set-line-wrap label t)
 
152
      label)))