GuiTV 0.3 → 0.4
raw patch · 6 files changed
+219/−67 lines, 6 filesdep +TypeComposedep ~TVdep ~phooeysetup-changed
Dependencies added: TypeCompose
Dependency ranges changed: TV, phooey
Files
- CHANGES +8/−3
- GuiTV.cabal +5/−4
- Makefile +6/−6
- Setup.lhs +2/−2
- src/Examples.hs +69/−27
- src/Interface/TV/UI.hs +129/−25
CHANGES view
@@ -1,3 +1,8 @@-Version 0.3: - -* Small changes to sync with Phooey 1.0 +== Version 0.4 ==++* Update for [[TV]] 0.3 and [[Phooey]] 1.3++== Version 0.3 ==++* Small changes to sync with [[Phooey]] 1.0+
GuiTV.cabal view
@@ -1,5 +1,5 @@ Name: GuiTV-Version: 0.3+Version: 0.4 Synopsis: GUIs for Tangible Values Category: Interfaces, User Interfaces Description:@@ -28,12 +28,13 @@ Copyright: (c) 2007 by Conal Elliott License: BSD3 Stability: experimental+Build-type: Simple Hs-Source-Dirs: src-Build-Depends: base, DeepArrow, phooey>=1.0, TV+Build-Depends: base, DeepArrow, TypeCompose>=0.2, phooey>=2.0, TV>=0.4 tested-with: GHC==6.6-Extensions: CPP+Extensions: Exposed-Modules: Interface.TV.UI Extra-Source-Files: Examples-ghc-options: -O -W+ghc-options: -Wall
Makefile view
@@ -1,11 +1,11 @@ # For doc-building. Otherwise see README. -build-args=-v+# build-args=-v -haddock-interfaces=\- http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \- http://darcs.haskell.org/packages/DeepArrow/doc/html,c:/Haskell/packages/DeepArrow-0.0.1/doc/html/DeepArrow.haddock \- http://darcs.haskell.org/packages/phooey/doc/html,c:/Haskell/packages/phooey-1.0/doc/html/phooey.haddock \- http://darcs.haskell.org/packages/TV/doc/html,c:/Haskell/packages/TV-0.2/doc/html/TV.haddock+# haddock-interfaces=\+# http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \+# http://darcs.haskell.org/packages/DeepArrow/doc/html,c:/Haskell/packages/DeepArrow-0.0.1/doc/html/DeepArrow.haddock \+# http://darcs.haskell.org/packages/phooey/doc/html,c:/Haskell/packages/phooey-1.0/doc/html/phooey.haddock \+# http://darcs.haskell.org/packages/TV/doc/html,c:/Haskell/packages/TV-0.2/doc/html/TV.haddock include ../my-cabal-make.inc
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell -> import Distribution.Simple +#!/usr/bin/env runhaskell+> import Distribution.Simple > main = defaultMain
src/Examples.hs view
@@ -1,68 +1,98 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE OverlappingInstances, UndecidableInstances+ , IncoherentInstances, FlexibleContexts+ , TypeSynonymInstances, FlexibleInstances+ , MultiParamTypeClasses+ #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts -fallow-overlapping-instances -fallow-incoherent-instances #-} + ---- Some GuiTV examples. See also the examples in TV. import Data.List (sort) import Interface.TV.UI+import Control.Arrow.DeepArrow+import Data.FunArr --- To pick up the FunArr instance for OFun. GHC bug.+-- TypeCompose+import Data.Title++-- To pick up the FunArr instance for OFun. import Interface.TV.OFun() -main = runBoth shopping+-- main = runBoth shopping -- Run both UI and IO flavors runBoth :: CTV a -> IO () runBoth tv = runUI tv >> runIO tv +-- or runBoth = runUI `mappend` runIO+ tv0 :: CTV String-tv0 = tv (oTitle "message" stringOut) "Hello World!"+tv0 = tv (title "message" stringOut) "Hello World!" tv1 :: CTV Int-tv1 = tv (oTitle "answer" showOut) (42 :: Int)+tv1 = tv (title "answer" showOut) (42 :: Int) -reverseT :: DefaultOut ([a] -> [a]) => CTV ([a] -> [a])-reverseT = tv (oTitle "reverse" defaultOut) reverse+-- This one is too polymorphic for runTV or runUI+reverseT :: ( DefaultOut src snk [a], DefaultIn src [a]+ , CommonOuts snk, CommonIns src+ , Show a, Read a) =>+ TV src snk ([a] -> [a])+reverseT = tv (title "reverse" defaultOut) reverse +-- The following two type specializations are type-constrained enough for runUI++reverseString :: CTV (String -> String)+reverseString = reverseT++reverseInts :: CTV ([Int] -> [Int])+reverseInts = reverseT+ -- This one reverses twice revTwice :: CTV (String -> String) revTwice = reverseT ->| reverseT apples, bananas :: CInput Int-apples = iTitle "apples" defaultIn-bananas = iTitle "bananas" defaultIn+apples = title "apples" defaultIn+bananas = title "bananas" defaultIn total :: Show a => COutput a-total = oTitle "total" showOut+total = title "total" showOut shoppingO :: COutput (Int -> Int -> Int)-shoppingO = oTitle "shopping list" $+shoppingO = title "shopping list" $ oLambda apples (oLambda bananas total) + shopping :: CTV (Int -> Int -> Int) shopping = tv shoppingO (+) +-- Uncurried variant shoppingPr :: CTV ((Int,Int) -> Int)-shoppingPr = tv ( oTitle "shopping list -- curried" $ +shoppingPr = tv ( title "shopping list -- curried" $ oLambda (iPair apples bananas) total ) (uncurry (+)) +-- Or simply use uncurryA shoppingPr' :: CTV ((Int,Int) -> Int) shoppingPr' = uncurryA $$ shopping +-- Sliders instead of default inputs applesU, bananasU :: Input UI Int-applesU = iTitle "apples" (islider (0,10) 3)-bananasU = iTitle "bananas" (islider (0,10) 7)+applesU = title "apples" (islider (0,10) 3)+bananasU = title "bananas" (islider (0,10) 7) -shoppingUO :: Output UI (Int -> Int -> Int)-shoppingUO = oTitle "shopping list" $+shoppingUO :: Output UI IU (Int -> Int -> Int)+shoppingUO = title "shopping list" $ oLambda applesU (oLambda bananasU total) -shoppingU :: TV UI (Int -> Int -> Int)+shoppingU :: TV UI IU (Int -> Int -> Int) shoppingU = tv shoppingUO (+) -shoppingPrU :: TV UI ((Int,Int) -> Int)+shoppingPrU :: TV UI IU ((Int,Int) -> Int) shoppingPrU = uncurryA $$ shoppingU @@ -70,28 +100,40 @@ -- "runBoth (sortT :: CTV ([String] -> [String]))". If you leave out the type -- annotation, a will default to Int. sortT :: (Read a, Show a, Ord a) => CTV ([a] -> [a])-sortT = tv (oTitle "sort" $ interactLineRS []) sort+sortT = tv (title "sort" $ interactLineRS []) sort ---- Composition. -- Idea: unwords, sort, words -instance DefaultOut [String] where defaultOut = showOut-instance DefaultIn [String] where defaultIn = readIn []+instance DefaultOut UI IU [String] where defaultOut = showOut+instance DefaultIn UI [String] where defaultIn = readIn [] wordsT :: CTV (String -> [String]) -wordsT = tv ( oTitle "function: words" $- oLambda (iTitle "sentence in" defaultIn)- (oTitle "words out" defaultOut))+wordsT = tv ( title "function: words" $+ oLambda (title "sentence in" defaultIn)+ (title "words out" defaultOut)) words unwordsT :: CTV ([String] -> String) -unwordsT = tv ( oTitle "function: unwords" $- oLambda (iTitle "words in" defaultIn)- (oTitle "sentence out" defaultOut))+unwordsT = tv ( title "function: unwords" $+ oLambda (title "words in" defaultIn)+ (title "sentence out" defaultOut)) unwords sortWordsT :: CTV (String -> String) sortWordsT = wordsT ->| sortT ->| unwordsT+++-- choiceLen :: TV UI IU (String -> Int)+-- choiceLen = tv ( oLambda ( choices (words "a big black bug") "big" ) defaultOut )+-- length++choiceLen :: TV UI IU (String -> Int)+choiceLen = tv ( title "length of choice" $+ oLambda ( title "choose a word" $+ choices (words "a big black bug") "big" )+ (title "length" defaultOut) )+ length
src/Interface/TV/UI.hs view
@@ -1,57 +1,161 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeOperators, PatternSignatures, ScopedTypeVariables+ , TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- | -- Module : Interface.TV.UI -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : TypeOperators, PatternSigs -- -- Graphical 'UI' instances of TV classes, plus UI-specific tools ---------------------------------------------------------------------- module Interface.TV.UI (- islider , runUI- , UI, module Interface.TV -- re-exports+ -- * Types+ IU, InU, OutU, TVU, unIU+ , UI, module Interface.TV -- re-exports+ -- * Some high-level widgets+ , oPrim'+ , stringEntry, stringDisplay, showDisplay+ , islider, isliderDisplay, fslider, fsliderDisplay+ , checkBoxEntry, checkBoxDisplay, choices+ , timedPoll+ , runUI ) where -import Graphics.UI.Phooey.Arrow hiding (runUI,islider)-import qualified Graphics.UI.Phooey.Arrow as Ph (islider)+import Control.Applicative +import Control.Compose+import Data.Pair++-- import Data.Source (Sink)++import Graphics.UI.Phooey.Applicative (UI,fromLeft,Action,OWidget)+import qualified Graphics.UI.Phooey.Applicative as P+ import Interface.TV +instance Pair UI where+ a `pair` b = fromLeft (liftA2 (,) a b)++ {----------------------------------------------------------- Instances+ Types ----------------------------------------------------------} -instance Present UI where- presentPair = fromLeft- presentLambda = fromTop- presentTitle = title- -- presentCompose = id+-- | GUI Sink+type IU = UI :. OI --- For the Eros version, I'll want presentCompose to replace all inner--- handles with one outer handle. -instance ToIO UI where toIO = runNamedUI "TV + Phooey"+-- | GUI input+type InU = Input UI -instance CommonInsOuts UI where- putString = stringDisplay- getString = stringEntry ""+-- | GUI output+type OutU = Output UI IU +-- |GUI-based TV+type TVU = TV UI IU --- | Integer-valued slider, given initial value and bounds-islider :: (Int,Int)- -> Int- -> Input UI Int-islider bounds initial = iPrim (Ph.islider bounds initial) +-- Standard instance+instance Cofunctor IU where cofmap = cofmapFC +instance Pair IU where pair = copair++-- unIU :: IU a -> UI (a -> IO ())+unIU :: Functor f => (f :. Flip (->) o) a -> f (a -> o)+unIU (O h) = fmap unFlip h+++instance CommonIns UI where+ getString = P.stringEntry+ getRead = getReadF+ getBool = P.checkBoxEntry++instance CommonOuts IU where+ putString = mkO P.stringDisplay+ putShow = putShowC+ putBool = mkO P.checkBoxDisplay++mkO :: Functor f => f (a ~> b) -> (f :. Flip (~>) b) a+mkO = O . fmap Flip+++{----------------------------------------------------------+ Some high-level widgets+----------------------------------------------------------}++oPrim' :: OWidget a -> OutU a+oPrim' = oPrim . mkO++-- standard Monoid instance for Applicative applied to Monoid+instance Monoid_f IU where+ { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }++instance ToOI IU where+ toOI (iu :: IU a) = Flip $ \ a -> P.runUI (unIU iu <*> pure a :: UI Action)++-- | Int slider input+islider :: (Int,Int) -- ^ bounds+ -> Int -- ^ initial value+ -> InU Int+islider bounds = iPrim . P.islider bounds++-- | Fractional slider input+fslider :: RealFrac a =>+ (a,a) -- ^ bounds+ -> a -- ^ initial value+ -> InU a+fslider bounds = iPrim . P.fslider bounds++-- | Int slider output+isliderDisplay :: (Int,Int) -> OutU Int+isliderDisplay bounds = oPrim' (P.isliderDisplay bounds)++-- | Fractional slider output+fsliderDisplay :: RealFrac a => (a,a) -> OutU a+fsliderDisplay bounds = oPrim' (P.fsliderDisplay bounds)++-- | Showable output+showDisplay :: Show a => OutU a+showDisplay = oPrim' P.showDisplay++-- | Boolean input+checkBoxEntry :: Bool -> InU Bool+checkBoxEntry = iPrim . P.checkBoxEntry++-- | Boolean output+checkBoxDisplay :: OutU Bool+checkBoxDisplay = oPrim' P.checkBoxDisplay++-- | String input+stringEntry :: InU String+stringEntry = iPrim (P.stringEntry "")++-- | String output+stringDisplay :: OutU String+stringDisplay = oPrim' P.stringDisplay++-- | Input from a \"menu\" of choices.+choices :: [String] -> String -> InU String+choices strs = iPrim . P.choices strs++-- | Input from a timer and a means of polling. Interval is in seconds.+-- Caches in case 'poll' is expensive.+timedPoll :: Double -> IO a -> InU a+timedPoll secs poll = iPrim (P.timedPoll secs poll)++-- TODO: Is it possible to define a caching function for Input?+ -- | Type-disambiguating alias for 'runTV'-runUI :: RunTV UI+runUI :: RunTV UI IU runUI = runTV