SH:IsString Instances:

Writing Haskell Functions in RPN

ok. i officially apologise for ever mentioning IsString.
– heard on #haskell

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.


Copyright © 2009 Sam Hughes