rpn.hs

{-# LANGUAGE TupleSections #-}

module RPN (main) where

import Control.Applicative ((<$>))
import Control.Monad (forM_, unless)
import Control.Monad.Instances ()
import Data.List (find, intercalate)
import Data.Maybe (listToMaybe)
import System.IO (stdout, hFlush)
import Text.Printf (printf)


type Stack = [Double]
type Result = Either String (Maybe Double, Stack)
type Operator = Stack -> Result

data Operation = Operation
    { opName :: String
    , opFn   :: Operator
    , opHelp :: String
    }

whileJust_ :: Monad m => (a -> m (Maybe a)) -> a -> m ()
whileJust_ f = go where go m = f m >>= maybe (return ()) go

maybeToEither :: a -> (b -> b') -> Maybe b -> Either a b'
maybeToEither e f = maybe (Left e) (Right . f)

nullary :: ([a] -> b) -> [a] -> Maybe b
nullary f xs = Just (f xs)

unary :: ([a] -> a -> b) -> [a] -> Maybe b
unary f xs = listToMaybe $ map (f xs) xs

binary :: ([a] -> a -> a -> b) -> [a] -> Maybe b
binary f xs = listToMaybe $ zipWith (f xs) (drop 1 xs) xs

action :: (Stack -> Maybe Double) -> Operator
action f xs = maybeToEither "stack underflow" ((, xs) . Just) (f xs)

manip :: (Stack -> Maybe Stack) -> Operator
manip f = maybeToEither "stack underflow" (Nothing ,) . f

consume :: (a -> a -> a) -> [a] -> a -> a -> [a]
consume f xs x y = f x y : drop 2 xs

push :: String -> Operator
push s = manip . nullary $ (read s:)

operations :: [Operation]
operations =
    [ Operation "#"    (action . nullary $ fromIntegral . length)
                "display number of values on the stack"
    , Operation "."    (action . unary $ flip const)
                "display the top value on the stack"
    , Operation "drop" (manip  . unary $ const . drop 1)
                "remove the top value from the stack"
    , Operation "dup"  (manip  . unary   $ flip (:))
                "duplicate the top value on the stack"
    , Operation "swap" (manip  . binary  $ \xs x y -> x:y:drop 2 xs)
                "swap the top two values on the stack"
    , Operation "+"    (manip  . binary  $ consume (+))
                "replace the top two values on the stack with their sum"
    , Operation "-"    (manip  . binary  $ consume (-))
                "replace the top two values on the stack with their difference"
    , Operation "*"    (manip  . binary  $ consume (*))
                "replace the top two values on the stack with their product"
    , Operation "/"    (manip  . binary  $ consume (/))
                "replace the top two values on the stack with their quotient"
    , Operation "^"    (manip  . binary  $ consume $ flip (**))
                "replace the top two values on the stack, x and y, with x raised to the y"
    ]

rpn :: Stack -> IO (Maybe Stack)
rpn xs = do { s <- prompt
            ; case s of
                { "exit" -> return Nothing
                ; "help" -> do
                    { let len = maximum $ length . opName <$> operations
                    ; putStrLn "Commands: "
                    ; forM_ operations $ \o -> printf ("%-" ++ show len ++ "s -- %s\n")
                                               (opName o) (opHelp o)
                    ; return (Just xs)
                    }
                ; _ -> Just <$> display (op s)
                }
            }
    where prompt = putStr "> " >> hFlush stdout >> getLine
          display (Left e)              = putStrLn e >> return xs
          display (Right (Just x, xs')) = print x    >> return xs'
          display (Right (_,      xs')) =               return xs'
          op s = maybe (push s) opFn (find ((== s) . opName) operations) xs

main :: IO ()
main = whileJust_ rpn []