Haskell: Parsec problem

{-# LANGUAGE InstanceSigs #-}

module Forth (ForthError (..), ForthState, evalText, toList, emptyState) where

import Data.Char (isDigit, isLetter)
import Data.Functor (($>))
import Data.Map (Map, empty, insert)
import Data.Text (Text, pack, toLower)
import Text.Parsec
import Text.Parsec.Text (Parser)
import Prelude hiding (drop)

data ForthError
  = DivisionByZero
  | StackUnderflow
  | InvalidWord
  | UnknownWord Text
  deriving (Show, Eq)

data Command = Command
  { runCommand :: ForthState -> Either ForthError ForthState,
    name :: String
  }

instance Show Command where
  show :: Command -> String
  show cmd = "<command " ++ name cmd ++ " >"

data ForthState = ForthState [Int] (Map String Command)

emptyState :: ForthState
emptyState = ForthState [] empty

evalText :: Text -> ForthState -> Either ForthError ForthState
evalText text' stack = undefined
  where
    text = toLower text'

    cmds = parse parseForthS "useless.log" text

toList :: ForthState -> [Int]
toList (ForthState xs _) = xs

parseForthS :: Parser [Command]
parseForthS = spaces *> (parseForth `sepEndBy` spaces)

parseForth :: Parser Command
parseForth =
  try (push <$> many1 (satisfy isDigit))
    <|> try (char '+' $> Command add "add")
    <|> try (char '-' $> Command sub "sub")
    <|> try (char '*' $> Command mul "mul")
    <|> try (char '/' $> Command di "div")
    <|> try (string "dup" $> Command dup "dup")
    <|> try (string "drop" $> Command drop "drop")
    <|> try (string "swap" $> Command swap "swap")
    <|> try (string "over" $> Command over "over")
    <|> try
      ( between
          (char ':' <* spaces)
          (char ';')
          ( liftA2
              define
              -- identifier
              (many1 $ satisfy isLetter)
              -- expressions
              parseForthS
          )
      )
    <|> (noop <$> many1 (satisfy (/= ' ')))
  where
    push x = Command body "push"
      where
        body (ForthState s m) = Right $ ForthState (read x : s) m

    add (ForthState (x : y : xs) m) = Right $ ForthState (y + x : xs) m
    add _ = Left StackUnderflow

    sub (ForthState (x : y : xs) m) = Right $ ForthState (y - x : xs) m
    sub _ = Left StackUnderflow

    mul (ForthState (x : y : xs) m) = Right $ ForthState (y * x : xs) m
    mul _ = Left StackUnderflow

    di (ForthState (x : y : xs) m)
      | x /= 0 = Right $ ForthState ((y `div` x) : xs) m -- TODO: may be broken
      | otherwise = Left DivisionByZero
    di _ = Left StackUnderflow

    dup (ForthState (x : xs) m) = Right $ ForthState (x : x : xs) m
    dup _ = Left StackUnderflow

    drop (ForthState (_ : xs) m) = Right $ ForthState xs m
    drop _ = Left StackUnderflow

    swap (ForthState (x : y : xs) m) = Right $ ForthState (y : x : xs) m
    swap _ = Left StackUnderflow

    over (ForthState (x : y : xs) m) = Right $ ForthState (y : x : y : xs) m
    over _ = Left StackUnderflow

    define :: String -> [Command] -> Command
    define w expressinos = Command (\(ForthState xs m) -> Right $ ForthState xs $ insert w body m) "define-command"
      where
        body = Command eff "define-body"
        eff fs = foldl app (Right fs) expressinos
        app :: Either ForthError ForthState -> Command -> Either ForthError ForthState
        app (Right fs@(ForthState _ _)) cmd = runCommand cmd fs
        app (Left fe) _ = Left fe

    noop x = Command (\_ -> Left $ UnknownWord $ pack x) "noop"