TV 0.2 → 0.4
raw patch · 19 files changed
+727/−502 lines, 19 filesdep +TypeComposedep −mtlsetup-changed
Dependencies added: TypeCompose
Dependencies removed: mtl
Files
- CHANGES +46/−26
- Makefile +5/−9
- Setup.lhs +2/−2
- TV.cabal +5/−9
- src/Examples.hs +36/−11
- src/Grading.lhs +5/−5
- src/Interface/TV.hs +2/−20
- src/Interface/TV/Common.hs +101/−51
- src/Interface/TV/Defaults.hs +33/−19
- src/Interface/TV/DefaultsList.hs +0/−128
- src/Interface/TV/IO.hs +30/−43
- src/Interface/TV/Input.hs +56/−55
- src/Interface/TV/Misc.hs +14/−13
- src/Interface/TV/OFun.hs +40/−42
- src/Interface/TV/Output.hs +59/−48
- src/Interface/TV/Present.hs +1/−1
- src/Interface/TV/Tangible.hs +28/−19
- src/Interface/TV/TestAF.hs +263/−0
- src/Interface/TV/UI.hs +1/−1
CHANGES view
@@ -1,28 +1,48 @@-Version 0.2:-* Simplified exports in src/Interface/TV.hs. Now just exports by module- rather than by entity. Also re-export DeepArrow modules.-* Moved GUI functionality out to a new package "GuiTV". Removed- dependency on Phooey and (indirectly) wxHaskell, as the latter can be- difficult to install.+% [TV](http://haskell.org/haskellwiki/TV) changes -Version 0.1.1:-* Changed all files to *nix-style line endings.+## Version 0.3 ## -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.++ Overhauled to integrate with [Eros](http://haskell.org/haskellwiki/Eros)++ Eliminated arrows, in favor of [applicative+ functors](http://haskell.org/haskellwiki/Applicative_functor). Now+ [Input](src/Interface/TV/Input.hs) takes a type (constructor) parameters:+ `src`, and [Output](src/Interface/TV/Output.hs) takes two type+ (constructor) parameters: `src` & `snk`.++ Using `LANGUAGE` pragma in place of most `OPTIONS`++## Version 0.2 ##+++ Simplified exports in [TV.hs](src/Interface/TV.hs). Now just exports by module+ rather than by entity. Also re-export [DeepArrow] modules.++ Moved GUI functionality out to a new package [GuiTV]. Removed+ dependency on [Phooey] and (indirectly) [wxHaskell], as the latter can+ be difficult to install. ++## Version 0.1.1 ##+++ Changed all files to *nix-style line endings.++## Version 0.1 ##+++ Removed iEmpty & oEmpty and corresponding constructors. Generate dynamic+ errors earlier rather than later.++ Removed ICompose & OCompose constructors. Redefined iCompose and+ oCompose (and consequently fmap on inputs and cofmap on outputs) to work+ only on (possibly titled) primitives. I don't know how to implement the+ DeepArrow algebra with OCompose.++ Added wrapO and wrapAO, sort of analogous (or dual) to wrapF. I'm not+ sure the name is a great choice. I've also considered "unwrapO".++ Added readShow, defined via wrapO.++ Redefined interactRSOut via readShow and renamed "interactLineRS".+ Added "interactRS".++ Added fromFile & toFile TV functions.++ Added fileOut++ Moved Grading example from src/Examples.hs to src/Grading.hs++ Added "short lines" example to src/Examples.hs.++ Added type alias RunTV for defining types of runTV specializations, such+ as runUI and runIO.++[GuiTV]: http://haskell.org/haskellwiki/GuiTV+[Phooey]: http://haskell.org/haskellwiki/Phooey+[wxHaskell]: http://haskell.org/haskellwiki/wxHaskell+
Makefile view
@@ -1,12 +1,8 @@-# See README for Cabal-based building. Other fancy stuff (like haddock) here.+# For special configuration, especially for docs. Otherwise see README. -user = conal+# haddock-interfaces=\+# http://haskell.org/ghc/docs/latest/html/libraries/base,c:/ghc/ghc-6.6/doc/html/libraries/base/base.haddock \+# http://haskell.org/ghc/docs/latest/html/libraries/mtl,c:/ghc/ghc-6.6/doc/html/libraries/mtl/mtl.haddock \+# http://darcs.haskell.org/packages/DeepArrow/doc/html,c:/Haskell/packages/DeepArrow-0.0.1/doc/html/DeepArrow.haddock -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/DeepArrow/doc/html,c:/Haskell/packages/DeepArrow-0.0/doc/html/DeepArrow.haddock \- $(source_args)\- $(comments_args)\- " include ../my-cabal-make.inc
Setup.lhs view
@@ -1,3 +1,3 @@-#!/usr/bin/env runhaskell -> import Distribution.Simple +#!/usr/bin/env runhaskell+> import Distribution.Simple > main = defaultMain
TV.cabal view
@@ -1,5 +1,5 @@ Name: TV-Version: 0.2+Version: 0.4 Synopsis: Tangible Values -- composable interfaces Category: Interfaces Description:@@ -25,22 +25,18 @@ License: BSD3 Stability: experimental Hs-Source-Dirs: src-Build-Depends: base, mtl, DeepArrow+Build-Depends: base, DeepArrow, TypeCompose >= 0.2 tested-with: GHC==6.6-Extensions: CPP+build-type: Simple 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.Kleisli Interface.TV.IO- Interface.TV.Misc+ Interface.TV.Defaults Extra-Source-Files: - Interface.TV.DefaultsList Examples-ghc-options: -O -W+ghc-options: -W
src/Examples.hs view
@@ -1,32 +1,57 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE OverlappingInstances, UndecidableInstances+ , IncoherentInstances, FlexibleContexts #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} +---- Some TV examples. See also GuiTV.+ module Examples where import Data.List (sort)+import Control.Compose (cofmap,OI)+import Control.Arrow.DeepArrow ((->|)) --- import Control.Arrow.DeepArrow--- import Data.FunArr+-- TypeCompose+import Data.Title+ import Interface.TV +-- To pick up the FunArr instance for OFun. GHC bug.+import Interface.TV.OFun()+ -- Try out these the examples with runIO. For the explicitly IO-typed examples, you--- can use runIO or runTV.+-- can use either runIO or runTV. -reverseT :: DefaultOut ([a] -> [a]) => CTV ([a] -> [a])-reverseT = tv (oTitle "reverse" defaultOut) reverse+reverseT :: CTV (String -> String)+reverseT = tv (title "reverse" defaultOut) reverse +-- I don't know why this more general version fails.+-- +-- reverseT :: ( Read a, Show a , CommonIns src , CommonOuts snk ) =>+-- TV src snk ([a] -> [a])+--+-- GHC wants to use the [a] rather than the String instances of DefaultIn+-- and DefaultOut. I thought the rule is most specific instance wins.+ -- This one reverses twice revTwice :: CTV (String -> String) revTwice = reverseT ->| reverseT +-- Same problem with more general type:+-- revTwice :: (Read a, Show a, CommonIns src, CommonOuts snk) =>+-- TV src snk ([a] -> [a])+++ ---- IO examples -testO :: Output KIO (String -> String)+testO :: Output IO OI (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+onLines f = unlines . f . lines+onWords f = unwords . f . words perLine,perWord :: (String -> String) -> (String -> String) perLine f = onLines (map f)@@ -49,13 +74,13 @@ 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 :: FilePath -> Output IO OI ([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 :: FilePath -> Int -> TV IO OI ([String] -> [String]) shortT path n = tv (shortO path) (sort . short n) -- Example: runTV (shortT "c:/conal/Misc/quotes.tw" 100)
src/Grading.lhs view
@@ -1,8 +1,8 @@ ! 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.+The example in this post illustrates an approach to separating logic and IO using the [[TV| http://haskell.org/haskellwiki/TV]] library. The example is [[from Don Stewart's blog| http://cgi.cse.unsw.edu.au/~dons/blog/2006/12/16#programming-haskell-intro]]. My thanks to Don, as this example inspired me to play with alternatives, which led to generalizing TV from GUIs to a more general notion of "interfaces". The TV approach clarifies the pure logic part and the IO part and is more conveniently composable than the mixed logic/IO formulation. ! What's this?-This post is a literate Haskell program, as well as a TiddlyWiki passage (tiddler). To run the program, double-click on the entry, copy the markup into file called "Grading.lhs", install [[TV| http://haskell.org/haskellwiki/TV]] 0.1 or later (and the libraries TV [[depends on| http://darcs.haskell.org/packages/TV/TV.cabal]]).+This post is a literate Haskell program, as well as a TiddlyWiki passage (tiddler). To run the program, double-click on the entry, copy the markup into file called "Grading.lhs", install [[TV| http://haskell.org/haskellwiki/TV]] 0.1 or later (and the libraries on which TV [[depends| http://darcs.haskell.org/packages/TV/TV.cabal]]). I recommend TV 0.2 or later, which does not require GUI support (moved out to [[GuiTV| http://haskell.org/haskellwiki/GuiTV]]). In the text below, you can click boxed ">" symbols to show more detail and click boxed "<" symbols to show less detail. For example, we begin with a module header. +++ \begin{code}@@ -12,7 +12,8 @@ import Data.Map (Map,empty,keys,insertWith,findWithDefault) import Text.Printf -import Interface.TV -- 0.1 or later+import Interface.TV+import Interface.TV.OFun() -- work around GHC bug. ticket #1145 \end{code} === @@ -67,8 +68,7 @@ \begin{code} gradingStrOut = oLambda (fileIn "tasks") stringOut \end{code}-The TV functions @fileIn@ and @stringOut@ are trivial wrappers around-@readFile@ and @putStr@.+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}
src/Interface/TV.hs view
@@ -1,10 +1,8 @@-{-# OPTIONS -fglasgow-exts #-}- ---------------------------------------------------------------------- -- | -- Module : Interface.TV -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -22,24 +20,14 @@ , module Interface.TV.Output -- | Tangible values -- interface (output) and value, combined & separable , module Interface.TV.Tangible- -- | Convert inputs and outputs to arrow values- , module Interface.TV.Present -- | Output transformations, as a deep arrow. , module Interface.TV.OFun -- | Some common interaction vocabulary , module Interface.TV.Common -- | Default inputs & outputs , module Interface.TV.Defaults- -- | Monadic TVs, via Kleisli arrows- , module Interface.TV.Kleisli- -- | IO-based instances of TV classes+ -- | Support for IO-based TVs , module Interface.TV.IO- -- | Miscellaneous helpers- , module Interface.TV.Misc- -- | Re-exports from DeepArrow- , module Control.Arrow.DeepArrow- , module Data.FunArr- ) where -- import Graphics.UI.Phooey (UI)@@ -47,13 +35,7 @@ import Interface.TV.Input import Interface.TV.Output import Interface.TV.Tangible-import Interface.TV.Present import Interface.TV.OFun import Interface.TV.Common import Interface.TV.Defaults-import Interface.TV.Kleisli import Interface.TV.IO-import Interface.TV.Misc--import Control.Arrow.DeepArrow-import Data.FunArr
src/Interface/TV/Common.hs view
@@ -1,14 +1,17 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE Rank2Types, TypeOperators, TypeSynonymInstances,+ PatternGuards, FlexibleInstances #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- | -- Module : Interface.TV.Common -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : Rank2Types -- -- Some common interaction vocabulary ----------------------------------------------------------------------@@ -16,74 +19,109 @@ module Interface.TV.Common ( -- * Type class- CommonInsOuts(..), Common, CInput, COutput, CTV+ CommonIns(..), readD, getReadF, CommonOuts(..), putShowC+ , CInput, CInputI, COutput, CTV -- * Inputs , stringIn, boolIn, readIn -- , intIn -- * Outputs , stringOut, boolOut, showOut, interactLine, readShow, interactLineRS ) where -import Control.Arrow+-- import Control.Arrow+-- import Control.Applicative +import Control.Compose (OI,Flip(..),Cofunctor(..))+ import Interface.TV.Input import Interface.TV.Output import Interface.TV.OFun (wrapO) import Interface.TV.Tangible (TV) -import Interface.TV.Misc (readD,Cofunctor(..))+-- 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++-- | This class captures some useful operations available in some input+-- types, and allows definition of some \"'Common'\" 'Input's+class CommonIns src where+ -- | Input a string (with default)+ getString :: String -> src String+ -- | Read-based input. Initial value is also used as a default for+ -- failed parse. Define as 'getReadF' when @src@ is a 'Functor'.+ -- Requires 'Show' as well as 'Read', for displaying the initial value.+ getRead :: (Show a, Read a) => a -> src a -- | Input a bool- getBool :: Bool -- ^ default- -> () ~> Bool- getBool dflt = getString >>> pure (readD dflt)+ getBool :: Bool -> src Bool+ getBool = getRead {- -- | Input an int with default & bounds -- TODO: add getDouble or generalize getInt :: Int -- ^ default -> (Int,Int) -- ^ bounds- -> () ~> Int+ -> src 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+-- | 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 --- | Outputs that work over all 'CommonInsOuts' arrows.-type COutput a = Common Output a+-- | 'getRead' for 'Functor's+getReadF :: (CommonIns src, Functor src, Show a, Read a) => a -> src a+getReadF dflt = fmap (readD dflt) (getString (show dflt)) --- | 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+instance CommonIns IO where { getString = const getLine; getRead = getReadF } --- | Bool input-boolIn :: Bool -- ^ default- -> CInput Bool-boolIn dflt = iPrim (getBool dflt)+instance CommonOuts OI where { putString = Flip putStrLn; putShow = putShowC } +-- Hm. putStrLn vs putStr above?++-- | This class captures some useful operations available in some arrows+-- and allows definition of some \"'Common'\" 'Input's, 'Output's, and+-- TVs.+class CommonOuts snk where+ -- | Output a string+ putString :: snk String+ -- | Shows based outout. Define as 'putReadC' when @snk@ is a+ -- 'Cofunctor'+ putShow :: Show a => snk a+ -- | Output a bool+ putBool :: snk Bool+ putBool = putShow++putShowC :: (CommonOuts snk, Cofunctor snk, Show a) => snk a+putShowC = cofmap show putString++-- | Inputs that work over all 'CommonInsOuts' typecons.+type CInput a = forall src. (CommonIns src) => Input src a++-- | 'CInput' with initial value+type CInputI a = a -> CInput a++-- | Outputs that work over all 'CommonOuts' typecons.+type COutput a =+ forall src snk. (CommonIns src, CommonOuts snk) => Output src snk a++-- | Convenient type synonym for TVs that work over all 'CommonInsOuts' typecons.+type CTV a = forall src snk. (CommonIns src, CommonOuts snk) => TV src snk a++-- | String input with default+stringIn :: CInputI String+stringIn s = iPrim (getString s)++-- | Bool input with default+boolIn :: CInputI Bool+boolIn b = iPrim (getBool b)+ -- -- | 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+readIn :: (Read a, Show a) => CInputI a+readIn a = iPrim (getRead a) -- | Output a string@@ -96,27 +134,39 @@ -- | Output a showable value showOut :: Show a => COutput a-showOut = cofmap show stringOut+showOut = oPrim putShow -- 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+interactLine :: String -> COutput (String -> String)+interactLine s = oLambda (stringIn s) stringOut -- | Handy Read+Show wrapper-readShow :: (Read a, Show b, CommonInsOuts (~>))- => Output (~>) (String->String) -- ^ base output+readShow :: ( Read a, Show b, CommonIns src, CommonOuts snk+ , Functor src, Cofunctor snk )+ => Output src snk (String->String) -- ^ base output -> a -- ^ default, when read fails- -> Output (~>) (a -> b)+ -> Output src snk (a -> b)+ readShow o dflt = wrapO show (readD dflt) o +-- Tempting to give the following terse type spec:+-- +-- readShow :: (Read a, Show b) =>+-- CFOutput (String->String) -> a -> CFOutput (a -> b)+--+-- However, the universality requirement on the first argument is too strong.+++ -- | Read+Show of 'interactLine'-interactLineRS :: (Read a, Show b, CommonInsOuts (~>))+interactLineRS :: ( Read a, Show a, Show b, CommonIns src, CommonOuts snk ) => a -- ^ default, if read fails- -> Output (~>) (a -> b)-interactLineRS = readShow interactLine+ -> Output src snk (a -> b) --- Equivalently:--- interactLineRS dflt = wrapO show (readD dflt) interactLine--- interactLineRS dflt = oLambda (readIn dflt) showOut+interactLineRS dflt = oLambda (readIn dflt) showOut++-- This version requires Functor src & Cofunctor snk+-- interactLineRS a = readShow (interactLine (show a)) a+
src/Interface/TV/Defaults.hs view
@@ -1,10 +1,14 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE MultiParamTypeClasses, OverlappingInstances+ , TypeSynonymInstances, FlexibleInstances, UndecidableInstances+ , IncoherentInstances #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts -fallow-overlapping-instances -fallow-incoherent-instances #-} ---------------------------------------------------------------------- -- | -- Module : Interface.TV.Defaults -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental@@ -34,37 +38,47 @@ ----------------------------------------------------------} -- | Class of types that provide a default input-class DefaultIn a where+class DefaultIn src a where -- | The default input for a type- defaultIn :: CInput a+ defaultIn :: Input src 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 CommonIns src => DefaultIn src Bool where defaultIn = boolIn False+instance CommonIns src => DefaultIn src Int where defaultIn = readIn 0+instance CommonIns src => DefaultIn src Double where defaultIn = readIn 0+instance CommonIns src => DefaultIn src Float where defaultIn = readIn 0+instance CommonIns src => DefaultIn src String where defaultIn = stringIn "" -instance (DefaultIn a, DefaultIn b) => DefaultIn (a,b) where+instance (DefaultIn src a, DefaultIn src b) => DefaultIn src (a,b) where defaultIn = IPair defaultIn defaultIn +instance (Read a, Show a, CommonIns src, DefaultIn src a) => DefaultIn src [a] where+ defaultIn = readIn [] + {---------------------------------------------------------- Outputs ----------------------------------------------------------} -- | Class of types that provide a default output-class DefaultOut a where+class DefaultOut src snk a where -- | The default output for a type- defaultOut :: COutput a+ defaultOut :: Output src snk 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 (CommonIns src, CommonOuts snk) => DefaultOut src snk Bool where defaultOut = boolOut+instance (CommonIns src, CommonOuts snk) => DefaultOut src snk Int where defaultOut = showOut+instance (CommonIns src, CommonOuts snk) => DefaultOut src snk Double where defaultOut = showOut+instance (CommonIns src, CommonOuts snk) => DefaultOut src snk Float where defaultOut = showOut+instance (CommonIns src, CommonOuts snk) => DefaultOut src snk String where defaultOut = stringOut -instance (DefaultOut a, DefaultOut b) => DefaultOut (a,b) where+-- The OverlappingInstances, UndecidableInstances, and IncoherentInstances+-- are all for the overlap of String and lists.++instance (DefaultOut src snk a, DefaultOut src snk b) => DefaultOut src snk (a,b) where defaultOut = OPair defaultOut defaultOut -instance (DefaultIn a, DefaultOut b) => DefaultOut (a->b) where+instance (DefaultIn src a, DefaultOut src snk b) => DefaultOut src snk (a->b) where defaultOut = OLambda defaultIn defaultOut++instance (Show a, CommonIns src, CommonOuts snk, DefaultOut src snk a) =>+ DefaultOut src snk [a] where+ defaultOut = showOut
− src/Interface/TV/DefaultsList.hs
@@ -1,128 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--------------------------------------------------------------------------- |--- Module : Interface.TV.DefaultsList--- Copyright : (c) Conal Elliott 2006--- License : LGPL--- --- Maintainer : conal@conal.net--- Stability : experimental--- Portability : portable--- --- Default inputs and outputs. Experimental variant of--- "Interface.TV.DefaultsList".--- --- This version extend the 'DefaultIn' and 'DefaultOut' type classes to--- handle lists in a general way, but still handle 'String' (@['Char']@)--- in the most familiar way. The 'Read' and 'Show' classes have a special--- trick. Can I adapt it? This module is an incomplete first attempt.--- See @error@ calls in the code for the gaps.--------------------------------------------------------------------------module Interface.TV.DefaultsList- (- -- * Inputs- DefaultIn(..)- -- * Outputs- , DefaultOut(..)- ) where--import Interface.TV.Input-import Interface.TV.Output-import Interface.TV.Common--{----------------------------------------------------------- Inputs-----------------------------------------------------------}---- | Class of types that provide a default input-class DefaultIn a where- -- | The default input for a type- defaultIn :: CInput a- -- | The default input for lists- defaultInList :: CInput [a]--readInL :: Read a => CInput [a]-readInL = readIn []--instance DefaultIn Bool where- defaultIn = boolIn False- defaultInList = readInL--instance DefaultIn Char where- defaultIn = readIn 'Q'- defaultInList = stringIn--instance DefaultIn Int where- defaultIn = readIn 0- defaultInList = readInL--instance DefaultIn Double where- defaultIn = readIn 0- defaultInList = readInL--instance DefaultIn Float where- defaultIn = readIn 0- defaultInList = readInL---- instance DefaultIn String where--- defaultIn = stringIn--- defaultInList = readInL--instance DefaultIn a => DefaultIn [a] where- defaultIn = defaultInList- defaultInList = error "defaultInList: not yet defined for [a]"--instance (DefaultIn a, DefaultIn b) => DefaultIn (a,b) where- defaultIn = IPair defaultIn defaultIn- defaultInList = error "defaultInList: not yet defined for (a,b)"--{----------------------------------------------------------- Outputs-----------------------------------------------------------}---- | Class of types that provide a default output-class DefaultOut a where- -- | The default output for a type- defaultOut :: COutput a- -- | The default output for lists- defaultOutList :: COutput [a]--instance DefaultOut Bool where- defaultOut = boolOut- defaultOutList = showOut--instance DefaultOut Char where- defaultOut = showOut- defaultOutList = stringOut--instance DefaultOut Int where- defaultOut = showOut- defaultOutList = showOut--instance DefaultOut Double where- defaultOut = showOut- defaultOutList = showOut--instance DefaultOut Float where- defaultOut = showOut- defaultOutList = showOut---- instance DefaultOut String where--- defaultOut = stringOut--- defaultOutList = showOut--instance DefaultOut a => DefaultOut [a] where- defaultOut = defaultOutList- defaultOutList = error "defaultOutList: not yet defined for [a]"--instance (DefaultOut a, DefaultOut b) => DefaultOut (a,b) where- defaultOut = OPair defaultOut defaultOut- defaultOutList = error "defaultOutList: not yet defined for (a,b)"--instance (DefaultIn a, DefaultOut b) => DefaultOut (a->b) where- defaultOut = OLambda defaultIn defaultOut- defaultOutList = error "defaultOutList: not yet defined for (a,b)"-
src/Interface/TV/IO.hs view
@@ -1,25 +1,20 @@-{-# OPTIONS -fglasgow-exts #-}- ---------------------------------------------------------------------- -- | -- Module : Interface.TV.IO -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental -- Portability : portable -- --- IO-based instances of TV classes 'PresentM', 'ToIOM', and--- 'CommonInsOuts'+-- Make IO play with TV ---------------------------------------------------------------------- module Interface.TV.IO (- -- * Types- KIO -- * Inputs- , contentsIn, fileIn+ contentsIn, fileIn -- * Outputs , interactOut, interactRS, fileOut -- * TVs@@ -28,34 +23,21 @@ , runIO ) where -import Control.Arrow+-- import Control.Arrow +import Control.Compose (OI,Flip(..))+-- import Data.Title (Title_f)+-- import Data.Fun (Fun)+import Control.Instances () -- for Monoid/IO instance+ import Interface.TV.Input import Interface.TV.Output import Interface.TV.Tangible (tv,TV,RunTV,runTV)-import Interface.TV.Kleisli-import Interface.TV.Common+import Interface.TV.Common (stringIn,stringOut,readShow) --- | 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+-- There's not much left to do here, given the IO instances for Title,+-- Pair & Fun, CommonIns, CommonOuts. {- @@ -70,51 +52,56 @@ -} +++ {---------------------------------------------------------- Inputs ----------------------------------------------------------} -- | 'Input' version of 'getContents'-contentsIn :: Input KIO String-contentsIn = kIn getContents+contentsIn :: Input IO String+contentsIn = iPrim getContents -- | 'Input' version of 'readFile'-fileIn :: FilePath -> Input KIO String-fileIn name = kIn (readFile name)+fileIn :: FilePath -> Input IO String+fileIn name = iPrim (readFile name) {---------------------------------------------------------- Outputs ----------------------------------------------------------} -- | Equivalent of 'interact'. See also 'Interface.TV.interactLine'-interactOut :: Output KIO (String -> String)+interactOut :: Output IO OI (String -> String) interactOut = oLambda contentsIn stringOut -- | Read+Show of 'interact' interactRS :: (Read a, Show b) => a -- ^ default, if read fails- -> Output KIO (a -> b)+ -> Output IO OI (a -> b)+ interactRS = readShow interactOut -- | 'Output' version of 'writeFile'-fileOut :: FilePath -> Output KIO String-fileOut name = kOut (writeFile name)-+fileOut :: FilePath -> Output IO OI String+fileOut name = oPrim (Flip (writeFile name)) {---------------------------------------------------------- TVs ----------------------------------------------------------} -fromFile :: FilePath -> TV KIO (String->String)+-- | Identity function, with 'fileIn' and 'stringOut'+fromFile :: FilePath -> TV IO OI (String->String) fromFile name = tv (oLambda (fileIn name) stringOut) id -toFile :: FilePath -> TV KIO (String->String)-toFile name = tv (oLambda stringIn (fileOut name)) id+-- | Identity function, with stringIn' and 'fileOut'+toFile :: FilePath -> TV IO OI (String->String)+toFile name = tv (oLambda (stringIn "") (fileOut name)) id {---------------------------------------------------------- Disambiguator ----------------------------------------------------------} -- | Type-disambiguating alias for 'runTV'-runIO :: RunTV KIO+runIO :: RunTV IO OI runIO = runTV
src/Interface/TV/Input.hs view
@@ -1,14 +1,17 @@-{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LANGUAGE GADTs, KindSignatures #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} + ---------------------------------------------------------------------- -- | -- Module : Interface.TV.Input--- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- Copyright : (c) Conal Elliott 2007+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : GADTs -- -- Inputs -- means of obtaining values ----------------------------------------------------------------------@@ -16,13 +19,16 @@ module Interface.TV.Input ( -- * Input data type- Input(..)- -- * Canonicalizers+ Input(..), input+ -- * Input functions+ -- ** Builders+ , iPrim, iPair, iTitle+ -- ** Canonicalizers , asIPair- {-, iEmpty-}, iPrim, iPair, iCompose, iTitle ) where -import Control.Arrow+import Data.Pair (Pair(..))+import Data.Title (Title_f(..)) {---------------------------------------------------------- Input data type@@ -30,48 +36,32 @@ -- | 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+data Input src :: * -> * where -- | Input primitive- IPrim :: () ~> a -> Input (~>) a+ IPrim :: src a -> Input src a -- | Input a pair- IPair :: Input (~>) a -> Input (~>) b -> Input (~>) (a,b)+ IPair :: Input src a -> Input src b -> Input src (a,b) -- | Massage via an arrow value (generalizes fmap)- -- ICompose :: Input (~>) a -> a ~> b -> Input (~>) b+ -- ICompose :: Input src a -> src (a -> b) -> Input src b -- | Title/label an input- ITitle :: String -> Input (~>) a -> Input (~>) a-#endif+ ITitle :: String -> Input src a -> Input src a +instance Title_f (Input src) where title_f = iTitle+ -- See 'OEmpty' for note about eliminating OEmpty. -instance Show (Input (~>) a) where+instance Show (Input src 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)+input :: (Pair src, Title_f src) => Input src t -> src t --- Alternatively, transform titles--- asIPair (ITitle s ab) = ( ITitle ("first of " ++s) a--- , ITitle ("second of "++s) b )--- where--- (a,b) = asIPair ab+input (IPrim ft) = ft+input (IPair a b) = input a `pair` input b+input (ITitle str t) = title_f str (input t) {----------------------------------------------------------@@ -81,37 +71,48 @@ -- 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 :: src a -> Input src a iPrim = IPrim -- | Input a pair-iPair :: Input (~>) a -> Input (~>) b -> Input (~>) (a,b)+iPair :: Input src a -> Input src b -> Input src (a,b) iPair = IPair +instance Pair (Input src) where pair = 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)+fmapO :: Functor src => (a -> b) -> Input src a -> Input src b+fmapO f (IPrim fa) = IPrim (fmap f fa)+fmapO f (ITitle str a) = ITitle str (fmapO f a)+fmapO _ i = error ("fmap given non-IPrim: "++show i) --- iCompose = ICompose+-- Not sure about the ITitle choice. Maybe mention fmap. +instance Functor src => Functor (Input src) where fmap = fmapO+ -- | Title (label) an input-iTitle :: String -> Input (~>) a -> Input (~>) a+iTitle :: String -> Input src a -> Input src a iTitle = ITitle --- | 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.+-- Must be a (possibly titled) pair-style input.+asIPair :: Input src (a,b) -> (Input src a, Input src 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
src/Interface/TV/Misc.hs view
@@ -13,30 +13,31 @@ -- Miscellaneous helpers ---------------------------------------------------------------------- + module Interface.TV.Misc (- readD, Cofunctor(..), ToIO(..), wrapF+ -- readD {-, Cofunctor(..), ToIO(..), wrapF -} ) 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)+-- Cofunctor is in TypeCompose --- | 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 ()+-- -- | 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+-- wrapF :: (c->d) -> (a->b) -> ((b->c) -> (a->d))+-- wrapF after before f = after . f . before
src/Interface/TV/OFun.hs view
@@ -1,56 +1,61 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- | -- Module : Interface.TV.OFun -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : MultiParamTypeClasses -- -- 'Output' transformations, as a deep arrow. ---------------------------------------------------------------------- -module Interface.TV.OFun (OX,OFun,wrapO,wrapAO) where+module Interface.TV.OFun (OX,OFun, wrapO{-,wrapAO-}) where import Control.Arrow +import Control.Compose (Cofunctor(..))+ import Data.FunArr import Control.Arrow.DeepArrow import Interface.TV.Output import Interface.TV.Input+-- import Interface.TV.Misc -- | Output functions.-type OX (~>) a b = Output (~>) a -> Output (~>) b+type OX dom ran a b = Output dom ran a -> Output dom ran b -- | Output functions as a 'DeepArrow'-newtype OFun (~>) a b = OFun (OX (~>) a b)+newtype OFun dom ran a b = OFun (OX dom ran a b) -- TODO: consider generalizing from "->" in IFun? -instance Arrow (OFun (~>)) where- -- (a->b) -> OFun (~>) a b+instance Arrow (OFun dom ran) where+ -- (a->b) -> OFun dom ran 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 dom ran a b -> OFun dom ran b c -> OFun dom ran a c OFun f >>> OFun g = OFun (f >>> g) - -- OFun (~>) a a' -> OFun (~>) (a,b) (a',b)+ -- OFun dom ran a a' -> OFun dom ran (a,b) (a',b) first (OFun f) = OFun (firstO f) - -- OFun (~>) b b' -> OFun (~>) (a,b) (a,b')+ -- OFun dom ran b b' -> OFun dom ran (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+instance DeepArrow (OFun dom ran) where idA = OFun id dupA = postFun "dup" dupO fstA = postFun "first half" fstO@@ -65,24 +70,24 @@ result (OFun ox) = OFun (resultO ox) -- argument (OFun ox) = OFun (argumentO ox) -instance FunArr (OFun (~>)) (Output (~>)) where+instance FunArr (OFun dom ran) (Output dom ran) 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 :: (String -> String) -> OX dom ran a b -> OX dom ran 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 :: String -> OX dom ran a b -> OX dom ran a b posttitle post = retitle (++ (" -- " ++ post)) -- Convenient wrappers--- reFun :: (String->String) -> OX (~>) a b -> OFun (~>) a b+-- reFun :: (String->String) -> OX dom ran a b -> OFun dom ran a b -- reFun re = OFun . retitle re -postFun :: String -> OX (~>) a b -> OFun (~>) a b+postFun :: String -> OX dom ran a b -> OFun dom ran a b postFun post = OFun . posttitle post -- Why don't we do postFun for 'result'? Because we get funny titles when@@ -92,82 +97,77 @@ ---- Output transformers -resultO :: OX (~>) b b' -> OX (~>) (a->b) (a->b')+resultO :: OX dom ran b b' -> OX dom ran (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 dom ran a' a -> OX dom ran (a->b) (a'->b) -- argumentO ox ab = -applyO :: Output (~>) (a->b) -> OX (~>) a b+applyO :: Output dom ran (a->b) -> OX dom ran a b applyO o = const b where (_,b) = asOLambda o -firstO :: OX (~>) a c -> OX (~>) (a,b) (c,b)+firstO :: OX dom ran a c -> OX dom ran (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 :: OX dom ran b c -> OX dom ran (a,b) (a,c) secondO f ab = OPair a (f b) where (a,b) = asOPair ab -dupO :: OX (~>) a (a,a)+dupO :: OX dom ran a (a,a) dupO a = OPair a a -fstO :: OX (~>) (a,b) a+fstO :: OX dom ran (a,b) a fstO ab = a where (a,_) = asOPair ab -sndO :: OX (~>) (a,b) b+sndO :: OX dom ran (a,b) b sndO ab = b where (_,b) = asOPair ab -funFO :: OX (~>) (c->a,b) (c->(a,b))+funFO :: OX dom ran (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' :: OX dom ran (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 :: OX dom ran (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 :: OX dom ran (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 :: OX dom ran (a,b) (b,a) swapO ab = OPair b a where (a,b) = asOPair ab -curryO :: OX (~>) ((a,b)->c) (a->b->c)+curryO :: OX dom ran ((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 :: OX dom ran (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)+wrapO :: (Functor dom, Cofunctor ran) =>+ (b'->b) -> (a->a') -> OX dom ran (a->b) (a'->b')+wrapO outer inner ab = OLambda (fmap inner ia) (cofmap outer ob) where (ia,ob) = asOLambda ab @@ -175,5 +175,3 @@ -- Then we get an elegant definition of @interactRSOut@: -- interactRSOut dflt = wrapO show (readD dflt) interactLine--
src/Interface/TV/Output.hs view
@@ -1,14 +1,16 @@-{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LANGUAGE GADTs, KindSignatures, MultiParamTypeClasses #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- | -- Module : Interface.TV.Output -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : GADTs -- -- Outputs (interfaces) -- means of presenting values ----------------------------------------------------------------------@@ -16,47 +18,48 @@ module Interface.TV.Output ( -- * Output data type- Output(..)+ Output(..), output -- * Output functions- -- ** General- {-, oEmpty-}, oPrim, oLambda, oPair, oCompose, oTitle+ -- ** Builders+ , oPrim, oLambda, oPair, oTitle -- ** Canonicalizers , asOLambda, asOPair+-- -- ** Type specialization+-- , Output', oPrim' ) where -import Control.Arrow +import Control.Compose (Cofunctor(..))+import Data.Pair (Pair(..))+import Data.Lambda (Lambda(..))+import Data.Title (Title_f(..))++ 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+data Output src snk :: * -> * where -- | Output primitive- OPrim :: a ~> () -> Output (~>) a+ OPrim :: snk a -> Output src snk a -- | Visualize a function. Akin to /lambda/- OLambda :: Input (~>) a -> Output (~>) b -> Output (~>) (a->b)+ OLambda :: Input src a -> Output src snk b -> Output src snk (a->b) -- | Visualize a pair- OPair :: Output (~>) a -> Output (~>) b -> Output (~>) (a,b)+ OPair :: Output src snk a -> Output src snk b -> Output src snk (a,b) -- | Massage via an arrow value (like cofmap)- -- OCompose :: a ~> b -> Output (~>) b -> Output (~>) a+ -- OCompose :: src (a -> b) -> Output src snk b -> Output src snk a -- | Title/label an output- OTitle :: String -> Output (~>) a -> Output (~>) a-#endif+ OTitle :: String -> Output src snk a -> Output src snk a --- See 'OEmpty' for note about eliminating OEmpty.+instance Title_f (Output src snk) where title_f = OTitle -instance Show (Output (~>) a) where+instance Show (Output src snk a) where -- show OEmpty = "OEmpty" show (OPrim _) = "(OPrim _)" show (OLambda i o) = "(Lambda "++show i++" "++show o++")"@@ -65,13 +68,24 @@ show (OTitle str o) = "(OTitle "++show str++" "++show o++")" +output :: (Pair src, Pair snk, Lambda src snk, Title_f src, Title_f snk) =>+ Output src snk t -> snk t++output (OPrim rant) = rant+output (OPair a b) = pair (output a) (output b)+output (OLambda i o) = lambda (input i) (output o)+output (OTitle str t) = title_f str (output t)++++ {---------------------------------------------------------- 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)+-- Must be a (possibly titled) pair-style input.+asOLambda :: Output src snk (a->b) -> (Input src a, Output src snk b) asOLambda (OLambda a b) = (a,b) asOLambda (OTitle _ ab) = asOLambda ab asOLambda o = error ("asOLambda of non-OLambda "++show o)@@ -85,7 +99,7 @@ -- where -- (a,b) = asOLambda ab -asOPair :: Output (~>) (a,b) -> (Output (~>) a, Output (~>) b)+asOPair :: Output src snk (a,b) -> (Output src snk a, Output src snk b) asOPair (OPair a b ) = (a,b) asOPair (OTitle _ ab) = asOPair ab asOPair o = error ("asOPair of non-OPair "++show o)@@ -107,40 +121,37 @@ -- 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 :: snk a -> Output src snk a oPrim = OPrim -- | Visualize a function. Akin to /lambda/-oLambda :: Input (~>) a -> Output (~>) b -> Output (~>) (a->b)+oLambda :: Input src a -> Output src snk b -> Output src snk (a->b) oLambda = OLambda -- | Visualize a pair-oPair :: Output (~>) a -> Output (~>) b -> Output (~>) (a,b)+oPair :: Output src snk a -> Output src snk b -> Output src snk (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+instance Pair (Output src snk) where pair = oPair +instance Lambda (Input src) (Output src snk) where lambda = oLambda++ -- | Title (label) an output-oTitle :: String -> Output (~>) a -> Output (~>) a+oTitle :: String -> Output src snk a -> Output src snk a oTitle = OTitle --- | Handy specialization of 'oCompose'-instance Arrow (~>) => Cofunctor (Output (~>)) where- cofmap f input = pure f `oCompose` input++-- I specialized oCompose to cofmapO. I don't think there's enough+-- machinery to do oCompose.++cofmapO :: Cofunctor snk => (a -> b) -> Output src snk b -> Output src snk a+f `cofmapO` OPrim ranb = OPrim (cofmap f ranb)+f `cofmapO` OTitle str ab = OTitle str (f `cofmapO` ab)+_ `cofmapO` o = error ("cofmapO given non-OPrim: "++show o)++instance Cofunctor snk => Cofunctor (Output src snk) where+ cofmap = cofmapO+
src/Interface/TV/Present.hs view
@@ -15,7 +15,7 @@ module Interface.TV.Present (- present, Present(..)+ present, accept, Present(..) ) where import Control.Arrow
src/Interface/TV/Tangible.hs view
@@ -1,14 +1,16 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE Rank2Types, TypeOperators #-}+-- For ghc 6.6 compatibility+-- {-# OPTIONS -fglasgow-exts #-} ---------------------------------------------------------------------- -- | -- Module : Interface.TV.Tangible -- Copyright : (c) Conal Elliott 2006--- License : LGPL+-- License : BSD3 -- -- Maintainer : conal@conal.net -- Stability : experimental--- Portability : portable+-- Portability : Rank2Types -- -- Tangible values -- interface (output) and value, combined & separable ----------------------------------------------------------------------@@ -16,45 +18,52 @@ module Interface.TV.Tangible ( -- * Tangible values- TV, tv, unTv, RunTV, runTV+ TV, TVFun, tv, unTv, RunTV, runTV ) where -import Control.Arrow-import Control.Monad.Identity+import Control.Compose (Id(..),(:*:)(..),(::*::)(..),Flip(..),ToOI(..))+import Data.Pair+import Data.Lambda+import Data.Title -import Data.Tupler+-- import Data.Tupler import Interface.TV.Output-import Interface.TV.Present-import Interface.TV.Misc+import Interface.TV.OFun -- import Control.Arrow.DeepArrow -- import Data.FunArr -- import Interface.TV.OFun -- | Tangible values (TVs).-type TV (~>) a = Pair1 (Output (~>)) Identity a+type TV src snk = Output src snk :*: Id +-- | Arrow on 'TV's+type TVFun src snk = OFun src snk ::*:: (->)++ -- 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+-- newtype TVFun src snk a b = TVFun (Pair2 (OFun src snk) (->) a b) deriving DeepArrow --- instance FunArr (~>) => FunArr (TVFun (~>)) (TV (~>))+-- instance FunArr src snk => FunArr (TVFun src snk) (TV src snk) -- | Make a 'TV'-tv :: Output (~>) a -> a -> TV (~>) a-tv o a = Pair1 (o, return a)+tv :: Output src snk a -> a -> TV src snk a+tv o a = Prod (o, Id a) -- | Dissect a 'TV'-unTv :: TV (~>) a -> (Output (~>) a, a)-unTv (Pair1 (o, ida)) = (o, runIdentity ida)+unTv :: TV src snk a -> (Output src snk a, a)+unTv (Prod (o, ida)) = (o, unId ida) -- | Useful to define disambiguating type-specializations of 'runTV'-type RunTV (~>) = forall a. TV (~>) a -> IO ()+type RunTV src snk = forall a. TV src snk a -> IO () -- | Run a 'TV'-runTV :: (ToIO (~>), Present (~>)) => RunTV (~>)-runTV teevee = toIO (pure (const a) >>> present o)+runTV :: ( Title_f snk, Title_f src+ , Lambda src snk, Pair snk, Pair src+ , ToOI snk) => RunTV src snk+runTV teevee = unFlip (toOI (output o)) a where (o,a) = unTv teevee
+ src/Interface/TV/TestAF.hs view
@@ -0,0 +1,263 @@+{-# OPTIONS -fglasgow-exts #-}++----------------------------------------------------------------------+-- |+-- Module : TestAF+-- Copyright : (c) Conal Elliott 2007+-- License : LGPL+-- +-- Maintainer : conal@conal.net+-- Stability : experimental+-- Portability : GADT+-- +-- Experiments in (applicative) functors for TV+----------------------------------------------------------------------++module TestAF+ (+ + ) where+++import Control.Applicative+import Control.Monad (liftM2)+import Data.Monoid+import Control.Arrow hiding (pure)+import Control.Compose+-- import Control.Instances++import qualified Interface.TV.Present as P (Present(..))++-- | An /Input/ describes a way to obtain a functional value from a user.+-- Used in Output for making function visualizations.+data Input :: (* -> *) -> * -> * where+ -- | Input primitive+ IPrim :: f a -> Input f a+ -- | Input a pair+ IPair :: Input f a -> Input f b -> Input f (a,b)+ -- | Title/label an input+ ITitle :: String -> Input f a -> Input f a++-- | An /Output/ describes a way to present a functional value, perhaps+-- interactively. It is the interface half of a tangible value.+data Output :: (* -> *) -> * -> * -> * where+ -- | Output primitive+ OPrim :: f (a -> o) -> Output f o a+ -- | Visualize a function. Akin to /lambda/+ OLambda :: Input f a -> Output f o b -> Output f o (a->b)+ -- | Visualize a pair+ OPair :: Output f o a -> Output f o b -> Output f o (a,b)+ -- | Title/label an output+ OTitle :: String -> Output f o a -> Output f o a++++ipairA :: Applicative f => f a -> f b -> f (a,b)+ipairA = liftA2 (,)++olambdaA :: Applicative f => f a -> f (b -> o) -> f ((a->b) -> o)+olambdaA = liftA2 (\ a snkb -> \ f -> snkb (f a))++opairA :: (Applicative f, Monoid o) =>+ f (a -> o) -> f (b -> o) -> f ((a,b) -> o)+opairA = liftA2 sinkPair+ where+ sinkPair :: Monoid o => (a -> o) -> (b -> o) -> ((a,b) -> o)+ sinkPair ka kb = \ (a,b) -> ka a `mappend` kb b++-- | 'present' requires a bit of arrow-specific help. For instance, in+-- UIs, pairs are presented horizontally, lambdas vertically, and titles+-- with a labeled box. I'm not really comfortable with this part of the+-- design, especially the specificity of addressing titles here. All of+-- the methods here have do-nothing defaults, so you can simply say+-- @instance Present arr@ for your arrow @arr@.+class Present f where+ presentPair :: f a -> f a+ presentPair = id+ presentLambda :: f a -> f a+ presentLambda = id+ presentTitle :: String -> f a -> f a+ presentTitle _ = id++-- | Convert an 'Input' into an arrow value.+accept :: (Applicative f, Present f) => Input f b -> f b++accept (IPrim p) = p+accept (IPair ia ib) = presentPair $ ipairA (accept ia) (accept ib)+accept (ITitle str i) = presentTitle str $ accept i+++-- | Convert an 'Output' into an arrow value+present :: (Applicative f, Monoid o, Present f) => Output f o a -> f (a -> o)++present (OPrim p) = p+present (OPair oa ob) = presentPair $ opairA (present oa) (present ob)+present (OLambda i o) = presentLambda $ olambdaA (accept i) (present o)+present (OTitle str o) = presentTitle str $ present o+++---- Next, generalize from the particular style of consumer (@f (a -> o)@)++class Pair cof where+ pair :: cof a -> cof b -> cof (a,b)++class Lambda f cof where+ lambda :: f a -> cof b -> cof (a->b)++-- class Cof f cof | cof -> f where+-- lambda :: f a -> cof b -> cof (a->b)+-- pair :: cof a -> cof b -> cof (a, b)+++---- Monads++olambdaM :: Monad m => m a -> (b -> m o) -> ((a->b) -> m o)+olambdaM ioa oib = \ f -> ioa >>= oib . f++opairM :: (Monad m, Monoid o) =>+ (a -> m o) -> (b -> m o) -> ((a,b) -> m o)+opairM coa cob = \ (a,b) -> liftM2 mappend (coa a) (cob b)++-- Repackage 'olambdaA', 'opairA' for use in a 'Lambda' instance.++type CoM m o = Flip (->) (m o)++lamM :: Monad m => m a -> CoM m o b -> CoM m o (a->b)+lamM ioa = inFlip (olambdaM ioa)++pairM :: (Monad m, Monoid o) =>+ CoM m o a -> CoM m o b -> CoM m o (a,b)+pairM = inFlip2 opairM++instance Present f => Present (CoM f o) where+ presentPair = inFlip (presentPair .)+ presentLambda = inFlip (presentLambda .)+ presentTitle str = inFlip (presentTitle str .)++-- Standard instance: replace IO with any monad+instance Monoid o => Pair (CoM IO o) where+ pair = pairM+instance Lambda IO (CoM IO o) where+ lambda = lamM++-- instance Monoid o => Cof IO (CoM IO o) where+-- lambda = lamM+-- pair = pairM+++---- Applicative functors++-- Repackage 'olambdaA', 'opairA' for use in a 'Lambda' instance.++type CoA f o = O f (Flip (->) o)++coA :: Functor f => f (b -> o) -> CoA f o b+coA = O . fmap Flip++unCoA :: Functor f => CoA f o b -> f (b -> o)+unCoA = fmap unFlip . unO++inCoA :: (Functor f, Functor g)+ => (f (a -> o) -> g (b -> p))+ -> (CoA f o a -> CoA g p b)+inCoA f = coA . f . unCoA++inCoA2 :: (Functor f, Functor g, Functor h)+ => (f (a -> o) -> g (b -> p) -> h (c -> q))+ -> (CoA f o a -> CoA g p b -> CoA h q c)+inCoA2 f coa coa' = coA (f (unCoA coa) (unCoA coa'))++-- or+-- inCoA2 f coa = inCoA (f (unCoA coa))+++lamA :: Applicative f => f a -> CoA f o b -> CoA f o (a->b)+lamA fa = inCoA (olambdaA fa)++pairA :: (Applicative f, Monoid o) =>+ CoA f o a -> CoA f o b -> CoA f o (a,b)+pairA = inCoA2 opairA+++instance (Functor f, Present f) => Present (CoA f o) where+ presentPair = inCoA presentPair+ presentLambda = inCoA presentLambda+ presentTitle str = inCoA (presentTitle str)++-- Standard instance: replace [] with any AF, particularly non-monads.+instance Monoid o => Pair (CoA [] o) where+ pair = pairA+instance Lambda [] (CoA [] o) where+ lambda = lamA++-- instance Monoid o => Cof [] (CoA [] o) where+-- lambda = lamA+-- pair = pairA+++---- Arrows++olambdaAr :: (Monoid i, Arrow (~>)) => (i ~> a) -> (b ~> o) -> ((a->b) ~> o)+olambdaAr ia ob = + arr (\ f -> (f, mempty)) >>>+ second ia >>>+ arr (uncurry ($)) >>>+ ob++opairAr :: (Arrow (~>), Monoid o) => (a ~> o) -> (b ~> o) -> ((a,b) ~> o)+opairAr oa ob = (oa *** ob) >>> arr (uncurry mappend)+++-- Repackage 'olambdaAr', 'opairAr' for use in a 'Lambda' instance.++lamAr :: (Monoid i, Arrow (~>)) => (i ~> a) -> Flip (~>) o b -> Flip (~>) o (a->b)+lamAr ia = inFlip (olambdaAr ia)++pairAr :: (Monoid o, Arrow (~>)) =>+ Flip (~>) o a -> Flip (~>) o b -> Flip (~>) o (a,b)+pairAr = inFlip2 opairAr+++instance P.Present (~>) => Present (Flip (~>) o) where+ presentPair = inFlip P.presentPair+ presentLambda = inFlip P.presentLambda+ presentTitle str = inFlip (P.presentTitle str)+++-- Standard instances: replace (->) with any arrow and () and [a] with any monoid+instance Pair (Flip (->) [a]) where+ pair = pairAr+instance Lambda ((->) ()) (Flip (->) [a]) where+ lambda = lamAr++-- instance Cof ((->) ()) (Flip (->) [a]) where+-- lambda = lamAr+-- pair = pairAr+++-- The type packaging used in CoM & CoA (Flip and O) complicate the+-- definitions. Maybe type-indexed synonyms (not yet implemented) will+-- eliminate them.++++-- | Alternative to 'Output'+data Output' :: (* -> *) -> (* -> *) -> (* -> *) where+ -- | Output primitive+ OPrim' :: cof a -> Output' f cof a+ -- | Visualize a function. Akin to /lambda/+ OLambda' :: Input f a -> Output' f cof b -> Output' f cof (a->b)+ -- | Visualize a pair+ OPair' :: Output' f cof a -> Output' f cof b -> Output' f cof (a,b)+ -- | Title/label an output+ OTitle' :: String -> Output' f cof a -> Output' f cof a++-- | Convert an 'Output' into an arrow value+present' :: (Applicative f, Pair cof, Lambda f cof, Present f, Present cof) =>+ Output' f cof a -> cof a++present' (OPrim' p) = p+present' (OPair' oa ob) = presentPair $ pair (present' oa) (present' ob)+present' (OLambda' i o) = presentLambda $ lambda (accept i) (present' o)+present' (OTitle' str o) = presentTitle str $ present' o+
src/Interface/TV/UI.hs view
@@ -31,7 +31,7 @@ import Interface.TV.Present (Present(..)) import Interface.TV.Common (CommonInsOuts(..)) import Interface.TV.Tangible (RunTV,runTV)-import Interface.TV.Misc (ToIO(..))+-- import Interface.TV.Misc (ToIO(..)) {----------------------------------------------------------