A haskell implementation of the hangman game

hangman.hs

{-# OPTIONS -Wall #-}
import Control.Monad (when, unless)
import Data.Char (toLower)
import Data.List (transpose)
import System.Random (randomIO)

wordsPath :: FilePath
wordsPath = "/usr/share/dict/words"

addHangImage :: [String] -> [String]
addHangImage img =
    "=========" :
    "|    |" :
    map ("|   " ++) img

hangmanImages :: [[String]]
hangmanImages =
    transpose
    [ [ "   ", " O ", " O ", " O ", " O " , "_O " , "_O_"  ]
    , [ "   ", "   ", " | ", " | ", " | " , " | " , " | "  ]
    , [ "   ", "   ", "   ", "/  ", "/ \\", "/ \\", "/ \\" ]
    ]

data GameState = GameState
    { wordToGuess :: String
    , guesses :: String
    }

maxTries :: Int
maxTries = length hangmanImages - 1

isGuessed :: GameState -> Bool
isGuessed guessState =
    all isGuessedChar $ wordToGuess guessState
    where isGuessedChar c = c `elem` guesses guessState

isGameDone :: GameState -> Bool
isGameDone guessState =
  numberOfWrongGuesses guessState == maxTries || isGuessed guessState

numberOfGuesses :: GameState -> Int
numberOfGuesses guessState = length $ guesses guessState

numberOfWrongGuesses :: GameState -> Int
numberOfWrongGuesses guessState = length $ filter nomatch triedChars
    where
        nomatch c = c `notElem` wordToGuess guessState
        triedChars = guesses guessState

-- for one reason or another getChar also appends <CR>
-- so I implemented my own getChar and made sure empty input is refused
getAChar :: IO Char
getAChar = do
    line <- getLine
    case line of
        [] -> getAChar
        (c:_) -> return c

getANewChar :: GameState -> IO Char
getANewChar guessState = do
    putStrLn "Next char to guess"
    c <- getAChar
    if c `elem` guesses guessState
    then do
        putStrLn "Character already used in guesses."
        getANewChar guessState
    else
        return c

validWord :: String -> Bool
validWord word =
    '\'' `notElem` word &&
    map toLower word == word

newGame :: IO GameState
newGame = do
    contents <- readFile wordsPath
    let words' = filter validWord $ lines contents
    let wordcount = length words'
    randomNumber <- randomIO
    let randomWord = words' !! (randomNumber `mod` wordcount)
    return $ GameState randomWord []

displayState :: GameState -> IO ()
displayState guessState
    | not (isGameDone guessState) = do
          displayHangman currentHangmanIndex
          putStrLn $ unlines
              [ "Word to guess: " ++ showWordWithGuesses guessState
              , ""
              , "Chars guessed: " ++ guesses guessState
              ]
    | isGuessed guessState =
          putStrLn $ unlines
              [ "CONGRATULATIONS!"
              , "You correctly guessed the word " ++ wordToGuess guessState
              , " in " ++ show (numberOfGuesses guessState) ++ " tries "
              ]
    | otherwise = do
          displayHangman currentHangmanIndex
          putStrLn $ unlines
              [ "YOU FAILED!"
              , "You failed to guess the word " ++ wordToGuess guessState
              ]
    where
        currentHangmanIndex = numberOfWrongGuesses guessState

gameLoop :: GameState -> IO ()
gameLoop guessState = do
    -- Consider converting guessState to a sum type (Win, Lose,
    -- Playing) and pass that to displayState and also case on it here
    displayState guessState
    unless (isGameDone guessState) $ do
        c <- getANewChar guessState
        gameLoop $ guessState { guesses = guesses guessState ++ [c] }

displayHangman :: Int -> IO ()
displayHangman currentHangmanIndex = do
    let img = addHangImage (hangmanImages !! currentHangmanIndex)
    mapM_ putStrLn img
    putStrLn ""

showWordWithGuesses :: GameState -> String
showWordWithGuesses guessState = blankOrChar <$> wordToGuess guessState
    where
        blankOrChar c
            | c `elem` guesses guessState = c
            | otherwise = '_'

game :: IO ()
game = newGame >>= gameLoop

main :: IO ()
main = do
    game
    putStrLn "Play again? (y/n):"
    option <- getAChar
    when (option == 'y') main