Created

Embed URL

HTTPS clone URL

SSH clone URL

You can clone with HTTPS or SSH.

Download Gist

Playing with Factor's Row Polymorphism in Haskell

View 0_RowPolymorphism_Primitives.hs
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
{-# 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?
View 0_RowPolymorphism_Primitives.hs
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
{-# 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.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.