a981bb0d4a
From "Haskell Programming from First Principles"... I have completed all of the exercises in the book thus far, but I only recently dedicated a Haskell module for each chapter. Previously I created ad hoc modules per exercise, per chapter... it was chaotic.
178 lines
4.2 KiB
Haskell
178 lines
4.2 KiB
Haskell
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)
|