オレ版コレ http://qiita.com/bra_cat_ket/items/c6d338e33e6d02141a9f

grade.hs

module Main where

import Data.Maybe (isJust)
import Text.Read (readMaybe)
import Control.Monad (join)

main :: IO ()
main = do
  let initState = (Nothing, GradesCounter 0 0 0 0)
  _ <- doWhileM updateGrade (isJust . fst) initState
  return ()

data Grade = A | B | C | F deriving (Show, Eq)

data GradesCounter = GradesCounter
                   { countA :: Int
                   , countB :: Int
                   , countC :: Int
                   , countF :: Int
                   } deriving (Show)

doWhileM :: Monad m => (a -> m a) -> (a -> Bool) -> a -> m a
doWhileM f p a = whileDoM f p =<< f a

whileDoM :: Monad m => (a -> m a) -> (a -> Bool) -> a -> m a
whileDoM f p a
  | p a       = whileDoM f p =<< f a
  | otherwise = return a

updateGrade :: (Maybe Grade, GradesCounter) -> IO (Maybe Grade, GradesCounter)
updateGrade (_, counter) = do
  grade <- getGrade
  let (_, counter') = addGrade (grade, counter)
  print counter'
  return (grade, counter')

addGrade :: (Maybe Grade, GradesCounter) -> (Maybe Grade, GradesCounter)
addGrade (Just A, counter) = (Just A, counter { countA = countA counter + 1 })
addGrade (Just B, counter) = (Just B, counter { countB = countB counter + 1 })
addGrade (Just C, counter) = (Just C, counter { countC = countC counter + 1 })
addGrade (Just F, counter) = (Just F, counter { countF = countF counter + 1 })
addGrade (Nothing, counter) = (Nothing, counter)

getGrade :: IO (Maybe Grade)
getGrade = do
  putStrLn "Put a grade here: "
  (join . fmap toGrade . readMaybe) <$> getLine

toGrade :: Int -> Maybe Grade
toGrade n
  |  0 <= n && n < 60    = Just F
  | 60 <= n && n < 70    = Just C
  | 70 <= n && n < 80    = Just B
  | 80 <= n && n <= 100  = Just A
  | otherwise            = Nothing