Minimal working Forth

forth.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 
--- This is a WIP solution to
+-- Inspired by
 -- https://exercism.org/tracks/haskell/exercises/forth
 
 module Forth (
@@ -14,8 +14,8 @@ module Forth (
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Read
+import Text.Read
 import Data.Either
-import Data.Maybe
 
 data ForthError
      = DivisionByZero
@@ -32,13 +32,27 @@ instance Show ForthState where
 emptyState :: ForthState
 emptyState = ForthState []
 
--- Your evaluator has to support the following words:
---   +, -, *, / (integer arithmetic)
---   DUP, DROP, SWAP, OVER (stack manipulation)
 evalText :: Text -> ForthState -> Either ForthError ForthState
-evalText text =
+evalText t state = runParsed state $ parseWords t
-    case text of
+
-        "/"       -> forthOp div
+-- like foldl but applies a lists of functions that return Eithers to acc,
+-- probably a better way to do this
+runParsed :: a -> [a -> Either b a] -> Either b a
+runParsed acc [] = Right $ acc
+runParsed acc (fn:fns) =
+    case (fn acc) of
+        Right v  -> runParsed v fns
+        Left err -> Left err
+
+-- Interpret Forth code text to list of functions
+parseWords :: Text -> [ForthState -> Either ForthError ForthState]
+parseWords = map (parseWord) . T.words
+
+-- Translate single word to a Forth instruction
+parseWord :: Text -> ForthState -> Either ForthError ForthState
+parseWord str =
+    case str of
+        "/"    -> forthSafeDiv
         "+"    -> forthOp (+)
         "-"    -> forthOp (-)
         "*"    -> forthOp (*)
@@ -46,22 +60,26 @@ evalText text =
         "DROP" -> forthDrop
         "SWAP" -> forthSwap
         "OVER" -> forthOver
-        otherwise -> appendAsNum
+        _      -> case decimal str of -- if not function: try to parse as int
-    where
-    appendAsNum =
-        case decimal text of
                     Right v  -> forthAppend $ fst v
-            Left _ -> \_ -> Left $ UnknownWord text
+                    Left err ->  \_ -> Left $ UnknownWord $ str
+
+-- Pop a, b from stack, push a/b to top. If b is zero return DivisionByZero
+forthSafeDiv :: ForthState -> Either ForthError ForthState
+forthSafeDiv (ForthState (x1:x2:xs)) =
+    case x2 of
+        0 -> Left $ DivisionByZero
+        _ -> Right $ ForthState (div x1 x2:xs)
 
 -- Pop a, b from stack, apply `op` to them and push the result on top.
 forthOp :: (Int -> Int -> Int) -> ForthState -> Either ForthError ForthState
 forthOp op (ForthState (x1:x2:xs)) = Right $ ForthState (op x1 x2:xs)
-forthOp op _ = Left StackUnderflow
+forthOp op _ = Left InvalidWord
 
 -- Duplicate the stack head
 forthDup :: ForthState -> Either ForthError ForthState
 forthDup (ForthState (x:xs)) = Right $ ForthState (x:x:xs)
-forthDup _ = Left StackUnderflow
+forthDup _ = Left InvalidWord
 
 -- Discard the stack head
 forthDrop :: ForthState -> Either ForthError ForthState
@@ -71,16 +89,17 @@ forthDrop _ = Left StackUnderflow
 -- Swap the top two elements of the stack.
 forthSwap :: ForthState -> Either ForthError ForthState
 forthSwap (ForthState (xa:xb:xs)) = Right $ ForthState (xb:xa:xs)
-forthSwap _ = Left StackUnderflow
+forthSwap _ = Left InvalidWord
 
 -- Copy second item to top
 forthOver :: ForthState -> Either ForthError ForthState
 forthOver (ForthState (x1:x2:xs)) = Right $ ForthState (x2:x1:x2:xs)
-forthOver _ = Left StackUnderflow
+forthOver _ = Left InvalidWord
 
 -- Add v to the top of the stack
 forthAppend :: Int -> ForthState -> Either ForthError ForthState
 forthAppend v (ForthState (x:xs)) = Right $ ForthState (v:x:xs)
+forthAppend v _ = Right $ ForthState [v]
 
 toList :: ForthState -> [Int]
 toList (ForthState stack) = stack