Clean

Does anyone use Haskell Clean?
Its faster then GHC

>>6

I can write an fibonacci function, it is easy in haskell. Just define a parametric higher-order abstract syntax lambda calculus with recursive binders as extension (mu binders) then use this DSL to express fibonacci in it:


{-# LANGUAGE RankNTypes, GADTs, MultiParamTypeClasses, FlexibleInstances, ViewPatterns, KindSignatures,   OverlappingInstances, NoMonomorphismRestriction, IncoherentInstances #-}
module Main where

import Control.Monad.Fix
import Control.Applicative


-- | A PHOAS encoded lambda calculus with mu-binders
data Term v t where
    Var :: v t -> Term v t
    App :: Term v (a -> b) -> Term v a -> Term v b
    Lam :: (v a -> Term v b) -> Term v (a -> b)
    Lam2 :: (v a -> v b -> Term v c) -> Term v (a -> b -> c) 
    If :: Term v Bool -> Term v t -> Term v t -> Term v t 
    Eq :: Eq a => Term v a -> Term v a -> Term v Bool
    Mu :: (v t -> Term v t) -> Term v t 
    MuN :: ([v t] -> [Term v t]) -> Term v t

-- | Hide the structure used as variables
--  This makes direct instantiation impossible and thus enforces the structure
data Exp t where
    Exp :: Variable v => Term v t -> Exp t

-- | Some helper to work with variables 
-- lower . raise = id
-- raise . lower = id_v
class Variable (v :: * -> *)  where
    raise :: a ->   v a
    lower :: v a -> a 
    on :: (a -> b) -> v a -> v b
    on f = raise . f . lower

instance Variable Id  where
    raise a = (Id a)
    lower ((Id a)) = a

-- | Lift any value into the language 
class Liftable t where
    lift :: Variable v => t -> Term v t

instance Liftable a where
    lift i = Var (raise i)


instance Liftable b => Liftable (a -> b) where
    lift f = Lam $ \x -> lift (f (lower x))

-- | A phoas term is a Functor
instance Variable v => Functor (Term v) where
    fmap f m = App (lift f) m

-- | And it is an applicative, this is handy for composition of lambdas
instance Variable v => Applicative (Term v) where
    pure = lift    
    (<*>) = App

-- | Some underlying functor for instantiating v
newtype Id a = Id {
        unId :: a
    }

{- | A couple of helper functions -}

-- | Non lifting application
($$) = App
-- | RHS lifting application
($.) f n =  App f (lift n)
-- | LHS lifting application
(.$) f n = App (lift f) n
-- | Both lifting application
(.$.) f n = App (lift f) (lift n)

-- | l to r Composition
($<) :: (Variable v, Liftable a, Liftable b, Liftable c) => Term v (b -> c) -> Term v (a -> b) -> Term v (a -> c)
($<) f g = (Lam (\(lower -> a) -> f $$ (g $. a)))

-- | r to l composition
($>) :: (Variable v, Liftable a, Liftable b, Liftable c) => Term v (a -> b) -> Term v (b -> c) -> Term v (a -> c)
($>) f g = (Lam (\(lower -> a) -> g $$ (f $. a)))

infixl 1 $$
infixl 1 .$
infixl 1 $.
infixl 1 .$.
infix 4 `eq`
infixr 9 $<
infixr 1 $>

lam = Lam
mu = Mu
eq = Eq

-- | Recursive definition of factorial (using mu binders)
fact :: Term Id (Integer -> Integer)
fact = mu (\(lower -> f) -> lam (\(lower -> n) ->
        If (pred n)
            (pure 1)
            $
            (*n) <$> (f <$> (pure $ n - 1))
    ))
  where
    next f n =   pure (f  (n - 1))
    pred n = pure (n == 0)

-- | Factorial function
fac :: Integer -> Integer
fac = eval (Exp fact)

-- | Recursive definition of fibonacci (using mu binders)
fibt :: Term Id (Integer -> Integer)
fibt = mu (\(lower -> f) -> lam (\(lower -> n) ->
        If (pred n)
            (pure 1)
            (next f n)
    ))
    where pred n = pure (n<1)
          next f n = let n1 = f <$> pure (n - 1)
                 n2 = f <$> pure (n - 2)
             in (+) <$>  n1 <*> n2 
-- | Fib function
fib :: Integer -> Integer
fib = eval (Exp fibt)          

-- | Evaluator for a expression
eval :: Exp t -> t
eval (Exp f) = evalC f  

-- | Evaluator for a PHOAS term
-- Evaluation of mu terms is defined with fix `fix f = let x = f x in x` to optimize sharing.
evalC :: Variable v => Term v t -> t
evalC (App f a) = evalC f $ evalC a
evalC (Var t) = lower t
evalC (Lam f) = \a -> evalC ( f (raise a)) 
evalC (If cond th el) = case evalC (cond) of
                True -> evalC th
                False -> evalC el
evalC (Eq a b) = evalC a == evalC b
evalC (Mu f) = fix (evalC . f . raise)
evalC (MuN f) = head $ fix (fmap evalC . f . fmap raise)