Complete Optional, List, Validation and ExactlyOne

README.md

@@ -1,4 +1,5 @@
-Exercise solutions from the Haskell Functional Programming course [fp-course](https://github.com/system-f/fp-course/).
+Exercise solutions from the Haskell Functional Programming course [fp-course](https://github.com/system-f/fp-course/). The tests are rewritten using Hspec and QuickCheck instead of their homegrown
+framework.
 
 [![](https://github.com/asarkar/fp-course-haskell/workflows/CI/badge.svg)](https://github.com/asarkar/fp-course-haskell/actions)
 

fp-course-haskell.cabal

@@ -42,7 +42,10 @@ test-suite fp-course-test
   main-is: Spec.hs
   other-modules:
       ListSpec
+      OptionalSpec
+      Property
       SpecHook
+      ValidationSpec
       Paths_fp_course_haskell
   hs-source-dirs:
       test
@@ -52,7 +55,8 @@ test-suite fp-course-test
       InstanceSigs
   ghc-options: -Werror -Weverything -Wno-missing-import-lists -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-safe-haskell-mode -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-kind-signatures -Wno-unused-top-binds -Wno-missing-export-lists -Wno-missing-role-annotations
   build-depends:
-      base >=4.7 && <5
+      QuickCheck
+    , base >=4.7 && <5
     , fp-course-haskell
     , hspec ==2.*
   default-language: Haskell2010

package.yaml

@@ -48,4 +48,4 @@ tests:
     defaults: hspec/hspec@main
     dependencies:
     - fp-course-haskell
-    # - QuickCheck
+    - QuickCheck

src/List.hs

@@ -74,7 +74,7 @@ foldLeft f b (h :. t) = let b' = f b h in b' `seq` foldLeft f b' t
 -- prop> \x -> x `headOr` Nil == x
 headOr :: a -> List a -> a
 headOr a Nil = a
-headOr _ (t :. _) = t
+headOr _ (x :. _) = x
 
 -- | The product of the elements of a list.
 --
@@ -86,11 +86,8 @@ headOr _ (t :. _) = t
 --
 -- >>> product (1 :. 2 :. 3 :. 4 :. Nil)
 -- 24
-product ::
-  List Int ->
-  Int
-product =
-  error "todo: Course.List#product"
+product :: List Int -> Int
+product = foldLeft (*) 1
 
 -- | Sum the elements of the list.
 --
@@ -101,23 +98,17 @@ product =
 -- 10
 --
 -- prop> \x -> foldLeft (-) (sum x) x == 0
-sum ::
-  List Int ->
-  Int
-sum =
-  error "todo: Course.List#sum"
+sum :: List Int -> Int
+sum = foldLeft (+) 0
 
 -- | Return the length of the list.
 --
 -- >>> length (1 :. 2 :. 3 :. Nil)
 -- 3
 --
 -- prop> \x -> sum (map (const 1) x) == length x
-length ::
-  List a ->
-  Int
-length =
-  error "todo: Course.List#length"
+length :: List a -> Int
+length = sum . map (const 1)
 
 -- | Map the given function on each element of the list.
 --
@@ -127,12 +118,8 @@ length =
 -- prop> \x -> headOr x (map (+1) infinity) == 1
 --
 -- prop> \x -> map id x == x
-map ::
-  (a -> b) ->
-  List a ->
-  List b
-map =
-  error "todo: Course.List#map"
+map :: (a -> b) -> List a -> List b
+map f = foldRight ((:.) . f) Nil
 
 -- | Return elements satisfying the given predicate.
 --
@@ -144,12 +131,10 @@ map =
 -- prop> \x -> filter (const True) x == x
 --
 -- prop> \x -> filter (const False) x == Nil
-filter ::
-  (a -> Bool) ->
-  List a ->
-  List a
-filter =
-  error "todo: Course.List#filter"
+filter :: (a -> Bool) -> List a -> List a
+filter f = foldRight g Nil
+  where
+    g x acc = if f x then x :. acc else acc
 
 -- | Append two lists to a new list.
 --
@@ -163,12 +148,8 @@ filter =
 -- prop> \x -> (x ++ y) ++ z == x ++ (y ++ z)
 --
 -- prop> \x -> x ++ Nil == x
-(++) ::
-  List a ->
-  List a ->
-  List a
-(++) =
-  error "todo: Course.List#(++)"
+(++) :: List a -> List a -> List a
+(++) = flip (foldRight (:.))
 
 infixr 5 ++
 
@@ -182,11 +163,8 @@ infixr 5 ++
 -- prop> \x -> headOr x (flatten (y :. infinity :. Nil)) == headOr 0 y
 --
 -- prop> \x -> sum (map length x) == length (flatten x)
-flatten ::
-  List (List a) ->
-  List a
-flatten =
-  error "todo: Course.List#flatten"
+flatten :: List (List a) -> List a
+flatten = flatMap id
 
 -- | Map a function then flatten to a list.
 --
@@ -198,22 +176,15 @@ flatten =
 -- prop> \x -> headOr x (flatMap id (y :. infinity :. Nil)) == headOr 0 y
 --
 -- prop> \x -> flatMap id (x :: List (List Int)) == flatten x
-flatMap ::
-  (a -> List b) ->
-  List a ->
-  List b
-flatMap =
-  error "todo: Course.List#flatMap"
+flatMap :: (a -> List b) -> List a -> List b
+flatMap f = foldRight ((++) . f) Nil
 
 -- | Flatten a list of lists to a list (again).
 -- HOWEVER, this time use the /flatMap/ function that you just wrote.
 --
 -- prop> \x -> let types = x :: List (List Int) in flatten x == flattenAgain x
-flattenAgain ::
-  List (List a) ->
-  List a
-flattenAgain =
-  error "todo: Course.List#flattenAgain"
+flattenAgain :: List (List a) -> List a
+flattenAgain = flatten
 
 -- | Convert a list of optional values to an optional list of values.
 --
@@ -234,11 +205,9 @@ flattenAgain =
 --
 -- >>> seqOptional (Empty :. map Full infinity)
 -- Empty
-seqOptional ::
-  List (Optional a) ->
-  Optional (List a)
-seqOptional =
-  error "todo: Course.List#seqOptional"
+seqOptional :: List (Optional a) -> Optional (List a)
+seqOptional Nil = Full Nil
+seqOptional (x :. xs) = (:.) P.<$> x P.<*> seqOptional xs
 
 -- | Find the first element in the list matching the predicate.
 --
@@ -256,12 +225,9 @@ seqOptional =
 --
 -- >>> find (const True) infinity
 -- Full 0
-find ::
-  (a -> Bool) ->
-  List a ->
-  Optional a
-find =
-  error "todo: Course.List#find"
+find :: (a -> Bool) -> List a -> Optional a
+find _ Nil = Empty
+find f (x :. xs) = if f x then Full x else find f xs
 
 -- | Determine if the length of the given list is greater than 4.
 --
@@ -276,11 +242,9 @@ find =
 --
 -- >>> lengthGT4 infinity
 -- True
-lengthGT4 ::
-  List a ->
-  Bool
-lengthGT4 =
-  error "todo: Course.List#lengthGT4"
+lengthGT4 :: List a -> Bool
+lengthGT4 (_ :. _ :. _ :. _ :. _ :. _) = True
+lengthGT4 _ = False
 
 -- | Reverse a list.
 --
@@ -293,11 +257,8 @@ lengthGT4 =
 -- prop> \x -> let types = x :: List Int in reverse x ++ reverse y == reverse (y ++ x)
 --
 -- prop> \x -> let types = x :: Int in reverse (x :. Nil) == x :. Nil
-reverse ::
-  List a ->
-  List a
-reverse =
-  error "todo: Course.List#reverse"
+reverse :: List a -> List a
+reverse = foldLeft (flip (:.)) Nil
 
 -- | Produce an infinite `List` that seeds with the given value at its head,
 -- then runs the given function for subsequent elements
@@ -307,12 +268,8 @@ reverse =
 --
 -- >>> let (x:.y:.z:.w:._) = produce (*2) 1 in [x,y,z,w]
 -- [1,2,4,8]
-produce ::
-  (a -> a) ->
-  a ->
-  List a
-produce _ _ =
-  error "todo: Course.List#produce"
+produce :: (a -> a) -> a -> List a
+produce f x = xs where xs = x :. map f xs
 
 -- | Do anything other than reverse a list.
 -- Is it even possible?
@@ -323,11 +280,8 @@ produce _ _ =
 -- prop> \x y -> let types = x :: List Int in notReverse x ++ notReverse y == notReverse (y ++ x)
 --
 -- prop> \x -> let types = x :: Int in notReverse (x :. Nil) == x :. Nil
-notReverse ::
-  List a ->
-  List a
-notReverse =
-  error "todo: Is it even possible?"
+notReverse :: List a -> List a
+notReverse = error "todo: Is it even possible?"
 
 ---- End of list exercises
 

src/Optional.hs

@@ -23,12 +23,10 @@ data Optional a
 --
 -- >>> fullOr 99 Empty
 -- 99
-fullOr ::
-  a ->
-  Optional a ->
-  a
-fullOr =
-  error "todo: Course.Optional#fullOr"
+fullOr :: a -> Optional a -> a
+fullOr x y = case y of
+  Empty -> x
+  Full z -> z
 
 -- | Map the given function on the possible value.
 --
@@ -37,12 +35,8 @@ fullOr =
 --
 -- >>> mapOptional (+1) (Full 8)
 -- Full 9
-mapOptional ::
-  (a -> b) ->
-  Optional a ->
-  Optional b
-mapOptional =
-  error "todo: Course.Optional#mapOptional"
+mapOptional :: (a -> b) -> Optional a -> Optional b
+mapOptional f = bindOptional (Full . f)
 
 -- | Bind the given function on the possible value.
 --
@@ -54,12 +48,10 @@ mapOptional =
 --
 -- >>> bindOptional (\n -> if even n then Full (n - 1) else Full (n + 1)) (Full 9)
 -- Full 10
-bindOptional ::
-  (a -> Optional b) ->
-  Optional a ->
-  Optional b
-bindOptional =
-  error "todo: Course.Optional#bindOptional"
+bindOptional :: (a -> Optional b) -> Optional a -> Optional b
+bindOptional f x = case x of
+  Empty -> Empty
+  Full y -> f y
 
 -- | Try the first optional for a value. If it has a value, use it; otherwise,
 -- use the second value.
@@ -75,12 +67,10 @@ bindOptional =
 --
 -- >>> Empty <+> Empty
 -- Empty
-(<+>) ::
-  Optional a ->
-  Optional a ->
-  Optional a
-(<+>) =
-  error "todo: Course.Optional#(<+>)"
+(<+>) :: Optional a -> Optional a -> Optional a
+(<+>) x y = case x of
+  Empty -> y
+  _ -> x
 
 -- | Replaces the Full and Empty constructors in an optional.
 --
@@ -89,13 +79,8 @@ bindOptional =
 --
 -- >>> optional (+1) 0 Empty
 -- 0
-optional ::
-  (a -> b) ->
-  b ->
-  Optional a ->
-  b
-optional =
-  error "todo: Course.Optional#optional"
+optional :: (a -> b) -> b -> Optional a -> b
+optional f x y = fullOr x (mapOptional f y)
 
 applyOptional :: Optional (a -> b) -> Optional a -> Optional b
 applyOptional f a = bindOptional (`mapOptional` a) f
@@ -108,15 +93,12 @@ contains _ Empty = False
 contains a (Full z) = a == z
 
 instance P.Functor Optional where
-  fmap =
-    M.liftM
+  fmap = M.liftM
 
 instance A.Applicative Optional where
-  (<*>) =
-    M.ap
-  pure =
-    Full
+  (<*>) = M.ap
+
+  pure = Full
 
 instance P.Monad Optional where
-  (>>=) =
-    flip bindOptional
+  (>>=) = flip bindOptional