Skip to content
Browse files

initialized

  • Loading branch information...
0 parents commit 6f974f984570f6fdb85428d618edbb21e1f7b5e7 @ekmett committed Jan 7, 2011
Showing with 263 additions and 0 deletions.
  1. +2 −0 .gitignore
  2. +199 −0 Data/Functor/Apply.hs
  3. +30 −0 LICENSE
  4. +7 −0 Setup.lhs
  5. +25 −0 functor-apply.cabal
2 .gitignore
@@ -0,0 +1,2 @@
+_darcs
+dist
199 Data/Functor/Apply.hs
@@ -0,0 +1,199 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Functor.Apply
+-- Copyright : (C) 2011 Edward Kmett,
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : Edward Kmett <ekmett@gmail.com>
+-- Stability : provisional
+-- Portability : portable
+--
+----------------------------------------------------------------------------
+module Data.Functor.Apply (
+ -- * Functors
+ Functor(..)
+ , (<$>) -- :: Functor f => (a -> b) -> f a -> f b
+ , ( $>) -- :: Functor f => f a -> b -> f b
+
+ -- * FunctorApply - strong lax semimonoidal endofunctors
+
+ , FunctorApply(..)
+ , (<..>) -- :: FunctorApply w => w a -> w (a -> b) -> w b
+ , liftF2 -- :: FunctorApply w => (a -> b -> c) -> w a -> w b -> w c
+ , liftF3 -- :: FunctorApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d
+
+ -- * Wrappers
+ , WrappedApplicative(..)
+ , MaybeApply(..)
+ ) where
+
+import Prelude hiding (id, (.))
+import Control.Applicative
+import Control.Arrow
+import Control.Category
+import Control.Monad.Trans.Identity
+import Data.Functor
+import Data.Functor.Identity
+import Data.Monoid
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+import qualified Data.IntMap as IntMap
+import Data.IntMap (Map)
+
+import Data.Seq (Seq)
+import Data.Tree (Tree)
+
+infixl 4 <.>, <., .>, <..>, $>
+
+-- | TODO: move into Data.Functor
+($>) :: Functor f => f a -> b -> f b
+($>) = flip (<$)
+
+-- | A strong lax semi-monoidal endofunctor
+
+class Functor f => FunctorApply f where
+ (<.>) :: f (a -> b) -> f a -> f b
+
+ -- | a .> b = const id <$> a <.> b
+ (.>) :: f a -> f b -> f b
+ a .> b = const id <$> a <.> b
+
+ -- | a <. b = const <$> a <.> b
+ (<.) :: f a -> f b -> f a
+ a <. b = const <$> a <.> b
+
+-- this only requires a Semigroup, but those don't exist
+instance Monoid m => FunctorApply ((,)m) where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+-- this only requires a Semigroup, but those don't exist
+instance Monoid m => FunctorApply ((->)m) where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+instance FunctorApply ZipList where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+instance FunctorApply [] where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+instance FunctorApply IO where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+instance FunctorApply Maybe where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+instance FunctorApply Identity where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+instance FunctorApply w => FunctorApply (IdentityT w) where
+ IdentityT wa <.> IdentityT wb = IdentityT (wa <.> wb)
+
+instance Monad m => FunctorApply (WrappedMonad m) where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+instance Monoid m => FunctorApply (Const m) where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+instance Arrow a => FunctorApply (WrappedArrow a b) where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+-- | A Map is not 'Applicative', but it is an instance of 'FunctorApply'
+instance Ord k => FunctorApply (Map k) where
+ mf <.> ma = Map.intersectionWith id
+ mf <. ma = Map.intersectionWith const
+ mf .> ma = Map.intersectionWith (const id)
+
+-- | An IntMap is not Applicative, but it is an instance of 'FunctorApply'
+instance FunctorApply IntMap where
+ mf <.> ma = IntMap.intersectionWith id
+ mf <. ma = IntMap.intersectionWith const
+ mf .> ma = IntMap.intersectionWith (const id)
+
+instance FunctorApply Seq where
+ (<.>) = ap
+
+instance FunctorApply Tree where
+ (<.>) = (<*>)
+ (<. ) = (<* )
+ ( .>) = ( *>)
+
+-- | Wrap an 'Applicative' to be used as a member of 'FunctorApply'
+newtype WrappedApplicative f a = WrappedApplicative { unwrapApplicative :: f a }
+
+instance Functor f => Functor (WrappedApplicative f) where
+ fmap f (WrappedApplicative a) = WrappedApplicative (f <$> a)
+
+instance Applicative f => FunctorApply (WrappedApplicative f) where
+ WrappedApplicative f <.> WrappedApplicative a = WrappedApplicative (f <*> a)
+ WrappedApplicative a <. WrappedApplicative b = WrappedApplicative (a <* b)
+ WrappedApplicative a .> WrappedApplicative b = WrappedApplicative (a *> b)
+
+instance Applicative f => Applicative (WrappedApplicative f) where
+ pure = WrappedApplicative . pure
+ WrappedApplicative f <*> WrappedApplicative a = WrappedApplicative (f <*> a)
+ WrappedApplicative a <* WrappedApplicative b = WrappedApplicative (a <* b)
+ WrappedApplicative a *> WrappedApplicative b = WrappedApplicative (a *> b)
+
+-- | Transform a FunctorApply into an Applicative by adding a unit.
+newtype MaybeApply f a = MaybeApply { runMaybeApply :: Either (f a) a }
+
+instance Functor f => Functor (MaybeApply f) where
+ fmap f (MaybeApply (Right a)) = MaybeApply (Right (f a ))
+ fmap f (MaybeApply (Left fa)) = MaybeApply (Left (f <$> fa))
+
+instance FunctorApply f => FunctorApply (MaybeApply f) where
+ MaybeApply (Right f) <.> MaybeApply (Right a) = MaybeApply (Right (f a ))
+ MaybeApply (Right f) <.> MaybeApply (Left fa) = MaybeApply (Left (f <$> fa))
+ MaybeApply (Left ff) <.> MaybeApply (Right a) = MaybeApply (Left (($a) <$> ff))
+ MaybeApply (Left ff) <.> MaybeApply (Left fa) = MaybeApply (Left (ff <.> fa))
+
+ MaybeApply a <. MaybeApply (Right _) = MaybeApply a
+ MaybeApply (Right a) <. MaybeApply (Left fb) = MaybeApply (Left (a <$ fb))
+ MaybeApply (Left fa) <. MaybeApply (Left fb) = MaybeApply (Left (fa <. fb))
+
+ MaybeApply (Right _) .> MaybeApply b = MaybeApply b
+ MaybeApply (Left fa) .> MaybeApply (Right b) = MaybeApply (Left (fa $> b ))
+ MaybeApply (Left fa) .> MaybeApply (Left fb) = MaybeApply (Left (fa .> fb))
+
+instance FunctorApply f => Applicative (MaybeApply f) where
+ pure a = MaybeApply (Right a)
+ (<*>) = (<.>)
+ (<* ) = (<. )
+ ( *>) = ( .>)
+
+-- | A variant of '<.>' with the arguments reversed.
+(<..>) :: FunctorApply w => w a -> w (a -> b) -> w b
+(<..>) = liftF2 (flip id)
+{-# INLINE (<..>) #-}
+
+-- | Lift a binary function into a comonad with zipping
+liftF2 :: FunctorApply w => (a -> b -> c) -> w a -> w b -> w c
+liftF2 f a b = f <$> a <.> b
+{-# INLINE liftF2 #-}
+
+-- | Lift a ternary function into a comonad with zipping
+liftF3 :: FunctorApply w => (a -> b -> c -> d) -> w a -> w b -> w c -> w d
+liftF3 f a b c = f <$> a <.> b <.> c
+{-# INLINE liftF3 #-}
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright 2011 Edward Kmett
+
+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 AUTHORS ``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.
7 Setup.lhs
@@ -0,0 +1,7 @@
+#!/usr/bin/runhaskell
+> module Main (main) where
+
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
25 functor-apply.cabal
@@ -0,0 +1,25 @@
+name: functor-apply
+category: Control, Comonads
+version: 0.5.0
+license: BSD3
+cabal-version: >= 1.2
+license-file: LICENSE
+author: Edward A. Kmett
+maintainer: Edward A. Kmett <ekmett@gmail.com>
+stability: provisional
+homepage: http://comonad.com/reader/
+copyright: Copyright (C) 2008-2011 Edward A. Kmett, Copyright (C) 2004-2008 Dave Menendez
+synopsis: Strong lax semimonoidal endofunctors (Applicative sans pure)
+description: Strong lax semimonoidal endofunctors (Applicative sans pure)
+build-type: Simple
+
+library
+ build-depends:
+ base >= 4 && < 4.4,
+ transformers >= 0.2.0 && < 0.3,
+ containers >= 0.4.0 && < 0.5
+
+ exposed-modules:
+ Data.Functor.Apply
+
+ ghc-options: -Wall

0 comments on commit 6f974f9

Please sign in to comment.
Something went wrong with that request. Please try again.