すごいH本で取り上げられていた逆ポーランド記法電卓で遊んだ

RPMCalc.hs

import Data.List
import Control.Monad
import System.IO

type Result = Either String 

readMaybe :: (Read a) => String -> Result a
readMaybe st = case reads st of [(x,"")] -> Right x
                                _ -> Left ("Parse Error: \"" ++ st ++ "\"")

ifr :: Bool -> a -> String -> Result a
ifr p x msg = if p then Right x else Left msg


folds :: [Double] -> String -> Result [Double]
folds (x:y:ys) "*" = Right ((y * x):ys)
folds (x:y:ys) "+" = Right ((y + x):ys)
folds (x:y:ys) "-" = Right ((y - x):ys)
folds (x:y:ys) "/" = ifr (x /= 0) ((y / x):ys) ("Zero Division: " ++ show y ++ " / " ++ show x)
folds (x:y:ys) "^" = Right ((y ** x):ys)

folds (x:y:ys) "~" = ifr (y <= x) ([y..x] ++ ys) ("Invalid Range: " ++ show y ++ " ~ " ++ show x)

folds (x:y:ys) "log"
    | x <= 0 = Left ("Non-positive Value: " ++ expr)
    | y <= 0 || y == 1 = Left ("Invalid Base: " ++ expr)
    | otherwise = Right (logBase y x:ys)
    where expr = "log " ++ show y ++ " " ++ show x
folds (x:xs) "ln" =    ifr (x > 0) (log x:xs) ("Non-positive Value: ln " ++ show x)
folds (x:xs) "lg" =    ifr (x > 0) (logBase 2 x:xs) ("Non-positive Value: lg " ++ show x )
folds (x:xs) "Log" =   ifr (x > 0) (logBase 10 x:xs) ("Non-positive Value: Log " ++ show x)

folds (x:xs) "sqrt" = ifr (x >= 0) (sqrt x:xs) ("Not a Real Number: sqrt " ++ show x)

folds xs "\\+" = Right [sum xs]
folds xs "\\*" = Right [product xs]

folds xs numberString = liftM (:xs) (readMaybe numberString)


eval :: String -> Result Double
eval st = do
    r:rs <- foldM folds [] (words st)
    ifr (null rs) r ("Multiple Answer: " ++ show (r:rs))

printEither :: (Show b) => Either String b -> IO ()
printEither (Left st) = putStrLn st
printEither (Right b)  = print b

main = do
    iseof <- hIsEOF stdin
    if iseof
        then return ()
        else do
            input <- hGetLine stdin
            if null input
              then return ()
              else do
                  printEither $ eval input
                  main