1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
------------------------------------------------------------------------------
--- Interface for ui descriptions
--- @author Christof Kluss
--- @version September 2008
------------------------------------------------------------------------------

module UI(
  Command(..),Ref(..),Handler(..),
  Widget(Widget),
  Event(..),WidgetKind(..),showWidgetKind,
  CanvasItem(..),
  UIEnv,
  -- for stils
  StyleClass(..),Position(..),Direction(..),
  Style(..),BorderStyle(..),FontStyle(..),Color(..),
  --
  addStyle,addStyles,setStyles,
  addHandler,addHandlers,setHandlers,
  setRef,getRef,
  -- IO Actions
  runUI,exitUI,
  getValue,setValue,updateValue,appendValue,
  changeStyles,setHandler,setDisabled,
  addCanvas,
  showPopup,showMessage,
  -- Widgets
  colS,col,rowS,row,matrixS,matrix,
  entry,entryS,label,labelS,button,buttonS,simpleButton,simpleButtonS,
  checkButton,checkButtonS,simpleCheckButton,simpleCheckButtonS,
  canvas,canvasS,
  textEdit,textEditS,
  scale,scaleS,message,messageS,
  menuBar,menuBarS,menu,menuS,menuSeparator,menuSeparatorS,
  menuItem,menuItemS,
  listBox,listBoxS,
  selection,selectionInitial,selectionInitialS,radio_main,radio_other,
  --
  showBorderStyle,showColor,showPos
) where


import Maybe

infixl 0 `setRef`
infixl 0 `setHandlers`
infixl 0 `addStyles`
infixl 0 `setStyles`

data Command act1 act2
  = Cmd act1
  | SpicyDoc act2

--- The data type of references to widgets in a UI window.
data Ref r = Ref r
 deriving Eq

data Handler act1 act2
  = Handler Event (Command act1 act2)

--- The generic type of a widget in an UI.
data Widget r act1 act2 =
  Widget
    (WidgetKind r act1 act2)
    (Maybe String) (Maybe (Ref r)) [Handler act1 act2]
    [StyleClass]
    [Widget r act1 act2]

--- The data type of possible events on which handlers can react.
data Event =
    DefaultEvent
  | FocusOut
  | FocusIn
  | MouseButton1
  | MouseButton2
  | MouseButton3
  | KeyPress
  | Return
  | Change
  | Click
  | DoubleClick


data WidgetKind r act1 act2 =
    Col
  | Row
  | Matrix [[Widget r act1 act2]]
  | Label
  | Button
  | Entry
  | TextEdit Int Int
  | Scale Int Int
  | CheckButton Bool
  | Menu | MenuSeparator | MenuBar | MenuItem
  | Canvas Int Int
  | ListBox Int [String] Int | ListBoxItem String Bool
  | Name String
  | Link
  | RadioButton Bool

showWidgetKind :: WidgetKind r a1 a2 -> String
showWidgetKind _ = "<some WidgetKind>"

defaultHandler :: a -> Handler a _
defaultHandler cmd = Handler DefaultEvent (Cmd cmd)

-------------------------------------------------------------------------------

addStyle :: Widget r a1 a2 -> StyleClass -> Widget r a1 a2
addStyle widget cls = addStyles widget [cls]

addStyles :: Widget r a1 a2 -> [StyleClass] -> Widget r a1 a2
addStyles (Widget str mblabel mbref handlers styleClasses ws) classes
  = Widget str mblabel mbref handlers (styleClasses ++ classes) ws

setStyles :: Widget r a1 a2 -> [StyleClass] -> Widget r a1 a2
setStyles (Widget str mblabel mbref handlers _ ws) classes
  = Widget str mblabel mbref handlers classes ws

addHandler :: Widget r a1 a2 -> Handler a1 a2 -> Widget r a1 a2
addHandler widget handler = addHandlers widget [handler]

addHandlers :: Widget r a1 a2 -> [Handler a1 a2] -> Widget r a1 a2
addHandlers  (Widget str mblabel mbref handlers styles ws) hs
  = Widget str mblabel mbref (handlers ++ hs) styles ws

setHandlers :: Widget r a1 a2 -> [Handler a1 a2] -> Widget r a1 a2
setHandlers (Widget str mblabel mbref _ styles ws) handlers
  = Widget str mblabel mbref handlers styles ws

