module HJS.Interpreter.Interp where
import Control.Monad.Identity
import Control.Monad.Error
import Control.Monad.State
import HJS.Parser.JavaScript
import HJS.Interpreter.InterpMDecl
import HJS.Interpreter.InterpM
import HJS.Interpreter.ObjectBasic
import HJS.Interpreter.Object
import HJS.Interpreter.Array
import HJS.Interpreter.Regex
import HJS.Interpreter.Debugger
import Data.Map (Map,fromList,lookup,empty,insert)
data MyError = NoMsg | Msg String deriving Show
instance Error MyError where
noMsg = NoMsg
strMsg = Msg
class InterpC t where
interp :: t -> InterpM Value
instance InterpC Null where
interp Null = return $ inj Null
instance InterpC a => InterpC (Maybe a) where
interp (Just x) = interp x
interp _ = return $ inj Null
instance InterpC a => InterpC [a] where
interp [] = return $ undefinedValue
interp (x:[]) = interp x
interp (x:xs) = do
interp x
interp xs
instance (InterpC t1, InterpC t2) => InterpC (Either t1 t2) where
interp (Left x) = interp x
interp (Right x) = interp x
instance InterpC Literal where
interp (LitInt i) = unitInj i
interp (LitString s) = return $ inj s
interp (LitBool b) = return $ inj b
interp (LitNull) = return nullValue
pnameToString (PropNameId s) = s
pnameToString (PropNameStr s) = s
pnameToString (PropNameInt i) = show i
instance InterpC PrimExpr where
interp (Literal l) = interp l
interp (Ident s) = return $ inj (Ref s)
interp (Brack e) = interp e
interp (PEFuncDecl f) = interp f
interp This = getThis
interp (Array (ArrSimple a)) = do
vs <- mapM interp a
o <- newArrayObject vs
return $ inj o
interp (Regex (p,f)) = do
newRegex (inj p) (inj f)
interp (HJS.Parser.JavaScript.Object ls) = do
f <- getValue (inj $ Ref "Object")
o <- newCall f []
mapM_ (toProperty o) ls
return o
interp x = throwInternalError $ "Cannot interp PrimExpr " ++ (show x)
toProperty :: Value -> (Either (PropName, AssignE) GetterPutter) -> InterpM ()
toProperty o x = case x of
Left (n,e) -> do
v <- interp e
putProperty (toObjId o) (pnameToString n) v
return ()
_ -> return ()
instance InterpC MemberExpr where
interp (MemPrimExpr p) = interp p
interp (ArrayExpr me e) = do
o <- interp me >>= getValue
e' <- interp e
x <- toRealString e'
case (prj o) of
(Just (o::ObjId)) -> return (inj $ RefObj o x)
_ -> throwInternalError $ "Invalid array access: " ++ (show o)
interp (MemberNew me args) = do
oref <- interp me >>= getValue
args' <- mapM interp args
newCall oref args'
interp (MemberCall me s) = do
ro <- getRefObj me s
return $ inj ro
getRefObj me s = do
o <- interp me >>= getValue
case (prj o) of
(Just (o::ObjId)) -> return (RefObj o s)
_ -> throwInternalError $ "Not an object" ++ (show o)
instance InterpC NewExpr where
interp (MemberExpr p) = interp p
instance InterpC LeftExpr where
interp (NewExpr n) = interp n
interp (CallExpr c) = interp c
instance InterpC CallExpr where
interp (CallDot e s) = do
obj <- interp e
case (prj obj) of
(Just (i::ObjId)) -> return (inj $ RefObj i s)
_ -> throwInternalError "Attempt to access property on a non-object"
interp (CallMember m args) = do
r <- interp m
args' <- mapM interp args
case prj r of
Just (ref ::Ref) -> do
f <- getValue r
case ref of
RefObj t _ -> callFunction f args' t
Ref t -> callFunction f args' ObjIdNull
_ -> throwInternalError "CallMember requires function reference"
interp (CallPrim p) = interp p
interp (CallCall m args) = do
f <- interp m
args' <- mapM interp args
callFunction f args' ObjIdNull
interp p = throwInternalError $ "Cannot interp " ++ (show p)
callFunction :: Value -> [Value] -> ObjId -> InterpM Value
callFunction f args' this = do
case (prj f) of
(Just (i::ObjId)) -> do
callFunction' i args' this
_ -> throwInternalError $ "Internal Error: Invalid function object" ++ (show f)
getCaller = do
cargs <- getValue (inj $ Ref "arguments")
case cargs == undefinedValue of
True -> return nullValue
False -> getProperty (toObjId cargs) "callee"
callFunction' i args' this = do
c <- getCallee
putProperty i "caller" c
argo <- newObject "arguments"
act <- newObject "activation"
putProperty argo "callee" (inj i)
putProperty act "arguments" (inj argo)
sc' <- getProperty i "Scope"
let (Just (sc::[ObjId])) = (prj sc')
pushContext (act:sc,act,this,i)
putValue (inj $ Ref "arguments") (inj argo)
fargs' <- getProperty i "Args"
let (Just (fargs::[String])) = (prj fargs')
zipWithM (\x y -> putProperty argo (show x) y) [0..] args'
zipWithM (\x y -> putProperty act x y) fargs args'
putProperty argo "length" (inj (length args'))
se <- getProperty i "Call"
res <- (runFunc se) `catchError` handleReturn
popContext
return res
runFunc se = do
case (prj se) of
(Just (CallJS se)) -> foldM (\v x -> interp x) (Left 0) se
(Just (CallBuiltIn f)) -> f
_ -> throwInternalError "Internal Error: Invalid function call block"
instance InterpC PostFix where
interp (LeftExpr l) = do
r <- interp l
getValue r
interp (PostInc l) = do
r <- interp l
v <- getValue r
v' <- getValue r `bindPrj` \ i ->
unitInj (i+ 1)
putValue r v'
return v
instance InterpC UExpr where
interp (PostFix p) = interp p
interp (Not u ) = do u' <- interp u
b <- toRealBool u'
case b of
True -> return $ inj False
_ -> return $ inj True
interp (TypeOf p) = interp p >>= typeOfString
interp (UnaryMinus p) = do x <- interp p
return $ inj $ ((1) * (toRealInt x))
interp x = throwInternalError $ "Internal Error: Cannot handle " ++ (show x)
instance InterpC AExpr where
interp (AEUExpr e) = interp e
interp (AOp "-" x y) = liftIt () x y
interp (AOp "+" x y) = liftIt22 (+) x y
interp (AOp "*" x y) = liftIt (*) x y
interp (AOp "&&" x y) = liftBool (&&) x y
interp (AOp "==" x y) = do x' <- interp x; y' <- interp y; return $ inj $ abstractEquality x' y'
interp (AOp "!=" x y) = do x' <- interp x; y' <- interp y; return $ inj $ not $ abstractEquality x' y'
interp (AOp "===" x y) = do x' <- interp x; y' <- interp y; return $ inj $ strictEquality x' y'
interp (AOp "<" x y) = liftRel (<) x y
interp (AOp ">" x y) = liftRel (>) x y
interp (AOp "<=" x y) = liftRel (<=) x y
interp (AOp ">=" x y) = liftRel (>=) x y
interp (AOp op x y) = throwInternalError $ "Operator not implemented: " ++ (show op)
liftIt22 :: (InterpC x, InterpC y) => (Int -> Int -> Int) -> x -> y -> InterpM Value
liftIt22 f x y = do
x' <- interp x >>= toPrimitive HNone
y' <- interp y >>= toPrimitive HNone
case typeOf x' == typeOf nullStringValue || typeOf y' == typeOf nullStringValue of
True -> do
x'' <- toRealString x'
y'' <- toRealString x'
return $ inj (x'' ++ y'')
False -> return $ inj $ f (toRealInt x') (toRealInt y')
strictEquality x y = if typeOf x /= typeOf y then False
else if ( x == nullValue || y == undefinedValue) then True
else ((==) x y)
abstractEquality x y = if typeOf x == typeOf y then ((==) x y)
else ( x == nullValue && y == undefinedValue) || ( y == nullValue && x == undefinedValue)
liftBool f x y = do
x' <- interp x >>= toRealBool
y' <- interp y >>= toRealBool
return $ inj $ (f x' y')
liftRel f x y = do
x' <- interp x
y' <- interp y
return $ inj $ (f x' y')
instance InterpC CondE where
interp (AExpr p) = interp p
instance InterpC AssignE where
interp (CondE p) = interp p
interp (Assign left AssignNormal right) = do
v <- interp right
r <- interp left
putValue r v
return v
interp (Assign left op right ) = do
v <- interp right
r <- interp left
rval <- getValue r
v' <- case op of
AssignOpPlus -> liftIt3 (+) rval v
putValue r v'
return v'
interp (AEFuncDecl fd) = interp fd
instance InterpC FuncDecl where
interp (FuncDecl (Just s) args ses) = do
fo <- newFuncObject args ses (defaultConstructor "Object")
putProperty fo "name" (inj s)
putValue (inj (Ref s)) (inj fo)
return (inj fo)
instance InterpC Expr where
interp (AssignE p) = interp p
instance InterpC VarDecl where
interp (VarDecl s (Just e)) = do v <- interp e; putValue (inj (Ref s)) v; return v
interp (VarDecl s Nothing) = do putValue (inj (Ref s)) (inj Undefined); return (inj Undefined)
instance InterpC IfStmt where
interp (IfElse e s1 s2) = do
b <- interp e >>= toRealBool
case b of
True -> interp s1
_ -> interp s2
interp (IfOnly e s) = do
b <- interp e >>= toRealBool
case b of
True -> interp s
_ -> return (inj Undefined)
handleBreakContinue (ThrowBreak s) = return (inj Break)
handleBreakContinue (ThrowContinue s) = return (inj (0::Int))
handleBreakContinue e = throwError e
instance InterpC ItStmt where
interp (DoWhile s e ) = do
vv <- (interp s) `catchError` handleBreakContinue
case (prj vv) of
(Just Break) -> return (inj (0::Int))
_ -> do
b <- interp e >>= toRealBool
case b of
False -> return vv
_ -> interp (DoWhile s e )
interp (While e s) = do
b <- interp e >>= toRealBool
case b of
False -> return (inj Undefined)
_ -> do
vv <- (interp s) `catchError` handleBreakContinue
case (prj vv) of
(Just Break) -> return (inj (0::Int))
_ -> interp (While e s)
interp (For e1 e2 e3 s) = interpFor e1 e2 e3 s
interp (ForVar e1 e2 e3 s) = interpFor e1 e2 e3 s
interp (ForIn e1 e2 s ) = interpForIn e1 e2 s
interpForIn e1 e2 s = do
v <- interp e1
e <- interp e2
ps <- getPropertyNames (toObjId e)
mapM (\p -> do putValue v (inj p); interp s) ps
return (undefinedValue)
interpFor e1 e2 e3 s = do
interp e1
b <- interp e2 >>= toRealBool
case b of
False -> return (inj Null)
_ -> do
vv <- interp s `catchError` handleBreakContinue
case (prj vv) of
(Just Break) -> return (inj (0::Int))
_ -> do interp e3; interp (For Nothing e2 e3 s)
interpList :: InterpC a => [a] -> InterpM Value
interpList (x:[]) = interp x
interpList (x:xs) = do
interp Null
interp x
interpList xs
instance InterpC Stmt where
interp (StmtPos p s) = do
putPosition p
debugPoint p
interp s
instance InterpC Stmt' where
interp (ExprStmt p) = interp p
interp (IfStmt p) = interp p
interp (Block xs) = interp xs
interp (ItStmt p) = interp p
interp (ReturnStmt (Just p)) = interp p >>= throwReturn
interp (ReturnStmt Nothing) = throwReturn (inj Undefined)
interp (BreakStmt s) = throwBreak s
interp (ContStmt s) = throwContinue s
interp (EmptyStmt) = return $ inj Undefined
interp (VarStmt v) = do vs <- mapM interp v; return $ head vs
interp (ThrowExpr e) = interp e >>= throwException
interp (TryStmt e) = interp e
interp (Switch e s) = do
x <- interp e
handleSwitch s x `catchError` handleBreakContinue
interp s = error $ "Missing Stmt handling" ++ (show s)
handleSwitch ((CaseClause e s):cs) x = do
y <- interp e
case abstractEquality x y of
True -> do interp s; fallThruSwitch cs
False -> handleSwitch cs x
handleSwitch ((DefaultClause s):cs) x = do interp s; fallThruSwitch cs
handleSwitch [] x = return $ undefinedValue
fallThruSwitch ((CaseClause e s):cs) = do interp s; fallThruSwitch cs
fallThruSwitch ((DefaultClause s):cs) = do interp s; fallThruSwitch cs
fallThruSwitch [] = return $ undefinedValue
instance InterpC TryStmt where
interp (TryTry s1 c s2) = interp s1 `catchError` (handleException c)
instance InterpC Catch where
interp (Catch _ s) = interp s
interp (CatchIf _ s e) = interp s
interp (CatchCatch i _ s) = interp s
handleException ((CatchCatch i _ s):_) (ThrowException v) = do
putValue (inj $ Ref i) v
interp s
handleException _ e = throwError e
instance InterpC SourceElement where
interp (Stmt s) = interp s
interp (SEFuncDecl fd) = interp fd
instance InterpC JSProgram where
interp (JSProgram xs) = interp xs
liftIt ::(SubType sub Value, SubType sub1 Value, InterpC t1, InterpC t) => (sub -> sub1 -> Int ) -> t -> t1 -> InterpM Value
liftIt f x y = interp x `bindPrj`\i ->
interp y `bindPrj` \j ->
(return . inj) ((f i j))
liftIt3 ::(SubType sub Value, SubType sub1 Value) => (sub -> sub1 -> Int ) -> Value -> Value-> InterpM Value
liftIt3 f x y = case (prj x) of
(Just x') -> case (prj y) of
(Just y') -> return $ inj $ f x' y'
_ -> throwInternalError "Cannot prj"
_ -> throwInternalError "Cannot prj"
liftIt2 g x y = interp x `bindPrj`\i ->
interp y `bindPrj` \j -> g i j
unitInj = return . inj
m `bindPrj` k =
m >>= \a ->
case (prj a) of
Just x -> k x
Nothing -> (throwInternalError $ "Internal Error: Cannot prj Value" ++ (show a))
defaultConstructor :: String -> InterpM Value
defaultConstructor name = do
o <- newObject name
t <- getThis
args <- getArgs
p <- getProperty (toObjId t) "prototype"
putProperty o "__proto__" p
callFunction' (toObjId t) args o
return $ inj o
x :: Value
x = inj (ObjId 1)
callIt :: Int -> Int
callIt _ = 99