From 8c4d2170b5dbac4d82e2765cc63cfbe1ca9ead9a Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Wed, 19 Aug 2015 15:17:03 +0200 Subject: tut 8.5 (menu) --- .gitignore | 1 + Makefile | 2 +- Notice.dcl | 22 +++++++++++++++++++++ Notice.icl | 67 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tut8_5.icl | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 152 insertions(+), 1 deletion(-) create mode 100644 Notice.dcl create mode 100644 Notice.icl create mode 100644 tut8_5.icl diff --git a/.gitignore b/.gitignore index 9ea6d6a..bd3e9de 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ !.gitignore !*.icl +!*.dcl !Makefile !*.md !LICENSE diff --git a/Makefile b/Makefile index 4f0d2dd..25ccd32 100644 --- a/Makefile +++ b/Makefile @@ -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 + -- cgit v1.2.3