Skip to content

Instantly share code, notes, and snippets.

@Kaisia-Estrel

Kaisia-Estrel/Main.hs

Created November 10, 2022 12:52
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save Kaisia-Estrel/9641d4b89ca0868426e4a5ae411056ab to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save Kaisia-Estrel/9641d4b89ca0868426e4a5ae411056ab to your computer and use it in GitHub Desktop.
Download ZIP
Simple Interpreter
Raw
Main.hs
{-# LANGUAGE LambdaCase #-}
module Main (main) where
import SimpleInteractiveInterpreter
import System.Console.Haskeline
main :: IO ()
main = runInputT defaultSettings (loop newInterpreter)
where
loop :: Interpreter -> InputT IO ()
loop env = do
getInputLine "λ> " >>= \case
Nothing -> loop env
Just ":q" -> return ()
Just ":r" -> loop newInterpreter
Just s -> do
case input s env of
Left x -> do
outputStrLn x
loop env
Right (out,newenv) -> do
outputStr $ maybe "" ((++"\n") . show) out
loop newenv
Raw
SimpleInteractiveInterpreter.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
module SimpleInteractiveInterpreter
( Interpreter
, Result
, newInterpreter
, input
, functionCall
, expr
) where
import Control.Lens
import Control.Monad.Combinators.Expr ( Operator(InfixL)
, makeExprParser
)
import Control.Monad.State
import Data.Function
import qualified Data.Map as M
import Data.Void ( Void )
import Text.Megaparsec hiding ( empty )
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import Data.Maybe
import Data.Char
data Arithmetic
= Add Expr Expr
| Sub Expr Expr
| Mul Expr Expr
| Div Expr Expr
| Mod Expr Expr
deriving Show
data Expr
= Function String [String] Expr
| Assignment String Expr
| FunctionCall String [Expr]
| Operation Arithmetic
| Parens Expr
| Variable String
| Constant Double
deriving Show
(.*.) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.*.) = (.) . (.)
{-# INLINE (.*.) #-}
type Parser = Parsec Void String
lexeme :: Parser a -> Parser a
lexeme = L.lexeme space
symbol :: String -> Parser String
symbol = L.symbol space
identifier :: Parser String
identifier = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_')
constant, variable, parens, term, operation, factor, assignment, functionCall, function, expr
:: Parser Expr
constant = Constant <$> L.decimal
variable = Variable <$> identifier
parens = (symbol "(" `between` symbol ")") (Parens <$> expr)
term = constant <|> variable <|> parens
operation = makeExprParser
(lexeme term)
[[binary "*" Mul, binary "/" Div, binary "%" Mod], [binary "+" Add, binary "-" Sub]]
where binary s f = InfixL (Operation .*. f <$ symbol s)
functionCall =
FunctionCall <$> lexeme identifier <*> (some (lexeme constant) <|> some functionCall)
assignment = Assignment <$> lexeme identifier <*> (symbol "=" *> expr)
factor = choice [try assignment, constant, variable, parens]
function =
Function
<$> (symbol "fn" *> lexeme identifier)
<*> (many (lexeme identifier) <* symbol "=>")
<*> expr
expr = function <|> try assignment <|> try functionCall <|> try operation <|> factor
newtype Interpreter = Interpreter {
_mem :: M.Map String (Maybe [String], Expr)
} deriving Show
makeLenses ''Interpreter
type Result = Maybe Double
lookupError :: String -> Either String Result
lookupError name = Left $ "ERROR: No value with name '" ++ name ++ "' found."
invalidType :: String -> String -> Either String Result
invalidType name s = Left $ "ERROR: attempt to use value '" ++ name ++ "' as a '" ++ s ++ "'"
inputSt :: Expr -> StateT Interpreter (Either String) Result
inputSt (Constant n ) = return (Just n)
inputSt (Variable name) = gets (M.lookup name . view mem) >>= \case
Just (Nothing ,ex) -> inputSt ex
Just (Just (_:_) , _) -> lift $ invalidType name "variable"
Just (Just [] , body) -> inputSt body
Nothing -> lift (lookupError name)
inputSt (Parens e) = inputSt e
inputSt (Operation opp) = case opp of
Add x y -> liftM2 (+) <$> inputSt x <*> inputSt y
Sub x y -> liftM2 (-) <$> inputSt x <*> inputSt y
Mul x y -> liftM2 (*) <$> inputSt x <*> inputSt y
Div x y -> liftM2 (/) <$> inputSt x <*> inputSt y
Mod x y -> liftM2 (fromInteger .*. mod `on` round) <$> inputSt x <*> inputSt y
inputSt (FunctionCall name arguments) = do
gets (M.lookup name . view mem) >>= \case
Nothing -> lift $ lookupError name
Just (args, body) -> do
case applyVars (fromMaybe [] args) arguments of
Left False -> lift $ Left "Too many arguments passed"
Left True -> lift $ Left "Too little arguments passed"
Right xs -> do
temp <- get
mapM_ inputSt xs
output <- inputSt body
put temp
return output
where
applyVars :: [String] -> [Expr] -> Either Bool [Expr]
applyVars (a:as) (b:bs) = (:) <$> Right (Assignment a b) <*> applyVars as bs
applyVars [] (_:_) = Left False
applyVars (_:_) [] = Left True
applyVars [] [] = Right []
inputSt (Assignment name value) = do
gets (M.lookup name . view mem) >>= \case
Just (Just _, _) ->
lift $ Left $ "TYPE ERROR: Attempt to assign a variable to function: '" ++ name ++ "'."
_ -> mem %= M.insertWith const name (Nothing,value)
inputSt value
inputSt (Function name args body) = do
gets (M.lookup name . view mem) >>= \case
Just (Nothing, _) ->
lift $ Left $ "TYPE ERROR: Attempt to assign a function to variable: '" ++ name ++ "'."
_ -> do
temp <- get
put newInterpreter
mapM_ (inputSt . (`Assignment` Constant 0)) args
_ <- inputSt body
put temp
mem %= M.insertWith const name (Just args, body)
return Nothing
newInterpreter :: Interpreter
newInterpreter = Interpreter M.empty
input :: String -> Interpreter -> Either String (Result, Interpreter)
input s interpreter
| all isSpace s = Right (Nothing, interpreter)
| otherwise = either (Left . errorBundlePretty) ((`runStateT` interpreter) . inputSt)
$ parse (expr <* eof) "" s
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment