Some Notes on Haskell Pedagogy - Code

pedagogy.hs

{-# LANGUAGE InstanceSigs #-}

import Data.Monoid
import Test.QuickCheck
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes

data List a = EmptyList | ListElement a (List a)
  deriving (Eq, Show)

instance Functor List where
  fmap :: (a -> b) -> List a -> List b
  fmap f EmptyList = EmptyList
  fmap f (ListElement x xs) = ListElement (f x) (fmap f xs)

instance Arbitrary a => Arbitrary (List a) where
  arbitrary = do
    a <- arbitrary
    b <- arbitrary
    frequency [(1, return EmptyList),
               (3, return $ ListElement a (ListElement b EmptyList))]

instance Eq a => EqProp (List a) where (=-=) = eq

test :: IO ()
test = let trigger = undefined :: List (String, Int, Int) in
           quickBatch (functor trigger)

data F a b c = F a (b c)
  deriving (Eq, Show)

instance Functor b => Functor (F a b) where
  fmap :: (c -> d) -> F a b c -> F a b d
  fmap f (F a bc) = F a (fmap f bc)

instance Foldable b => Foldable (F a b) where
  foldMap :: Monoid m => (c -> m) -> F a b c -> m 
  foldMap f (F a bc) = foldMap f bc

instance Traversable b => Traversable (F a b) where
  traverse :: Applicative f => (c -> f d) -> F a b c -> f (F a b d)
  traverse f (F a bc) = F a <$> traverse f bc

data G a b c d e = G (a b c) (d e) e e
  deriving (Eq, Show)

instance Functor d => Functor (G a b c d) where
  fmap :: (e -> f) -> G a b c d e -> G a b c d f
  fmap f (G abc de e e') = G abc (fmap f de) (f e) (f e')

instance Foldable d => Foldable (G a b c d) where
  foldMap :: Monoid m => (e -> m) -> G a b c d e -> m
  foldMap f (G abc de e e') = foldMap f de <> f e <> f e'

instance Traversable d => Traversable (G a b c d) where
  traverse :: Applicative f => (e -> f g) -> G a b c d e -> f (G a b c d g)
  traverse f (G abc de e e') = G abc <$> traverse f de <*> f e <*> f e'

data A b c d e f g = A (b (c (d e) f) f) f

instance Functor (A b c d e f) where
  fmap :: (g -> h) -> A b c d e f g -> A b c d e f h
  fmap f (A bcdeff x) = A bcdeff x

data Q o p r = Q o (p -> r)

instance Functor (Q o p) where
  fmap :: (a -> b) -> Q o p a -> Q o p b
  fmap f (Q o pr) = Q o (f . pr)

data Greek a b c = Alpha | Beta b | Gamma a b c

instance Functor (Greek a b) where
  fmap :: (c -> d) -> Greek a b c -> Greek a b d
  fmap _ Alpha = Alpha
  fmap _ (Beta b) = Beta b
  fmap f (Gamma a b c) = Gamma a b (f c)