Complete exercises from Applicative chapter
From "Haskell Programming from First Principles"...
This commit is contained in:
parent
406764f552
commit
71e79f5f5d
1 changed files with 213 additions and 0 deletions
213
scratch/haskell-programming-from-first-principles/applicative.hs
Normal file
213
scratch/haskell-programming-from-first-principles/applicative.hs
Normal file
|
@ -0,0 +1,213 @@
|
|||
module ApplicativeScratch where
|
||||
|
||||
import Data.Function ((&))
|
||||
|
||||
import Control.Applicative (liftA3)
|
||||
import qualified Data.List as List
|
||||
import qualified GHC.Base as Base
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- xs :: [(Integer, Integer)]
|
||||
-- xs = zip [1..3] [4..6]
|
||||
|
||||
-- added :: Maybe Integer
|
||||
-- added =
|
||||
-- (+3) <$> (lookup 3 xs)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- y :: Maybe Integer
|
||||
-- y = lookup 3 xs
|
||||
|
||||
-- z :: Maybe Integer
|
||||
-- z = lookup 2 xs
|
||||
|
||||
-- tupled :: Maybe (Integer, Integer)
|
||||
-- tupled = Base.liftA2 (,) y z
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- x :: Maybe Int
|
||||
-- x = List.elemIndex 3 [1..5]
|
||||
|
||||
-- y :: Maybe Int
|
||||
-- y = List.elemIndex 4 [1..5]
|
||||
|
||||
-- maxed :: Maybe Int
|
||||
-- maxed = Base.liftA2 max x y
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
xs = [1..3]
|
||||
ys = [4..6]
|
||||
|
||||
x :: Maybe Integer
|
||||
x = lookup 3 $ zip xs ys
|
||||
|
||||
y :: Maybe Integer
|
||||
y = lookup 2 $ zip xs ys
|
||||
|
||||
summed :: Maybe Integer
|
||||
summed = sum <$> Base.liftA2 (,) x y
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype Identity a = Identity a deriving (Eq, 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)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype Constant a b =
|
||||
Constant { getConstant :: a }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor (Constant a) where
|
||||
fmap _ (Constant x) = Constant x
|
||||
|
||||
instance Monoid a => Applicative (Constant a) where
|
||||
pure _ = Constant mempty
|
||||
(Constant x) <*> (Constant y) = Constant (x <> y)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
one = const <$> Just "Hello" <*> Just "World"
|
||||
|
||||
two :: Maybe (Integer, Integer, String, [Integer])
|
||||
two = (,,,) <$> (Just 90)
|
||||
<*> (Just 10)
|
||||
<*> (Just "Tierness")
|
||||
<*> (Just [1..3])
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data List a = Nil | Cons a (List a) deriving (Eq, Show)
|
||||
|
||||
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)
|
||||
|
||||
toList :: List a -> [a]
|
||||
toList Nil = []
|
||||
toList (Cons x xs) = x : toList xs
|
||||
|
||||
fromList :: [a] -> List a
|
||||
fromList [] = Nil
|
||||
fromList (x:xs) = Cons x (fromList xs)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype ZipList' a =
|
||||
ZipList' [a]
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- instance Eq a => EqProp (ZipList' a) where
|
||||
-- (ZipList' lhs) =-= (ZipList' rhs) =
|
||||
-- (take 1000 lhs) `eq` (take 1000 rhs)
|
||||
|
||||
instance Functor ZipList' where
|
||||
fmap f (ZipList' xs) = ZipList' $ fmap f xs
|
||||
|
||||
instance Applicative ZipList' where
|
||||
pure x = ZipList' (repeat x)
|
||||
(ZipList' fs) <*> (ZipList' xs) =
|
||||
ZipList' $ zipWith ($) fs xs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Validation e a
|
||||
= Failure e
|
||||
| Success a
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Functor (Validation e) where
|
||||
fmap f (Failure x) = Failure x
|
||||
fmap f (Success x) = Success (f x)
|
||||
|
||||
instance Monoid e => Applicative (Validation e) where
|
||||
pure = undefined
|
||||
(Success f) <*> (Success x) = Success (f x)
|
||||
_ <*> (Failure x) = Failure x
|
||||
(Failure x) <*> _ = Failure x
|
||||
|
||||
data Error
|
||||
= DivideByZero
|
||||
| StackOverflow
|
||||
deriving (Eq, Show)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
stops :: String
|
||||
stops = "pbtdkg"
|
||||
|
||||
vowels :: String
|
||||
vowels = "aeiou"
|
||||
|
||||
combos :: [a] -> [b] -> [c] -> [(a, b, c)]
|
||||
combos xs ys zs =
|
||||
liftA3 (,,) xs ys zs
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Pair a = Pair a a deriving Show
|
||||
|
||||
instance Functor Pair where
|
||||
fmap f (Pair x y) = Pair (f x) (f y)
|
||||
|
||||
instance Applicative Pair where
|
||||
pure x = Pair x x
|
||||
(Pair f g) <*> (Pair x y) = Pair (f x) (g x)
|
||||
|
||||
p :: Pair Integer
|
||||
p = Pair 1 2
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Two a b = Two a b
|
||||
|
||||
instance Functor (Two a) where
|
||||
fmap f (Two x y) = Two x (f y)
|
||||
|
||||
instance Monoid a => Applicative (Two a) where
|
||||
pure x = Two mempty x
|
||||
_ <*> _ = undefined
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Three a b c = Three a b c
|
||||
|
||||
instance Functor (Three a b) where
|
||||
fmap f (Three x y z) = Three x y (f z)
|
||||
|
||||
instance (Monoid a, Monoid b) => Applicative (Three a b) where
|
||||
pure x = Three mempty mempty x
|
||||
(Three a b f) <*> (Three x y z) = Three (a <> x) (b <> y) (f z)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Three' a b = Three' a b b
|
||||
|
||||
instance Functor (Three' a) where
|
||||
fmap f (Three' x y z) = Three' x (f y) (f z)
|
||||
|
||||
instance Monoid a => Applicative (Three' a) where
|
||||
pure x = Three' mempty x x
|
||||
(Three' a f g) <*> (Three' x y z) = Three' (a <> x) (f y) (g z)
|
Loading…
Reference in a new issue