Context: I'm writing an interpreter for a language which is basically a small subset of Haskell.
Haskell's lazy evaluation is being a poo and refusing to evaluate this trace
command due to (I suspect) an infinite recursion which results in an "Out of memory" exception.
evalE :: VEnv -> Exp -> Value
evalE g e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") False = undefined
-- actual definition of evalE follows from here
-- ...
I'm getting the following result:
weber % ./run_tests.sh
Building minhs-0.1.0.0...
Preprocessing executable 'minhs-1' for minhs-0.1.0.0...
Check.hs: out of memory (requested 1048576 bytes)
weber %
Is there some easy way to force trace
to evaluate, regardless of the exception? Perhaps a way to quickly force strict evaluation? I really would like to get some debugging info about what it's actually trying to evaluate.
edit: some further googling has revealed the ($!) operator, which is supposed to force strictness. However I've added it to my code and nothing has changed:
evalE g e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") $! False = undefined
Any other hints? I really want to force that trace to evaluate it's side effects.
edit2: yet more googling revealed the seq
operator, however it is not behaving as advertised.
evalE g e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") False `seq` False = undefined
Even this refuses to print the trace.
I also worked out how to get the BangPatterns extension working, but that didn't print the trace either:
evalE !g !e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") False = undefined
(full file for reference. It's a multifile program though):
module MinHS.Evaluator where
import qualified MinHS.Env as E
import MinHS.Syntax
import MinHS.Pretty
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import Debug.Trace
type VEnv = E.Env Value
data Value = I Integer
| B Bool
| Nil
| Cons Integer Value
| Fun VEnv [String] Exp
deriving (Show)
instance PP.Pretty Value where
pretty (I i) = numeric $ i
pretty (B b) = datacon $ show b
pretty (Nil) = datacon "Nil"
pretty (Cons x v) = PP.parens (datacon "Cons" PP.<+> numeric x PP.<+> PP.pretty v)
pretty _ = undefined -- should not ever be used
evaluate :: Program -> Value
evaluate [Bind _ _ _ e] = evalE E.empty e
evaluate bs = evalE E.empty (Let bs (Var "main"))
instance Num Value where
I x + I y = I (x + y)
I x * I y = I (x * y)
I x - I y = I (x - y)
abs (I x) = I (abs x)
fromInteger x = I x
instance Integral Value where
div _ (I 0) = error $ "Cannot divide by zero"
div (I x) (I y) = I (div x y)
mod (I x) (I y) = I (mod x y)
instance Real Value where
instance Enum Value where
instance Ord Value where
I x > I y = x > y
I x >= I y = x >= y
I x <= I y = x <= y
I x < I y = x < y
instance Eq Value where
I x == I y = x == y
I x /= I y = x /= y
evalE :: VEnv -> Exp -> Value
evalE g e | trace ("VEnv: " ++ show g ++ "\nExp: " ++ show e ++ "\n\n") False = undefined
evalE g (Num x) = I x
evalE g (App (Prim Neg) x) = (evalE g x) * (-1)
evalE g (Con "False") = B False
evalE g (Con "True") = B True
evalE g (Con "Nil") = Nil
evalE g (App (App (Prim Gt) x) y) = B ((evalE g x) > (evalE g y))
evalE g (App (App (Prim Ge) x) y) = B ((evalE g x) >= (evalE g y))
evalE g (App (App (Prim Lt) x) y) = B ((evalE g x) < (evalE g y))
evalE g (App (App (Prim Le) x) y) = B ((evalE g x) <= (evalE g y))
evalE g (App (App (Prim Eq) x) y) = B ((evalE g x) == (evalE g y))
evalE g (App (App (Prim Ne) x) y) = B ((evalE g x) /= (evalE g y))
evalE g (App (Prim Head) (Con "Nil")) = error $ "Cannot take head of empty list"
evalE g (App (Prim Tail) (Con "Nil")) = error $ "Cannot take tail of empty list"
evalE g (App (Prim Head) (App (App (Con "Cons") x) _)) = evalE g x
evalE g (App (Prim Tail) (App (App (Con "Cons") _) x)) = evalE g x
evalE g (App (Prim Null) list) = case evalE g list of
Nil -> B True
_ -> B False
evalE g (App (App (Con "Cons") (Num x)) y) = Cons x (evalE g y)
evalE g (App (App (Prim Add) x) y) = (evalE g x) + (evalE g y)
evalE g (App (App (Prim Mul) x) y) = (evalE g x) * (evalE g y)
evalE g (App (App (Prim Sub) x) y) = (evalE g x) - (evalE g y)
evalE g (App (App (Prim Quot) x) y) = div (evalE g x) (evalE g y)
evalE g (App (App (Prim Rem) x) y) = mod (evalE g x) (evalE g y)
evalE g (Let bindings exp) = evalE ((E.addAll g . (map (\(Bind str _ _ bexp) -> (str, evalE g bexp)))) bindings) exp
evalE g e@(Var x) = case E.lookup g x of
Just y -> y
Nothing -> error $ "Variable " ++ x ++ " not defined" ++ errz g e
evalE g (If exp t f) = case evalE g exp of
B True -> evalE g t
B False -> evalE g f
evalE g e@(Letfun (Bind name _ args exp)) = Fun (E.add g (name, evalE g e)) args exp
evalE g e@(App (Var x) exp) = case E.lookup g x of
Just (Fun env args f) -> evalE (E.addAll env [(head args, evalE g exp)]) f
Nothing -> error $ "Function " ++ x ++ " not defined" ++ errz g e
evalE g (App exp1 exp2) = case evalE g exp1 of
Fun env args f -> evalE (E.addAll env [(head args, evalE g exp2)]) f
evalE g e = error $ "No pattern" ++ errz g e
--evalE g e = error "Implement me!"
errz g e = "\nVEnv: \n" ++ show g ++ "\n\nExp: \n" ++ show e