module Interface.TV.Gtk where
import Control.Applicative (liftA2,(<$>))
import Control.Monad (when)
import Data.IORef
import Data.Maybe (fromMaybe)
import Data.Time (getCurrentTime,utctDayTime)
import Data.Title
import Data.Pair
import Data.Lambda
import Interface.TV.Input
import Interface.TV.Output
import Graphics.UI.Gtk
type In = Input MkI
type Out = Output MkI MkO
newtype MkI a = MkI { unMkI :: MkI' a }
type MkI' a = IO () -> IO (Widget, IO a, IO ())
newtype MkO a = MkO { unMkO :: MkO' a }
type MkO' a = IO (Widget, OI a, IO ())
type OI a = a -> IO ()
result :: (b -> b') -> ((a -> b) -> (a -> b'))
result = (.)
runOut :: Out a -> String -> a -> IO ()
runOut out name a = do
initGUI
(wid,sink,cleanup) <- unMkO (output out)
sink a
window <- windowNew
set window [ windowDefaultWidth := 200
, containerChild := wid
, windowFocusOnMap := True
, windowTitle := name
]
onDestroy window (cleanup >> mainQuit)
widgetShowAll window
mainGUI
return ()
data Orient = Horizontal | Vertical deriving (Read,Show)
boxNew :: Orient -> Bool -> Int -> IO Box
boxNew Vertical = boxer vBoxNew
boxNew Horizontal = boxer hBoxNew
boxer :: BoxClass box => (a -> b -> IO box) -> (a -> b -> IO Box)
boxer = (result.result.fmap) toBox
instance Pair MkI where
pair (MkI ia) (MkI ob) = MkI $ \ refresh ->
do box <- boxNew Horizontal True 10
(wa,geta,cleana) <- ia refresh
(wb,getb,cleanb) <- ob refresh
set box [ containerChild := wa , containerChild := wb ]
return (toWidget box, liftA2 (,) geta getb, cleana >> cleanb)
instance Pair MkO where
pair (MkO oa) (MkO ob) = MkO $
do box <- boxNew Horizontal True 10
(wa,snka,cleana) <- oa
(wb,snkb,cleanb) <- ob
set box [ containerChild := wa , containerChild := wb ]
return (toWidget box, \ (a,b) -> snka a >> snkb b, cleana >> cleanb)
instance Title_f MkI where
title_f str (MkI ia) = MkI $ \ refresh ->
do (widget,geta,cleana) <- ia refresh
frame <- frameNew
set frame [ frameLabel := str
, containerChild := widget ]
return (toWidget frame, geta, cleana)
instance Title_f MkO where
title_f str (MkO oa) = MkO $
do (widget,sink,clean) <- oa
frame <- frameNew
set frame [ frameLabel := str
, containerChild := widget ]
return (toWidget frame, sink, clean)
instance Lambda MkI MkO where
lambda (MkI ia) (MkO ob) = MkO $
mdo box <- boxNew Vertical True 10
reff <- newIORef (error "mkLambda: no function yet")
let update = do f <- readIORef reff
a <- geta
snkb (f a)
(wa,geta,cleana) <- ia update
(wb,snkb,cleanb) <- ob
set box [ containerChild := wa , containerChild := wb ]
return ( toWidget box
, \ f -> writeIORef reff f >> update
, cleana >> cleanb)
primMkI :: MkI' a -> In a
primMkI = iPrim . MkI
primMkO :: MkO' a -> Out a
primMkO = oPrim . MkO
type R = Float
sliderRI :: (R,R) -> R -> In R
sliderRI = sliderGIn realToFrac realToFrac 0.01 5
sliderII :: (Int,Int) -> Int -> In Int
sliderII = sliderGIn fromIntegral round 1 0
sliderGIn :: Eq a => (a -> Double) -> (Double -> a) -> a -> Int
-> (a,a) -> a -> In a
sliderGIn toD fromD step digits
(lo,hi) a0 = primMkI $ \ refresh ->
let changeTo getter new =
do old <- getter
when (old /= new) refresh
in
do w <- hScaleNewWithRange (toD lo) (toD hi) (toD step)
set w [ rangeValue := toD a0, scaleDigits := digits ]
let getter = fromD <$> get w rangeValue
onRangeChangeValue w (\ _ x -> changeTo getter (fromD x) >> return False)
return (toWidget w, getter, return ())
toggleI :: Bool -> In Bool
toggleI start = primMkI $ \ refresh ->
do w <- checkButtonNew
toggleButtonSetActive w start
onToggled w refresh
return (toWidget w, toggleButtonGetActive w, return ())
toggleO :: Out Bool
toggleO = primMkO $
do w <- checkButtonNew
return (toWidget w, toggleButtonSetActive w, return ())
mkFileName :: FilePath -> In FilePath
mkFileName start = primMkI $ \ refresh ->
do w <- fileChooserButtonNew "Select file" FileChooserActionOpen
fileChooserSetFilename w start
onCurrentFolderChanged w refresh
return ( toWidget w
, fromMaybe start <$> fileChooserGetFilename w
, return () )
textI :: String -> In String
textI start = primMkI $ \ refresh ->
do entry <- entryNew
entrySetText entry start
onEntryActivate entry refresh
return (toWidget entry, entryGetText entry, return ())
textO :: Out String
textO = primMkO $
do entry <- entryNew
return (toWidget entry, entrySetText entry, return ())
clockDtI :: R -> In R
clockDtI period = primMkI $ \ refresh ->
do start <- time
timeout <- timeoutAddFull (refresh >> return True)
priorityDefaultIdle (round (period * 1000))
w <- vBoxNew True 0
return (toWidget w, subtract start <$> time, timeoutRemove timeout)
clockI :: In R
clockI = clockDtI (1/60)
time :: IO R
time = (fromRational . toRational . utctDayTime) <$> getCurrentTime