Bulls and Cows game

BullsCows.hs

module BullsCows where

import Control.Monad (forever)
import Data.List
import Data.Sequence (Seq, adjust, fromList, index)
import System.Exit (exitSuccess)

parseInput :: String -> Maybe [Int]
parseInput s = do
    s <- (if length s /= 4 then Nothing else return s)
    s <- if and ((`elem` ['0'..'9']) <$> s) == False then Nothing else return s
    return $ (read . (:"")) <$> s

countAB :: [Int] -> [Int] -> (Int, Int)
countAB answer guess = go (zip answer guess) (fromList $ take 10 $ repeat 0) 0 0
    where go :: [(Int, Int)] -> Seq Int -> Int -> Int -> (Int, Int)
          go [] _ cA cB = (cA, cB)
          go ((a, g):ags) mem cA cB = case a == g of
                                        True  -> go ags mem (cA + 1) cB
                                        False -> let mem'  = adjust (+1) a mem
                                                     mem'' = adjust (subtract 1) g mem'
                                                     mem_a = index mem'' a
                                                     mem_b = index mem'' g
                                                     cB'   = if mem_a <= 0 then cB  + 1 else cB
                                                     cB''  = if mem_b >= 0 then cB' + 1 else cB'
                                                  in go ags mem'' cA cB''

showResult :: Int -> Int -> IO ()
showResult a b = putStrLn $ show a ++ "A" ++ show b ++ "B"

runloop :: [Int] -> IO ()
runloop a = forever $ do
    guess <- getLine
    case parseInput guess of
      Nothing -> putStrLn "Input guess is not in correct format" >> runloop a
      Just g  -> case (cA, cB) of
                   (4, 0) -> showResult cA cB >> putStrLn "Bingo!" >> exitSuccess
                   _      -> showResult cA cB >> runloop a
                 where (cA, cB) = countAB a g

main :: IO ()
main = do
    putStrLn "First, enter the secret anwer:"
    answer <- getLine
    case parseInput answer of
      Nothing  -> putStrLn "Input answer is not in correct format" >> exitSuccess
      (Just a) -> do
          putStrLn "--"
          putStrLn "Start guessing:"
          runloop a