Initial import.

.gitignore

@@ -0,0 +1,2 @@
+dist/
+*.swp

LICENSE

@@ -0,0 +1,28 @@
+Copyright (c) Sebastiaan Visser 2008
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
+

Setup.lhs

@@ -0,0 +1,6 @@
+#! /usr/bin/env runhaskell
+
+>import Distribution.Simple
+
+>main = defaultMain
+

arrow-list.cabal

@@ -0,0 +1,26 @@
+Name:             arrow-list
+Version:          0.0.1
+Description:      List arrows.
+Synopsis:         List arrows.
+Category:         Control
+License:          BSD3
+License-file:     LICENSE
+Author:           Sebastiaan Visser
+Maintainer:       haskell@fvisser.nl
+Build-Type:       Simple
+Cabal-Version:    >= 1.2
+
+Library
+  GHC-Options:      -threaded -Wall -O
+  HS-Source-Dirs:   src
+
+  Build-Depends:    base ==4.*,
+                    monads-fd,
+                    transformers
+
+  Exposed-modules:  Control.Arrow.ArrowKleisli
+                    Control.Arrow.ArrowList
+                    Control.Arrow.Functor
+                    Control.Arrow.Instances
+                    Control.Arrow.List
+

src/Control/Arrow/ArrowKleisli.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE
+    TypeOperators
+  , MultiParamTypeClasses
+  , FlexibleContexts
+  , FlexibleInstances
+  #-}
+module Control.Arrow.ArrowKleisli where
+
+import Control.Arrow
+
+class (Monad m, Arrow (~>)) => ArrowKleisli m (~>) where
+  arrM :: (a -> m b) -> a ~> b
+
+instance Monad m => ArrowKleisli m (Kleisli m) where
+  arrM f = Kleisli f
+

src/Control/Arrow/ArrowList.hs

@@ -0,0 +1,145 @@
+{-# LANGUAGE TypeOperators, Arrows #-}
+{- |
+The `ArrowList' type class, and a collection of list arrow related functions.
+-}
+module Control.Arrow.ArrowList
+(
+  -- * ArrowList type class.
+  ArrowList (..)
+
+  -- * Creating list arrows.
+, unlistA
+, listA
+, none
+, concatA
+, maybeL
+
+  -- * Collecting the results.
+, collect
+, empty
+
+  -- * Conditional and filter arrows.
+, isA
+, ifA
+, when
+, guards
+, filterA
+, notA
+, orElse
+
+  -- * Optionality.
+, optional
+)
+where
+
+import Control.Monad hiding (when)
+import Control.Category
+import Control.Arrow
+import Prelude hiding ((.), id)
+
+-- | The `ArrowList' class represents two possible actions:
+-- 
+--   1. Lifting functions from one value to a list of values into a list arrow.
+-- 
+--   2. Mapping a function over the result list of a list arrow.
+
+class Arrow (~>) => ArrowList (~>) where
+  arrL :: (a -> [b]) -> a ~> b
+  mapL :: ([b] -> [c]) -> (a ~> b) -> (a ~> c)
+
+-- | Create a list arrow of an input list.
+
+unlistA :: ArrowList (~>) => [b] ~> b
+unlistA = arrL id
+
+-- | Take the output of an arrow producing two results and concatenate them
+-- into the result of the list arrow.
+
+listA :: ArrowList (~>) => (a ~> (b, b)) -> a ~> b
+listA = mapL (concatMap (\(a, b) -> [a, b]))
+
+-- | Ignore the input and produce no results. Like `zeroArrow'.
+
+none :: ArrowList (~>) => a ~> b
+none = arrL (const [])
+
+-- | Collect the results of applying multiple arrows to the same input.
+
+concatA :: ArrowPlus (~>) => [a ~> b] -> a ~> b
+concatA = foldr (<+>) zeroArrow
+
+-- | Map a `Maybe' input to a list output. When the Maybe is a `Nothing' an
+-- empty list will be returned, `Just' will result in a singleton list.
+
+maybeL :: ArrowList (~>) => Maybe a ~> a
+maybeL = arrL (maybe [] return)
+
+-- | Collect the entire results of an list arrow as a singleton value in the
+-- result list.
+
+collect :: ArrowList (~>) => (a ~> b) -> a ~> [b]
+collect = mapL return
+
+-- | Returns a `Bool' indicating whether the input arrow produce any results.
+
+empty :: ArrowList (~>) => (a ~> b) -> a ~> Bool
+empty = mapL (\xs -> [if null xs then True else False])
+
+-- | Create a filtering list arrow by mapping a predicate function over the
+-- input. When the predicate returns `True' the input will be returned in the
+-- output list, when `False' the empty list is returned.
+
+isA :: ArrowList (~>) => (a -> Bool) -> a ~> a
+isA f = arrL (\a -> if f a then [a] else [])
+
+-- | Use the result a list arrow as a conditional, like an if-then-else arrow.
+-- When the first arrow produces any results the /then/ arrow will be used,
+-- when the first arrow produces no results the /else/ arrow will be used.
+
+ifA :: (ArrowList (~>), ArrowChoice (~>))
+    => (a ~> c)  -- ^ Arrow used as condition.
+    -> (a ~> b)  -- ^ Arrow to use when condition has results.
+    -> (a ~> b)  -- ^ Arrow to use when condition has no results.
+    -> a ~> b
+ifA c t e = proc i -> do x <- empty c -< i; if x then e -< i else t -< i
+
+-- | Apply a list arrow only when a conditional arrow produces any results.
+-- When the conditional produces no results the output arrow /behaves like the identity/.
+-- The /second/ input arrow is used as the conditional, this allow
+-- you to write: @ a \`when\` c @
+
+when :: (ArrowList (~>), ArrowChoice (~>))
+     => (a ~> a)  -- ^ The arrow to apply,
+     -> (a ~> b)  -- ^ when this conditional holds.
+     -> a ~> a
+when a c = ifA c a id
+
+-- | Apply a list arrow only when a conditional arrow produces any results.
+-- When the conditional produces no results the output arrow /produces no results/.
+-- The /first/ input arrow is used as the conditional, this allow you
+-- to write: @ c \`guards\` a @
+
+guards :: (ArrowList (~>), ArrowChoice (~>))
+       => (a ~> c)  -- ^ When this condition holds,
+       -> (a ~> b)  -- ^ then apply this arrow.
+       -> a ~> b
+guards c a = ifA c a none
+
+
+
+
+filterA :: (ArrowChoice (~>), ArrowList (~>)) => (a ~> c) -> a ~> a
+filterA c = ifA c id none
+
+notA :: (ArrowList (~>), ArrowChoice (~>)) => (a ~> b) -> a ~> a
+notA c = ifA c none id
+
+
+
+
+orElse :: (ArrowList (~>), ArrowChoice (~>)) => (a ~> b) -> (a ~> b) -> a ~> b
+orElse a = ifA a a
+
+optional :: (ArrowChoice (~>), ArrowList (~>)) => (a ~> b) -> a ~> Maybe b
+optional a = ifA a (arr Just . a) (arr (const Nothing))
+

src/Control/Arrow/Functor.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE TypeOperators, Arrows #-}
+module Control.Arrow.Functor where
+
+import Control.Category
+import Control.Arrow
+import Prelude ()
+
+class FunctorA f where
+  mapA :: ArrowChoice (~>) => (a ~> b) -> (f a ~> f b)
+
+instance FunctorA [] where
+  mapA a = proc i ->
+    case i of
+      []   -> id -< []
+      x:xs -> do y  <- a      -< x
+                 ys <- mapA a -< xs
+                 id -< y:ys
+

src/Control/Arrow/Instances.hs

@@ -0,0 +1,25 @@
+{-# OPTIONS -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleInstances, Arrows #-}
+module Control.Arrow.Instances where
+
+import Control.Applicative
+import Control.Arrow
+import Control.Category
+import Prelude hiding ((.), id)
+
+instance Arrow (~>) => Functor ((~>) a) where
+  fmap f a = arr f . a
+
+instance Arrow (~>) => Applicative ((~>) a) where
+  pure a = arr (const a)
+  a <*> b = proc i ->
+    do x <- a -< i
+       y <- b -< i
+       id -< x y
+
+instance ArrowApply (~>) => Monad ((~>) a) where
+  return a = arr (const a)
+  a >>= b = proc i ->
+    do x <- a -< i
+       b x -<< i
+

src/Control/Arrow/List.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE
+    GeneralizedNewtypeDeriving
+  , TypeOperators
+  , FlexibleInstances
+  , MultiParamTypeClasses
+  , StandaloneDeriving
+  #-}
+module Control.Arrow.List where
+
+import Prelude hiding ((.), id)
+import Control.Arrow
+import Control.Arrow.ArrowKleisli
+import Control.Arrow.ArrowList
+import Control.Category
+import Control.Monad.Identity
+import Control.Monad.List
+
+newtype ListTArrow m a b = ListTArrow { runListTArrow' :: Kleisli (ListT m) a b }
+  deriving
+    ( Category
+    , Arrow
+    , ArrowZero
+    , ArrowPlus
+    , ArrowApply
+    , ArrowChoice
+    )
+
+instance Monad m => ArrowKleisli m (ListTArrow m) where
+  arrM a = ListTArrow (Kleisli (ListT . (liftM return . a)))
+
+runListTArrow :: ListTArrow m a b -> a -> m [b]
+runListTArrow a = runListT . runKleisli (runListTArrow' a)
+
+type ListArrow a b = ListTArrow Identity a b
+
+runListArrow :: ListArrow a b -> a -> [b]
+runListArrow a = runIdentity . runListTArrow a
+
+instance Monad m => ArrowList (ListTArrow m) where
+  arrL a   = ListTArrow (Kleisli (ListT . return . a))
+  mapL f g = arrML (liftM f . runListTArrow g)
+
+arrML :: (ArrowList (~>), ArrowKleisli m (~>)) => (a -> m [b]) -> a ~> b
+arrML x = unlistA . arrM x
+