拿Haskell写的Interpreter For JavaScript

 

At first, it’s better not to meet you

So we cannot fall in love

Then it’s better not to know you

So I don’t need to become lovesick

时隔一年，偶尔看到Haskell虽然还能看懂但是细枝末节的语法都忘了

决定收拾归纳一波以前写过的若干code，同时这个博客号已经申了两年了， 再放着都gammel了

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

使用Haskell完成一个简易版本的JavaScript的Interpreter，支持赋值，判断以及循环语句等。

主要是锻炼Monad的实际使用

 

自己记录之余为了方便与诸君共同交流学习，详细的功能都有备注。（因为cnblog没有支持haskell，如下代码的插入采用Scale替代）

如下是主体部分的code，完整repository计划在毕业后push到github上，届时将更新并附上链接。

 

Note:需转载请务必通知作者，否则法律责任后果自负

 

 

module SubsInterpreter
       (
         Value(..)
       , runExpr
       )
       where

import SubsAst

import Control.Monad
import qualified Data.Map as Map
import Data.Map(Map)
import Data.Foldable

{-
   A value is either an integer, the special constant undefined,
   true, false, a string, or an array of values.
   Expressions are evaluated to values.
-}
data Value = IntVal Int
           | UndefinedVal
           | TrueVal | FalseVal
           | StringVal String
           | ArrayVal [Value]
           deriving (Eq, Show)

type Error = String
type Env = Map Ident Value
type Primitive = [Value] -> Either Error Value
type PEnv = Map FunName Primitive
type Context = (Env, PEnv)

{-
  Takes as input the Context type, that is, the Map for Value types
  and the Map for functions/operators. More specifically, the function
  returns an emptry context, that is, emptry Map of each.
  Specifically the binding is:
  Context: (Map String Value, Map String ([Value] -> Either Error Value))
  So it returns the Either monad
-}
initialContext :: Context
initialContext = (Map.empty, initialPEnv)
  where initialPEnv =
          Map.fromList [ ("===", equalOp)
                       , ("<", lowerOp)
                       , ("+", plusOp)
                       , ("*", multOp)
                       , ("-", minusOp)
                       , ("%", moduloOp)
                       , ("Array", mkArray)
                       ]

{-
  The data type for the Monad, which takes a single type constructor
  and has a single field. Inside the field is the function runSubsM,
  the accessor function of the monad.
-}
newtype SubsM a = SubsM {runSubsM :: Context -> Either Error (a, Env)}

{-
  The Functor instance of SubsM. It contains the
  default implementation for fmap, which binds the
  return of the f a invocation to the state.
-}
instance Functor SubsM where
  fmap f m = m >>= \a -> return (f a)

{-
  The Appplicative instance of SubsM.
  Contains simply some placeholders for pure and
  (<*>) functions
-}
instance Applicative SubsM where
  pure = return
  (<*>) = ap

{-
  The Monad instance of SubsM. The return function returns
  The new result a is kept in the unchanged state env.
  The bind operator is done with a monad m and a function f.
  Here, we run the accessor function runSubsM with the monad m
  and state x. Then, we pattern match whether it returns Right
  or Left from the Either monad. For Right, we update the
  primitive environment and the new value that return from (f a)
-}
instance Monad SubsM where
  return a = SubsM (\(env, _) -> Right (a, env))
  m >>= f = SubsM (\x -> case runSubsM m x of
                    Right (a, env) -> let (_, penv) = x
                                      in runSubsM (f a) (env, penv)
                    Left err -> Left err
                )
  fail s = SubsM (\_ -> Left s)

{-
  Compares for structural equality without type coercions
  Comparison of number and string will always yield false
  The type binding alias is: [Value] -> Either Error Value
-}
equalOp :: Primitive
equalOp vals =
  case vals of
    [StringVal x, StringVal y] -> if x == y then return TrueVal
                            else return FalseVal
    [IntVal x, IntVal y] -> if x == y then return TrueVal
                            else return FalseVal
    [IntVal _, StringVal _] -> return FalseVal
    [StringVal _, IntVal _] -> return FalseVal
    [UndefinedVal, UndefinedVal] -> return UndefinedVal
    [TrueVal, FalseVal] -> return FalseVal
    [FalseVal, TrueVal] -> return FalseVal
    [FalseVal, FalseVal] -> return TrueVal
    [TrueVal, TrueVal] -> return TrueVal
    [ArrayVal a, ArrayVal b] -> if a == b then return TrueVal
                                else return FalseVal
    _ -> fail "Invalid equal operation"

