-
-
Save Exegetech/dd9685d422524f73c1005241856b342a to your computer and use it in GitHub Desktop.
simple concatenative interpreter
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE DeriveDataTypeable #-} | |
| {-# LANGUAGE LambdaCase #-} | |
| import Control.Monad | |
| import Data.Data | |
| import Data.Typeable | |
| import System.IO | |
| import System.Exit | |
| type Stack = [Lit] | |
| data Named a = Named | |
| { nValue :: a | |
| , nName :: String | |
| } | |
| deriving (Show, Eq, Ord) | |
| data Lit | |
| = LitInt Int | |
| | LitChar Char | |
| | LitBool Bool | |
| deriving (Show, Eq, Ord, Data, Typeable) | |
| ppLit :: Lit -> String | |
| ppLit = \case | |
| LitInt x -> show x | |
| LitChar x -> show x | |
| LitBool x -> show x | |
| litType :: Lit -> String | |
| litType = drop 3 . show . toConstr | |
| data Expr | |
| = Lit Lit | |
| | Fun (Stack -> Either String Stack) | |
| funcs :: [Named (Stack -> Either String Stack)] | |
| funcs = | |
| [ pure `Named` "id" | |
| , ints2 $ (+) `Named` "+" | |
| , ints2 $ (-) `Named` "-" | |
| , ints2 $ (*) `Named` "*" | |
| , toStack2 $ (\x y -> pure [y, x]) `Named` "swap" | |
| ] | |
| toStack2 :: Named (Lit -> Lit -> Either String Stack) -> Named (Stack -> Either String Stack) | |
| toStack2 (Named f name) = (`Named` name) $ \case | |
| x : y : rest -> (++rest) <$> f x y | |
| xs -> Left $ "Too few arguments for function " ++ name ++ ". expecting 2 but got " ++ show (length xs) | |
| ints2 :: Named (Int -> Int -> Int) -> Named (Stack -> Either String Stack) | |
| ints2 (Named f name) = toStack2 $ g `Named` name | |
| where | |
| g x y = case (x, y) of | |
| (LitInt n, LitInt m) -> pure [LitInt $ f n m] | |
| _ -> Left $ "Unexpected argument types. expecting Int, Int but got: " ++ litType x ++ ", " ++ litType y | |
| env :: [(String, Stack -> Either String Stack)] | |
| env = map toEnv funcs | |
| where | |
| toEnv x = (nName x, nValue x) | |
| emsum :: a -> [Either a b] -> Either a b | |
| emsum e list = case list of | |
| Left _ : next -> emsum e next | |
| Right r : _ -> pure r | |
| _ -> Left e | |
| parseExpr :: String -> Either String Expr | |
| parseExpr str = case lookup str env of | |
| Just f -> pure $ Fun $ f | |
| Nothing -> Lit <$> emsum ("'" ++ str ++ "' is not in the environment nor it can be parsed as a Lit.") | |
| [ LitInt <$> parseLit str | |
| , LitChar <$> parseLit str | |
| , LitBool <$> parseLit str | |
| ] | |
| parseLit :: Read a => String -> Either String a | |
| parseLit str = case reads str of | |
| [(result, "")] -> pure result | |
| _ -> Left $ "Failed to parse '" ++ str ++ "' as Lit" | |
| parse :: String -> Either String [Expr] | |
| parse = mapM parseExpr . words | |
| evalExpr :: Expr -> Stack -> Either String Stack | |
| evalExpr e stack = case e of | |
| Lit x -> pure $ x : stack | |
| Fun f -> f stack | |
| eval :: String -> Stack -> Either String Stack | |
| eval line stack = | |
| parse line | |
| >>= foldM (flip evalExpr) stack | |
| main :: IO () | |
| main = do | |
| hSetBuffering stdout NoBuffering | |
| putStrLn "concat interpreter. :q to quit." | |
| go [] | |
| putStrLn "Bye." | |
| where | |
| go stack = do | |
| putStr "> " | |
| line <- getLine | |
| case line of | |
| ":q" -> | |
| pure () | |
| _ -> do | |
| case eval line stack of | |
| Left err -> do | |
| putStrLn $ "*** Error: " ++ err | |
| go stack | |
| Right s' -> do | |
| mapM_ (putStrLn . ppLit) s' | |
| go s' |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment