Haskell Hangman

{-# LANGUAGE TupleSections #-}
import System.IO(hFlush, stdout)
import System.Random(randomRIO)
import Control.Arrow(second)
import Data.List(intersperse, intersect, nub)

dictFile = "dict.txt" -- first line is # of words, following lines are words

type Game = (String,[Char]) -- (word,guess)
data GameStatus
  = Win
  | Lose
  | Playing

instance Show GameStatus where
  show Win = "YOU WIN"
  show Lose = "YOU LOSE"
  show Playing = ""

addGuess :: Char -> Game -> Game
addGuess c = second (nub . (++ [c]))

goodGuesses :: Game -> Int
goodGuesses game@(word,guess) = length $ nub $ intersect word guess

badGuesses :: Game -> Int
badGuesses game@(word,guess) = length guess - goodGuesses game

revealed :: Game -> [Char]
revealed game@(word,guess) = reveal <$> word
  where
    reveal c | c `elem` guess = c
    reveal _ = '_'

statusOf :: Game -> GameStatus
statusOf game@(word,guess) =
  if badGuesses game >= 5 then
    Lose
  else if intersect word guess == word then
    Win
  else
    Playing

asciiMan :: [[String]]
asciiMan =
  [ ["     "
    ,"     "
    ,"     "
    ,"     "]
  , ["  O  "
    ,"     "
    ,"     "
    ,"     "]
  , ["  O  "
    ,"  |  "
    ,"  |  "
    ,"     "]
  , ["  O  "
    ,"--|--"
    ,"  |  "
    ,"     "]
  , ["  O  "
    ,"--|--"
    ,"  |  "
    ," /   "]
  , ["  O  "
    ,"--|--"
    ,"  |  "
    ," / \\ "] ]

asciiHangar :: [String] -> [String]
asciiHangar man =
  ["    /-----| "] ++
  (pad <$> man) ++
  ["          | "
  ,"----------+-"]
  where
    pad s = "  " ++ s ++ "   | "

asciiGame :: Game -> [String]
asciiGame game@(word,guess) = zipWith (++) hangar texts
  where
    bad = badGuesses game
    hangar = asciiHangar $ asciiMan !! (min 5 bad)
    texts = [ "word: " ++ intersperse ' ' (revealed game)
            , ""
            , "guesses: " ++ show (length guess)
            , " " ++ intersperse ' ' guess
            , ""
            , show (statusOf game)
            , "" ]

hangman :: Game -> IO ()
hangman game =
  mapM_ putStrLn (asciiGame game) >>
  case statusOf game of
    Win ->
      return ()

    Lose -> do
      putStr $ "\nthe word was: " ++ fst game
      putStr "\nplay again? (y/n) "
      hFlush stdout
      p <- getLine
      if p == "y" then
        main
      else
        return ()

    Playing -> do
      putStr "\nguess a letter: "
      hFlush stdout
      (c:_) <- getLine
      hangman $! (addGuess c game)

randomWord :: IO String
randomWord = do
  (x:xs) <- lines <$> readFile dictFile
  let n = read x
  k <- randomRIO (0,n-1)
  return $! xs !! k

main :: IO ()
main = randomWord >>= hangman . (,[])