{-# LANGUAGE NoMonomorphismRestriction #-}
module ArrowStack where

import Prelude hiding ((.), id, drop)
import Control.Arrow
import Control.Category

{- Not very useful: Arrows are naturally uncurried
liftStack1 f (a,s) = (f a, s)
liftStack2 f (a,(b,s)) = (f a b, s)
liftStack3 f (a,(b,(c,s))) = (f a b c, s)
-}

{- Arrow plumbing operators to support stack composition. -}

-- Plumbing functions.  The order is to preserve the Forth argument
-- order as in "a b -".
arg1 (a,s) = (a,s)
arg2 (b,(a,s)) = ((a,b),s)
arg3 (c,(b,(a,s))) = ((a,b,c),s)

dup2 (a,s) = (a,(s,s))

-- Operators: lift arrow to stack arrow.
stack1 :: Arrow a => a x       r -> a (x,s)         (r,s)
stack2 :: Arrow a => a (x,y)   r -> a (y,(x,s))     (r,s)
stack3 :: Arrow a => a (x,y,z) r -> a (z,(y,(x,s))) (r,s)

stack1 = first
stack2 a = (first a) . (arr arg2)
stack3 a = (first a) . (arr arg3)

-- Stack ops
dup  = arr $ \(a,s) -> (a,(a,s))
swap = arr $ \(a,(b,s)) -> (b,(a,s))
drop = arr $ \(_,s) -> s

-- Unpack 1-element stack.
top   = arr $ \(t,()) -> t

-- Lift unary and binary functions.
sarr1 = stack1 . arr
sarr2 = stack2 . arr . uncurry

add = sarr2 (+)
mul = sarr2 (*)






-- stack2 (a,(b,s)) = (f a b, s)
-- stack3 (a,(b,(c,s))) = (f a b c, s)