TV 0.0 → 0.1.1
raw patch · 21 files changed
+1758/−1522 lines, 21 files
Files
- CHANGES +21/−19
- Makefile +14/−15
- README +23/−23
- TODO +6/−6
- TV.cabal +51/−51
- src/Examples.hs +140/−229
- src/Grading.lhs +237/−0
- src/Interface/TV.hs +51/−48
- src/Interface/TV/Common.hs +122/−109
- src/Interface/TV/Defaults.hs +70/−70
- src/Interface/TV/DefaultsList.hs +128/−128
- src/Interface/TV/IO.hs +121/−99
- src/Interface/TV/Input.hs +118/−113
- src/Interface/TV/Kleisli.hs +61/−61
- src/Interface/TV/Misc.hs +48/−48
- src/Interface/TV/OFun.hs +179/−152
- src/Interface/TV/Output.hs +147/−137
- src/Interface/TV/Present.hs +78/−74
- src/Interface/TV/Tangible.hs +58/−55
- src/Interface/TV/UI.hs +73/−73
- src/tasks +12/−12
CHANGES view
@@ -1,19 +1,21 @@-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 +Version 0.1.1:+* Changed all files to *nix-style line endings.++Version 0.1:+* Removed iEmpty & iEmpty 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.
Makefile view
@@ -1,15 +1,14 @@-# 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 +# See README for Cabal-based building. Other fancy stuff (like haddock) here.++user = conal+package = TV++configure_args=--disable-use-packages --haddock-args="\+ --read-interface=http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \+ --read-interface=http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \+ --read-interface=http://darcs.haskell.org/packages/phooey/doc/html,c:/Haskell/packages/phooey-0.1/doc/html/phooey.haddock \+ --read-interface=http://darcs.haskell.org/packages/DeepArrow/doc/html,c:/Haskell/packages/DeepArrow-0.0/doc/html/DeepArrow.haddock \+ $(source_args)\+ $(comments_args)\+ "+include ../my-cabal-make.inc
README view
@@ -1,23 +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. +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.
TODO view
@@ -1,6 +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. + 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,51 +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! - . - © 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 +Name: TV+Version: 0.1.1+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!+ .+ © 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 -W
src/Examples.hs view
@@ -1,229 +1,140 @@-{-# 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 +{-# OPTIONS -fglasgow-exts #-}++module Examples where++import Data.List (sort)++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 shoppingUO (+)++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" $ interactLineRS []) 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)++-- io3, ... :: 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+++-- Find lines with 0 < length < n+short :: Int -> [String] -> [String]+short n = filter (tween 1 n . length)+ where tween lo hi i = lo <= i && i < hi++-- Extract lines from a file before a function and combine lines after.+shortO :: FilePath -> Output KIO ([String] -> [String])+shortO path = oLambda (fmap lines (fileIn path)) (cofmap unlines defaultOut)++-- Nearly equivalent, but retains more Output structure:+-- shortO path = cofmap (wrapF unlines lines) (oLambda (fileIn path) defaultOut)++shortT :: FilePath -> Int -> TV KIO ([String] -> [String])+shortT path n = tv (shortO path) (sort . short n)++-- Example: runTV (shortT "c:/conal/Misc/quotes.tw" 100)
+ src/Grading.lhs view
@@ -0,0 +1,237 @@+! Introduction /% -*-Twee-*- (http://www.gimcrackd.com/etc/src/twee.el) %/+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 TV [[depends on| http://darcs.haskell.org/packages/TV/TV.cabal]]).++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 Control.Arrow.DeepArrow+import Interface.TV -- 0.1+\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.hs view
@@ -1,48 +1,51 @@-{-# 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 +{-# 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+ -- * 'Output' transformers+ , OX, OFun, wrapO, wrapAO+ -- * Common ins & outs+ , Common, CInput, COutput+ , stringIn, readIn{-, intIn-}, stringOut, showOut, interactLine+ , readShow, interactLineRS+ -- * Default ins & outs+ , DefaultIn(..), DefaultOut(..)+ -- * Kleisli arrows+ , kIn, kOut+ -- ** IO-based+ , KIO, contentsIn, fileIn, interactOut, fileOut, fromFile, toFile, 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
@@ -1,109 +1,122 @@-{-# 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 +{-# 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, readShow, interactLineRS+ ) where++import Control.Arrow++import Interface.TV.Input+import Interface.TV.Output+import Interface.TV.OFun (wrapO)+import Interface.TV.Tangible (TV)++import Interface.TV.Misc (readD,Cofunctor(..))++-- | 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 -- ^ default+ -> 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 -- ^ default+ -> CInput a+readIn dflt = fmap (readD dflt) stringIn+++-- | 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 = cofmap show 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++-- | Handy Read+Show wrapper+readShow :: (Read a, Show b, CommonInsOuts (~>))+ => Output (~>) (String->String) -- ^ base output+ -> a -- ^ default, when read fails+ -> Output (~>) (a -> b)+readShow o dflt = wrapO show (readD dflt) o++-- | Read+Show of 'interactLine'+interactLineRS :: (Read a, Show b, CommonInsOuts (~>))+ => a -- ^ default, if read fails+ -> Output (~>) (a -> b)+interactLineRS = readShow interactLine++-- Equivalently:+-- interactLineRS dflt = wrapO show (readD dflt) interactLine+-- interactLineRS dflt = oLambda (readIn dflt) showOut
src/Interface/TV/Defaults.hs view
@@ -1,70 +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 +{-# 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
@@ -1,128 +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)" - +{-# 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
@@ -1,99 +1,121 @@-{-# 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 +{-# 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, interactRS, fileOut+ -- * TVs+ , fromFile, toFile+ -- * Disambiguator+ , runIO+ ) where++import Control.Arrow++import Interface.TV.Input+import Interface.TV.Output+import Interface.TV.Tangible (tv,TV,RunTV,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 :: FilePath -> 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++-- | Read+Show of 'interact'+interactRS :: (Read a, Show b)+ => a -- ^ default, if read fails+ -> Output KIO (a -> b)+interactRS = readShow interactOut++-- | 'Output' version of 'writeFile'+fileOut :: FilePath -> Output KIO String+fileOut name = kOut (writeFile name)+++{----------------------------------------------------------+ TVs+----------------------------------------------------------}++fromFile :: FilePath -> TV KIO (String->String)+fromFile name = tv (oLambda (fileIn name) stringOut) id++toFile :: FilePath -> TV KIO (String->String)+toFile name = tv (oLambda stringIn (fileOut name)) id++{----------------------------------------------------------+ Disambiguator+----------------------------------------------------------}++-- | Many TVs work for all 'CommonInsOuts' arrows. Applying 'runTV' is+-- then ambiguous. This type specialization disambiguates.+runIO :: RunTV KIO+runIO = runTV
src/Interface/TV/Input.hs view
@@ -1,113 +1,118 @@-{-# 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 - +{-# 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 (generalizes 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++")"++{----------------------------------------------------------+ 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 i = error ("asIPair of non-IPair "++show i)+-- 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+iPrim = IPrim++-- | Input a pair+iPair :: Input (~>) a -> Input (~>) b -> Input (~>) (a,b)+iPair = IPair++-- | Massage via an arrow value (generalizes fmap)+iCompose :: Arrow (~>) => Input (~>) a -> a ~> b -> Input (~>) b+IPrim put `iCompose` arr = IPrim (put >>> arr)+i `iCompose` _ = error ("iCompose given non-IPrim: "++show i)++-- iCompose = ICompose++-- | Title (label) an input+iTitle :: String -> Input (~>) a -> Input (~>) a+iTitle = ITitle+++-- | Handy specialization of 'iCompose'+instance Arrow (~>) => Functor (Input (~>)) where+ fmap f input = input `iCompose` pure f
src/Interface/TV/Kleisli.hs view
@@ -1,61 +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) +{-# 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
@@ -1,48 +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 +{-# 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
@@ -1,152 +1,179 @@-{-# 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. - +{-# 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 (OX,OFun,wrapO,wrapAO) where++import Control.Arrow++import Data.FunArr+import Control.Arrow.DeepArrow++import Interface.TV.Output+import Interface.TV.Input++-- | Output functions.+type OX (~>) a b = Output (~>) a -> Output (~>) b++-- | Output functions as a 'DeepArrow'+newtype OFun (~>) a b = OFun (OX (~>) a b)++-- TODO: consider generalizing from "->" in IFun?++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)+ -- argument (OFun ox) = OFun (argumentO 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++-- argumentO :: OX (~>) a' a -> OX (~>) (a->b) (a'->b)+-- argumentO ox 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.+++---- Other functions++-- | Like @wrapF@, but for outputs and reversed orientation.+-- Specialization of 'wrapAO'.+wrapO :: Arrow (~>) => (b'->b) -> (a->a') -> OX (~>) (a->b) (a'->b')+wrapO g f = wrapAO (pure g) (pure f)++-- | Generalizes 'wrapO' for arbitrary arrows.+wrapAO :: Arrow (~>) =>+ (b' ~> b) -> (a ~> a') -> OX (~>) (a->b) (a'->b')+wrapAO outer inner ab = OLambda (ia `iCompose` inner) (outer `oCompose` ob)+ where+ (ia,ob) = asOLambda ab+++-- Then we get an elegant definition of @interactRSOut@:++-- interactRSOut dflt = wrapO show (readD dflt) interactLine++
src/Interface/TV/Output.hs view
@@ -1,137 +1,147 @@-{-# 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 +{-# 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 o = error ("asOLambda of non-OLambda "++show o)++--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 o = error ("asOPair of non-OPair "++show o)++-- 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 :: Arrow (~>) => a ~> b -> Output (~>) b -> Output (~>) a+arr `oCompose` OPrim put = OPrim (arr >>> put)+_ `oCompose` o = error ("oCompose given non-OPrim: "++show o)++-- oCompose = OCompose++-- | Title (label) an output+oTitle :: String -> Output (~>) a -> Output (~>) a+oTitle = OTitle++-- | Handy specialization of 'oCompose'+instance Arrow (~>) => Cofunctor (Output (~>)) where+ cofmap f input = pure f `oCompose` input
src/Interface/TV/Present.hs view
@@ -1,74 +1,78 @@-{-# 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) +{-# 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+ 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/Tangible.hs view
@@ -1,55 +1,58 @@-{-# 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 +{-# 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, 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)++-- | To define disambiguating type-specializations+type RunTV (~>) = forall a. TV (~>) a -> IO ()++-- | Run a 'TV'+runTV :: (ToIO (~>), Present (~>)) => RunTV (~>)+runTV teevee = toIO (pure (const a) >>> present o)+ where (o,a) = unTv teevee
src/Interface/TV/UI.hs view
@@ -1,73 +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 +{-# 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 view
@@ -1,12 +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 +Simon 94+Henk 79+Alonzo 70+Don 69+Bob 80+Oleg 77+Henk 89+Bob 90+Simon 45+Alonzo 99+Oleg 85+Don 97