import Tk

-- auxiliary function for simple menu bars
menubar :: Window -> [(String,[(String,Cmd ())])] -> Cmd Packable
menubar w ms = do 
  f <- w.frame [BorderWidth 1, Relief Raised]
  ms <- mapM (setMenu f) ms
  pack(row(map rigid ms))
  return (fillX f)
   where setMenu f (name,bs) = do
            mb <- f.menuButton [Text name]
            m  <- mb.menu []
            es <- mapM (\(name,cmd) -> m.mButton [CLabel name, Command cmd]) bs
            return mb
         
-- auxiliary function for simple toolbars
toolbar :: Window -> [(Image,Cmd ())] -> Cmd Packable
toolbar w ts = do
  f <- w.frame [BorderWidth 1, Relief Raised]
  ms <- mapM (mkToolEntry f) ts
  pack(row(map rigid ms))
  return (fillX f)
    where mkToolEntry f (i,c) = do
            l <- f.label [Img i,BorderWidth 1, Relief Raised]
            l.bind [ButtonPress 1 (const c)]
            return l

-- arranging Packables in a matrix. No width correction, 
-- i.e. the individual Packables must have same width.
matrix :: Int -> [Packable] -> Packable
matrix n ps = col(map row (splitSegs n ps))
           where splitSegs n xs = if n >= length xs then [xs]
                                  else (as : splitSegs n bs)
                                  where (as,bs) = splitAt n xs



-- Groups of radiobuttons controlling a value 
struct RadioGroup a < WWidget StdOpt, Cell(Maybe a)
radio :: (Show a, Read a) =>           -- we communicate via strings...
           BasicWindow b ->                   -- to display in
           [([RadioButtonOpt],a)] ->   -- option/value pairs for all buttons
           [FrameOpt] ->               -- options for the whole frame
           Int ->                      -- nr of columns
           Cmd(RadioGroup a)
radio win rs fs n = do 
   let (oss,vs) = unzip rs
   f <- win.frame fs
   bs <- mapM f.radioButton oss
   x <- primGetPath  -- to get a unique name
   forall (r,a) <- zip bs vs do
      primExTcl_ [r.ident,"configure -variable",x,"-value",show a] 
   pack (matrix n bs)    
   template in
    struct
      ident   = f.ident
      destroy = f.destroy
      exists  = f.exists
      set     = f.set
      focus   = f.focus
      lower   = f.lower
      raise   = f.raise
      bind    = f.bind
      packIn  = f.packIn
      wname   = f.wname
      setValue a = action
        case a of 
          Nothing ->  primExTcl_ ["global",x,"; set",x,"\"\""]
          Just v -> primExTcl_ ["global",x,"; set",x,show v]
      getValue = request 
          a <- primExTcl ["global",x,"; set",x]
          if a=="" then
             return Nothing
          else 
             return(Just(read a))


messageDialog :: Tk -> String -> String -> Cmd () -> Cmd ()
messageDialog env title message cmd = dialog env title (Just info) message [("OK",cmd)]

-- Modal dialog box with a row of buttons associated with actions
dialog :: Tk -> 
          String ->           -- dialog window title
          Maybe PredefBitmap ->     
          String ->           -- text in top of window
          [(String,Cmd ())] -> -- button text/command pairs
          Cmd ()
dialog tk title bmp text alts = do
         primExTcl_ ["update"]
         win <- tk.window [Title title]
         top <- win.frame [BorderWidth 1, Relief Raised]
         lab1 <- top.label [Anchor C]
         case bmp of
            Just img -> lab1.set [Btmp img]
                        lab1.set [ Width 30]
            Nothing ->  done
         lab2 <- top.label [Text text,Font "times 16", Padx 10, Pady 10]
         pack(lab1<<<lab2)
         let f act = do
           primExTcl_ ["grab release",win.ident]
           win.destroy 
           act
         bs <- mapM (\(text,act) -> win.button [Text text, Command (f act)]) alts 
         pack (top ^^^ rigid (row bs))
         tk.delay 10 (\_ -> primExTcl_ ["grab set",win.ident])
         done

-- Modal dialog box with a text entry associated with an action
dialog2 :: Tk -> 
           String ->             -- dialog window title
           String ->             -- text in top of window
           String ->             -- default text entry
           (String -> Cmd ()) -> -- action when user closes window
           Cmd ()
dialog2 tk title text def cmd = do
         win <- tk.window [Title title]
         top <- win.frame [BorderWidth 1, Relief Raised]
         lab1 <- top.label [Btmp question, Anchor C]
         lab2 <- top.label [Text text, Font "times 16", Padx 10, Pady 10]
         pack(lab1<<<lab2)
         ent <- win.entry [Width 20]
         ent.setValue def
         let f act = do
               act
               primExTcl_ ["grab release",win.ident]
               win.destroy 
             react = do s <- ent.getValue; cmd s
         bs <- mapM (\(text,act) -> win.button [Text text, Command (f act)]) 
                    [("OK",react),("Cancel",done)]
         ent.bind [KeyPress "Return" (f react)]
         pack (col[top, ent,row bs])
         tk.delay 10 (\_ -> primExTcl_ ["grab set",win.ident])
         done

-- function to add scrollbars to a ScrollWidget 
-- the typing prevents use of this function to decorate an Entry,
-- which is the only ScrollWidget not supporting vertical scrollbars.
addScrollbars :: Frame -> ScrollWidget StdOpt -> Cmd (WWidget StdOpt)
addScrollbars f wid = do
  sv    <- f.scrollBar []
  sh    <- f.scrollBar []
  dummy <- f.canvas [Width 18, Height 18]
  sv.attach wid Ver
  sh.attach wid Hor
  pack ((wid <<< fillY sv) ^^^ fillX (sh <<< rigid dummy))
  return f