about summary refs log tree commit diff
path: root/scratch
diff options
context:
space:
mode:
authorWilliam Carroll <wpcarro@gmail.com>2020-06-18T10·05+0100
committerWilliam Carroll <wpcarro@gmail.com>2020-06-18T10·05+0100
commit406764f5521fc0a1ef713ffc4e99f897268cc536 (patch)
tree5b94cc74261b7b38639f4f5229402f8168b8b056 /scratch
parent766a2a6b78a4f8cc8681aa8330acd614c7d6121f (diff)
Complete exercises from Foldable chapter
I'm creating Haskell modules to host my attempts and solutions for the exercises
defined in each chapter of "Haskell Programming From First Principles".
Diffstat (limited to 'scratch')
-rw-r--r--scratch/haskell-programming-from-first-principles/foldable.hs107
1 files changed, 107 insertions, 0 deletions
diff --git a/scratch/haskell-programming-from-first-principles/foldable.hs b/scratch/haskell-programming-from-first-principles/foldable.hs
new file mode 100644
index 000000000000..5b59d9e9ba50
--- /dev/null
+++ b/scratch/haskell-programming-from-first-principles/foldable.hs
@@ -0,0 +1,107 @@
+module FoldableScratch where
+
+import Data.Function ((&))
+
+--------------------------------------------------------------------------------
+
+sum :: (Foldable t, Num a) => t a -> a
+sum xs =
+  foldr (+) 0 xs
+
+product :: (Foldable t, Num a) => t a -> a
+product xs =
+  foldr (*) 1 xs
+
+elem :: (Foldable t, Eq a) => a -> t a -> Bool
+elem y xs =
+  foldr (\x acc -> if acc then acc else y == x) False xs
+
+minimum :: (Foldable t, Ord a) => t a -> Maybe a
+minimum xs =
+  foldr (\x acc ->
+           case acc of
+             Nothing   -> Just x
+             Just curr -> Just (min curr x)) Nothing xs
+
+maximum :: (Foldable t, Ord a) => t a -> Maybe a
+maximum xs =
+  foldr (\x acc ->
+           case acc of
+             Nothing   -> Nothing
+             Just curr -> Just (max curr x)) Nothing xs
+
+-- TODO: How could I use QuickCheck to see if Prelude.null and this null return
+-- the same results for the same inputs?
+null :: (Foldable t) => t a -> Bool
+null xs =
+  foldr (\_ _ -> False) True xs
+
+length :: (Foldable t) => t a -> Int
+length xs =
+  foldr (\_ acc -> acc + 1) 0 xs
+
+toList :: (Foldable t) => t a -> [a]
+toList xs =
+  reverse $ foldr (\x acc -> x : acc) [] xs
+
+fold :: (Foldable t, Monoid m) => t m -> m
+fold xs =
+  foldr mappend mempty xs
+
+foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m
+foldMap f xs =
+  foldr (\x acc -> mappend (f x) acc) mempty xs
+
+--------------------------------------------------------------------------------
+
+data List a = Nil | Cons a (List a) deriving (Eq, Show)
+
+instance Foldable List where
+  foldr f acc (Cons x rest) = foldr f (f x acc) rest
+  foldr f acc Nil = acc
+
+fromList :: [a] -> List a
+fromList [] = Nil
+fromList (x:rest) = Cons x (fromList rest)
+
+--------------------------------------------------------------------------------
+
+data Constant a b = Constant b deriving (Eq, Show)
+
+-- TODO: Is this correct?
+instance Foldable (Constant a) where
+  foldr f acc (Constant x) = f x acc
+
+--------------------------------------------------------------------------------
+
+data Two a b = Two a b deriving (Eq, Show)
+
+instance Foldable (Two a) where
+  foldr f acc (Two x y) = f y acc
+
+--------------------------------------------------------------------------------
+
+data Three a b c = Three a b c deriving (Eq, Show)
+
+instance Foldable (Three a b) where
+  foldr f acc (Three x y z) = f z acc
+
+--------------------------------------------------------------------------------
+
+data Three' a b = Three' a b b deriving (Eq, Show)
+
+instance Foldable (Three' a) where
+  foldr f acc (Three' x y z) = acc & f z & f y
+
+--------------------------------------------------------------------------------
+
+data Four' a b = Four' a b b b deriving (Eq, Show)
+
+instance Foldable (Four' a) where
+  foldr f acc (Four' w x y z) = acc & f z & f y & f x
+
+--------------------------------------------------------------------------------
+
+filterF :: (Applicative f, Foldable t, Monoid (f a)) => (a -> Bool) -> t a -> f a
+filterF pred xs =
+  foldr (\x acc -> if pred x then pure x `mappend` acc else acc) mempty xs