{-
  Arguments for < should either be of the same type,
  e.g. both strings or both int, and for strings they should be
  compared in lexicographical order.
-}
lowerOp :: Primitive
lowerOp vals =
  case vals of
    [StringVal x, StringVal y] -> if x < y then return TrueVal
                            else return FalseVal
    [IntVal x, IntVal y] -> if x < y then return TrueVal
                            else return FalseVal
    [UndefinedVal, UndefinedVal] -> return UndefinedVal
    [TrueVal, FalseVal] -> return FalseVal
    [FalseVal, TrueVal] -> return TrueVal
    [FalseVal, FalseVal] -> return FalseVal
    [TrueVal, TrueVal] -> return FalseVal
    _ -> fail "Invalid lower than operation"

{-
  Somewhat strongly typed, no addition of boolean and integer for example.
  Except for addition: ok to add two strings or a string
  and a number in any order. Remember the conversation first.
  For two strings it is string concatenation.
-}
plusOp :: Primitive
plusOp vals =
  case vals of
    [StringVal x, StringVal y] -> return $ StringVal (x++y)
    [IntVal x, IntVal y] -> return $ IntVal (x+y)
    [StringVal x, IntVal y] -> return $ StringVal (x ++ show y)
    [IntVal x, StringVal y] -> return $ StringVal (show x ++ y)
    [ArrayVal x, ArrayVal y] -> return $ ArrayVal (x++y)
    [TrueVal, FalseVal] -> return FalseVal
    [FalseVal, TrueVal] -> return FalseVal
    [UndefinedVal, UndefinedVal] -> return UndefinedVal
    _ -> fail "Invalid plus operation"

{-
  Covering the multiplication operator for two integers
  and also for two Arrays. However, for the array as input
  we recursively evaluated the deconstructed types to IntVal
  and then execute the operation.
-}
multOp :: Primitive
multOp vals = case vals of
                [IntVal x, IntVal y] -> return $ IntVal (x*y)
                [ArrayVal x, ArrayVal y] -> do
                                               a <- multOp x
                                               b <- multOp y
                                               Right (ArrayVal (a : [b]))
                _ -> fail "Illegal multiplication operation.\
                          \Can only be two integers"

{-
  Covering the subtraction operator for two integers
  and also for two Arrays. However, for the array as input
  we recursively evaluate the deconstructed types to IntVal
  and then execute the operation.
-}
minusOp :: Primitive
minusOp vals = case vals of
                 [IntVal x, IntVal y] -> return $ IntVal (x-y)
                 [ArrayVal x, ArrayVal y] -> do
                                                a <- minusOp x
                                                b <- minusOp y
                                                Right (ArrayVal (a : [b]))
                 _ -> fail "Illegal minus operations. Can only be two integers"

{-
  Covering the modulo operator for two integers
  and also for two Arrays. However, for the array as input
  we recursively evaluate the deconstructed types to IntVal
  and then execute the operation.
-}
moduloOp :: Primitive
moduloOp vals = case vals of
                  [IntVal x, IntVal y] -> return $ IntVal (x `mod` y)
                  [ArrayVal x, ArrayVal y] -> do
                                                 a <- moduloOp x
                                                 b <- moduloOp y
                                                 Right (ArrayVal (a : [b]))
                  _ -> fail "Illegal modulo operation. Can only be two integers"

{-
  Function for making an array of undefined values
  given the non negative integer n
-}
mkArray :: Primitive
mkArray [IntVal n] | n >= 0 = return $ ArrayVal (replicate n UndefinedVal)
mkArray _ = Left "Array() called with wrong number or type of arguments"

{-
  A function that given a function f
  updates the environment/state
-}
modifyEnv :: (Env -> Env) -> SubsM ()
modifyEnv f = SubsM (\(env, _) -> Right ((), f env))

{-
  Given an identifier and a corresponding value
  We insert these in the Map in the monad, thus,
  we modify the environment/state
-}
putVar :: Ident -> Value -> SubsM ()
putVar ident val = modifyEnv (Map.insert ident val)

