Hangman in Haskell

hangman.hs

import Control.Monad
import Data.Bifunctor
import Data.Function
import Data.Char
import Data.List
import Data.Maybe
import System.Random (randomRIO)
import System.IO

-- Each character and whether that character is visible, and the set of mistakes
type GameState = ([(Bool, Char)], String)

-- A default game of hangman. All alpha characters are hidden and no mistakes have been made
createGame :: String -> GameState
createGame word = ([(not (isAlpha c), c) | c <- word], [])

-- Just True or False if the game is won or lost, or Nothing if still playing
gameOutcome :: GameState -> Maybe Bool
gameOutcome (word, mistakes) | length mistakes >= 6 = Just False
                             | all fst word         = Just True
                             | otherwise            = Nothing

-- Take a character and either mark matching hangman characters visible, or if
-- there are no matching characters, insert it into the mistakes set.
nextState :: GameState -> Char -> GameState
nextState ([], mistakes) c = ([], mistakes `union` [toLower c])
nextState (x:xs, mistakes) c = nextState (xs, mistakes) c &
    if toLower (snd x) == toLower c
    then bimap ((True, snd x):) (const mistakes) -- Mark visibility as true and cancel modifying mistakes.
    else first (x :)                             -- Leave visibility alone

-- Doesn't progress the game state if the game is finished
nextState' :: GameState -> Char -> GameState
nextState' gs | isJust (gameOutcome gs) = const gs
              | otherwise               = nextState gs

-- Show the current state of the game as a string
showState :: GameState -> String
showState gs@(word, mistakes) = showWord ++ " (" ++ showLives ++ ") (" ++ mistakes ++ ")"
  where showWord | isJust (gameOutcome gs) = map snd word
                 | otherwise               = map (\(v, c) -> if v then c else '_') word
        showLives = show lives ++ if lives == 1 then " life" else " lives"
        lives  = 6 - length mistakes

-- Play a game using input from the user. Return true if user won.
gameLoop :: GameState -> IO Bool
gameLoop game = do
    putStr (showState game)
    case gameOutcome game of
        Just x -> return x
        Nothing -> prompt >> getLine >>= gameLoop . foldl nextState' game . filter isAlpha
  where prompt = putStr "> " >> hFlush stdout

-- Pick a random word from the system dictionary
pickWord :: IO String
pickWord = pickRandom =<< dictionary
  where pickRandom xs = liftM (xs !!) (randomRIO (0, length xs - 1))
        dictionary = lines <$> readFile "/usr/share/dict/words"

main :: IO ()
main = forever (createGame <$> pickWord >>= gameLoop >>= putStrLn . msg)
  where msg True  = " - You won!\n"
        msg False = " - You lost...\n"