module SimpleH.Applicative(
module SimpleH.Functor,
Applicative(..),
ZipList(..),ZipTree(..),Backwards(..),
(*>),(<*),(<**>),ap,sequence_,traverse_,for_,forever,
between,
liftA,liftA2,liftA3,liftA4,
plusA,zeroA,filter
) where
import SimpleH.Functor
import SimpleH.Classes
import SimpleH.Core
import Data.Tree
import SimpleH.Foldable
instance Applicative (Either a)
instance Monad (Either a) where join (Right a) = a
join (Left a) = Left a
instance Applicative ((->) a)
instance Semigroup b => Semigroup (a -> b) where (+) = plusA
instance Monoid b => Monoid (a -> b) where zero = zeroA
instance Ring b => Ring (a -> b) where (*) = timesA ; one = oneA
instance Monad ((->) a) where join f x = f x x
instance Monoid w => Applicative ((,) w)
instance Monoid w => Monad ((,) w) where
join ~(w,~(w',a)) = (w+w',a)
instance Applicative []
instance Monad [] where join = fold
instance (Unit f,Unit g) => Unit (f:**:g) where pure a = pure a:**:pure a
instance (Applicative f,Applicative g) => Applicative (f:**:g) where
ff:**:fg <*> xf:**:xg = (ff<*>xf) :**: (fg<*>xg)
instance Applicative Tree
instance Monad Tree where
join (Node (Node a subs) subs') = Node a (subs + map join subs')
instance (Applicative f,Applicative g) => Applicative (f:.:g) where
Compose fs <*> Compose xs = Compose ((<*>)<$>fs<*>xs)
deriving instance Unit Interleave
instance Applicative Interleave
instance Monad Interleave where join = fold
newtype ZipList a = ZipList { getZipList :: [a] }
instance Semigroup a => Semigroup (ZipList a) where (+) = plusA
instance Monoid a => Monoid (ZipList a) where zero = zeroA
instance Functor ZipList where
map f (ZipList l) = ZipList (map f l)
instance Unit ZipList where
pure a = ZipList (repeat a)
instance Applicative ZipList where
ZipList zf <*> ZipList zx = ZipList (zip_ zf zx)
where zip_ (f:fs) (x:xs) = f x:zip_ fs xs
zip_ _ _ = []
deriving instance Foldable ZipList
newtype ZipTree a = ZipTree (Tree a)
instance Functor ZipTree where
map f (ZipTree t) = ZipTree (map f t)
instance Unit ZipTree where
pure a = ZipTree (Node a (getZipList (pure (pure a))))
instance Applicative ZipTree where
ZipTree (Node f fs) <*> ZipTree (Node x xs) =
ZipTree (Node (f x) (getZipList ((<*>)<$>ZipList fs<*>ZipList xs)))
deriving instance Foldable ZipTree
newtype Backwards f a = Backwards { forwards :: f a }
deriving instance Semigroup (f a) => Semigroup (Backwards f a)
deriving instance Monoid (f a) => Monoid (Backwards f a)
deriving instance Ring (f a) => Ring (Backwards f a)
deriving instance Unit f => Unit (Backwards f)
deriving instance Functor f => Functor (Backwards f)
instance Applicative f => Applicative (Backwards f) where
Backwards fs <*> Backwards xs = Backwards (fs<**>xs)
ap :: Applicative f => f (a -> b) -> f a -> f b
plusA :: (Applicative f,Semigroup a) => f a -> f a -> f a
zeroA :: (Unit f,Monoid a) => f a
oneA :: (Unit f,Ring a) => f a
timesA :: (Applicative f,Ring a) => f a -> f a -> f a
(*>) :: Applicative f => f b -> f a -> f a
(<*) :: Applicative f => f a -> f b -> f a
(<**>) :: Applicative f => f (a -> b) -> f a -> f b
ap = (<*>)
infixl 1 <*
infixl 2 <**>,*>
(*>) = liftA2 (flip const)
(<*) = liftA2 const
f <**> x = liftA2 (&) x f
sequence_ = foldr (*>) (pure ())
sequence_ :: (Applicative f,Foldable t) => t (f a) -> f ()
traverse_ f = sequence_ . map f
traverse_ :: (Applicative f,Foldable t) => (a -> f b) -> t a -> f ()
for_ = flip traverse_
for_ :: (Applicative f,Foldable t) => t a -> (a -> f b) -> f ()
forever :: Applicative f => f a -> f b
forever m = undefined<$sequence_ (repeat m)
liftA :: Functor f => (a -> b) -> (f a -> f b)
liftA = map
liftA2 :: Applicative f => (a -> b -> c) -> (f a -> f b -> f c)
liftA2 f = \a b -> f<$>a<*>b
liftA3 :: Applicative f => (a -> b -> c -> d) -> (f a -> f b -> f c -> f d)
liftA3 f = \a b c -> f<$>a<*>b<*>c
liftA4 :: Applicative f => (a -> b -> c -> d -> e) -> (f a -> f b -> f c -> f d -> f e)
liftA4 f = \a b c d -> f<$>a<*>b<*>c<*>d
plusA = liftA2 (+)
zeroA = pure zero
oneA = pure one
timesA = liftA2 (*)
between :: Applicative f => f b -> f c -> f a -> f a
between start end p = liftA3 (\_ b _ -> b) start p end
instance (Applicative f,Semigroup (g a)) => Semigroup ((f:.:g) a) where
Compose f+Compose g = Compose ((+)<$>f<*>g)
instance (Applicative f,Monoid (g a)) => Monoid ((f:.:g) a) where
zero = Compose (pure zero)