-- 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"