TV 0.4.7 → 0.4.8
raw patch · 17 files changed
+47/−862 lines, 17 files
Files
- CHANGES +0/−48
- COPYING +25/−0
- Makefile +0/−1
- README +0/−15
- TODO +0/−6
- TV.cabal +3/−2
- src/Grading.lhs +0/−236
- src/Interface/TV/Common.hs +7/−7
- src/Interface/TV/Kleisli.hs +0/−61
- src/Interface/TV/Misc.hs +0/−43
- src/Interface/TV/OFun.hs +3/−3
- src/Interface/TV/Output.hs +9/−9
- src/Interface/TV/Present.hs +0/−78
- src/Interface/TV/TestAF.hs +0/−263
- src/Interface/TV/UI.hs +0/−73
- src/tasks +0/−12
- src/test.txt +0/−5
− CHANGES
@@ -1,48 +0,0 @@-% [TV](http://haskell.org/haskellwiki/TV) changes--## Version 0.3 ##--+ Overhauled to integrate with [Eros](http://haskell.org/haskellwiki/Eros)-+ Eliminated arrows, in favor of [applicative- functors](http://haskell.org/haskellwiki/Applicative_functor). Now- [Input](src/Interface/TV/Input.hs) takes a type (constructor) parameters:- `src`, and [Output](src/Interface/TV/Output.hs) takes two type- (constructor) parameters: `src` & `snk`.-+ Using `LANGUAGE` pragma in place of most `OPTIONS`--## Version 0.2 ##--+ Simplified exports in [TV.hs](src/Interface/TV.hs). Now just exports by module- rather than by entity. Also re-export [DeepArrow] modules.-+ Moved GUI functionality out to a new package [GuiTV]. Removed- dependency on [Phooey] and (indirectly) [wxHaskell], as the latter can- be difficult to install. --## Version 0.1.1 ##--+ Changed all files to *nix-style line endings.--## Version 0.1 ##--+ Removed iEmpty & oEmpty and corresponding constructors. Generate dynamic- errors earlier rather than later.-+ Removed ICompose & OCompose constructors. Redefined iCompose and- oCompose (and consequently fmap on inputs and cofmap on outputs) to work- only on (possibly titled) primitives. I don't know how to implement the- DeepArrow algebra with OCompose.-+ Added wrapO and wrapAO, sort of analogous (or dual) to wrapF. I'm not- sure the name is a great choice. I've also considered "unwrapO".-+ Added readShow, defined via wrapO.-+ Redefined interactRSOut via readShow and renamed "interactLineRS".- Added "interactRS".-+ Added fromFile & toFile TV functions.-+ Added fileOut-+ Moved Grading example from src/Examples.hs to src/Grading.hs-+ Added "short lines" example to src/Examples.hs.-+ Added type alias RunTV for defining types of runTV specializations, such- as runUI and runIO.--[GuiTV]: http://haskell.org/haskellwiki/GuiTV-[Phooey]: http://haskell.org/haskellwiki/Phooey-[wxHaskell]: http://haskell.org/haskellwiki/wxHaskell-
+ 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.+
− Makefile
@@ -1,1 +0,0 @@-include ../cho-home-cabal-make.inc
− README
@@ -1,15 +0,0 @@-TV is a library for interfacing to functional values. It can also be-viewed as an approach to functional interfaces. The name "TV" comes-"tangible values", which is the central idea of the library. For a fuller-description and link to documentation, please see the project wiki page:-- http://haskell.org/haskellwiki/TV--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--See src/Examples.hs for examples.
− TODO
@@ -1,6 +0,0 @@- 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
@@ -1,5 +1,5 @@ Name: TV-Version: 0.4.7+Version: 0.4.8 Synopsis: Tangible Values -- composable interfaces Category: Interfaces Description:@@ -23,6 +23,7 @@ Package-Url: http://code.haskell.org/~conal/code/TV Copyright: (c) 2006,2009 by Conal Elliott License: BSD3+License-File: COPYING Stability: experimental Hs-Source-Dirs: src Build-Depends: base<5, DeepArrow>=0.3.1, TypeCompose >= 0.6.7@@ -38,5 +39,5 @@ Interface.TV.IO Interface.TV.Defaults Extra-Source-Files: - Examples+ src/Examples.hs ghc-options: -Wall
− src/Grading.lhs
@@ -1,236 +0,0 @@-! Introduction /% -*-Twee-*- (http://www.gimcrackd.com/etc/src/twee.el) %/-The example in this post illustrates an approach to separating logic and IO using the [[TV| http://haskell.org/haskellwiki/TV]] library. The example is [[from Don Stewart's blog| http://cgi.cse.unsw.edu.au/~dons/blog/2006/12/16#programming-haskell-intro]]. My thanks to Don, as this example inspired me to play with alternatives, which led to generalizing TV from GUIs to a more general notion of "interfaces". The TV approach clarifies the pure logic part and the IO part and is more conveniently composable than the mixed logic/IO formulation.--! What's this?-This post is a literate Haskell program, as well as a TiddlyWiki passage (tiddler). To run the program, double-click on the entry, copy the markup into file called "Grading.lhs", install [[TV| http://haskell.org/haskellwiki/TV]] 0.1 or later (and the libraries on which TV [[depends| http://darcs.haskell.org/packages/TV/TV.cabal]]). I recommend TV 0.2 or later, which does not require GUI support (moved out to [[GuiTV| http://haskell.org/haskellwiki/GuiTV]]).--In the text below, you can click boxed ">" symbols to show more detail and click boxed "<" symbols to show less detail. For example, we begin with a module header. +++-\begin{code}-module Grading where--import Data.List (sort)-import Data.Map (Map,empty,keys,insertWith,findWithDefault)-import Text.Printf--import Interface.TV-import Interface.TV.OFun() -- work around GHC bug. ticket #1145-\end{code}-=== --! Original example-Here's the original version that mixes logic and I/O:-\begin{code}-grades = 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-\end{code}--! Separating logic and interface-!! A bit of massaging-As a first step, have @draw@ yield a string to be concat'd, rather than performing a side-effect. Then we can easily isolate the pure code and separate out an @IO@ driver. +++-\begin{code}-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-\end{code}-=== -\begin{code}-type GradingStr = String -> String--gradingStr :: GradingStr--grades_2 = readFile "tasks" >>= return . gradingStr >>= putStr-\end{code}--Let's look at the driver definition (@grades_2@). It contains three parts: external input (@readFile "tasks"@), logic (@gradingStr@), and external output (@putStr@). By "external", I mean external to the world of pure values.--!! Declarative interface specification-This plumbing pattern used for @grades_2@ can be abstracted out and used with any pure function. That style of abstraction would be very useful, but not universal, because it only applies to functions.--A more general approach is to split @grades_2@ into //two// parts (rather than three). One is the pure value (the @gradingStr@ function in this case) and the other is a way to "output" that value, i.e., an //interface//. One way to output a function is to combine a way to input arguments and a way to output results.-\begin{code}-gradingStrOut = oLambda (fileIn "tasks") stringOut-\end{code}-The TV functions @fileIn@ and @stringOut@ are trivial wrappers around @readFile@ and @putStr@.--Combining this interface with the pure value, we get a "TV" (tangible value):-\begin{code}-gradingStrT :: TV KIO GradingStr-gradingStrT = tv gradingStrOut gradingStr-\end{code}--We can re-express @grades@ simply as running this TV. +++-{{{-*Grading> grades_3-Alonzo [70.0,99.0] Average: 84.5-Bob [80.0,90.0] Average: 85.0-Don [69.0,97.0] Average: 83.0-Henk [79.0,89.0] Average: 84.0-Oleg [77.0,85.0] Average: 81.0-Simon [94.0,45.0] Average: 69.5-}}}-=== -\begin{code}-grades_3 = runTV gradingStrT-\end{code}--To see the input file, we can use @gradingStrOut@ (defined above) as an interface to the identity function. +++-{{{-*Grading> runTV (tv gradingStrOut id)-Simon 94-Henk 79-Alonzo 70-Don 69-Bob 80-Oleg 77-Henk 89-Bob 90-Simon 45-Alonzo 99-Oleg 85-Don 97-}}}-This pattern of using an identity function and a file is generally useful, so it has a name, "[[fromFile| http://darcs.haskell.org/packages/TV/doc/html/Interface-TV-IO.html#fromFile]]". The command above is equivalent to "@runTV (fromFile "tasks")@". (There is also "[[toFile| http://darcs.haskell.org/packages/TV/doc/html/Interface-TV-IO.html#toFile]]".)-=== --! Deeper interfaces-The string representations used in @grading@ are also aspects of "interfacing" (to file representation and human reader). To factor out these aspects, re-express @gradingStr@ as a composition of parsing, grading, and unparsing: -\begin{code}-gradingStr_2 = unparseGrades . grading . parseTasks-\end{code}--Since this sort of wrapping (of @grading@) is common, we have a name for it (@wrapF@ in [[Interface.TV.Misc| http://darcs.haskell.org/packages/TV/doc/html/Interface-TV-Misc.html]]).-\begin{code}-gradingStr_3 :: GradingStr-gradingStr_3 = wrapF unparseGrades parseTasks grading-\end{code}--The data types and conversions result from refactoring @gradingStr@. +++-\begin{code}-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-\end{code}-=== --Now we can make a @Grading@ output that parses on the way in and unparses on the way out.-\begin{code}-gradingOut = oLambda (fmap parseTasks (fileIn "tasks"))- (cofmap unparseGrades stringOut)-\end{code}--Better, define @gradingOut@ via @gradingStrOut@, dual to the formulation of @gradingStr@ via @grading@:-\begin{code}-gradingOut_2 :: Output KIO Grading-gradingOut_2 = wrapO unparseGrades parseTasks gradingStrOut-\end{code}--Finally, combine the interface and the logic:-\begin{code}-gradingT :: TV KIO Grading-gradingT = tv gradingOut_2 grading-\end{code}--\begin{code}-grades_4 = runTV gradingT-\end{code}--! Composition-Above we've made TVs directly, from interface and value. We can also compose them from simpler TVs. Here's a simple decomposition of @grading@ into two phases: coalesce tasks for each student, and compute average grades.-\begin{code}-type Coalesced = Map String [Double]--coalesce :: [Task] -> Coalesced-summarize :: Coalesced -> [Grade]--grading_2 :: Grading-grading_2 = summarize . coalesce-\end{code}-The implementation is just a refactoring of @grading@. +++-\begin{code}-coalesce tasks = foldr insert empty tasks- where- insert (s,g) = insertWith (++) s [g]--summarize grades = map (summary grades) (sort (keys grades))- where- summary g s = (s,marks,avg)- where- marks = findWithDefault (error "No such student") s g- avg = sum marks / fromIntegral (length marks) :: Double-\end{code}-=== --Let's give each of these pieces its own interface.-\begin{code}-coalesceT = tv (oLambda (fmap parseTasks (fileIn "tasks")) showOut)- coalesce--summarizeT = tv (oLambda (readIn empty)- (cofmap unparseGrades defaultOut))- summarize-\end{code}--We can run these TVs independently. First @coalesceT@, with input from the tasks file:-{{{-*Grading> runTV coalesceT-fromList [("Alonzo",[70.0,99.0]),("Bob",[80.0,90.0]),("Don",[69.0,97.0]),("Henk",[79.0,89.0]),("Oleg",[77.0,85.0]),("Simon",[94.0,45.0])]-}}}-Running the second phase (pasting in the first phase output as second phase input) gives our summary output. +++-{{{-*Grading> runTV summarizeT-fromList [("Alonzo",[70.0,99.0]),("Bob",[80.0,90.0]),("Don",[69.0,97.0]),("Henk",[79.0,89.0]),("Oleg",[77.0,85.0]),("Simon",[94.0,45.0])]-Alonzo [70.0,99.0] Average: 84.5-Bob [80.0,90.0] Average: 85.0-Don [69.0,97.0] Average: 83.0-Henk [79.0,89.0] Average: 84.0-Oleg [77.0,85.0] Average: 81.0-Simon [94.0,45.0] Average: 69.5-}}}-=== --We can also compose the two TVs and run the result.-\begin{code}-gradingT_2 = coalesceT ->| summarizeT--grades_5 = runTV gradingT_2-\end{code}-This composition does less work than running each phase separately. The matching input and output vanish during composition, eliminating conversion of the map to and from a string representation, as well as the writing and reading of those strings. This same elimination applies to other kinds of interfaces as well, such as GUIs.
src/Interface/TV/Common.hs view
@@ -28,7 +28,7 @@ -- import Control.Arrow -- import Control.Applicative -import Control.Compose (OI,Flip(..),Cofunctor(..))+import Control.Compose (OI,Flip(..),ContraFunctor(..)) import Interface.TV.Input import Interface.TV.Output@@ -83,14 +83,14 @@ -- | Output a string putString :: snk String -- | Shows based outout. Define as 'putShowC' when @snk@ is a- -- 'Cofunctor'+ -- 'ContraFunctor' putShow :: Show a => snk a -- | Output a bool putBool :: snk Bool putBool = putShow -putShowC :: (CommonOuts snk, Cofunctor snk, Show a) => snk a-putShowC = cofmap show putString+putShowC :: (CommonOuts snk, ContraFunctor snk, Show a) => snk a+putShowC = contraFmap show putString -- | Inputs that work over all 'CommonInsOuts' typecons. type CInput a = forall src. (CommonIns src) => Input src a@@ -132,7 +132,7 @@ -- | Output a showable value showOut :: Show a => COutput a-showOut = oPrim putShow -- cofmap show stringOut+showOut = oPrim putShow -- contraFmap show stringOut -- | 'Output' version of 'interact'. Well, not quite, since the IO -- version uses 'getLine' instead of 'getContents'. See also@@ -142,7 +142,7 @@ -- | Handy Read+Show wrapper readShow :: ( Read a, Show b, CommonIns src, CommonOuts snk- , Functor src, Cofunctor snk )+ , Functor src, ContraFunctor snk ) => Output src snk (String->String) -- ^ base output -> a -- ^ default, when read fails -> Output src snk (a -> b)@@ -165,6 +165,6 @@ interactLineRS dflt = oLambda (readIn dflt) showOut --- This version requires Functor src & Cofunctor snk+-- This version requires Functor src & ContraFunctor snk -- interactLineRS a = readShow (interactLine (show a)) a
− src/Interface/TV/Kleisli.hs
@@ -1,61 +0,0 @@-{-# 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
@@ -1,43 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : Interface.TV.Misc--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : experimental--- Portability : portable--- --- Miscellaneous helpers--------------------------------------------------------------------------module Interface.TV.Misc- (- -- readD {-, Cofunctor(..), ToIO(..), wrapF -}- ) where---- | 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---- Cofunctor is in TypeCompose---- -- | 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
src/Interface/TV/OFun.hs view
@@ -26,7 +26,7 @@ #endif -import Control.Compose (Cofunctor(..))+import Control.Compose (ContraFunctor(..)) import Data.FunArr import Control.Arrow.DeepArrow@@ -183,9 +183,9 @@ -- | Like @wrapF@, but for outputs and reversed orientation. -- Specialization of 'wrapAO'.-wrapO :: (Functor dom, Cofunctor ran) =>+wrapO :: (Functor dom, ContraFunctor ran) => (b'->b) -> (a->a') -> OX dom ran (a->b) (a'->b')-wrapO outer inner ab = OLambda (fmap inner ia) (cofmap outer ob)+wrapO outer inner ab = OLambda (fmap inner ia) (contraFmap outer ob) where (ia,ob) = asOLambda ab
src/Interface/TV/Output.hs view
@@ -26,7 +26,7 @@ ) where -import Control.Compose (Cofunctor(..))+import Control.Compose (ContraFunctor(..)) import Data.Pair (Pair(..)) import Data.Lambda (Lambda(..)) import Data.Title (Title_f(..))@@ -50,7 +50,7 @@ OLambda :: Input src a -> Output src snk b -> Output src snk (a->b) -- -- | Visualize a pair OPair :: Output src snk a -> Output src snk b -> Output src snk (a,b)- -- -- | Massage via an arrow value (like cofmap)+ -- -- | Massage via an arrow value (like contraFmap) -- OCompose :: src (a -> b) -> Output src snk b -> Output src snk a -- -- | Title/label an output OTitle :: String -> Output src snk a -> Output src snk a@@ -148,14 +148,14 @@ oTitle = OTitle --- I specialized oCompose to cofmapO. I don't think there's enough+-- I specialized oCompose to contraFmapO. I don't think there's enough -- machinery to do oCompose. -cofmapO :: Cofunctor snk => (a -> b) -> Output src snk b -> Output src snk a-f `cofmapO` OPrim ranb = OPrim (cofmap f ranb)-f `cofmapO` OTitle str ab = OTitle str (f `cofmapO` ab)-_ `cofmapO` o = error ("cofmapO given non-OPrim: "++show o)+contraFmapO :: ContraFunctor snk => (a -> b) -> Output src snk b -> Output src snk a+f `contraFmapO` OPrim ranb = OPrim (contraFmap f ranb)+f `contraFmapO` OTitle str ab = OTitle str (f `contraFmapO` ab)+_ `contraFmapO` o = error ("contraFmapO given non-OPrim: "++show o) -instance Cofunctor snk => Cofunctor (Output src snk) where- cofmap = cofmapO+instance ContraFunctor snk => ContraFunctor (Output src snk) where+ contraFmap = contraFmapO
− src/Interface/TV/Present.hs
@@ -1,78 +0,0 @@-{-# 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, accept, 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- presentPair = id- presentLambda :: a ~> b -> a ~> b- presentLambda = id- presentTitle :: String -> a ~> b -> a ~> b- presentTitle _ = id--- presentCompose :: a ~> b -> a ~> b--- presentCompose = 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 (ITitle str i) = presentTitle str (accept i)---- accept (ICompose a ab) = presentCompose (accept a >>> ab)---- | 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/TestAF.hs
@@ -1,263 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : TestAF--- Copyright : (c) Conal Elliott 2007--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : experimental--- Portability : GADT--- --- Experiments in (applicative) functors for TV-------------------------------------------------------------------------module TestAF- (- - ) where---import Control.Applicative-import Control.Monad (liftM2)-import Data.Monoid-import Control.Arrow hiding (pure)-import Control.Compose--- import Control.Instances--import qualified Interface.TV.Present as P (Present(..))---- | An /Input/ describes a way to obtain a functional value from a user.--- Used in Output for making function visualizations.-data Input :: (* -> *) -> * -> * where- -- | Input primitive- IPrim :: f a -> Input f a- -- | Input a pair- IPair :: Input f a -> Input f b -> Input f (a,b)- -- | Title/label an input- ITitle :: String -> Input f a -> Input f a---- | An /Output/ describes a way to present a functional value, perhaps--- interactively. It is the interface half of a tangible value.-data Output :: (* -> *) -> * -> * -> * where- -- | Output primitive- OPrim :: f (a -> o) -> Output f o a- -- | Visualize a function. Akin to /lambda/- OLambda :: Input f a -> Output f o b -> Output f o (a->b)- -- | Visualize a pair- OPair :: Output f o a -> Output f o b -> Output f o (a,b)- -- | Title/label an output- OTitle :: String -> Output f o a -> Output f o a----ipairA :: Applicative f => f a -> f b -> f (a,b)-ipairA = liftA2 (,)--olambdaA :: Applicative f => f a -> f (b -> o) -> f ((a->b) -> o)-olambdaA = liftA2 (\ a snkb -> \ f -> snkb (f a))--opairA :: (Applicative f, Monoid o) =>- f (a -> o) -> f (b -> o) -> f ((a,b) -> o)-opairA = liftA2 sinkPair- where- sinkPair :: Monoid o => (a -> o) -> (b -> o) -> ((a,b) -> o)- sinkPair ka kb = \ (a,b) -> ka a `mappend` kb b---- | '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 Present f where- presentPair :: f a -> f a- presentPair = id- presentLambda :: f a -> f a- presentLambda = id- presentTitle :: String -> f a -> f a- presentTitle _ = id---- | Convert an 'Input' into an arrow value.-accept :: (Applicative f, Present f) => Input f b -> f b--accept (IPrim p) = p-accept (IPair ia ib) = presentPair $ ipairA (accept ia) (accept ib)-accept (ITitle str i) = presentTitle str $ accept i----- | Convert an 'Output' into an arrow value-present :: (Applicative f, Monoid o, Present f) => Output f o a -> f (a -> o)--present (OPrim p) = p-present (OPair oa ob) = presentPair $ opairA (present oa) (present ob)-present (OLambda i o) = presentLambda $ olambdaA (accept i) (present o)-present (OTitle str o) = presentTitle str $ present o------- Next, generalize from the particular style of consumer (@f (a -> o)@)--class Pair cof where- pair :: cof a -> cof b -> cof (a,b)--class Lambda f cof where- lambda :: f a -> cof b -> cof (a->b)---- class Cof f cof | cof -> f where--- lambda :: f a -> cof b -> cof (a->b)--- pair :: cof a -> cof b -> cof (a, b)------- Monads--olambdaM :: Monad m => m a -> (b -> m o) -> ((a->b) -> m o)-olambdaM ioa oib = \ f -> ioa >>= oib . f--opairM :: (Monad m, Monoid o) =>- (a -> m o) -> (b -> m o) -> ((a,b) -> m o)-opairM coa cob = \ (a,b) -> liftM2 mappend (coa a) (cob b)---- Repackage 'olambdaA', 'opairA' for use in a 'Lambda' instance.--type CoM m o = Flip (->) (m o)--lamM :: Monad m => m a -> CoM m o b -> CoM m o (a->b)-lamM ioa = inFlip (olambdaM ioa)--pairM :: (Monad m, Monoid o) =>- CoM m o a -> CoM m o b -> CoM m o (a,b)-pairM = inFlip2 opairM--instance Present f => Present (CoM f o) where- presentPair = inFlip (presentPair .)- presentLambda = inFlip (presentLambda .)- presentTitle str = inFlip (presentTitle str .)---- Standard instance: replace IO with any monad-instance Monoid o => Pair (CoM IO o) where- pair = pairM-instance Lambda IO (CoM IO o) where- lambda = lamM---- instance Monoid o => Cof IO (CoM IO o) where--- lambda = lamM--- pair = pairM------- Applicative functors---- Repackage 'olambdaA', 'opairA' for use in a 'Lambda' instance.--type CoA f o = O f (Flip (->) o)--coA :: Functor f => f (b -> o) -> CoA f o b-coA = O . fmap Flip--unCoA :: Functor f => CoA f o b -> f (b -> o)-unCoA = fmap unFlip . unO--inCoA :: (Functor f, Functor g)- => (f (a -> o) -> g (b -> p))- -> (CoA f o a -> CoA g p b)-inCoA f = coA . f . unCoA--inCoA2 :: (Functor f, Functor g, Functor h)- => (f (a -> o) -> g (b -> p) -> h (c -> q))- -> (CoA f o a -> CoA g p b -> CoA h q c)-inCoA2 f coa coa' = coA (f (unCoA coa) (unCoA coa'))---- or--- inCoA2 f coa = inCoA (f (unCoA coa))---lamA :: Applicative f => f a -> CoA f o b -> CoA f o (a->b)-lamA fa = inCoA (olambdaA fa)--pairA :: (Applicative f, Monoid o) =>- CoA f o a -> CoA f o b -> CoA f o (a,b)-pairA = inCoA2 opairA---instance (Functor f, Present f) => Present (CoA f o) where- presentPair = inCoA presentPair- presentLambda = inCoA presentLambda- presentTitle str = inCoA (presentTitle str)---- Standard instance: replace [] with any AF, particularly non-monads.-instance Monoid o => Pair (CoA [] o) where- pair = pairA-instance Lambda [] (CoA [] o) where- lambda = lamA---- instance Monoid o => Cof [] (CoA [] o) where--- lambda = lamA--- pair = pairA------- Arrows--olambdaAr :: (Monoid i, Arrow (~>)) => (i ~> a) -> (b ~> o) -> ((a->b) ~> o)-olambdaAr ia ob = - arr (\ f -> (f, mempty)) >>>- second ia >>>- arr (uncurry ($)) >>>- ob--opairAr :: (Arrow (~>), Monoid o) => (a ~> o) -> (b ~> o) -> ((a,b) ~> o)-opairAr oa ob = (oa *** ob) >>> arr (uncurry mappend)----- Repackage 'olambdaAr', 'opairAr' for use in a 'Lambda' instance.--lamAr :: (Monoid i, Arrow (~>)) => (i ~> a) -> Flip (~>) o b -> Flip (~>) o (a->b)-lamAr ia = inFlip (olambdaAr ia)--pairAr :: (Monoid o, Arrow (~>)) =>- Flip (~>) o a -> Flip (~>) o b -> Flip (~>) o (a,b)-pairAr = inFlip2 opairAr---instance P.Present (~>) => Present (Flip (~>) o) where- presentPair = inFlip P.presentPair- presentLambda = inFlip P.presentLambda- presentTitle str = inFlip (P.presentTitle str)----- Standard instances: replace (->) with any arrow and () and [a] with any monoid-instance Pair (Flip (->) [a]) where- pair = pairAr-instance Lambda ((->) ()) (Flip (->) [a]) where- lambda = lamAr---- instance Cof ((->) ()) (Flip (->) [a]) where--- lambda = lamAr--- pair = pairAr----- The type packaging used in CoM & CoA (Flip and O) complicate the--- definitions. Maybe type-indexed synonyms (not yet implemented) will--- eliminate them.------ | Alternative to 'Output'-data Output' :: (* -> *) -> (* -> *) -> (* -> *) where- -- | Output primitive- OPrim' :: cof a -> Output' f cof a- -- | Visualize a function. Akin to /lambda/- OLambda' :: Input f a -> Output' f cof b -> Output' f cof (a->b)- -- | Visualize a pair- OPair' :: Output' f cof a -> Output' f cof b -> Output' f cof (a,b)- -- | Title/label an output- OTitle' :: String -> Output' f cof a -> Output' f cof a---- | Convert an 'Output' into an arrow value-present' :: (Applicative f, Pair cof, Lambda f cof, Present f, Present cof) =>- Output' f cof a -> cof a--present' (OPrim' p) = p-present' (OPair' oa ob) = presentPair $ pair (present' oa) (present' ob)-present' (OLambda' i o) = presentLambda $ lambda (accept i) (present' o)-present' (OTitle' str o) = presentTitle str $ present' o-
− src/Interface/TV/UI.hs
@@ -1,73 +0,0 @@-{-# 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 (RunTV,runTV)--- import Interface.TV.Misc (ToIO(..))---{----------------------------------------------------------- Instances-----------------------------------------------------------}--instance Present UI where- presentPair = fromLeft- presentLambda = fromTop- presentTitle = title- -- presentCompose = id---- 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 :: RunTV UI-runUI = runTV
− src/tasks
@@ -1,12 +0,0 @@-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
@@ -1,5 +0,0 @@-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