packages feed

TV (empty) → 0.0

raw patch · 22 files changed

+1530/−0 lines, 22 filesdep +DeepArrowdep +basedep +mtlbuild-type:Customsetup-changed

Dependencies added: DeepArrow, base, mtl, phooey

Files

+ CHANGES view
@@ -0,0 +1,19 @@+Version 0.0:
+
+* Support for Kleisli arrows and IO in particular.
+
+* Grading examples.  I'm very happy with them.
+
+* Added ICompose & OCompose, and used for Functor & Cofunctor instances.  Now
+  I have to figure out what the Eros composition operators do with these
+  constructors.
+
+* Used fmap/cofmap to define a Read&Show version of interact.
+
+* Made prompts/titles an orthogonal feature (as in Phooey).  Now one can
+  title an aggregate.  Required adding constructors to Input & Output.
+  Figure out Eros operators.
+
+---- darcs record
+
+* Created
+ Makefile view
@@ -0,0 +1,15 @@+# See README for Cabal-based building.  Other fancy stuff (like haddock) here.
+
+user = conal
+package = TV
+
+haddock_args=\
+  --no-use-packages \
+  --haddock-arg=--read-interface=http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \
+  --haddock-arg=--read-interface=http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \
+  --haddock-arg=--read-interface=http://wxhaskell.sourceforge.net/doc,c:/Haskell/wxhaskell/out/doc/wxhaskell.haddock \
+  --haddock-arg=--read-interface=http://darcs.haskell.org/packages/phooey/doc/html,c:/Haskell/packages/phooey-0.1/doc/html/phooey.haddock \
+  --haddock-arg=--read-interface=http://darcs.haskell.org/packages/DeepArrow/doc/html,c:/Haskell/packages/DeepArrow-0.0/doc/html/DeepArrow.haddock \
+  # enough, already!
+
+include ../my-cabal-make.inc
+ README view
@@ -0,0 +1,23 @@+TV is a library for visualizing functional values.  It can also be viewed
+as an approach to functional user interfaces.  It is implemented very
+simply on top of Phooey (http://conal.net/phooey).  The name "TV" comes
+"tangible values", which is the central idea of the library.
+
+TV is an intermediate stage between Phooey and Eros
+(http://conal.net/papers/Eros).
+
+See tv.cabal for more info, including home page and license.
+
+You can configure, build, generate haddock docs, and install all in the usual
+way with Cabal commands.
+
+  runhaskell Setup.lhs configure
+  runhaskell Setup.lhs build
+  runhaskell Setup.lhs install
+
+You can find the Haddock-generated documentation at 
+
+  http://darcs.haskell.org/packages/TV/doc/html
+
+Or you can generate them locally with "make colourPrep hscolour haddock".
+There are a few other tricky bits in the Makefile you probably won't need.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
+ TODO view
@@ -0,0 +1,6 @@+                            To-do items for TV
+
+* Track down the horizontal fill problem that shows up with example tv4.  This is really a problem with Phooey, that I hadn't previousy noticed.  See ui3 in phooey/src/Examples.hs. See if Eros handles it correctly.
+
+* Reconsider some of the differences between Phooey & TV:
+** islider has dynamic bounds in Phooey and static in TV.
+ TV.cabal view
@@ -0,0 +1,51 @@+Name:                TV
+Version:             0.0
+Synopsis:	     Tangible Values -- composable interfaces
+Category:            Interfaces
+Description:
+  TV is a library for composing /tangible values/ (\"TVs\"), i.e., values
+  that carry along external interfaces.  Values and interfaces are
+  /combined and separable/, which makes TVs ready to use and to reuse.
+  .
+  If you just want to /use/ TV, see the main module below
+  ("Interface.TV").  The other modules (@UI.Graphics.TV.*@) are useful
+  for understanding the implementation and adding new features.
+  .
+  Try out the examples in @src\/Examples.hs@.
+  .
+  For more information, including examples, please see the project wiki
+  page <http://haskell.org/haskellwiki/TV>
+  .
+  This page and the module documentation pages have links to colorized
+  source code and to wiki pages where you can read and contribute /user
+  comments/.  Enjoy!
+  .
+  &#169; 2007 by Conal Elliott; BSD3 license.
+Author:              Conal Elliott 
+Maintainer:          conal@conal.net
+Homepage:            http://haskell.org/haskellwiki/TV
+Package-Url:	     http://darcs.haskell.org/packages/TV
+Copyright:           (c) 2006 by Conal Elliott
+License:             BSD3
+Stability:	     experimental
+Hs-Source-Dirs:      src
+Build-Depends:       base, mtl, phooey>=0.1, DeepArrow
+tested-with:	     GHC==6.6
+Extensions:          CPP
+Exposed-Modules:     
+                     Interface.TV
+                     Interface.TV.Input
+                     Interface.TV.Output
+                     Interface.TV.Tangible
+                     Interface.TV.Present
+                     Interface.TV.OFun
+                     Interface.TV.Common
+                     Interface.TV.Defaults
+                     Interface.TV.UI
+                     Interface.TV.Kleisli
+                     Interface.TV.IO
+                     Interface.TV.Misc
+Extra-Source-Files:  
+                     Interface.TV.DefaultsList
+                     Examples
+ghc-options:         -O
+ src/Examples.hs view
@@ -0,0 +1,229 @@+{-# OPTIONS -fglasgow-exts #-}
+
+module Examples where
+
+import Data.Map (empty,keys,insertWith,findWithDefault)
+import Data.List (sort)
+import Text.Printf
+
+import Control.Arrow.DeepArrow
+import Data.FunArr
+
+import Interface.TV
+
+main = runBoth shopping
+
+
+-- Run both UI and IO flavors
+runBoth :: CTV a -> IO ()
+runBoth tv = runUI tv >> runIO tv
+
+tv0 :: CTV String
+tv0 = tv (oTitle "message" stringOut) "Hello World!"
+
+tv1 :: CTV Int
+tv1 = tv (oTitle "answer" showOut) (42 :: Int)
+
+reverseT :: DefaultOut ([a] -> [a]) => CTV ([a] -> [a])
+reverseT = tv (oTitle "reverse" defaultOut) reverse
+
+--  This one reverses twice
+revTwice :: CTV (String -> String)
+revTwice = reverseT ->| reverseT
+
+apples, bananas :: CInput Int
+apples  = iTitle "apples"  defaultIn
+bananas = iTitle "bananas" defaultIn
+
+total :: Show a => COutput a
+total = oTitle "total" showOut
+
+shoppingO :: COutput (Int -> Int -> Int)
+shoppingO = oTitle "shopping list" $
+            oLambda apples (oLambda bananas total)
+
+shopping :: CTV (Int -> Int -> Int)
+shopping = tv shoppingO (+)
+
+shoppingPr :: CTV ((Int,Int) -> Int)
+shoppingPr = tv ( oTitle "shopping list -- curried" $ 
+                  oLambda (iPair apples bananas) total )
+                (uncurry (+))
+
+shoppingPr' :: CTV ((Int,Int) -> Int)
+shoppingPr' = uncurryA $$ shopping
+
+
+applesU, bananasU :: Input UI Int
+applesU  = iTitle "apples"  (islider 3 (0,10))
+bananasU = iTitle "bananas" (islider 7 (0,10))
+
+-- shoppingUO :: Output UI (Int -> Int -> Int)
+-- shoppingUO = 
+--              oTitle "shopping list" $
+--              oLambda applesU (oLambda bananasU total)
+
+shoppingU :: TV UI (Int -> Int -> Int)
+shoppingU = tv ( oTitle "shopping list" $
+                 oLambda applesU (oLambda bananasU total) )
+               (+)
+
+shoppingPrU :: TV UI ((Int,Int) -> Int)
+shoppingPrU = uncurryA $$ shoppingU
+
+
+-- This one is polymorphic in value, so say something like
+-- "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" $ interactRSOut []) sort
+
+
+---- Composition.
+
+-- Idea: unwords, sort, words
+
+instance DefaultOut [String] where defaultOut = showOut
+instance DefaultIn  [String] where defaultIn  = readIn []
+
+
+wordsT :: CTV (String -> [String]) 
+wordsT = tv ( oTitle "function: words" $
+              oLambda (iTitle "sentence in" defaultIn)
+                      (oTitle "words out"   defaultOut))
+            words
+
+unwordsT :: CTV ([String] -> String) 
+unwordsT = tv ( oTitle "function: unwords" $
+                oLambda (iTitle "words in"     defaultIn)
+                        (oTitle "sentence out" defaultOut))
+              unwords
+
+sortWordsT :: CTV (String -> String)
+sortWordsT = wordsT ->| sortT ->| unwordsT
+
+
+---- IO examples
+
+testO :: Output KIO (String -> String)
+testO = oLambda (fileIn "test.txt") defaultOut
+
+-- Apply a function on the lines or on the words of a string.
+onLines, onWords :: ([String] -> [String]) -> (String -> String)
+onLines = wrapF unlines lines
+onWords = wrapF unwords words
+
+perLine,perWord :: (String -> String) -> (String -> String)
+perLine f = onLines (map f)
+perWord f = onWords (map f)
+
+--  :: TV KIO (String -> String)
+
+io3 = tv testO (onLines reverse)            -- reverse the lines
+io4 = tv testO (onWords reverse)            -- reverse words
+io5 = tv testO (perLine (onWords reverse))  -- reverse words on each line
+
+io3' = tv testO (perLine reverse)           -- reverse each line
+io4' = tv testO (perWord reverse)           -- reverse each word
+io5' = tv testO (perLine (perWord reverse)) -- reverse each word, leaving lines
+
+-- From http://cgi.cse.unsw.edu.au/~dons/blog/2006/12/16
+grades0 = do
+    src <- readFile "tasks"
+    let pairs  = map (split.words) (lines src)
+        grades = foldr insert empty pairs
+    mapM_ (draw grades) (sort (keys grades))
+  where
+    insert (s, g) = insertWith (++) s [g]
+    split [name,mark] = (name, read mark)
+    draw g s = printf "%s\t%s\tAverage: %f\n" s (show marks) avg
+      where
+        marks = findWithDefault (error "No such student") s g
+        avg   = sum marks / fromIntegral (length marks) :: Double
+
+-- To better separate IO from functional, have draw return a string to be
+-- concat'd.
+
+grades1 = readFile "tasks" >>= return . gradingStr >>= putStr
+
+type GradingStr = String -> String
+
+gradingStr :: GradingStr
+gradingStr src = concatMap (draw grades) (sort (keys grades))
+  where
+    pairs  = map (split.words) (lines src)
+    grades = foldr insert empty pairs
+    
+    insert (s, g) = insertWith (++) s [g]
+    split [name,mark] = (name, read mark)
+    draw g s = printf "%s\t%s\tAverage: %f\n" s (show marks) avg
+      where
+        marks = findWithDefault (error "No such student") s g
+        avg   = sum marks / fromIntegral (length marks) :: Double
+
+-- Or in TV style:
+
+tasksStrIn   = fileIn "tasks"
+gradesStrOut = oTitle "Grades" stringOut
+
+o6 = oLambda tasksStrIn gradesStrOut
+
+io6 = tv o6 gradingStr
+
+
+-- The string representations are also aspects of "I/O" (input from file
+-- storage and output to human reader).  To factor out these I/O aspects,
+-- we'll re-express gradingStr as a composition of parsing, grading, and
+-- unparsing: 
+-- 
+--   gradingStr = unparseSummaries . grading . parseTasks
+--
+-- Since this sort of wrapping (of grading) is common, we have a name for
+-- it (wrapF in Interface.TV.Misc).
+
+gradingStr' :: GradingStr
+gradingStr' = wrapG grading
+
+wrapG :: ([Task] -> [Grade]) -> String -> String
+wrapG = wrapF unparseGrades parseTasks
+
+
+-- Define the data types and conversion:
+
+type Task    = (String,Double)          -- ^ name and task score
+type Grade   = (String,[Double],Double) -- ^ name, scores, average
+type Grading = [Task] -> [Grade]
+
+parseTasks    :: String -> [Task]
+unparseGrades :: [Grade] -> String
+grading       :: Grading
+
+parseTasks src = map (split.words) (lines src)
+ where
+   split [name,mark] = (name, read mark)
+
+unparseGrades = concatMap draw
+ where
+   draw (s,marks,avg) = printf "%s\t%s\tAverage: %f\n" s (show marks) avg
+
+grading tasks = map (summary grades) (sort (keys grades))
+ where
+   grades = foldr insert empty tasks
+   insert (s, g) = insertWith (++) s [g]
+   summary g s = (s,marks,avg)
+     where
+       marks = findWithDefault (error "No such student") s g
+       avg   = sum marks / fromIntegral (length marks) :: Double
+
+
+-- Now we can make a Grading output that parses on the way in and
+-- unparses on the way out.
+o7 :: Output KIO Grading
+o7 = oLambda (fmap parseTasks tasksStrIn)
+             (cofmap unparseGrades gradesStrOut)
+
+-- Or define o7 via o6, dual to formulation of gradingStr via grading:
+o7' :: Output KIO Grading
+o7' = cofmap wrapG o6
+
+io7 = tv o7' grading
+ src/Interface/TV.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -fglasgow-exts #-}
+
+{- |
+   Module      :  Interface.TV
+   Copyright   :  (c) Conal Elliott 2006
+   License     :  LGPL
+
+   Maintainer  :  conal@conal.net
+   Stability   :  experimental
+   Portability :  portable
+
+-}
+
+module Interface.TV
+  (
+  -- * Tangible values
+   TV, CTV, tv, unTv, runTV
+  -- * 'Input'
+  , Input, iEmpty, iPrim, iPair, iTitle
+  -- * 'Output'
+  , Output, oEmpty, oPrim, oLambda, oPair, oCompose, oTitle
+  -- * Common ins & outs
+  , Common, CInput, COutput
+  , stringIn, readIn{-, intIn-}, stringOut, showOut, interactLine, interactRSOut
+  -- * Default ins & outs
+  , DefaultIn(..), DefaultOut(..)
+  -- * Kleisli arrows
+  , kIn, kOut
+  -- ** IO-based
+  , KIO, contentsIn, fileIn, interactOut, runIO
+  -- * UI
+  , UI, islider, runUI
+  -- * Misc
+  , wrapF, Cofunctor(..)
+  ) where
+
+import Graphics.UI.Phooey (UI)
+
+import Interface.TV.Input
+import Interface.TV.Output
+import Interface.TV.OFun ()
+import Interface.TV.Common
+import Interface.TV.Defaults
+import Interface.TV.UI
+import Interface.TV.Kleisli
+import Interface.TV.IO
+import Interface.TV.Misc
+import Interface.TV.Tangible
+ src/Interface/TV/Common.hs view
@@ -0,0 +1,109 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.Common
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Some common interaction vocabulary 
+----------------------------------------------------------------------
+
+module Interface.TV.Common
+  (
+  -- * Type class
+   CommonInsOuts(..), Common, CInput, COutput, CTV
+  -- * Inputs
+  , stringIn, boolIn, readIn  -- , intIn
+  -- * Outputs
+  , stringOut, boolOut, showOut, interactLine, interactRSOut
+  ) where
+
+import Control.Arrow
+
+import Interface.TV.Input
+import Interface.TV.Output
+import Interface.TV.Tangible (TV)
+
+import Interface.TV.Misc (readD)
+
+-- | This class captures some useful operations available in some arrows
+-- and allows definition of some \"'Common'\" 'Input's, 'Output's, and
+-- TVs.
+class Arrow (~>) => CommonInsOuts (~>) where
+  -- | Output a string
+  putString :: String ~> ()
+  -- | Input a string
+  getString :: () ~> String
+  -- | Output a bool
+  putBool :: Bool ~> ()
+  putBool = pure show >>> putString
+  -- | Input a bool
+  getBool :: Bool               -- ^ default
+          -> () ~> Bool
+  getBool dflt = getString >>> pure (readD dflt)
+{-
+  -- | Input an int with default & bounds
+  -- TODO: add getDouble or generalize
+  getInt :: Int                 -- ^ default
+         -> (Int,Int)           -- ^ bounds
+         -> () ~> Int
+-}
+
+-- | For operations over all 'CommonInsOuts' arrows.
+type Common f a = forall (~>). CommonInsOuts (~>) => f (~>) a
+
+-- | Inputs that work over all 'CommonInsOuts' arrows.
+type CInput a = Common Input a
+
+-- | Outputs that work over all 'CommonInsOuts' arrows.
+type COutput a = Common Output a
+
+-- | Convenient type synonym for TVs that work over all 'CommonInsOuts' arrows.
+type CTV a = Common TV a
+
+-- | String input
+stringIn :: CInput String
+stringIn = iPrim getString
+
+-- | Bool input
+boolIn :: Bool -> CInput Bool
+boolIn dflt = iPrim (getBool dflt)
+
+-- -- | Int input, with default and bounds
+-- intIn :: Int -> (Int,Int) -> CInput Int
+-- intIn dflt bounds = iPrim (getInt dflt bounds)
+
+-- | Input a readable value.  Use default when read fails.
+readIn :: Read a => a -> CInput a
+readIn dflt = stringIn `iCompose` pure (readD dflt)
+
+
+-- | Output a string
+stringOut :: COutput String
+stringOut = oPrim putString
+
+-- | Output a bool
+boolOut :: COutput Bool
+boolOut = oPrim putBool
+
+-- | Output a showable value
+showOut :: Show a => COutput a
+showOut = pure show `oCompose` stringOut
+
+-- | 'Output' version of 'interact'.  Well, not quite, since the IO
+-- version uses 'getLine' instead of 'getContents'.  See also
+-- 'Interface.TV.interactOut'
+interactLine :: COutput (String -> String)
+interactLine = oLambda stringIn stringOut
+
+-- | Read+Show of 'interact'
+interactRSOut :: (Read a, Show b) => a -> COutput (a -> b)
+interactRSOut dflt = oLambda (readIn dflt) showOut
+
+-- The following definition is more elegant but loses the oLambda structure.
+-- cofmap (wrapF show (readD dflt)) interactLine
+ src/Interface/TV/Defaults.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.Defaults
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Default inputs and outputs
+-- 
+-- TODO: Provide @[a]@ instances for DefaultIn and DefaultOut using the
+-- trick for Show @[a]@.  See "Interface.TV.DefaultsList" for a first
+-- attempt.
+----------------------------------------------------------------------
+
+module Interface.TV.Defaults
+  (
+  -- * Inputs
+   DefaultIn(..)
+  -- * Outputs
+  , DefaultOut(..)
+  ) where
+
+import Interface.TV.Input
+import Interface.TV.Output
+import Interface.TV.Common
+
+{----------------------------------------------------------
+    Inputs
+----------------------------------------------------------}
+
+-- | Class of types that provide a default input
+class DefaultIn a where
+  -- | The default input for a type
+  defaultIn :: CInput a
+
+instance DefaultIn Bool   where defaultIn = boolIn False
+instance DefaultIn Int    where defaultIn = readIn 0
+instance DefaultIn Double where defaultIn = readIn 0
+instance DefaultIn Float  where defaultIn = readIn 0
+instance DefaultIn String where defaultIn = stringIn
+
+instance (DefaultIn a, DefaultIn b) => DefaultIn (a,b) where
+  defaultIn = IPair defaultIn defaultIn
+
+
+{----------------------------------------------------------
+    Outputs
+----------------------------------------------------------}
+
+-- | Class of types that provide a default output
+class DefaultOut a where
+  -- | The default output for a type
+  defaultOut :: COutput a
+
+instance DefaultOut Bool   where defaultOut = boolOut
+instance DefaultOut Int    where defaultOut = showOut
+instance DefaultOut Double where defaultOut = showOut
+instance DefaultOut Float  where defaultOut = showOut
+instance DefaultOut String where defaultOut = stringOut
+
+instance (DefaultOut a, DefaultOut b) => DefaultOut (a,b) where
+  defaultOut = OPair defaultOut defaultOut
+
+instance (DefaultIn a, DefaultOut b) => DefaultOut (a->b) where
+  defaultOut = OLambda defaultIn defaultOut
+ src/Interface/TV/DefaultsList.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.DefaultsList
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Default inputs and outputs.  Experimental variant of
+-- "Interface.TV.DefaultsList".
+-- 
+-- This version extend the 'DefaultIn' and 'DefaultOut' type classes to
+-- handle lists in a general way, but still handle 'String' (@['Char']@)
+-- in the most familiar way.  The 'Read' and 'Show' classes have a special
+-- trick.  Can I adapt it?  This module is an incomplete first attempt.
+-- See @error@ calls in the code for the gaps.
+
+----------------------------------------------------------------------
+
+module Interface.TV.DefaultsList
+  (
+  -- * Inputs
+   DefaultIn(..)
+  -- * Outputs
+  , DefaultOut(..)
+  ) where
+
+import Interface.TV.Input
+import Interface.TV.Output
+import Interface.TV.Common
+
+{----------------------------------------------------------
+    Inputs
+----------------------------------------------------------}
+
+-- | Class of types that provide a default input
+class DefaultIn a where
+  -- | The default input for a type
+  defaultIn :: CInput a
+  -- | The default input for lists
+  defaultInList :: CInput [a]
+
+readInL :: Read a => CInput [a]
+readInL = readIn []
+
+instance DefaultIn Bool where
+  defaultIn     = boolIn False
+  defaultInList = readInL
+
+instance DefaultIn Char where
+  defaultIn     = readIn 'Q'
+  defaultInList = stringIn
+
+instance DefaultIn Int where
+  defaultIn     = readIn 0
+  defaultInList = readInL
+
+instance DefaultIn Double where
+  defaultIn     = readIn 0
+  defaultInList = readInL
+
+instance DefaultIn Float where
+  defaultIn     = readIn 0
+  defaultInList = readInL
+
+-- instance DefaultIn String where
+--   defaultIn     = stringIn
+--   defaultInList = readInL
+
+instance DefaultIn a => DefaultIn [a] where
+  defaultIn     = defaultInList
+  defaultInList = error "defaultInList: not yet defined for [a]"
+
+instance (DefaultIn a, DefaultIn b) => DefaultIn (a,b) where
+  defaultIn     = IPair defaultIn defaultIn
+  defaultInList = error "defaultInList: not yet defined for (a,b)"
+
+{----------------------------------------------------------
+    Outputs
+----------------------------------------------------------}
+
+-- | Class of types that provide a default output
+class DefaultOut a where
+  -- | The default output for a type
+  defaultOut :: COutput a
+  -- | The default output for lists
+  defaultOutList :: COutput [a]
+
+instance DefaultOut Bool where
+  defaultOut     = boolOut
+  defaultOutList = showOut
+
+instance DefaultOut Char where
+  defaultOut     = showOut
+  defaultOutList = stringOut
+
+instance DefaultOut Int where
+  defaultOut     = showOut
+  defaultOutList = showOut
+
+instance DefaultOut Double where
+  defaultOut     = showOut
+  defaultOutList = showOut
+
+instance DefaultOut Float where
+  defaultOut     = showOut
+  defaultOutList = showOut
+
+-- instance DefaultOut String where
+--   defaultOut     = stringOut
+--   defaultOutList = showOut
+
+instance DefaultOut a => DefaultOut [a] where
+  defaultOut     = defaultOutList
+  defaultOutList = error "defaultOutList: not yet defined for [a]"
+
+instance (DefaultOut a, DefaultOut b) => DefaultOut (a,b) where
+  defaultOut     = OPair defaultOut defaultOut
+  defaultOutList = error "defaultOutList: not yet defined for (a,b)"
+
+instance (DefaultIn a, DefaultOut b) => DefaultOut (a->b) where
+  defaultOut     = OLambda defaultIn defaultOut
+  defaultOutList = error "defaultOutList: not yet defined for (a,b)"
+
+ src/Interface/TV/IO.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.IO
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- IO-based instances of TV classes 'PresentM', 'ToIOM', and
+-- 'CommonInsOuts'
+----------------------------------------------------------------------
+
+module Interface.TV.IO
+  (
+  -- * Types
+   KIO
+  -- * Inputs
+  , contentsIn, fileIn
+  -- * Outputs
+  , interactOut
+  -- * Disambiguator
+  , runIO
+  ) where
+
+import Control.Arrow
+
+import Interface.TV.Input
+import Interface.TV.Output
+import Interface.TV.Tangible (TV,runTV)
+import Interface.TV.Kleisli
+import Interface.TV.Common
+
+
+-- | Convenient shorthand for 'Kleisli IO'
+type KIO = Kleisli IO
+
+-- There's not much to do here, given Kleisli
+
+instance PresentM IO where
+  presentTitleM str io = putStr (str ++ suffix) >> io
+   where
+     suffix | null str              = ""
+            | last str `elem` ".?:" = " "
+            | otherwise             = ": "
+
+instance ToIOM IO where toIOM = id
+
+instance CommonInsOuts KIO where
+  putString = Kleisli putStrLn          -- or putStr?
+  getString = Kleisli (const getLine)
+
+--  getInt    = getIntKIO
+
+{-
+
+getIntKIO :: Int -> (Int,Int) -> KIO () Int
+-- Get a string, read, and check bounds.
+-- TODO: If the read or bounds check fails, output an error message and
+-- keep asking.
+getIntKIO dflt (lo,hi) = getString >>> pure (check . readD dflt)
+ where
+   check val | lo <= val && val <= hi = val
+             | otherwise = dflt
+
+-}
+
+{----------------------------------------------------------
+    Inputs
+----------------------------------------------------------}
+
+-- | 'Input' version of 'getContents'
+contentsIn :: Input KIO String
+contentsIn = kIn getContents
+
+-- | 'Input' version of 'readFile'
+fileIn :: String -> Input KIO String
+fileIn name = kIn (readFile name)
+
+{----------------------------------------------------------
+    Outputs
+----------------------------------------------------------}
+
+-- | Equivalent of 'interact'.  See also 'Interface.TV.interactLine'
+interactOut :: Output KIO (String -> String)
+interactOut = oLambda contentsIn stringOut
+
+
+{----------------------------------------------------------
+    Disambiguator
+----------------------------------------------------------}
+
+-- | Many TVs work for all 'CommonInsOuts' arrows.  Applying 'runTV' is
+-- then ambiguous.  This type specialization disambiguates.
+runIO :: TV KIO a -> IO ()
+runIO = runTV
+ src/Interface/TV/Input.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS -fglasgow-exts -cpp #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.Input
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- This module defines an 'Input' type constructor, for obtaining typed
+-- values from a user.
+----------------------------------------------------------------------
+
+module Interface.TV.Input
+  (
+  -- * Input data type
+    Input(..)
+  -- * Canonicalizers
+  , asIPair
+  , iEmpty, iPrim, iPair, iCompose, iTitle
+  ) where
+
+import Control.Arrow
+
+{----------------------------------------------------------
+    Input data type
+----------------------------------------------------------}
+
+-- | An /Input/ describes a way to obtain a functional value from a user.
+-- Used in Output for making function visualizations.
+#ifdef __HADDOCK__
+data Input (~>) a
+#else
+data Input (~>) :: * -> * where
+  -- | When we don't know what input to use.   I might remove this constructor.
+  IEmpty   :: Input (~>) a
+  -- | Input primitive
+  IPrim  :: (~>) () a -> Input (~>) a
+  -- | Input a pair
+  IPair  :: Input (~>) a -> Input (~>) b -> Input (~>) (a,b)
+  -- | Massage via an arrow value (like fmap)
+  ICompose :: Input (~>) a -> a ~> b -> Input (~>) b
+  -- | Title/label an input
+  ITitle :: String -> Input (~>) a -> Input (~>) a
+#endif
+
+-- See 'OEmpty' for note about eliminating OEmpty.
+
+instance Show (Input (~>) a) where
+  show IEmpty          = "IEmpty"
+  show (IPrim _)       = "(IPrim _)"
+  show (IPair a b)     = "(IPair "++show a++" "++show b++")"
+  show (ICompose a _)  = "(ICompose "++show a++" _)"
+  show (ITitle str i)  = "(ITitle "++show str++" "++show i++")"
+
+-- | Handy specialization of 'ICompose'
+instance Arrow (~>) => Functor (Input (~>)) where
+  fmap f input = input `ICompose` pure f
+
+{----------------------------------------------------------
+    Canonicalizers
+----------------------------------------------------------}
+
+-- | Dissect a pair-valued input into two inputs.  Loses outer 'iTitle's.
+-- Yields empty inputs when not a (possibly titled) pair-style input.
+asIPair :: Input (~>) (a,b) -> (Input (~>) a, Input (~>) b)
+asIPair (IPair  a b ) = (a,b)
+asIPair (ITitle _ ab) = asIPair ab
+asIPair _             = (iEmpty, iEmpty)
+
+-- Alternatively, transform titles
+-- asIPair (ITitle s ab) = ( ITitle ("first of " ++s) a
+--                         , ITitle ("second of "++s) b )
+--  where
+--    (a,b) = asIPair ab
+
+
+{----------------------------------------------------------
+    Input functions
+----------------------------------------------------------}
+
+-- The rest just rename the constructors.  Maybe eliminate.
+-- Keep for now, since Haddock can't digest the constructor declarations.
+
+-- | An empty (invisible) input for when we don't know what else to do.
+-- Careful: this one probably yields bottom when used.
+iEmpty :: Input (~>) a
+iEmpty = IEmpty
+
+-- Alternatively, eliminate IEmpty and define
+
+-- iEmpty = iPrim $ (~>) $ const $ error "cannot get value from empty input"
+
+-- | Input primitive
+iPrim :: () ~> a -> Input (~>) a
+
+-- | Input a pair
+iPair :: Input (~>) a -> Input (~>) b -> Input (~>) (a,b)
+
+-- | Massage via an arrow value (like fmap)
+iCompose :: Input (~>) a -> a ~> b -> Input (~>) b
+
+-- | Title (label) an input
+iTitle :: String -> Input (~>) a -> Input (~>) a
+
+iPrim    = IPrim
+iPair    = IPair
+iCompose = ICompose
+iTitle   = ITitle
+
+ src/Interface/TV/Kleisli.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.Kleisli
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Support for monadic TVs, via Kleisli arrows
+----------------------------------------------------------------------
+
+module Interface.TV.Kleisli
+  (
+  -- * Monadic variants
+    PresentM(..), ToIOM(..)
+  -- * 'Input' and 'Output' makers
+  , kIn, kOut
+  ) where
+
+import Control.Arrow
+
+import Interface.TV.Input (Input,iPrim)
+import Interface.TV.Output (Output,oPrim)
+import Interface.TV.Present (Present(..))
+import Interface.TV.Misc (ToIO(..))
+
+
+-- | Monadic variant of 'Present'
+class Monad m => PresentM m where
+  presentPairM, presentLambdaM :: m a -> m a
+  presentTitleM :: String -> m a -> m a
+  presentPairM   = id
+  presentLambdaM = id
+
+-- | Monadic variant of 'ToIOM'
+class Monad m => ToIOM m where
+  toIOM :: m a -> IO a
+
+instance PresentM m => Present (Kleisli m) where
+  presentPair      = liftK presentPairM
+  presentLambda    = liftK presentLambdaM
+  presentTitle str = liftK (presentTitleM str)
+
+liftK :: (m b -> m b) -> (Kleisli m a b -> Kleisli m a b)
+liftK mf (Kleisli f) = Kleisli (mf . f)
+
+instance ToIOM m => ToIO (Kleisli m) where
+  toIO (Kleisli f) = toIOM (f ())
+
+
+-- | Make an 'Input' from a monadic value
+kIn :: m a -> Input (Kleisli m) a
+kIn m = iPrim (Kleisli (const m))
+
+-- | Make an 'Output' from a monadic function
+kOut :: (b -> m ()) -> Output (Kleisli m) b
+kOut f = oPrim (Kleisli f)
+ src/Interface/TV/Misc.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.Misc
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Misc helpers
+----------------------------------------------------------------------
+
+module Interface.TV.Misc where
+
+import Control.Arrow (Arrow)
+
+-- | Read with default value.  If the input doesn't parse as a value of
+-- the expected type, or it's ambiguous, yield the default value.
+readD :: Read a => a -> String -> a
+readD dflt str | [(a,"")] <- reads str = a
+               | otherwise             = dflt
+
+-- | Often useful for \"acceptors\" of values.
+class Cofunctor acceptor where
+  cofmap :: (a -> b) -> (acceptor b -> acceptor a)
+
+-- | Arrows that convert to IO actions.
+class Arrow (~>) => ToIO (~>) where
+  -- Result type is restricted to () to allow arr types that yield more
+  -- (or fewer) than one value.
+  toIO :: () ~> () -> IO ()
+
+-- | Handy wrapping pattern.  For instance, @wrapF show read@ turns a
+-- string function into value function.
+wrapF :: (c->d) -> (a->b) -> ((b->c) -> (a->d))
+wrapF after before f = after . f . before
+
+
+-- Just a haddock test.  I added this infix support.
+
+-- foodle :: Arrow (~>) => a~>b -> b~>c -> a~>c
+-- foodle = undefined
+
+-- doodle :: Arrow arr => a `arr` b
+-- doodle = undefined
+ src/Interface/TV/OFun.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.OFun
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- 'Output' transformations, as a "deep arrow".
+----------------------------------------------------------------------
+
+module Interface.TV.OFun (OFun) where
+
+import Control.Arrow
+
+import Data.FunArr
+import Control.Arrow.DeepArrow
+
+import Interface.TV.Output
+import Interface.TV.Input
+
+type OX (~>) a b = Output (~>) a -> Output (~>) b
+
+newtype OFun (~>) a b = OFun (OX (~>) a b)
+
+-- TODO: consider generalizing from "->" in OFun?
+
+instance Arrow (OFun (~>)) where
+  -- (a->b) -> OFun (~>) a b
+  arr = -- error "Interface.TV.OFun: no 'arr' method"
+        -- We could use the following definition instead.
+        const $ OFun (const OEmpty)
+
+  -- OFun (~>) a b -> OFun (~>) b c -> OFun (~>) a c
+  OFun f >>> OFun g = OFun (f >>> g)
+
+  -- OFun (~>) a a' -> OFun (~>) (a,b) (a',b)
+  first (OFun f) = OFun (firstO f)
+
+  -- OFun (~>) b b' -> OFun (~>) (a,b) (a,b')
+  second (OFun f) = OFun (secondO f)
+  -- Or, as recommended in DeepArrow.
+  -- second f = swapA >>> first f >>> swapA
+  -- As recommended
+  f &&& g = dupA >>> f *** g
+
+instance DeepArrow (OFun (~>)) where
+  idA      = OFun id
+  dupA     = postFun "dup" dupO
+  fstA     = postFun "first half" fstO
+  sndA     = postFun "second half" sndO
+  funF     = postFun "funF" funFO
+  funS     = postFun "funS" funSO
+  funR     = postFun "funR" funRO
+  swapA    = postFun "swapped" swapO
+  curryA   = postFun "curried" curryO
+  uncurryA = postFun "uncurried" uncurryO
+
+  result (OFun ox) = OFun (resultO ox)
+
+instance FunArr (OFun (~>)) (Output (~>)) where
+  toArr ofun = OFun (applyO ofun)
+  OFun ox $$ o = ox o
+
+-- Alter any outer titles before transforming
+retitle :: (String -> String) -> OX (~>) a b -> OX (~>) a b
+retitle re ofun (OTitle str o) = OTitle (re str) (retitle re ofun o)
+retitle _  ofun o = ofun o
+
+-- Alter by appending a comment
+posttitle :: String -> OX (~>) a b -> OX (~>) a b
+posttitle post = retitle (++ (" -- " ++ post))
+
+-- Convenient wrappers
+-- reFun :: (String->String) -> OX (~>) a b -> OFun (~>) a b
+-- reFun re = OFun . retitle re
+
+postFun :: String -> OX (~>) a b -> OFun (~>) a b
+postFun post = OFun . posttitle post
+
+-- Why don't we do postFun for 'result'?  Because we get funny titles when
+-- composing (like "reverse -- result" for reverse composed with itself).
+-- Maybe more experience will tell that automatic retitling is a bad idea
+-- in general.  Wait & see.
+
+---- Output transformers
+
+resultO :: OX (~>) b b' -> OX (~>) (a->b) (a->b')
+resultO ox ab = OLambda a (ox b)
+  where (a,b) = asOLambda ab
+
+applyO :: Output (~>) (a->b) -> OX (~>) a b
+applyO o = const b where (_,b) = asOLambda o
+
+firstO :: OX (~>) a c -> OX (~>) (a,b) (c,b)
+firstO f ab = OPair (f a) b where (a,b) = asOPair ab
+
+secondO :: OX (~>) b c -> OX (~>) (a,b) (a,c)
+secondO f ab = OPair a (f b) where (a,b) = asOPair ab
+
+dupO :: OX (~>) a (a,a)
+dupO a = OPair a a
+
+fstO :: OX (~>) (a,b) a
+fstO ab = a where (a,_) = asOPair ab
+
+sndO :: OX (~>) (a,b) b
+sndO ab = b where (_,b) = asOPair ab
+
+funFO :: OX (~>) (c->a,b) (c->(a,b))
+funFO gb = OLambda c (OPair a b)
+  where
+    (g,b) = asOPair gb
+    (c,a) = asOLambda g
+
+-- Try this style
+-- funFO' :: OX (~>) (c->a,b) (c->(a,b))
+-- funFO' gb = OLambda c (OPair a b)
+--   where
+--     ((c,a),b) = first asOLambda (asOPair gb)
+
+funSO :: OX (~>) (a,c->b) (c->(a,b))
+funSO ag = OLambda c (OPair a b)
+  where
+    (a,g) = asOPair ag
+    (c,b) = asOLambda g
+
+funRO :: OX (~>) (a->b->c) (b->a->c)
+funRO abc = OLambda b (OLambda a c) 
+ where
+   (a,bc) = asOLambda abc
+   (b,c)  = asOLambda bc
+
+swapO :: OX (~>) (a,b) (b,a)
+swapO ab = OPair b a where (a,b) = asOPair ab
+
+curryO :: OX (~>) ((a,b)->c) (a->b->c)
+curryO o = OLambda a (OLambda b c)
+  where (ab,c) = asOLambda o
+        (a ,b) = asIPair ab
+
+uncurryO :: OX (~>) (a->b->c) ((a,b)->c)
+uncurryO o = OLambda (IPair a b) c
+  where (a,bc) = asOLambda o
+        (b, c) = asOLambda bc
+
+-- For now leave lAssocA and rAssocA as default.
+
+ src/Interface/TV/Output.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS -fglasgow-exts -cpp #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.Output
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- This module defines an 'Output' type constructor, for presenting
+-- typed values to a user.
+----------------------------------------------------------------------
+
+module Interface.TV.Output
+  (
+  -- * Output data type
+    Output(..)
+  -- * Output functions
+  -- ** General
+  , oEmpty, oPrim, oLambda, oPair, oCompose, oTitle
+  -- ** Canonicalizers
+  , asOLambda, asOPair
+  ) where
+
+import Control.Arrow
+
+import Interface.TV.Input
+import Interface.TV.Misc (Cofunctor(..))
+
+
+{----------------------------------------------------------
+    Output data type
+----------------------------------------------------------}
+
+-- | An /Output/ describes a way to present a functional value, perhaps
+-- interactively.  It is the user-interface half of a tangible value.
+#ifdef __HADDOCK__
+data Output (~>) a
+#else
+data Output (~>) :: * -> * where
+  -- | When we don't know what output to use.  I might remove this constructor.
+  OEmpty   :: Output (~>) a
+  -- | Output primitive
+  OPrim    :: a ~> () -> Output (~>) a
+  -- | Visualize a function.  Akin to /lambda/
+  OLambda  :: Input (~>)  a -> Output (~>) b -> Output (~>) (a->b)
+  -- | Visualize a pair
+  OPair    :: Output (~>) a -> Output (~>) b -> Output (~>) (a,b)
+  -- | Massage via an arrow value (like cofmap)
+  OCompose :: a ~> b -> Output (~>) b -> Output (~>) a
+  -- | Title/label an output
+  OTitle :: String -> Output (~>) a -> Output (~>) a
+#endif
+
+-- See 'OEmpty' for note about eliminating OEmpty.
+
+instance Show (Output (~>) a) where
+  show OEmpty          = "OEmpty"
+  show (OPrim _)       = "(OPrim _)"
+  show (OLambda i o)   = "(Lambda "++show i++" "++show o++")"
+  show (OPair oa ob)   = "(OPair "++show oa++" "++show ob++")"
+  show (OCompose _ b)  = "(ICompose _ "++show b++")"
+  show (OTitle str o)  = "(OTitle "++show str++" "++show o++")"
+
+
+{----------------------------------------------------------
+    Canonicalizers
+----------------------------------------------------------}
+
+-- | Dissect a pair-valued input into two inputs.  Loses outer 'oTitle's.
+-- Yields empty inputs when not a (possibly titled) pair-style input.
+asOLambda :: Output (~>) (a->b) -> (Input (~>) a, Output (~>) b)
+asOLambda (OLambda a b) = (a,b)
+asOLambda (OTitle _ ab) = asOLambda ab
+asOLambda _             = (iEmpty, oEmpty)
+
+-- Alternatively, transform titles
+-- asOLambda (OTitle  s ab) = ( ITitle ("input of " ++s) a
+--                            , OTitle ("output of "++s) b )
+--  where
+--    (a,b) = asOLambda ab
+
+asOPair :: Output (~>) (a,b) -> (Output (~>) a, Output (~>) b)
+asOPair (OPair  a b ) = (a,b)
+asOPair (OTitle _ ab) = asOPair ab
+asOPair _             = (oEmpty, oEmpty)
+
+-- Alternatively:
+-- asOPair (OTitle s ab) = ( OTitle ("first of " ++s) a
+--                         , OTitle ("second of "++s) b )
+--  where
+--    (a,b) = asOPair ab
+
+
+
+{----------------------------------------------------------
+    Output functions
+----------------------------------------------------------}
+
+-- These functions just rename the constructors.  Maybe eliminate.
+-- Keep for now, since Haddock can't digest the constructor declarations.
+
+-- | An empty (invisible) output for when we don't know what else to do.
+oEmpty :: Output (~>) a
+oEmpty = OEmpty
+
+-- Alternatively, eliminate OEmpty and define
+
+-- oEmpty = oPrim (arr $ const ())
+
+
+-- | Output primitive
+oPrim :: a ~> () -> Output (~>) a
+oPrim = OPrim
+
+-- | Visualize a function.  Akin to /lambda/
+oLambda :: Input (~>)  a -> Output (~>) b -> Output (~>) (a->b)
+oLambda = OLambda
+
+-- | Visualize a pair
+oPair :: Output (~>) a -> Output (~>) b -> Output (~>) (a,b)
+oPair = OPair
+
+-- | Massage via an arrow value (like cofmap)
+oCompose :: a ~> b -> Output (~>) b -> Output (~>) a
+oCompose = OCompose
+
+-- | Title (label) an output
+oTitle :: String -> Output (~>) a -> Output (~>) a
+oTitle = OTitle
+
+-- | Handy specialization of 'iCompose'
+instance Arrow (~>) => Cofunctor (Output (~>)) where
+  cofmap f input = pure f `oCompose` input
+ src/Interface/TV/Present.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.Present
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Convert inputs and outputs to arrow values
+----------------------------------------------------------------------
+
+module Interface.TV.Present
+  (
+   present, Present(..)
+  ) where
+
+import Control.Arrow
+
+import Interface.TV.Input
+import Interface.TV.Output
+-- import Interface.TV.Misc (ToIO(..))
+
+
+-- | 'present' requires a bit of arrow-specific help.  For instance, in
+-- UIs, pairs are presented horizontally, lambdas vertically, and titles
+-- with a labeled box.  I'm not really comfortable with this part of the
+-- design, especially the specificity of addressing titles here.  All of
+-- the methods here have do-nothing defaults, so you can simply say
+-- @instance Present arr@ for your arrow @arr@.
+class Arrow (~>) => Present (~>) where
+  presentPair     :: a ~> b -> a ~> b
+  presentLambda   :: a ~> b -> a ~> b
+  presentCompose  :: a ~> b -> a ~> b
+  presentTitle    :: String -> a ~> b -> a ~> b
+  presentPair     =  id
+  presentLambda   =  id
+  presentCompose  =  id
+  presentTitle _  =  id
+
+-- | Convert an 'Input' into an arrow value.
+accept :: Present (~>) => Input (~>) b -> () ~> b
+
+accept IEmpty          = arr $ const $ error "cannot get value from empty input"
+accept (IPrim p)       = p
+accept (IPair ia ib)   = presentPair (accept ia &&& accept ib)
+accept (ICompose a ab) = presentCompose (accept a >>> ab)
+accept (ITitle str i)  = presentTitle str (accept i)
+
+-- | Convert an 'Output' into an arrow value
+present :: Present (~>) => Output (~>) a -> a ~> ()
+
+present OEmpty = arr $ const ()
+                 -- presentEmpty
+
+present (OPrim p) = p
+
+present (OPair oa ob) =  presentPair $
+                              (present oa *** present ob)  >>>
+                              pure (const ())
+
+present (OLambda i o) =  presentLambda $
+                              pure (\ f -> (f, ()))  >>>
+                              second (accept i)      >>>
+                              pure (uncurry ($))     >>>
+                              present o
+
+present (OCompose ab b) = presentCompose $
+                               ab >>> present b
+
+present (OTitle str o)  = presentTitle str (present o)
+ src/Interface/TV/Tangible.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS -fglasgow-exts #-}
+
+{- |
+   Module      :  Interface.TV.Tangible
+   Copyright   :  (c) Conal Elliott 2006
+   License     :  LGPL
+
+   Maintainer  :  conal@conal.net
+   Stability   :  experimental
+   Portability :  portable
+
+-}
+
+module Interface.TV.Tangible
+  (
+  -- * Tangible values
+   TV, tv, unTv, runTV
+  ) where
+
+import Control.Arrow
+import Control.Monad.Identity
+
+import Data.Tupler
+import Interface.TV.Output
+import Interface.TV.Present
+import Interface.TV.Misc
+
+-- import Control.Arrow.DeepArrow
+-- import Data.FunArr
+-- import Interface.TV.OFun 
+
+-- | Tangible values (TVs).
+type TV (~>) a = Pair1 (Output (~>)) Identity a
+
+-- To do: use a newtype for TV, for friendlier messages.  Requires TVFun
+-- and FunArr instance below.  Unfortunately, GHC will not automatically
+-- derive the instances I'll need.
+
+-- -- | 'DeepArrow' corresponding to 'TV'
+-- newtype TVFun (~>) a b = TVFun (Pair2 (OFun (~>)) (->) a b) deriving DeepArrow
+
+-- instance FunArr (~>) => FunArr (TVFun (~>)) (TV (~>))
+
+-- | Make a 'TV'
+tv :: Output (~>) a -> a -> TV (~>) a
+tv o a = Pair1 (o, return a)
+
+-- | Dissect a 'TV'
+unTv :: TV (~>) a -> (Output (~>) a, a)
+unTv (Pair1 (o, ida)) = (o, runIdentity ida)
+
+-- | Run a 'TV'
+runTV :: (ToIO (~>), Present (~>)) => TV (~>) a -> IO ()
+runTV teevee = toIO (pure (const a) >>> present o)
+  where (o,a) = unTv teevee
+ src/Interface/TV/UI.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS -fglasgow-exts #-}
+
+----------------------------------------------------------------------
+-- |
+-- Module      :  Interface.TV.UI
+-- Copyright   :  (c) Conal Elliott 2006
+-- License     :  LGPL
+-- 
+-- Maintainer  :  conal@conal.net
+-- Stability   :  experimental
+-- Portability :  portable
+-- 
+-- Graphical 'UI' instances of TV classes 'Present', 'ToIO', and
+-- 'CommonInsOuts'
+----------------------------------------------------------------------
+
+module Interface.TV.UI
+  (
+   -- * Input
+     islider
+   -- * Disambiguator
+   , runUI
+  ) where
+
+import Control.Arrow (pure,(>>>))
+
+import Graphics.UI.Phooey hiding (runUI,islider)
+import qualified Graphics.UI.Phooey as Ph (islider)
+
+import Interface.TV.Input (Input,iPrim)
+import Interface.TV.Present (Present(..))
+import Interface.TV.Common (CommonInsOuts(..))
+import Interface.TV.Tangible (TV,runTV)
+import Interface.TV.Misc (ToIO(..))
+
+
+{----------------------------------------------------------
+    Instances
+----------------------------------------------------------}
+
+instance Present UI where
+  presentPair    = fromLeft
+  presentLambda  = fromTop
+  presentCompose = id
+  presentTitle   = title
+
+-- 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"
+
+instance CommonInsOuts UI where
+  putString = stringDisplay
+  getString = textEntry
+
+
+{----------------------------------------------------------
+    Input
+----------------------------------------------------------}
+
+islider :: Int -> (Int,Int) -> Input UI Int
+islider initial bounds =
+  iPrim (pure (const bounds) >>> Ph.islider initial)
+
+
+{----------------------------------------------------------
+    Disambiguator
+----------------------------------------------------------}
+
+-- | Many TVs work for all 'CommonInsOuts' arrows.  Applying 'runTV' is
+-- then ambiguous.  This type specialization disambiguates.
+runUI :: TV UI a -> IO ()
+runUI = runTV
+ src/tasks view
@@ -0,0 +1,12 @@+Simon 94
+Henk 79
+Alonzo 70
+Don 69
+Bob 80
+Oleg 77
+Henk 89
+Bob 90
+Simon 45
+Alonzo 99
+Oleg 85
+Don 97
+ src/test.txt view
@@ -0,0 +1,5 @@+To see a World in a Grain of Sand
+And a Heaven in a Wild Flower, 
+Hold Infinity in the palm of your hand
+And Eternity in an hour.
+    - William Blake