Cat.hs

Cat.hs

{-
 - This is a simple type-safe concatenative (stack-based) language
 - implemented as an embedded DSL in Haskell. It's based on the ideas presented in
 -
 - http://www.codecommit.com/blog/cat/the-joy-of-concatenative-languages-part-1
 -                                -"-                                         2
 -                                -"-                                         3
 -
 - MIT License, Tim Baumann
 -}


import Prelude ()
import qualified Prelude as P
import qualified Control.Monad as M

-- | Stack

data S a b = a :-: b deriving (P.Eq, P.Show)

data N = Null deriving (P.Eq, P.Show)


-- | Standard Library

liftS :: (a -> b) -> S x a -> S x b
liftS f (x:-:a) = x:-:(f a)

liftS2 :: (a -> b -> c) -> S (S x a) b -> S x c
liftS2 f ((x:-:a):-:b) = x:-:(f a b)

dup :: S x a -> S (S x a) a
dup (x:-:a) = (x:-:a):-:a

swap :: S (S x a) b -> S (S x b) a
swap ((x:-:a):-:b) = ((x:-:b):-:a)

dip :: S (S x a) (x -> y) -> S y a
dip ((x:-:a):-:f) = (f x):-:a

pop :: S x a -> x
pop (x:-:a) = x

push, p :: a -> b -> S b a
push x = (:-:x)
p = push

apply :: S a (a -> b) -> b
apply (a:-:f) = f a

iff :: S (S (S x P.Bool) (x -> y)) (x -> y) -> y
iff (((x:-:i):-:t):-:e) = if i then t x else e x

(+), (-), (*) :: (P.Num a) => S (S x a) a -> S x a
(+) = liftS2 (P.+)
(-) = liftS2 (P.-)
(*) = liftS2 (P.*)
(/) :: (P.Fractional a) => S (S x a) a -> S x a
(/) = liftS2 (P./)
mod, div :: (P.Integral a) => S (S x a) a -> S x a
mod = liftS2 P.mod
div = liftS2 P.div

(==), eq, (/=) :: (P.Eq a) => S (S x a) a -> S x P.Bool
(==) = liftS2 (P.==)
eq = (==)
(/=) = liftS2 (P./=)

(<), (<=), (>), (>=) :: (P.Ord a) => S (S x a) a -> S x P.Bool
(<)  = liftS2 (P.<)
(<=) = liftS2 (P.<=)
(>)  = liftS2 (P.>)
(>=) = liftS2 (P.>=)

-- | Lists
empty :: S x [a] -> S (S x [a]) P.Bool
empty = dup . liftS P.null
cons :: S (S x [a]) a -> S x [a]
cons ((x:-:l):-:i) = x:-:(i:l)
uncons :: S x [a] -> S (S x [a]) a
uncons (x:-:(i:l)) = (x:-:l):-:i

infixr 9 .
(.) :: (a -> b) -> (b -> c) -> a -> c
(.) = P.flip (P..)

end :: a -> a
end = P.id


-- | Examples

main :: P.IO ()
main = do
  M.forM_ results P.$ \(res, msg) -> if res then P.return () else P.putStrLn msg
  P.putStrLn P.$ P.show (P.length (P.filter P.fst results)) P.++ " out of " P.++
                 P.show (P.length results) P.++ " tests succeeded."
  where test exp act | exp P.== act = (P.True, "")
                     | P.otherwise  = (P.False, "Expected: " P.++ P.show exp P.++
                                                ", got: " P.++ P.show act)
        results = [ test (Null:-:5) P.$ sum1 Null
                  , test (Null:-:9) P.$ sum2 Null
                  , test (Null:-:120) P.$ fac (Null:-:5)
                  , test (Null:-:1) P.$ collatz (Null:-:3) -- ^ 10, 5, 16, 8, 4, 2, 1
                  , test (Null:-:5) P.$ length (Null:-:"hallo")
                  , test (Null:-:[3,2,1]) P.$ reverse (Null:-:[1,2,3])
                  ]

sum1, sum2 :: (P.Integral a) => x -> S x a
sum1 = p 2 . p 3 . (+)
sum2 = p 2 . p 3 . p 4 . (+) . (+)

-- | Factorial
fac :: (P.Integral a) => (S x a) -> (S x a)
fac = dup . p 0 . eq . p (pop . p 1) . p (dup . p 1 . (-) . fac . (*)) . iff

-- | Collatz' n*3+1 conjecture
collatz :: (P.Integral a) => (S x a) -> (S x a)
collatz = dup . p 2 . mod . p 0 . (==) . p ifEven . p ifOdd . iff
  where ifEven = p 2 . div . dup . p 1 . (==) . p end . p collatz . iff
        ifOdd  = p 3 . (*) . p 1 . (+) . collatz

-- | Length of lists
length :: (P.Integral a) => S x [y] -> S x a
length = empty . p (pop . p 0) . p (uncons . pop . length . p 1 . (+)) . iff

-- | Reverse lists
reverse :: S x [a] -> S x [a]
reverse = p [] . swap . recurse
  where recurse = empty . p pop . p (uncons . swap . p cons . dip . recurse) . iff