PoorScript Interpleter (Extensible Effects 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.Lazy (fix)
import Control.Monad.ST
import Control.Monad.Eff.Class
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 (sepBy1)

-- 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 h = State {
    operators :: Map String (STRef h (State h) -> List Expression -> Eff (err :: EXCEPTION, st :: ST h) Expression),
    variables :: Map String Expression
}

eval :: forall h . STRef h (State h) -> Expression -> Eff (err :: EXCEPTION, st :: ST h) Expression
eval ref = go
  where
    go :: Expression -> Eff (err :: EXCEPTION, st :: ST h) Expression
    go (Number n) = pure (Number n)
    go (String s) = pure (String s)
    go (Boolean b) = pure (Boolean b)
    go (List (String op : args)) = do
        State st <- readSTRef ref
        maybe (throw ("Unknown operator: " <> op)) (\f -> f ref args) (lookup op st.operators)
    go (Assignment key value) = do
        value' <- go value
        modifySTRef ref \(State s) -> State s { variables = insert key value' s.variables }
        pure value'
    go _ = throw "Invalid expression"

operators :: forall h . Map String (STRef h (State h) -> List Expression -> Eff (st :: ST h, err :: EXCEPTION) Expression)
operators = fromFoldable [
    Tuple "+" $ fromOp (+),
    Tuple "-" $ fromOp (-),
    Tuple "*" $ fromOp (*),
    Tuple "/" $ fromOp (/),
    Tuple "=" \ref args -> case args of
        x : xs -> do
            x' <- eval ref x
            xs' <- for xs (eval ref)
            pure $ Boolean $ all ((==) x') xs'
        _ -> throw "Invalid args in =",
    Tuple "set" \ref args -> case args of
        key : value : _ -> do
            key' <- eval ref key
            case key' of
                String key'' -> do
                    value' <- eval ref value
                    modifySTRef ref \(State s) -> State s { variables = insert key'' value' s.variables }
                    pure value'
                _ -> throw "the key is not a string"
        _ -> throw "Invalid args",
    Tuple "get" \ref args -> case args of
        String k : Nil -> do
            State state <- readSTRef ref
            maybe (throw "No Variable") pure (lookup k state.variables)
        _ -> throw "Invalid args",
    Tuple "until" \ref args -> case args of
        cond: body: _ -> let go retVal = do
                                    c <- eval ref cond
                                    case c of
                                        Boolean b | not b -> do
                                            eval ref body
                                            go retVal
                                        Boolean b | b -> pure retVal
                                        _ -> throw "Invalid args in until"
                                            in go (Boolean false)
        _ -> throw "Invalid args in until",
    Tuple "step" \ref args -> case args of
        x: xs -> foldl (*>) (eval ref x) (eval ref <$> xs)
        _ -> throw "too few args"
]
  where
    fromOp :: forall h . (Number -> Number -> Number) -> STRef h (State h) -> List Expression -> Eff (st :: ST h, err :: EXCEPTION) Expression
    fromOp f ref Nil = throw "Too few args"
    fromOp f ref (x : xs) = do
        x' <- evalNum ref x
        xs' <- for xs (evalNum ref)
        pure $ Number $ foldl f x' xs'

    evalNum :: forall h . STRef h (State h) -> Expression -> Eff (st :: ST h, err :: EXCEPTION) Number
    evalNum ref n = do
        n' <- eval ref n
        case n' of
            Number n -> pure n
            _ -> throw "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 -> do
                let result = pureST do
                        ref <- newSTRef (State { operators, variables: empty })
                        try (eval ref program)
                case result of
                    Right value -> log $ file <> ": " <> show value
                    Left err -> log $ file <> ": " <> show err