Last active
October 3, 2016 15:13
-
-
Save aratama/1b5a87c15c3a01ed4ea1c6cfc936cdb4 to your computer and use it in GitHub Desktop.
PoorScript Interpreter (Monad transformers version)
This file contains 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
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