逆ポーランド記法を対話的に計算

RPolish.hs

module RPolish where
import Data.Char
import Data.Maybe

calc :: IO ()
calc = do
    putStr "> "
    line <- getLine
    if not (head line == '0')
        then do
            -- このへん見にくいので何とかしたい
            if checkFormula line
                then do
                    let res = calculate line
                    putStrLn $ if length res == 1 then show $ head res else "Worng Formula"
                else putStrLn "Wrong Formula"
            calc
        else putStrLn "Bye Bye"

calculate :: String -> [Float]
calculate = (foldl f []) . words
    where
        f :: [Float] -> String -> [Float]
        f (x:y:zs) "+" = (y + x):zs
        f (x:y:zs) "-" = (y - x):zs
        f (x:y:zs) "*" = (y * x):zs
        f (x:y:zs) "/" = (y / x):zs
        f (x:y:zs) "^" = (y ** x):zs
        f xs y = read y : xs

checkFormula :: String -> Bool
checkFormula formula = check $ words formula
    where
        check :: [String] -> Bool
        check []     = True
        check (x:xs) =
            if compareAll x ["+", "-", "*", "/", "^"]
                then check xs
                else case maybeRead x :: Maybe Float of
                    Just _  -> check xs
                    Nothing -> False

maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads

compareAll :: String -> [String] -> Bool
compareAll w cand = f w cand
    where
        f :: String -> [String] -> Bool
        f w []    = False
        f w (x:xs) = if w == x then True else f w xs

-- 挫折 --
--maybeCalculate :: String -> [Float]
--maybeCalculate = (foldl f []) . words
--    where
--        f (x:y:zs) "+" = (y + x):zs
--        f (x:y:zs) "-" = (y - x):zs
--        f (x:y:zs) "*" = (y * x):zs
--        f (x:y:zs) "/" = (y / x):zs
--        f (x:y:zs) "^" = (y ** x):zs
--        f xs y = case maybeRead y :: Maybe Float of
--            Just r  -> r:xs
--            Nothing -> 0.0:xs