selective.hs

{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, FlexibleInstances, DeriveFunctor #-}

import Data.Bool
import Data.Functor
import Data.Bifunctor
import Data.Function ((&))
import Data.Semigroup
import Control.Applicative
import Control.Monad

newtype EitherT e m a = EitherT { runEitherT :: m (Either e a) }
  deriving Functor

-- EitherT Monad
instance Monad f => Applicative (EitherT b f) where
  pure = return
  (<*>) = ap

instance Monad m => Monad (EitherT b m) where
  return          = EitherT . pure . Right
  EitherT m >>= f = EitherT $ m >>= z where
    z (Right x) = runEitherT $ f x
    z (Left  x) = pure . Left $ x

-- Validation
data Validation e a = Failure e | Success a
  deriving (Functor, Show)

instance Semigroup e => Applicative (Validation e) where
  pure = Success
  Failure e1 <*> Failure e2 = Failure (e1 <> e2)
  Failure e1 <*> Success _  = Failure e1
  Success _  <*> Failure e2 = Failure e2
  Success f  <*> Success a  = Success (f a)

-- Monad for Validations containing Eithers
instance {-# OVERLAPS #-} Applicative (EitherT b (Validation e)) where
  pure = return
  (<*>) = ap

instance {-# OVERLAPS #-} Monad (EitherT b (Validation e)) where
  return x = EitherT (Success (Right x))
  EitherT (Success (Left b))  >>= _ = EitherT (Success (Left b))
  EitherT (Failure e)         >>= _ = EitherT (Failure e)
  EitherT (Success (Right a)) >>= f = f a

-- Selective functor stuff
handle_ :: (Functor f, Monad (EitherT b f)) => f (Either b a) -> f (a -> b) -> f b
handle_ e h = fmap (either id id) . runEitherT $ (EitherT e) >>= (\a -> EitherT $ (Left . ($ a)) <$> h)

flipE :: Either a b -> Either b a
flipE (Right a) = Left  a
flipE (Left  b) = Right b

handle = handle_ . fmap flipE


-- All the code from here on is copy pasted and should work as defined in the blog post (although the constraints are different)

select x l r = fmap (fmap Left) x `handle` fmap (fmap Right) l `handle` r

ifS i t e = select (bool (Right ()) (Left ()) <$> i) (const <$> t) (const <$> e)

-- ...

-- Examples
type Radius = Int
type Width  = Int
type Height = Int

data Shape = Circle Radius | Rectangle Width Height deriving Show

shape s r w h = ifS s (Circle <$> r) (Rectangle <$> w <*> h)