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,36 +32,54 @@ 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,
-        "+"       -> forthOp (+)
+-- probably a better way to do this
-        "-"       -> forthOp (-)
+runParsed :: a -> [a -> Either b a] -> Either b a
-        "*"       -> forthOp (*)
+runParsed acc [] = Right $ acc
-        "DUP"     -> forthDup
+runParsed acc (fn:fns) =
-        "DROP"    -> forthDrop
+    case (fn acc) of
-        "SWAP"    -> forthSwap
+        Right v  -> runParsed v fns
-        "OVER"    -> forthOver
+        Left err -> Left err
-        otherwise -> appendAsNum
+
-    where
+-- Interpret Forth code text to list of functions
-    appendAsNum =
+parseWords :: Text -> [ForthState -> Either ForthError ForthState]
-        case decimal text of
+parseWords = map (parseWord) . T.words
-            Right v -> forthAppend $ fst v
+
-            Left _ -> \_ -> Left $ UnknownWord text
+-- Translate single word to a Forth instruction
+parseWord :: Text -> ForthState -> Either ForthError ForthState
+parseWord str =
+    case str of
+        "/"    -> forthSafeDiv
+        "+"    -> forthOp (+)
+        "-"    -> forthOp (-)
+        "*"    -> forthOp (*)
+        "DUP"  -> forthDup
+        "DROP" -> forthDrop
+        "SWAP" -> forthSwap
+        "OVER" -> forthOver
+        _      -> case decimal str of -- if not function: try to parse as int
+                    Right v  -> forthAppend $ fst v
+                    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