Solutions to Tony Morris's Haskell Exercises

20exercises.hs

{-# LANGUAGE InstanceSigs #-}

-- http://blog.tmorris.net/posts/20-intermediate-haskell-exercises/

-- Functor
class Fluffy f where
  furry :: (a -> b) -> f a -> f b

instance Fluffy [] where
  furry :: (a -> b) -> [a] -> [b]
  furry f = foldr ((:) . f) []

instance Fluffy Maybe where
  furry :: (a -> b) -> Maybe a -> Maybe b
  furry f (Just x) = Just $ f x
  furry _ _        = Nothing

instance Fluffy ((->) t) where
  furry :: (a -> b) -> (t -> a) -> (t -> b)
  furry = (.)

instance Fluffy (Either e) where
  furry :: (a -> b) -> Either e a -> Either e b
  furry f (Right v) = Right $ f v
  furry _ (Left  v) = Left v

newtype EitherLeft b a = EitherLeft (Either a b) deriving (Show)
newtype EitherRight a b = EitherRight (Either a b) deriving (Show)

instance Fluffy (EitherLeft t) where
  furry :: (a -> b) -> EitherLeft t a -> EitherLeft t b
  furry f (EitherLeft (Left val))  = EitherLeft . Left $ f val
  furry _ (EitherLeft (Right val)) = EitherLeft . Right $ val

instance Fluffy (EitherRight t) where
  furry :: (a -> b) -> EitherRight t a -> EitherRight t b
  furry _ (EitherRight (Left val))  = EitherRight . Left $ val
  furry f (EitherRight (Right val)) = EitherRight . Right $ f val

-- Monad
class Misty m where
  banana :: (a -> m b) -> m a -> m b
  unicorn :: a -> m a

  furry' :: (a -> b) -> m a -> m b
  furry' f = banana (unicorn . f)

instance Misty [] where
  banana :: (a -> [b]) -> [a] -> [b]
  banana = concatMap

  unicorn :: a -> [a]
  unicorn = (: [])

instance Misty Maybe where
  banana :: (a -> Maybe b) -> Maybe a -> Maybe b
  banana _ Nothing = Nothing
  banana k (Just x) = k x

  unicorn :: a -> Maybe a
  unicorn = Just

instance Misty ((->) e) where
  banana :: (a -> (e -> b)) -> (e -> a) -> (e -> b)
  banana a2eb ea = \e -> a2eb (ea e) e

  unicorn :: a -> (e -> a)
  unicorn = const

instance Misty (EitherLeft t) where
  banana :: (a -> EitherLeft t b) -> EitherLeft t a -> EitherLeft t b
  banana mf (EitherLeft (Left a)) = mf a
  banana _ (EitherLeft (Right a)) = EitherLeft . Right $ a

  unicorn :: a -> EitherLeft t a
  unicorn = EitherLeft . Left

instance Misty (EitherRight t) where
  banana :: (a -> EitherRight t b) -> EitherRight t a -> EitherRight t b
  banana mf (EitherRight (Right a)) = mf a
  banana _  (EitherRight (Left  a)) = EitherRight . Left $ a

  unicorn :: a -> EitherRight t a
  unicorn = EitherRight . Right

-- join
jellybean :: (Misty m) => m (m a) -> m a
jellybean = banana id

-- ap
-- ap v mk = v >>= (\x -> mk >>= (\f -> return $ f x))
-- ap v mk = do { x <- v; f <- mk; return $ f x }
apple :: (Misty m) => m a -> m (a -> b) -> m b
apple v mk = banana (\x -> banana (\f -> unicorn $ f x) mk) v

-- mapM
moppy :: (Misty m) => [a] -> (a -> m b) -> m [b]
moppy xs k = sausage $ furry' k xs

-- sequence
-- sequence = foldr k (return [])
--   where k m m' = do {x <- m; xs <- m'; return (x:xs)}
-- or
-- sequence = foldr (liftM2 (:)) (return [])
sausage :: (Misty m) => [m a] -> m [a]
sausage = foldr (banana2 (:)) (unicorn [])

-- bonus : use apple + furry'
banana2 :: (Misty m) => (a -> b -> c) -> m a -> m b -> m c
banana2 f ma mb = apple mb $ furry' f ma

-- bonus : use apple + banana2
banana3 :: (Misty m) => (a -> b -> c -> d) -> m a -> m b -> m c -> m d
banana3 f ma mb mc = apple mc $ banana2 f ma mb

-- bonus : use apple + banana3
banana4 :: (Misty m) => (a -> b -> c -> d -> e) -> m a -> m b -> m c -> m d -> m e
banana4 f ma mb mc md = apple md $ banana3 f ma mb mc

newtype State s a = State {
  state :: s -> (s, a)
}

instance Fluffy (State s) where
  furry :: (a -> b) -> State s a -> State s b
  furry f sa = State sb
    where sb = \s -> let (s', a) = state sa s
                      in (s', f a)

instance Misty (State s) where
  banana :: (a -> State s b) -> State s a -> State s b
  banana k sa = State $ \s -> let (s',  a) = state sa s
                               in state (k a) s'

  unicorn :: a -> State s a
  unicorn a = State $ \s -> (s,a)