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…
	
	Add table
		Add a link
		
	
		Reference in a new issue