diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 + diff --git a/GuiTV.cabal b/GuiTV.cabal --- a/GuiTV.cabal +++ b/GuiTV.cabal @@ -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 diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple +#!/usr/bin/env runhaskell +> import Distribution.Simple > main = defaultMain diff --git a/src/Examples.hs b/src/Examples.hs --- a/src/Examples.hs +++ b/src/Examples.hs @@ -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 diff --git a/src/Interface/TV/UI.hs b/src/Interface/TV/UI.hs --- a/src/Interface/TV/UI.hs +++ b/src/Interface/TV/UI.hs @@ -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