Skip to content

Instantly share code, notes, and snippets.

@masaeedu
Last active Jan 29, 2020
Embed
What would you like to do?
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment