commit 875dcff8d48864c50dc704be7cec3f085adac8c2
Author: olemorud <ole.kristian.morud@cern.ch>
Date:   Sun May 7 12:47:35 2023 +0200

    Initial commit

diff --git a/forth.hs b/forth.hs
new file mode 100644
index 0000000..74023ac
--- /dev/null
+++ b/forth.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- This is a WIP solution to
+-- https://exercism.org/tracks/haskell/exercises/forth
+
+module Forth (
+    ForthError(..),
+    ForthState,
+    evalText,
+    toList,
+    emptyState
+) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Read
+import Data.Either
+import Data.Maybe
+
+data ForthError
+     = DivisionByZero
+     | StackUnderflow
+     | InvalidWord
+     | UnknownWord Text
+     deriving (Show, Eq)
+
+data ForthState = ForthState [Int]
+
+instance Show ForthState where
+  show (ForthState stack) = "ForthState " ++ show stack
+
+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 =
+    case text of
+        "/"       -> forthOp div
+        "+"       -> forthOp (+)
+        "-"       -> forthOp (-)
+        "*"       -> forthOp (*)
+        "DUP"     -> forthDup
+        "DROP"    -> forthDrop
+        "SWAP"    -> forthSwap
+        "OVER"    -> forthOver
+        otherwise -> appendAsNum
+    where
+    appendAsNum =
+        case decimal text of
+            Right v -> forthAppend $ fst v
+            Left _ -> \_ -> Left $ UnknownWord text
+
+-- 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
+
+-- Duplicate the stack head
+forthDup :: ForthState -> Either ForthError ForthState
+forthDup (ForthState (x:xs)) = Right $ ForthState (x:x:xs)
+forthDup _ = Left StackUnderflow
+
+-- Discard the stack head
+forthDrop :: ForthState -> Either ForthError ForthState
+forthDrop (ForthState (_:xs)) = Right $ ForthState xs
+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
+
+-- Copy second item to top
+forthOver :: ForthState -> Either ForthError ForthState
+forthOver (ForthState (x1:x2:xs)) = Right $ ForthState (x2:x1:x2:xs)
+forthOver _ = Left StackUnderflow
+
+-- Add v to the top of the stack
+forthAppend :: Int -> ForthState -> Either ForthError ForthState
+forthAppend v (ForthState (x:xs)) = Right $ ForthState (v:x:xs)
+
+toList :: ForthState -> [Int]
+toList (ForthState stack) = stack
+