Skip to content

Instantly share code, notes, and snippets.

@trevorc trevorc/rpn.hs
Created Oct 17, 2012

Embed
What would you like to do?
{-# 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 []
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.