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，借以告慰即将逝去的Master时光～
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
使用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