PoorScript Interpreter (Monad transformers version)

Main.purs

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