tvl-depot/users/wpcarro/scratch/haskell-programming-from-first-principles/monad.hs

module MonadScratch where

import Data.Function ((&))
import Test.QuickCheck
import Test.QuickCheck.Checkers
import Control.Applicative (liftA2)
import qualified Control.Monad as Monad

--------------------------------------------------------------------------------

bind :: Monad m => (a -> m b) -> m a -> m b
bind f x = Monad.join $ fmap f x

--------------------------------------------------------------------------------

fTrigger :: Functor f => f (Int, String, [Int])
fTrigger = undefined

aTrigger :: Applicative a => a (Int, String, [Int])
aTrigger = undefined

mTrigger :: Monad m => m (Int, String, [Int])
mTrigger = undefined

--------------------------------------------------------------------------------

data Sum a b
  = Fst a
  | Snd b
  deriving (Eq, Show)

instance (Eq a, Eq b) => EqProp (Sum a b) where
  (=-=) = eq

instance (Arbitrary a, Arbitrary b) => Arbitrary (Sum a b) where
  arbitrary = frequency [ (1, Fst <$> arbitrary)
                        , (1, Snd <$> arbitrary)
                        ]

instance Functor (Sum a) where
  fmap f (Fst x) = Fst x
  fmap f (Snd x) = Snd (f x)

instance Applicative (Sum a) where
  pure x = Snd x
  (Snd f) <*> (Snd x) = Snd (f x)
  (Snd f) <*> (Fst x) = Fst x
  (Fst x) <*> _ = Fst x

instance Monad (Sum a) where
  (Fst x) >>= _ = Fst x
  (Snd x) >>= f = f x

--------------------------------------------------------------------------------

data Nope a = NopeDotJpg deriving (Eq, Show)

instance Arbitrary (Nope a) where
  arbitrary = pure NopeDotJpg

instance EqProp (Nope a) where
  (=-=) = eq

instance Functor Nope where
  fmap f _ = NopeDotJpg

instance Applicative Nope where
  pure _ = NopeDotJpg
  _ <*> _ = NopeDotJpg

instance Monad Nope where
  NopeDotJpg >>= f = NopeDotJpg

--------------------------------------------------------------------------------

data BahEither b a
  = PLeft a
  | PRight b
  deriving (Eq, Show)

instance (Arbitrary b, Arbitrary a) => Arbitrary (BahEither b a) where
  arbitrary = frequency [ (1, PLeft <$> arbitrary)
                        , (1, PRight <$> arbitrary)
                        ]

instance (Eq a, Eq b) => EqProp (BahEither a b) where
  (=-=) = eq

instance Functor (BahEither b) where
  fmap f (PLeft x) = PLeft (f x)
  fmap _ (PRight x) = PRight x

instance Applicative (BahEither b) where
  pure = PLeft
  (PRight x) <*> _ = PRight x
  (PLeft f) <*> (PLeft x) = PLeft (f x)
  _ <*> (PRight x) = PRight x

instance Monad (BahEither b) where
  (PRight x) >>= _ = PRight x
  (PLeft x) >>= f = f x

--------------------------------------------------------------------------------

newtype Identity a = Identity a
  deriving (Eq, Ord, Show)

instance Functor Identity where
  fmap f (Identity x) = Identity (f x)

instance Applicative Identity where
  pure = Identity
  (Identity f) <*> (Identity x) = Identity (f x)

instance Monad Identity where
  (Identity x) >>= f = f x

--------------------------------------------------------------------------------

data List a
  = Nil
  | Cons a (List a)
  deriving (Eq, Show)

instance Arbitrary a => Arbitrary (List a) where
  arbitrary = frequency [ (1, pure Nil)
                        , (1, Cons <$> arbitrary <*> arbitrary)
                        ]

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

fromList :: [a] -> List a
fromList [] = Nil
fromList (x:xs) = Cons x (fromList xs)

instance Semigroup (List a) where
  Nil <> xs = xs
  xs <> Nil = xs
  (Cons x xs) <> ys =
    Cons x (xs <> ys)

instance Functor List where
  fmap f Nil = Nil
  fmap f (Cons x xs) = Cons (f x) (fmap f xs)

instance Applicative List where
  pure x = Cons x Nil
  Nil <*> _ = Nil
  _ <*> Nil = Nil
  (Cons f fs) <*> xs =
    (f <$> xs) <> (fs <*> xs)

instance Monad List where
  Nil >>= _ = Nil
  (Cons x xs) >>= f = (f x) <> (xs >>= f)

--------------------------------------------------------------------------------

j :: Monad m => m (m a) -> m a
j = Monad.join

l1 :: Monad m => (a -> b) -> m a -> m b
l1 = Monad.liftM

l2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c
l2 = Monad.liftM2

a :: Monad m => m a -> m (a -> b) -> m b
a = flip (<*>)

meh :: Monad m => [a] -> (a -> m b) -> m [b]
meh xs f = flipType $ f <$> xs

flipType :: Monad m => [m a] -> m [a]
flipType [] = pure mempty
flipType (m:ms) =
  m >>= (\x -> (x:) <$> flipType ms)