diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,2 @@ +Version 0.1.1: +* Changed all files to *nix-style line endings. diff --git a/DeepArrow.cabal b/DeepArrow.cabal --- a/DeepArrow.cabal +++ b/DeepArrow.cabal @@ -1,49 +1,49 @@ -Name: DeepArrow -Version: 0.0 -Synopsis: Arrows for "deep application" -Category: Composition -Description: - This library provides a framework for type-directed composition of value - editors (non-syntactic transformations). The tools enable \"deep function - application\" in two senses: deep application of functions and - application of deep functions. These tools generalize beyond values and - functions, via the @DeepArrow@ subclass of the @Arrow@ type class. - . - For more information see: - . - * The project wiki page - . - * Application of deep arrows for composable interfaces in the TV library: - - . - * The motivating idea and paper "Functional Programming by Interacting - with Tangible Values": - . - 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! - . - The primary module is "Control.Arrow.DeepArrow". Examples in - "Control.Arrow.DeepArrow.Examples". - . - /Note/: Many of the type signatures use infix type operators (as in - @a~>b@), a recent extension to GHC. In reading the documentation and - code, be aware that infix operators bind more tightly than @->@. - . - © 2007 by Conal Elliott (); BSD3 license. -Author: Conal Elliott -Maintainer: conal@conal.net -Homepage: http://haskell.org/haskellwiki/DeepArrow -Package-Url: http://darcs.haskell.org/packages/DeepArrow -License: BSD3 -Stability: experimental -Copyright: (c) 2007 by Conal Elliott -Hs-Source-Dirs: src -Build-Depends: base, mtl -Extensions: CPP, UndecidableInstances -Exposed-Modules: - Control.Arrow.DeepArrow - Data.Tupler - Data.FunArr - Control.Arrow.DeepArrow.Examples -ghc-options: -O -Wall +Name: DeepArrow +Version: 0.0.1 +Synopsis: Arrows for "deep application" +Category: Composition +Description: + This library provides a framework for type-directed composition of value + editors (non-syntactic transformations). The tools enable \"deep function + application\" in two senses: deep application of functions and + application of deep functions. These tools generalize beyond values and + functions, via the @DeepArrow@ subclass of the @Arrow@ type class. + . + For more information see: + . + * The project wiki page + . + * Application of deep arrows for composable interfaces in the TV library: + + . + * The motivating idea and paper "Functional Programming by Interacting + with Tangible Values": + . + 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! + . + The primary module is "Control.Arrow.DeepArrow". Examples in + "Control.Arrow.DeepArrow.Examples". + . + /Note/: Many of the type signatures use infix type operators (as in + @a~>b@), a recent extension to GHC. In reading the documentation and + code, be aware that infix operators bind more tightly than @->@. + . + © 2007 by Conal Elliott (); BSD3 license. +Author: Conal Elliott +Maintainer: conal@conal.net +Homepage: http://haskell.org/haskellwiki/DeepArrow +Package-Url: http://darcs.haskell.org/packages/DeepArrow +License: BSD3 +Stability: experimental +Copyright: (c) 2007 by Conal Elliott +Hs-Source-Dirs: src +Build-Depends: base, mtl +Extensions: CPP, UndecidableInstances +Exposed-Modules: + Control.Arrow.DeepArrow + Data.Tupler + Data.FunArr + Control.Arrow.DeepArrow.Examples +ghc-options: -O -Wall diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,12 +1,12 @@ -# See README for Cabal-based building. Other fancy stuff (like haddock) here. - -user = conal -package = DeepArrow - -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 \ - # enough, already! - -include ../my-cabal-make.inc +# See README for Cabal-based building. Other fancy stuff (like haddock) here. + +user = conal + +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 \ + $(source_args)\ + $(comments_args)\ + " + +include ../my-cabal-make.inc diff --git a/README b/README --- a/README +++ b/README @@ -1,14 +1,14 @@ -This library provides a framework for type-directed composition of value -editors. For a fuller description and link to documentation, please see -the Haskell wiki page: - - http://haskell.org/haskellwiki/DeepArrow - -You can configure, build, and install all in the usual way with Cabal -commands. - - runhaskell Setup.lhs configure - runhaskell Setup.lhs build - runhaskell Setup.lhs install - -See src/Control/Arrow/DeepArrow/Examples.hs for examples. +The DeepArrow library provides a framework for type-directed composition +of value editors. For a fuller description and link to documentation, +please see the Haskell wiki page: + + http://haskell.org/haskellwiki/DeepArrow + +You can configure, build, and install all in the usual way with Cabal +commands. + + runhaskell Setup.lhs configure + runhaskell Setup.lhs build + runhaskell Setup.lhs install + +See src/Control/Arrow/DeepArrow/Examples.hs for examples. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ -#!/usr/bin/env runhaskell -> import Distribution.Simple +#!/usr/bin/env runhaskell +> import Distribution.Simple > main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO diff --git a/src/Control/Arrow/DeepArrow.hs b/src/Control/Arrow/DeepArrow.hs --- a/src/Control/Arrow/DeepArrow.hs +++ b/src/Control/Arrow/DeepArrow.hs @@ -1,247 +1,247 @@ -{-# OPTIONS -fglasgow-exts #-} - ----------------------------------------------------------------------- --- | --- Module : Control.Arrow.DeepArrow --- Copyright : (c) Conal Elliott 2006 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- \"Deep arrows\" as an 'Arrow' subclass. ----------------------------------------------------------------------- - -module Control.Arrow.DeepArrow - ( - -- * The DeepArrow class - DeepArrow(..) - -- * Composable function extractors - , funFirst, funSecond, funResult - -- * Composable input extractors - , inpF, inpS, inpFirst, inpSecond - -- * Misc functions - , flipA, unzipA - -- * Some utilities - , (->|) - ) where - -import Control.Arrow - -import Data.Tupler (Pair2(..)) -import Data.FunArr - - -{---------------------------------------------------------- - The "deep arrow class" -----------------------------------------------------------} - -{- | - -Arrows for deep application. Most of these methods could be defined -using 'arr', but 'arr' is not definable for some types. If your -'DeepArrow' instance has 'arr', you might want to use these -implementations - -@ - 'idA' = 'arr' 'id' - 'fstA' = 'arr' 'fst' - 'dupA' = 'arr' (\\ x -> (x,x)) - 'sndA' = 'arr' 'snd' - 'funF' = 'arr' (\\ (f,b) -> \\ c -> (f c, b)) - 'funS' = 'arr' (\\ (a,f) -> \\ c -> (a, f c)) - 'funR' = 'arr' 'flip' - 'curryA' = 'arr' 'curry' - 'uncurryA' = 'arr' 'uncurry' - 'swapA' = 'arr' (\\ (a,b) -> (b,a)) - 'lAssocA' = 'arr' (\\ (a,(b,c)) -> ((a,b),c)) - 'rAssocA' = 'arr' (\\ ((a,b),c) -> (a,(b,c))) -@ - -If your 'DeepArrow' instance /does not/ have 'arr', you'll have to come up -with other definitions. In any case, I recommend the following -definitions, which mirror 'Arrow' defaults while avoiding 'arr'. Be sure -also to define 'arr' or 'pure' to yield an error message (rather than -ping-ponging infinitely between them via the 'Arrow' default definitions). - -@ - 'second' f = 'swapA' '>>>' 'first' f '>>>' 'swapA' - f '&&&' g = 'dupA' '>>>' f '***' g -@ - -In a few cases, there are default methods, as noted below. The -defaults do not use 'arr'. - --} - -class Arrow (~>) => DeepArrow (~>) where - -- | Apply arrow in a function's result. Analogous to 'first' and - -- 'second'. - result :: (b ~> b') -> ((a->b) ~> (a->b')) - -- Complicates OFun considerably and not used. - -- Apply arrow in a function's argument. Note contravariance. - -- argument :: (a' ~> a ) -> ((a->b) ~> (a'->b)) - -- | Identity. - idA :: a ~> a - -- | Duplicate. - dupA :: a ~> (a,a) - -- | Extract first. - fstA :: (a,b) ~> a - -- | Extract second. - sndA :: (a,b) ~> b - -- | Extract function from first element. - funF :: (c->a, b) ~> (c->(a,b)) - -- | Extract function from second element. - funS :: (a, c->b) ~> (c->(a,b)) -- Could default via swapA & funF - -- | Extract function from result. - funR :: (a->c->b) ~> (c->a->b) - -- | Curry arrow. - curryA :: ((a,b)->c) ~> (a->b->c) - -- | Uncurry arrow. - uncurryA :: (a->b->c) ~> ((a,b)->c) - -- | Swap elements. Has default. - swapA :: (a,b) ~> (b,a) - swapA = sndA &&& fstA - -- | Left-associate. Has default. - lAssocA :: (a,(b,c)) ~> ((a,b),c) - lAssocA = (idA***fstA) &&& (sndA>>>sndA) - -- | Right-associate. Has default. - rAssocA :: ((a,b),c) ~> (a,(b,c)) - rAssocA = (fstA>>>fstA) &&& (sndA *** idA) - -- I don't think this one is used. - -- composeA :: Arrow (~~>) => (a ~~> b, b ~~> c) ~> (a ~~>c) - -- composeA = arr (uncurry (>>>)) - - -{---------------------------------------------------------- - Composable function extractors -----------------------------------------------------------} - --- | Promote a function extractor into one that reaches into the first --- element of a pair. -funFirst :: DeepArrow (~>) => (d ~> (c->a)) -> ((d, b) ~> (c->(a, b))) - --- | Promote a function extractor into one that reaches into the second --- element of a pair. -funSecond :: DeepArrow (~>) => (d ~> (c->b)) -> ((a, d) ~> (c->(a, b))) - --- | Promote a function extractor into one that reaches into the result --- element of a function. -funResult :: DeepArrow (~>) => (d ~> (c->b)) -> ((a->d) ~> (c->(a->b))) - -funFirst h = first h >>> funF -funSecond h = second h >>> funS -funResult h = result h >>> funR - - -{---------------------------------------------------------- - Composable input extractors -----------------------------------------------------------} - --- | Extract the first component of a pair input. -inpF :: DeepArrow (~>) => ((a,b) -> c) ~> (a -> (b->c)) -inpF = curryA - --- | Extract the second component of a pair input. -inpS :: DeepArrow (~>) => ((a,b) -> c) ~> (b -> (a->c)) -inpS = curryA >>> flipA - - --- Given a way to extract a @d@ input from an @a@ input, leaving an @a'@ --- residual input, 'inpFirst' yields a way to extract a @d@ input from an --- @(a,b)@ input, leaving an @(a',b)@ residual input. -inpFirst :: DeepArrow (~>) => - (( a ->c) ~> (d -> ( a' ->c))) - -> (((a,b)->c) ~> (d -> ((a',b)->c))) - --- Analogous to 'inpFirst'. -inpSecond :: DeepArrow (~>) => - (( b ->c) ~> (d -> ( b' ->c))) - -> (((a,b)->c) ~> (d -> ((a,b')->c))) - - --- See ICFP submission for the derivation of inpFirst and inpSecond - -inpFirst h = curryA >>> flipA >>> result h >>> flipA >>> - result (flipA>>>uncurryA) - -inpSecond h = curryA >>> result h >>> flipA >>> - result uncurryA - - -{---------------------------------------------------------- - Misc functions -----------------------------------------------------------} - --- | Flip argument order -flipA :: DeepArrow (~>) => (a->c->b) ~> (c->a->b) -flipA = funR - --- | Like 'unzip' but for 'DeepArrow' arrows instead of lists. -unzipA :: DeepArrow (~>) => (a ~> (b,c)) -> (a ~> b, a ~> c) -unzipA f = (f >>> fstA, f >>> sndA) - - -{---------------------------------------------------------- - Some 'DeepArrow' instances -----------------------------------------------------------} - -instance DeepArrow (->) where - result = (.) - -- argument = flip (.) - -- Since (->) implements 'arr', use the recommended defaults for the rest. - idA = arr id - fstA = arr fst - dupA = arr (\x->(x,x)) - sndA = arr snd - funF = arr (\ (f,b) -> \ c -> (f c, b)) - funS = arr (\ (a,f) -> \ c -> (a, f c)) - funR = arr flip - curryA = arr curry - uncurryA = arr uncurry - swapA = arr (\ (a,b) -> (b,a)) - lAssocA = arr (\ (a,(b,c)) -> ((a,b),c)) - rAssocA = arr (\ ((a,b),c) -> (a,(b,c))) - - --- Arrow "pairs" are arrows -instance (Arrow f, Arrow f') => Arrow (Pair2 f f') where - arr h = Pair2 (arr h , arr h ) - Pair2 (f,f') >>> Pair2 (g,g') = Pair2 (f>>>g , f'>>>g' ) - first (Pair2 (f,f')) = Pair2 (first f , first f' ) - second (Pair2 (f,f')) = Pair2 (second f, second f') - Pair2 (f,f') *** Pair2 (g,g') = Pair2 (f***g , f'***g' ) - Pair2 (f,f') &&& Pair2 (g,g') = Pair2 (f&&&g , f'&&&g' ) - --- and DeepArrow "pairs" are deep arrows - -instance (DeepArrow ar, DeepArrow ar') => DeepArrow (Pair2 ar ar') where - idA = Pair2 (idA, idA) - dupA = Pair2 (dupA, dupA) - fstA = Pair2 (fstA, fstA) - sndA = Pair2 (sndA, sndA) - funF = Pair2 (funF, funF) - funS = Pair2 (funS, funS) - funR = Pair2 (funR, funR) - curryA = Pair2 (curryA, curryA) - uncurryA = Pair2 (uncurryA, uncurryA) - swapA = Pair2 (swapA, swapA) - lAssocA = Pair2 (lAssocA, lAssocA) - rAssocA = Pair2 (rAssocA, rAssocA) - - result (Pair2 (f,f')) = Pair2 (result f, result f') - - -- composeA = Pair2 (composeA, composeA) - -- argument (Pair2 (f,f')) = Pair2 (argument f, argument f') - - -{---------------------------------------------------------- - Some utilities -----------------------------------------------------------} - --- | Compose wrapped functions -(->|) :: (DeepArrow (~>), FunArr (~>) w) => - w (a->b) -> w (b->c) -> w (a->c) -(->|) f g = result (toArr g) $$ f - +{-# OPTIONS -fglasgow-exts #-} + +---------------------------------------------------------------------- +-- | +-- Module : Control.Arrow.DeepArrow +-- Copyright : (c) Conal Elliott 2006 +-- License : LGPL +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- Portability : portable +-- +-- \"Deep arrows\" as an 'Arrow' subclass. +---------------------------------------------------------------------- + +module Control.Arrow.DeepArrow + ( + -- * The DeepArrow class + DeepArrow(..) + -- * Composable function extractors + , funFirst, funSecond, funResult + -- * Composable input extractors + , inpF, inpS, inpFirst, inpSecond + -- * Misc functions + , flipA, unzipA + -- * Some utilities + , (->|) + ) where + +import Control.Arrow + +import Data.Tupler (Pair2(..)) +import Data.FunArr + + +{---------------------------------------------------------- + The "deep arrow class" +----------------------------------------------------------} + +{- | + +Arrows for deep application. Most of these methods could be defined +using 'arr', but 'arr' is not definable for some types. If your +'DeepArrow' instance has 'arr', you might want to use these +implementations + +@ + 'idA' = 'arr' 'id' + 'fstA' = 'arr' 'fst' + 'dupA' = 'arr' (\\ x -> (x,x)) + 'sndA' = 'arr' 'snd' + 'funF' = 'arr' (\\ (f,b) -> \\ c -> (f c, b)) + 'funS' = 'arr' (\\ (a,f) -> \\ c -> (a, f c)) + 'funR' = 'arr' 'flip' + 'curryA' = 'arr' 'curry' + 'uncurryA' = 'arr' 'uncurry' + 'swapA' = 'arr' (\\ (a,b) -> (b,a)) + 'lAssocA' = 'arr' (\\ (a,(b,c)) -> ((a,b),c)) + 'rAssocA' = 'arr' (\\ ((a,b),c) -> (a,(b,c))) +@ + +If your 'DeepArrow' instance /does not/ have 'arr', you'll have to come up +with other definitions. In any case, I recommend the following +definitions, which mirror 'Arrow' defaults while avoiding 'arr'. Be sure +also to define 'arr' or 'pure' to yield an error message (rather than +ping-ponging infinitely between them via the 'Arrow' default definitions). + +@ + 'second' f = 'swapA' '>>>' 'first' f '>>>' 'swapA' + f '&&&' g = 'dupA' '>>>' f '***' g +@ + +In a few cases, there are default methods, as noted below. The +defaults do not use 'arr'. + +-} + +class Arrow (~>) => DeepArrow (~>) where + -- | Direct arrow into a function's result. Analogous to 'first' and + -- 'second'. + result :: (b ~> b') -> ((a->b) ~> (a->b')) + -- Complicates OFun considerably and not used. + -- Direct arrow into a function's argument. Note contravariance. + -- argument :: (a' ~> a ) -> ((a->b) ~> (a'->b)) + -- | Identity. + idA :: a ~> a + -- | Duplicate. + dupA :: a ~> (a,a) + -- | Extract first. + fstA :: (a,b) ~> a + -- | Extract second. + sndA :: (a,b) ~> b + -- | Extract function from first element. + funF :: (c->a, b) ~> (c->(a,b)) + -- | Extract function from second element. + funS :: (a, c->b) ~> (c->(a,b)) -- Could default via swapA & funF + -- | Extract function from result. + funR :: (a->c->b) ~> (c->a->b) + -- | Curry arrow. + curryA :: ((a,b)->c) ~> (a->b->c) + -- | Uncurry arrow. + uncurryA :: (a->b->c) ~> ((a,b)->c) + -- | Swap elements. Has default. + swapA :: (a,b) ~> (b,a) + swapA = sndA &&& fstA + -- | Left-associate. Has default. + lAssocA :: (a,(b,c)) ~> ((a,b),c) + lAssocA = (idA***fstA) &&& (sndA>>>sndA) + -- | Right-associate. Has default. + rAssocA :: ((a,b),c) ~> (a,(b,c)) + rAssocA = (fstA>>>fstA) &&& (sndA *** idA) + -- I don't think this one is used. + -- composeA :: Arrow (~~>) => (a ~~> b, b ~~> c) ~> (a ~~>c) + -- composeA = arr (uncurry (>>>)) + + +{---------------------------------------------------------- + Composable function extractors +----------------------------------------------------------} + +-- | Promote a function extractor into one that reaches into the first +-- element of a pair. +funFirst :: DeepArrow (~>) => (d ~> (c->a)) -> ((d, b) ~> (c->(a, b))) + +-- | Promote a function extractor into one that reaches into the second +-- element of a pair. +funSecond :: DeepArrow (~>) => (d ~> (c->b)) -> ((a, d) ~> (c->(a, b))) + +-- | Promote a function extractor into one that reaches into the result +-- element of a function. +funResult :: DeepArrow (~>) => (d ~> (c->b)) -> ((a->d) ~> (c->(a->b))) + +funFirst h = first h >>> funF +funSecond h = second h >>> funS +funResult h = result h >>> funR + + +{---------------------------------------------------------- + Composable input extractors +----------------------------------------------------------} + +-- | Extract the first component of a pair input. +inpF :: DeepArrow (~>) => ((a,b) -> c) ~> (a -> (b->c)) +inpF = curryA + +-- | Extract the second component of a pair input. +inpS :: DeepArrow (~>) => ((a,b) -> c) ~> (b -> (a->c)) +inpS = curryA >>> flipA + + +-- Given a way to extract a @d@ input from an @a@ input, leaving an @a'@ +-- residual input, 'inpFirst' yields a way to extract a @d@ input from an +-- @(a,b)@ input, leaving an @(a',b)@ residual input. +inpFirst :: DeepArrow (~>) => + (( a ->c) ~> (d -> ( a' ->c))) + -> (((a,b)->c) ~> (d -> ((a',b)->c))) + +-- Analogous to 'inpFirst'. +inpSecond :: DeepArrow (~>) => + (( b ->c) ~> (d -> ( b' ->c))) + -> (((a,b)->c) ~> (d -> ((a,b')->c))) + + +-- See ICFP submission for the derivation of inpFirst and inpSecond + +inpFirst h = curryA >>> flipA >>> result h >>> flipA >>> + result (flipA>>>uncurryA) + +inpSecond h = curryA >>> result h >>> flipA >>> + result uncurryA + + +{---------------------------------------------------------- + Misc functions +----------------------------------------------------------} + +-- | Flip argument order +flipA :: DeepArrow (~>) => (a->c->b) ~> (c->a->b) +flipA = funR + +-- | Like 'unzip' but for 'DeepArrow' arrows instead of lists. +unzipA :: DeepArrow (~>) => (a ~> (b,c)) -> (a ~> b, a ~> c) +unzipA f = (f >>> fstA, f >>> sndA) + + +{---------------------------------------------------------- + Some 'DeepArrow' instances +----------------------------------------------------------} + +instance DeepArrow (->) where + result = (.) + -- argument = flip (.) + -- Since (->) implements 'arr', use the recommended defaults for the rest. + idA = arr id + fstA = arr fst + dupA = arr (\x->(x,x)) + sndA = arr snd + funF = arr (\ (f,b) -> \ c -> (f c, b)) + funS = arr (\ (a,f) -> \ c -> (a, f c)) + funR = arr flip + curryA = arr curry + uncurryA = arr uncurry + swapA = arr (\ (a,b) -> (b,a)) + lAssocA = arr (\ (a,(b,c)) -> ((a,b),c)) + rAssocA = arr (\ ((a,b),c) -> (a,(b,c))) + + +-- Arrow "pairs" are arrows +instance (Arrow f, Arrow f') => Arrow (Pair2 f f') where + arr h = Pair2 (arr h , arr h ) + Pair2 (f,f') >>> Pair2 (g,g') = Pair2 (f>>>g , f'>>>g' ) + first (Pair2 (f,f')) = Pair2 (first f , first f' ) + second (Pair2 (f,f')) = Pair2 (second f, second f') + Pair2 (f,f') *** Pair2 (g,g') = Pair2 (f***g , f'***g' ) + Pair2 (f,f') &&& Pair2 (g,g') = Pair2 (f&&&g , f'&&&g' ) + +-- and DeepArrow "pairs" are deep arrows + +instance (DeepArrow ar, DeepArrow ar') => DeepArrow (Pair2 ar ar') where + idA = Pair2 (idA, idA) + dupA = Pair2 (dupA, dupA) + fstA = Pair2 (fstA, fstA) + sndA = Pair2 (sndA, sndA) + funF = Pair2 (funF, funF) + funS = Pair2 (funS, funS) + funR = Pair2 (funR, funR) + curryA = Pair2 (curryA, curryA) + uncurryA = Pair2 (uncurryA, uncurryA) + swapA = Pair2 (swapA, swapA) + lAssocA = Pair2 (lAssocA, lAssocA) + rAssocA = Pair2 (rAssocA, rAssocA) + + result (Pair2 (f,f')) = Pair2 (result f, result f') + + -- composeA = Pair2 (composeA, composeA) + -- argument (Pair2 (f,f')) = Pair2 (argument f, argument f') + + +{---------------------------------------------------------- + Some utilities +----------------------------------------------------------} + +-- | Compose wrapped functions +(->|) :: (DeepArrow (~>), FunArr (~>) w) => + w (a->b) -> w (b->c) -> w (a->c) +(->|) f g = result (toArr g) $$ f + diff --git a/src/Control/Arrow/DeepArrow/Examples.hs b/src/Control/Arrow/DeepArrow/Examples.hs --- a/src/Control/Arrow/DeepArrow/Examples.hs +++ b/src/Control/Arrow/DeepArrow/Examples.hs @@ -1,91 +1,91 @@ -{-# OPTIONS -fglasgow-exts #-} - ----------------------------------------------------------------------- --- | --- Module : Examples --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- DeepArrow examples. --- --- The types in the source code are formatted for easier reading. ----------------------------------------------------------------------- - -module Control.Arrow.DeepArrow.Examples - ( - -- * Deep application - deep - -- * Function extraction - , extF - -- * Input etraction - , extI, extFI - ) where - -import Control.Arrow -import Control.Arrow.DeepArrow - - -{---------------------------------------------------------- - Deep application -----------------------------------------------------------} - --- | Given a value of type @(a -> (f,b -> (c,g)),e)@, apply a function to --- just the @c@ part and leave the rest intact. --- --- @deep = 'first' . 'result' . 'second' . 'result' . 'first' @ -deep :: DeepArrow (~>) => (c ~> c') -> - (a -> (f,b -> (c ,g)),e) - ~> (a -> (f,b -> (c',g)),e) -deep = first.result.second.result.first - - - -{---------------------------------------------------------- - Function extraction -----------------------------------------------------------} - --- | Given a way to extract a function from a @d@ value, create a way to --- extract a function from a @(e -> (a,d), f)@ value. --- --- @extF = 'funFirst' . 'funResult' . 'funSecond'@ - -extF :: DeepArrow (~>) => (d ~> (c -> b)) -> - (e -> (a,d), f) - ~> (c -> (e -> (a,b), f)) -extF = funFirst.funResult.funSecond - --- | To make an extractor, simply apply the extractor-transformer 'extF' --- to the identity arrow. --- --- @'extFF' = 'extF' 'idA'@ -extFF :: DeepArrow (~>) => - (e -> (a,(c-> b)),f) - ~> (c -> (e -> (a, b),f)) -extFF = extF idA - - -{---------------------------------------------------------- - Input extraction -----------------------------------------------------------} - --- | Extract a @b@ input from a @((a,(b,e)),c)@ argument. --- --- @extI = ('inpFirst' . 'inpSecond') 'inpF'@ -extI :: DeepArrow (~>) => - ( ((a,(b,e)),c) -> d) - ~> (b -> ((a, e ),c) -> d) -extI = (inpFirst.inpSecond) inpF - - --- | Typically, we will have to combine function and input extractors. --- For instance, combine 'extF' and 'extI'. --- --- @extFI = 'extF' 'extI'@ -extFI :: DeepArrow (~>) => - (e -> (g,(((a,(b,e)),c) -> d)), f) - ~> (b -> (e -> (g,(((a, e) ,c) -> d)), f)) -extFI = extF extI +{-# OPTIONS -fglasgow-exts #-} + +---------------------------------------------------------------------- +-- | +-- Module : Control.Arrow.DeepArrow.Examples +-- Copyright : (c) Conal Elliott 2007 +-- License : LGPL +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- Portability : portable +-- +-- DeepArrow examples. +-- +-- The types in the source code are formatted for easier reading. +---------------------------------------------------------------------- + +module Control.Arrow.DeepArrow.Examples + ( + -- * Deep application + deep + -- * Function extraction + , extF, extFF + -- * Input etraction + , extI, extFI + ) where + +import Control.Arrow +import Control.Arrow.DeepArrow + + +{---------------------------------------------------------- + Deep application +----------------------------------------------------------} + +-- | Given a value of type @(a -> (f,b -> (c,g)),e)@, apply a function to +-- just the @c@ part and leave the rest intact. +-- +-- @deep = 'first' . 'result' . 'second' . 'result' . 'first' @ +deep :: DeepArrow (~>) => (c ~> c') -> + (a -> (f,b -> (c ,g)),e) + ~> (a -> (f,b -> (c',g)),e) +deep = first.result.second.result.first + + + +{---------------------------------------------------------- + Function extraction +----------------------------------------------------------} + +-- | Given a way to extract a function from a @d@ value, create a way to +-- extract a function from a @(e -> (a,d), f)@ value. +-- +-- @extF = 'funFirst' . 'funResult' . 'funSecond'@ + +extF :: DeepArrow (~>) => (d ~> (c -> b)) -> + (e -> (a,d), f) + ~> (c -> (e -> (a,b), f)) +extF = funFirst.funResult.funSecond + +-- | To make an extractor, simply apply the extractor-transformer 'extF' +-- to the identity arrow. +-- +-- @'extFF' = 'extF' 'idA'@ +extFF :: DeepArrow (~>) => + (e -> (a,(c-> b)),f) + ~> (c -> (e -> (a, b),f)) +extFF = extF idA + + +{---------------------------------------------------------- + Input extraction +----------------------------------------------------------} + +-- | Extract a @b@ input from a @((a,(b,e)),c)@ argument. +-- +-- @extI = ('inpFirst' . 'inpSecond') 'inpF'@ +extI :: DeepArrow (~>) => + ( ((a,(b,e)),c) -> d) + ~> (b -> ((a, e ),c) -> d) +extI = (inpFirst.inpSecond) inpF + + +-- | Typically, we will have to combine function and input extractors. +-- For instance, combine 'extF' and 'extI'. +-- +-- @extFI = 'extF' 'extI'@ +extFI :: DeepArrow (~>) => + (e -> (g,(((a,(b,e)),c) -> d)), f) + ~> (b -> (e -> (g,(((a, e) ,c) -> d)), f)) +extFI = extF extI diff --git a/src/Data/FunArr.hs b/src/Data/FunArr.hs --- a/src/Data/FunArr.hs +++ b/src/Data/FunArr.hs @@ -1,53 +1,53 @@ -{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} - ----------------------------------------------------------------------- --- | --- Module : Data.FunArr --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- Conversion between arrow values and wrapped functions. ----------------------------------------------------------------------- - -module Data.FunArr - ( - FunArr(..), wapl - ) where - -import Control.Monad.Identity -import Data.Tupler - -infixr 0 $$ -- FunArr application - --- | Convert between an arrow value and a \"wrapped function\". The \"arrow\" --- doesn't really have to be an arrow. I'd appreciate ideas for names & --- uses. -class FunArr (~>) w | (~>)->w, w->(~>) where - -- | Convert a @w@-wrapped function to an arrow value - toArr :: w (a->b) -> (a ~> b) - -- | Apply an arrow to a @w@-wrapped value - ($$) :: (a ~> b) -> w a -> w b - --- | Apply a wrapped function to a wrapped value -wapl :: FunArr (~>) w => w (a->b) -> w a -> w b -wapl f a = toArr f $$ a - --- Function/Id instance -instance FunArr (->) Identity where - toArr = runIdentity - f $$ ida = return (f (runIdentity ida)) - -- ($$) f = return . f . runIdentity - --- The following instance violates the "coverage condition" and so --- requires -fallow-undecidable-instances. - -instance (FunArr ar w, FunArr ar' w') - => FunArr (Pair2 ar ar') (Pair1 w w') where - toArr (Pair1 (f,f')) = Pair2 (toArr f, toArr f') - Pair2 (f,f') $$ Pair1 (w,w') = Pair1 (f $$ w, f' $$ w') - - +{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} + +---------------------------------------------------------------------- +-- | +-- Module : Data.FunArr +-- Copyright : (c) Conal Elliott 2007 +-- License : LGPL +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- Portability : portable +-- +-- Conversion between arrow values and wrapped functions. +---------------------------------------------------------------------- + +module Data.FunArr + ( + FunArr(..), wapl + ) where + +import Control.Monad.Identity +import Data.Tupler + +infixr 0 $$ -- FunArr application + +-- | Convert between an arrow value and a \"wrapped function\". The \"arrow\" +-- doesn't really have to be an arrow. I'd appreciate ideas for names & +-- uses. +class FunArr (~>) w | (~>)->w, w->(~>) where + -- | Convert a @w@-wrapped function to an arrow value + toArr :: w (a->b) -> (a ~> b) + -- | Apply an arrow to a @w@-wrapped value + ($$) :: (a ~> b) -> w a -> w b + +-- | Apply a wrapped function to a wrapped value +wapl :: FunArr (~>) w => w (a->b) -> w a -> w b +wapl f a = toArr f $$ a + +-- Function/Id instance +instance FunArr (->) Identity where + toArr = runIdentity + f $$ ida = return (f (runIdentity ida)) + -- ($$) f = return . f . runIdentity + +-- The following instance violates the "coverage condition" and so +-- requires -fallow-undecidable-instances. + +instance (FunArr ar w, FunArr ar' w') + => FunArr (Pair2 ar ar') (Pair1 w w') where + toArr (Pair1 (f,f')) = Pair2 (toArr f, toArr f') + Pair2 (f,f') $$ Pair1 (w,w') = Pair1 (f $$ w, f' $$ w') + + diff --git a/src/Data/Tupler.hs b/src/Data/Tupler.hs --- a/src/Data/Tupler.hs +++ b/src/Data/Tupler.hs @@ -1,66 +1,66 @@ -{-# OPTIONS -fglasgow-exts #-} - ----------------------------------------------------------------------- --- | --- Module : Data.Tupler --- Copyright : (c) Conal Elliott 2007 --- License : LGPL --- --- Maintainer : conal@conal.net --- Stability : experimental --- Portability : portable --- --- The tuple type constructors (i.e., (,), (,,), etc) are to value types, --- as the /tupler/ type constructors are to type constructors. ----------------------------------------------------------------------- - -module Data.Tupler - ( - Pair1(..), Pair2(..) - ) where - - -import Data.Typeable -- or AltData.Typeable ? - --- | Pairing for unary type constructors. -newtype Pair1 f g a = Pair1 {unPair1 :: (f a, g a)} - deriving (Eq, Ord, Show) - -instance (Typeable1 f, Typeable1 g) => Typeable1 (Pair1 f g) where - typeOf1 = const $ mkTyConApp (mkTyCon tyConStr) [] - where - tyConStr = "Data.Tupler.Pair1" - ++ tcStringSP (undefined :: f Bool) - ++ tcStringSP (undefined :: g Bool) - --- | Pairing for binary type constructors. -newtype Pair2 f g a b = Pair2 {unPair2 :: (f a b, g a b)} - deriving (Eq, Ord, Show) - -instance (Typeable2 f, Typeable2 g) => Typeable2 (Pair2 f g) where - typeOf2 = const $ mkTyConApp (mkTyCon tyConStr) [] - where - tyConStr = "Data.Tupler.Pair2" - ++ tcStringSP (undefined :: f Bool Bool) - ++ tcStringSP (undefined :: g Bool Bool) - - ----- Misc - --- | Disambuating hack for a function argument. Wrap parens around a string --- if it contains a space. -parensIfSpace :: String -> String -parensIfSpace str | ' ' `elem` str = "("++str++")" - | otherwise = str - --- | Extract the type constructor as a string -tcString :: Typeable a => a -> String -tcString = tyConString . typeRepTyCon . typeOf - --- | 'tcString' with disambiguating optional parens -tcStringP :: Typeable a => a -> String -tcStringP = parensIfSpace . tcString - --- | 'tcString' with leading space and optional parens -tcStringSP :: Typeable a => a -> String -tcStringSP = (' ':) . tcStringP +{-# OPTIONS -fglasgow-exts #-} + +---------------------------------------------------------------------- +-- | +-- Module : Data.Tupler +-- Copyright : (c) Conal Elliott 2007 +-- License : LGPL +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- Portability : portable +-- +-- The tuple type constructors (i.e., (,), (,,), etc) are to value types, +-- as the /tupler/ type constructors are to type constructors. +---------------------------------------------------------------------- + +module Data.Tupler + ( + Pair1(..), Pair2(..) + ) where + + +import Data.Typeable -- or AltData.Typeable ? + +-- | Pairing for unary type constructors. +newtype Pair1 f g a = Pair1 {unPair1 :: (f a, g a)} + deriving (Eq, Ord, Show) + +instance (Typeable1 f, Typeable1 g) => Typeable1 (Pair1 f g) where + typeOf1 = const $ mkTyConApp (mkTyCon tyConStr) [] + where + tyConStr = "Data.Tupler.Pair1" + ++ tcStringSP (undefined :: f Bool) + ++ tcStringSP (undefined :: g Bool) + +-- | Pairing for binary type constructors. +newtype Pair2 f g a b = Pair2 {unPair2 :: (f a b, g a b)} + deriving (Eq, Ord, Show) + +instance (Typeable2 f, Typeable2 g) => Typeable2 (Pair2 f g) where + typeOf2 = const $ mkTyConApp (mkTyCon tyConStr) [] + where + tyConStr = "Data.Tupler.Pair2" + ++ tcStringSP (undefined :: f Bool Bool) + ++ tcStringSP (undefined :: g Bool Bool) + + +---- Misc + +-- | Disambuating hack for a function argument. Wrap parens around a string +-- if it contains a space. +parensIfSpace :: String -> String +parensIfSpace str | ' ' `elem` str = "("++str++")" + | otherwise = str + +-- | Extract the type constructor as a string +tcString :: Typeable a => a -> String +tcString = tyConString . typeRepTyCon . typeOf + +-- | 'tcString' with disambiguating optional parens +tcStringP :: Typeable a => a -> String +tcStringP = parensIfSpace . tcString + +-- | 'tcString' with leading space and optional parens +tcStringSP :: Typeable a => a -> String +tcStringSP = (' ':) . tcStringP