wordle implementation in haskell

wordle.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M

import Control.Monad
import Data.Coerce
import Data.List
import Data.Maybe
import Data.String
import System.Console.ANSI (clearLine, cursorUpLine, setCursorColumn)
import System.Random
import Rainbow
import System.IO (hFlush, stdout)
import System.Exit (exitSuccess)

-- WordleWord

wordleWordLength :: Int
wordleWordLength = 5

newtype WordleWord = Word String
  deriving (Eq, Show)

parseWord :: String -> Maybe WordleWord
parseWord word | length word == wordleWordLength
               = Just $ Word word
parseWord _    = Nothing

-- Response

data LetterResponse = Red | Yellow | Green
  deriving (Eq, Show)

newtype Response = Response [LetterResponse]
  deriving (Eq, Show)

respondToGuess :: WordleWord -- guess
               -> WordleWord -- correct answer
               -> Response
respondToGuess (Word guess) (Word answer) = Response letter_responses
  where
    potential_yellows :: [Char]
    potential_yellows = [a | (g, a) <- zip guess answer, g /= a]

    letter_responses :: [LetterResponse]
    (_, letter_responses) = mapAccumL go potential_yellows (zip guess answer)

    go :: [Char]                   -- unused yellows
       -> (Char, Char)             -- guess and answer letter
       -> ([Char], LetterResponse) -- (remaining unused yellows, response)
    go unused_yellows (guess_char, answer_char)
      | guess_char == answer_char        = (unused_yellows, Green)
      | guess_char `elem` unused_yellows = (delete guess_char unused_yellows, Yellow)
      | otherwise                        = (unused_yellows, Red)

-- IO

prettyResponse :: WordleWord -> Response -> [Chunk]
prettyResponse (Word guess) (Response responses) =
  zipWith pretty_response guess responses
    where
      response_to_radiant :: LetterResponse -> Radiant
      response_to_radiant r = case r of
                                Green  -> green
                                Yellow -> yellow
                                Red    -> red

      pretty_response :: Char -> LetterResponse -> Chunk
      pretty_response char response =
        fore (response_to_radiant response) $ fromString [char]

clearPreviousLine :: IO ()
clearPreviousLine = do
  cursorUpLine 1
  clearLine
  hFlush stdout

errorMessageBuffer :: Int
errorMessageBuffer = 10

invalid :: String -- error message
        -> IO ()
invalid err = do
  clearPreviousLine
  putStr $ replicate errorMessageBuffer ' '
  putStr err
  setCursorColumn 0
  hFlush stdout

getGuess :: [WordleWord] -> IO WordleWord
getGuess word_list = do
  input <- getLine
  case parseWord input of
    Nothing -> do
      invalid $ "'" <> input <> "' does not have 5 letters"
      getGuess word_list
    Just guess ->
      if guess `notElem` word_list
         then do
            invalid $ "'" <> input <> "' is not a valid word"
            getGuess word_list
         else pure guess

respond :: WordleWord -- guess
      -> WordleWord -- answer
      -> IO ()
respond guess answer = do
  let response = respondToGuess guess answer
  clearPreviousLine
  putChunksLn (prettyResponse guess response)
  when (response == Response (replicate wordleWordLength Green)) exitSuccess

wordleTries :: Int
wordleTries = 6

main :: IO ()
main = do
  putChunkLn $ bold $ fromString "Wordle"
  final_words <- mapMaybe parseWord . lines <$> readFile "final-words.txt"
  guess_words <- mapMaybe parseWord . lines <$> readFile "guess-words.txt"

  (word_index, _) <- uniformR (0, length final_words) <$> initStdGen
  let the_word  = final_words !! word_index

  let all_words = final_words <> guess_words
  replicateM_ wordleTries $ do
    guess <- getGuess all_words
    respond guess the_word

  putStrLn $ "The word was " <> coerce the_word