Solution to Alej's exercise

Mabes.hs

{- |

Fill in the Blank: Meet Mabes - the other Maybe type.

This exercise is all about defining common abstraction over Mabes, e.g.:

* Functor
* Applicative
* Monad
* Alternative
* MonadPlus
* Monoid

Everywhere you encounter a '_' is a place to fill in your
solution. These are typed-holes and will give you a compilation error
that's a tiny clue as to what's needed to fill in the blank.

Once you've gotten things to compile, load the file in ghci and run
`tests` to see if everything is working. Like so:

$ ghci Mabes.hs
> tests

Good luck!

-}
module Mabes where

import Control.Applicative
import Control.Monad
import Data.Monoid

data M a = J a | N deriving (Show, Eq)

instance Functor M where
  fmap f N = N
  fmap f (J x) = J (f x)

instance Applicative M where
  pure x = J x
  J l <*> J r = J (l r)
  _ <*> _ = N

instance Alternative M where
  empty = N
  J x <|> _ = J x
  N <|> J y = J y
  _ <|> _ = N

instance Monad M where
  return = pure
  N   >>= f = N
  J x >>= f = (f x)

instance Monoid a => Monoid (M a) where
  mempty = N
  mappend (J x) (J y) = J (x <> y)
  mappend (J x) N = J x
  mappend N (J y) = J y
  mappend _ _ = N

instance MonadPlus M where
 mzero = empty
 mplus = (<|>)

expect :: (Eq a, Show a) => a -> a -> String -> IO ()
expect f exp name =
 if f == exp
 then print $ "pass: " <> name
 else print $ "error: expecting (" <> show exp <> "), found (" <> show f <> ") in test: " <> name

expectInt :: M Int -> M Int -> String -> IO ()
expectInt = expect

expectString :: M String -> M String -> String -> IO ()
expectString = expect

tests :: IO ()
tests = sequence_
 [
   -- testing Functor
   expectInt ((+1) <$> J 1) (J 2) "fmap f J"
 , expectInt ((+1) <$> N) N "fmap f N"

   -- testing Applicative
 , expectInt ((+) <$> J 1 <*> J 2) (J 3) "<*> J J"
 , expectInt ((+) <$> N <*> J 1) N "<*> N J"
 , expectInt ((+) <$> J 1 <*> N) N "<*> J N"
 , expectInt ((+) <$> N <*> N) N "<*> N N"

  -- testing Alternative and MonadPlus
 , expectInt (J 1 <|> J 2) (J 1) "J <|> J"
 , expectInt (J 1 <|> N) (J 1) "J <|> N"
 , expectInt (N <|> J 2) (J 2) "N <|> J"
 , expectInt (N <|> N) N "N <|> N"

   -- testing Monoid
   -- these should probably be property tests:
   --   mempty <> x = x
   --   x <> mempty = x
   --   mempty <> mempty = mempty
 , expectString (J "cat" <> J "dog") (J "catdog") "J <> J"
 , expectString (J "cat" <> N) (J "cat") "J <> N"
 , expectString (N <> J "dog") (J "dog") "N <> J"
 , expectString (N <> N :: M String) (N) "N <> N"

   -- Testing Monad
 , expectInt (J 1 >>= (\a -> J $ a + 1)) (J 2) "J >>= J"
 , expectInt (J 1 >>= (\_ -> N)) N "J >>= N"
 , expectInt (N >>= (\a -> J $ a + 1)) N "N >>= J"
 , expectInt (N >>= (\_ -> N)) N "N >>= N"
 ]

main :: IO ()
main = tests