module GUI.MLens.Gtk.IO
( runI
) where
import Control.Category
import Control.Monad
import Control.Monad.Writer
import Control.Monad.Free
import Data.Maybe
import Prelude hiding ((.), id)
import Graphics.UI.Gtk
import Data.MLens.Ref
import Control.MLens.NewRef
import GUI.MLens.Gtk.Interface
type WriterState = (IO (), IO (), IO ())
type IOWriterState = WriterT WriterState IO
runI :: I IO -> IO ()
runI i = do
_ <- initGUI
dca <- newRef []
rea <- newRef True
(c, _) <- runWriterT $ userr_ rea dca i
window <- windowNew
set window [ containerBorderWidth := 10, containerChild := c ]
_ <- window `on` deleteEvent $ liftIO (mainQuit) >> return False
widgetShowAll window
mainGUI
where
userr_ :: Ref IO Bool -> Ref IO [Ref IO (Maybe (Bool, IO ()))] -> I IO -> IOWriterState Widget
userr_ rea dca i = case i of
Button s m -> do
w <- lift'' buttonNew
lift $ evalFree (maybe (return ()) ((\x -> on w buttonActivated x >> return ()) . react))
((\x -> on w buttonActivated x >> return ()) . react . join . fmap (maybe (return ()) id) . join . fmap (induce id)) m
s >>=.. buttonSetLabel w
fmap isJust m >>=.. widgetSetSensitive w
return' w
Entry k -> do
w <- lift'' entryNew
_ <- lift $ on w entryActivate $ react $ entryGetText w >>= writeRef k
readRef k >>=. entrySetText w
return' w
Checkbox k -> do
w <- lift'' checkButtonNew
_ <- lift $ on w toggled $ react $ toggleButtonGetActive w >>= writeRef k
readRef k >>=. toggleButtonSetActive w
return' w
Combobox ss k -> do
w <- lift'' comboBoxNewText
lift $ flip mapM_ ss $ comboBoxAppendText w
_ <- lift $ on w changed $ react $ fmap (max 0) (comboBoxGetActive w) >>= writeRef k
readRef k >>=. comboBoxSetActive w
return' w
List o xs -> do
w <- lift' $ case o of
Vertical -> fmap castToBox $ vBoxNew False 1
Horizontal -> fmap castToBox $ hBoxNew False 1
flip mapM_ xs $ flattenI' >=> containerAdd'' w
return' w
Notebook xs -> do
w <- lift' notebookNew
flip mapM_ xs $ \(s, i) ->
flattenI' i >>= lift . flip (notebookAppendPage w) s
return' w
Label s -> do
w <- lift'' $ labelNew Nothing
s >>=.. labelSetLabel w
return' w
Action m ->
lift m >>= flattenI'
Cell False m f -> do
w <- lift' $ alignmentNew 0 0 1 1
cancelc <- lift $ newRef mempty
togglec <- lift $ newRef mempty
showc <- lift $ newRef mempty
let cc = (readRef cancelc >>= id) >> writeRef cancelc mempty >> writeRef togglec mempty >> writeRef showc mempty
let cc' = readRef togglec >>= id
let cc'' = readRef showc >>= id
tell (cc, cc', cc'')
m >>=. \new -> do
cc
containerForeach w $ containerRemove w
(x, (c1, c2, c3)) <- runWriterT $ flattenI' (f new)
writeRef cancelc c1
writeRef togglec c2
writeRef showc c3
containerAdd w x
widgetShowAll w
return' w
Cell True m f -> do
w <- lift' $ hBoxNew False 1
tri <- lift $ newRef []
cancelc <- lift $ newRef mempty
togglec <- lift $ newRef mempty
showc <- lift $ newRef mempty
let cc = (readRef cancelc >>= id) >> writeRef cancelc mempty >> writeRef togglec mempty >> writeRef showc mempty
let cc' = readRef togglec >>= id
let cc'' = readRef showc >>= id
tell (cc, cc', cc'')
m >>=. \new -> do
cc'
containerForeach w $ widgetHideAll
t <- readRef tri
case [b | (a,b) <-t, a == new] of
[] -> do
(x, (c1, c2, c3)) <- runWriterT $ flattenI' $ f new
modRef cancelc (>> c1)
containerAdd w x
widgetShowAll x
modRef tri ((new, (c2, c3)) :)
writeRef togglec c2
writeRef showc c3
[(c2, c3)] -> do
c2
c3
writeRef togglec c2
writeRef showc c3
return' w
where
flattenI' = userr_ rea dca
infixl 1 >>=.., >>=.
m >>=.. f = evalFree (lift . f) ((>>=. f) . join . fmap (induce id)) m
(>>=.) :: (Eq a) => IO a -> (a -> IO ()) -> IOWriterState ()
get >>=. install = lift get >>= \x -> do
v <- lift $ newRef x
b <- lift $ newRef $ Just $ (,) True $ do
x <- readRef v
x' <- get
when (x /= x') $ do
writeRef v x'
install x'
return ()
lift $ modRef dca (b :)
tell (writeRef b Nothing, modRef b $ fmap $ mapFst not, mempty)
lift $ install x
react :: IO () -> IO ()
react a = do
b <- readRef rea
when b $ do
writeRef rea False
a
xs <- readRef dca
writeRef dca ([] :: [Ref IO (Maybe (Bool, IO ()))])
let ff (Just (b, m)) = when b m >> return True
ff Nothing = return False
xs' <- filterM ((>>= ff) . readRef) . reverse $ xs
modRef dca (++ reverse xs')
writeRef rea True
return' :: GObjectClass x => x -> IOWriterState Widget
return' = return . castToWidget
lift' m = do
x <- lift m
tell (mempty, mempty, widgetShow (castToWidget x))
return x
lift'' m = do
x <- lift m
tell (mempty, mempty, widgetShowAll (castToWidget x))
return x
containerAdd'' w x = do
a <- lift' $ alignmentNew 0 0 0 0
lift $ containerAdd a x
lift $ containerAdd w a
lift $ set w [ boxChildPacking a := PackNatural ]
mapFst f (a, b) = (f a, b)
instance Monoid (IO ()) where
mempty = return ()
mappend = (>>)