Playing with Factor's Row Polymorphism in Haskell

0_RowPolymorphism_Primitives.hs

{-# LANGUAGE TypeOperators #-}
-- inspired by "Why concatenative programming matters."
-- (http://evincarofautumn.blogspot.com/2012/02/why-concatenative-programming-matters.html)
--
-- playing with adapting row polymorphism to Haskell, because, hey, why not?
module RowPolymorphism.Primitives (
  (:>)(), Stack,
  lift, quote, (!),
  dip, dup, over, swap, drop, call
) where

-- our drop is better
import Prelude hiding (drop) 

-- build a Stack for us to be Row Polymorphic on
data s :> a = s :> a
  deriving (Show, Eq, Ord)
infixl 5 :>

class Stack a
instance Stack ()
instance Stack s => Stack (s :> a)

-- lift lets us change all our haskell functions into
-- into more factor-like words that operate on the stack
lift :: Stack s => (a -> b) -> (s :> a) -> (s :> b)
lift f (s :> a) = s :> f a

-- quote lets us push things onto the stack.
--
-- `quote dip` is equivalent to factor's `[ dip ]`
--
-- Note that `quote 3` is not the equivalent of `[ 3 ]`.
-- For that, we need `quote __3__`, where 
--    __3__ :: (Stack s, Num a) => s -> (s :> a)
--    __3__ = quote 3
-- This is due to the different semantic meaning of the literal 3 in 
-- haskell and factor.
quote :: Stack s => a -> s -> (s :> a)
quote = flip (:>)

-- factor uses whitespace to represent concatenation, whereas
-- haskell uses whitespace to represent application, so we'll
-- need an operator to combine our factor terms
(!) :: (Stack s, Stack s') => (s -> s') -> (s' -> s'') -> (s -> s'')
(!) = flip (.)
infixl 9 !

-- equivalent to factor's dip from http://docs.factorcode.org/content/word-dip,kernel.html
dip :: (Stack s, Stack s') => (s :> x :> (s -> s')) -> (s' :> x)
dip (s :> x :> f) = f s :> x

-- equivalent to factor's dup from http://docs.factorcode.org/content/word-dup,kernel.html
dup :: Stack s => (s :> a) -> (s :> a :> a)
dup s@(_ :> a) = s :> a

-- equivalent to factor's over from http://docs.factorcode.org/content/word-over,kernel.html
over :: Stack s => (s :> a :> b) -> (s :> a :> b :> a)
over s@(_ :> a :> _) = s :> a

-- equivalent to factor's swap from http://docs.factorcode.org/content/word-swap,kernel.html
swap :: Stack s => (s :> b :> a) -> (s :> a :> b)
swap (s :> b :> a) = s :> a :> b

-- equivalent to factor's drop from http://docs.factorcode.org/content/word-drop,kernel.html
drop :: Stack s => (s :> a) -> s
drop (s :> _) = s

-- equivalent to factor's call from http://docs.factorcode.org/content/word-call,kernel.html
call :: Stack s => (s :> (s -> s')) -> s'
call ( s :> f ) = f s

-- not going to claim this is a minimum basis, but it's a start, right?

1_RowPolymorphism_Core.hs

{-# LANGUAGE TypeOperators #-}
module RowPolymorphism.Core where

-- now that we've got some primitives
import RowPolymorphism.Primitives

-- let's see whether we can do some factor in haskell!

__plus__ :: (Stack s, Num a) => (s :> a :> a) -> (s :> a)
-- lift . (+)               :: a -> (s :> a) -> (s :> a)
-- lift (lift . (+))        :: (s' :> a) -> (s' :> ((s :> a) -> (s:> a))
-- lift (lift . (+)) ! call :: (s :> a :> a) -> (s :> a)
__plus__ = lift (lift . (+)) ! call

__minus__ :: (Stack s, Num a) => (s :> a :> a) -> (s :> a)
__minus__ = lift (lift . flip (-)) ! call

__replicate__ :: Stack s => (s :> a :> Int) -> (s :> [a])
-- replicate                      :: Int -> a -> [a]
-- lift . replicate               :: Int -> (s :> a) -> (s :> [a])
-- lift (lift . replicate)        :: (s' :> Int) -> (s' :> ((s :> a) -> (s:> [a]))
-- lift (lift . replicate) ! call :: (s :> a :> Int) -> (s :> [a])
__replicate__ = lift (lift . replicate) ! call

-- similar to factor's if, except it forces the two branches to
-- leave an identical stack
-- (see http://docs.factorcode.org/content/word-if,kernel.html)
__if__ :: Stack s => (s :> Bool :> (s -> s') :> (s -> s')) -> s'
-- lift (\a -> lift (\a' -> lift (ifThenElse a a'))) ! call ! call
--      :: ( s :> Bool :> a :> a ) -> ( s :> a )
__if__ = lift (lift . (lift .) . ifThenElse) ! call ! call ! call
  where ifThenElse :: a -> a -> Bool -> a
        ifThenElse a a' b = if b then a else a'

-- for a quarternary function f, to lift it, we'd need:
--  lift ( lift . ( lift . ) . ( (lift .) . ) . f ) ! call ! call ! call
-- which is getting completely out of hand :)

-- same as definition from http://docs.factorcode.org/content/word-keep,kernel.html
keep :: (Stack s, Stack s') => (s :> x :> (s :> x -> s')) -> (s' :> x)
keep = over ! quote call ! dip  

-- same as definition from http://docs.factorcode.org/content/word-bi,kernel.html
bi :: (Stack s, Stack s') => (s :> x :> (s :> x -> s') :> (s' :> x -> s'')) -> s''
bi  = quote keep ! dip ! call

-- same as definition from http://docs.factorcode.org/content/word-bi__star__,kernel.html
bi__star__ :: (Stack s, Stack s') => (s :> x :> y :> (s :> x -> s') :> (s' :> y -> s'')) -> s''
bi__star__ = quote dip ! dip ! call

-- same as definition from http://docs.factorcode.org/content/word-2dup,kernel.html
__2__dup :: Stack s => (s :> x :> y) -> (s :> x :> y :> x :> y)
__2__dup = over ! over

-- same as definition from http://docs.factorcode.org/content/word-2dip,kernel.html
__2__dip :: (Stack s, Stack s') => (s :> x :> y :> (s -> s')) -> (s' :> x :> y)
__2__dip = swap ! quote dip ! dip

-- same as definition from http://docs.factorcode.org/content/word-2keep,kernel.html
__2__keep :: (Stack s, Stack s') => (s :> x :> y :> (s :> x :> y -> s')) -> (s' :> x :> y)
__2__keep = quote __2__dup ! dip ! __2__dip 

-- same as definition from http://docs.factorcode.org/content/word-2bi,kernel.html
__2__bi :: (Stack s, Stack s') => (s :> x :> y :> (s :> x :> y -> s') :> (s' :> x :> y -> s'')) -> s''
__2__bi = quote __2__keep ! dip ! call

-- this obviously won't work for everything (what about all that side-effecty
-- stuff), but it's still fun.

Core.hs

1_RowPolymorphism_Core.hs

Primitives.hs

0_RowPolymorphism_Primitives.hs