You can use
overloaded
string literals to write any type's values in string literal
form. We'll make an IsString instance for functions,
where the functions are written in RPN.
Get the source file here: RPNIsString.hs
Examples:
"2 3 + *" -- multiplies by 5
"[dup [dup tor * swap 1 - 3 pick ap] [drop] ifte] 1 rot 3 pick ap"
-- factorial
So, how do we implement the code?
First, we'll need some LANGUAGE
pragmas, to activate the necessary Haskell extensions. Essentially,
we need to use strange typeclass instances. We won't even enable
OverloadedStrings, which is the feature we're implementing this for.
That would have to be turned on by the module that imports ours, for
it to take effect. We don't actually use overloaded strings, a mere
form of syntactic sugar, anywhere in this module.
So, here are the extensions we will use:
{-# 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 a big lookup list associating RPN function names
with their Haskell implementations. 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) ] }
Here we have the evaluator. It reads a list of functions from the string, composing them together.
Note that the 'do' notation we're using in here is for the Maybe monad.
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'') } -- 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"
With that, we can load up GHCi and load the module.
Prelude> :l RPNIsString [1 of 1] Compiling RPNIsString ( RPNIsString.hs, interpreted ) Ok, modules loaded: RPNIsString. *RPNIsString> "2 3 + *" 7 <interactive>:1:0: Couldn't match expected type `t1 -> t' against inferred type `[Char]' In the expression: "2 3 + *" 7 In the definition of `it': it = "2 3 + *" 7
Oops, we forgot something:
*RPNIsString> :set -XOverloadedStrings *RPNIsString> "2 3 + *" 7 <interactive>:1:0: Ambiguous type variable `t' in the constraint: `RPNValue t' arising from the literal `"2 3 + *"' at <interactive>:1:0-10 Probable fix: add a type signature that fixes these type variable(s)
We need to add a type signature to specify the return type.
*RPNIsString> "2 3 + *" 7 :: Double 35.0 *RPNIsString> "2 3 + *" 7 :: Integer 35 *RPNIsString> "[dup [dup tor * swap 1 - 3 pick ap] [drop] ifte] 1 rot 3 pick ap" 7 :: Double 5040.0
It works.
We don't really need both of the typeclasses, RPNValue and RPNFunc.