GtkTV (empty) → 0.0.0
raw patch · 6 files changed
+385/−0 lines, 6 filesdep +TVdep +TypeComposedep +basesetup-changed
Dependencies added: TV, TypeCompose, base, gtk, time
Files
- COPYING +25/−0
- GtkTV.cabal +32/−0
- Makefile +1/−0
- Setup.lhs +3/−0
- examples/test.hs +78/−0
- src/Interface/TV/Gtk.hs +246/−0
+ COPYING view
@@ -0,0 +1,25 @@+Copyright (c) 2009 Conal Elliott+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. The names of the authors may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ GtkTV.cabal view
@@ -0,0 +1,32 @@+Name: GtkTV+Version: 0.0.0+Cabal-Version: >= 1.2+Synopsis: +Category: Gtk-based GUIs for Tangible Values+Description:+ GtkTV is a very small library that extends the TV (tangible value)+ framework with graphical user interfaces, using gtk2hs.+ .+ © 2007 by Conal Elliott; BSD3 license.+Author: Conal Elliott+Maintainer: conal@conal.net+Homepage: http://haskell.org/haskellwiki/GtkTV+Package-Url: http://code.haskell.org/~conal/code/GtkTV+Copyright: (c) 2009 by Conal Elliott+License: BSD3+License-File: COPYING+Stability: experimental+build-type: Simple++extra-source-files:+ examples/test++Library+ hs-Source-Dirs: src+ Extensions:+ Build-Depends: base<5, time, gtk, TypeCompose>=0.6.5, TV+ Exposed-Modules:+ Interface.TV.Gtk+ ghc-options: -Wall++-- ghc-prof-options: -prof -auto-all
+ Makefile view
@@ -0,0 +1,1 @@+include ../cho-home-cabal-make.inc
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ examples/test.hs view
@@ -0,0 +1,78 @@+-- {-# LANGUAGE #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : test+-- Copyright : (c) Conal Elliott 2009+-- License : GPL-3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Test GtkTV+----------------------------------------------------------------------++import Data.Lambda (lambda) -- or use oLambda+import Data.Pair (pair) -- or use iPair, oPair++import Interface.TV+import Interface.TV.Gtk+++{--------------------------------------------------------------------+ Tests+--------------------------------------------------------------------}++i1 :: In R+i1 = iTitle "size" $ sliderRI (0,10) 3++i2 :: In Bool+i2 = iTitle "happy" $ toggleI False++i3 :: In (R, Bool)+i3 = iPair i1 i2++i4 :: In Int+i4 = iTitle "cookies" $ sliderII (0,10) 5++testI :: Show a => In a -> IO ()+testI i = runOut (oLambda i textO) "test" show++t1,t2,t3,t4,t5 :: IO ()+t1 = testI i1+t2 = testI i2+t3 = testI i3+t4 = testI i4+t5 = testI (pair i1 i4)++-- t5 = runUI TextureIn "Gtk.hs" print+-- t6 = runUI TextureIn "/home/conal/Pictures/phone pics/Image002.jpg" print++-- WORKING HERE: curried function.++o6 :: Out (R -> Bool -> String)+o6 = lambda i1 $ lambda i2 $ textO++t6 :: IO ()+t6 = runOut o6 "currying" (\ a b -> show (a,b))++{-++t7 = testI TextureIn 0++{-+tryTex str = do allInit + loadTexture' str >>= print+ IL.showErrors+ showGLErrors++t8 = tryTex "/home/conal/Haskell/gadget/src/marble-256.png"+t9 = tryTex "/home/conal/cabal/nehe-tuts-0.1.1/Data/NeHe.bmp"+-}++main = t6++-- With a bogus file, I get errors. With a legit file I get no errors and+-- texture 0. Hm! Could 0 be correct? Try applying the texture.++-}
+ src/Interface/TV/Gtk.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE RecursiveDo, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Interface.TV.Gtk+-- Copyright : (c) Conal Elliott 2009+-- License : BSD3+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- +-- Gtk-based GUIs in the TV (tangible value) framework+----------------------------------------------------------------------++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 -- as Gtk++type In = Input MkI+type Out = Output MkI MkO++ -- IPrim :: src a -> Input src a+ -- OPrim :: snk a -> Output src snk a+++-- Make a input UI.+newtype MkI a = MkI { unMkI :: MkI' a }++-- Representation type for 'MkI'. Takes a change call-back and produces a widget and a+-- polling operation and a clean-up action.+type MkI' a = IO () -> IO (Widget, IO a, IO ())++-- Make an output UI.+newtype MkO a = MkO { unMkO :: MkO' a }++-- Representation type for 'MkO'. Give a widget and a way to send it new+-- info to disply and a clean-up action.+type MkO' a = IO (Widget, OI a, IO ())++-- | Sink of information+type OI a = a -> IO ()++-- | Add post-processing+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 -- , windowDefaultHeight := 200+ -- , containerBorderWidth := 10+ , containerChild := wid+ , windowFocusOnMap := True -- helpful?+ , 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+ -- , frameShadowType := ShadowEtchedOut+ , 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+ -- , frameShadowType := ShadowEtchedOut+ , 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 -- note loop+ 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++-- TODO: Consider using R == Double (for constant folding), while really+-- being float on the GLSL side.++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++-- Generalized slider. Gtk's scaling widgets work with Double, so this+-- adapter takes some initial params for conversion. Only fires when a+-- value really changes.+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+ -- putStrLn $ "(old,new) ==" ++ show (old,new)+ when (old /= new) refresh+ in+ do w <- hScaleNewWithRange (toD lo) (toD hi) (toD step)+ set w [ rangeValue := toD a0, scaleDigits := digits ]+ -- Unlike wxHaskell, I guess call-backs aren't attributes in gtk2hs.+ let getter = fromD <$> get w rangeValue+ onRangeChangeValue w (\ _ x -> changeTo getter (fromD x) >> return False)+ -- TODO: experiment with return False vs True+ 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+ -- fileChooserGetFilename w >>= print -- testing+ return ( toWidget w+ , fromMaybe start <$> fileChooserGetFilename w+ , return () )++-- mkTextureI :: GlTexture -> In GlTexture+-- mkTextureI = error "mkTexture: not yet implemented"++-- mkTexture start refresh (BaseG oi) = do ...+-- mkTexture _ _ _ = error "mkTexture: not BaseG"++-- onEntryActivate :: EntryClass ec => ec -> IO () -> IO (ConnectId ec)++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 ())++-- textO = primMkO $+-- do lab <- labelNew Nothing+-- return (toWidget lab, labelSetText lab)++-- | A clock that reports time in seconds and updates at the given period+-- (in seconds).+clockDtI :: R -> In R+clockDtI period = primMkI $ \ refresh ->+ do start <- time+ timeout <- timeoutAddFull (refresh >> return True)+ priorityDefaultIdle (round (period * 1000))+ w <- vBoxNew True 0 -- size 0 box+ return (toWidget w, subtract start <$> time, timeoutRemove timeout)+++-- Deactivating the clock's timeout during clean-up prevents it from+-- running when gtk starts up again. Particularly useful in ghci, where+-- restarting gtk is commonplace.+++-- | A clock that updates every 1/60 second+clockI :: In R+clockI = clockDtI (1/60)++-- Get the time since midnight, in seconds+time :: IO R+time = (fromRational . toRational . utctDayTime) <$> getCurrentTime+