[Haskell-cafe] Re: Re: implementing recursive let

[Ben Franksen]

Ben Franksen wrote:
> Ok, it seems I have a version that does what I want. It is not very
> elegant, I have to manually wrap/unwrap the ErrorT stuff just for the Val
> case, but at least it seems to work. Here it goes:
> 
>> eval (Var x) = Eval $ ErrorT $ do
>>   env <- get
>>   v <- case M.lookup x env of
>>     Just v -> return v
>>     Nothing -> do
>>       warning ("reference to undefined variable " ++ show x)
>>       let v = Data ""
>>       modify (M.insert x v)
>>       return v
>>   return (Right v)
>> 
>> warning s = tell $ ["Warning: " ++ s]

While this works for simple var=constant declarations, it breaks down again
as soon as I add lambdas and application. Same symptoms as before: eval
loops; and it works again if I remove the ErrorT (but then I get a pattern
match failure if I apply a non-function which is of course what I wanted to
avoid with the ErrorT).

This is maddening! There must be some way to get mutual recursion to work
while still allowing for clean handling of failure. What galls me the most
is that it is so unpredictable whether the program will terminate with a
given input or not.

(The code is attached.)

Cheers
Ben
-------------- next part --------------
{-# LANGUAGE RecursiveDo, GeneralizedNewtypeDeriving,
TypeSynonymInstances, MultiParamTypeClasses #-}
import Control.Monad
import Control.Monad.State
import Control.Monad.Error
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Fix
import qualified Data.Map as M

data Expr = Let [(String, Expr)] Expr | Const Int | Var String
          | Lam String Expr | App Expr Expr

data Value = Data String | Function (Value -> Eval Value)

instance Show Value where
    show (Data s) = s

type Env = M.Map String Value

eval :: Expr -> Eval Value
eval (Const n) = return (Data (show n))
eval (Var x) = Eval $ noError $ do
  env <- get
  case M.lookup x env of
    Just v -> return v
    Nothing -> do
      warning ("reference to undefined variable " ++ show x)
      let v = Data ""
      modify (M.insert x v)
      return v
eval (Let decls body) = mdo
  let (names,exprs) = unzip decls
      updateEnv env = foldr (uncurry M.insert) env $ zip names values
  (values,result) <- local updateEnv $ liftM2 (,) (mapM eval exprs) (eval body)
  return result
eval (Lam parm body) = do
  env <- ask
  return $ Function (\val -> local (\_ -> M.insert parm val env) (eval body))
eval (App fun arg) = do
  f <- eval fun
  x <- eval arg -- call-by-value, so evaluate the arg first
  case f of
    Function f -> f x

warning s = tell $ ["Warning: " ++ s]

newtype Eval a = Eval {
    unEval :: ErrorT String (StateT Env (Writer [String])) a
  } deriving (
    Monad, MonadFix, MonadWriter [String],
    MonadState Env, MonadError String
  )

runEval :: Eval Value -> Either String Value
runEval = fst . runWriter . flip evalStateT M.empty . runErrorT . unEval

evaluate = runEval . eval

instance MonadReader Env Eval where
  ask = get
  local tr act = do
    s <- get
    modify tr
    r <- act
    put s
    return r

noError ::  (Monad m, Error e) => ErrorT e m a -> ErrorT e m a
noError m = ErrorT $ do
  ~(Right r) <- runErrorT m
  return (Right r)

-- examples
good1 = Let [("x", Const 1)] (Var "x")
good2 = Let [("y", Var "x"),("x", Const 1)] (Var "y")
bad1 = Let [("x", Const 1)] (Var "y")
letf = Let [("f",Lam "x" (Var "x"))] (App (Var "f") (Const 1))
badapp = Let [("f",Lam "x" (Var "x"))] (App (Const 1) (Var "f"))