Solutions for the exercises in Finding Success (and Failure) in Haskell

finding_success.hs

{-# 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