module Graphics.UI.Gtk.Custom.JSInput where
import Text.JSON
import Data.Ratio
import Graphics.UI.Gtk as GTK
import Data.IORef
import Control.Monad.IO.Class
jsInputNew ::
[(String,JSValue)] ->
(Result [(String,JSValue)] -> IO())->
IO Widget
jsInputNew
feilds
onUpdate
= do
vb <- GTK.vBoxNew False 0
let
(JSObject initialObject) = makeObj feilds
valuesIORef <- newIORef feilds
let
addFeild (key,value) = do
element <- case value of
JSBool checked -> do
b <- GTK.checkButtonNewWithLabel key
set b [toggleButtonActive := checked
,toggleButtonMode := True]
b `on` GTK.toggled $ do
values <- readIORef valuesIORef
value <- get b toggleButtonActive
let
newValues =
map
(\(k,v)->
case k == key of
True -> (k,JSBool value)
False -> (k,v))
values
writeIORef valuesIORef newValues
onUpdate $ Ok newValues
GTK.boxPackStart vb b GTK.PackNatural 0
return $ castToWidget b
r@JSRational{} -> do
hb <- hBoxNew False 0
l <- labelNew $ Just key
GTK.boxPackStart hb l GTK.PackNatural 0
e <- GTK.entryNew
entrySetText e $ encode r
e `on` GTK.focusOutEvent $ liftIO $ do
values <- readIORef valuesIORef
text <- get e entryText
let
valueR' = decode text
valueR =
case valueR' of
Ok (rational@JSRational{}) -> Ok rational
Ok _ -> Error "Not a rational."
Error err -> Error err
newValuesR =
case valueR of
Ok val ->
Ok $ map
(\(k,v)->
case k == key of
True -> (k, val)
False -> (k,v))
values
Error err -> Error err
case newValuesR of
Ok newValues -> writeIORef valuesIORef newValues
_ -> return ()
onUpdate $ newValuesR
return False
GTK.boxPackStart hb e GTK.PackNatural 0
GTK.boxPackStart vb hb GTK.PackNatural 0
return $ castToWidget hb
JSString jsstring -> do
hb <- vBoxNew False 0
l <- labelNew $ Just key
GTK.boxPackStart hb l GTK.PackNatural 0
tb <- GTK.textBufferNew Nothing
GTK.textBufferSetText tb $ fromJSString jsstring
tv <- GTK.textViewNewWithBuffer tb
tv `on` GTK.focusOutEvent $ liftIO $ do
values <- readIORef valuesIORef
text <- get tb textBufferText
let
newValuesR =
Ok $ map
(\(k,v)->
case k == key of
True -> (k, JSString $ toJSString text)
False -> (k,v))
values
case newValuesR of
Ok newValues -> writeIORef valuesIORef newValues
_ -> return ()
onUpdate $ newValuesR
return False
GTK.boxPackStart hb tv GTK.PackGrow 0
GTK.boxPackStart vb hb GTK.PackGrow 0
return $ castToWidget hb
_ -> return $ error "Unsupported value type. We only support Bool Rational and String, sorry!"
return ()
mapM addFeild feilds
return $ castToWidget vb