diff --git a/forth.hs b/forth.hs index 74023ac..2e7c886 100644 --- a/forth.hs +++ b/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 = - 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 +evalText t state = runParsed state $ parseWords t + +-- 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 (*) + "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