packages feed

DeepArrow (empty) → 0.0

raw patch · 8 files changed

+535/−0 lines, 8 filesdep +basedep +mtlbuild-type:Customsetup-changed

Dependencies added: base, mtl

Files

+ DeepArrow.cabal view
@@ -0,0 +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 <http://haskell.org/haskellwiki/DeepArrow>
+  .
+  * Application of deep arrows for composable interfaces in the TV library:
+    <http://haskell.org/haskellwiki/TV>
+  .
+  * The motivating idea and paper "Functional Programming by Interacting
+    with Tangible Values": <http://conal.net/papers/Eros>
+  .
+  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 @->@.
+  .
+  &#169; 2007 by Conal Elliott (<http://conal.net>); BSD3 license.
+Author:			Conal Elliott <conal@conal.net>
+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
+ Makefile view
@@ -0,0 +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
+ README view
@@ -0,0 +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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
+ src/Control/Arrow/DeepArrow.hs view
@@ -0,0 +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
+
+ src/Control/Arrow/DeepArrow/Examples.hs view
@@ -0,0 +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
+ src/Data/FunArr.hs view
@@ -0,0 +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')
+
+
+ src/Data/Tupler.hs view
@@ -0,0 +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