diff options
| author | Camil Staps | 2015-08-19 15:17:03 +0200 |
|---|---|---|
| committer | Camil Staps | 2015-08-19 15:17:03 +0200 |
| commit | 8c4d2170b5dbac4d82e2765cc63cfbe1ca9ead9a (patch) | |
| tree | 49a8738d019e4e33e20cb46c45b7dada342bd99e | |
| parent | Setting up (diff) | |
tut 8.5 (menu)
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | Notice.dcl | 22 | ||||
| -rw-r--r-- | Notice.icl | 67 | ||||
| -rw-r--r-- | tut8_5.icl | 61 |
5 files changed, 152 insertions, 1 deletions
@@ -2,6 +2,7 @@ !.gitignore !*.icl +!*.dcl !Makefile !*.md !LICENSE @@ -14,7 +14,7 @@ CLM_OPTS=-tst APP_OPTS=-h 512M -ICL=$(wildcard *.icl) +ICL=$(filter-out Notice.icl, $(wildcard *.icl)) EXE=$(patsubst %.icl,%,$(ICL)) all: $(EXE) diff --git a/Notice.dcl b/Notice.dcl new file mode 100644 index 0000000..e2456f7 --- /dev/null +++ b/Notice.dcl @@ -0,0 +1,22 @@ +definition module Notice
+
+// **************************************************************************************************
+//
+// A new instance of the Dialogs type constructor class to easily create simple notice dialogues.
+//
+// This module has been written in Clean 2.0 and uses the Clean Standard Object I/O library 1.2.2
+//
+// **************************************************************************************************
+
+import StdWindow
+
+:: Notice ls pst
+ = Notice [String] (NoticeButton *(ls,pst)) [NoticeButton *(ls,pst)]
+:: NoticeButton st
+ = NoticeButton String (IdFun st)
+
+instance Dialogs Notice
+
+openNotice :: !(Notice .ls (PSt .l)) !(PSt .l) -> PSt .l
+/* openNotice can be used to create a Notice without having to bother about the ErrorReport result.
+*/
diff --git a/Notice.icl b/Notice.icl new file mode 100644 index 0000000..813a85e --- /dev/null +++ b/Notice.icl @@ -0,0 +1,67 @@ +implementation module Notice
+
+// **************************************************************************************************
+//
+// A new instance of the Dialogs type constructor class to easily create simple notice dialogues.
+//
+// This module has been written in Clean 2.0 and uses the Clean Standard Object I/O library 1.2.2
+//
+// **************************************************************************************************
+
+import StdMisc, StdTuple
+import StdId, StdPSt, StdWindow
+
+/* The data type that defines a notice.
+*/
+:: Notice ls pst = Notice [String] (NoticeButton *(ls,pst)) [NoticeButton *(ls,pst)]
+:: NoticeButton st = NoticeButton String (IdFun st)
+
+/* Notices are defined as a new instance of the Dialogs type constructor class.
+*/
+instance Dialogs Notice where
+ openDialog ls notice pst
+ # (wId, pst) = accPIO openId pst
+ # (okId,pst) = accPIO openId pst
+ = openDialog ls (noticeToDialog wId okId notice) pst
+
+ openModalDialog ls notice pst
+ # (wId,pst) = accPIO openId pst
+ # (okId,pst) = accPIO openId pst
+ = openModalDialog ls (noticeToDialog wId okId notice) pst
+
+ getDialogType notice
+ = "Notice"
+
+/* A specialised version that ignores the error report.
+*/
+openNotice :: !(Notice .ls (PSt .l)) !(PSt .l) -> PSt .l
+openNotice notice pst
+ = snd (openModalDialog undef notice pst)
+
+/* noticeToDialog converts a Notice expression into a Dialog expression.
+*/
+noticeToDialog :: Id Id (Notice .ls (PSt .l))
+ -> *Dialog (:+: (LayoutControl (ListLS TextControl))
+ (:+: ButtonControl
+ (ListLS ButtonControl)
+ )) .ls (PSt .l)
+noticeToDialog wId okId (Notice texts (NoticeButton text f) buttons)
+ = Dialog ""
+ ( LayoutControl
+ ( ListLS
+ [ TextControl text [ControlPos (Left,zero)]
+ \\ text <- texts
+ ]
+ ) [ControlHMargin 0 0, ControlVMargin 0 0, ControlItemSpace 3 3]
+ :+: ButtonControl text
+ [ControlFunction (noticefun f), ControlPos (Right,zero), ControlId okId]
+ :+: ListLS
+ [ ButtonControl text [ControlFunction (noticefun f),ControlPos (LeftOfPrev,zero)]
+ \\ (NoticeButton text f) <- buttons
+ ]
+ )
+ [ WindowId wId
+ , WindowOk okId
+ ]
+where
+ noticefun f (ls,pst) = f (ls,closeWindow wId pst)
diff --git a/tut8_5.icl b/tut8_5.icl new file mode 100644 index 0000000..76a4752 --- /dev/null +++ b/tut8_5.icl @@ -0,0 +1,61 @@ +module tut8_5 + +// ******************************************************************************** +// Clean tutorial example program. +// +// This program creates a Multiple Document Interface process with a Window menu. +// ******************************************************************************** + +import StdEnv, StdIO, Notice + +Start :: *World -> *World +Start world +# (id, world) = openId world += startIO MDI Void (initialise id) [ProcessClose quit] world + +quit :: (PSt .l) -> PSt .l +quit pst = openNotice notice pst +where + notice = Notice ["Do you really want to quit?"] + (NoticeButton "&Ok" (noLS closeProcess)) + [NoticeButton "&Cancel" id] + +initialise :: Id (PSt .l) -> PSt .l +initialise closeid pst + # (err, pst) = openMenu 0 menu pst + | err <> NoError = abort "MDI could not open File Menu" + | otherwise = pst +where + menu = Menu "&File" + ({newLS=1, newDef=MenuItem "&New" [MenuShortKey 'n', MenuFunction new]} :+: + MenuItem "&Close" [MenuShortKey 'w', MenuFunction (noLS close), MenuId closeid, MenuSelectState Unable] :+: + MenuSeparator [] :+: + MenuItem "&Quit" [MenuShortKey 'q', MenuFunction (noLS quit)]) [] + + close :: (PSt .l) -> PSt .l + close pst + # pst = closeActiveWindow pst + # (rest, pst) = accPIO getWindowsStack pst + | isEmpty rest = appPIO (disableMenuElements [closeid]) pst + | otherwise = pst + + new :: (Int, PSt .l) -> (Int, PSt .l) + new (i,pst) + # (err, pst) = openWindow Void window pst + | err <> NoError + # notice = Notice ["MDI could not open new window"] (NoticeButton "&Ok" id) [] + = (i, openNotice notice pst) + | otherwise = (i+1, appPIO (enableMenuElements [closeid]) pst) + where + window = Window ("Window " +++ toString i) NilLS [ + WindowClose (noLS close), + WindowViewSize {w=300, h=300}, + WindowLook True look ] + + look :: SelectState UpdateState *Picture -> *Picture + look _ {newFrame=frame=:{corner1,corner2}} picture + # picture = unfill frame picture + # picture = draw frame picture + # picture = drawLine corner1 corner2 picture + = drawLine {corner1 & x=corner2.x} {corner2 & x=corner1.x} picture + |