{-
  Given an identifier we get the retrieved
  value, provided it exists, in the monad
-}
getVar :: Ident -> SubsM Value
getVar name = do
  s <- SubsM (\(env, _) -> Right (env, env))
  case Map.lookup name s of
    Just a  -> return a
    Nothing -> fail "Variable name not in scope"

{-
  Given a function name, we look it up the
  in the Map, return the Map with the monad type
  SubsM (Either monad)
-}
getFunction :: FunName -> SubsM Primitive
getFunction name = do
  s <- SubsM (\(env, penv) -> Right (penv, env))
  case Map.lookup name s of
    Just n  -> return n
    Nothing -> fail "Function name not in scope"

{-
  evalExpr evaluates the various expressions to their corresponding
  Value in the monad.
-}
evalExpr :: Expr -> SubsM Value
evalExpr (Number x) = return (IntVal x)
evalExpr (String s) = return (StringVal s)
evalExpr (Array []) = return (ArrayVal [])
evalExpr (Array (x:xs)) = do
                             x' <- evalExpr x
                             xs' <- evalExpr (Array xs)
                             case xs' of
                               ArrayVal y -> return (ArrayVal (x':y))
                               _ -> fail "Evaluating array expected an ArrayVal\
                                         \,but was not given"
evalExpr TrueConst = return TrueVal
evalExpr FalseConst = return FalseVal
evalExpr Undefined = return UndefinedVal
evalExpr (Var x) = getVar x
evalExpr (Assign ident expr) =  do
                                   xpeval <- evalExpr expr
                                   putVar ident xpeval
                                   return xpeval
evalExpr (Call name expr) = do
                               fn <- getFunction name
                               values <- mapM evalExpr expr
                               case fn values of
                                 Right y -> return y
                                 Left _ -> fail "Invalid function call"
evalExpr (Comma expr1 expr2) = do
                                  _ <- evalExpr expr1
                                  evalExpr expr2
evalExpr (Compr compr) = do
                            x <- evalCompr compr
                            return (ArrayVal x)

{-
  evaluating the comprehension mechanism
  taking as an input the type and returning
  a list of Value in the SubsM monad. We have patterns
  for the three types and here the ACFor is the most complex.
  In case of an array evaluate each value in it and then concatenate
  In case of a string we do similarly, however, we get for each string
  an additional list layer
-}
evalCompr :: ArrayCompr -> SubsM [Value]
evalCompr arrcompr =
  case arrcompr of
    ACBody expr -> do
                      x <- evalExpr expr
                      return [ArrayVal [x]]
    ACFor ident expr arrcomp ->
      do
         xpeval <- evalExpr expr
         var <- getVarMaybe ident
         retVal <- case xpeval of
                     ArrayVal vals -> do
                                         a <- mapM (helpFun arrcomp ident) vals
                                         _ <- evalCompr arrcomp
                                         return (concatMap f a)
                     StringVal s -> do
                                      _ <- putVar ident (StringVal s)
                                      _ <- evalCompr arrcomp
                                      let x = ArrayVal [StringVal s]
                                      return (concatMap f [[x]])
                     _ -> fail "Only Arrays and Strings allowed\
                               \in for comprehensions"
         Data.Foldable.forM_ var (putVar ident)
         -- when (isJust var) (putVar ident (fromJust var))
         return retVal
           where f [ArrayVal x] = x
                 f x = x
                 helpFun arrc idier val = do
                           _ <- putVar idier val
                           evalCompr arrc
    ACIf expr arrcomp ->
      do
         xpeval <- evalExpr expr
         case xpeval of
           TrueVal -> evalCompr arrcomp
           FalseVal -> return [ArrayVal []]
           _ -> fail "If stmt not working"

{-
  Function used to invoke whether variable exists in
  the Map or not. getVar can't be used, as it would yield
  an error and not resume execution.
-}
getVarMaybe :: Ident -> SubsM (Maybe Value)
getVarMaybe name = do
  s <- SubsM (\(env, _) -> Right (env, env))
  case Map.lookup name s of
    Just a  -> return (Just a)
    Nothing -> return Nothing

{-
  Running an expression, also running the initialContext function
  with empty Maps, eventually returning the Either monad of either
  Error or Value.
-}
runExpr :: Expr -> Either Error Value
runExpr expr =
  case runSubsM (evalExpr expr) initialContext of
    Right (a, _) -> Right a
    Left err -> fail err