module Tk where infix 6 ^^^ infix 7 <<< struct Tk = window :: [WindowOpt] -> Request Window bitmap :: [BitmapOpt] -> Request ConfBitmap photo :: [PhotoOpt] -> Request Photo delay :: Int -> (String -> Cmd ()) -> Request String periodic :: Int -> Cmd () -> Request Runnable bell :: Action font :: String -> Request TkFont -- Windows struct BasicWindow a < ConfWidget a = button :: [ButtonOpt] -> Request Button canvas :: [CanvasOpt] -> Request Canvas checkButton :: [CheckButtonOpt] -> Request CheckButton entry :: [EntryOpt] -> Request Entry frame :: [FrameOpt] -> Request Frame label :: [LabelOpt] -> Request Label listBox :: [ListBoxOpt] -> Request ListBox menuButton :: [MenuButtonOpt] -> Request MenuButton radioButton :: [RadioButtonOpt] -> Request RadioButton scrollBar :: [ScrollBarOpt] -> Request ScrollBar slider :: [SliderOpt] -> Request Slider textEditor :: [TextEditorOpt] -> Request TextEditor type Pos = (Int,Int) struct ManagedWindow = getGeometry :: Request (Pos,Pos) -- size,position setSize :: Pos -> Action setPosition :: Pos -> Action iconify :: Action deiconify :: Action -- top level windows struct Window < BasicWindow WindowOpt, ManagedWindow -- Images struct Image = imageName :: String struct Bitmap < Image struct ConfBitmap < Bitmap, Configurable BitmapOpt struct PredefBitmap < Bitmap struct Photo < Image, Configurable PhotoOpt = blank :: Action putPixel :: Pos -> Color -> Action getPixel :: Pos -> Request Color copyFrom :: Photo -> Action -- to be refined saveAs :: FilePath -> Action struct Runnable = start :: Action stop :: Action struct TkEnv < Tk, StdEnv -- General widget structures struct Widget = ident :: String destroy :: Action exists :: Request Bool focus, raise, lower :: Action bind :: [Event] -> Action struct Configurable a = set :: [a] -> Action struct ConfWidget a < Widget, Configurable a -- Structures for subtyping by WWidgets struct Cell a = setValue :: a -> Action getValue :: Request a struct LineEditable = lines :: Request Int getLine :: Int -> Request String deleteLine :: Int -> Action insertLines :: Int -> [String] -> Action struct Invokable = invoke :: Action struct Packable = packIn :: String -> Dir -> Stretch -> Expansion -> Cmd () wname :: String struct Scannable a = mark :: a -> Action drag :: a -> Action struct WWidget a < ConfWidget a, Packable struct ScrollWidget a < WWidget a = xview :: Request (Double,Double) yview :: Request (Double,Double) -- Window widgets struct Frame < BasicWindow FrameOpt, WWidget FrameOpt struct Slider < WWidget SliderOpt, Cell Int struct Button < WWidget ButtonOpt, Invokable = flash :: Action struct CheckButton < Button = toggle :: Action checked :: Request Bool struct RadioButton < Button = select :: Action deselect :: Action struct MenuButton < WWidget MenuButtonOpt = menu :: [MenuOpt] -> Request Menu struct Label < WWidget LabelOpt struct ListBox < ScrollWidget ListBoxOpt, LineEditable, Cell [Int], Scannable Pos = view :: Int -> Action struct TextEditor < ScrollWidget TextEditorOpt, LineEditable, Scannable Pos struct Entry < ScrollWidget EntryOpt, Cell String, Scannable Int = cursorPos :: Request Int struct Canvas < ScrollWidget CanvasOpt, Scannable Pos = oval :: Pos -> Pos -> [OvalOpt] -> Request Oval arc :: Pos -> Pos -> [ArcOpt] -> Request Arc rectangle :: Pos -> Pos -> [RectangleOpt] -> Request Rectangle line :: [Pos] -> [LineOpt] -> Request Line polygon :: [Pos] -> [PolygonOpt] -> Request Polygon text :: Pos -> [CTextOpt] -> Request CText image :: Pos -> [CImageOpt] -> Request CImage cwindow :: Pos -> [CWindowOpt] -> Request CWindow clear :: Action save :: FilePath -> Action struct ScrollBar < WWidget ScrollBarOpt = attach :: ScrollWidget BasicWOpt -> Dir -> Action -- Canvas Widgets struct CWidget a < ConfWidget a = getCoords :: Request [Pos] setCoords :: [Pos] -> Action move :: Pos -> Action struct Arc < CWidget ArcOpt struct Oval < CWidget OvalOpt struct Rectangle < CWidget RectangleOpt struct Line < CWidget LineOpt struct Polygon < CWidget PolygonOpt struct CText < CWidget CTextOpt struct CImage < CWidget CImageOpt struct CWindow < CWidget WindowOpt, BasicWindow WindowOpt -- Menus struct Menu < ConfWidget MenuOpt = mButton :: [MButtonOpt] -> Request MButton cascade :: [MButtonOpt] -> Request Menu struct MButton < Configurable MButtonOpt, Invokable -- Color data Color = RGB Int Int Int deriving (Eq) black = RGB 0 0 0 white = RGB 255 255 255 red = RGB 255 0 0 green = RGB 0 255 0 blue = RGB 0 0 255 yellow = RGB 255 255 0 rgb :: Int -> Int -> Int -> Color rgb r g b = RGB r g b -- Auxiliary types for options data None = None data AnchorType = NW | N | NE | W | C | E | SW | S | SE data ReliefType = Raised | Sunken | Flat | Ridge | Solid | Groove data VertSide = Top | Bottom data WrapType = NoWrap | CharWrap | WordWrap data SelectType = Single | Multiple data Align = LeftAlign | CenterAlign | RightAlign data Round = Round data ArcStyleType = Pie | Chord | Perimeter data CapStyleType > Round = Butt | Proj data JoinStyleType > Round = Bevel | Miter data ArrowType > None = First | Last | Both -- Options data Anchor = Anchor AnchorType data Angles = Angles Pos data ArcStyle = ArcStyle ArcStyleType data Arrow = Arrow ArrowType data Background = Background Color data BitmapData = BitmapData String data BorderWidth = BorderWidth Int data Btmp = Btmp PredefBitmap data CapStyle = CapStyle CapStyleType data CLabel = CLabel String data CmdInt = CmdInt (Int -> Cmd ()) data Command = Command (Cmd ()) data Cursor = Cursor String data Enabled = Enabled Bool data File = File FilePath data Fill = Fill Color data Font = Font String | NamedFont TkFont data Foreground = Foreground Color data From = From Int data Height = Height Int data Img = Img Image data Indicatoron = Indicatoron Bool data JoinStyle = JoinStyle JoinStyleType data Justify = Justify Align data Length = Length Int data Orientation = Orientation Dir data Outline = Outline Color data Padx = Padx Int data Pady = Pady Int data Relief = Relief ReliefType data ScrollRegion = ScrollRegion (Int,Int) (Int,Int) data SelectMode = SelectMode SelectType data SelectColor = SelectColor (Maybe Color) data Smooth = Smooth Bool data Stipple = Stipple String data Text = Text String data Title = Title String data To = To Int data Underline = Underline Int data Width = Width Int data Wrap = Wrap WrapType -- widget option types data BasicOpt > Background, BorderWidth, Cursor, Relief data BasicWOpt > BasicOpt, Width data DimOpt > Height, Width data StdOpt > BasicWOpt, DimOpt data FontOpt > Font, Foreground, Anchor, Justify data PadOpt > Padx, Pady data WindowOpt > BasicOpt, Title data PhotoOpt > DimOpt, File data BitmapOpt > Background, Foreground, File, BitmapData data ButtonOpt > MenuButtonOpt, Command data CanvasOpt > StdOpt, ScrollRegion data CheckButtonOpt > ButtonOpt, Indicatoron, SelectColor data EntryOpt > BasicWOpt, Justify, Font, Foreground, Enabled type FrameOpt = StdOpt data LabelOpt > StdOpt, FontOpt, PadOpt, Img, Btmp, Underline, Text data ListBoxOpt > StdOpt, Font, Foreground, SelectMode data MenuButtonOpt > LabelOpt, Enabled type RadioButtonOpt = CheckButtonOpt type ScrollBarOpt = StdOpt data SliderOpt > BasicWOpt, From, To, Orientation, Length, Font, Foreground, CmdInt, Enabled data TextEditorOpt > StdOpt, Font, Foreground, PadOpt, Wrap, Enabled data CBasicOpt > Fill, Width, Stipple data CImageOpt > Anchor, Img, Btmp data CTextOpt > Font, Justify, Text, Anchor, Fill data CWindowOpt > DimOpt, Anchor data LineOpt > CBasicOpt, Arrow, Smooth, CapStyle, JoinStyle data PolygonOpt > OvalOpt, Smooth data ArcOpt > OvalOpt, ArcStyle, Angles data OvalOpt > CBasicOpt, Outline data RectangleOpt > OvalOpt data MenuOpt > WindowOpt, Enabled data MButtonOpt > StdOpt, FontOpt, PadOpt, Img, Btmp, Underline, CLabel, Enabled, Command data AllOpt > MenuOpt, CheckButtonOpt, TextEditorOpt, FrameOpt, LineOpt, WindowOpt, ArcOpt, PolygonOpt, OvalOpt, CTextOpt, RectangleOpt, SliderOpt, MButtonOpt, CanvasOpt, ListBoxOpt, BitmapOpt, PhotoOpt, CImageOpt, EntryOpt, CWindowOpt, ButtonOpt, MenuButtonOpt, LabelOpt --- Events data ButtonPress = ButtonPress Int (Pos -> Cmd ()) | AnyButtonPress (Int -> Pos -> Cmd ()) data MouseEvent > ButtonPress = ButtonRelease Int (Pos -> Cmd ()) | AnyButtonRelease (Int -> Pos -> Cmd ()) | Motion Int (Pos -> Cmd ()) | AnyMotion (Pos -> Cmd ()) | Double ButtonPress | Triple ButtonPress data WindowEvent = Enter (Cmd ()) | Leave (Cmd ()) | Configure (Pos -> Cmd ()) data SimpleKeyEvent = KeyPress String (Cmd ()) | KeyRelease String (Cmd ()) | AnyKeyPress (String -> Cmd ()) data KeyEvent > SimpleKeyEvent = Mod [Modifier] SimpleKeyEvent data Modifier = Alt | Control | Lock | Meta | Shift deriving Show data DestroyEvent = Destroy (Cmd ()) data Event > MouseEvent, KeyEvent, WindowEvent, DestroyEvent --- Packing (row,col) = (p Hor, p Ver) where p dir as = struct packIn = lpackIn as dir XYFill True wname = a.wname where a = if null as then error "row/col []" else head as fill fillMode exp p = struct packIn mstr dir _ _ = p.packIn mstr dir fillMode exp wname = p.wname rigid = fill None False fillX = fill XFill False fillY = fill YFill False p1 <<< p2 = row [p1,p2] p1 ^^^ p2 = col [p1,p2] pack :: Packable -> Cmd () pack p = p.packIn p.wname Ver XYFill True instance Show ArrowType where showsPrec _ None rest = "none"++rest showsPrec _ First rest = "frst"++rest showsPrec _ Last rest = "last"++rest showsPrec _ Both rest = "both"++rest instance Show ArcStyleType where showsPrec _ Pie rest = "pieslice"++rest showsPrec _ Chord rest = "chord"++rest showsPrec _ Perimeter rest = "arc"++rest instance Show CapStyleType where showsPrec _ Round rest = "round"++rest showsPrec _ Butt rest = "butt"++rest showsPrec _ Proj rest = "projecting"++rest instance Show JoinStyleType where showsPrec _ Round rest = "round"++rest showsPrec _ Bevel rest = "bevel"++rest showsPrec _ Miter rest = "miter"++rest instance Show AnchorType where showsPrec _ NW rest = "nw"++rest showsPrec _ N rest = "n"++rest showsPrec _ NE rest = "ne"++rest showsPrec _ W rest = "w"++rest showsPrec _ C rest = "c"++rest showsPrec _ E rest = "e"++rest showsPrec _ SW rest = "sw"++rest showsPrec _ S rest = "s"++rest showsPrec _ SE rest = "se"++rest instance Show ReliefType where showsPrec _ Raised rest = "raised"++rest showsPrec _ Sunken rest = "sunken"++rest showsPrec _ Flat rest = "flat"++rest showsPrec _ Ridge rest = "ridge"++rest showsPrec _ Solid rest = "solid"++rest showsPrec _ Groove rest = "groove"++rest instance Show VertSide where showsPrec _ Top rest = "top"++rest showsPrec _ Bottom rest = "bottom"++rest app ::String -> String -> String app "." y = y app x y = x++y instance Show Color where showsPrec _ col rest = case col of RGB r g b -> rgb r g b++ rest where rgb r g b = "#" ++ concat (map (hex 2 "") [r,g,b]) hex 0 rs _ = rs hex t rs 0 = hex (t-1) ('0':rs) 0 hex t rs i = let m = mod i 16 in hex (t-1)((chr (48+m+7*(div m 10))):rs)(div i 16) quoteString s = "\"" ++ concatMap quote s ++ "\"" where quote '$' = "\\$" quote '[' = "\\[" quote '"' = "\\\"" quote '\\' = "\\\\" quote c = [c] --textOpt :: AllOpt -> Cmd String textOpt opt = case opt of Anchor a -> return(unwords ["anchor",show a]) Angles (x,y) -> return(unwords ["start",show x,"-extent",show y]) ArcStyle a -> return(unwords ["style",show a]) Arrow a -> return(unwords ["arrow",show a]) Background c -> return(unwords ["background",show c]) BorderWidth n -> return(unwords ["borderwidth",show n]) BitmapData str -> return(unwords ["data ",quoteString str]) CapStyle c -> return(unwords ["capstyle",show c]) Btmp bmp -> return(unwords ["bitmap",bmp.imageName]) CLabel str -> return(unwords ["label ",quoteString str]) Cursor str -> return(unwords ["cursor",str]) Command a -> do n <- primAddCallBack (\_ -> a) return ("command {doEvent " ++ show n ++ "}") CmdInt a -> do let f str = a(read y) where [x,y] = words str n <- primAddCallBack f return ("command {doEvent " ++ show n ++ "}") Enabled s -> return(unwords ["state",enabled s]) File p -> return(unwords ["file",p]) Fill c -> return(unwords ["fill",show c]) Foreground c -> return(unwords ["foreground",show c]) Font str -> return(unwords ["font",quoteString str]) NamedFont f -> return(unwords ["font",quoteString (f.fontName)]) From x -> return(unwords ["from",show x]) Height h -> return(unwords ["height",show h]) Img image -> return(unwords ["image",image.imageName]) Indicatoron b -> return(unwords ["indicatoron", show b]) JoinStyle c -> return(unwords ["joinstyle",show c]) Justify a -> return(unwords ["justify", textAlign a]) Length n -> return(unwords ["length",show n]) Orientation d -> return(unwords ["orient",show d]) Outline c -> return(unwords ["outline",show c]) Padx n -> return(unwords ["padx",show n]) Pady n -> return(unwords ["pady",show n]) Relief r -> return(unwords ["relief",show r]) ScrollRegion (x1,y1) (x2,y2) -> return(unwords("scrollregion {":[show x1, show y1, show x2, show y2]++["}"])) SelectMode s -> return(unwords ["selectmode",textSelect s]) SelectColor Nothing -> return(unwords ["selectcolor","\"\""]) SelectColor (Just c) -> return(unwords ["selectcolor", show c]) Smooth b -> return(unwords ["smooth",show b]) Stipple file -> return(unwords ["stipple",'@':file]) Text str -> return(unwords ["text", quoteString str]) Title str -> return(unwords ["title", quoteString str]) To x -> return(unwords ["to",show x]) Underline x -> return(unwords ["underline",show x]) Width w -> return(unwords ["width",show w]) Wrap w -> return(unwords ["wrap",textWrap w]) enabled :: Bool -> String enabled True = "normal" enabled False = "disabled" textOpts :: [AllOpt ] -> Cmd String textOpts opts = do os <- mapM textOpt opts return (concatMap (" -"++) os) textEv ev = '<':t ev++">" where t (ButtonPress n _) = "ButtonPress-"++show n t (AnyButtonPress _) = "ButtonPress" t (ButtonRelease n _) = "ButtonRelease-"++show n t (AnyButtonRelease _)= "ButtonRelease" t (Motion n _) = 'B':show n++"-Motion" t (AnyMotion _) = "Motion" t (Double bp) = "Double-"++t bp t (Triple bp) = "Triple-"++t bp t (Enter _) = "Enter" t (Leave _) = "Leave" t (Configure _) = "Configure" t (KeyPress c _) = "KeyPress-"++c t (KeyRelease c _) = "KeyRelease-"++c t (AnyKeyPress _) = "KeyPress" t (Mod ms sk) = concatMap (\m -> show m++"-") ms++t sk t (Destroy _) = "Destroy" textDir Hor = "-side left" textDir Ver = "-side top" instance Show Dir where showsPrec _ Hor rest = "hor"++rest showsPrec _ Ver rest = "ver"++rest instance Show Stretch where showsPrec _ None rest = rest showsPrec _ XFill rest = "-fill x"++rest showsPrec _ YFill rest = "-fill y"++rest showsPrec _ XYFill rest = "-fill both"++rest textExp False = "-expand 0" textExp True = "-expand 1" textSelect Single = "browse" textSelect Multiple = "extended" textWrap NoWrap = "none" textWrap CharWrap = "char" textWrap WordWrap = "word" textAlign LeftAlign = "left" textAlign CenterAlign = "center" textAlign RightAlign = "right" data Stretch > None = XFill | YFill | XYFill type Expansion = Bool data Dir = Hor | Ver wpackIn nm mstr dir fill exp = do primExTcl_ ["pack", nm, "-in", mstr, textDir dir, show fill, textExp exp] lpackIn as dir' fill' exp' mstr dir fill exp = do x <- primGetPath let nm0 = app mstr x col <- primExTcl[mstr,"configure -bg"] primExTcl_ ["frame",nm0,"-bg",last(words col)] primExTcl_ ["lower",nm0] primExTcl_ ["pack", nm0, "-in", mstr, textDir dir, show fill, textExp exp] forall a <- as do a.packIn nm0 dir' fill' exp' bnd init evs = do let g init ev nr end = init++[textEv ev,"{doEvent \"",show nr,end] forall ev <- evs do let bindxy f = do let a str = f (read xstr,read ystr) where [_,xstr,ystr] = words str nr <- primAddCallBack a primExTcl_ (g init ev nr "%x %y\"}") bindwh f = do let a str = f (read xstr,read ystr) where [_,xstr,ystr] = words str nr <- primAddCallBack a primExTcl_ (g init ev nr "%w %h\"}") bindbxy f = do let a str = f (read but) (read xstr,read ystr) where [_,but,xstr,ystr] = words str nr <- primAddCallBack a primExTcl_ (g init ev nr "%b %x %y\"}") bind_ f = do nr <- primAddCallBack (\_ -> f) primExTcl_ (g init ev nr "\"}") bindK f = do let a str = f ws where [_,ws] = words str nr <- primAddCallBack a primExTcl_ (g init ev nr "%K\"}") case ev of ButtonPress _ f -> bindxy f Double(ButtonPress _ f) -> bindxy f Triple(ButtonPress _ f) -> bindxy f ButtonRelease _ f -> bindxy f Motion _ f -> bindxy f AnyMotion f -> bindxy f AnyButtonPress f -> bindbxy f AnyButtonRelease f -> bindbxy f Enter a -> bind_ a Leave a -> bind_ a Configure f -> bindwh f KeyPress _ a -> bind_ a KeyRelease _ a -> bind_ a AnyKeyPress f -> bindK f Destroy f -> bind_ f widget nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs excmd nm = do b <- primExTcl["winfo exists",nm] return(toEnum(read b)) men :: String -> String -> Template Menu men wname nm = template index := -1 in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs mButton opts = request index := index+1 os <- textOpts opts primExTcl_ [nm,"add command", os] mbut nm index cascade opts = request index := index+1 os <- textOpts opts x <- primGetPath let nm1 = app nm x primExTcl_ ["menu",nm1] primExTcl_ [nm,"add cascade -menu",nm1,os] men wname nm1 mbut :: String -> Int -> Template MButton mbut nm index = template in struct invoke = primExTcl_ [nm,"invoke",show index] set os = action forall o <- os do ostr <- textOpt o primExTcl_ [nm,"entryconfigure",show index,'-': ostr] winsetcmd nm os = do forall o <- os do ostr <- textOpt o case o of Title str -> primExTcl_["wm title",nm,quoteString str] From _ -> primExTcl_[nm,"configure",'-': ostr] _ -> primExTcl_[nm,"configure",'-': ostr] setcmd :: String -> [AllOpt] -> Cmd () setcmd nm os = do ostr <- textOpts os primExTcl_[nm,"configure",ostr] bwin :: String -> Template (BasicWindow AllOpt) bwin nm = template in let ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs wwid wname f opts = request x <- primGetPath let nm0 = app nm x os <- textOpts opts primExTcl_ [wname,nm0,os] f nm nm0 button = wwid "button" but label = wwid "label" lab canvas = wwid "canvas" canv textEditor = wwid "text" editor listBox = wwid "listbox" lstbox entry = wwid "entry" ent radioButton = wwid "radiobutton" rdbut menuButton = wwid "menubutton" menubut scrollBar = wwid "scrollbar" scrbar frame opts = request x <- primGetPath let nm0 = app nm x os <- textOpts opts primExTcl_ ["frame",nm0,os] primExTcl_ ["lower",nm0] frm nm nm0 checkButton opts = request x <- primGetPath let nm0 = app nm x os <- textOpts opts primExTcl_ ["checkbutton",nm0,"-variable",nm0,os] chbut nm nm0 slider opts = request x <- primGetPath let nm0 = app nm x os <- textOpts opts primExTcl_ ["scale",nm0,"-variable",nm0,os] sldr nm nm0 in struct ..BasicWindow managedWindow :: String -> Template ManagedWindow managedWindow nm = template in struct getGeometry = request g <- primExTcl["winfo geometry",nm] return (parseGeometry g) setSize (w,h) = primExTcl_ ["wm geometry",nm,show w++"x"++show h] setPosition (x,y) = primExTcl_ ["wm geometry",nm,"+"++show x++"+"++show y] iconify = primExTcl_ ["wm iconify",nm] deiconify = primExTcl_ ["wm deiconify",nm] win :: String -> Template Window win nm = template bw <- bwin nm mw <- managedWindow nm in struct ident = bw.ident destroy = bw.destroy exists = bw.exists set os = action winsetcmd nm os focus = bw.focus lower = bw.lower raise = bw.raise bind = bw.bind button = bw.button canvas = bw.canvas checkButton = bw.checkButton entry = bw.entry frame = bw.frame label = bw.label listBox = bw.listBox menuButton = bw.menuButton radioButton = bw.radioButton scrollBar = bw.scrollBar slider = bw.slider textEditor = bw.textEditor getGeometry = mw.getGeometry setSize = mw.setSize setPosition = mw.setPosition iconify = mw.iconify deiconify = mw.deiconify parseGeometry str = ((read w,read h),(read x,read y)) where [(w,r1)] = lex str [(h,r2)] = lex(tail r1) [(x,r3)] = lex(tail r2) [(y,r4)] = lex(tail r3) scrbar :: String -> String -> Template ScrollBar scrbar wname nm = template wid <- widget nm in struct ident = wid.ident destroy = wid.destroy exists = wid.exists set = wid.set focus = wid.focus lower = wid.lower raise = wid.raise bind = wid.bind packIn = wpackIn nm wname = wname attach win dir = action let wn = win.ident case dir of Hor -> primExTcl_[wn,"configure -xscrollcommand {",nm,"set}"] primExTcl_[nm,"configure -orient hor -command {",wn,"xview}"] Ver -> primExTcl_[wn,"configure -yscrollcommand {",nm,"set}"] primExTcl_[nm,"configure -orient ver -command {",wn,"yview}"] but :: String -> String -> Template Button but wname nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs packIn = wpackIn nm wname = wname flash = primExTcl_[nm,"flash"] invoke = primExTcl_[nm,"invoke"] ent :: String -> String -> Template Entry ent wname nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs packIn = wpackIn nm wname = wname setValue a = action primExTcl_[nm,"delete 0 end"] primExTcl_[nm,"insert end",quoteString a] getValue = primExTcl[nm,"get"] mark x = primExTcl_[nm,"scan mark",show x] drag x = primExTcl_[nm,"scan dragto",show x] cursorPos = request ind <- primExTcl[nm,"index insert"] return(read ind) xview = request xy <- primExTcl [nm,"xview"] let [x,y] = words xy return (read0 x,read0 y) yview = request xy <- primExTcl [nm,"yview"] let [x,y] = words xy return (read0 x,read0 y) read0 :: String -> Double read0 "0" = 0.0 read0 "1" = 1.0 read0 str = read str frm :: String -> String -> Template Frame frm wname nm = template wwid <- bwin nm in struct ident = wwid.ident destroy = wwid.destroy exists = wwid.exists set = wwid.set focus = wwid.focus lower = wwid.lower raise = wwid.raise bind = wwid.bind button = wwid.button canvas = wwid.canvas checkButton = wwid.checkButton entry = wwid.entry frame = wwid.frame label = wwid.label listBox = wwid.listBox menuButton = wwid.menuButton radioButton = wwid.radioButton scrollBar = wwid.scrollBar slider = wwid.slider textEditor = wwid.textEditor packIn = wpackIn nm wname = wname chbut :: String -> String -> Template CheckButton chbut wname nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs packIn = wpackIn nm wname = wname flash = primExTcl_[nm,"flash"] invoke = primExTcl_[nm,"invoke"] toggle = primExTcl_[nm,"toggle"] checked = request s <- primExTcl["global",nm,"; set",nm] return(toEnum(read s)) rdbut :: String -> String -> Template RadioButton rdbut wname nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs packIn = wpackIn nm wname = wname flash = primExTcl_[nm,"flash"] invoke = primExTcl_[nm,"invoke"] select = primExTcl_[nm,"select"] deselect = primExTcl_[nm,"deselect"] menubut :: String -> String -> Template MenuButton menubut wname nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs packIn = wpackIn nm wname = wname menu opts = request x <- primGetPath let nm0 = app nm x os <- textOpts opts primExTcl_["menu",nm0,"-tearoff 0",os] primExTcl_[nm,"configure -menu",nm0] men wname nm0 sldr :: String -> String -> Template Slider sldr wname nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_ ["focus",nm] lower = primExTcl_ ["lower",nm] raise = primExTcl_ ["raise",nm] bind evs = action bnd ["bind",nm] evs packIn = wpackIn nm wname = wname setValue x = primExTcl_[nm,"set",show x] getValue = request x <- primExTcl["global",nm,"; set",nm] return(read x) lab :: String -> String -> Template Label lab wname nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_["focus",nm] lower = primExTcl_["lower",nm] raise = primExTcl_["raise",nm] bind evs = action bnd["bind",nm] evs packIn = wpackIn nm wname = wname editor :: String -> String -> Template TextEditor editor wname nm = template in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_["focus",nm] lower = primExTcl_["lower",nm] raise = primExTcl_["raise",nm] bind evs = action bnd["bind",nm] evs packIn = wpackIn nm wname = wname lines = request x <- primExTcl[nm, "index end"] return (read(takeWhile (/='.') x)-1) getLine n = primExTcl[nm, "get", show n++".0", show(n+1)++".0"] insertLines n ss = primExTcl_[nm, "insert", show n++".0", quoteString (unlines ss)] deleteLine n = primExTcl_[nm, "delete", show n++".0", show(n+1)++".0"] mark (x,y) = primExTcl_[nm,"scan mark",show x, show y] drag (x,y) = primExTcl_[nm,"scan dragto",show x, show y] xview = request xy <- primExTcl [nm,"xview"] let [x,y] = words xy return (read0 x,read0 y) yview = request xy <- primExTcl [nm,"yview"] let [x,y] = words xy return (read0 x,read0 y) lstbox :: String -> String -> Template ListBox lstbox wname nm = template wid <- widget nm in struct ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_["focus",nm] lower = primExTcl_["lower",nm] raise = primExTcl_["raise",nm] bind evs = action bnd["bind",nm] evs packIn = wpackIn nm wname = wname lines = request x <- primExTcl[nm, "size"] return (read x) getLine n = primExTcl[nm, "get", show n] insertLines n ss = primExTcl_([nm, "insert", show n," "]++ map (\s -> quoteString s ++" ") ss) deleteLine n = primExTcl_[nm, "delete", show n] setValue ns = action primExTcl_[nm, "selection clear 0 end"] forall n <- ns do primExTcl_[nm, "selection set", show n] getValue = request ns <- primExTcl[nm, "curselection"] return(map read (words ns)) mark (x,y) = primExTcl_[nm,"scan mark",show x, show y] drag (x,y) = primExTcl_[nm,"scan dragto",show x, show y] view n = primExTcl_[nm,"see",show n] xview = request xy <- primExTcl [nm,"xview"] let [x,y] = words xy return (read0 x,read0 y) yview = request xy <- primExTcl [nm,"yview"] let [x,y] = words xy return (read0 x,read0 y) canv :: String -> String -> Template Canvas canv wname' nm = template wid <- widget nm in let ident = nm destroy = primExTcl_["destroy",nm] exists = request excmd nm set os = action setcmd nm os focus = primExTcl_["focus",nm] lower = primExTcl_["lower",nm] raise = primExTcl_["raise",nm] bind evs = action bnd["bind",nm] evs packIn = wpackIn nm wname = wname' showall [] = [] showall ((x,y):ps) = show x:show y:showall ps cwid typ ps f opts = request os <- textOpts opts id <- primExTcl([nm,"create",typ]++ showall ps ++ [os]) f nm id oval p1 p2 = cwid "oval" [p1,p2] ovl arc p1 p2 = cwid "arc" [p1,p2] arcc rectangle p1 p2 = cwid "rectangle" [p1,p2] rect line ps = cwid "line" ps lne polygon ps = cwid "polygon" ps pgn text p = cwid "text" [p] txt image p = cwid "image" [p] cim cwindow p opts = request cwin nm p opts clear = primExTcl_ [nm,"delete all"] save file = primExTcl_[nm,"postscript -file",file] mark (x,y) = primExTcl_[nm,"scan mark",show x, show y] drag (x,y) = primExTcl_[nm,"scan dragto",show x, show y] xview = request xy <- primExTcl [nm,"xview"] let [x,y] = words xy return (read0 x,read0 y) yview = request xy <- primExTcl [nm,"yview"] let [x,y] = words xy return (read0 x,read0 y) in struct ..Canvas cwidget :: String -> String -> Template(CWidget AllOpt) cwidget nm id = template in let ident = (nm++'i':show id) destroy = primExTcl_[nm,"delete",id] exists = request t <- primExTcl[nm,"type",id] return(t/="") -- can't be the good way to do this... set os = action forall o <- os do ostr <- textOpt o primExTcl_ [nm,"itemconfigure",id,'-': ostr] focus = primExTcl_[nm,"focus",id] lower = primExTcl_[nm,"lower",id] raise = primExTcl_[nm,"raise",id] bind evs = action bnd [nm,"bind",id] evs getCoords = request str <- primExTcl[nm,"coords",id] return(coords (map (round . read) (words str))) where coords [] = [] coords (x:y:ps) = (x,y):coords ps setCoords ps = primExTcl_([nm,"coords",id]++ map (\(x,y) -> show x++" "++show y) ps) move (x,y) = primExTcl_[nm,"move",id,show x,show y] in struct ..CWidget -- This type signature is necessary. arcc :: String -> String -> Template Arc arcc nm id = template cwid <- cwidget nm id in struct ident = cwid.ident destroy = cwid.destroy exists = cwid.exists set = cwid.set focus = cwid.focus lower = cwid.lower raise = cwid.raise bind = cwid.bind getCoords = cwid.getCoords setCoords = cwid.setCoords move = cwid.move ovl :: String -> String -> Template Oval ovl nm id = template cwid <- cwidget nm id in struct ident = cwid.ident destroy = cwid.destroy exists = cwid.exists set = cwid.set focus = cwid.focus lower = cwid.lower raise = cwid.raise bind = cwid.bind getCoords = cwid.getCoords setCoords = cwid.setCoords move = cwid.move rect :: String -> String -> Template Rectangle rect nm id = template cwid <- cwidget nm id in struct ident = cwid.ident destroy = cwid.destroy exists = cwid.exists set = cwid.set focus = cwid.focus lower = cwid.lower raise = cwid.raise bind = cwid.bind getCoords = cwid.getCoords setCoords = cwid.setCoords move = cwid.move lne :: String -> String -> Template Line lne nm id = template cwid <- cwidget nm id in struct ident = cwid.ident destroy = cwid.destroy exists = cwid.exists set = cwid.set focus = cwid.focus lower = cwid.lower raise = cwid.raise bind = cwid.bind getCoords = cwid.getCoords setCoords = cwid.setCoords move = cwid.move pgn :: String -> String -> Template Polygon pgn nm id = template cwid <- cwidget nm id in struct ident = cwid.ident destroy = cwid.destroy exists = cwid.exists set = cwid.set focus = cwid.focus lower = cwid.lower raise = cwid.raise bind = cwid.bind getCoords = cwid.getCoords setCoords = cwid.setCoords move = cwid.move cim :: String -> String -> Template CImage cim nm id = template cwid <- cwidget nm id in struct ident = cwid.ident destroy = cwid.destroy exists = cwid.exists set = cwid.set focus = cwid.focus lower = cwid.lower raise = cwid.raise bind = cwid.bind getCoords = cwid.getCoords setCoords = cwid.setCoords move = cwid.move txt :: String -> String -> Template CText txt nm id = template cwid <- cwidget nm id in struct ident = cwid.ident destroy = cwid.destroy exists = cwid.exists set = cwid.set focus = cwid.focus lower = cwid.lower raise = cwid.raise bind = cwid.bind getCoords = cwid.getCoords setCoords = cwid.setCoords move = cwid.move cwin :: String -> Pos -> [CWindowOpt] -> Cmd CWindow cwin nm (x,y) opts = do p <- primGetPath let nmw = app nm p wwid <- bwin nmw os <- textOpts opts primExTcl_ ["frame",nmw] id <- primExTcl[nm,"create window",show x,show y,os,"-window",nmw] cwid <- cwidget nm id template in struct ident = cwid.ident destroy = cwid.destroy exists = cwid.exists set = cwid.set focus = cwid.focus lower = cwid.lower raise = cwid.raise bind = cwid.bind getCoords = cwid.getCoords setCoords = cwid.setCoords move = cwid.move button = wwid.button canvas = wwid.canvas checkButton = wwid.checkButton entry = wwid.entry frame = wwid.frame label = wwid.label listBox = wwid.listBox menuButton = wwid.menuButton radioButton = wwid.radioButton scrollBar = wwid.scrollBar slider = wwid.slider textEditor = wwid.textEditor btmp :: String -> Template ConfBitmap btmp nm = template in struct imageName = nm set os = action forall o <- os do ostr <- textOpt o primExTcl_[nm,"configure",'-': ostr] phto :: String -> Template Photo phto nm = template in struct imageName = nm set os = action forall o <- os do ostr <- textOpt o primExTcl_[nm,"configure",'-': ostr] blank = primExTcl_[nm,"blank"] putPixel (x,y) col = primExTcl_[nm,"put {{",show col,"}} -to",show x,show y] getPixel (x,y) = request str <- primExTcl[nm,"get",show x,show y] let [r,g,b] = words str return (RGB (read r) (read g) (read b)) copyFrom ph = primExTcl_[nm, "copy", ph.imageName] saveAs file = primExTcl_[nm,"write",file] stop, hourglass, info, questhead, question, warning :: PredefBitmap stop = struct imageName = "error" hourglass = struct imageName = "hourglass" info = struct imageName = "info" questhead = struct imageName = "questhead" question = struct imageName = "question" warning = struct imageName = "warning" struct TkFont = fontName :: String ascent :: Int descent :: Int linespace :: Int fixed :: Bool getTextWidth :: String -> Request Int tkfont name asc desc lsp fixed = template in struct fontName = name ascent = asc descent = desc linespace = lsp fixed = fixed getTextWidth str = request width <- primExTcl ["font measure",quoteString name, quoteString str] return (read width) hnd nm = template running := False in struct start = action if not running then running := True primExTcl_ [nm] stop = action running := False primExTcl_ ["after cancel",nm] primTk :: Template Tk primTk = template in let window opts = request x <- primGetPath primExTcl_["toplevel",x] winsetcmd x opts win x bell = primExTcl_ ["bell"] delay t a = request n <- primNextCallBack tag <- primExTcl ["after",show t, "{doEvent ",show n,"}"] let tag' = drop 6 tag -- all tags start with "after#" primAddCallBack (\_ -> a tag') return tag' periodic t a = request n <- primAddCallBack (\_ -> a) let ln = "loop"++show n primExTcl_["proc",ln,"{args} {haskellEvent ",show n,"\nupdate\nafter",show t,ln,"}"] hnd ln bitmap opts = request os <- textOpts opts nm <- primExTcl["image create bitmap",os] btmp nm photo opts = request os <- textOpts opts nm <- primExTcl["image create photo",os] phto nm font name = request ascent <- primExTcl ["font metrics",quoteString name,"-ascent"] descent <- primExTcl ["font metrics",quoteString name,"-descent"] lsp <- primExTcl ["font metrics",quoteString name,"-linespace"] fixed <- primExTcl ["font metrics",quoteString name,"-fixed"] tkfont name (read ascent) (read descent) (read lsp) (fixed=="1") in struct ..Tk primTkEnv :: Template TkEnv primTkEnv = template tkenv <- primTk env <- primStdEnvT in let window = tkenv.window bell = tkenv.bell delay = tkenv.delay periodic = tkenv.periodic bitmap = tkenv.bitmap photo = tkenv.photo font = tkenv.font putChar = env.putChar putStr = env.putStr putStrLn = env.putStrLn setReader a = action n <- primAddCallBack $ \_ -> action s <- primExTcl ["read stdin 1"] a (head s) primExTcl_ ["fileevent stdin readable {doEvent ",show n,"}"] setLineReader act = action setLineR act putChar >>= setReader writeFile = env.writeFile appendFile = env.appendFile readFile = env.readFile timeOfDay = env.timeOfDay progArgs = env.progArgs getEnv = env.getEnv devices = env.devices inet = env.inet sendMIDI = env.sendMIDI quit = env.quit in struct ..TkEnv primExTcl = primExecuteTcl . unwords primExTcl_ = primExecuteTcl_ . unwords primitive primTclDebug "primTclDebug" :: Bool -> Action primitive primInitTcl "primInitTcl" :: Request Bool primitive primRunTcl "primRunTcl" :: Request Bool primitive primExecuteTcl "primExecuteTcl" :: String -> Request String primitive primExecuteTcl_ "primExecuteTcl_" :: String -> Action primitive primSetVar "primSetVar" :: String -> String -> Action primitive primGetTcl "primGetTcl" :: Request String primitive primGetPath "primGetPath" :: Request String primitive primAddCallBack "primAddCallBack" :: (String -> Cmd ()) -> Request Int primitive primNextCallBack "primNextCallBack" :: Request Int