Proper 'throw' usage in VM

1 files changed, 15 insertions, 9 deletions

diff --git a/VM.hs b/VM.hs
index 138bf26..e0ed2f4 100644
--- a/VM.hs
+++ b/VM.hs
@@ -112,7 +112,10 @@ callClosure info@(Info bbmap gfds _) state@(State { sTempMap = tmap }) cl as =
 vmRunBuiltin :: State -> Name -> [RunValue] -> IO (RunValue, State)
 -- vmRunBuiltin _ name args | trace (name ++ " " ++ show args) False = undefined
 vmRunBuiltin state "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList [], state)
-vmRunBuiltin state "=" [a, b] = return (if equalOp a b then RVNum 1 else RVNum 0, state)
+vmRunBuiltin state "=" [a, b] = case equalOp a b of
+    Left err -> throw err
+    Right True -> return (RVNum 1, state)
+    Right False -> return (RVNum 0, state)
 vmRunBuiltin state "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b)), state)
 vmRunBuiltin state "+" [RVNum a, RVNum b] = return (RVNum (a + b), state)
 vmRunBuiltin state "-" [RVNum a, RVNum b] = return (RVNum (a - b), state)
@@ -165,17 +168,20 @@ vmRunBuiltin state "type-number?" [value] = return (RVNum (case value of { RVNum
 vmRunBuiltin state "type-string?" [value] = return (RVNum (case value of { RVString _ -> 1; _ -> 0 }), state)
 vmRunBuiltin state "type-quoted?" [value] = return (RVNum (case value of { RVQuoted _ -> 1; _ -> 0 }), state)
 vmRunBuiltin state "type-symbol?" [value] = return (RVNum (case value of { RVName _   -> 1; _ -> 0 }), state)
+vmRunBuiltin _ "error" [RVString str] = throw ("error: " ++ str)
 vmRunBuiltin _ name args = error (name ++ " " ++ show args)
 
-equalOp :: RunValue -> RunValue -> Bool
-equalOp (RVClosure _ _) _ = error "Cannot compare closures in '='"
-equalOp _ (RVClosure _ _) = error "Cannot compare closures in '='"
-equalOp (RVList vs) (RVList ws) = length vs == length ws && all id (zipWith equalOp vs ws)
-equalOp (RVNum a) (RVNum b) = a == b
-equalOp (RVString s) (RVString t) = s == t
+equalOp :: RunValue -> RunValue -> Either String Bool
+equalOp (RVClosure _ _) _ = Left "Cannot compare closures in '='"
+equalOp _ (RVClosure _ _) = Left "Cannot compare closures in '='"
+equalOp (RVList vs) (RVList ws)
+    | length vs == length ws = all id <$> sequence (zipWith equalOp vs ws)
+    | otherwise = Right False
+equalOp (RVNum a) (RVNum b) = Right (a == b)
+equalOp (RVString s) (RVString t) = Right (s == t)
 equalOp (RVQuoted v) (RVQuoted w) = equalOp v w
-equalOp (RVName n) (RVName m) = n == m
-equalOp _ _ = False
+equalOp (RVName n) (RVName m) = Right (n == m)
+equalOp _ _ = Right False
 
 printshow :: RunValue -> String
 printshow (RVString str) = str