Skip to content

Instantly share code, notes, and snippets.

@shangaslammi
Created February 17, 2012 06:01
  • Star 3 You must be signed in to star a gist
  • Fork 1 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save shangaslammi/1851086 to your computer and use it in GitHub Desktop.
Concatenative Programming in Haskell
{-# LANGUAGE TypeOperators, NoImplicitPrelude #-}
import qualified Data.List as L
import Control.Arrow
import Control.Monad
import Prelude (Bool, Int, Float, fst, snd, flip, ($), uncurry, Show(..), String, (.), otherwise, IO)
import qualified Prelude as P
data s :. a = !s :. !a
infixl 1 :.
push :: a -> s -> s:.a
push a s = s:.a
q :: a -> s -> s:.a
q = push
dup :: s:.a -> s:.a:.a
dup (s:.a) = (s:.a:.a)
swap :: s:.a:.b -> s:.b:.a
swap (s:.a:.b) = s:.b:.a
add :: P.Num n => s:.n:.n -> s:.n
add (s:.a:.b) = s:.a P.+ b
test = push 1 >>> push 2 >>> add
addTwo = push 2 >>> add
liftS :: (a -> b) -> (s:.a -> s:.b)
liftS f (s:.a) = s:.f a
liftS2 :: (a -> b -> c) -> (s:.a:.b -> s:.c)
liftS2 f (s:.a:.b) = s:.f a b
(+) :: P.Num n => s:.n:.n -> s:.n
(+) = liftS2 (P.+)
(-) :: P.Num n => s:.n:.n -> s:.n
(-) = liftS2 (P.-)
(*) :: P.Num n => s:.n:.n -> s:.n
(*) = liftS2 (P.*)
(/) :: P.Fractional n => s:.n:.n -> s:.n
(/) = liftS2 (P./)
(<) :: P.Ord n => s:.n:.n -> s:.Bool
(<) = liftS2 (P.<)
(>) :: P.Ord n => s:.n:.n -> s:.Bool
(>) = liftS2 (P.>)
(>=) :: P.Ord n => s:.n:.n -> s:.Bool
(>=) = liftS2 (P.>=)
(<=) :: P.Ord n => s:.n:.n -> s:.Bool
(<=) = liftS2 (P.<=)
(==) :: P.Eq n => s:.n:.n -> s:.Bool
(==) = liftS2 (P.==)
(++) :: s:.[a]:.[a] -> s:.[a]
(++) = liftS2 (P.++)
null :: s:.[a] -> s:.Bool
null = liftS P.null
decons :: s:.[a] -> s:.[a]:.a
decons (s:.(x:xs)) = s:.xs:.x
cons :: s:.[a]:.a -> s:.[a]
cons (s:.xs:.x) = s:. x:xs
drop :: s:.a -> s
drop (s:.a) = s
drop2 :: s:.a:.b -> s
drop2 = drop . drop
drop3 :: s:.a:.b:.c -> s
drop3 = drop . drop2
nip :: s:.a:.b -> s:.b
nip (s:.a:.b) = s:.b
nip2 :: s:.a:.b:.c -> s:.c
nip2 = nip . nip
over :: s:.a:.b -> s:.a:.b:.a
over (s:.a:.b) = (s:.a:.b:.a)
pick :: s:.a:.b:.c -> s:.a:.b:.c:.a
pick (s:.a:.b:.c) = (s:.a:.b:.c:.a)
dupd :: s:.a:.b -> s:.a:.a:.b
dupd (s:.a:.b) = (s:.a:.a:.b)
swapd :: s:.a:.b:.c -> s:.b:.a:.c
swapd (s:.a:.b:.c) = s:.b:.a:.c
rotl :: s:.a:.b:.c -> s:.b:.c:.a
rotl (s:.a:.b:.c) = s:.b:.c:.a
rotr :: s:.a:.b:.c -> s:.c:.a:.b
rotr (s:.a:.b:.c) = s:.c:.a:.b
apply :: s:.(s -> s') -> s'
apply (s:.f) = f s
dip :: s:.a:.(s -> s') -> s':.a
dip (s:.a:.f) = f s :. a
dip2 :: s:.a:.b:.(s -> s') -> s':.a:.b
dip2 (s:.a:.b:.f) = f s :. a :. b
keep :: s:.a:.(s:.a -> s') -> s':.a
keep (s:.a:.f) = f (s:.a) :. a
keep2 :: s:.a:.b:.(s:.a:.b -> s') -> s':.a:.b
keep2 (s:.a:.b:.f) = f (s:.a:.b) :. a :. b
length :: s:.[a] -> s:.Int
length = liftS P.length
reverse :: s:.[a] -> s:.[a]
reverse = liftS P.reverse
take :: s:.[a]:.Int -> s:.[a]
take = liftS2 $ flip P.take
if_ :: s:.Bool:.(s -> s'):.(s -> s') -> s'
if_ (s:.cond:.then_:.else_)
| cond = then_ s
| otherwise = else_ s
map :: s:.[a]:.(s:.a -> s:.b) -> s:.[b]
map (s:.lst:.f) = (uncurry (:.)) (L.mapAccumL step s lst) where
step s x = let s:.y = f (s:.x) in (s,y)
foldr :: s:.[x]:.acc:.(s:.acc:.x -> s:.acc) -> s:.acc
foldr = pick
>>> null
>>> q( drop >>> nip )
>>> q( q decons
>>> dip2
>>> rotl
>>> q( q foldr >>> keep ) >>> dip
>>> swap
>>> apply
)
>>> if_
foldl :: s:.[x]:.acc:.(s:.x:.acc -> s:.acc) -> s:.acc
foldl = pick
>>> null
>>> q( drop >>> nip )
>>> q( q( decons >>> swap )
>>> dip2
>>> rotl
>>> q( q apply >>> keep )
>>> dip
>>> rotr
>>> foldl
)
>>> if_
filter :: s:.[x]:.(s:.x -> s:.Bool) -> s:.[x]
filter = swap >>> push [] >>> q step >>> foldr >>> nip where
step = rotr
>>> pick
>>> q( q( apply >>> q( q cons ) >>> q( q drop ) >>> if_ )
>>> keep
) >>> dip2
>>> q rotl >>> dip
>>> swap
>>> apply
testFilter = push [1..20]
>>> q( push 5 >>> (>) )
>>> filter
>>> push 5 >>> take
applyTest = push 2 >>> q( push 3 >>> (+) ) >>> apply
putStr :: s:.String -> IO s
putStr (s:.x) = P.putStr x >> return s
putStrLn :: s:.String -> IO s
putStrLn (s:.x) = P.putStrLn x >> return s
getLine :: s -> IO (s:.String)
getLine s = P.getLine >>= \ln -> return (s:.ln)
hello = push "What's your name? " >>> return
>=> putStr
>=> push "Hello, " >>> return
>=> getLine
>=> (++) >>> push "!" >>> (++) >>> return
>=> putStrLn
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment