diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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. diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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. diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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. diff --git a/TV.cabal b/TV.cabal --- a/TV.cabal +++ b/TV.cabal @@ -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 - . - 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 + . + 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 diff --git a/src/Examples.hs b/src/Examples.hs --- a/src/Examples.hs +++ b/src/Examples.hs @@ -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) diff --git a/src/Grading.lhs b/src/Grading.lhs new file mode 100644 --- /dev/null +++ b/src/Grading.lhs @@ -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. diff --git a/src/Interface/TV.hs b/src/Interface/TV.hs --- a/src/Interface/TV.hs +++ b/src/Interface/TV.hs @@ -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 diff --git a/src/Interface/TV/Common.hs b/src/Interface/TV/Common.hs --- a/src/Interface/TV/Common.hs +++ b/src/Interface/TV/Common.hs @@ -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 diff --git a/src/Interface/TV/Defaults.hs b/src/Interface/TV/Defaults.hs --- a/src/Interface/TV/Defaults.hs +++ b/src/Interface/TV/Defaults.hs @@ -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 diff --git a/src/Interface/TV/DefaultsList.hs b/src/Interface/TV/DefaultsList.hs --- a/src/Interface/TV/DefaultsList.hs +++ b/src/Interface/TV/DefaultsList.hs @@ -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)" + diff --git a/src/Interface/TV/IO.hs b/src/Interface/TV/IO.hs --- a/src/Interface/TV/IO.hs +++ b/src/Interface/TV/IO.hs @@ -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 diff --git a/src/Interface/TV/Input.hs b/src/Interface/TV/Input.hs --- a/src/Interface/TV/Input.hs +++ b/src/Interface/TV/Input.hs @@ -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 diff --git a/src/Interface/TV/Kleisli.hs b/src/Interface/TV/Kleisli.hs --- a/src/Interface/TV/Kleisli.hs +++ b/src/Interface/TV/Kleisli.hs @@ -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) diff --git a/src/Interface/TV/Misc.hs b/src/Interface/TV/Misc.hs --- a/src/Interface/TV/Misc.hs +++ b/src/Interface/TV/Misc.hs @@ -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 diff --git a/src/Interface/TV/OFun.hs b/src/Interface/TV/OFun.hs --- a/src/Interface/TV/OFun.hs +++ b/src/Interface/TV/OFun.hs @@ -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 + + diff --git a/src/Interface/TV/Output.hs b/src/Interface/TV/Output.hs --- a/src/Interface/TV/Output.hs +++ b/src/Interface/TV/Output.hs @@ -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 diff --git a/src/Interface/TV/Present.hs b/src/Interface/TV/Present.hs --- a/src/Interface/TV/Present.hs +++ b/src/Interface/TV/Present.hs @@ -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) diff --git a/src/Interface/TV/Tangible.hs b/src/Interface/TV/Tangible.hs --- a/src/Interface/TV/Tangible.hs +++ b/src/Interface/TV/Tangible.hs @@ -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 diff --git a/src/Interface/TV/UI.hs b/src/Interface/TV/UI.hs --- a/src/Interface/TV/UI.hs +++ b/src/Interface/TV/UI.hs @@ -1,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 diff --git a/src/tasks b/src/tasks --- a/src/tasks +++ b/src/tasks @@ -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