setRef :: Widget r a1 a2 -> Ref r -> Widget r a1 a2
setRef  (Widget str mblabel _ handlers styles ws) ref
  = Widget str mblabel (Just ref) handlers styles ws

getRef :: Widget r a1 a2 -> (Ref r,Widget r a1 a2)
getRef w@(Widget str mblabel mbref handlers styles ws) = case mbref of
  Just r  -> (r,w)
  Nothing -> (ref,Widget str mblabel (Just ref) handlers styles ws)
    where ref free

-------------------------------------------------------------------------------

--- The data type of items in a canvas.
data CanvasItem =
    CLine [(Int,Int)] String
  | CPolygon [(Int,Int)] String
  | CRectangle (Int,Int) (Int,Int) String
  | COval (Int,Int) (Int,Int) String
  | CText (Int,Int) String String


-- Styles
-------------------------------------------------------------------------------

data StyleClass = Class [Style]
 deriving Show

data Position = Center | Left | Right | Top | Bottom
 deriving Show

data Direction = X | Y | Both
 deriving Show

--- The data type of possible styles.
data Style =
   Align Position
 | TextAlign Position
 | TextColor Color
 | Fill Direction
 | Height Int
 | Width Int
 | Active Bool
 | Fg Color
 | Bg Color
 | Font FontStyle
 | Border BorderStyle
 | Display Bool
 | NameValue String String
  deriving Show


data BorderStyle = Dotted | Dashed | Solid
 deriving Show

data FontStyle   = Bold | Italic | Underline
 deriving Show

--- The data type of possible colors.
data Color
  = Black | Blue | Brown | Cyan | Gold | Gray | Green
  | Magenta | Navy | Orange | Pink | Purple | Red
  | Tomato| Turquoise | Violet | White | Yellow | Default
 deriving Show

-------------------------------------------------------------------------------

type UIRef = Ref ()
type UIWidget = Widget () (UI.UIEnv -> IO ()) ()
data UIEnv = UIEnv

--- Run a Widget in a new window.
runUI :: String -> UIWidget -> IO ()
runUI _ _ = error "UI:runUI not executable"

--- An event handler for terminating the GUI.
exitUI :: UIEnv -> IO ()
exitUI _ = error "UI:exitUI not executable"

--- Gets the String value of a variable in an UI.
getValue :: UIRef -> UIEnv -> IO String
getValue _ _ = error "UI:getValue not executable"

--- Sets the String value of a variable in an UI.
setValue :: UIRef -> String -> UIEnv -> IO ()
setValue _ _ _ = error "UI:setValue not executable"

--- Updates the (String) value of a variable 
--- w.r.t. to an update function.
updateValue :: (String -> String) -> UIRef -> UIEnv -> IO ()
updateValue _ _ _ = error "UI:updateValue not executable"

--- Appends a String value to the contents of a widget.
appendValue :: UIRef -> String -> UIEnv -> IO ()
appendValue _ _ _ = error "UI:appendValue not executable"

--- Changes the style of a widget
changeStyles :: UIRef -> [StyleClass] -> UIEnv -> IO ()
changeStyles _ _ _ = error "UI:changeStyles not executable"

--- Sets a new Handler to a Widget referred by the first argument.
--- An existing Handler for the same event type is overridden
setHandler :: UIRef -> Event -> (UIEnv -> IO ()) -> UIEnv -> IO ()
setHandler _ _ _ _ = error "UI:setHandler not executable"

--- Sets the state of a widget to disabled (inactive)
--- or active (inactive widgets do not accept any events)
setDisabled :: UIRef -> Bool -> UIEnv -> IO ()
setDisabled _ _ _ = error "UI:setDisabled not executable"

--- Adds a list of canvas items to a canvas 
--- referred by the first argument.
addCanvas :: UIRef -> [CanvasItem] -> UIEnv -> IO ()
addCanvas _ _ _ = error "UI:addCanvas not executable"

--- Runs a Widget in a new window.
showPopup :: String -> UIWidget -> UIEnv -> IO ()
showPopup _ _ _ = error "UI:showPopup not executable"

--- Shows a String Message in a new window.
showMessage :: String -> UIEnv -> IO ()
showMessage _ _  = error "UI:showMessage not executable"


---------------------------------------------------------

--- Vertical alignment of widgets.
colS :: [StyleClass] -> [Widget r a1 a2] -> Widget r a1 a2
colS styles ws = Widget Col Nothing Nothing [] styles ws
col :: [Widget r a1 a2] -> Widget r a1 a2
col = colS []

