Create a gist now

Instantly share code, notes, and snippets.

@aratama /Main.purs
Last active Oct 3, 2016

What would you like to do?
PoorScript Interpreter (Monad transformers version)
module Main where
import Control.Alt
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff
import Control.Monad.Eff.Exception
import Control.Monad.Aff.Console (log, logShow)
import Control.Monad.State.Trans
import Control.Lazy (fix)
import Data.Int
import Data.Either
import Data.Identity
import Data.List (List(Nil, Cons), (:), many)
import Data.Traversable
import Data.Map (Map, fromFoldable, lookup, empty, insert)
import Data.Tuple
import Data.Maybe (maybe)
import Node.FS.Aff
import Node.FS
import Node.Encoding
import Prelude
import Text.Parsing.Parser
import Text.Parsing.Parser.Language
import Text.Parsing.Parser.Token (GenTokenParser, makeTokenParser)
import Text.Parsing.Parser.String
import Text.Parsing.Parser.Combinators
-- Syntax tree
data Expression = Boolean Boolean
| Number Number
| String String
| List (List Expression)
| Assignment String Expression
instance eq_Expression :: Eq Expression where
eq (Boolean x) (Boolean y) = x == y
eq (Number x) (Number y) = x == y
eq (String x) (String y) = x == y
eq (List xs) (List ys) = xs == ys
eq _ _ = false
instance show_Expression :: Show Expression where
show (Boolean x) = show x
show (Number x) = show x
show (String x) = show x
show (List xs) = show xs
show (Assignment key value) = key <> "=" <> show value
-- parser
lexer :: GenTokenParser String Identity
lexer = makeTokenParser emptyDef
program :: Parser String Expression
program = lexer.whiteSpace *> expression <* eof
where
sign = (char '-' *> pure negate) <|> (char '+' *> pure id) <|> pure id
number = Number <$> (sign <*> (either toNumber id <$> lexer.naturalOrFloat))
string = String <$> lexer.stringLiteral
list expression = List <$> lexer.brackets (sepBy1 expression lexer.comma)
assignment expression = Assignment <$> lexer.identifier <*> (lexer.symbol "=" *> expression)
expression = fix \expression -> string <|> number <|> list expression <|> assignment expression
-- evaluator
newtype State = State {
operators :: Map String (List Expression -> StateT State (Either String) Expression),
variables :: Map String Expression
}
eval :: Expression -> StateT State (Either String) Expression
eval (Number n) = lift $ Right (Number n)
eval (String s) = lift $ Right (String s)
eval (Boolean b) = lift $ Right (Boolean b)
eval (List (String op : args)) = do
State st <- get
maybe (lift $ Left $ "Unknown operator: " <> op) ((#) args) (lookup op st.operators)
eval (Assignment key value) = do
value' <- eval value
modify \(State s) -> State s { variables = insert key value' s.variables }
lift (pure value')
eval _ = lift $ Left "Invalid expression"
operators :: Map String (List Expression -> StateT State (Either String) Expression)
operators = fromFoldable [
Tuple "+" $ fromOp (+),
Tuple "-" $ fromOp (-),
Tuple "*" $ fromOp (*),
Tuple "/" $ fromOp (/),
Tuple "=" \args -> case args of
x : xs -> do
x' <- eval x
xs' <- for xs eval
lift $ Right $ Boolean $ all ((==) x') xs'
_ -> lift $ Left "Invalid args in =",
Tuple "set" \args -> case args of
key : value : _ -> do
key' <- eval key
case key' of
String key'' -> do
value' <- eval value
modify \(State s) -> State s { variables = insert key'' value' s.variables }
lift (pure value')
_ -> lift $ Left "the key is not a string"
_ -> lift $ Left "Invalid args",
Tuple "get" \args -> case args of
String k : Nil -> do
State state <- get
lift $ maybe (Left "No Variable") Right (lookup k state.variables)
_ -> lift $ Left "Invalid args",
Tuple "until" \args -> case args of
cond: body: _ -> let go retVal = do
c <- eval cond
case c of
Boolean b | not b -> do
eval body
go retVal
Boolean b | b -> lift (pure retVal)
_ -> lift $ Left "Invalid args in until"
in go (Boolean false)
_ -> lift $ Left "Invalid args in until",
Tuple "step" \args -> case args of
x: xs -> foldl (*>) (eval x) (eval <$> xs)
_ -> lift $ Left "too few args"
]
where
fromOp :: (Number -> Number -> Number) -> List Expression -> StateT State (Either String) Expression
fromOp f Nil = lift $ Left "Too few args"
fromOp f (x : xs) = do
x' <- evalNum x
xs' <- for xs evalNum
lift $ pure $ Number $ foldl f x' xs'
evalNum :: Expression -> StateT State (Either String) Number
evalNum n = do
n' <- eval n
lift case n' of
Number n -> Right n
_ -> Left "The Argument is not a number"
main :: Eff (fs :: FS, console :: CONSOLE, err :: EXCEPTION) Unit
main = void $ launchAff do
files <- readdir "test"
for files \file -> do
source <- readTextFile UTF8 ("test/" <> file)
case runParser source program of
Left err -> log $ file <> ": Syntax Error " <> show err
Right program -> case evalStateT (eval program) (State { operators, variables: empty }) of
Right value -> log $ file <> ": " <> show value
Left err -> log $ file <> ": " <> show err
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment