Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment