Skip to content
{{ message }}

Instantly share code, notes, and snippets.

# jezen/finding_success.hs

Created Apr 9, 2019
Solutions for the exercises in Finding Success (and Failure) in Haskell
 {-# LANGUAGE ApplicativeDo #-} -- My solutions for the exercises in Finding Success (and Failure) in Haskell -- by Julie Moronuki and Chris Martin import Data.Char (isAlphaNum) import Data.List (sort) import Data.List.NonEmpty (NonEmpty) import Data.Validation -------------------------------------------------------------------------------- -- | Ex. 1 absVal :: (Num a, Ord a) => a -> a absVal a = case a < 0 of True -> negate a False -> a -- Implemented with a guard instead absVal' :: (Num a, Ord a) => a -> a absVal' a | a < 0 = negate a | otherwise = a -------------------------------------------------------------------------------- -- | Ex. 2 validateUsernamePassword :: String -> String -> String validateUsernamePassword user pass = case (null user, null pass) of (True, True) -> "Empty username and password" (True, _) -> "Empty username" (_, True) -> "Empty password" _ -> "Okay" -------------------------------------------------------------------------------- -- | Ex. 3 -- -- The example given does not typecheck because the first case evaluates to a -- list, when actually it should evaluate to an `a` from inside the list, -- according to the type signature. -- -- Since there is no `a` to produce, it is not possible to write this function. -- -- @ -- head' :: [a] -> a -- head' [] = [] -- head' (x:xs) = x -- @ -------------------------------------------------------------------------------- -- | Ex. 4 tail' :: [a] -> Maybe [a] tail' [] = Nothing tail' [a] = Nothing tail' (_:xs) = Just xs head' :: [a] -> Maybe a head' [] = Nothing head' (x:_) = Just x -------------------------------------------------------------------------------- -- | Ex. 5 checkPalindrome :: IO () checkPalindrome = do putStr "Please enter a word\n> " a <- getLine print \$ msg a where isWord :: [a] -> Bool isWord = not . null msg :: Eq a => [a] -> String msg a | not \$ isWord a = "Invalid input" | a == reverse a = "Yes, this is a palindrome" | otherwise = "No, that is not a palindrome" -------------------------------------------------------------------------------- -- | Ex. 6 speak1337 :: IO () speak1337 = do putStr "OMG I love the map de_dust. I can pwn so many n00bs on it!\n> " a <- getLine print \$ to1337 a where to1337 :: String -> String to1337 = map subChar subChar :: Char -> Char subChar 'e' = '3' subChar 'o' = '0' subChar 'a' = '4' subChar 'l' = '1' subChar a = a -------------------------------------------------------------------------------- -- | Ex. 7 checkPasswordLengthM :: String -> Maybe String checkPasswordLengthM p = if length p `elem` [10..20] then Just p else Nothing -------------------------------------------------------------------------------- -- | Ex. 8 -- -- This function demonstrates the classic problem of walking indentation. I -- think the entire point of this book is avoiding code like this. validatePasswordM :: String -> Maybe String validatePasswordM p = case cleanWhitespaceM p of Nothing -> Nothing Just p1 -> case requireAlphaNumM p1 of Nothing -> Nothing Just p2 -> checkPasswordLengthM p2 -- It is not clear to me why this function is necessary. There is no reason -- why whitespace characters should not be included in a password. Failing -- on an empty string is also unnecessary (apart from to justify their -- recursive approach), as this would be caught by `checkPasswordLength` cleanWhitespaceM :: String -> Maybe String cleanWhitespaceM "" = Nothing cleanWhitespaceM a = Just \$ filter (/= ' ') a requireAlphaNumM :: String -> Maybe String requireAlphaNumM a = if all isAlphaNum a then Just a else Nothing -------------------------------------------------------------------------------- -- | Ex. 9 -- -- My implementation of `requireAlphaNum` evaluates to `Just ""` for the empty -- string because `all isAlphaNum ""` evaluates to True. The `all` function -- only evaluates to False when any of the elements in the list do not conform -- to the test function. There are no elements to fail the test, therefore the -- test does not fail. -------------------------------------------------------------------------------- -- | Ex. 10 reverseLine :: IO () reverseLine = getLine >>= print . reverse reverseLine' :: IO () reverseLine' = do a <- getLine print \$ reverse a -------------------------------------------------------------------------------- -- | Ex. 11 bindMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b bindMaybe Nothing _ = Nothing bindMaybe (Just a) f = f a -------------------------------------------------------------------------------- -- | Ex. 12 -- This is similar to Either, but the Left has been given a concrete type data StrVal a = Str String | Val a deriving Show bindStrVal :: StrVal a -> (a -> StrVal b) -> StrVal b bindStrVal (Str s) _ = Str s bindStrVal (Val a) f = f a -------------------------------------------------------------------------------- -- | Ex. 13 cleanWhitespaceE :: String -> Either String String cleanWhitespaceE "" = Left "Your password cannot be empty" cleanWhitespaceE a = Right \$ filter (/= ' ') a requireAlphaNumE :: String -> Either String String requireAlphaNumE a | all isAlphaNum a = Right a | otherwise = Left "Your password cannot contain special characters" checkPasswordLengthE :: String -> Either String String checkPasswordLengthE p | length p `elem` [10..20] = Right p | otherwise = Left "Your password must be between 10 and 20\ \ characters in length" validatePasswordE :: String -> Either String String validatePasswordE p = cleanWhitespaceE p >>= requireAlphaNumE >>= checkPasswordLengthE -------------------------------------------------------------------------------- -- | Ex. 14 -- -- Validation stops on the first failure it encounters. -------------------------------------------------------------------------------- -- | Ex. 15 printTestResult :: Either String () -> IO () printTestResult r = case r of Left err -> putStrLn err Right () -> putStrLn "All tests passed." eq :: (Eq a, Show a) => Int -> a -> a -> Either String () eq n actual expected = case actual == expected of True -> Right () False -> Left \$ unlines [ "Test " ++ show n , " Expected: " ++ show expected , " But got: " ++ show actual ] test :: IO () test = printTestResult \$ do eq 1 (cleanWhitespaceE "") (Left "Your password cannot be empty") eq 2 (cleanWhitespaceE " foo bar ") (Right "foobar") -- Would be better to use QuickCheck here eq 3 (requireAlphaNumE "foobar!") \$ Left "Your password cannot contain special characters" eq 4 (requireAlphaNumE "foobar") (Right "foobar") eq 5 (checkPasswordLengthE "") \$ Left "Your password must be between 10 and 20 characters in length" eq 6 (checkPasswordLengthE "strongpass") (Right "strongpass") -------------------------------------------------------------------------------- -- | Ex. 16 -- -- For a type to be a monad, it must have the kind * -> *. The (,) type cannot -- be a monad until we partially apply it. This works the same way for Either -- (and any types isomorphic to Either) -- -- String :: * -- [] :: * -> * -- (,) :: * -> * -> * -- (,) Int :: * -> * -- -- data Pair a = Pair a a -- Pair :: * -> * -------------------------------------------------------------------------------- -- | Ex. 17 newtype Username = Username String deriving Show newtype Password = Password String deriving Show newtype Error = Error String deriving Show cleanWhitespaceE' :: String -> Either Error String cleanWhitespaceE' "" = Left \$ Error "Your password cannot be empty" cleanWhitespaceE' a = Right \$ filter (/= ' ') a requireAlphaNumE' :: String -> Either Error String requireAlphaNumE' a | all isAlphaNum a = Right a | otherwise = Left \$ Error "Your password cannot contain special characters" checkUsernameLength :: String -> Either Error Username checkUsernameLength u | length u `elem` [3..12] = Right \$ Username u | otherwise = Left \$ Error "Your username must be between 3 and 12\ \ characters in length" validateUsername :: Username -> Either Error Username validateUsername (Username u) = cleanWhitespaceE' u >>= requireAlphaNumE' >>= checkUsernameLength -------------------------------------------------------------------------------- -- | Ex. 18 -- -- I think it makes more sense to use either a range or two integer arguments -- here than a single integer, so the user can enforce both a minimum and -- maximum boundary. I'll go with two integer arguments. checkLength :: Int -> Int -> String -> Either Error String checkLength low high s = if length s >= low && length s <= high then Right s else Left \$ Error \$ "Input must be between " ++ show low ++ " and " ++ show high ++ " characters in length" -------------------------------------------------------------------------------- -- | Ex. 19 validatePassword :: Password -> Either Error Password validatePassword (Password p) = Password <\$> checkLength 8 20 p ex19 :: IO () ex19 = putStr "Please enter a password.\n> " >> Password <\$> getLine >>= print . validatePassword -------------------------------------------------------------------------------- -- | Ex. 20 checkPasswordLengthE' :: String -> Either Error Password checkPasswordLengthE' p | length p `elem` [10..20] = Right \$ Password p | otherwise = Left \$ Error "Your password must be between 10 and 20\ \ characters in length" validatePassword' :: Password -> Either Error Password validatePassword' (Password p) = do a <- cleanWhitespaceE' p b <- requireAlphaNumE' a checkPasswordLengthE' b -------------------------------------------------------------------------------- -- | Ex. 21 data User = User Username Password deriving Show makeUserTmpPassword :: Username -> Either Error User makeUserTmpPassword name = User <\$> validateUsername name <*> pure (Password "strongpass") -------------------------------------------------------------------------------- -- | Ex. 22 pureMaybe :: a -> Maybe a pureMaybe a = Just a pureEither :: a -> Either l a pureEither a = Right a -------------------------------------------------------------------------------- -- | Ex. 23 -- -- Hooray for type inference! ex23 :: IO () ex23 = let checkAnagram a b | sort a == sort b = "These words are anagrams." | otherwise = "These words are not anagrams." promptWord1 = putStr "Please enter a word.\n> " >> getLine promptWord2 = putStr "Please enter a second word.\n> " >> getLine in checkAnagram <\$> promptWord1 <*> promptWord2 >>= print -------------------------------------------------------------------------------- -- | Ex. 24 -- -- Although Either is a monad, we can still write this function in an -- Applicative style because Applicative is a superclass of Monad, i.e., every -- Monad is also an Applicative. validatePasswordA :: String -> Either String String validatePasswordA password = case cleanWhitespaceE password of Left err -> Left err Right pw -> requireAlphaNumE pw *> checkPasswordLengthE pw -------------------------------------------------------------------------------- -- | Ex. 25 -- -- Oops. I already wrote the one-liner in ex23. promptWord1 :: IO String promptWord1 = putStr "Please enter a word.\n> " *> getLine -- While I can observe that the right bird produces a value and the left bird -- doesn't, I haven't yet properly understood _why_ that is. Is it because it's -- giving me back the value on the right side of the operator? Some more -- applicative exercises would be a good idea. -- -- Maybe I'm right? I also observe that I can make it work in reverse, i.e.: -- @ -- getLine <* putStrLn "foo" -- @ promptWord2 :: IO String promptWord2 = putStr "Please enter a second word.\n> " *> getLine -------------------------------------------------------------------------------- -- | Ex. 26 newtype ErrorV = ErrorV [String] deriving Show instance Semigroup ErrorV where ErrorV xs <> ErrorV ys = ErrorV (xs <> ys) requireAlphaNumV :: String -> Validation ErrorV String requireAlphaNumV a | all isAlphaNum a = Success a | otherwise = Failure \$ ErrorV ["Your password cannot contain special characters"] checkUsernameLengthV :: Username -> Validation ErrorV Username checkUsernameLengthV (Username u) | length u `elem` [3..12] = Success \$ Username u | otherwise = Failure \$ ErrorV ["Your username must be between 3 and 12 characters in length"] checkPasswordLengthV :: Password -> Validation ErrorV Password checkPasswordLengthV (Password u) | length u `elem` [10..20] = Success \$ Password u | otherwise = Failure \$ ErrorV ["Your password must be between 10 and 20 characters in length"] validateUsernameV :: Username -> Validation ErrorV Username validateUsernameV (Username username) = case cleanWhitespaceE' username of Left (Error err) -> Failure \$ ErrorV [err] Right uname -> requireAlphaNumV uname *> checkUsernameLengthV (Username uname) validatePasswordV :: Password -> Validation ErrorV Password validatePasswordV (Password pass) = case cleanWhitespaceE' pass of Left (Error err) -> Failure \$ ErrorV [err] Right pass' -> requireAlphaNumV pass' *> checkPasswordLengthV (Password pass') makeUser :: Username -> Password -> Validation ErrorV User makeUser name pass = do name' <- validateUsernameV name pass' <- validatePasswordV pass pure \$ User name' pass' -------------------------------------------------------------------------------- -- | Ex. 27 -- -- I'm going to skip this exercise, because I'm already familiar with Text -- through my years of working with it in Yesod. I won't learn anything by -- changing all the strings in the file to their text equivalent. -------------------------------------------------------------------------------- -- | Ex. 28 newtype Error28 = Error28 String deriving Show instance Semigroup Error28 where Error28 a <> Error28 b = Error28 \$ unlines [ a, b ] -------------------------------------------------------------------------------- -- | Ex. 29 -- -- This seems pointless, other than to motivate later examples of `coerce`. mkError :: String -> Error mkError = Error -------------------------------------------------------------------------------- -- | Ex. 30 newtype Error30 a = Error30 (NonEmpty a) deriving Show
to join this conversation on GitHub. Already have an account? Sign in to comment