[Haskell-cafe] Interesting Thread on OO Usefulness (scala mailing list)

[Tillmann Rendel]

Hi,

Paolo Losi wrote:
> I'm following an interesting thread on the scala mailing list:
> 
> http://www.nabble.com/-scala--usefulness-of-OOP-td23268250.html
> 
> Martin Odersky advocates the OO features of the scala language
> proposing an interesting problem where the OO approach seams
> valuable.
> 
> I would be very much interested in seeing an Haskell solution
> to that problem. 

Here is my take on it, using type families.

   Tillmann


{-# LANGUAGE TypeFamilies #-}

import Data.List (elemIndex)

   -- COMMON INTERFACE --

-- environments and variables
class Env env where
   data V env
   empty :: env a
   bind :: (String, a) -> env a -> env a
   find :: env a -> V env -> a

   -- too bad we have to include these here :(
   showVar :: Int -> V env -> ShowS
   showEnv :: Show a => Int -> env a -> ShowS

   -- GENERIC INTERPRETER --

-- terms (for some type of variables v)
data T env
   = Lam [String] (T env)
   | App (T env) [T env]
   | Var (V env)
   | Lit Integer

instance Env env => Show (T env) where
   showsPrec p t = showParen (p > 10) $ case t of
     Lam vs t -> ("Lam " ++) . showsPrec 11 vs . (' ' :) . showsPrec 11 t
     App f xs -> ("App " ++) . showsPrec 11 f . (' ' :) . showsPrec 11 xs
     Var v    -> ("Var " ++) . showVar 11 v
     Lit n    -> ("Lit " ++) . showsPrec 11 n

-- domain of values
data D env
   = Fun [String] (T env) (env (D env))
   | Num Integer

instance Env env => Show (D env) where
   showsPrec p t = showParen (p > 10) $ case t of
     Fun vs t env -> ("Fun " ++) . showsPrec 11 vs . (' ' :) . showsPrec 
11 t . (' ' :) . showEnv 11 env
     Num n        -> ("Num " ++) . showsPrec 11 n

-- interpreter
eval :: Env env => env (D env) -> T env -> D env
eval env (Lam vs t) = Fun vs t env
eval env (App f xs) = apply (eval env f) (map (eval env) xs)
eval env (Var v   ) = find env v
eval env (Lit n   ) = Num n

apply :: Env env => D env -> [D env] -> D env
apply (Fun vs t env) xs
   | length vs == length xs = eval env' t
   | otherwise = error ("arity mismatch: " ++ show vs ++ ", " ++ show xs)
   where env' = foldr bind env (zip vs xs)
apply (Num n) xs = error "not a function"

   -- VARIABLES AS STRINGS --

data AssocList a = AssocList [(String, a)] deriving Show

instance Env AssocList where
   data V AssocList = Name String deriving Show
   empty = AssocList []
   bind (v, x) (AssocList env) = AssocList ((v, x) : env)
   find (AssocList env) (Name v)
     = case lookup v env of
         Just x -> x
         Nothing -> error "free variable"
   showVar = showsPrec
   showEnv = showsPrec

   -- VARIABLES AS De-BRUIJN INDICES --

data Stack a = Stack [a] deriving Show

instance Env Stack where
   data V Stack = Index Int deriving Show
   empty = Stack []
   bind (v, x) (Stack env) = Stack (x : env)
   find (Stack env) (Index v)
     = if v < length env
         then env !! v
         else error "free variable"
   showVar = showsPrec
   showEnv = showsPrec

   -- CONVERT NAMES TO DE-BRUIJN INDICES --

index :: [String] -> T AssocList -> T Stack
index vs (Lam ws t    ) = Lam ws (index (ws ++ vs) t)
index vs (App f xs    ) = App (index vs f) (map (index vs) xs)
index vs (Var (Name v)) = case elemIndex v vs of
                             Just n -> Var (Index n)
                             Nothing -> error "free variable"
index vs (Lit n       ) = Lit n


   -- TEST --

identity = Lam ["x"] (Var (Name "x"))
two = Lam ["f", "x"] (App (Var (Name "f"))
                           [(App (Var (Name "f")) [(Var (Name "x"))])])
five = App two [identity, Lit 5]

test = case (eval empty five, eval empty (index [] five)) of
          (Num 5, Num 5) -> True
          _ -> False