Tagless final concatenative programming

tagless-final-concat.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
import Prelude (Bool,Show, (+))
import qualified Prelude as P
import Control.Arrow
import Control.Monad
import Control.Category

data s :. a = s :. a
            deriving Show

infixl 1 :.

class ForthSym sem where
  dup :: sem (s:.a) -> sem (s:.a:.a)
  push :: a -> sem s -> sem (s:.a)
  add :: P.Num n => sem (s:.n:.n) -> sem (s:.n)
  liftS :: (a -> b) -> (sem (s:.a) -> sem (s:.b))
  swap :: sem (s:.a:.b) -> sem (s:.b:.a)
  if_ :: sem (s:.Bool:.(s -> s'):.(s -> s')) -> sem s'
  liftS2 :: (a -> b -> c) -> sem (s:.a:.b) -> sem (s:.c)

instance Functor f => ForthSym f where
  push a = fmap (:. a)
  dup = fmap (\(s:.a) -> s:.a:.a)
  swap = fmap (\(s:.a:.b) -> s:.b:.a)
  add = fmap (\(s:.a:.b) -> s:.a + b)
  liftS f = fmap (\(s:.a) -> s:.f a)
  if_ = fmap (\(s:.cond:.then_:.else_) -> (if cond then then_ else else_) s)
  liftS2 f = fmap (\(s:.a:.b) -> s:.f a b)

(++) = liftS2 (P.++)
putStr = fmap (\(s:.x) -> P.putStr x >> return s)
putStrLn = fmap (\(s:.x) -> P.putStrLn x >> return s)
getLine = fmap (\s -> P.getLine >>= \ln -> return (s:.ln))

hello = push "What's your name? " >>> return
      >=> putStr
      >=> push "Hello, " >>> return
      >=> getLine
      >=> return
      >=> (++) >>> push "!" >>> (++) >>> return
      >=> putStrLn
      >=> id