--- Horizontal alignment of widgets.
rowS :: [StyleClass] -> [Widget r a1 a2] -> Widget r a1 a2
rowS styles ws = Widget Row Nothing Nothing [] styles ws
row :: [Widget r a1 a2] -> Widget r a1 a2
row = rowS []

--- A 2-dimensional (matrix) alignment of widgets
matrixS :: [StyleClass] -> [[Widget r a1 a2]] -> Widget r a1 a2
matrixS styles wss = Widget (Matrix wss) Nothing Nothing [] styles []
matrix :: [[Widget r a1 a2]] -> Widget r a1 a2
matrix = matrixS []

--- An entry widget for entering single lines
entry :: Ref r -> String -> Widget r a1 a2
entry = entryS []
entryS :: [StyleClass] -> Ref r -> String -> Widget r a1 a2
entryS styles ref content =
  Widget Entry  (Just content) (Just ref) [] styles []

--- A label for showing a text
label :: String -> Widget r a1 a2
label = labelS []
labelS :: [StyleClass] -> String -> Widget r a1 a2
labelS styles str = Widget Label (Just str) Nothing [] styles []

-- A button in a UI whose event handler is activated
-- if the user presses the button
button :: a1 -> String -> Widget r a1 a2
button = buttonS []
buttonS :: [StyleClass] -> a1 -> String -> Widget r a1 a2
buttonS styles cmd text =
  Widget Button (Just text) Nothing [defaultHandler cmd] styles []

--- A button without handler, but reference
simpleButton :: Ref r -> String -> Widget r a1 a2
simpleButton = simpleButtonS []
simpleButtonS :: [StyleClass] -> Ref r -> String -> Widget r a1 a2
simpleButtonS styles ref text =
  Widget Button (Just text) (Just ref) [] styles []

--- A check button: 
--- it has value "0" if it is unchecked and
---        value "1" if it is checked
checkButton :: Ref r -> a1 -> String -> Bool -> Widget r a1 a2
checkButton = checkButtonS []
checkButtonS :: [StyleClass] -> Ref r -> a1 -> String -> Bool ->
                                                            Widget r a1 a2
checkButtonS styles ref cmd text checked =
  Widget (CheckButton checked)
         (Just text) (Just ref) [defaultHandler cmd] styles []


-- A check button without a reference: 
-- it has value "0" if it is unchecked and
--        value "1" if it is checked
simpleCheckButton :: Ref r -> String -> Bool -> Widget r a1 a2
simpleCheckButton = simpleCheckButtonS []
simpleCheckButtonS :: [StyleClass] -> Ref r -> String -> Bool ->
                                                           Widget r a1 a2
simpleCheckButtonS styles ref text checked =
  Widget (CheckButton checked) (Just text) (Just ref) [] styles []


-- A canvas to draw pictures containing CanvasItems
canvas :: Ref r -> Int -> Int -> Widget r a1 a2
canvas = canvasS []
canvasS :: [StyleClass] -> Ref r -> Int -> Int -> Widget r a1 a2
canvasS styles ref h w = Widget (Canvas h w) Nothing (Just ref) [] styles []


-- A text editor widget to show and manipulate larger text paragraphs
textEdit :: Ref r -> String -> Int -> Int -> Widget r a1 a2
textEdit = textEditS []
textEditS :: [StyleClass] -> Ref r -> String -> Int -> Int -> Widget r a1 a2
textEditS styles  ref text rows cols =
  Widget (TextEdit rows cols) (Just text) (Just ref) [] styles []


--- A scale widget to input values by a slider
scale :: Ref r -> a1 -> Int -> Int -> Widget r a1 a2
scale = scaleS []
scaleS :: [StyleClass] -> Ref r -> a1 -> Int -> Int -> Widget r a1 a2
scaleS styles  ref cmd min max =
  Widget (Scale min max) Nothing (Just ref) [defaultHandler cmd] styles []

--- A message for showing simple string values
message :: Ref r -> Widget r a1 a2
message = messageS []
messageS :: [StyleClass] -> Ref r -> Widget r a1 a2
messageS styles ref = Widget Label Nothing (Just ref) [] styles []

