Easy Traversable1 instances

Traversable1.hs

{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
module Traversable1 where

import Data.Functor.Apply
import Data.Semigroup.Foldable
import Data.Semigroup.Traversable

-- | Apply a non-empty container of functions to a possibly-empty-with-unit container of values.
(<.*>) :: (Apply f) => f (a -> b) -> MaybeApply f a -> f b
ff <.*> MaybeApply (Left fa) = ff <.> fa
ff <.*> MaybeApply (Right a) = ($ a) <$> ff
infixl 4 <.*>

-- | Apply a possibly-empty-with-unit container of functions to a non-empty container of values.
(<*.>) :: (Apply f) => MaybeApply f (a -> b) -> f a -> f b
MaybeApply (Left ff) <*.> fa = ff <.> fa
MaybeApply (Right f) <*.> fa = f <$> fa
infixl 4 <*.>

-- | Traverse using 'Apply', but getting back the result in 'MaybeApply f' instead of in 'f'.
traverse1Maybe :: (Apply f, Traversable t) => (a -> f b) -> t a -> MaybeApply f (t b)
traverse1Maybe f = traverse (MaybeApply . Left . f)

data Foo a = Foo (Maybe a) (Maybe a) (Maybe a) a [a]
  deriving (Functor, Traversable, Foldable)

instance Traversable1 Foo where
  traverse1 f (Foo ma mb mc a as) = 
    Foo <$> traverse1Maybe f ma <*> traverse1Maybe f mb <*> traverse1Maybe f mc <*.> f a <.*> traverse1Maybe f as

-- necessary superclass instance
instance Foldable1 Foo where
  foldMap1 = foldMap1Default