Using Generic to write Applicative/Monad methods

GenericApplicative.hs

{-# LANGUAGE TypeOperators, FlexibleContexts, DeriveGeneric #-}

import Control.Applicative
import GHC.Generics
import Data.Monoid

-------- Needed for making instances using Generic machinery
-- Orphan instances are bad though.

-- Nullary product
instance Functor U1 where
    fmap _ _ = U1
instance Applicative U1 where
    pure _ = U1
    _ <*> _ = U1
instance Monad U1 where
    return _ = U1
    _ >>= _ = U1

-- Identity (unary product)
instance Functor Par1 where
    fmap f (Par1 a) = Par1 (f a)
instance Applicative Par1 where
    pure = Par1
    Par1 f <*> Par1 a = Par1 (f a)
instance Monad Par1 where
    return = Par1
    Par1 a >>= k = k a

-- Embedding a type constructor in a field
instance Functor f => Functor (Rec1 f) where
    fmap f (Rec1 a) = Rec1 (fmap f a)
instance Applicative f => Applicative (Rec1 f) where
    pure a = Rec1 (pure a)
    Rec1 f <*> Rec1 a = Rec1 (f <*> a)
instance Monad f => Monad (Rec1 f) where
    return a = Rec1 (return a)
    Rec1 a >>= k = Rec1 $ a >>= unRec1 . k

-- For fields with types that don't mention the type variable
instance Functor (K1 i c) where
    fmap _ (K1 a) = K1 a
instance Monoid c => Applicative (K1 i c) where -- Const c is an Applicative when c is a Monoid
    pure a = K1 mempty
    K1 a <*> K1 b = K1 (a <> b)

-- No idea what's different between this and Rec1
instance Functor f => Functor (M1 i c f) where
    fmap f (M1 a) = M1 (fmap f a)
instance Applicative f => Applicative (M1 i c f) where
    pure a = M1 (pure a)
    M1 f <*> M1 a = M1 (f <*> a)
instance Monad f => Monad (M1 i c f) where
    return a = M1 (return a)
    M1 a >>= k = M1 $ a >>= unM1 . k

-- Binary sums
instance (Functor f, Functor g) => Functor (f :+: g) where
    fmap f (L1 a) = L1 (fmap f a)
    fmap f (R1 a) = R1 (fmap f a)
-- Sums of applicatives/monads aren't generally applicatives/monads

-- Binary products
instance (Functor f, Functor g) => Functor (f :*: g) where
    fmap f (a :*: b) = fmap f a :*: fmap f b
instance (Applicative f, Applicative g) => Applicative (f :*: g) where
    pure a = pure a :*: pure a
    (f :*: g) <*> (a :*: b) = (f <*> a) :*: (g <*> b)
instance (Monad f, Monad g) => Monad (f :*: g) where
    return a = return a :*: return a
    (fa :*: ga) >>= k = (fa >>= fst' . k) :*: (ga >>= snd' . k)
      where
        fst' (a :*: b) = a
        snd' (a :*: b) = b

-- Composition
instance (Functor f, Functor g) => Functor (f :.: g) where
    fmap f (Comp1 a) = Comp1 (fmap (fmap f) a)
instance (Applicative f, Applicative g) => Applicative (f :.: g) where
    pure a = Comp1 (pure (pure a))
    Comp1 f <*> Comp1 a = Comp1 ((fmap (<*>) f) <*> a)
-- Composition of monads isn't generally a monad

-------- Method definitions using Generic machinery

gfmap :: (Generic1 f, Functor (Rep1 f)) => (a -> b) -> f a -> f b
gfmap f = to1 . fmap f . from1

gpure :: (Generic1 f, Applicative (Rep1 f)) => a -> f a
gpure = to1 . pure

gapp :: (Generic1 f, Applicative (Rep1 f)) => f (a -> b) -> f a -> f b
gapp f a = to1 (from1 f <*> from1 a)

greturn :: (Generic1 f, Monad (Rep1 f)) => a -> f a
greturn = to1 . return

gbind :: (Generic1 f, Monad (Rep1 f)) => f a -> (a -> f b) -> f b
gbind a f = to1 (from1 a >>= from1 . f)

-------- Examples

data Two a = Two a a
    deriving (Show, Generic1)

instance Functor Two where
    fmap = gfmap
instance Applicative Two where
    pure = gpure
    (<*>) = gapp
instance Monad Two where
    return = greturn
    (>>=) = gbind


data Reader r a = Reader (r -> a)
    deriving (Generic1)

instance Functor (Reader r) where
    fmap = gfmap
instance Applicative (Reader r) where
    pure = gpure
    (<*>) = gapp
instance Monad (Reader r) where
    return = greturn
    (>>=) = gbind


data Stream a = Stream a (Stream a)
    deriving (Show, Generic1)

instance Functor Stream where
    fmap = gfmap
instance Applicative Stream where
    pure = gpure
    (<*>) = gapp
instance Monad Stream where
    return = greturn
    (>>=) = gbind


data State s a = State (s -> (s,a))
    deriving (Generic1)

instance Functor (State s) where
    fmap = gfmap
-- can't make Applicative or Monoid instances with Generic