Advertisement
leokostarev

Haskell: Parsec problem

Feb 4th, 2024
1,081
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. {-# LANGUAGE InstanceSigs #-}
  2.  
  3. module Forth (ForthError (..), ForthState, evalText, toList, emptyState) where
  4.  
  5. import Data.Char (isDigit, isLetter)
  6. import Data.Functor (($>))
  7. import Data.Map (Map, empty, insert)
  8. import Data.Text (Text, pack, toLower)
  9. import Text.Parsec
  10. import Text.Parsec.Text (Parser)
  11. import Prelude hiding (drop)
  12.  
  13. data ForthError
  14.   = DivisionByZero
  15.   | StackUnderflow
  16.   | InvalidWord
  17.   | UnknownWord Text
  18.   deriving (Show, Eq)
  19.  
  20. data Command = Command
  21.   { runCommand :: ForthState -> Either ForthError ForthState,
  22.     name :: String
  23.   }
  24.  
  25. instance Show Command where
  26.   show :: Command -> String
  27.   show cmd = "<command " ++ name cmd ++ " >"
  28.  
  29. data ForthState = ForthState [Int] (Map String Command)
  30.  
  31. emptyState :: ForthState
  32. emptyState = ForthState [] empty
  33.  
  34. evalText :: Text -> ForthState -> Either ForthError ForthState
  35. evalText text' stack = undefined
  36.  where
  37.    text = toLower text'
  38.  
  39.     cmds = parse parseForthS "useless.log" text
  40.  
  41. toList :: ForthState -> [Int]
  42. toList (ForthState xs _) = xs
  43.  
  44. parseForthS :: Parser [Command]
  45. parseForthS = spaces *> (parseForth `sepEndBy` spaces)
  46.  
  47. parseForth :: Parser Command
  48. parseForth =
  49.   try (push <$> many1 (satisfy isDigit))
  50.     <|> try (char '+' $> Command add "add")
  51.     <|> try (char '-' $> Command sub "sub")
  52.     <|> try (char '*' $> Command mul "mul")
  53.     <|> try (char '/' $> Command di "div")
  54.     <|> try (string "dup" $> Command dup "dup")
  55.     <|> try (string "drop" $> Command drop "drop")
  56.     <|> try (string "swap" $> Command swap "swap")
  57.     <|> try (string "over" $> Command over "over")
  58.     <|> try
  59.       ( between
  60.           (char ':' <* spaces)
  61.           (char ';')
  62.           ( liftA2
  63.               define
  64.               -- identifier
  65.               (many1 $ satisfy isLetter)
  66.               -- expressions
  67.               parseForthS
  68.           )
  69.       )
  70.     <|> (noop <$> many1 (satisfy (/= ' ')))
  71.   where
  72.     push x = Command body "push"
  73.       where
  74.         body (ForthState s m) = Right $ ForthState (read x : s) m
  75.  
  76.     add (ForthState (x : y : xs) m) = Right $ ForthState (y + x : xs) m
  77.     add _ = Left StackUnderflow
  78.  
  79.     sub (ForthState (x : y : xs) m) = Right $ ForthState (y - x : xs) m
  80.     sub _ = Left StackUnderflow
  81.  
  82.     mul (ForthState (x : y : xs) m) = Right $ ForthState (y * x : xs) m
  83.     mul _ = Left StackUnderflow
  84.  
  85.     di (ForthState (x : y : xs) m)
  86.       | x /= 0 = Right $ ForthState ((y `div` x) : xs) m -- TODO: may be broken
  87.       | otherwise = Left DivisionByZero
  88.     di _ = Left StackUnderflow
  89.  
  90.     dup (ForthState (x : xs) m) = Right $ ForthState (x : x : xs) m
  91.     dup _ = Left StackUnderflow
  92.  
  93.     drop (ForthState (_ : xs) m) = Right $ ForthState xs m
  94.     drop _ = Left StackUnderflow
  95.  
  96.     swap (ForthState (x : y : xs) m) = Right $ ForthState (y : x : xs) m
  97.     swap _ = Left StackUnderflow
  98.  
  99.     over (ForthState (x : y : xs) m) = Right $ ForthState (y : x : y : xs) m
  100.     over _ = Left StackUnderflow
  101.  
  102.     define :: String -> [Command] -> Command
  103.     define w expressinos = Command (\(ForthState xs m) -> Right $ ForthState xs $ insert w body m) "define-command"
  104.       where
  105.         body = Command eff "define-body"
  106.         eff fs = foldl app (Right fs) expressinos
  107.         app :: Either ForthError ForthState -> Command -> Either ForthError ForthState
  108.         app (Right fs@(ForthState _ _)) cmd = runCommand cmd fs
  109.         app (Left fe) _ = Left fe
  110.  
  111.     noop x = Command (\_ -> Left $ UnknownWord $ pack x) "noop"
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement