Example implementation of the classic typeclasses Functor, Applicative & Monad for a simple newtype

classic-typeclasses.hs

{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

newtype Bag a = Bag {content :: a}
  deriving (Eq, Show)

instance Functor Bag where
  fmap fn Bag {content} = Bag {content = fn content}

bag = Bag {content = 10.0}

test = fmap (2.0 *) bag

instance Applicative Bag where
  pure a = Bag {content = a}

  (<*>) ff fa = do
    let Bag {content = fn} = ff
        Bag {content = a} = fa
    pure $ fn a

double :: Double -> Bag Double
double a = pure (a * 2.0)

doublerBag :: Bag (Double -> Double)
doublerBag = pure (* 2.0)

test1 = doublerBag <*> bag

applicativeIdentity = (pure id <*> Bag {content = 2}) == Bag {content = 2}

applicativeHomomorphism = (pure id <*> pure 2 :: Bag Integer) == pure (id 2)

-- (u >> v) >> w = u >> (v >> w)
applicativeComposition = do
  let u :: Bag (Integer -> Integer)
      u = return (+ 1)
      v = return (+ 2)
      w = return 3
      res1 = pure (.) <*> u <*> v <*> w
      res2 = u <*> (v <*> w)
  res1 == res2

applicativeInterchange = do
  let u :: Bag (Integer -> Integer)
      u = return (+ 1)
      y = 10
  (u <*> pure y) == (pure ($ y) <*> u)

instance Monad Bag where
  return = pure
  (>>=) Bag {content = a} fn = fn a

test2 :: Bag Integer
test2 = do
  res1 <- (pure 1 :: Bag Integer)
  res2 <- (pure 2 :: Bag Integer)
  return $ res1 + res2

leftIdentityLaw2 = do
  let x = 10
  let f = return
  (return x >>= f) == (f x :: Bag Integer)

leftIdentityLaw = do
  let a = 1.0
  (return a >>= return) == (return a :: Bag Double)

rightIdentityLaw2 = do
  let m :: Bag Integer
      m = return 10
  (m >>= return) == m

rightIdentityLaw = do
  let fa = Bag {content = 1}
  (fa >>= return) == fa

associativityLaw = do
  let fa :: Bag Integer
      fa = return 1
  ((fa >>= return) >>= return) == (fa >>= (\a -> return a >>= return))

main :: IO ()
main = do
  print bag
  print test
  print test1
  print test2
  let printLaw typeclass law value = print $ typeclass <> " " <> law <> " law: " <> show value
  let printApplicativeLaw = printLaw "applicative"
  let printMonadLaw = printLaw "monad"

  printApplicativeLaw "identity" applicativeIdentity
  printApplicativeLaw "composition" applicativeComposition
  printApplicativeLaw "homomorphism" applicativeHomomorphism
  printApplicativeLaw "interchange" applicativeInterchange

  printMonadLaw "left identity" leftIdentityLaw
  printMonadLaw "right identity" rightIdentityLaw
  printMonadLaw "associativity" associativityLaw