--- A menubar contains a list of menus
menuBar :: [Widget r a1 a2] -> Widget r a1 a2
menuBar = menuBarS []
menuBarS :: [StyleClass] -> [Widget r a1 a2] -> Widget r a1 a2
menuBarS styles xs    = Widget MenuBar Nothing Nothing [] styles xs

--- A button with a pull-down menu for a menubar
menu :: String -> [Widget r a1 a2] -> Widget r a1 a2
menu = menuS []
menuS :: [StyleClass] -> String -> [Widget r a1 a2] -> Widget r a1 a2
menuS styles text xs = Widget Menu (Just text) Nothing [] styles xs

--- A separator between menu entries
menuSeparator :: Widget r a1 a2
menuSeparator = menuSeparatorS []
menuSeparatorS :: [StyleClass] -> Widget r a1 a2
menuSeparatorS styles =
  Widget MenuSeparator (Just "--------------------") Nothing [] styles []

--- A button with an associated command and a label string
menuItem :: a1 -> String -> Widget r a1 a2
menuItem = menuItemS []

menuItemS :: [StyleClass] -> a1 -> String -> Widget r a1 a2
menuItemS styles cmd text =
  Widget MenuItem
         (Just text) Nothing [defaultHandler cmd] styles []

--- A widget containing a list of items for selection
listBox :: Int -> [String] -> Ref r -> a1 -> Widget r a1 a2
listBox = listBoxS []
listBoxS :: [StyleClass] -> Int -> [String] -> Ref r -> a1 -> Widget r a1 a2
listBoxS styles size strs ref cmd =
  Widget (ListBox size strs (-1))
         Nothing (Just ref) [defaultHandler cmd] styles []

-------------------------------------------------------------------------------

--- A selection button with a reference and a list of name/value pairs.
--- The names are shown in the selection and the value is returned
--- for the selected name.
selection :: Ref r -> [String] -> Widget r a1 a2
selection ref menue = selectionInitial ref menue (-1)

--- A selection button with a reference, a list of name/value pairs,
--- and a preselected item in this list.
--- The names are shown in the selection and the value is returned
--- for the selected name.
selectionInitial :: Ref r -> [String] -> Int -> Widget r a1 a2
selectionInitial = selectionInitialS []
selectionInitialS :: [StyleClass] -> Ref r -> [String] -> Int ->
                                                            Widget r a1 a2
selectionInitialS styles ref items sel =
  Widget (ListBox 1 items sel) Nothing (Just ref) [] styles []

--- A main button of a radio (initially "on") with a reference and a value.
--- The value is returned of this button is on.
--- A complete radio button suite always consists of a main button
--- (radio_main) and some further buttons (radio_others) with the
--- same reference. Initially, the main button is selected
--- (or nothing is selected if one uses radio_main_off instead of radio_main).
--- The user can select another button but always at most one button
--- of the radio can be selected. The value corresponding to the
--- selected button is returned in the environment for this radio reference.
radio_main :: Ref r -> String -> Widget r a1 a2
radio_main   ref value =
  Widget (RadioButton True) (Just value) (Just ref) [] [] []

--- A further button of a radio (initially "off") with a reference (identical
--- to the main button of this radio) and a value.
--- The value is returned of this button is on.
radio_other :: Ref r -> String -> Widget r a1 a2
radio_other  ref value =
  Widget (RadioButton False) (Just value) (Just ref) [] [] []
-------------------------------------------------------------------------------

showBorderStyle :: BorderStyle -> String
showBorderStyle Dotted = "dotted"
showBorderStyle Dashed = "dashed"
showBorderStyle Solid = "solid"

--- Converts a style value into its textual representation.
showColor :: Color -> String
showColor Black     = "black"
showColor Blue      = "blue"
showColor Brown     = "brown"
showColor Cyan      = "cyan"
showColor Gold      = "gold"
showColor Gray      = "gray"
--showColor Green     = "forest green"
showColor Green     = "green"
showColor Magenta   = "magenta"
showColor Navy      = "navy"
showColor Orange    = "orange"
showColor Pink      = "pink"
showColor Purple    = "purple"
showColor Red       = "red"
showColor Tomato    = "tomato"
showColor Turquoise = "turquoise"
showColor Violet    = "violet"
showColor White     = "white"
showColor Yellow    = "yellow"
showColor Default   = "white"

showPos :: Position -> String
showPos Center = "center"
showPos Left   = "left"
showPos Right  = "right"
showPos Top    = "top"
showPos Bottom = "bottom"