EmbeddedTree.hs

{-# LANGUAGE FlexibleContexts, FlexibleInstances
  , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-}

module EmbeddedTree where

import Graphics.UI.WX as Wx
import Graphics.UI.AF.AFWx as AF   -- cannot do qualified as `derive` then complains

data Tree = Branch { left :: Tree, right :: Tree }
          | Leaf Int    deriving (Show, Eq)
$(AF.derive [''Tree])

-- Should not be neccesary, but GHC 6.6 requires it. Remove when we stop support for GHC 6.6.
instance AF.ECCreator Tree

simpleTree  = Leaf 2
complexTree = Branch (Branch (Leaf 3) (Leaf 123)) (Leaf 2)

main :: IO ()
main = start $
    do w <- frame [text := "Embedded Tree"]
       p <- panel w []
       ps <- scrolledWindow p [ scrollRate := sz 10 10 ]
              
       -- wid <- AF.makeWidget complexTree ps [ Wx.enabled := False ] -- Simple widget without autoform functions
       let limitTree (Leaf x) = return (x < 117)
           limitTree _        = return True
           changeEditorComponent :: AF.EC Tree -> AF.EC Tree
           changeEditorComponent = AF.limit limitTree "Rejected by limit-tree"
           -- focusOn will not work until `AFWx a` becomes a `Window (AFWx a)`.
       wid <- AF.makeWidget' changeEditorComponent complexTree ps [ enabled := False ]
       simpleTreeButton    <- button p [ text := "Simple tree", Wx.enabled := True
                                       , on command := set wid [ value := simpleTree ]
                                       ]
       disableButton       <- button p [ text := "Disable", enabled := True
                                       , on command := set wid [ enabled := False ]
                                       ]
       enableButton        <- button p [ text := "Enable", enabled := True
                                       , on command := set wid [ enabled := True ]
                                       ]
       set wid [ on Wx.command := do val <- get wid value
                                     putStr $ "Value changed by user input: " ++ show val ++ "\n"
               ]
       
       set w [ layout := container p $ fill $ column 10
                          [ container ps $ fill $ widget wid
                          , hfill $ valignBottom $ row 5
                                      [ widget disableButton
                                      , widget enableButton
                                      , widget simpleTreeButton
                                      ]
                          ]
             ]