Skip to content

Instantly share code, notes, and snippets.

@rampion
Created February 16, 2012 20:51
Show Gist options
  • Save rampion/1847747 to your computer and use it in GitHub Desktop.
Save rampion/1847747 to your computer and use it in GitHub Desktop.
Playing with Factor's Row Polymorphism in Haskell
{-# 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?
{-# 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.
1_RowPolymorphism_Core.hs
0_RowPolymorphism_Primitives.hs
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment