{-
  An embedding of the Cat language in Haskell
  Copyright 2007, Stefan Monnier
  Modified by Christopher Diggins

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 3 of the License, or
  (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program. If not, see <http://www.gnu.org/licenses/>.

  Compile with Glasgow extensions on. From GHCi this can be done using
  ":set -fglasgow-exts"

  See Also:
  *  Techniques for Embedding Postfix Languages in Haskell by Chris
Okasaki. Haskell Workshop,
    October 2002, pages 105-113.
    - http://www.eecs.usma.edu/webs/people/okasaki/hw02.ps
    - http://www.eecs.usma.edu/webs/people/okasaki/Hw02code.zip
  * Miaou: Cat in Haskell using Monads by Adrien Pierard
    - http://pied.mine.nu//index.php?page=Lambda&id=22
  * Cat interpreter in Omega using thrists (threaded lists) by Gabor Greif
    - http://svn.berlios.de/viewcvs/al4nin/trunk/purgatory/Thrist.omg?rev=351
  * Cat evaluator function in Standard ML by Kevin Millikin
    - http://lambda-the-ultimate.org/node/2281#comment-33765
-}

-- Push a literal value "x" onto stack "s"
lit' x s = (s, x)

-- Remove top value from stack
pop' (s, x) = s

-- Duplicate top value on stack
dup' (s, x) = ((s, x), x)

-- Add top two values on stack
add' ((s, x), y) = (s, x + y)

-- Apply function on the top of the stack to the rest of the stack
apply'(s, f) = f s

-- Apply function on the stack below the next value
-- Should be equivalent to "swap quote compose apply"
dip' ((s, x), f) = (f s, x)

-- Swap top two elements of the stack
swap' ((s, x), y) = ((s, y), x)

-- Compose top two functions on the stack
compose' ((s, f), g) = (s, g . f)

-- Create a constant generaing function from top value on the stack
quote' :: (t, a) -> (t, forall u . u -> (u, a))
quote' (s, x) = (s, \s -> (s,x))

-- Used to delimit sequences of Cat instructions
start k = k ()
end s = s

-- Technique to allow Cat instructions to be expressed in postfix
postfix0 f s k = k (f s)
postfix1 f s arg k = k (f arg s)
postfix2 f s arg1 arg2 k = k (f arg1 arg2 s)

-- Construct postfix versions of each function
lit     = postfix1 lit'
pop     = postfix0 pop'
dup     = postfix0 dup'
swap    = postfix0 swap'
add     = postfix0 add'
apply   = postfix0 apply'
dip     = postfix0 dip'
quote   = postfix0 quote'
compose = postfix0 compose'

-- Some tests, expect a stack of "((), 1, 2)" as a result of each test
t0 = start lit 1 lit 2 end
t1 = start lit 0 lit 1 add lit 2 end
t2 = start lit 1 dup lit 1 add end
t3 = start lit 1 lit 2 lit 3 pop end
t4 = start lit 2 lit 1 swap end

-- Failing Tests
t5 = start lit 0 lit 1 lit add apply lit 2 end
t6 = start lit 0 lit 1 lit 2 lit add dip end