-- Copyright (c) 2008 Samuel Hughes -- -- You may do what you want with this. {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE OverlappingInstances #-} -- Then we'll want to start our module and make the necessary imports. module RPNIsString where import Data.String -- for IsString import Data.Char (isSpace) -- We'll make our IsString instance now, since that tells us what -- we'll need to implement later. Our RPN strings will describe -- functions of type (a -> b), where a and b are both types of values -- that we know how to push onto and pop off of the RPN stack. -- -- We'll mark these types by making them a member of the typeclass, -- RPNValue. instance (RPNValue a, RPNValue b) => IsString (a -> b) where fromString s = fromStack . evalRPN s .toStack -- We'll implement these later: -- fromStack :: RPNValue b => Stack -> b -- evalRPN :: String -> (Stack -> Stack) -- toStack :: RPNValue a => a -> Stack class RPNValue a where pushStack :: a -> Stack -> Stack -- ^ Pushes a Haskell value onto a stack, translating it -- as necessary. popStack :: Stack -> (a,Stack) -- ^ Pops our Haskell value off a stack, returning the value -- and a stack with some of the leading elements removed. -- We haven't specified the Stack type yet, and we should. We'll make -- it a list of “stack objects,” where a “stack object” is either -- a Double or a function that transforms the stack. We allow Doubles -- and functions because we'll want to support first-class functions -- in our stack language. type Stack = [StackObj] data StackObj = DNum !Double | SFun !StackFunc type StackFunc = Stack -> Stack -- Now we can knock off fromStack and toStack. fromStack :: RPNValue a => Stack -> a fromStack = fst . popStack toStack :: RPNValue a => a -> Stack toStack x = pushStack x [] -- We still have evalRPN to implement, but first let's make a whole -- bunch of instances for RPNValue. -- A Double is represented by a Double on the stack. instance RPNValue Double where pushStack x xs = DNum x : xs popStack (DNum x:xs) = (x,xs) popStack (SFun _:xs) = (castError, xs) popStack [] = emptyStack -- We'll implement 'castError' and 'emptyStack' (both of which are error -- values) later. -- A Float is raised to a Double when pushed onto the stack. instance RPNValue Float where pushStack x xs = DNum (realToFrac x) : xs popStack (DNum x:xs) = (realToFrac x,xs) popStack (SFun _:xs) = (castError, xs) popStack [] = emptyStack -- False is represented by zero; True gets converted to 1. -- Everything nonzero gets converted to True. instance RPNValue Bool where pushStack True xs = DNum 1 : xs pushStack False xs = DNum 0 : xs popStack (DNum 0:xs) = (False, xs) popStack ( _:xs) = (True, xs) popStack [] = emptyStack -- The only other singular values we say can be pushed onto the stack -- are Integral values. Which we convert to Double accordingly. instance Integral a => RPNValue a where pushStack x xs = DNum (fromIntegral x) : xs popStack (DNum x:xs) = (round x, xs) popStack (SFun _:xs) = (castError, xs) popStack [] = emptyStack -- We can also push lists of RPNValues onto the stack. Note that -- pushStack (xs ++ ys) = pushStack xs . pushStack ys instance RPNValue a => RPNValue [a] where pushStack hs xs = foldr pushStack xs hs popStack [] = ([],[]) popStack xs = let (val, xs') = popStack xs (vals, []) = popStack xs' in (val : vals, []) -- Tuple Instances -- The rightmost element of tuples end up on the top of the stack, -- with the leftmost on the bottom. instance (RPNValue a, RPNValue b) => RPNValue (a,b) where pushStack (x,y) = pushStack y . pushStack x -- We push y onto the stack _after_ we push x. popStack xs = let (y,xs') = popStack xs -- pop y off first, giving xs' as the remainder (x,xs'') = popStack xs' -- then pop x, with xs'' the remainder in ((x,y),xs'') instance (RPNValue a, RPNValue b, RPNValue c) => RPNValue (a,b,c) where pushStack (x,y,z) = pushStack z . pushStack y . pushStack x popStack xs = let ((y,z),xs') = popStack xs -- the popStack above is from the (RPNValue a, -- RPNValue b) => RPNValue (a,b) instance (x,xs'') = popStack xs' in ((x,y,z),xs'') instance (RPNValue a, RPNValue b, RPNValue c, RPNValue d) => RPNValue (a,b,c,d) where pushStack (w,x,y,z) = pushStack (z,y) . pushStack (x,w) popStack xs = let ((x,y,z),xs') = popStack xs -- same as before (w,xs'') = popStack xs' in ((w,x,y,z),xs'') -- Those are all of our RPNValue instances, for now. More could be -- added, if you wanted to do so. -- -- Now, we're going to want to implement a bunch of StackFuncs, -- because we'll need to have a standard library of functions that the -- users can call. For example, we'll want to support addition, -- subtraction, absolute values, branching, and some basic stack -- operations. A StackFunc is merely a function of type [StackObj] -> -- [StackObj], so one way we could do this is to implement all the -- Stack functions by hand. For example, we could implement "+" in the -- following manner: -- > plus :: StackObj -> StackObj -- > plus (DNum x : DNum x' : xs) = DNum (x + x') : xs -- > plus _ = error "+: You fool! Invalid types\ -- \ on RPN stack!" -- But that gets tiresome. Instead, we'll make a utility typeclass! class RPNFunc a where stackFunc :: a -> StackFunc -- This describes Haskell values that can be converted to stack -- functions. -- -- Our first instance will be for raw RPN values. Any RPNValue can be -- converted to a StackFunc simply by making a function that pushes it -- onto the stack. instance RPNValue a => RPNFunc a where stackFunc = pushStack -- stackFunc x = \stack -> pushStack x stack -- Now we'll make an instance that converts mathematical functions to -- those that operate on the stack. instance (RPNValue a, RPNFunc b) => RPNFunc (a->b) where stackFunc f xs = let (val,xs') = popStack xs -- ^ Pop f's argument off the stack. -- val :: a. Did you know? f' = f val -- ^ Now we have our new RPNFunc. -- f' :: b. Did you know? in stackFunc f' xs' -- So we apply that to the new stack. -- That provides an instance for functions of any number of arguments, -- because a -> b -> c -> ... -> y -> z is cute syntax for the type, a -- -> (b -> (c -> (... -> (y -> z)...)). We know by induction that as -- long as all the variables involved are some kind of RPNValue, the -- function is an RPNFunc. -- Now we deliver something ugly, a big lookup list associating RPN -- function names with their Haskell implementations. If you wanted -- this faster, you could use a set. (But then you'd be encouraging -- practical use!) You'll see that since many numeric types can be -- RPNValue, it is necessary to add some type signatures to give some -- constraints, or else things become too polymorphic, and then the -- compiler would have to guess which types you need. For example, we -- specify that (+) receives a Double as its first argument (that's -- what we will say the 'd' function expects), forcing our instance of -- (+) to take on the type, Double -> Double -> Double. funcs :: [(String, StackFunc)] funcs = numFs ++ stackFs where { d :: RPNFunc a => (Double -> a) -> StackFunc ; d = stackFunc ; i :: RPNFunc a => (Integer -> a) -> StackFunc ; i = stackFunc ; di :: (Double -> Integer) -> StackFunc ; di = stackFunc ; ; -- Above are the convenient functions whose names are shorter ; -- than 'stackFunc', whose type signatures force their ; -- arguments to a certain type. ; ; -- numFs contains our numeric functions. ; numFs :: [(String, StackFunc)] ; numFs = [ ("+", d (+)) , ("-", d (flip (-))) -- flip! , ("*", d (*)) , ("1-", d negate) , ("abs", d abs) , ("sign", d signum) , ("quot", i (flip quot)) , ("rem", i (flip rem)) , ("div", i (flip div)) , ("mod", i (flip mod)) , ("quotRem", i (flip quotRem)) , ("divMod", i (flip divMod)) , ("/", d (flip (/))) , ("1/", d recip) , ("pi", stackFunc (pi :: Double)) , ("exp", d exp) , ("log", d log) , ("sqrt", d sqrt) , ("**", d (flip (**))) , ("logBase", d logBase) -- don't flip! , ("sin", d sin) , ("cos", d cos) , ("tan", d tan) , ("asin", d asin) , ("acos", d acos) , ("atan", d atan) , ("sinh", d sinh) , ("cosh", d cosh) , ("tanh", d tanh) , ("asinh", d asinh) , ("acosh", d acosh) , ("atanh", d atanh) , ("properFraction" , stackFunc (properFraction :: Double -> (Integer, Double)) ) , ("truncate", di truncate) , ("round", di round) , ("ceiling", di ceiling) , ("floor", di floor) , ("=", d (==)) , ("<", d (flip (<))) , (">", d (flip (>))) , ("<=", d (flip (<=))) , (">=", d (flip (>=))) , ("/=", d (/=)) ] ; ; -- Then we have our stack functions, which we just ; -- implement manually. Adding useful error messages ; -- is left as an exercise to the reader :-) ; ; stackFs :: [(String, StackFunc)] ; stackFs = [ ("dup", \(x:xs) -> x:x:xs) , ("swap", \(x:y:xs) -> y:x:xs) , ("rot", \(x:y:z:xs) -> z:x:y:xs) , ("tor", \(z:x:y:xs) -> x:y:z:xs) , ("roll", \(DNum x:xs) -> let n = round x (ts, b:bs) = splitAt (n-1) xs in b : (ts ++ bs)) , ("llor", \(DNum x:xs) -> let n = round x (t:ts, bs) = splitAt n xs in ts ++ (t : bs)) , ("pick", \(DNum x:xs) -> let n = round x (ts, bs@(b:_)) = splitAt (n-1) xs in b : xs) , ("cycle", cycle) -- haha , ("ifte", \(e:t:DNum b:xs) -> let SFun f = if b == 0 then e else t in f xs) , ("ap", \(SFun f:xs) -> f xs) , ("drop", tail) , ("++", \(SFun f : SFun g : xs) -> SFun (f . g) : xs) , ("nquot", \(DNum n : xs) -> let f (SFun f) g = g . f f (DNum x) g = g . (DNum x :) (bef,aft) = splitAt (round n) xs in SFun (foldr f id bef) : aft) ] } -- FINALLY we get to the interesting part, the evaluator. Or do we? -- It's not really that interesting. All it does is read a list of -- functions from the string, composing them together. It's just a -- bunch of parsing drudgery, which would be made clearer by using -- something like Parsec, but that would just add more for the reader -- to understand. -- Note that the 'do' notation we're using in here is for the Maybe -- monad. That means if readFuncs throws an 'exception' by returning -- Nothing, it gets automatically filtered down through the do -- notation. evalRPN :: String -> StackFunc evalRPN s = case readFuncs s of Just (f,"") -> f _ -> invalidSyntax where { -- readFuncs tries parsing a sequence of StackFuncs ; -- off the string. ; readFuncs :: String -> Maybe (StackFunc, String) ; -- The empty string is equivalent to the identity function. ; -- (This is a concatenative language, after all.) ; readFuncs [] = Just (id,"") ; -- Leading spaces are skipped. ; readFuncs (c:cs) | isSpace c = readFuncs cs ; -- When we've hit the end of a block, you're done reading ; -- functions. ; readFuncs cs@(']':_) = Just (id, cs) ; -- At the beginning of a block, we read the funcs inside ; -- the block, then the rest of the funcs. The block ; -- gets pushed onto the stack, the next func applied. ; readFuncs ('[':cs) = do { (f, (']':cs')) <- readFuncs cs ; (g, cs'') <- readFuncs cs' ; return (g . pusher f, cs'') } ; ; -- Anything else, we've got a token. We try parsing the token ; -- as a number (using reads), and if it fails, we look it up ; -- in our list of funcs. (If _that_ fails, we fail.) ; readFuncs cs = do { let (tok, cs') = readToken cs ; f <- case reads tok :: [(Double,String)] of [(x, "")] -> return (stackFunc x) _ -> lookup tok funcs ; (fs, cs'') <- readFuncs cs' ; -- We return the composition of our first ; -- function, f, with the composition of the ; -- rest of the functions, fs. ; return (fs . f, cs'') } ; -- readToken "abc blah" = ("abc", " blah") ; readToken :: String -> (String, String) ; readToken [] = ("","") ; readToken cs@(c:cs') | isSpace c || c `elem` "[]" = ("",cs) | otherwise = let (tok', cs'') = readToken cs' in (c:tok', cs'') } -- That's it! We just compose functions together as we read them off -- the string. We're not in the business of optimizing code or -- anything. The following are some utility functions we've used. -- pusher f is a function that pushes f onto the stack. pusher :: StackFunc -> StackFunc pusher f = (SFun f :) invalidSyntax :: a invalidSyntax = error "evalRPN: invalid syntax" emptyStack :: (a,b) emptyStack = (emptyStackError,emptyStackError) emptyStackError :: a emptyStackError = error "empty stack" castError :: a castError = error "could not cast stack value to Haskell type"