From 8a3dd3709e1f4e6e41097f98669cfd0327eae440 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Thu, 21 Apr 2016 10:13:57 -0700
Subject: [PATCH] ui: adding a WINDOW: that is like MAIN-WINDOW: but without
 making the word a main word.

---
 basis/ui/ui-docs.factor | 23 +++++++++++++++++++++--
 basis/ui/ui.factor      | 18 +++++++++++-------
 2 files changed, 32 insertions(+), 9 deletions(-)

diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index e060dff42b..d6c9450224 100644
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -161,8 +161,11 @@ ARTICLE: "ui-windows" "Top-level windows"
 { $subsections ungraft* }
 "The root of the gadget hierarchy in a window is a special gadget which is rarely operated on directly, but it is helpful to know it exists:"
 { $subsections world }
-"There is also syntax for defining a main window as the entry point for a vocabulary:"
-{ $subsections POSTPONE: MAIN-WINDOW: } ;
+"There is also syntax for defining window words, including a main window that is the entry point for a vocabulary:"
+{ $subsections
+    POSTPONE: WINDOW:
+    POSTPONE: MAIN-WINDOW:
+} ;
 
 ARTICLE: "ui-backend" "Developing UI backends"
 "None of the words documented in this section should be called directly by user code. They are only of interest when developing new UI backends."
@@ -340,6 +343,20 @@ HELP: textured-background
 HELP: dialog-window
 { $description "Provides a hint to the window manager to create a floating, dialog-style window. Currently, this is only implemented for the GTK backend." } ;
 
+HELP: WINDOW:
+{ $syntax "WINDOW: window-word { attributes }
+    attribute-code ;" }
+{ $description "Defines a word for the current vocabulary named " { $snippet "window-word" } " that opens a UI window when run. The " { $snippet "attributes" } " specify the key-value pairs of the window's " { $link world-attributes } ". The " { $snippet "attribute-code" } " is run with the " { $snippet "world-attributes" } " on the stack; this allows the word to construct gadget objects to place in the " { $snippet "gadget" } " slot or set other runtime-dependent world attributes." }
+{ $examples
+"From the " { $vocab-link "hello-ui" } " vocabulary. Creates a window with the title \"Hi\" containing a label reading \"Hello world\":"
+{ $code
+"USING: accessors ui ui.gadgets.labels ;
+IN: hello-ui
+
+WINDOW: hello { { title \"Hi\" } }
+    \"Hello world\" <label> >>gadgets ;"
+} } ;
+
 HELP: MAIN-WINDOW:
 { $syntax "MAIN-WINDOW: window-word { attributes }
     attribute-code ;" }
@@ -354,6 +371,8 @@ MAIN-WINDOW: hello { { title \"Hi\" } }
     \"Hello world\" <label> >>gadgets ;"
 } } ;
 
+{ POSTPONE: WINDOW: POSTPONE: MAIN-WINDOW: } related-words
+
 ARTICLE: "ui.gadgets.worlds-window-controls" "Window controls"
 "The following window controls can be placed in a " { $link world } " window:"
 { $subsections
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 289dd23d0f..e80fd009c4 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -223,16 +223,20 @@ HOOK: beep ui-backend ( -- )
 
 HOOK: system-alert ui-backend ( caption text -- )
 
-: parse-main-window-attributes ( class -- attributes )
+: parse-window-attributes ( class -- attributes )
     "{" expect dup all-slots parse-tuple-literal-slots ;
 
-: define-main-window ( word attributes quot -- )
-    [
-        '[ [ f _ clone @ open-window ] with-ui ] ( -- ) define-declared
-    ] [ 2drop current-vocab main<< ] 3bi ;
+: define-window ( word attributes quot -- )
+    '[ [ f _ clone @ open-window ] with-ui ] ( -- ) define-declared ;
+
+SYNTAX: WINDOW:
+    scan-new-word
+    world-attributes parse-window-attributes
+    parse-definition
+    define-window ;
 
 SYNTAX: MAIN-WINDOW:
     scan-new-word
-    world-attributes parse-main-window-attributes
+    world-attributes parse-window-attributes
     parse-definition
-    define-main-window ;
+    [ define-window ] [ 2drop current-vocab main<< ] 3bi ;