ecma262 (empty) → 0.0.0
raw patch · 15 files changed
+9318/−0 lines, 15 filesdep +basedep +containersdep +data-defaultsetup-changed
Dependencies added: base, containers, data-default, ecma262, lens, parsec, safe, transformers
Files
- LICENSE +23/−0
- Main.hs +17/−0
- Setup.hs +2/−0
- ecma262.cabal +58/−0
- src/Language/JavaScript.hs +29/−0
- src/Language/JavaScript/AST.hs +470/−0
- src/Language/JavaScript/Host.hs +11/−0
- src/Language/JavaScript/Host/Console.hs +100/−0
- src/Language/JavaScript/Interpret.hs +7174/−0
- src/Language/JavaScript/Lexer.hs +670/−0
- src/Language/JavaScript/Parser.hs +535/−0
- src/Language/JavaScript/Prim.hs +107/−0
- src/Language/JavaScript/String.hs +67/−0
- src/Language/JavaScript/SubType.hs +43/−0
- src/Language/JavaScript/Util.hs +12/−0
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright (c) 2014, Fabian Bergmark+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Main.hs view
@@ -0,0 +1,17 @@+module Main+ ( main ) where++import Control.Monad (void)++import System.Environment (getArgs)++import Language.JavaScript+import Language.JavaScript.Parser+import Language.JavaScript.Host.Console++main :: IO ()+main = do+ (file:_) <- getArgs+ source <- readFile file+ let eAST = parseJavaScript source+ void $ runHostedJavaScript source console
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ecma262.cabal view
@@ -0,0 +1,58 @@+name: ecma262+version: 0.0.0+synopsis: A ECMA-262 interpreter library+description: A library for iterpreting ECMA-262 code.+homepage: https://github.com/fabianbergmark/ECMA-262+category: Language+author: Fabian Bergmark+maintainer: fabian.bergmark@gmail.com+license: BSD2+license-file: LICENSE+cabal-version: >= 1.10+build-type: Simple++extra-source-files: LICENSE++source-repository head+ type: git+ location: https://github.com/fabianbergmark/ECMA-262.git++library+ default-language: Haskell2010++ hs-source-dirs: src/++ exposed-modules: Language.JavaScript+ Language.JavaScript.AST+ Language.JavaScript.Interpret+ Language.JavaScript.Lexer+ Language.JavaScript.Parser+ Language.JavaScript.String+ Language.JavaScript.Util+ Language.JavaScript.SubType+ Language.JavaScript.Host+ Language.JavaScript.Host.Console++ other-modules: Language.JavaScript.Prim++ ghc-options: -fno-warn-orphans -fno-warn-unused-binds -fno-warn-unused-matches++ build-depends: base == 4.*+ , containers == 0.4.* || == 0.5.*+ , data-default == 0.5.*+ , lens == 4.6.*+ , parsec == 3.1.*+ , safe == 0.3.*+ , transformers == 0.4.*++executable ecma262+ default-language: Haskell2010++ main-is: Main.hs++ ghc-options: -fno-warn-orphans -fno-warn-unused-binds -fno-warn-unused-matches++ other-modules: Main++ build-depends: base == 4.*+ , ecma262 == 0.0.0
+ src/Language/JavaScript.hs view
@@ -0,0 +1,29 @@+module Language.JavaScript+ where++import Control.Applicative ((<$>))++import Text.Parsec (ParseError)++import Language.JavaScript.Interpret+import Language.JavaScript.Parser++runJavaScript :: (Functor m, Monad m) =>+ String -> m (Either ParseError (Either Value Completion))+runJavaScript source = do+ let eAST = parseJavaScript source+ case eAST of+ Right ast -> do+ Right <$> runJavaScriptT initialState (interpret ast)+ Left e -> return (Left e)++runHostedJavaScript :: (Functor m, Monad m) =>+ String ->+ JavaScriptT m () ->+ m (Either ParseError (Either Value Completion))+runHostedJavaScript source hostInit = do+ let eAST = parseJavaScript source+ case eAST of+ Right ast -> do+ Right <$> runJavaScriptT initialState (hostInit >> interpret ast)+ Left e -> return (Left e)
+ src/Language/JavaScript/AST.hs view
@@ -0,0 +1,470 @@+module Language.JavaScript.AST+ where++data IdentName =+ IdentName String+ deriving (Eq, Show)++data Ident =+ Ident IdentName+ deriving (Eq, Show)++data Literal+ = LiteralNull NullLit+ | LiteralBool BoolLit+ | LiteralNum NumLit+ | LiteralString StringLit+ | LiteralRegExp RegExpLit+ deriving (Eq, Show)++data NullLit+ = NullLit+ deriving (Eq, Show)++data BoolLit+ = BoolLit Bool+ deriving (Eq, Show)++data NumLit+ = NumLit Double+ deriving (Eq, Show)++data StringLit+ = StringLit String+ deriving (Eq, Show)++data RegExpLit+ = RegExpLit (String, String)+ deriving (Eq, Show)++data PrimExpr+ = PrimExprThis+ | PrimExprIdent Ident+ | PrimExprLiteral Literal+ | PrimExprArray ArrayLit+ | PrimExprObject ObjectLit+ | PrimExprParens Expr+ deriving (Eq, Show)++data ArrayLit+ = ArrayLitH (Maybe Elision)+ | ArrayLit ElementList+ | ArrayLitT ElementList (Maybe Elision)+ deriving (Eq, Show)++data ElementList+ = ElementList (Maybe Elision) AssignExpr+ | ElementListCons ElementList (Maybe Elision) AssignExpr+ deriving (Eq, Show)++data Elision+ = ElisionComma+ | ElisionCons Elision+ deriving (Eq, Show)++data ObjectLit+ = ObjectLitEmpty+ | ObjectLit PropList+ deriving (Eq, Show)++data PropList+ = PropListAssign PropAssign+ | PropListCons PropList PropAssign+ deriving (Eq, Show)++data PropAssign+ = PropAssignField PropName AssignExpr+ | PropAssignGet PropName FuncBody+ | PropAssignSet PropName PropSetParamList FuncBody+ deriving (Eq, Show)++data PropSetParamList+ = PropSetParamList Ident+ deriving (Eq, Show)++data PropName+ = PropNameId IdentName+ | PropNameStr StringLit+ | PropNameNum NumLit+ deriving (Eq, Show)++data MemberExpr+ = MemberExprPrim PrimExpr+ | MemberExprFunc FuncExpr+ | MemberExprArray MemberExpr Expr+ | MemberExprDot MemberExpr IdentName+ | MemberExprNew MemberExpr Arguments+ deriving (Eq, Show)++data NewExpr+ = NewExprMember MemberExpr+ | NewExprNew NewExpr+ deriving (Eq, Show)++data CallExpr+ = CallExprMember MemberExpr Arguments+ | CallExprCall CallExpr Arguments+ | CallExprArray CallExpr Expr+ | CallExprDot CallExpr IdentName+ deriving (Eq, Show)++data Arguments+ = ArgumentsEmpty+ | Arguments ArgumentList+ deriving (Eq, Show)++data ArgumentList+ = ArgumentList AssignExpr+ | ArgumentListCons ArgumentList AssignExpr+ deriving (Eq, Show)++data LeftExpr+ = LeftExprNewExpr NewExpr+ | LeftExprCallExpr CallExpr+ deriving (Eq, Show)++data PostFixExpr+ = PostFixExprLeftExpr LeftExpr+ | PostFixExprPostInc LeftExpr+ | PostFixExprPostDec LeftExpr+ deriving (Eq, Show)++data UExpr+ = UExprPostFix PostFixExpr+ | UExprDelete UExpr+ | UExprVoid UExpr+ | UExprTypeOf UExpr+ | UExprDoublePlus UExpr+ | UExprDoubleMinus UExpr+ | UExprUnaryPlus UExpr+ | UExprUnaryMinus UExpr+ | UExprBitNot UExpr+ | UExprNot UExpr+ deriving (Eq, Show)++data MultExpr+ = MultExpr UExpr+ | MultExprMult MultExpr UExpr+ | MultExprDiv MultExpr UExpr+ | MultExprMod MultExpr UExpr+ deriving (Eq, Show)++data AddExpr+ = AddExpr MultExpr+ | AddExprAdd AddExpr MultExpr+ | AddExprSub AddExpr MultExpr+ deriving (Eq, Show)++data ShiftExpr+ = ShiftExpr AddExpr+ | ShiftExprLeft ShiftExpr AddExpr+ | ShiftExprRight ShiftExpr AddExpr+ | ShiftExprRightZero ShiftExpr AddExpr+ deriving (Eq, Show)++data RelExpr+ = RelExpr ShiftExpr+ | RelExprLess RelExpr ShiftExpr+ | RelExprGreater RelExpr ShiftExpr+ | RelExprLessEq RelExpr ShiftExpr+ | RelExprGreaterEq RelExpr ShiftExpr+ | RelExprInstanceOf RelExpr ShiftExpr+ | RelExprIn RelExpr ShiftExpr+ deriving (Eq, Show)++data RelExprNoIn+ = RelExprNoIn ShiftExpr+ | RelExprNoInLess RelExprNoIn ShiftExpr+ | RelExprNoInGreater RelExprNoIn ShiftExpr+ | RelExprNoInLessEq RelExprNoIn ShiftExpr+ | RelExprNoInGreaterEq RelExprNoIn ShiftExpr+ | RelExprNoInInstanceOf RelExprNoIn ShiftExpr+ deriving (Eq, Show)++data EqExpr+ = EqExpr RelExpr+ | EqExprEq EqExpr RelExpr+ | EqExprNotEq EqExpr RelExpr+ | EqExprStrictEq EqExpr RelExpr+ | EqExprStrictNotEq EqExpr RelExpr+ deriving (Eq, Show)++data EqExprNoIn+ = EqExprNoIn RelExprNoIn+ | EqExprNoInEq EqExprNoIn RelExprNoIn+ | EqExprNoInNotEq EqExprNoIn RelExprNoIn+ | EqExprNoInStrictEq EqExprNoIn RelExprNoIn+ | EqExprNoInStrictNotEq EqExprNoIn RelExprNoIn+ deriving (Eq, Show)++data BitAndExpr+ = BitAndExpr EqExpr+ | BitAndExprAnd BitAndExpr EqExpr+ deriving (Eq, Show)++data BitAndExprNoIn+ = BitAndExprNoIn EqExprNoIn+ | BitAndExprNoInAnd BitAndExprNoIn EqExprNoIn+ deriving (Eq, Show)++data BitXorExpr+ = BitXorExpr BitAndExpr+ | BitXorExprXor BitXorExpr BitAndExpr+ deriving (Eq, Show)++data BitXorExprNoIn+ = BitXorExprNoIn BitAndExprNoIn+ | BitXorExprNoInXor BitXorExprNoIn BitAndExprNoIn+ deriving (Eq, Show)++data BitOrExpr+ = BitOrExpr BitXorExpr+ | BitOrExprOr BitOrExpr BitXorExpr+ deriving (Eq, Show)++data BitOrExprNoIn+ = BitOrExprNoIn BitXorExprNoIn+ | BitOrExprNoInOr BitOrExprNoIn BitXorExprNoIn+ deriving (Eq, Show)++data LogicalAndExpr+ = LogicalAndExpr BitOrExpr+ | LogicalAndExprAnd LogicalAndExpr BitOrExpr+ deriving (Eq, Show)++data LogicalAndExprNoIn+ = LogicalAndExprNoIn BitOrExprNoIn+ | LogicalAndExprNoInAnd LogicalAndExprNoIn BitOrExprNoIn+ deriving (Eq, Show)++data LogicalOrExpr+ = LogicalOrExpr LogicalAndExpr+ | LogicalOrExprOr LogicalOrExpr LogicalAndExpr+ deriving (Eq, Show)++data LogicalOrExprNoIn+ = LogicalOrExprNoIn LogicalAndExprNoIn+ | LogicalOrExprNoInOr LogicalOrExprNoIn LogicalAndExprNoIn+ deriving (Eq, Show)++data CondExpr+ = CondExpr LogicalOrExpr+ | CondExprIf LogicalOrExpr AssignExpr AssignExpr+ deriving (Eq, Show)++data CondExprNoIn+ = CondExprNoIn LogicalOrExprNoIn+ | CondExprNoInIf LogicalOrExprNoIn AssignExpr AssignExpr+ deriving (Eq, Show)++data AssignExpr+ = AssignExprCondExpr CondExpr+ | AssignExprAssign LeftExpr AssignOp AssignExpr+ deriving (Eq, Show)++data AssignExprNoIn+ = AssignExprNoInCondExpr CondExprNoIn+ | AssignExprNoInAssign LeftExpr AssignOp AssignExprNoIn+ deriving (Eq, Show)++data AssignOp+ = AssignOpNormal+ | AssignOpMult+ | AssignOpDiv+ | AssignOpMod+ | AssignOpPlus+ | AssignOpMinus+ | AssignOpShiftLeft+ | AssignOpShiftRight+ | AssignOpShiftRightZero+ | AssignOpBitAnd+ | AssignOpBitXor+ | AssignOpBitOr+ deriving (Eq, Show)++data Expr+ = Expr AssignExpr+ | ExprCons Expr AssignExpr+ deriving (Eq, Show)++data ExprNoIn+ = ExprNoIn AssignExprNoIn+ | ExprNoInCons ExprNoIn AssignExprNoIn+ deriving (Eq, Show)++data Stmt+ = StmtBlock Block+ | StmtVar VarStmt+ | StmtEmpty EmptyStmt+ | StmtExpr ExprStmt+ | StmtIf IfStmt+ | StmtIt ItStmt+ | StmtCont ContStmt+ | StmtBreak BreakStmt+ | StmtReturn ReturnStmt+ | StmtWith WithStmt+ | StmtLabelled LabelledStmt+ | StmtSwitch SwitchStmt+ | StmtThrow ThrowStmt+ | StmtTry TryStmt+ | StmtDbg DbgStmt+ deriving (Eq, Show)++data Block+ = Block (Maybe StmtList)+ deriving (Eq, Show)++data StmtList+ = StmtList Stmt+ | StmtListCons StmtList Stmt+ deriving (Eq, Show)++data VarStmt+ = VarStmt VarDeclList+ deriving (Eq, Show)++data VarDeclList+ = VarDeclList VarDecl+ | VarDeclListCons VarDeclList VarDecl+ deriving (Eq, Show)++data VarDeclListNoIn+ = VarDeclListNoIn VarDeclNoIn+ | VarDeclListNoInCons VarDeclListNoIn VarDeclNoIn+ deriving (Eq, Show)++data VarDecl+ = VarDecl Ident (Maybe Initialiser)+ deriving (Eq, Show)++data VarDeclNoIn+ = VarDeclNoIn Ident (Maybe InitialiserNoIn)+ deriving (Eq, Show)++data Initialiser+ = Initialiser AssignExpr+ deriving (Eq, Show)++data InitialiserNoIn+ = InitialiserNoIn AssignExprNoIn+ deriving (Eq, Show)++data EmptyStmt+ = EmptyStmt+ deriving (Eq, Show)++data ExprStmt+ = ExprStmt Expr+ deriving (Eq, Show)++data IfStmt+ = IfStmtIfElse Expr Stmt Stmt+ | IfStmtIf Expr Stmt+ deriving (Eq, Show)++data ItStmt+ = ItStmtDoWhile Stmt Expr+ | ItStmtWhile Expr Stmt+ | ItStmtFor (Maybe ExprNoIn) (Maybe Expr) (Maybe Expr) Stmt+ | ItStmtForVar VarDeclListNoIn (Maybe Expr) (Maybe Expr) Stmt+ | ItStmtForIn LeftExpr Expr Stmt+ | ItStmtForVarIn VarDeclNoIn Expr Stmt+ deriving (Eq, Show)++data ContStmt+ = ContStmt+ | ContStmtLabelled Ident+ deriving (Eq, Show)++data BreakStmt+ = BreakStmt+ | BreakStmtLabelled Ident+ deriving (Eq, Show)++data ReturnStmt+ = ReturnStmt+ | ReturnStmtExpr Expr+ deriving (Eq, Show)++data WithStmt+ = WithStmt Expr Stmt+ deriving (Eq, Show)++data SwitchStmt+ = SwitchStmt Expr CaseBlock+ deriving (Eq, Show)++data CaseBlock+ = CaseBlock (Maybe CaseClauses)+ | CaseBlockDefault (Maybe CaseClauses) DefaultClause (Maybe CaseClauses)+ deriving (Eq, Show)++data CaseClauses+ = CaseClauses CaseClause+ | CaseClausesCons CaseClauses CaseClause+ deriving (Eq, Show)++data CaseClause+ = CaseClause Expr (Maybe StmtList)+ deriving (Eq, Show)++data DefaultClause+ = DefaultClause (Maybe StmtList)+ deriving (Eq, Show)++data LabelledStmt+ = LabelledStmt Ident Stmt+ deriving (Eq, Show)++data ThrowStmt+ = ThrowStmt Expr+ deriving (Eq, Show)++data TryStmt+ = TryStmtBC Block Catch+ | TryStmtBF Block Finally+ | TryStmtBCF Block Catch Finally+ deriving (Eq, Show)++data Catch+ = Catch Ident Block+ deriving (Eq, Show)++data Finally+ = Finally Block+ deriving (Eq, Show)++data DbgStmt+ = DbgStmt+ deriving (Eq, Show)++data FuncDecl+ = FuncDecl Ident (Maybe FormalParamList) FuncBody+ deriving (Eq, Show)++data FuncExpr+ = FuncExpr (Maybe Ident) (Maybe FormalParamList) FuncBody+ deriving (Eq, Show)++data FormalParamList+ = FormalParamList Ident+ | FormalParamListCons FormalParamList Ident+ deriving (Eq, Show)++data FuncBody =+ FuncBody (Maybe SourceElements)+ deriving (Eq, Show)++data Program =+ Program (Maybe SourceElements)+ deriving (Eq, Show)++data SourceElements+ = SourceElements SourceElement+ | SourceElementsCons SourceElements SourceElement+ deriving (Eq, Show)++data SourceElement+ = SourceElementStmt Stmt+ | SourceElementFuncDecl FuncDecl+ deriving (Eq, Show)
+ src/Language/JavaScript/Host.hs view
@@ -0,0 +1,11 @@+module Language.JavaScript.Host where++import Control.Lens++import Language.JavaScript.Interpret++defineGlobalProperty :: (Monad m) =>+ String -> Property -> JavaScriptT m ()+defineGlobalProperty i p = do+ global <- use globalObject+ property global i ?= p
+ src/Language/JavaScript/Host/Console.hs view
@@ -0,0 +1,100 @@+module Language.JavaScript.Host.Console where++import Control.Lens++import Control.Monad (forM)+import Control.Monad.IO.Class (MonadIO(..))++import Data.List (intersperse)++import Language.JavaScript.Host+import Language.JavaScript.Interpret+import Language.JavaScript.SubType++import qualified Data.Map as Map (empty, fromList)++console :: (Functor m, Monad m, MonadIO m) =>+ JavaScriptT m ()+console = do+ consoleLogId <- createNextInternalId+ op <- use objectPrototypeObject+ fp <- use functionPrototypeObject+ let consoleLogObj = Object consoleLogId+ consoleLogObjInt = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist fp),+ objectInternalClass = "Function",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Just consoleLogCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ mInternalObject consoleLogObj ?= consoleLogObjInt++ consoleId <- createNextInternalId+ let consoleObj = Object consoleId+ consoleObjInt = ObjectInternal {+ objectInternalProperties = Map.fromList+ [ ("log", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj consoleLogObj,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True }) ],+ objectInternalPrototype = const $ return (JSExist op),+ objectInternalClass = "Object",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ mInternalObject consoleObj ?= consoleObjInt++ defineGlobalProperty+ "console"+ (PropertyData DataDescriptor {+ dataDescriptorValue = inj consoleObj,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })++consoleLogCallImpl :: (Functor m, Monad m, MonadIO m) => InternalCallType m+consoleLogCallImpl f this (List args) = do+ forM (intersperse (inj " ") args) $ \v -> toString v >>= liftIO . putStr+ liftIO $ putStrLn ""+ return (inj Undefined)
+ src/Language/JavaScript/Interpret.hs view
@@ -0,0 +1,7174 @@+{-# LANGUAGE AllowAmbiguousTypes,+ FlexibleContexts,+ FlexibleInstances,+ FunctionalDependencies,+ GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ OverlappingInstances,+ PatternSynonyms,+ RankNTypes,+ RecordWildCards,+ ScopedTypeVariables,+ TypeOperators,+ TypeSynonymInstances #-}++module Language.JavaScript.Interpret+ where++import Control.Applicative ((<$>), (<|>), (<*>))+import Control.Lens (Lens', (.=), (?=), (%=))+import qualified Control.Lens as Lens (at, lens, use)+import Control.Monad (void)+import Control.Monad (forM, liftM2, when)+import qualified Control.Monad.Trans.Except as Except+ (ExceptT, catchE, runExceptT, throwE)+import qualified Control.Monad.Trans.State.Lazy as State+ (StateT(..), evalStateT)++import Data.Default+import Data.Int+import Data.Fixed (mod')+import Data.Map (Map)+import qualified Data.Map as Map+ (empty, fromList, insert, lookup, member, toList)+import Data.Maybe (fromJust, isJust)+import Data.Word+import Data.Bits+ ((.|.), (.&.), complement, shiftL, shiftR, xor)+import Data.Foldable (foldlM)++import Prelude (Bool(..), Double, Either(..), Integer,+ Maybe(..), String,+ Eq((/=), (==)), Floating(..), Fractional(..),+ Functor(..), Monad(..), Num((+), (-), (*), abs),+ Ord((>), (<), (>=), (<=)), Real, RealFloat, RealFrac, Show(..),+ ($), (.), (^), (++),+ (&&), (||), (!!),+ const, elem, error, flip, floor, foldl,+ fromInteger, fromIntegral, id, isInfinite, isNaN, isNegativeZero,+ length, maybe, mod, not, null, show, signum, snd, succ,+ undefined)+import qualified Prelude++import Safe (tailSafe)++import Language.JavaScript.AST+import Language.JavaScript.String+import Language.JavaScript.SubType++class Interpret f m t | f -> t where+ interpret :: f -> m t++class Interpret1 f m p t | f -> p, f -> t where+ interpret1 :: f -> p -> m t++instance (Functor m, Monad m) => Interpret Literal m Value where+ interpret (LiteralNull n) = do+ n' <- interpret n+ return $ inj n'+ interpret (LiteralBool b) = do+ b' <- interpret b+ return $ inj b'+ interpret (LiteralNum n) = do+ n' <- interpret n+ return $ inj n'+ interpret (LiteralString s) = do+ s' <- interpret s+ return $ inj s'+ interpret (LiteralRegExp r) = do+ r' <- interpret r+ return $ inj r'++instance (Functor m, Monad m) => Interpret NullLit m Null where+ interpret NullLit = return Null++instance (Functor m, Monad m) => Interpret BoolLit m Bool where+ interpret (BoolLit b) = return b++instance (Functor m, Monad m) => Interpret StringLit m String where+ interpret (StringLit s) = return s++instance (Functor m, Monad m) => Interpret NumLit m Number where+ interpret (NumLit n) = return $ Number n++instance (Functor m, Monad m) => Interpret RegExpLit m Undefined where+ interpret (RegExpLit _) = return $ Undefined++instance (Functor m, Monad m) =>+ Interpret PrimExpr (JavaScriptT m) CallValue where+ interpret PrimExprThis = do+ v <- Lens.use $ contextStack . currentContext . thisBinding+ return $ inj v++ interpret (PrimExprIdent (Ident (IdentName s))) = do+ env <- Lens.use $ contextStack . currentContext . lexicalEnvironment+ let strict = False+ inj <$> getIdentifierReference (Just env) s strict++ interpret (PrimExprLiteral l) = do+ v <- interpret l+ return $ inj v+ interpret (PrimExprArray a) = do+ o <- interpret a+ return $ inj o+ interpret (PrimExprObject o) = do+ v <- interpret o+ return $ inj v+ interpret (PrimExprParens e) = do+ v <- interpret e+ return $ inj v++instance (Functor m, Monad m) =>+ Interpret ArrayLit (JavaScriptT m) Object where+ interpret (ArrayLitH me) = do+ a <- newArrayObject []+ pad <- case me of+ Just e -> interpret e+ _ -> return $ Number 0+ put a "length" (inj pad) False+ return a++ interpret (ArrayLit e) = interpret e+ interpret (ArrayLitT e mel) = do+ array <- interpret e+ pad <- case mel of+ Just el -> interpret el+ _ -> return $ Number 0+ len <- get array "length" >>= toNumber+ newLen <- toUint32 (pad + len)+ put array "length" (inj $ Number $ fromIntegral newLen) False+ return array++instance (Functor m, Monad m) =>+ Interpret ObjectLit (JavaScriptT m) Object where+ interpret ObjectLitEmpty = do+ o <- newObjectObject Nothing+ return o++ interpret (ObjectLit pl) = interpret pl++instance (Functor m, Monad m) =>+ Interpret PropList (JavaScriptT m) Object where+ interpret (PropListAssign pa) = do+ obj <- newObjectObject Nothing+ PropertyIdentifier name desc <- interpret pa+ defineOwnProperty obj name desc False+ return obj++ interpret (PropListCons pl pa) = do+ obj <- interpret pl+ PropertyIdentifier name desc <- interpret pa+ mPrevious <- getOwnProperty obj name+ case mPrevious of+ JSJust previous -> return ()+ JSNothing -> return ()+ defineOwnProperty obj name desc False+ return obj++instance (Functor m, Monad m) =>+ Interpret PropAssign (JavaScriptT m) PropertyIdentifier where+ interpret (PropAssignField pn ae) = do+ propName <- interpret pn+ exprValue <- interpret ae+ propValue <- getValue exprValue+ let desc = def {+ propertyDescriptorValue = Just propValue,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ return $ PropertyIdentifier propName desc++ interpret (PropAssignGet pn fb) = do+ propName <- interpret pn+ lex <- Lens.use $ contextStack . currentContext . lexicalEnvironment+ let strict = False+ closure <- newFunctionObject Nothing fb lex strict+ let desc = def {+ propertyDescriptorGet = Just closure,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ return $ PropertyIdentifier propName desc++ interpret (PropAssignSet pn (PropSetParamList i) fb) = do+ propName <- interpret pn+ lex <- Lens.use $ contextStack . currentContext . lexicalEnvironment+ let strict = False+ closure <- newFunctionObject (Just (FormalParamList i)) fb lex strict+ let desc = def {+ propertyDescriptorSet = Just closure,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ return $ PropertyIdentifier propName desc++instance (Functor m, Monad m) =>+ Interpret PropName (JavaScriptT m) String where+ interpret (PropNameId (IdentName s)) = return s+ interpret (PropNameStr (StringLit s)) = return s+ interpret (PropNameNum (NumLit n)) = do+ let nbr = Number n+ toString nbr++instance (Functor m, Monad m) =>+ Interpret Elision m Number where+ interpret (ElisionComma) = return $ Number 1+ interpret (ElisionCons e ) = do+ Number n <- interpret e+ return $ Number (n+1)++instance (Functor m, Monad m) =>+ Interpret ElementList (JavaScriptT m) Object where+ interpret (ElementList me ae) = do+ array <- newArrayObject []+ firstIndex <-+ case me of+ Just e -> interpret e+ _ -> return $ Number 0+ initResult <- interpret ae+ initValue <- getValue initResult+ s <- toString firstIndex+ defineOwnProperty+ array+ s+ (def {+ propertyDescriptorValue = Just initValue,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True })+ False+ return array++ interpret (ElementListCons el me ae) = do+ array <- interpret el+ pad <- case me of+ Just e -> interpret e+ _ -> return $ Number 0+ initResult <- interpret ae+ initValue <- getValue initResult+ len <- get array "length"+ newLen <- pad `operatorPlus` len >>=+ toUint32 >>=+ toString . Number . fromIntegral+ let desc = def {+ propertyDescriptorValue = Just initValue,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ defineOwnProperty array newLen desc False+ return array+++instance (Functor m, Monad m) =>+ Interpret Stmt (JavaScriptT m) Completion where+ interpret (StmtBlock b) = interpret b+ interpret (StmtVar v) = interpret v+ interpret (StmtEmpty e) = interpret e+ interpret (StmtExpr e) = interpret e+ interpret (StmtIf i) = interpret i+ interpret (StmtIt i) = interpret i+ interpret (StmtCont c) = interpret c+ interpret (StmtBreak b) = interpret b+ interpret (StmtReturn r) = interpret r+ interpret (StmtWith w) = interpret w+ interpret (StmtLabelled l) = interpret l+ interpret (StmtSwitch s) = interpret s+ interpret (StmtThrow t) = interpret t+ interpret (StmtTry t) = interpret t+ interpret (StmtDbg d) = interpret d++instance (Functor m, Monad m) =>+ Interpret Block (JavaScriptT m) Completion where+ interpret (Block Nothing) =+ return $ Completion CompletionTypeNormal Nothing Nothing+ interpret (Block (Just sl)) = interpret sl++instance (Functor m, Monad m) =>+ Interpret StmtList (JavaScriptT m) Completion where+ interpret (StmtList stmt) =+ Except.catchE+ (interpret stmt)+ (\v -> return $ Completion CompletionTypeThrow (Just v) Nothing)+ interpret (StmtListCons sl stmt) = do+ slc <- interpret sl+ case slc of+ Completion CompletionTypeNormal slv _ ->+ Except.catchE+ (do+ s@(Completion sty sva sta) <- (interpret stmt :: JavaScriptT m Completion)+ if isJust sva+ then return $ Completion sty sva sta+ else return $ Completion sty slv sta)+ (\v -> return $ Completion CompletionTypeThrow (Just v) Nothing)+ _ -> return slc++instance (Functor m, Monad m) =>+ Interpret VarStmt (JavaScriptT m) Completion where+ interpret (VarStmt vdl) = do+ interpret vdl+ return $ Completion CompletionTypeNormal Nothing Nothing++instance (Functor m, Monad m) =>+ Interpret VarDeclList (JavaScriptT m) String where+ interpret (VarDeclList vd) = interpret vd+ interpret (VarDeclListCons vdl vd) = do+ interpret vdl+ interpret vd++instance (Functor m, Monad m) =>+ Interpret VarDeclListNoIn (JavaScriptT m) String where+ interpret (VarDeclListNoIn vd) = interpret vd+ interpret (VarDeclListNoInCons vdl vd) = do+ interpret vdl+ interpret vd++instance (Functor m, Monad m) =>+ Interpret VarDecl (JavaScriptT m) String where+ interpret (VarDecl (Ident (IdentName s)) Nothing) =+ return s+ interpret (VarDecl ident@(Ident (IdentName s)) (Just init)) = do+ lhs <- interpret ident+ rhs <- interpret init+ value <- getValue rhs+ putValue lhs value+ return s++instance (Functor m, Monad m) =>+ Interpret VarDeclNoIn (JavaScriptT m) String where+ interpret (VarDeclNoIn (Ident (IdentName s)) Nothing) =+ return s+ interpret (VarDeclNoIn ident@(Ident (IdentName s)) (Just init)) = do+ lhs <- interpret ident+ rhs <- interpret init+ value <- getValue rhs+ putValue lhs value+ return s++instance (Functor m, Monad m) =>+ Interpret Initialiser (JavaScriptT m) CallValue where+ interpret (Initialiser ae) = interpret ae++instance (Functor m, Monad m) =>+ Interpret InitialiserNoIn (JavaScriptT m) CallValue where+ interpret (InitialiserNoIn ae) = interpret ae++instance (Functor m, Monad m) =>+ Interpret EmptyStmt m Completion where+ interpret EmptyStmt =+ return $+ Completion CompletionTypeNormal Nothing Nothing++instance (Functor m, Monad m) =>+ Interpret ExprStmt (JavaScriptT m) Completion where+ interpret (ExprStmt e) = do+ exprRef <- interpret e+ v <- getValue exprRef+ return $ Completion CompletionTypeNormal (Just v) Nothing++instance (Functor m, Monad m) =>+ Interpret IfStmt (JavaScriptT m) Completion where+ interpret (IfStmtIfElse e s1 s2) = do+ exprRef <- interpret e+ b <- getValue exprRef >>= return . toBoolean+ if b+ then interpret s1+ else interpret s2++ interpret (IfStmtIf e s) = do+ exprRef <- interpret e+ b <- getValue exprRef >>= return . toBoolean+ if b+ then interpret s+ else return $ Completion CompletionTypeNormal Nothing Nothing++instance (Functor m, Monad m) =>+ Interpret ItStmt (JavaScriptT m) Completion where+ interpret (ItStmtDoWhile stmt expr) = doWhile Nothing+ where+ doWhile :: Maybe Value -> JavaScriptT m Completion+ doWhile v = do+ s@(Completion sty sv sta) <- interpret stmt+ let v' = sv <|> v+ ils <- inCurrentLabelSet sta+ if sty /= CompletionTypeContinue ||+ not ils+ then do+ if sty == CompletionTypeBreak &&+ ils+ then return $ Completion CompletionTypeNormal v Nothing+ else+ if sty /= CompletionTypeNormal+ then return s+ else do+ exprRef <- interpret expr+ b <- getValue exprRef >>= return . toBoolean+ if b+ then doWhile v'+ else return $ Completion CompletionTypeNormal v' Nothing+ else do+ exprRef <- interpret expr+ b <- getValue exprRef >>= return . toBoolean+ if b+ then doWhile v'+ else return $ Completion CompletionTypeNormal v' Nothing++ interpret (ItStmtWhile expr stmt) = while Nothing+ where+ while :: Maybe Value -> JavaScriptM Completion+ while v = do+ exprRef <- interpret expr+ b <- getValue exprRef >>= return . toBoolean+ if not b+ then return $ Completion CompletionTypeNormal v Nothing+ else do+ s@(Completion sty sv sta) <- interpret stmt+ let v' = sv <|> v+ ils <- inCurrentLabelSet sta+ if sty /= CompletionTypeContinue ||+ not ils+ then+ if sty == CompletionTypeBreak &&+ ils+ then return $ Completion CompletionTypeNormal v' Nothing+ else+ if sty /= CompletionTypeNormal+ then return s+ else while v'+ else while v'++ interpret (ItStmtFor me1 me2 me3 s) = do+ case me1 of+ Just e1 -> do+ exprRef <- interpret e1+ getValue exprRef+ return ()+ _ -> return ()+ for Nothing+ where+ for :: Maybe Value -> JavaScriptM Completion+ for v = do+ case me2 of+ Just e2 -> do+ testExprRef <- interpret e2+ b <- getValue testExprRef >>= return . toBoolean+ if not b+ then return $ Completion CompletionTypeNormal v Nothing+ else runLoop v+ _ -> runLoop v+ runLoop v = do+ stmt@(Completion sty sv sta) <- interpret s+ let v' = sv <|> v+ ils <- inCurrentLabelSet sta+ if sty == CompletionTypeBreak &&+ ils+ then return $ Completion CompletionTypeNormal v' Nothing+ else+ if (sty /= CompletionTypeContinue ||+ not ils) &&+ sty /= CompletionTypeNormal+ then return stmt+ else do+ case me3 of+ Just e3 -> do+ incExprRef <- interpret e3+ getValue incExprRef+ return ()+ Nothing -> return ()+ for v'++ interpret (ItStmtForVar vdl me2 me3 s) = do+ interpret vdl+ for Nothing+ where+ for :: Maybe Value -> JavaScriptM Completion+ for v = do+ case me2 of+ Just e2 -> do+ testExprRef <- interpret e2+ b <- getValue testExprRef >>= return . toBoolean+ if not b+ then return $ Completion CompletionTypeNormal v Nothing+ else runLoop v+ _ -> runLoop v+ runLoop v = do+ stmt@(Completion sty sv sta) <- interpret s+ let v' = sv <|> v+ ils <- inCurrentLabelSet sta+ if sty == CompletionTypeBreak &&+ ils+ then return $ Completion CompletionTypeNormal v' Nothing+ else+ if (sty /= CompletionTypeContinue ||+ not ils) &&+ sty /= CompletionTypeNormal+ then return stmt+ else do+ case me3 of+ Just e3 -> do+ incExprRef <- interpret e3+ getValue incExprRef+ return ()+ Nothing -> return ()+ for v'++ interpret (ItStmtForIn le e s) = do+ exprRef <- interpret e+ exprValue <- getValue exprRef+ case exprValue of+ ValueNull _ ->+ return $ Completion CompletionTypeNormal Nothing Nothing+ ValueUndefined _ ->+ return $ Completion CompletionTypeNormal Nothing Nothing+ _ -> do+ obj <- toObject exprValue+ ps <- Lens.use $ properties obj+ forIn (Map.toList ps) Nothing+ where+ forIn :: [(String, Property)] -> Maybe Value -> JavaScriptM Completion+ forIn [] v = return $ Completion CompletionTypeNormal v Nothing+ forIn ((p, pr):ps) v = do+ let enum = case pr of+ PropertyData (DataDescriptor {..}) ->+ dataDescriptorEnumerable+ PropertyAccessor (AccessorDescriptor {..}) ->+ accessorDescriptorEnumerable+ if enum+ then do+ lhsRef <- interpret le+ putValue lhsRef p+ stmt@(Completion sty sv sta) <- interpret s+ let v' = sv <|> v+ ils <- inCurrentLabelSet sta+ if sty == CompletionTypeBreak &&+ ils+ then return $ Completion CompletionTypeNormal v Nothing+ else+ if (sty /= CompletionTypeContinue ||+ not ils) &&+ sty /= CompletionTypeNormal+ then return stmt+ else forIn ps v'+ else forIn ps v++ interpret (ItStmtForVarIn vd e s) = do+ varName <- interpret vd+ exprRef <- interpret e+ exprValue <- getValue exprRef+ case exprValue of+ ValueNull _ ->+ return $ Completion CompletionTypeNormal Nothing Nothing+ ValueUndefined _ ->+ return $ Completion CompletionTypeNormal Nothing Nothing+ _ -> do+ obj <- toObject exprValue+ ps <- Lens.use $ properties obj+ forIn (Map.toList ps) varName Nothing+ where+ forIn :: [(String, Property)] -> String -> Maybe Value ->+ JavaScriptM Completion+ forIn [] _ v = return $ Completion CompletionTypeNormal v Nothing+ forIn ((p, pr):ps) varName v = do+ let enum = case pr of+ PropertyData (DataDescriptor {..}) ->+ dataDescriptorEnumerable+ PropertyAccessor (AccessorDescriptor {..}) ->+ accessorDescriptorEnumerable+ if enum+ then do+ varRef <- interpret (Ident (IdentName varName))+ putValue varRef p+ stmt@(Completion sty sv sta) <- interpret s+ let v' = sv <|> v+ ils <- inCurrentLabelSet sta+ if sty == CompletionTypeBreak &&+ ils+ then return $ Completion CompletionTypeNormal v Nothing+ else+ if (sty /= CompletionTypeContinue ||+ not ils) &&+ sty /= CompletionTypeNormal+ then return stmt+ else forIn ps varName v'+ else forIn ps varName v++instance (Functor m, Monad m) =>+ Interpret ContStmt m Completion where+ interpret (ContStmt) =+ return $+ Completion CompletionTypeContinue Nothing Nothing++ interpret (ContStmtLabelled i) =+ return $+ Completion CompletionTypeContinue Nothing (Just i)++instance (Functor m, Monad m) =>+ Interpret BreakStmt m Completion where+ interpret (BreakStmt) =+ return $+ Completion CompletionTypeBreak Nothing Nothing++ interpret (BreakStmtLabelled i) =+ return $+ Completion CompletionTypeBreak Nothing (Just i)++instance (Functor m, Monad m) =>+ Interpret ReturnStmt (JavaScriptT m) Completion where+ interpret (ReturnStmt) = do+ return $ Completion CompletionTypeReturn (inj Undefined) Nothing+ interpret (ReturnStmtExpr e) = do+ exprRef <- interpret e+ v <- getValue exprRef+ return $ Completion CompletionTypeReturn (Just v) Nothing++instance (Functor m, Monad m) =>+ Interpret WithStmt (JavaScriptT m) Completion where+ interpret (WithStmt expr stmt) = do+ val <- interpret expr+ obj <- getValue val >>= toObject+ oldEnv <- Lens.use (contextStack . currentContext . lexicalEnvironment)+ newEnv <- newObjectObjectEnvironment obj (Just oldEnv)+ contextStack . currentContext . lexicalEnvironment .= newEnv+ c <- Except.catchE+ (interpret stmt :: JavaScriptT m Completion)+ (\v -> return $ Completion CompletionTypeThrow (Just v) Nothing)+ contextStack . currentContext . lexicalEnvironment .= oldEnv+ return c++instance (Functor m, Monad m) =>+ Interpret SwitchStmt (JavaScriptT m) Completion where+ interpret (SwitchStmt expr cb) = do+ exprRef <- interpret expr+ v <- getValue exprRef+ r@(Completion rty rv rta) <- interpret1 cb v+ case rty of+ CompletionTypeBreak ->+ if False+ then return $ Completion CompletionTypeNormal rv Nothing+ else return r+ _ -> return r++instance (Functor m, Monad m) =>+ Interpret1 CaseBlock (JavaScriptT m) Value Completion where+ interpret1 (CaseBlock mccs) = \input -> do+ let v = Nothing+ case mccs of+ Nothing -> return $ Completion CompletionTypeNormal v Nothing+ Just ccs -> do+ ecv <- search input ccs v+ case ecv of+ Left c -> return c+ Right (v', mrccs) -> do+ case mrccs of+ Nothing -> return $ Completion CompletionTypeNormal v' Nothing+ Just rccs -> falltrough rccs v'+ where+ search input (CaseClauses c@(CaseClause e msl)) v = do+ clauseSelector <- interpret c+ if input == clauseSelector+ then do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ if cty /= CompletionTypeNormal+ then return $ Left r+ else return $ Right (cv, Nothing)+ Nothing -> return $ Right (v, Nothing)+ else return $ Left $ Completion CompletionTypeNormal v Nothing+ search input (CaseClausesCons ccs c@(CaseClause e msl)) v = do+ clauseSelector <- interpret c+ if input == clauseSelector+ then do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ if cty /= CompletionTypeNormal+ then return $ Left r+ else return $ Right (cv, Just ccs)+ Nothing -> return $ Right (v, Just ccs)+ else search input ccs v+ falltrough (CaseClauses c@(CaseClause e msl)) v = do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v' = cv <|> v+ if cty /= CompletionTypeNormal+ then return $ Completion cty v' cta+ else return $ Completion CompletionTypeNormal v' Nothing+ Nothing -> return $ Completion CompletionTypeNormal v Nothing+ falltrough (CaseClausesCons ccs c@(CaseClause e msl)) v = do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v' = cv <|> v+ if cty /= CompletionTypeNormal+ then return $ Completion cty v' cta+ else falltrough ccs v'+ Nothing -> return $ Completion CompletionTypeNormal v Nothing++ interpret1 (CaseBlockDefault mfccs df@(DefaultClause msl) mrccs) = \input -> do+ let v = Nothing+ found = False+ ecvf <- case mfccs of+ Nothing -> return $ Right (v, found)+ Just fccs -> searchFirst input found fccs v+ case ecvf of+ Left c -> return c+ Right (v', found') -> do+ let foundInB = False+ ecvf' <- case (found, mrccs) of+ (False, _) -> return $ Right (v, foundInB, mrccs)+ (_, Nothing) -> return $ Right (v, foundInB, mrccs)+ (_, Just rccs) -> searchSecond input foundInB rccs v'+ case ecvf' of+ Left c -> return c+ Right (v'', foundInB', mrrccs) -> do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v''' = cv <|> v''+ if cty /= CompletionTypeNormal+ then return $ Completion cty v''' cta+ else do+ case mrrccs of+ Just rrccs -> falltrough rrccs v'''+ Nothing -> return $ Completion CompletionTypeNormal v''' Nothing+ where+ searchFirst input found cs@(CaseClauses c@(CaseClause e msl)) v = do+ if not found+ then do+ clauseSelector <- interpret c+ if input == clauseSelector+ then searchFirst input True cs v+ else return $ Right (v, found)+ else do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v' = cv <|> v+ if cty /= CompletionTypeNormal+ then return $ Left $ Completion cty v' cta+ else return $ Right (v', found)+ Nothing -> return $ Right (v, found)+ searchFirst input found cccs@(CaseClausesCons ccs c) v = do+ if not found+ then do+ clauseSelector <- interpret c+ if input == clauseSelector+ then searchFirst input True cccs v+ else return $ Right (v, found)+ else do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v' = cv <|> v+ if cty /= CompletionTypeNormal+ then return $ Left $ Completion cty v' cta+ else searchFirst input found ccs v'+ Nothing -> searchFirst input found ccs v+ searchSecond input foundInB cs@(CaseClauses c@(CaseClause e msl)) v = do+ clauseSelector <- interpret c+ if input == clauseSelector+ then do+ let foundInB' = True+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v' = cv <|> v+ if cty /= CompletionTypeNormal+ then return $ Left $ Completion cty v' cta+ else return $ Right (v', foundInB', Nothing)+ Nothing -> return $ Right (v, foundInB', Nothing)+ else return $ Right (v, foundInB, Nothing)+ searchSecond input foundInB (CaseClausesCons ccs c@(CaseClause e msl)) v = do+ clauseSelector <- interpret c+ if input == clauseSelector+ then do+ let foundInB' = True+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v' = cv <|> v+ if cty /= CompletionTypeNormal+ then return $ Left $ Completion cty v' cta+ else return $ Right (v', foundInB', Just ccs)+ Nothing -> return $ Right (v, foundInB', Just ccs)+ else searchSecond input foundInB ccs v+ falltrough cs@(CaseClauses c@(CaseClause e msl)) v = do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v' = cv <|> v+ if cty /= CompletionTypeNormal+ then return $ Completion cty v' cta+ else return $ Completion CompletionTypeNormal v' Nothing+ Nothing -> return $ Completion CompletionTypeNormal v Nothing+ falltrough (CaseClausesCons ccs c@(CaseClause e msl)) v = do+ case msl of+ Just sl -> do+ r@(Completion cty cv cta) <- interpret sl+ let v' = cv <|> v+ if cty /= CompletionTypeNormal+ then return $ Completion cty v' cta+ else falltrough ccs v'+ Nothing -> falltrough ccs v++instance (Functor m, Monad m) =>+ Interpret CaseClause (JavaScriptT m) Value where+ interpret (CaseClause expr _) = do+ exprRef <- interpret expr+ getValue exprRef++instance (Functor m, Monad m) =>+ Interpret LabelledStmt (JavaScriptT m) Completion where+ interpret (LabelledStmt ident stmt) = do+ contextStack . currentContext . labels %= (ident:)+ c@(Completion cty cv cta) <- interpret stmt+ contextStack . currentContext . labels %= tailSafe+ if cty == CompletionTypeBreak &&+ cta == Just ident+ then return $ Completion CompletionTypeNormal cv Nothing+ else return c++instance (Functor m, Monad m) =>+ Interpret ThrowStmt (JavaScriptT m) Completion where+ interpret (ThrowStmt expr) = do+ exprRef <- interpret expr+ v <- getValue exprRef+ return $ Completion CompletionTypeThrow (Just v) Nothing++instance (Functor m, Monad m) =>+ Interpret TryStmt (JavaScriptT m) Completion where+ interpret (TryStmtBC block catch) = do+ b@(Completion cty (Just cv) cta) <- interpret block+ if cty /= CompletionTypeThrow+ then return b+ else interpret1 catch cv+ interpret (TryStmtBF block finally) = do+ b@(Completion bcty bcv bcta) <- interpret block+ f@(Completion fcty fcv fcta) <- interpret finally+ if fcty == CompletionTypeNormal+ then return b+ else return f+ interpret (TryStmtBCF block catch finally) = do+ b@(Completion bcty (Just bcv) bcta) <- interpret block+ c <- if bcty == CompletionTypeThrow+ then interpret1 catch bcv+ else return b+ f@(Completion fcty fcv fcta) <- interpret finally+ if fcty == CompletionTypeNormal+ then return c+ else return f++instance (Functor m, Monad m) =>+ Interpret1 Catch (JavaScriptT m) Value Completion where+ interpret1 (Catch (Ident (IdentName ident)) block) = \c -> do+ oldEnv <- Lens.use (contextStack . currentContext . lexicalEnvironment)+ catchEnv <- newDeclarativeEnvironment (Just oldEnv)+ envRec <- Lens.use $ lexicalEnvironmentInternal catchEnv . environmentRecord+ createMutableBinding envRec ident Nothing+ setMutableBinding envRec ident c False+ contextStack . currentContext . lexicalEnvironment .= catchEnv+ b <- interpret block+ contextStack . currentContext . lexicalEnvironment .= oldEnv+ return b++instance (Functor m, Monad m) =>+ Interpret Finally (JavaScriptT m) Completion where+ interpret (Finally block) = interpret block++instance (Functor m, Monad m) =>+ Interpret DbgStmt (JavaScriptT m) Completion where+ interpret (DbgStmt) = return $ Completion CompletionTypeNormal Nothing Nothing++instance (Functor m, Monad m) =>+ Interpret FuncDecl (JavaScriptT m) Object where+ interpret (FuncDecl i mfpl fb) = do+ var <- Lens.use $ contextStack . currentContext . variableEnvironment+ let strict = False+ newFunctionObject mfpl fb var strict++instance (Functor m, Monad m) =>+ Interpret Program (JavaScriptT m) Completion where+ interpret program@(Program mses) = do+ case mses of+ Nothing -> return $ Completion CompletionTypeNormal Nothing Nothing+ Just ses -> do+ enterGlobalContext program+ result <- interpret ses+ popContext+ return result++instance (Functor m, Monad m) =>+ Interpret FuncExpr (JavaScriptT m) Object where+ interpret (FuncExpr Nothing mfpl fb) = do+ lex <- Lens.use $ contextStack . currentContext . lexicalEnvironment+ let strict = False+ newFunctionObject mfpl fb lex strict+ interpret (FuncExpr (Just (Ident (IdentName s))) mfpl fb) = do+ lex <- Lens.use $ contextStack . currentContext . lexicalEnvironment+ funcEnv <- newDeclarativeEnvironment (Just lex)+ envRec <- Lens.use $ lexicalEnvironmentInternal funcEnv . environmentRecord+ decEnvRec <- Lens.use $ environmentRecordInternal envRec .+ declarativeEnvironmentRecord+ createImmutableBindingDeclarative decEnvRec s+ let strict = False+ closure <- newFunctionObject mfpl fb funcEnv strict+ initializeImmutableBindingDeclarative decEnvRec s (inj closure)+ return closure++instance (Functor m, Monad m) =>+ Interpret FuncBody (JavaScriptT m) Completion where+ interpret (FuncBody Nothing) = return $+ Completion CompletionTypeNormal (Just (inj Undefined)) Nothing+ interpret (FuncBody (Just ses)) = interpret ses++instance (Functor m, Monad m) =>+ Interpret SourceElements (JavaScriptT m) Completion where+ interpret (SourceElementsCons ses se) = do+ headResult@(Completion hcty hcv hcta) <- interpret ses+ if hcty /= CompletionTypeNormal+ then return headResult+ else do+ tailResult@(Completion tcty tcv tcta) <- interpret se+ let v = tcv <|> hcv+ return $ Completion tcty v tcta+ interpret (SourceElements se) = interpret se++instance (Functor m, Monad m) =>+ Interpret SourceElement (JavaScriptT m) Completion where+ interpret (SourceElementStmt s) = interpret s+ interpret (SourceElementFuncDecl fd) =+ return $ Completion CompletionTypeNormal Nothing Nothing++instance (Functor m, Monad m) =>+ Interpret UExpr (JavaScriptT m) CallValue where+ interpret (UExprPostFix pfe) = interpret pfe++ interpret (UExprDelete ue) = do+ (rv :: CallValue) <- interpret ue+ case rv of+ Left ref -> do+ case getBase ref of+ BaseUndefined _ -> do+ if isStrictReference ref+ then newSyntaxErrorObject Nothing >>= jsThrow+ else return $ inj True+ BaseProperty propertyBase -> do+ obj <- toObject $ inj propertyBase+ inj <$> delete obj (getReferencedName ref) (isStrictReference ref)+ BaseEnvironmentRecord environmentRecordBase -> do+ if isStrictReference ref+ then newSyntaxErrorObject Nothing >>= jsThrow+ else do+ inj <$> deleteBinding environmentRecordBase (getReferencedName ref)++ interpret (UExprVoid ue) = do+ expr <- interpret ue+ getValue expr+ return $ inj Undefined++ interpret (UExprTypeOf ue) = do+ vr <- interpret ue+ case vr of+ Left ref -> do+ if isUnresolvableReference ref+ then return $ inj "undefined"+ else do+ val <- getValue ref+ return . inj . show $ typeOf val+ Right val -> do+ return . inj . show $ typeOf val++ interpret (UExprDoublePlus ue) = do+ (expr :: CallValue) <- interpret ue+ case prj expr of+ Just ref -> do+ if isStrictReference ref+ then do+ case prj (getBase ref) of+ Just (er :: EnvironmentRecord) -> do+ let name = getReferencedName ref+ if name == "eval" ||+ name == "arguments"+ then newSyntaxErrorObject Nothing >>= jsThrow+ else return ()+ Nothing -> return ()+ else return ()+ Nothing -> return ()+ v <- getValue expr+ oldValue <- toNumber v+ let newValue = oldValue + (Number 1)+ putValue expr newValue+ return $ inj newValue++ interpret (UExprDoubleMinus ue) = do+ expr <- interpret ue+ case prj expr of+ Just ref -> do+ if isStrictReference ref+ then do+ case prj (getBase ref) of+ Just (er :: EnvironmentRecord) -> do+ let name = getReferencedName ref+ if name == "eval" ||+ name == "arguments"+ then newSyntaxErrorObject Nothing >>= jsThrow+ else return ()+ Nothing -> return ()+ else return ()+ Nothing -> return ()+ v <- getValue expr+ oldValue <- toNumber v+ let newValue = oldValue - (Number 1)+ putValue expr newValue+ return $ inj newValue++ interpret (UExprUnaryPlus ue) = do+ expr <- interpret ue+ v <- getValue expr+ inj <$> toNumber v++ interpret (UExprUnaryMinus ue) = do+ expr <- interpret ue+ v <- getValue expr+ oldValue <- toNumber v+ return $ inj (-oldValue)++ interpret (UExprBitNot ue) = do+ expr <- interpret ue+ v <- getValue expr+ oldValue <- toInt32 v+ return $ inj $ Number (fromIntegral $ complement oldValue)++ interpret (UExprNot ue) = do+ expr <- interpret ue+ v <- getValue expr+ let oldValue = toBoolean v+ return $ inj $ not oldValue++instance (Functor m, Monad m) =>+ Interpret MemberExpr (JavaScriptT m) CallValue where+ interpret (MemberExprPrim pe) = do+ v <- interpret pe+ return $ inj v++ interpret (MemberExprFunc fe) = do+ (o :: Object) <- interpret fe+ return $ inj o++ interpret (MemberExprArray me expr) = do+ baseReference <- interpret me+ baseValue <- getValue baseReference+ propertyNameReference <- interpret expr+ propertyNameValue <- getValue propertyNameReference+ baseValueCoercible <- toObjectCoercible baseValue+ propertyNameString <- toString propertyNameValue+ let strict = False+ return $ inj $ Reference (inj baseValueCoercible) propertyNameString strict++ interpret (MemberExprDot me (IdentName s)) = do+ baseReference <- interpret me+ baseValue <- getValue baseReference+ baseValueCoercible <- toObjectCoercible baseValue+ let strict = False+ return $ inj $ Reference (inj baseValueCoercible) s strict++ interpret (MemberExprNew me args) = do+ ref <- interpret me+ constructor <- getValue ref+ argList <- interpret args+ case constructor of+ ValueObject o -> do+ inj <$> construct o argList+ _ -> newTypeErrorObject Nothing >>= jsThrow++instance (Functor m, Monad m) =>+ Interpret NewExpr (JavaScriptT m) CallValue where+ interpret (NewExprMember me) = interpret me+ interpret (NewExprNew ne) = do+ ref <- interpret ne+ constructor <- getValue ref+ case constructor of+ ValueObject o -> do+ inj <$> construct o (List [])+ _ -> newTypeErrorObject Nothing >>= jsThrow+++instance (Functor m, Monad m) =>+ Interpret CallExpr (JavaScriptT m) CallValue where+ interpret (CallExprMember me args) = do+ rv <- interpret me+ func <- getValue rv+ argList <- interpret args+ case func of+ ValueObject o -> do+ thisValue <-+ case rv of+ Left ref -> do+ case toPropertyReference ref of+ Right propertyBase -> return $ inj propertyBase+ Left (Left er) -> do+ implicitThisValue er+ _ -> return $ inj Undefined+ call o thisValue argList+ _ -> newTypeErrorObject Nothing >>= jsThrow++ interpret (CallExprCall ce args) = do+ rv <- interpret ce+ func <- getValue rv+ argList <- interpret args+ case func of+ ValueObject o -> do+ thisValue <-+ case rv of+ Left ref -> do+ case toPropertyReference ref of+ Right propertyBase -> return $ inj propertyBase+ Left (Left er) -> do+ implicitThisValue er+ _ -> return $ inj Undefined+ call o thisValue argList+ _ -> newTypeErrorObject Nothing >>= jsThrow++ interpret (CallExprArray ce expr) = do+ baseReference <- interpret ce+ baseValue <- getValue baseReference+ propertyNameReference <- interpret expr+ propertyNameValue <- getValue propertyNameReference+ baseValueCoercible <- toObjectCoercible baseValue+ propertyNameString <- toString propertyNameValue+ let strict = False+ return $ inj $ Reference (inj baseValueCoercible) propertyNameString strict++ interpret (CallExprDot ce (IdentName s)) = do+ baseReference <- interpret ce+ baseValue <- getValue baseReference+ baseValueCoercible <- toObjectCoercible baseValue+ let strict = False+ return $ inj $ Reference (inj baseValueCoercible) s strict++instance (Functor m, Monad m) =>+ Interpret Arguments (JavaScriptT m) (List Value) where+ interpret (ArgumentsEmpty) = return (List [])+ interpret (Arguments al) = interpret al++instance (Functor m, Monad m) =>+ Interpret ArgumentList (JavaScriptT m) (List Value) where+ interpret (ArgumentList ae) = do+ ref <- interpret ae+ arg <- getValue ref+ return $ List [arg]++ interpret (ArgumentListCons al ae) = do+ List precedingArgs <- interpret al+ ref <- interpret ae+ arg <- getValue ref+ return $ List (precedingArgs ++ [arg])++instance (Functor m, Monad m) =>+ Interpret LeftExpr (JavaScriptT m) CallValue where+ interpret (LeftExprNewExpr ne) = do+ v <- interpret ne+ return $ inj v+ interpret (LeftExprCallExpr ce) = interpret ce++instance (Functor m, Monad m) =>+ Interpret PostFixExpr (JavaScriptT m) CallValue where+ interpret (PostFixExprLeftExpr le) = interpret le++ interpret (PostFixExprPostInc le) = do+ lhs <- interpret le+ case lhs of+ CallValueReference ref ->+ when (isStrictReference ref) $ do+ case getBase ref of+ BaseEnvironmentRecord _ -> do+ let name = getReferencedName ref+ when (name == "eval" || name == "arguments") $+ newSyntaxErrorObject Nothing >>= jsThrow+ _ -> return ()+ _ -> return ()+ oldValue <- getValue lhs >>= toNumber+ let newValue = oldValue + (Number 1)+ putValue lhs newValue+ return (inj oldValue)++ interpret (PostFixExprPostDec le) = do+ lhs <- interpret le+ case lhs of+ CallValueReference ref ->+ when (isStrictReference ref) $ do+ case getBase ref of+ BaseEnvironmentRecord _ -> do+ let name = getReferencedName ref+ when (name == "eval" || name == "arguments") $+ newSyntaxErrorObject Nothing >>= jsThrow+ _ -> return ()+ _ -> return ()+ oldValue <- getValue lhs >>= toNumber+ let newValue = oldValue - (Number 1)+ putValue lhs newValue+ return (inj oldValue)++instance (Functor m, Monad m) =>+ Interpret MultExpr (JavaScriptT m) CallValue where+ interpret (MultExpr ue) = interpret ue++ interpret (MultExprMult me ue) = do+ left <- interpret me+ right <- interpret ue+ inj <$> left `operatorMult` right++ interpret (MultExprDiv me ue) = do+ left <- interpret me+ right <- interpret ue+ inj <$> left `operatorDiv` right++ interpret (MultExprMod me ue) = do+ left <- interpret me+ right <- interpret ue+ inj <$> left `operatorMod` right++instance (Functor m, Monad m) =>+ Interpret AddExpr (JavaScriptT m) CallValue where+ interpret (AddExpr me) = interpret me++ interpret (AddExprAdd ae me) = do+ lref <- interpret ae+ rref <- interpret me+ inj <$> lref `operatorPlus` rref++ interpret (AddExprSub ae me) = do+ lref <- interpret ae+ rref <- interpret me+ inj <$> lref `operatorMinus` rref++instance (Functor m, Monad m) =>+ Interpret ShiftExpr (JavaScriptT m) CallValue where+ interpret (ShiftExpr ae) = interpret ae+ interpret (ShiftExprLeft se ae) = do+ lref <- interpret se+ rref <- interpret ae+ inj <$> lref `operatorLeftShift` rref++ interpret (ShiftExprRight se ae) = do+ lref <- interpret se+ rref <- interpret ae+ inj <$> lref `operatorSignedRightShift` rref++ interpret (ShiftExprRightZero se ae) = do+ lref <- interpret se+ rref <- interpret ae+ inj <$> lref `operatorUnsignedRightShift` rref++instance (Functor m, Monad m) =>+ Interpret RelExpr (JavaScriptT m) CallValue where+ interpret (RelExpr se) = interpret se++ interpret (RelExprLess re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ mr <- compareLess lval rval True+ case mr of+ JSNothing -> return $ inj False+ JSJust r -> return $ inj r++ interpret (RelExprGreater re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ mr <- compareLess rval lval False+ case mr of+ JSNothing -> return $ inj False+ JSJust r -> return $ inj r++ interpret (RelExprLessEq re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ mr <- compareLess rval lval False+ case mr of+ JSNothing -> return $ inj False+ JSJust _ -> return $ inj True++ interpret (RelExprGreaterEq re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ mr <- compareLess lval rval True+ case mr of+ JSNothing -> return $ inj False+ JSJust True -> return $ inj False+ JSJust False -> return $ inj True++ interpret (RelExprInstanceOf re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ case rval of+ ValueObject o -> do+ inj <$> hasInstance o lval+ _ -> newTypeErrorObject Nothing >>= jsThrow++ interpret (RelExprIn re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ case prj rval of+ Nothing -> newTypeErrorObject Nothing >>= jsThrow+ Just obj -> do+ s <- toString lval+ inj <$> hasProperty obj s++instance (Functor m, Monad m) =>+ Interpret RelExprNoIn (JavaScriptT m) CallValue where+ interpret (RelExprNoIn se) = interpret se+ interpret (RelExprNoInLess re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ mr <- compareLess lval rval True+ case mr of+ JSNothing -> return $ inj False+ JSJust r -> return $ inj r++ interpret (RelExprNoInGreater re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ mr <- compareLess rval lval False+ case mr of+ JSNothing -> return $ inj False+ JSJust r -> return $ inj r++ interpret (RelExprNoInLessEq re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ mr <- compareLess rval lval False+ case mr of+ JSNothing -> return $ inj False+ JSJust _ -> return $ inj True++ interpret (RelExprNoInGreaterEq re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ mr <- compareLess lval rval True+ case mr of+ JSNothing -> return $ inj False+ JSJust True -> return $ inj False+ JSJust False -> return $ inj True++ interpret (RelExprNoInInstanceOf re se) = do+ lref <- interpret re+ lval <- getValue lref+ rref <- interpret se+ rval <- getValue rref+ case rval of+ ValueObject obj ->+ inj <$> hasInstance obj lval+ _ -> newTypeErrorObject Nothing >>= jsThrow++instance (Functor m, Monad m) =>+ Interpret EqExpr (JavaScriptT m) CallValue where+ interpret (EqExpr re) = interpret re++ interpret (EqExprEq eq re) = do+ lref <- interpret eq+ lval <- getValue lref+ rref <- interpret re+ rval <- getValue rref+ inj <$> compare rval lval++ interpret (EqExprNotEq eq re) = do+ lref <- interpret eq+ lval <- getValue lref+ rref <- interpret re+ rval <- getValue rref+ r <- compare rval lval+ return $ inj $ not r++ interpret (EqExprStrictEq eq re) = do+ lref <- interpret eq+ lval <- getValue lref+ rref <- interpret re+ rval <- getValue rref+ return $ inj $ compareStrict rval lval++ interpret (EqExprStrictNotEq eq re) = do+ lref <- interpret eq+ lval <- getValue lref+ rref <- interpret re+ rval <- getValue rref+ return $ inj $ not $ compareStrict rval lval++instance (Functor m, Monad m) =>+ Interpret EqExprNoIn (JavaScriptT m) CallValue where+ interpret (EqExprNoIn re) = interpret re++ interpret (EqExprNoInEq eq re) = do+ lref <- interpret eq+ lval <- getValue lref+ rref <- interpret re+ rval <- getValue rref+ inj <$> compare rval lval++ interpret (EqExprNoInNotEq eq re) = do+ lref <- interpret eq+ lval <- getValue lref+ rref <- interpret re+ rval <- getValue rref+ r <- compare rval lval+ return $ inj $ not r++ interpret (EqExprNoInStrictEq eq re) = do+ lref <- interpret eq+ lval <- getValue lref+ rref <- interpret re+ rval <- getValue rref+ return $ inj $ compareStrict rval lval++ interpret (EqExprNoInStrictNotEq eq re) = do+ lref <- interpret eq+ lval <- getValue lref+ rref <- interpret re+ rval <- getValue rref+ return $ inj $ not $ compareStrict rval lval++instance (Functor m, Monad m) =>+ Interpret BitAndExpr (JavaScriptT m) CallValue where+ interpret (BitAndExpr eq) = interpret eq++ interpret (BitAndExprAnd bae eq) = do+ lref <- interpret bae+ rref <- interpret eq+ inj <$> lref `operatorBitwiseAnd` rref++instance (Functor m, Monad m) =>+ Interpret BitAndExprNoIn (JavaScriptT m) CallValue where+ interpret (BitAndExprNoIn eq) = interpret eq++ interpret (BitAndExprNoInAnd bae eq) = do+ lref <- interpret bae+ rref <- interpret eq+ inj <$> lref `operatorBitwiseAnd` rref++instance (Functor m, Monad m) =>+ Interpret BitXorExpr (JavaScriptT m) CallValue where+ interpret (BitXorExpr eq) = interpret eq++ interpret (BitXorExprXor bae eq) = do+ lref <- interpret bae+ rref <- interpret eq+ inj <$> lref `operatorBitwiseXor` rref++instance (Functor m, Monad m) =>+ Interpret BitXorExprNoIn (JavaScriptT m) CallValue where+ interpret (BitXorExprNoIn eq) = interpret eq++ interpret (BitXorExprNoInXor bae eq) = do+ lref <- interpret bae+ rref <- interpret eq+ inj <$> lref `operatorBitwiseXor` rref++instance (Functor m, Monad m) =>+ Interpret BitOrExpr (JavaScriptT m) CallValue where+ interpret (BitOrExpr eq) = interpret eq++ interpret (BitOrExprOr bae eq) = do+ lref <- interpret bae+ rref <- interpret eq+ inj <$> lref `operatorBitwiseOr` rref++instance (Functor m, Monad m) =>+ Interpret BitOrExprNoIn (JavaScriptT m) CallValue where+ interpret (BitOrExprNoIn eq) = interpret eq++ interpret (BitOrExprNoInOr bae eq) = do+ lref <- interpret bae+ rref <- interpret eq+ inj <$> lref `operatorBitwiseOr` rref++instance (Functor m, Monad m) =>+ Interpret LogicalAndExpr (JavaScriptT m) CallValue where+ interpret (LogicalAndExpr boe) = interpret boe++ interpret (LogicalAndExprAnd lae boe) = do+ lref <- interpret lae+ lval <- getValue lref+ if not $ toBoolean lval+ then return $ inj lval+ else do+ rref <- interpret boe+ inj <$> getValue rref++instance (Functor m, Monad m) =>+ Interpret LogicalAndExprNoIn (JavaScriptT m) CallValue where+ interpret (LogicalAndExprNoIn boe) = do+ n <- interpret boe+ return $ inj n++ interpret (LogicalAndExprNoInAnd lae boe) = do+ lref <- interpret lae+ lval <- getValue lref+ if not $ toBoolean lval+ then return $ inj lval+ else do+ rref <- interpret boe+ inj <$> getValue rref++instance (Functor m, Monad m) =>+ Interpret LogicalOrExpr (JavaScriptT m) CallValue where+ interpret (LogicalOrExpr boe) = interpret boe++ interpret (LogicalOrExprOr lae boe) = do+ lref <- interpret lae+ lval <- getValue lref+ if not $ toBoolean lval+ then return $ inj lval+ else do+ rref <- interpret boe+ inj <$> getValue rref++instance (Functor m, Monad m) =>+ Interpret LogicalOrExprNoIn (JavaScriptT m) CallValue where+ interpret (LogicalOrExprNoIn boe) = interpret boe++ interpret (LogicalOrExprNoInOr lae boe) = do+ lref <- interpret lae+ lval <- getValue lref+ if toBoolean lval+ then return $ inj lval+ else do+ rref <- interpret boe+ inj <$> getValue rref++instance (Functor m, Monad m) =>+ Interpret CondExpr (JavaScriptT m) CallValue where+ interpret (CondExpr loe) = interpret loe++ interpret (CondExprIf loe ae1 ae2) = do+ lref <- interpret loe+ lval <- getValue lref+ if toBoolean lval+ then do+ trueRef <- interpret ae1+ inj <$> getValue trueRef+ else do+ falseRef <- interpret ae2+ inj <$> getValue falseRef++instance (Functor m, Monad m) =>+ Interpret CondExprNoIn (JavaScriptT m) CallValue where+ interpret (CondExprNoIn loe) = interpret loe++ interpret (CondExprNoInIf loe ae1 ae2) = do+ lref <- interpret loe+ lval <- getValue lref+ if toBoolean lval+ then do+ trueRef <- interpret ae1+ inj <$> getValue trueRef+ else do+ falseRef <- interpret ae2+ inj <$> getValue falseRef++instance (Functor m, Monad m) =>+ Interpret AssignExpr (JavaScriptT m) CallValue where+ interpret (AssignExprCondExpr ce) = interpret ce++ interpret (AssignExprAssign le AssignOpNormal ae) = do+ lref <- interpret le+ rref <- interpret ae+ rval <- getValue rref+ case lref of+ CallValueReference ref -> do+ when (isStrictReference ref &&+ typeOf (getBase ref) == TypeEnvironmentRecord &&+ (getReferencedName ref == "eval" ||+ getReferencedName ref == "arguments")) $ do+ newSyntaxErrorObject Nothing >>= jsThrow+ _ -> return ()+ putValue lref rval+ return $ inj rval++ interpret (AssignExprAssign le aop ae) = do+ lref <- interpret le+ lval <- getValue lref+ rref <- interpret ae+ rval <- getValue rref+ r <- case aop of+ AssignOpMult -> inj <$> lval `operatorMult` rval+ AssignOpDiv -> inj <$> lval `operatorDiv` rval+ AssignOpMod -> inj <$> lval `operatorMod` rval+ AssignOpPlus -> lval `operatorPlus` rval+ AssignOpMinus -> inj <$> lval `operatorMinus` rval+ AssignOpShiftLeft -> inj <$> lval `operatorLeftShift` rval+ AssignOpShiftRight -> inj <$> lval `operatorSignedRightShift` rval+ AssignOpShiftRightZero -> inj <$> lval `operatorUnsignedRightShift` rval+ AssignOpBitAnd -> inj <$> lval `operatorBitwiseAnd` rval+ AssignOpBitXor -> inj <$> lval `operatorBitwiseXor` rval+ AssignOpBitOr -> inj <$> lval `operatorBitwiseOr` rval+ case lref of+ CallValueReference ref -> do+ when (isStrictReference ref &&+ typeOf (getBase ref) == TypeEnvironmentRecord &&+ (getReferencedName ref == "eval" ||+ getReferencedName ref == "arguments")) $ do+ newSyntaxErrorObject Nothing >>= jsThrow+ _ -> return ()+ putValue lref r+ return $ inj r++instance (Functor m, Monad m) =>+ Interpret AssignExprNoIn (JavaScriptT m) CallValue where+ interpret (AssignExprNoInCondExpr ce) = interpret ce++ interpret (AssignExprNoInAssign le AssignOpNormal ae) = do+ lref <- interpret le+ rref <- interpret ae+ rval <- getValue rref+ case prj lref of+ Just ref -> do+ when (isStrictReference ref &&+ typeOf (getBase ref) == TypeEnvironmentRecord &&+ (getReferencedName ref == "eval" ||+ getReferencedName ref == "arguments")) $ do+ newSyntaxErrorObject Nothing >>= jsThrow+ Nothing -> return ()+ putValue lref rval+ return $ inj rval++ interpret (AssignExprNoInAssign le aop ae) = do+ lref <- interpret le+ lval <- getValue lref+ rref <- interpret ae+ rval <- getValue rref+ r <- case aop of+ AssignOpMult -> inj <$> lval `operatorMult` rval+ AssignOpDiv -> inj <$> lval `operatorDiv` rval+ AssignOpMod -> inj <$> lval `operatorMod` rval+ AssignOpPlus -> lval `operatorPlus` rval+ AssignOpMinus -> inj <$> lval `operatorMinus` rval+ AssignOpShiftLeft -> inj <$> lval `operatorLeftShift` rval+ AssignOpShiftRight -> inj <$> lval `operatorSignedRightShift` rval+ AssignOpShiftRightZero -> inj <$> lval `operatorUnsignedRightShift` rval+ AssignOpBitAnd -> inj <$> lval `operatorBitwiseAnd` rval+ AssignOpBitXor -> inj <$> lval `operatorBitwiseXor` rval+ AssignOpBitOr -> inj <$> lval `operatorBitwiseOr` rval+ case prj lref of+ Just ref -> do+ when (isStrictReference ref &&+ typeOf (getBase ref) == TypeEnvironmentRecord &&+ (getReferencedName ref == "eval" ||+ getReferencedName ref == "arguments")) $ do+ newSyntaxErrorObject Nothing >>= jsThrow+ Nothing -> return ()+ putValue lref r+ return $ inj r++instance (Functor m, Monad m) =>+ Interpret Expr (JavaScriptT m) CallValue where+ interpret (Expr ae) = interpret ae++ interpret (ExprCons e ae) = do+ lref <- interpret e+ getValue lref+ rref <- interpret ae+ inj <$> getValue rref++instance (Functor m, Monad m) =>+ Interpret ExprNoIn (JavaScriptT m) CallValue where+ interpret (ExprNoIn ae) = interpret ae++ interpret (ExprNoInCons e ae) = do+ lref <- interpret e+ getValue lref+ rref <- interpret ae+ inj <$> getValue rref++instance (Functor m, Monad m) =>+ Interpret Ident (JavaScriptT m) Reference where+ interpret (Ident (IdentName s)) = do+ env <- Lens.use $ contextStack . currentContext . lexicalEnvironment+ let strict = False+ getIdentifierReference (Just env) s strict++declarationBindingInstantiation :: (Functor m, Monad m) =>+ Code -> JavaScriptT m ()+declarationBindingInstantiation c = do+ let strict = False+ configurableBindings =+ case c of+ CodeEval {} -> True+ _ -> False++ case c of+ CodeFunction func args -> do+ (FuncBody mses) <- code func+ (lex, env) <- step1+ dec <- Lens.use $ environmentRecordInternal env . declarativeEnvironmentRecord+ names <- step2 strict dec func args+ case mses of+ Just ses -> do+ step3 strict configurableBindings env ses+ argumentsAlreadyDeclared <- step4 env+ when (not argumentsAlreadyDeclared) $ do+ step5 strict lex dec func names args+ step6 strict configurableBindings env ses+ return ()+ Nothing -> do+ argumentsAlreadyDeclared <- step4 env+ when (not argumentsAlreadyDeclared) $ do+ step5 strict lex dec func names args+ return ()+ CodeGlobal (Program mses) -> do+ (lex, env) <- step1+ case mses of+ Just ses -> do+ step3 strict configurableBindings env ses+ step4 env+ step6 strict configurableBindings env ses+ return ()+ Nothing -> do+ step4 env+ return ()+ where+ step1 :: (Functor m, Monad m) =>+ JavaScriptT m (LexicalEnvironment, EnvironmentRecord)+ step1 = do+ var <- Lens.use $ contextStack . currentContext . variableEnvironment+ env <- Lens.use $ lexicalEnvironmentInternal var . environmentRecord+ return (var, env)++ step2 :: (Functor m, Monad m) =>+ Bool -> DeclarativeEnvironmentRecord -> Object -> List Value ->+ JavaScriptT m (List String)+ step2 strict env func args@(List as) = do+ names@(List ns) <- formalParameters func+ let argCount = length as+ n = 0+ (flip . flip foldlM) n ns $ \n argName -> do+ let n' = n+1+ v = if n' > argCount+ then inj Undefined+ else as !! (n' - 1)+ argAlreadyDeclared <- hasBindingDeclarative env argName+ when (not argAlreadyDeclared) $ do+ createMutableBindingDeclarative env argName Nothing+ setMutableBindingDeclarative env argName v strict+ return n'+ return names++ step3 :: (Functor m, Monad m) =>+ Bool -> Bool -> EnvironmentRecord -> SourceElements ->+ JavaScriptT m ()+ step3 strict configurableBindings env ses = do+ forM (extractFuncDecls ses) $+ \f@(FuncDecl (Ident (IdentName fn)) mfpl fb) -> do+ fo <- interpret f+ funcAlreadyDeclared <- hasBinding env fn+ if (not funcAlreadyDeclared)+ then createMutableBinding env fn (Just configurableBindings)+ else do+ if False+ then return ()+ else return ()+ setMutableBinding env fn (inj fo) strict+ return ()++ step4 :: (Functor m, Monad m) =>+ EnvironmentRecord -> JavaScriptT m Bool+ step4 env = do+ argumentsAlreadyDeclared <- hasBinding env "arguments"+ return argumentsAlreadyDeclared++ step5 :: (Functor m, Monad m) =>+ Bool -> LexicalEnvironment -> DeclarativeEnvironmentRecord ->+ Object -> List String -> List Value -> JavaScriptT m ()+ step5 strict lex env func names args@(List as) = do+ argsObj <- createArgumentsObject+ func names args lex strict+ if strict+ then do+ createImmutableBindingDeclarative env "arguments"+ initializeImmutableBindingDeclarative env "arguments" (inj argsObj)+ return ()+ else do+ createMutableBindingDeclarative env "arguments" Nothing+ setMutableBindingDeclarative env "arguments" (inj argsObj) False++ step6 :: (Functor m, Monad m) =>+ Bool -> Bool -> EnvironmentRecord -> SourceElements ->+ JavaScriptT m ()+ step6 strict configurableBindings env ses = do+ forM (extractVarDeclIdents ses) $ \(Ident (IdentName dn)) -> do+ varAlreadyDeclared <- hasBinding env dn+ when (not varAlreadyDeclared) $ do+ createMutableBinding env dn (Just configurableBindings)+ setMutableBinding env dn (inj Undefined) strict+ return ()++ extractFuncDecls :: SourceElements -> [FuncDecl]+ extractFuncDecls (SourceElements (SourceElementFuncDecl fd)) = [fd]+ extractFuncDecls (SourceElements _) = []+ extractFuncDecls (SourceElementsCons ses (SourceElementFuncDecl fd)) =+ fd:(extractFuncDecls ses)+ extractFuncDecls (SourceElementsCons ses _) =+ extractFuncDecls ses++ extractVarDeclIdents :: SourceElements -> [Ident]+ extractVarDeclIdents (SourceElementsCons ses se) =+ extractVarDeclIdentsSE se ++ extractVarDeclIdents ses+ extractVarDeclIdents (SourceElements se) =+ extractVarDeclIdentsSE se+ extractVarDeclIdentsSE (SourceElementStmt s) =+ extractVarDeclIdentsS s+ extractVarDeclIdentsSE _ = []+ extractVarDeclIdentsS (StmtVar vs) =+ extractVarDeclIdentsVS vs+ extractVarDeclIdentsS _ = []+ extractVarDeclIdentsVS (VarStmt vdl) =+ extractVarDeclIdentsVDL vdl+ extractVarDeclIdentsVDL (VarDeclList vd) =+ extractVarDeclIdentsVD vd+ extractVarDeclIdentsVDL (VarDeclListCons vdl vd) =+ extractVarDeclIdentsVD vd ++ extractVarDeclIdentsVDL vdl+ extractVarDeclIdentsVD (VarDecl i _) = [i]+++type UInt16 = Word16+type UInt32 = Word32++data Context+ = Context+ { contextLexicalEnvironment :: LexicalEnvironment+ , contextVariableEnvironment :: LexicalEnvironment+ , contextThisBinding :: Value+ , contextLabels :: [Ident] }+ deriving (Show)++lexicalEnvironment :: Lens' Context LexicalEnvironment+lexicalEnvironment =+ Lens.lens+ contextLexicalEnvironment+ (\c le -> c { contextLexicalEnvironment = le })++variableEnvironment :: Lens' Context LexicalEnvironment+variableEnvironment =+ Lens.lens+ contextVariableEnvironment+ (\c ve -> c { contextVariableEnvironment = ve })++thisBinding :: Lens' Context Value+thisBinding =+ Lens.lens+ contextThisBinding+ (\c t -> c { contextThisBinding = t })++labels :: Lens' Context [Ident]+labels = Lens.lens contextLabels (\c ls -> c { contextLabels = ls })++inCurrentLabelSet :: Maybe Ident -> JavaScriptM Bool+inCurrentLabelSet mi = do+ case mi of+ Just i -> do+ ls <- Lens.use $ contextStack . currentContext . labels+ return (i `elem` ls)+ _ -> return True++data ContextStack+ = ContextStack+ { contextStackCurrent :: Context+ , contextStackStack :: [Context] }+ deriving (Show)++currentContext :: Lens' ContextStack Context+currentContext =+ Lens.lens+ contextStackCurrent+ (\cs c -> cs { contextStackCurrent = c })++type EnvironmentRecordHeap+ = Map EnvironmentRecord EnvironmentRecordInternal++type DeclarativeEnvironmentRecordHeap+ = Map DeclarativeEnvironmentRecord DeclarativeEnvironmentRecordInternal++type LexicalEnvironmentHeap+ = Map LexicalEnvironment LexicalEnvironmentInternal++type ObjectHeap m = Map Object (ObjectInternal m)++data JavaScriptState m+ = JavaScriptState+ { javaScriptStateContextStack :: ContextStack+ , javaScriptStateNextInternalId :: InternalId+ , javaScriptStateEnvironmentRecordHeap :: EnvironmentRecordHeap+ , javaScriptStateDeclarativeEnvironmentRecordHeap :: DeclarativeEnvironmentRecordHeap+ , javaScriptStateLexicalEnvironmentHeap :: LexicalEnvironmentHeap+ , javaScriptStateObjectHeap :: ObjectHeap m+ , javaScriptStateGlobalLexicalEnvironment :: LexicalEnvironment+ , javaScriptStateGlobalObject :: Object+ , javaScriptStateArrayPrototypeObject :: Object+ , javaScriptStateBooleanPrototypeObject :: Object+ , javaScriptStateDatePrototypeObject :: Object+ , javaScriptStateErrorPrototypeObject :: Object+ , javaScriptStateEvalErrorPrototypeObject :: Object+ , javaScriptStateRangeErrorPrototypeObject :: Object+ , javaScriptStateReferenceErrorPrototypeObject :: Object+ , javaScriptStateSyntaxErrorPrototypeObject :: Object+ , javaScriptStateTypeErrorPrototypeObject :: Object+ , javaScriptStateURIErrorPrototypeObject :: Object+ , javaScriptStateFunctionPrototypeObject :: Object+ , javaScriptStateNumberPrototypeObject :: Object+ , javaScriptStateObjectPrototypeObject :: Object+ , javaScriptStateRegExpPrototypeObject :: Object+ , javaScriptStateStringPrototypeObject :: Object+ , javaScriptStateThrowTypeErrorObject :: Object }++initialState :: (Functor m, Monad m) => JavaScriptState m+initialState =+ let ctx = Context {+ contextLexicalEnvironment = error "Unitialised lexical environment",+ contextVariableEnvironment = error "Unitialised variable environment",+ contextThisBinding = error "Unitialised this binding",+ contextLabels = [] }++ ctxs = ContextStack {+ contextStackCurrent = ctx,+ contextStackStack = [] }++ environmentRecordHeap =+ Map.fromList+ [ (globalEnvironmentRecord, globalEnvironmentRecordInternal) ]++ declarativeEnvironmentRecordHeap =+ Map.empty++ lexicalEnvironmentHeap =+ Map.fromList+ [ (globalLexicalEnvironment, globalLexicalEnvironmentInternal) ]++ objectHeap =+ Map.fromList+ [ (globalObject, globalObjectInternal)+ , (arrayPrototypeObject, arrayPrototypeObjectInternal)+ , (booleanPrototypeObject, booleanPrototypeObjectInternal)+ , (datePrototypeObject, datePrototypeObjectInternal)+ , (errorPrototypeObject, errorPrototypeObjectInternal)+ , (errorPrototypeToString, errorPrototypeToStringInternal)+ , (evalErrorPrototypeObject, evalErrorPrototypeObjectInternal)+ , (rangeErrorPrototypeObject, rangeErrorPrototypeObjectInternal)+ , (referenceErrorPrototypeObject, referenceErrorPrototypeObjectInternal)+ , (syntaxErrorPrototypeObject, syntaxErrorPrototypeObjectInternal)+ , (typeErrorPrototypeObject, typeErrorPrototypeObjectInternal)+ , (uriErrorPrototypeObject, uriErrorPrototypeObjectInternal)+ , (functionPrototypeObject, functionPrototypeObjectInternal)+ , (numberPrototypeObject, numberPrototypeObjectInternal)+ , (objectPrototypeObject, objectPrototypeObjectInternal)+ , (regExpPrototypeObject, regExpPrototypeObjectInternal)+ , (stringPrototypeObject, stringPrototypeObjectInternal)+ , (throwTypeErrorObject, throwTypeErrorObjectInternal)+ , (objectConstructor, objectConstructorInternal)+ , (functionConstructor, functionConstructorInternal)+ , (arrayConstructor, arrayConstructorInternal)+ , (stringConstructor, stringConstructorInternal)+ , (booleanConstructor, booleanConstructorInternal)+ , (numberConstructor, numberConstructorInternal)+ , (dateConstructor, dateConstructorInternal)+ , (regExpConstructor, regExpConstructorInternal)+ , (errorConstructor, errorConstructorInternal)+ , (evalErrorConstructor, evalErrorConstructorInternal)+ , (rangeErrorConstructor, rangeErrorConstructorInternal)+ , (referenceErrorConstructor, referenceErrorConstructorInternal)+ , (syntaxErrorConstructor, syntaxErrorConstructorInternal)+ , (typeErrorConstructor, typeErrorConstructorInternal)+ , (uriErrorConstructor, uriErrorConstructorInternal)+ , (mathObject, mathObjectInternal)+ , (jsonObject, jsonObjectInternal) ]++ globalLexicalEnvironmentInternal =+ LexicalEnvironmentInternal globalEnvironmentRecord Nothing+ globalLexicalEnvironment = LexicalEnvironment 0++ globalEnvironmentRecordInternal =+ EnvironmentRecordInternalObject+ (ObjectEnvironmentRecord globalObject True)+ globalEnvironmentRecord = EnvironmentRecord 1++ globalObject = Object 2+ globalObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ globalObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("NaN", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj nan,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("Infinity", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj posInf,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("undefined", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj Undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("eval", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalEval,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("parseInt", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalParseInt,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("parseFloat", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalParseFloat,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("isNaN", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalIsNaN,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("isFinite", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalIsFinite,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("decodeURI", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalDecodeURI,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("decodeURIComponent", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalDecodeURIComponent,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("encodeURI", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalEncodeURI,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("encodeURIComponent", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj globalEncodeURIComponent,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("Object", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj objectConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("Function", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj functionConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("Array", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("String", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj stringConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("Boolean", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj booleanConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("Number", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj numberConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("Date", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj dateConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("RegExp", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj regExpConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("Error", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj errorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("EvalError", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj evalErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("RangeError", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj rangeErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("ReferenceError", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj referenceErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("SyntaxError", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj syntaxErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("TypeError", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj typeErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("URIError", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj uriErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("Math", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathObject,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True })+ , ("JSON", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj jsonObject,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = True }) ],+ objectInternalPrototype = const $ return JSNull,+ objectInternalClass = "Object",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ globalEval = error "globalEval" :: Object+ globalParseInt = error "globalParseInt" :: Object+ globalParseFloat = error "globalParseFloat" :: Object+ globalIsNaN = error "globalIsNaN" :: Object+ globalIsFinite = error "globalIsFinite" :: Object+ globalDecodeURI = error "globalDecodeURI" :: Object+ globalDecodeURIComponent = error "globalDecodeURIComponent" :: Object+ globalEncodeURI = error "globalEncodeURI" :: Object+ globalEncodeURIComponent = error "globalEncodeURIComponent" :: Object++ arrayPrototypeObject = Object 3+ arrayPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ def {+ dataDescriptorValue = inj $ Number 0 })+ , ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toString", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeToString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toLocaleString", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeToLocaleString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("concat", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeConcat,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("join", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeJoin,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("pop", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypePop,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("push", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypePush,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("reverse", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeReverse,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("shift", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeShift,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("slice", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeSlice,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("sort", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeSort,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("splice", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeSplice,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("unshift", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeUnshift,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("indexOf", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeIndexOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("lastIndexOf", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeLastIndexOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("every", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeEvery,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("some", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeSome,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("forEach", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeForEach,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("map", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeMap,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("filter", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeFilter,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("reduce", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeReduce,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("reduceRight", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj arrayPrototypeReduceRight,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "Array",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = arrayDefineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ arrayPrototypeToString = error "arrayPrototypeToString" :: Object+ arrayPrototypeToLocaleString = error "arrayPrototypeToLocaleString" :: Object+ arrayPrototypeConcat = error "arrayPrototypeConcat" :: Object+ arrayPrototypeJoin = error "arrayPrototypeJoin" :: Object+ arrayPrototypePop = error "arrayPrototypePop" :: Object+ arrayPrototypePush = error "arrayPrototypePush" :: Object+ arrayPrototypeReverse = error "arrayPrototypeReverse" :: Object+ arrayPrototypeShift = error "arrayPrototypeShift" :: Object+ arrayPrototypeSlice = error "arrayPrototypeSlice" :: Object+ arrayPrototypeSort = error "arrayPrototypeSort" :: Object+ arrayPrototypeSplice = error "arrayPrototypeSplice" :: Object+ arrayPrototypeUnshift = error "arrayPrototypeUnshift" :: Object+ arrayPrototypeIndexOf = error "arrayPrototypeUndexOf" :: Object+ arrayPrototypeLastIndexOf = error "arrayPrototypeLastIndexOf" :: Object+ arrayPrototypeEvery = error "arrayPrototypeEvery" :: Object+ arrayPrototypeSome = error "arrayPrototypeSome" :: Object+ arrayPrototypeForEach = error "arrayPrototypeForEach" :: Object+ arrayPrototypeMap = error "arrayPrototypeMap" :: Object+ arrayPrototypeFilter = error "arrayPrototypeFilter" :: Object+ arrayPrototypeReduce = error "arrayPrototypeReduce" :: Object+ arrayPrototypeReduceRight = error "arrayPrototypeReduceRight" :: Object++ booleanPrototypeObject = Object 4+ booleanPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj booleanConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toString", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj booleanPrototypeToString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("valueOf", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj booleanPrototypeValueOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "Boolean",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just (const $ return (inj False)),+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ booleanPrototypeToString = error "booleanPrototypeToString" :: Object++ booleanPrototypeValueOf = error "booleanPrototypeValueOf" :: Object++ datePrototypeObject = Object 5+ datePrototypeObjectInternal = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "Date",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just (const $ return (inj nan)),+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ errorPrototypeObject = Object 6+ errorPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj errorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("name", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "Error",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toString", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj errorPrototypeToString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ errorPrototypeToString = Object 7+ errorPrototypeToStringInternal :: (Functor m, Monad m) => ObjectInternal m+ errorPrototypeToStringInternal =+ propertyFunctionObject errorPrototypeToStringCallImpl 0++ evalErrorPrototypeObject = Object 8+ evalErrorPrototypeObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ evalErrorPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj evalErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("name", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "EvalError",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist errorPrototypeObject),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ rangeErrorPrototypeObject = Object 9+ rangeErrorPrototypeObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ rangeErrorPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj rangeErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("name", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "RangeError",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist errorPrototypeObject),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ referenceErrorPrototypeObject = Object 10+ referenceErrorPrototypeObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ referenceErrorPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj referenceErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("name", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "ReferenceError",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist errorPrototypeObject),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ syntaxErrorPrototypeObject = Object 11+ syntaxErrorPrototypeObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ syntaxErrorPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj syntaxErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("name", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "SyntaxError",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist errorPrototypeObject),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ typeErrorPrototypeObject = Object 12+ typeErrorPrototypeObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ typeErrorPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj typeErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("name", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "TypeError",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist errorPrototypeObject),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ uriErrorPrototypeObject = Object 13+ uriErrorPrototypeObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ uriErrorPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj uriErrorConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("name", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "URIError",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj "",+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist errorPrototypeObject),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ functionPrototypeObject = Object 14+ functionPrototypeObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ functionPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ def {+ dataDescriptorValue = inj $ Number 0 })+ , ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj functionConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toString", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj functionPrototypeToString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("apply", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj functionPrototypeApply,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("call", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj functionPrototypeCall,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("bind", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj functionPrototypeBind,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })],+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "Function",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Just functionPrototypeCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ functionPrototypeToString = error "functionPrototypeToString" :: Object+ functionPrototypeApply = error "functionPrototypeApply" :: Object+ functionPrototypeCall = error "functionPrototypeCall" :: Object+ functionPrototypeBind = error "functionPrototypeBind" :: Object++ numberPrototypeObject = Object 15+ numberPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj numberConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toString", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj numberPrototypeToString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toLocaleString", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj numberPrototypeToLocaleString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("valueOf", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj numberPrototypeValueOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toFixed", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj numberPrototypeToFixed,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toExponential", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj numberPrototypeToExponential,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toPrecision", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj numberPrototypeToPrecision,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "Number",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just (const $ return (inj (Number 0))),+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ numberPrototypeToString = error "numberPrototypeToString" :: Object+ numberPrototypeToLocaleString = error "numberPrototypeToLocaleString" :: Object+ numberPrototypeValueOf = error "numberPrototypeValueOf" :: Object+ numberPrototypeToFixed = error "numberPrototypeToFixed" :: Object+ numberPrototypeToExponential = error "numberPrototypeToExponential" :: Object+ numberPrototypeToPrecision = error "numberPrototypeToPrecision" :: Object++ objectPrototypeObject = Object 16+ objectPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toString", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectPrototypeToString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toLocaleString", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectPrototypeToLocaleString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("valueOf", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectPrototypeValueOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("hasOwnProperty", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectPrototypeHasOwnProperty,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("isPrototypeOf", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectPrototypeIsPrototypeOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("propertyIsEnumerable", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectPrototypeIsEnumerable,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return JSNull,+ objectInternalClass = "Object",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just (const $ return (inj (Number 0))),+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ objectPrototypeToString = error "objectPrototypeToString" :: Object+ objectPrototypeToLocaleString = error "objectPrototypeToLocaleString" :: Object+ objectPrototypeValueOf = error "objectPrototypeValueOf" :: Object+ objectPrototypeHasOwnProperty = error "objectPrototypeHasOwnProperty" :: Object+ objectPrototypeIsPrototypeOf = error "objectPrototypeIsPrototypeOf" :: Object+ objectPrototypeIsEnumerable = error "objectPrototypeIsEnumerable" :: Object++ regExpPrototypeObject = Object 17+ regExpPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "RegExp",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = stringGetOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Just regExpMatchImpl,+ objectInternalParameterMap = Nothing }++ stringPrototypeObject = Object 18+ stringPrototypeObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("constructor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj stringConstructor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toString", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeToString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("valueOf", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeValueOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("charAt", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeCharAt,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("charCodeAt", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeCharCodeAt,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("concat", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeConcat,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("indexOf", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeIndexOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("lastIndexOf", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeLastIndexOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("localeCompare", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeLocaleCompare,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("match", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeMatch,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("replace", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeReplace,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("search", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeSearch,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("slice", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeSlice,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("split", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeSplit,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("substring", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeSubString,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toLowerCase", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeToLowerCase,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toLocaleLowerCase", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeToLocaleLowerCase,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toUpperCase", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeToUpperCase,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("toLocaleUpperCase", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeToLocaleUpperCase,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("trim", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeTrim,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "String",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = stringGetOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just $ stringPrimitiveValueImpl (inj ""),+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ stringPrototypeToString = error "stringPrototypeToString" :: Object+ stringPrototypeValueOf = error "stringPrototypeValueOf" :: Object+ stringPrototypeCharAt = error "stringPrototypeCharAt" :: Object+ stringPrototypeCharCodeAt = error "stringPrototypeCharCodeAt" :: Object+ stringPrototypeConcat = error "stringPrototypeConcat" :: Object+ stringPrototypeIndexOf = error "stringPrototypeIndexOf" :: Object+ stringPrototypeLastIndexOf = error "stringPrototypeLastIndexOf" :: Object+ stringPrototypeLocaleCompare = error "stringPrototypeLocaleCompare" :: Object+ stringPrototypeMatch = error "stringPrototypeMatch" :: Object+ stringPrototypeReplace = error "stringPrototypeReplace" :: Object+ stringPrototypeSearch = error "stringPrototypeSearch" :: Object+ stringPrototypeSlice = error "stringPrototypeSlice" :: Object+ stringPrototypeSplit = error "stringPrototypeSplit" :: Object+ stringPrototypeSubString = error "stringPrototypeSubString" :: Object+ stringPrototypeToLowerCase = error "stringPrototypeToLowerCase" :: Object+ stringPrototypeToLocaleLowerCase = error "stringPrototypeToLocaleLowerCase" :: Object+ stringPrototypeToUpperCase = error "stringPrototypeToUpperCase" :: Object+ stringPrototypeToLocaleUpperCase = error "stringPrototypeToLocaleUpperCase" :: Object+ stringPrototypeTrim = error "stringPrototypeTrim" :: Object++ throwTypeErrorObject = Object 19+ throwTypeErrorObjectInternal = error "throwTypeErrorObject"++ objectConstructor = Object 20+ objectConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ def {+ dataDescriptorValue = inj (Number 1) })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj objectPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("getPrototypeOf", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorGetPrototypeOf,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("getOwnPropertyDescriptor", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorGetOwnPropertyDescriptor,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("getOwnPropertyNames", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorGetOwnPropertyNames,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("create", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorCreate,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("defineProperty", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorDefineProperty,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("defineProperties", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorDefineProperties,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("seal", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorSeal,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("freeze", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorFreeze,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("preventExtensions", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorPreventExtensions,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("isSealed", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorIsSealed,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("isFrozen", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorIsFrozen,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("isExtensible", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorIsExtensible,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("keys", PropertyData $ DataDescriptor {+ dataDescriptorValue =+ inj objectConstructorKeys,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $+ return (JSExist functionPrototypeObject),+ objectInternalClass = "Object",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just (const $ return (inj (Number 0))),+ objectInternalConstruct = Just objectConstructorConstructImpl,+ objectInternalCall = Just objectConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ objectConstructorGetPrototypeOf = error "objectConstructorGetPrototypeOf" :: Object+ objectConstructorGetOwnPropertyDescriptor = error "objectConstructorGetOwnPropertyDescriptor" :: Object+ objectConstructorGetOwnPropertyNames = error "objectConstructorGetOwnPropertyNames" :: Object+ objectConstructorCreate = error "objectConstructorCreate" :: Object+ objectConstructorDefineProperty = error "objectConstructorDefineProperty" :: Object+ objectConstructorDefineProperties = error "objectConstructorDefineProperties" :: Object+ objectConstructorSeal = error "objectConstructorSeal" :: Object+ objectConstructorFreeze = error "objectConstructorFreeze" :: Object+ objectConstructorPreventExtensions = error "objectConstructorPreventExtensions" :: Object+ objectConstructorIsSealed = error "objectConstructorIsSealed" :: Object+ objectConstructorIsFrozen = error "objectConstructorIsFrozen" :: Object+ objectConstructorIsExtensible = error "objectConstructorIsExtensible" :: Object+ objectConstructorKeys = error "objectConstructorKeys" :: Object++ functionConstructor = Object 21+ functionConstructorInternal :: (Functor m, Monad m) => ObjectInternal m+ functionConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ functionPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }),+ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })],+ objectInternalPrototype = const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "Function",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just functionConstructorConstructImpl,+ objectInternalCall = Just functionConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ arrayConstructor = Object 22+ arrayConstructorInternal :: (Functor m, Monad m) => ObjectInternal m+ arrayConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ arrayPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("isArray", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ arrayConstructorIsArray,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "Function",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just arrayConstructorConstructImpl,+ objectInternalCall = Just arrayConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ arrayConstructorIsArray = error "arrayConstructorIsArray" :: Object++ stringConstructor = Object 23+ stringConstructorInternal :: (Functor m, Monad m) => ObjectInternal m+ stringConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("fromCharCode", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ stringConstructorFromCharCode,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "String",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just stringConstructorConstructImpl,+ objectInternalCall = Just stringConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ stringConstructorFromCharCode = error "stringConstructorFromCharCode" :: Object++ booleanConstructor = Object 24+ booleanConstructorInternal :: (Functor m, Monad m) => ObjectInternal m+ booleanConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ booleanPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "Boolean",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just booleanConstructorConstructImpl,+ objectInternalCall = Just booleanConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ numberConstructor = Object 25+ numberConstructorInternal :: (Functor m, Monad m) => ObjectInternal m+ numberConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ numberPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("MAX_VALUE", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("MIN_VALUE", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("NaN", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("NEGATIVE_INFINITY", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("POSITIVE_INFINITY", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "Number",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just numberConstructorConstructImpl,+ objectInternalCall = Just numberConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ dateConstructor = Object 26+ dateConstructorInternal = error "dateConstructorInternal"++ regExpConstructor = Object 27+ regExpConstructorInternal = error "regExpConstructorInternal"++ errorConstructor = Object 28+ errorConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj errorPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype =+ const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just errorConstructorConstructImpl,+ objectInternalCall = Just errorConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ evalErrorConstructor = Object 29+ evalErrorConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj evalErrorPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype =+ const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "EvalError",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just errorConstructorConstructImpl,+ objectInternalCall = Just errorConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ rangeErrorConstructor = Object 30+ rangeErrorConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj rangeErrorPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype =+ const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "RangeError",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just errorConstructorConstructImpl,+ objectInternalCall = Just errorConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ referenceErrorConstructor = Object 31+ referenceErrorConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj referenceErrorPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype =+ const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "ReferenceError",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just errorConstructorConstructImpl,+ objectInternalCall = Just errorConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ syntaxErrorConstructor = Object 32+ syntaxErrorConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj syntaxErrorPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype =+ const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "SyntaxError",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just errorConstructorConstructImpl,+ objectInternalCall = Just errorConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ typeErrorConstructor = Object 33+ typeErrorConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj typeErrorPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype =+ const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "TypeError",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just errorConstructorConstructImpl,+ objectInternalCall = Just errorConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ uriErrorConstructor = Object 34+ uriErrorConstructorInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj $ Number 1,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("prototype", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj uriErrorPrototypeObject,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype =+ const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "URIError",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just errorConstructorConstructImpl,+ objectInternalCall = Just errorConstructorCallImpl,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ mathObject = Object 35+ mathObjectInternal :: (Functor m, Monad m) => ObjectInternal m+ mathObjectInternal = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("E", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("LN10", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("LN2", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("LOG2E", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("LOG10E", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("PI", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("SQRT1_2", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("SQRT2", PropertyData $ DataDescriptor {+ dataDescriptorValue = undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("abs", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathAbs,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("acos", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathAcos,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("asin", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathAsin,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("atan", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathAtan,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("atan2", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathAtan2,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("ceil", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathCeil,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("cos", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathCos,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("exp", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathExp,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("floor", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathFloor,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("log", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathLog,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("max", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathMax,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("min", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathMin,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("pow", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathPow,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("random", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathRandom,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("round", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathRound,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("sin", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathSin,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("sqrt", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathSqrt,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False })+ , ("tan", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj mathTan,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype = const $ return (JSExist objectPrototypeObject),+ objectInternalClass = "Math",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ mathAbs = error "mathAbs" :: Object+ mathAcos = error "mathAcos" :: Object+ mathAsin = error "mathAsin" :: Object+ mathAtan = error "mathAtan" :: Object+ mathAtan2 = error "mathAtan2" :: Object+ mathCeil = error "mathCeil" :: Object+ mathCos = error "mathCos" :: Object+ mathExp = error "mathExp" :: Object+ mathFloor = error "mathFloor" :: Object+ mathLog = error "mathLog" :: Object+ mathMax = error "mathMax" :: Object+ mathMin = error "mathMin" :: Object+ mathPow = error "mathPow" :: Object+ mathRandom = error "mathRandom" :: Object+ mathRound = error "mathRound" :: Object+ mathSin = error "mathSin" :: Object+ mathSqrt = error "mathSqrt" :: Object+ mathTan = error "mathTan" :: Object++ jsonObject = Object 36+ jsonObjectInternal = error "jsonObjectInternal"++ nextInternalId = 37++ propertyFunctionObject :: (Functor m, Monad m) =>+ InternalCallType m -> Number -> ObjectInternal m+ propertyFunctionObject c l = ObjectInternal {+ objectInternalProperties =+ Map.fromList+ [ ("length", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj l,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ],+ objectInternalPrototype =+ const $ return (JSExist functionPrototypeObject),+ objectInternalClass = "Function",+ objectInternalExtensible = const $ return True,+ objectInternalGet = functionGetImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Just c,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ in+ JavaScriptState {+ javaScriptStateContextStack =+ ctxs,+ javaScriptStateNextInternalId =+ nextInternalId,+ javaScriptStateEnvironmentRecordHeap =+ environmentRecordHeap,+ javaScriptStateDeclarativeEnvironmentRecordHeap =+ declarativeEnvironmentRecordHeap,+ javaScriptStateLexicalEnvironmentHeap =+ lexicalEnvironmentHeap,+ javaScriptStateObjectHeap =+ objectHeap,+ javaScriptStateGlobalLexicalEnvironment =+ globalLexicalEnvironment,+ javaScriptStateGlobalObject =+ globalObject,+ javaScriptStateArrayPrototypeObject =+ arrayPrototypeObject,+ javaScriptStateBooleanPrototypeObject =+ booleanPrototypeObject,+ javaScriptStateDatePrototypeObject =+ datePrototypeObject,+ javaScriptStateErrorPrototypeObject =+ errorPrototypeObject,+ javaScriptStateEvalErrorPrototypeObject =+ evalErrorPrototypeObject,+ javaScriptStateRangeErrorPrototypeObject =+ rangeErrorPrototypeObject,+ javaScriptStateReferenceErrorPrototypeObject =+ referenceErrorPrototypeObject,+ javaScriptStateSyntaxErrorPrototypeObject =+ syntaxErrorPrototypeObject,+ javaScriptStateTypeErrorPrototypeObject =+ typeErrorPrototypeObject,+ javaScriptStateURIErrorPrototypeObject =+ uriErrorPrototypeObject,+ javaScriptStateFunctionPrototypeObject =+ functionPrototypeObject,+ javaScriptStateNumberPrototypeObject =+ numberPrototypeObject,+ javaScriptStateObjectPrototypeObject =+ objectPrototypeObject,+ javaScriptStateRegExpPrototypeObject =+ regExpPrototypeObject,+ javaScriptStateStringPrototypeObject =+ stringPrototypeObject,+ javaScriptStateThrowTypeErrorObject =+ throwTypeErrorObject }++pushContext :: Context -> JavaScriptM ()+pushContext ctx = do+ contextStack %= push+ where+ push :: ContextStack -> ContextStack+ push (ContextStack c cs) = ContextStack ctx (c:cs)++popContext :: JavaScriptM ()+popContext = do+ contextStack %= pop+ where+ pop :: ContextStack -> ContextStack+ pop (ContextStack _ []) = error "Internal error: no context to pop"+ pop (ContextStack _ (c:cs)) = ContextStack c cs++contextStack :: Lens' (JavaScriptState m) ContextStack+contextStack = Lens.lens+ javaScriptStateContextStack+ (\jss cs -> jss { javaScriptStateContextStack = cs })++nextInternalId :: Lens' (JavaScriptState m) InternalId+nextInternalId = Lens.lens+ javaScriptStateNextInternalId+ (\jss noi -> jss { javaScriptStateNextInternalId = noi })++environmentRecordHeap :: Lens' (JavaScriptState m) EnvironmentRecordHeap+environmentRecordHeap =+ Lens.lens+ javaScriptStateEnvironmentRecordHeap+ (\jss erh -> jss { javaScriptStateEnvironmentRecordHeap = erh })++declarativeEnvironmentRecordHeap :: Lens' (JavaScriptState m) DeclarativeEnvironmentRecordHeap+declarativeEnvironmentRecordHeap =+ Lens.lens+ javaScriptStateDeclarativeEnvironmentRecordHeap+ (\jss derh -> jss { javaScriptStateDeclarativeEnvironmentRecordHeap = derh })++lexicalEnvironmentHeap :: Lens' (JavaScriptState m) LexicalEnvironmentHeap+lexicalEnvironmentHeap =+ Lens.lens+ javaScriptStateLexicalEnvironmentHeap+ (\jss lh -> jss { javaScriptStateLexicalEnvironmentHeap = lh })++lexicalEnvironmentInternal :: LexicalEnvironment -> Lens' (JavaScriptState m) LexicalEnvironmentInternal+lexicalEnvironmentInternal i =+ Lens.lens+ (\JavaScriptState {..} ->+ case Map.lookup i javaScriptStateLexicalEnvironmentHeap of+ Nothing -> error "Internal error: can't find lexicalEnvironment environment"+ Just o -> o)+ (\jss@(JavaScriptState {..}) oi ->+ jss { javaScriptStateLexicalEnvironmentHeap = Map.insert i oi javaScriptStateLexicalEnvironmentHeap })++mLexicalEnvironmentInternal :: LexicalEnvironment -> Lens' (JavaScriptState m) (Maybe LexicalEnvironmentInternal)+mLexicalEnvironmentInternal i = lexicalEnvironmentHeap . Lens.at i++objectHeap :: Lens' (JavaScriptState m) (ObjectHeap m)+objectHeap = Lens.lens+ javaScriptStateObjectHeap+ (\jss oh -> jss { javaScriptStateObjectHeap = oh })++internalObject :: Object -> Lens' (JavaScriptState m) (ObjectInternal m)+internalObject i =+ Lens.lens+ (\JavaScriptState {..} ->+ case Map.lookup i javaScriptStateObjectHeap of+ Nothing -> error "Internal error: can't find object"+ Just o -> o)+ (\jss@(JavaScriptState {..}) oi ->+ jss { javaScriptStateObjectHeap = Map.insert i oi javaScriptStateObjectHeap })++mInternalObject :: Object -> Lens' (JavaScriptState m) (Maybe (ObjectInternal m))+mInternalObject i = objectHeap . Lens.at i++globalLexicalEnvironment :: Lens' (JavaScriptState m) LexicalEnvironment+globalLexicalEnvironment =+ Lens.lens+ javaScriptStateGlobalLexicalEnvironment+ (\jss lid -> jss { javaScriptStateGlobalLexicalEnvironment = lid })++globalObject :: Lens' (JavaScriptState m) Object+globalObject =+ Lens.lens+ javaScriptStateGlobalObject+ (\jss oid -> jss { javaScriptStateGlobalObject = oid })++arrayPrototypeObject :: Lens' (JavaScriptState m) Object+arrayPrototypeObject =+ Lens.lens+ javaScriptStateArrayPrototypeObject+ (\jss oid -> jss { javaScriptStateArrayPrototypeObject = oid })++booleanPrototypeObject :: Lens' (JavaScriptState m) Object+booleanPrototypeObject =+ Lens.lens+ javaScriptStateBooleanPrototypeObject+ (\jss oid -> jss { javaScriptStateBooleanPrototypeObject = oid })++datePrototypeObject :: Lens' (JavaScriptState m) Object+datePrototypeObject =+ Lens.lens+ javaScriptStateDatePrototypeObject+ (\jss oid -> jss { javaScriptStateDatePrototypeObject = oid })++errorPrototypeObject :: Lens' (JavaScriptState m) Object+errorPrototypeObject =+ Lens.lens+ javaScriptStateErrorPrototypeObject+ (\jss oid -> jss { javaScriptStateErrorPrototypeObject = oid })++evalErrorPrototypeObject :: Lens' (JavaScriptState m) Object+evalErrorPrototypeObject =+ Lens.lens+ javaScriptStateEvalErrorPrototypeObject+ (\jss oid -> jss { javaScriptStateEvalErrorPrototypeObject = oid })++rangeErrorPrototypeObject :: Lens' (JavaScriptState m) Object+rangeErrorPrototypeObject =+ Lens.lens+ javaScriptStateRangeErrorPrototypeObject+ (\jss oid -> jss { javaScriptStateRangeErrorPrototypeObject = oid })++referenceErrorPrototypeObject :: Lens' (JavaScriptState m) Object+referenceErrorPrototypeObject =+ Lens.lens+ javaScriptStateReferenceErrorPrototypeObject+ (\jss oid -> jss { javaScriptStateReferenceErrorPrototypeObject = oid })++syntaxErrorPrototypeObject :: Lens' (JavaScriptState m) Object+syntaxErrorPrototypeObject =+ Lens.lens+ javaScriptStateSyntaxErrorPrototypeObject+ (\jss oid -> jss { javaScriptStateSyntaxErrorPrototypeObject = oid })++typeErrorPrototypeObject :: Lens' (JavaScriptState m) Object+typeErrorPrototypeObject =+ Lens.lens+ javaScriptStateTypeErrorPrototypeObject+ (\jss oid -> jss { javaScriptStateTypeErrorPrototypeObject = oid })++uriErrorPrototypeObject :: Lens' (JavaScriptState m) Object+uriErrorPrototypeObject =+ Lens.lens+ javaScriptStateURIErrorPrototypeObject+ (\jss oid -> jss { javaScriptStateURIErrorPrototypeObject = oid })++functionPrototypeObject :: Lens' (JavaScriptState m) Object+functionPrototypeObject =+ Lens.lens+ javaScriptStateFunctionPrototypeObject+ (\jss oid -> jss { javaScriptStateFunctionPrototypeObject = oid })++numberPrototypeObject :: Lens' (JavaScriptState m) Object+numberPrototypeObject =+ Lens.lens+ javaScriptStateNumberPrototypeObject+ (\jss oid -> jss { javaScriptStateNumberPrototypeObject = oid })++objectPrototypeObject :: Lens' (JavaScriptState m) Object+objectPrototypeObject =+ Lens.lens+ javaScriptStateObjectPrototypeObject+ (\jss oid -> jss { javaScriptStateObjectPrototypeObject = oid })++regexpPrototypeObject :: Lens' (JavaScriptState m) Object+regexpPrototypeObject =+ Lens.lens+ javaScriptStateRegExpPrototypeObject+ (\jss oid -> jss { javaScriptStateRegExpPrototypeObject = oid })++stringPrototypeObject :: Lens' (JavaScriptState m) Object+stringPrototypeObject =+ Lens.lens+ javaScriptStateStringPrototypeObject+ (\jss oid -> jss { javaScriptStateStringPrototypeObject = oid })++throwTypeErrorObject :: Lens' (JavaScriptState m) Object+throwTypeErrorObject =+ Lens.lens+ javaScriptStateThrowTypeErrorObject+ (\jss oid -> jss { javaScriptStateThrowTypeErrorObject = oid })++type JavaScriptT m = Except.ExceptT Value (State.StateT (JavaScriptState m) m)+type JavaScriptM a = forall m. (Functor m, Monad m) => JavaScriptT m a++runJavaScriptT :: (Functor m, Monad m) =>+ JavaScriptState m ->+ JavaScriptT m a ->+ m (Either Value a)+runJavaScriptT s a = flip State.evalStateT s $ Except.runExceptT a++jsThrow :: (SubType v Value) => v -> JavaScriptM a+jsThrow v = Except.throwE (inj v)++type JSNullable a = a + Null++pattern JSNull = Right Null++pattern JSExist a = Left a++type JSMaybe a = a + Undefined++pattern JSNothing = Right Undefined++pattern JSJust a = Left a++jsMaybe :: b -> (a -> b) -> JSMaybe a -> b+jsMaybe b f ma =+ case ma of+ JSJust a -> f a+ JSNothing -> b+ _ -> b++type Primitive = Null + Undefined + Number + String + Bool++pattern PrimitiveNull a = Left a :: Primitive+pattern PrimitiveUndefined a = Right (Left a) :: Primitive+pattern PrimitiveNumber a = Right (Right (Left a)) :: Primitive+pattern PrimitiveString a = Right (Right (Right (Left a))) :: Primitive+pattern PrimitiveBool a = Right (Right (Right (Right a))) :: Primitive++type Value = Object + Primitive++pattern ValueObject a = Left a :: Value+pattern ValuePrimitive a = Right a :: Value+pattern ValueNull a = Right (PrimitiveNull a) :: Value+pattern ValueUndefined a = Right (PrimitiveUndefined a) :: Value+pattern ValueNumber a = Right (PrimitiveNumber a) :: Value+pattern ValueString a = Right (PrimitiveString a) :: Value+pattern ValueBool a = Right (PrimitiveBool a) :: Value++type CallValue = Reference + Value++pattern CallValueReference a = Left a :: CallValue+pattern CallValueValue a = Right a :: CallValue+pattern CallValueObject a = Right (ValueObject a) :: CallValue+pattern CallValuePrimitive a = Right (ValuePrimitive a) :: CallValue+pattern CallValueNull a = Right (ValueNull a) :: CallValue+pattern CallValueUndefined a = Right (ValueUndefined a) :: CallValue+pattern CallValueNumber a = Right (ValueNumber a) :: CallValue+pattern CallValueString a = Right (ValueString a) :: CallValue+pattern CallValueBool a = Right (ValueBool a) :: CallValue++type Spec a = EnvironmentRecord ++ LexicalEnvironment ++ PropertyIdentifier ++ PropertyDescriptor ++ Completion ++ List a ++ Reference++pattern SpecEnvironmentRecord a = Left a+pattern SpecLexicalEnvironment a = Right (Left a)+pattern SpecPropertyIdentifier a = Right (Right (Left a))+pattern SpecPropertyDescriptor a = Right (Right (Right (Left a)))+pattern SpecCompletion a = Right (Right (Right (Right (Left a))))+pattern SpecList a = Right (Right (Right (Right (Right (Left a)))))+pattern SpecReference a = Right (Right (Right (Right (Right (Right a)))))++type ECMA a = EnvironmentRecord ++ LexicalEnvironment ++ PropertyIdentifier ++ PropertyDescriptor ++ Completion ++ List a ++ Reference ++ Value++pattern ECMAEnvironmentRecord a = Left a+pattern ECMALexicalEnvironment a = Right (Left a)+pattern ECMAPropertyIdentifier a = Right (Right (Left a))+pattern ECMAPropertyDescriptor a = Right (Right (Right (Left a)))+pattern ECMACompletion a = Right (Right (Right (Right (Left a))))+pattern ECMAList a = Right (Right (Right (Right (Right (Left a)))))+pattern ECMAReference a = Right (Right (Right (Right (Right (Right (Left a))))))+pattern ECMAValue a = Right (Right (Right (Right (Right (Right (Right a))))))++data Undefined =+ Undefined+ deriving (Eq, Ord, Show)++data Null+ = Null+ deriving (Eq, Ord, Show)++data Signum+ = SignumPos+ | SignumNeg+ deriving (Eq, Show)++newtype Number+ = Number Double+ deriving (Eq, Floating, Fractional, Num, Ord, Real, RealFloat, RealFrac, Show)++nan :: Number+nan = Number (0 / 0)++posInf :: Number+posInf = Number (1 / 0)++negInf :: Number+negInf = Number ((-1) / 0)++type Base = EnvironmentRecord + Object + Undefined + Number + String + Bool++pattern BaseEnvironmentRecord a = Left a :: Base+pattern BaseObject a = Right (Left a) :: Base+pattern BaseUndefined a = Right (Right (Left a)) :: Base+pattern BaseProperty a = Right (Right (Right a)) :: Base+pattern BaseNumber a = Right (Right (Right (Left a))) :: Base+pattern BaseString a = Right (Right (Right (Right (Left a)))) :: Base+pattern BaseBool a = Right (Right (Right (Right (Right a)))) :: Base++data Reference+ = Reference Base String Bool+ deriving (Eq, Show)++getBase :: Reference -> Base+getBase (Reference base _ _) = base++getReferencedName :: Reference -> String+getReferencedName (Reference _ name _) = name++isStrictReference :: Reference -> Bool+isStrictReference (Reference _ _ strict) = strict++toPrimitiveBase :: Reference ->+ (EnvironmentRecord + Object + Undefined)+ ++ (Number + String + Bool)+toPrimitiveBase (Reference (BaseEnvironmentRecord er) _ _) = Left (inj er)+toPrimitiveBase (Reference (BaseObject o) _ _) = Left (inj o)+toPrimitiveBase (Reference (BaseUndefined u) _ _) = Left (inj u)+toPrimitiveBase (Reference (BaseNumber n) _ _) = Right (inj n)+toPrimitiveBase (Reference (BaseString s) _ _) = Right (inj s)+toPrimitiveBase (Reference (BaseBool b) _ _) = Right (inj b)++isPropertyReference :: Reference -> Bool+isPropertyReference ref =+ case toPropertyReference ref of+ Left _ -> False+ _ -> True++toPropertyReference :: Reference ->+ (EnvironmentRecord + Undefined)+ ++ (Object + Number + String + Bool)+toPropertyReference (Reference (BaseEnvironmentRecord er) _ _) = Left (inj er)+toPropertyReference (Reference (BaseUndefined u) _ _) = Left (inj u)+toPropertyReference (Reference (BaseObject o) _ _) = Right (inj o)+toPropertyReference (Reference (BaseNumber n) _ _) = Right (inj n)+toPropertyReference (Reference (BaseString s) _ _) = Right (inj s)+toPropertyReference (Reference (BaseBool b) _ _) = Right (inj b)++isUnresolvableReference :: Reference -> Bool+isUnresolvableReference ref =+ case toUnresolvableReference ref of+ Left _ -> True+ _ -> False++toUnresolvableReference :: Reference ->+ Undefined+ ++ (EnvironmentRecord + Object + Number + String + Bool)+toUnresolvableReference (Reference (BaseUndefined u) _ _) = Left u+toUnresolvableReference (Reference (BaseEnvironmentRecord er) _ _) = Right (inj er)+toUnresolvableReference (Reference (BaseObject o) _ _) = Right (inj o)+toUnresolvableReference (Reference (BaseProperty p) _ _) = Right (inj p)+toUnresolvableReference (Reference (BaseNumber n) _ _) = Right (inj n)+toUnresolvableReference (Reference (BaseString s) _ _) = Right (inj s)+toUnresolvableReference (Reference (BaseBool b) _ _) = Right (inj b)++newtype List a+ = List [a]+ deriving (Eq, Show)++data CompletionType+ = CompletionTypeNormal+ | CompletionTypeBreak+ | CompletionTypeContinue+ | CompletionTypeReturn+ | CompletionTypeThrow+ deriving (Eq, Show)++data Completion+ = Completion CompletionType (Maybe Value) (Maybe Ident)+ deriving (Eq, Show)++data Type+ = TypeNumber+ | TypeString+ | TypeBoolean+ | TypeUndefined+ | TypeNull+ | TypeObject+ | TypeReference+ | TypeList+ | TypeCompletion+ | TypePropertyDescriptor+ | TypePropertyIdentifier+ | TypeLexicalEnvironment+ | TypeEnvironmentRecord+ deriving (Eq, Show)++typeOf :: forall v a. (SubType v (ECMA a)) => v -> Type+typeOf v =+ case (inj v :: ECMA a) of+ ECMAEnvironmentRecord _ -> TypeEnvironmentRecord+ ECMALexicalEnvironment _ -> TypeLexicalEnvironment+ ECMAPropertyIdentifier _ -> TypePropertyIdentifier+ ECMAPropertyDescriptor _ -> TypePropertyDescriptor+ ECMACompletion _ -> TypeCompletion+ ECMAList _ -> TypeList+ ECMAReference _ -> TypeReference+ ECMAValue (ValueObject _) -> TypeObject+ ECMAValue (ValueNull _) -> TypeNull+ ECMAValue (ValueUndefined _) -> TypeUndefined+ ECMAValue (ValueBool _) -> TypeBoolean+ ECMAValue (ValueString _) -> TypeString+ ECMAValue (ValueNumber _) -> TypeNumber++getValue :: (Functor m, Monad m, SubType v CallValue) =>+ v -> JavaScriptT m Value+getValue sub = do+ case (inj sub :: CallValue) of+ CallValueValue v -> return v+ CallValueReference ref -> do+ let base = getBase ref+ case toUnresolvableReference ref of+ Left _ -> newReferenceErrorObject+ (Just . inj $ getReferencedName ref) >>= jsThrow+ Right resolvableBase -> do+ case resolvableBase of+ Right propertyBase -> do+ case propertyBase of+ Left objectBase -> do+ get objectBase (getReferencedName ref)+ Right primitiveBase -> do+ let p = getReferencedName ref+ o <- toObject (inj primitiveBase)+ mDesc <- getProperty o p+ case mDesc of+ JSNothing -> return $ inj Undefined+ JSJust (PropertyDescriptor {..}) -> do+ case toDataDescriptor mDesc of+ JSJust (DataDescriptor {..}) -> do+ return dataDescriptorValue+ JSNothing ->+ case propertyDescriptorGet of+ Nothing -> return $ inj Undefined+ Just getter -> do+ callNative getter (inj primitiveBase) (List [])+ Left environmentRecordBase -> do+ getBindingValue+ environmentRecordBase+ (getReferencedName ref)+ (isStrictReference ref)++putValue :: (SubType v1 CallValue, SubType v2 Value) =>+ v1 -> v2 -> JavaScriptM ()+putValue rv w = do+ case (inj rv :: CallValue) of+ CallValueValue _ -> newReferenceErrorObject Nothing >>= jsThrow+ CallValueReference ref -> do+ let base = getBase ref+ case toUnresolvableReference ref of+ Left _ -> do+ if isStrictReference ref+ then newReferenceErrorObject+ (Just . inj $ getReferencedName ref) >>= jsThrow+ else do+ global <- Lens.use globalObject+ put global (getReferencedName ref) (inj w) False+ Right resolvableBase -> do+ case resolvableBase of+ Right propertyBase -> do+ case propertyBase of+ Left objectBase -> do+ put objectBase (getReferencedName ref) (inj w) (isStrictReference ref)+ Right primitiveBase -> do+ let p = getReferencedName ref+ throw = isStrictReference ref+ o <- toObject (inj primitiveBase)+ c <- canPut o p+ if not c+ then do+ if throw+ then newTypeErrorObject Nothing >>= jsThrow+ else return ()+ else do+ ownDesc <- getOwnProperty o p+ if isDataDescriptor ownDesc+ then+ if throw+ then newTypeErrorObject Nothing >>= jsThrow+ else return ()+ else do+ desc <- getProperty o p+ case toAccessorDescriptor desc of+ JSJust (AccessorDescriptor {..}) -> do+ let JSJust setter = accessorDescriptorSet+ call setter (inj primitiveBase) (List [(inj w)])+ return ()+ JSNothing -> do+ if throw+ then newTypeErrorObject Nothing >>= jsThrow+ else return ()+ Left environmentRecordBase -> do+ setMutableBinding+ environmentRecordBase+ (getReferencedName ref)+ (inj w)+ (isStrictReference ref)++data Property+ = PropertyData DataDescriptor+ | PropertyAccessor AccessorDescriptor+ deriving (Eq, Show)++data DataDescriptor+ = DataDescriptor+ { dataDescriptorValue :: Value+ , dataDescriptorWritable :: Bool+ , dataDescriptorEnumerable :: Bool+ , dataDescriptorConfigurable :: Bool }+ deriving (Eq, Show)++instance Default DataDescriptor where+ def = DataDescriptor {+ dataDescriptorValue = inj Undefined,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }++data AccessorDescriptor+ = AccessorDescriptor+ { accessorDescriptorGet :: JSMaybe Object+ , accessorDescriptorSet :: JSMaybe Object+ , accessorDescriptorEnumerable :: Bool+ , accessorDescriptorConfigurable :: Bool }+ deriving (Eq, Show)++instance Default AccessorDescriptor where+ def = AccessorDescriptor {+ accessorDescriptorGet = JSNothing,+ accessorDescriptorSet = JSNothing,+ accessorDescriptorEnumerable = False,+ accessorDescriptorConfigurable = False }++data PropertyIdentifier+ = PropertyIdentifier String PropertyDescriptor++data PropertyDescriptor+ = PropertyDescriptor+ { propertyDescriptorValue :: Maybe Value+ , propertyDescriptorGet :: Maybe Object+ , propertyDescriptorSet :: Maybe Object+ , propertyDescriptorWritable :: Maybe Bool+ , propertyDescriptorEnumerable :: Maybe Bool+ , propertyDescriptorConfigurable :: Maybe Bool }+ deriving (Eq, Show)++instance Default PropertyDescriptor where+ def = PropertyDescriptor {+ propertyDescriptorValue = Nothing,+ propertyDescriptorGet = Nothing,+ propertyDescriptorSet = Nothing,+ propertyDescriptorWritable = Nothing,+ propertyDescriptorEnumerable = Nothing,+ propertyDescriptorConfigurable = Nothing }++isAccessorDescriptor :: JSMaybe PropertyDescriptor -> Bool+isAccessorDescriptor mp =+ case mp of+ JSJust PropertyDescriptor {..} ->+ isJust propertyDescriptorGet || isJust propertyDescriptorSet+ _ -> False++toAccessorDescriptor :: JSMaybe PropertyDescriptor -> JSMaybe AccessorDescriptor+toAccessorDescriptor mp =+ case mp of+ JSNothing -> JSNothing+ JSJust p@(PropertyDescriptor {..}) ->+ if isAccessorDescriptor mp+ then JSJust $ AccessorDescriptor {+ accessorDescriptorGet = maybe JSNothing JSJust propertyDescriptorGet,+ accessorDescriptorSet = maybe JSNothing JSJust propertyDescriptorSet,+ accessorDescriptorEnumerable = maybe False id propertyDescriptorEnumerable,+ accessorDescriptorConfigurable = maybe False id propertyDescriptorConfigurable }+ else JSNothing++fromAccessorDescriptor :: AccessorDescriptor -> PropertyDescriptor+fromAccessorDescriptor AccessorDescriptor {..} =+ PropertyDescriptor {+ propertyDescriptorValue = Nothing,+ propertyDescriptorGet = jsMaybe Nothing Just accessorDescriptorGet,+ propertyDescriptorSet = jsMaybe Nothing Just accessorDescriptorSet,+ propertyDescriptorWritable = Nothing,+ propertyDescriptorEnumerable = Just accessorDescriptorEnumerable,+ propertyDescriptorConfigurable = Just accessorDescriptorConfigurable }++isDataDescriptor :: JSMaybe PropertyDescriptor -> Bool+isDataDescriptor mp =+ case mp of+ JSJust (PropertyDescriptor {..}) ->+ isJust propertyDescriptorValue || isJust propertyDescriptorWritable+ JSNothing -> False++toDataDescriptor :: JSMaybe PropertyDescriptor -> JSMaybe DataDescriptor+toDataDescriptor mp =+ case mp of+ JSNothing -> JSNothing+ JSJust p@(PropertyDescriptor {..}) ->+ if isDataDescriptor mp+ then JSJust $ DataDescriptor {+ dataDescriptorValue = maybe (inj Undefined) id propertyDescriptorValue,+ dataDescriptorWritable = maybe False id propertyDescriptorWritable,+ dataDescriptorEnumerable = maybe False id propertyDescriptorEnumerable,+ dataDescriptorConfigurable = maybe False id propertyDescriptorConfigurable }+ else JSNothing++fromDataDescriptor :: DataDescriptor -> PropertyDescriptor+fromDataDescriptor DataDescriptor {..} =+ PropertyDescriptor {+ propertyDescriptorValue = Just dataDescriptorValue,+ propertyDescriptorGet = Nothing,+ propertyDescriptorSet = Nothing,+ propertyDescriptorWritable = Just dataDescriptorWritable,+ propertyDescriptorEnumerable = Just dataDescriptorEnumerable,+ propertyDescriptorConfigurable = Just dataDescriptorConfigurable }++isGenericDescriptor :: JSMaybe PropertyDescriptor -> Bool+isGenericDescriptor desc =+ not $ isAccessorDescriptor desc || isDataDescriptor desc++fromPropertyDescriptor :: JSMaybe PropertyDescriptor -> JavaScriptM (JSMaybe Object)+fromPropertyDescriptor mdesc = do+ o <- newObjectObject Nothing+ case mdesc of+ JSNothing -> return JSNothing+ JSJust desc@(PropertyDescriptor {..}) -> do+ if isDataDescriptor mdesc+ then do+ defineOwnProperty+ o+ "value"+ def {+ propertyDescriptorValue = propertyDescriptorValue,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ False+ defineOwnProperty+ o+ "writable"+ def {+ propertyDescriptorValue = inj <$> propertyDescriptorWritable,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ False+ else do+ defineOwnProperty+ o+ "get"+ def {+ propertyDescriptorValue = inj <$> propertyDescriptorGet,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ False+ defineOwnProperty+ o+ "set"+ def {+ propertyDescriptorValue = inj <$> propertyDescriptorSet,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ False+ return $ JSJust o++data LexicalEnvironment+ = LexicalEnvironment InternalId+ deriving (Eq, Ord, Show)++data LexicalEnvironmentInternal+ = LexicalEnvironmentInternal EnvironmentRecord (Maybe LexicalEnvironment)+ deriving (Eq, Show)++environmentRecord :: Lens' LexicalEnvironmentInternal EnvironmentRecord+environmentRecord =+ Lens.lens+ (\(LexicalEnvironmentInternal er _) -> er)+ (\(LexicalEnvironmentInternal _ mc) er -> LexicalEnvironmentInternal er mc)++getIdentifierReference :: Maybe LexicalEnvironment -> String -> Bool ->+ JavaScriptM Reference+getIdentifierReference mLex name strict = do+ case mLex of+ Nothing ->+ return $ Reference (inj Undefined) name strict+ Just lex -> do+ LexicalEnvironmentInternal envRec outer <- Lens.use $ lexicalEnvironmentInternal lex+ exists <- hasBinding envRec name+ if exists+ then return $ Reference (inj envRec) name strict+ else getIdentifierReference outer name strict++newDeclarativeEnvironment :: Maybe LexicalEnvironment ->+ JavaScriptM LexicalEnvironment+newDeclarativeEnvironment e = do+ ier <- createNextInternalId+ ider <- createNextInternalId+ ile <- createNextInternalId+ let decEnvRecInternal+ = DeclarativeEnvironmentRecordInternal {+ declarativeEnvironmentRecordInternalBindings = Map.empty }+ decEnvRec = DeclarativeEnvironmentRecord ider+ envrecInternal+ = EnvironmentRecordInternalDeclarative decEnvRec+ envrec = EnvironmentRecord ier+ envInternal = LexicalEnvironmentInternal envrec e+ env = LexicalEnvironment ile+ mEnvironmentRecordInternal envrec ?= envrecInternal+ mDeclarativeEnvironmentRecordInternal decEnvRec ?= decEnvRecInternal+ mLexicalEnvironmentInternal env ?= envInternal+ return env++newObjectObjectEnvironment :: Object -> Maybe LexicalEnvironment -> JavaScriptM LexicalEnvironment+newObjectObjectEnvironment o e = do+ ier <- createNextInternalId+ ile <- createNextInternalId+ let envrecInternal = EnvironmentRecordInternalObject (ObjectEnvironmentRecord o False)+ envrec = EnvironmentRecord ier+ envInternal = LexicalEnvironmentInternal envrec e+ env = LexicalEnvironment ile+ mEnvironmentRecordInternal envrec ?= envrecInternal+ mLexicalEnvironmentInternal env ?= envInternal+ return env++enterGlobalContext :: Program -> JavaScriptM ()+enterGlobalContext program = do+ global <- Lens.use globalObject+ globalEnvironment <- Lens.use globalLexicalEnvironment+ contextStack . currentContext . variableEnvironment .= globalEnvironment+ contextStack . currentContext . lexicalEnvironment .= globalEnvironment+ contextStack . currentContext . thisBinding .= (inj global)+ declarationBindingInstantiation (CodeGlobal program)++enterEvalContext :: JavaScriptM ()+enterEvalContext = error "enterEvalContext"++enterFunctionContext :: Object -> Value -> List Value -> JavaScriptM ()+enterFunctionContext f thisArg args = do+ let strict = False+ thisBinding <-+ if strict+ then return thisArg+ else+ case thisArg of+ ValueNull _ -> do+ global <- Lens.use globalObject+ return (inj global)+ ValueUndefined _ -> do+ global <- Lens.use globalObject+ return (inj global)+ _ -> do+ obj <- toObject thisArg+ return (inj obj)+ lex <- scope f+ localEnv <- newDeclarativeEnvironment (Just lex)+ let ctx = Context {+ contextLexicalEnvironment = localEnv,+ contextVariableEnvironment = localEnv,+ contextThisBinding = thisBinding,+ contextLabels = [] }+ pushContext ctx+ declarationBindingInstantiation (CodeFunction f args)++data EnvironmentRecord+ = EnvironmentRecord InternalId+ deriving (Eq, Ord, Show)++data EnvironmentRecordInternal+ = EnvironmentRecordInternalDeclarative DeclarativeEnvironmentRecord+ | EnvironmentRecordInternalObject ObjectEnvironmentRecord+ deriving (Eq, Show)++environmentRecordInternal :: EnvironmentRecord ->+ Lens' (JavaScriptState m) EnvironmentRecordInternal+environmentRecordInternal i =+ Lens.lens+ (\JavaScriptState {..} ->+ case Map.lookup i javaScriptStateEnvironmentRecordHeap of+ Nothing -> error "Internal error: can't find environmentRecord"+ Just o -> o)+ (\jss@(JavaScriptState {..}) oi ->+ jss { javaScriptStateEnvironmentRecordHeap = Map.insert i oi javaScriptStateEnvironmentRecordHeap })++mEnvironmentRecordInternal :: EnvironmentRecord -> Lens' (JavaScriptState m) (Maybe EnvironmentRecordInternal)+mEnvironmentRecordInternal i = environmentRecordHeap . Lens.at i++declarativeEnvironmentRecord :: Lens'+ EnvironmentRecordInternal+ DeclarativeEnvironmentRecord+declarativeEnvironmentRecord =+ Lens.lens+ (\eri -> case eri of+ EnvironmentRecordInternalDeclarative der -> der+ _ -> error "Not a declarative environment record")+ (\eri der -> case eri of+ EnvironmentRecordInternalDeclarative _ ->+ EnvironmentRecordInternalDeclarative der+ _ -> error "Not a declarative environment record")++objectEnvironmentRecord :: Lens'+ EnvironmentRecordInternal+ ObjectEnvironmentRecord+objectEnvironmentRecord =+ Lens.lens+ (\eri -> case eri of+ EnvironmentRecordInternalObject der -> der+ _ -> error "Not a object environment record")+ (\eri der -> case eri of+ EnvironmentRecordInternalObject _ ->+ EnvironmentRecordInternalObject der+ _ -> error "Not a object environment record")++data DeclarativeEnvironmentRecord+ = DeclarativeEnvironmentRecord InternalId+ deriving (Eq, Ord, Show)++data DeclarativeBinding+ = DeclarativeBindingMutable+ { declarativeBindingMutableValue :: Value+ , declarativeBindingMutableDelete :: Bool }+ | DeclarativeBindingImmutable+ { declarativeBindingImmutableValue :: Value+ , declarativeBindingImmutableInitialised :: Bool }+ deriving (Eq, Show)++data DeclarativeEnvironmentRecordInternal+ = DeclarativeEnvironmentRecordInternal+ { declarativeEnvironmentRecordInternalBindings+ :: Map String DeclarativeBinding }++internalDeclarativeEnvironmentRecordBindings+ :: Lens'+ DeclarativeEnvironmentRecordInternal+ (Map String DeclarativeBinding)+internalDeclarativeEnvironmentRecordBindings =+ Lens.lens+ declarativeEnvironmentRecordInternalBindings+ (\deri bs ->+ deri { declarativeEnvironmentRecordInternalBindings = bs })++internalDeclarativeEnvironmentRecordBinding+ :: String ->+ Lens'+ DeclarativeEnvironmentRecordInternal+ (Maybe DeclarativeBinding)+internalDeclarativeEnvironmentRecordBinding n =+ internalDeclarativeEnvironmentRecordBindings . Lens.at n++declarativeEnvironmentRecordInternal+ :: DeclarativeEnvironmentRecord ->+ Lens' (JavaScriptState m) DeclarativeEnvironmentRecordInternal+declarativeEnvironmentRecordInternal i =+ Lens.lens+ (\JavaScriptState {..} ->+ case Map.lookup i javaScriptStateDeclarativeEnvironmentRecordHeap of+ Nothing -> error "Internal error: can't find declarativeEnvironmentRecord"+ Just o -> o)+ (\jss@(JavaScriptState {..}) oi ->+ jss { javaScriptStateDeclarativeEnvironmentRecordHeap =+ Map.insert i oi javaScriptStateDeclarativeEnvironmentRecordHeap })++mDeclarativeEnvironmentRecordInternal :: DeclarativeEnvironmentRecord -> Lens' (JavaScriptState m) (Maybe DeclarativeEnvironmentRecordInternal)+mDeclarativeEnvironmentRecordInternal i =+ declarativeEnvironmentRecordHeap . Lens.at i++data ObjectEnvironmentRecord+ = ObjectEnvironmentRecord+ { objectEnvironmentRecordBindingObject :: Object+ , objectEnvironmentRecordProvideThis :: Bool }+ deriving (Eq, Show)++hasBinding :: EnvironmentRecord -> String -> JavaScriptM Bool+hasBinding er n = do+ eri <- Lens.use $ environmentRecordInternal er+ case eri of+ EnvironmentRecordInternalDeclarative der ->+ hasBindingDeclarative der n+ EnvironmentRecordInternalObject oer ->+ hasBindingObject oer n++hasBindingDeclarative :: DeclarativeEnvironmentRecord ->+ String -> JavaScriptM Bool+hasBindingDeclarative envRec n = do+ deri <- Lens.use $ declarativeEnvironmentRecordInternal envRec+ let bindings = declarativeEnvironmentRecordInternalBindings deri+ return $ Map.member n bindings++hasBindingObject :: ObjectEnvironmentRecord ->+ String -> JavaScriptM Bool+hasBindingObject envRec n = do+ let bindings = objectEnvironmentRecordBindingObject envRec+ hasProperty bindings n++createMutableBinding :: EnvironmentRecord -> String -> Maybe Bool -> JavaScriptM ()+createMutableBinding er n d = do+ eri <- Lens.use $ environmentRecordInternal er+ case eri of+ EnvironmentRecordInternalDeclarative der ->+ createMutableBindingDeclarative der n d+ EnvironmentRecordInternalObject oer ->+ createMutableBindingObject oer n d++createMutableBindingDeclarative :: DeclarativeEnvironmentRecord ->+ String -> Maybe Bool -> JavaScriptM ()+createMutableBindingDeclarative envRec n d = do+ let markDel = maybe False id d+ binding = DeclarativeBindingMutable (inj Undefined) markDel+ declarativeEnvironmentRecordInternal envRec .+ internalDeclarativeEnvironmentRecordBinding n ?= binding++createMutableBindingObject :: ObjectEnvironmentRecord ->+ String -> Maybe Bool -> JavaScriptM ()+createMutableBindingObject envRec n d = do+ let bindings = objectEnvironmentRecordBindingObject envRec+ configValue = if d == Just True then True else False+ desc = def {+ propertyDescriptorValue = Just (inj Undefined),+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just configValue }+ defineOwnProperty bindings n desc True+ return ()++setMutableBinding :: EnvironmentRecord -> String -> Value -> Bool -> JavaScriptM ()+setMutableBinding er n v s = do+ eri <- Lens.use $ environmentRecordInternal er+ case eri of+ EnvironmentRecordInternalDeclarative der ->+ setMutableBindingDeclarative der n v s+ EnvironmentRecordInternalObject oer ->+ setMutableBindingObject oer n v s++setMutableBindingDeclarative :: DeclarativeEnvironmentRecord ->+ String -> Value -> Bool -> JavaScriptM ()+setMutableBindingDeclarative envRec n v s = do+ binding <- Lens.use $ declarativeEnvironmentRecordInternal envRec .+ internalDeclarativeEnvironmentRecordBinding n+ case binding of+ Nothing -> error "Internal error: setMutableBindingDeclarative assert failed"+ Just (DeclarativeBindingMutable _ d) -> do+ let binding = DeclarativeBindingMutable v d+ declarativeEnvironmentRecordInternal envRec .+ internalDeclarativeEnvironmentRecordBinding n ?= binding+ Just (DeclarativeBindingImmutable {}) ->+ if s+ then newTypeErrorObject Nothing >>= jsThrow+ else return ()++setMutableBindingObject :: ObjectEnvironmentRecord ->+ String -> Value -> Bool -> JavaScriptM ()+setMutableBindingObject envRec n v s = do+ let bindings = objectEnvironmentRecordBindingObject envRec+ put bindings n v s++getBindingValue :: EnvironmentRecord -> String -> Bool -> JavaScriptM Value+getBindingValue er n s = do+ eri <- Lens.use $ environmentRecordInternal er+ case eri of+ EnvironmentRecordInternalDeclarative der ->+ getBindingValueDeclarative der n s+ EnvironmentRecordInternalObject oer ->+ getBindingValueObject oer n s++getBindingValueDeclarative :: DeclarativeEnvironmentRecord ->+ String -> Bool -> JavaScriptM Value+getBindingValueDeclarative envRec n s = do+ binding <- Lens.use $ declarativeEnvironmentRecordInternal envRec .+ internalDeclarativeEnvironmentRecordBinding n+ case binding of+ Nothing -> error "Internal error: getBindingValueDeclarative assert failed"+ Just (DeclarativeBindingImmutable v False) ->+ if not s+ then return (inj Undefined)+ else newReferenceErrorObject (Just . inj $ s) >>= jsThrow+ Just (DeclarativeBindingImmutable v _) -> return v+ Just (DeclarativeBindingMutable v _) -> return v++getBindingValueObject :: ObjectEnvironmentRecord ->+ String -> Bool -> JavaScriptM Value+getBindingValueObject envRec n s = do+ let bindings = objectEnvironmentRecordBindingObject envRec+ value <- hasProperty bindings n+ if not value+ then do+ if not s+ then return (inj Undefined)+ else newReferenceErrorObject (Just . inj $ s) >>= jsThrow+ else get bindings n++deleteBinding :: EnvironmentRecord -> String -> JavaScriptM Bool+deleteBinding er n = do+ eri <- Lens.use $ environmentRecordInternal er+ case eri of+ EnvironmentRecordInternalDeclarative der ->+ deleteBindingDeclarative der n+ EnvironmentRecordInternalObject oer ->+ deleteBindingObject oer n++deleteBindingDeclarative :: DeclarativeEnvironmentRecord ->+ String -> JavaScriptM Bool+deleteBindingDeclarative envRec n = do+ binding <- Lens.use $ declarativeEnvironmentRecordInternal envRec .+ internalDeclarativeEnvironmentRecordBinding n+ case binding of+ Nothing -> return True+ Just (DeclarativeBindingMutable _ True) -> do+ declarativeEnvironmentRecordInternal envRec .+ internalDeclarativeEnvironmentRecordBinding n .= Nothing+ return True+ _ -> return False++deleteBindingObject :: ObjectEnvironmentRecord ->+ String -> JavaScriptM Bool+deleteBindingObject envRec n = do+ let bindings = objectEnvironmentRecordBindingObject envRec+ delete bindings n False++implicitThisValue :: EnvironmentRecord -> JavaScriptM Value+implicitThisValue er = do+ eri <- Lens.use $ environmentRecordInternal er+ case eri of+ EnvironmentRecordInternalDeclarative der ->+ implicitThisValueDeclarative der+ EnvironmentRecordInternalObject oer ->+ implicitThisValueObject oer++implicitThisValueDeclarative :: DeclarativeEnvironmentRecord ->+ JavaScriptM Value+implicitThisValueDeclarative _ = return (inj Undefined)++implicitThisValueObject :: ObjectEnvironmentRecord ->+ JavaScriptM Value+implicitThisValueObject envRec = do+ if objectEnvironmentRecordProvideThis envRec+ then return $ inj $ objectEnvironmentRecordBindingObject envRec+ else return $ inj Undefined++createImmutableBindingDeclarative :: DeclarativeEnvironmentRecord ->+ String ->+ JavaScriptM ()+createImmutableBindingDeclarative envRec n = do+ let binding = DeclarativeBindingImmutable (inj Undefined) False+ declarativeEnvironmentRecordInternal envRec .+ internalDeclarativeEnvironmentRecordBinding n ?= binding++initializeImmutableBindingDeclarative :: DeclarativeEnvironmentRecord ->+ String ->+ Value ->+ JavaScriptM ()+initializeImmutableBindingDeclarative envRec n v = do+ let binding = DeclarativeBindingImmutable v True+ declarativeEnvironmentRecordInternal envRec .+ internalDeclarativeEnvironmentRecordBinding n ?= binding++data MatchResult+ = MatchResult++type InternalId = Int++data Object+ = Object InternalId+ deriving (Eq, Ord, Show)++type InternalPropertiesType = Map String Property+type InternalPrototypeType m = Object -> JavaScriptT m (JSNullable Object)+type InternalClassType = String+type InternalExtensibleType m = Object -> JavaScriptT m Bool+type InternalGetType m = Object -> String -> JavaScriptT m Value+type InternalGetOwnPropertyType m = Object -> String -> JavaScriptT m (JSMaybe PropertyDescriptor)+type InternalGetPropertyType m = Object -> String -> JavaScriptT m (JSMaybe PropertyDescriptor)+type InternalPutType m = Object -> String -> Value -> Bool -> JavaScriptT m ()+type InternalCanPutType m = Object -> String -> JavaScriptT m Bool+type InternalHasPropertyType m = Object -> String -> JavaScriptT m Bool+type InternalDeleteType m = Object -> String -> Bool -> JavaScriptT m Bool+type InternalDefaultValueType m = Object -> Maybe Hint -> JavaScriptT m Primitive+type InternalDefineOwnPropertyType m = Object -> String -> PropertyDescriptor -> Bool -> JavaScriptT m Bool+type InternalPrimitiveValueType m = Object -> JavaScriptT m Primitive+type InternalConstructType m = Object -> List Value -> JavaScriptT m Object+type InternalCallType m = Object -> Value -> List Value -> JavaScriptT m CallValue+type InternalCallNativeType m = Object -> Value -> List Value -> JavaScriptT m Value+type InternalHasInstanceType m = Object -> Value -> JavaScriptT m Bool+type InternalScopeType m = Object -> JavaScriptT m LexicalEnvironment+type InternalFormalParametersType m = Object -> JavaScriptT m (List String)+type InternalCodeType m = Object -> JavaScriptT m FuncBody+type InternalTargetFunctionType m = Object -> JavaScriptT m Object+type InternalBoundThisType m = Object -> JavaScriptT m Value+type InternalBoundArgumentsType m = Object -> JavaScriptT m (List Value)+type InternalMatchType m = Object -> String -> Int -> JavaScriptT m MatchResult+type InternalParameterMapType m = Object -> JavaScriptT m Object++data ObjectInternal m =+ ObjectInternal+ { objectInternalProperties :: InternalPropertiesType+ , objectInternalPrototype :: InternalPrototypeType m+ , objectInternalClass :: InternalClassType+ , objectInternalExtensible :: InternalExtensibleType m+ , objectInternalGet :: InternalGetType m+ , objectInternalGetOwnProperty :: InternalGetOwnPropertyType m+ , objectInternalGetProperty :: InternalGetPropertyType m+ , objectInternalPut :: InternalPutType m+ , objectInternalCanPut :: InternalCanPutType m+ , objectInternalHasProperty :: InternalHasPropertyType m+ , objectInternalDelete :: InternalDeleteType m+ , objectInternalDefaultValue :: InternalDefaultValueType m+ , objectInternalDefineOwnProperty :: InternalDefineOwnPropertyType m+ , objectInternalPrimitiveValue :: Maybe (InternalPrimitiveValueType m)+ , objectInternalConstruct :: Maybe (InternalConstructType m)+ , objectInternalCall :: Maybe (InternalCallType m)+ , objectInternalHasInstance :: Maybe (InternalHasInstanceType m)+ , objectInternalScope :: Maybe (InternalScopeType m)+ , objectInternalFormalParameters :: Maybe (InternalFormalParametersType m)+ , objectInternalCode :: Maybe (InternalCodeType m)+ , objectInternalTargetFunction :: Maybe (InternalTargetFunctionType m)+ , objectInternalBoundThis :: Maybe (InternalBoundThisType m)+ , objectInternalBoundArguments :: Maybe (InternalBoundArgumentsType m)+ , objectInternalMatch :: Maybe (InternalMatchType m)+ , objectInternalParameterMap :: Maybe (InternalParameterMapType m) }++internalProperties :: Lens' (ObjectInternal m) InternalPropertiesType+internalProperties =+ Lens.lens+ objectInternalProperties+ (\oi ps -> oi { objectInternalProperties = ps })++internalProperty :: String -> Lens' (ObjectInternal m) (Maybe Property)+internalProperty p = internalProperties . Lens.at p++properties :: Object -> Lens' (JavaScriptState m) InternalPropertiesType+properties o = internalObject o . internalProperties++property :: Object -> String -> Lens' (JavaScriptState m) (Maybe Property)+property o p = internalObject o . internalProperty p++internalPrototype :: Lens' (ObjectInternal m) (InternalPrototypeType m)+internalPrototype =+ Lens.lens+ objectInternalPrototype+ (\oi p -> oi { objectInternalPrototype = p })++prototype :: (Functor m, Monad m) => InternalPrototypeType m+prototype o = callInternalProperty o objectInternalPrototype++internalClass :: Lens' (ObjectInternal m) InternalClassType+internalClass =+ Lens.lens+ objectInternalClass+ (\oi c -> oi { objectInternalClass = c })++class' :: Object -> Lens' (JavaScriptState m) InternalClassType+class' o = internalObject o . internalClass++internalExtensible :: Lens' (ObjectInternal m) (InternalExtensibleType m)+internalExtensible =+ Lens.lens+ objectInternalExtensible+ (\oi e -> oi { objectInternalExtensible = e })++extensible :: (Functor m, Monad m) => InternalExtensibleType m+extensible o = callInternalProperty o objectInternalExtensible++internalGet :: Lens' (ObjectInternal m) (InternalGetType m)+internalGet =+ Lens.lens+ objectInternalGet+ (\oi g -> oi { objectInternalGet = g })++get :: (Functor m, Monad m) => InternalGetType m+get o = callInternalProperty1 o objectInternalGet++internalGetOwnProperty :: Lens' (ObjectInternal m) (InternalGetOwnPropertyType m)+internalGetOwnProperty =+ Lens.lens+ objectInternalGetOwnProperty+ (\oi gop -> oi { objectInternalGetOwnProperty = gop })++getOwnProperty :: (Functor m, Monad m) => InternalGetOwnPropertyType m+getOwnProperty o = callInternalProperty1 o objectInternalGetOwnProperty++internalGetProperty :: Lens' (ObjectInternal m) (InternalGetPropertyType m)+internalGetProperty =+ Lens.lens+ objectInternalGetProperty+ (\oi gp -> oi { objectInternalGetProperty = gp })++getProperty :: (Functor m, Monad m) => InternalGetPropertyType m+getProperty o = callInternalProperty1 o objectInternalGetProperty++internalPut :: Lens' (ObjectInternal m) (InternalPutType m)+internalPut =+ Lens.lens+ objectInternalPut+ (\oi p -> oi { objectInternalPut = p })++put :: (Functor m, Monad m) => InternalPutType m+put o = callInternalProperty3 o objectInternalPut++internalCanPut :: Lens' (ObjectInternal m) (InternalCanPutType m)+internalCanPut =+ Lens.lens+ objectInternalCanPut+ (\oi cp -> oi { objectInternalCanPut = cp })++canPut :: (Functor m, Monad m) => InternalCanPutType m+canPut o = callInternalProperty1 o objectInternalCanPut++internalHasProperty :: Lens' (ObjectInternal m) (InternalHasPropertyType m)+internalHasProperty =+ Lens.lens+ objectInternalHasProperty+ (\oi hp -> oi { objectInternalHasProperty = hp })++hasProperty :: (Functor m, Monad m) => InternalHasPropertyType m+hasProperty o = callInternalProperty1 o objectInternalHasProperty++internalDelete :: Lens' (ObjectInternal m) (InternalDeleteType m)+internalDelete =+ Lens.lens+ objectInternalDelete+ (\oi d -> oi { objectInternalDelete = d })++delete :: (Functor m, Monad m) => InternalDeleteType m+delete o = callInternalProperty2 o objectInternalDelete++internalDefaultValue :: Lens' (ObjectInternal m) (InternalDefaultValueType m)+internalDefaultValue =+ Lens.lens+ objectInternalDefaultValue+ (\oi dv -> oi { objectInternalDefaultValue = dv })++defaultValue :: (Functor m, Monad m) => InternalDefaultValueType m+defaultValue o = callInternalProperty1 o objectInternalDefaultValue++internalDefineOwnProperty :: Lens' (ObjectInternal m) (InternalDefineOwnPropertyType m)+internalDefineOwnProperty =+ Lens.lens+ objectInternalDefineOwnProperty+ (\oi dop -> oi { objectInternalDefineOwnProperty = dop })++defineOwnProperty :: (Functor m, Monad m) => InternalDefineOwnPropertyType m+defineOwnProperty o = callInternalProperty3 o objectInternalDefineOwnProperty++internalPrimitiveValue :: Lens' (ObjectInternal m) (Maybe (InternalPrimitiveValueType m))+internalPrimitiveValue =+ Lens.lens+ objectInternalPrimitiveValue+ (\oi mpv -> oi { objectInternalPrimitiveValue = mpv })++primitiveValue :: (Functor m, Monad m) => InternalPrimitiveValueType m+primitiveValue o = callInternalOptionalProperty o objectInternalPrimitiveValue++internalConstruct :: Lens' (ObjectInternal m) (Maybe (InternalConstructType m))+internalConstruct =+ Lens.lens+ objectInternalConstruct+ (\oi c -> oi { objectInternalConstruct = c })++construct :: (Functor m, Monad m) => InternalConstructType m+construct o = callInternalOptionalProperty1 o objectInternalConstruct++internalCall :: Lens' (ObjectInternal m) (Maybe (InternalCallType m))+internalCall =+ Lens.lens+ objectInternalCall+ (\oi c -> oi { objectInternalCall = c })++call :: (Functor m, Monad m) => InternalCallType m+call o = callInternalOptionalProperty2 o objectInternalCall++callNative :: (Functor m, Monad m) => InternalCallNativeType m+callNative o t l = do+ rv <- callInternalOptionalProperty2 o objectInternalCall t l+ case prj rv of+ Nothing -> error "Native function can't return references"+ Just v -> return v++hasInstance :: (Functor m, Monad m) => InternalHasInstanceType m+hasInstance o = callInternalOptionalProperty1 o objectInternalHasInstance++internalHasInstance :: Lens' (ObjectInternal m) (Maybe (InternalHasInstanceType m))+internalHasInstance =+ Lens.lens+ objectInternalHasInstance+ (\oi hi -> oi { objectInternalHasInstance = hi })++scope :: (Functor m, Monad m) => InternalScopeType m+scope o = callInternalOptionalProperty o objectInternalScope++internalScope :: Lens' (ObjectInternal m) (Maybe (InternalScopeType m))+internalScope =+ Lens.lens+ objectInternalScope+ (\oi s -> oi { objectInternalScope = s })++formalParameters :: (Functor m, Monad m) => InternalFormalParametersType m+formalParameters o = callInternalOptionalProperty o objectInternalFormalParameters++internalFormalParameters :: Lens' (ObjectInternal m) (Maybe (InternalFormalParametersType m))+internalFormalParameters =+ Lens.lens+ objectInternalFormalParameters+ (\oi fp -> oi { objectInternalFormalParameters = fp })++code :: (Functor m, Monad m) => InternalCodeType m+code o = callInternalOptionalProperty o objectInternalCode++internalCode :: Lens' (ObjectInternal m) (Maybe (InternalCodeType m))+internalCode =+ Lens.lens+ objectInternalCode+ (\oi c -> oi { objectInternalCode = c })++internalTargetFunction :: Lens' (ObjectInternal m) (Maybe (InternalTargetFunctionType m))+internalTargetFunction =+ Lens.lens+ objectInternalTargetFunction+ (\oi tf -> oi { objectInternalTargetFunction = tf })++internalBoundThis :: Lens' (ObjectInternal m) (Maybe (InternalBoundThisType m))+internalBoundThis =+ Lens.lens+ objectInternalBoundThis+ (\oi bt -> oi { objectInternalBoundThis = bt })++internalBoundArguments :: Lens' (ObjectInternal m) (Maybe (InternalBoundArgumentsType m))+internalBoundArguments =+ Lens.lens+ objectInternalBoundArguments+ (\oi bas -> oi { objectInternalBoundArguments = bas })++internalMatch :: Lens' (ObjectInternal m) (Maybe (InternalMatchType m))+internalMatch =+ Lens.lens+ objectInternalMatch+ (\oi m -> oi { objectInternalMatch = m })++internalParameterMap :: Lens' (ObjectInternal m) (Maybe (InternalParameterMapType m))+internalParameterMap =+ Lens.lens+ objectInternalParameterMap+ (\oi pm -> oi { objectInternalParameterMap = pm })++callInternalProperty :: (Functor m, Monad m) => Object -> (ObjectInternal m -> Object -> JavaScriptT m a) -> JavaScriptT m a+callInternalProperty o p = do+ oi <- Lens.use $ internalObject o+ p oi o++callInternalProperty1 :: (Functor m, Monad m) => Object -> (ObjectInternal m -> Object -> a -> JavaScriptT m b) -> a -> JavaScriptT m b+callInternalProperty1 o p a = do+ oi <- Lens.use $ internalObject o+ p oi o a++callInternalProperty2 :: (Functor m, Monad m) => Object -> (ObjectInternal m -> Object -> a -> b -> JavaScriptT m c) -> a -> b -> JavaScriptT m c+callInternalProperty2 o p a b = do+ oi <- Lens.use $ internalObject o+ p oi o a b++callInternalProperty3 :: (Functor m, Monad m) => Object -> (ObjectInternal m -> Object -> a -> b -> c -> JavaScriptT m d) -> a -> b -> c -> JavaScriptT m d+callInternalProperty3 o p a b c = do+ oi <- Lens.use $ internalObject o+ p oi o a b c++callInternalOptionalProperty :: (Functor m, Monad m) => Object -> (ObjectInternal m -> Maybe (Object -> JavaScriptT m a)) -> JavaScriptT m a+callInternalOptionalProperty o p = do+ oi <- Lens.use $ internalObject o+ case p oi of+ Just op -> op o+ Nothing -> newTypeErrorObject Nothing >>= jsThrow++callInternalOptionalProperty1 :: (Functor m, Monad m) =>+ Object ->+ (ObjectInternal m ->+ Maybe (Object -> a -> JavaScriptT m b)) ->+ a ->+ JavaScriptT m b+callInternalOptionalProperty1 o p a = do+ oi <- Lens.use $ internalObject o+ case p oi of+ Just op -> op o a+ Nothing -> newTypeErrorObject Nothing >>= jsThrow++callInternalOptionalProperty2 :: (Functor m, Monad m) =>+ Object ->+ (ObjectInternal m ->+ Maybe (Object -> a -> b -> JavaScriptT m c)) ->+ a -> b ->+ JavaScriptT m c+callInternalOptionalProperty2 o p a b = do+ oi <- Lens.use $ internalObject o+ case p oi of+ Just op -> op o a b+ Nothing -> newTypeErrorObject Nothing >>= jsThrow++callInternalOptionalProperty3 :: (Functor m, Monad m) =>+ Object ->+ (ObjectInternal m ->+ Maybe (Object -> a -> b -> c -> JavaScriptT m d)) ->+ a -> b -> c ->+ JavaScriptT m d+callInternalOptionalProperty3 o p a b c = do+ oi <- Lens.use $ internalObject o+ case p oi of+ Just op -> op o a b c+ Nothing -> newTypeErrorObject Nothing >>= jsThrow++getOwnPropertyImpl :: Object -> String -> JavaScriptM (JSMaybe PropertyDescriptor)+getOwnPropertyImpl o p = do+ oi@(ObjectInternal {..}) <- Lens.use $ internalObject o+ case Map.lookup p objectInternalProperties of+ Just x -> do+ case x of+ PropertyData (DataDescriptor {..}) -> do+ return $ JSJust+ def { propertyDescriptorValue = Just dataDescriptorValue+ , propertyDescriptorWritable = Just dataDescriptorWritable+ , propertyDescriptorEnumerable = Just dataDescriptorEnumerable+ , propertyDescriptorConfigurable = Just dataDescriptorConfigurable }+ PropertyAccessor (AccessorDescriptor {..}) -> do+ return $ JSJust+ def { propertyDescriptorGet = jsMaybe Nothing Just accessorDescriptorGet+ , propertyDescriptorSet = jsMaybe Nothing Just accessorDescriptorSet+ , propertyDescriptorEnumerable = Just accessorDescriptorEnumerable+ , propertyDescriptorConfigurable = Just accessorDescriptorConfigurable }++ Nothing -> return JSNothing++getPropertyImpl :: Object -> String -> JavaScriptM (JSMaybe PropertyDescriptor)+getPropertyImpl o p = do+ prop <- getOwnProperty o p+ case prop of+ JSJust _ -> return prop+ JSNothing -> do+ proto <- prototype o+ case proto of+ JSNull -> return JSNothing+ JSExist po -> do+ getProperty po p++getImpl :: Object -> String -> JavaScriptM Value+getImpl o p = do+ mDesc <- getProperty o p+ case mDesc of+ JSNothing -> return $ inj Undefined+ JSJust desc@(PropertyDescriptor {..}) -> do+ case toDataDescriptor mDesc of+ JSJust DataDescriptor {..} -> return dataDescriptorValue+ JSNothing -> do+ case propertyDescriptorGet of+ Nothing -> return $ inj Undefined+ Just getter -> callNative getter (inj o) (List [])++canPutImpl :: Object -> String -> JavaScriptM Bool+canPutImpl o p = do+ mDesc <- getOwnProperty o p+ case mDesc of+ JSJust desc@(PropertyDescriptor {..}) -> do+ case toAccessorDescriptor mDesc of+ JSJust AccessorDescriptor {..} -> do+ case accessorDescriptorSet of+ JSNothing -> return False+ _ -> return True+ _ -> return $ fromJust propertyDescriptorWritable+ JSNothing -> do+ nProto <- prototype o+ case nProto of+ JSNull -> extensible o+ JSExist proto -> do+ mInherited <- getProperty proto p+ case mInherited of+ JSNothing -> extensible o+ JSJust inherited@(PropertyDescriptor {..}) -> do+ if isAccessorDescriptor mInherited+ then do+ case propertyDescriptorSet of+ Nothing -> return False+ _ -> return True+ else do+ e <- extensible o+ if not e+ then return False+ else return $ fromJust propertyDescriptorWritable++putImpl :: Object -> String -> Value -> Bool -> JavaScriptM ()+putImpl o p v throw = do+ c <- canPut o p+ if not c+ then do+ if throw+ then newTypeErrorObject Nothing >>= jsThrow+ else return ()+ else do+ ownDesc <- getOwnProperty o p+ if isDataDescriptor ownDesc+ then do+ let valueDesc = def { propertyDescriptorValue = Just v }+ defineOwnProperty o p valueDesc throw+ return ()+ else do+ desc <- getProperty o p+ if isAccessorDescriptor desc+ then do+ let JSJust (PropertyDescriptor {..}) = desc+ let setter = fromJust propertyDescriptorSet+ callNative setter (inj o) (List [v])+ return ()+ else do+ let newDesc = def {+ propertyDescriptorValue = Just v,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just True }+ defineOwnProperty o p newDesc throw+ return ()+ return ()++hasPropertyImpl :: Object -> String -> JavaScriptM Bool+hasPropertyImpl o p = do+ desc <- getProperty o p+ case desc of+ JSNothing -> return False+ _ -> return True++deleteImpl :: Object -> String -> Bool -> JavaScriptM Bool+deleteImpl o p throw = do+ desc <- getOwnProperty o p+ case desc of+ JSNothing -> return True+ JSJust (PropertyDescriptor {..}) -> do+ if propertyDescriptorConfigurable == Just True+ then do+ return True+ else do+ if throw+ then newTypeErrorObject Nothing >>= jsThrow+ else return False++data Hint+ = HintString+ | HintNumber+ deriving (Eq, Show)++defaultValueImpl :: Object -> Maybe Hint -> JavaScriptM Primitive+defaultValueImpl o (Just HintString) = do+ f <- get o "toString"+ mc <- toCallable f+ case mc of+ Just c -> do+ str <- call c (inj o) (List [])+ case prj str of+ Just p -> return p+ Nothing -> valueOfBranch+ Nothing -> valueOfBranch+ where+ valueOfBranch = do+ valueOf <- get o "valueOf"+ mc <- toCallable valueOf+ case mc of+ Just c -> do+ val <- call c (inj o) (List [])+ case val of+ CallValuePrimitive p -> return p+ _ -> newTypeErrorObject Nothing >>= jsThrow+ Nothing -> newTypeErrorObject Nothing >>= jsThrow++defaultValueImpl o (Just HintNumber) = do+ valueOf <- get o "valueOf"+ mc <- toCallable valueOf+ case mc of+ Just c -> do+ val <- call c (inj o) (List [])+ case prj val of+ Just p -> return p+ Nothing -> toStringBranch+ Nothing -> toStringBranch+ where+ toStringBranch = do+ f <- get o "toString"+ mc <- toCallable f+ case mc of+ Just c -> do+ str <- call c (inj o) (List [])+ case str of+ CallValuePrimitive p -> return p+ _ -> newTypeErrorObject Nothing >>= jsThrow+ Nothing -> newTypeErrorObject Nothing >>= jsThrow++defaultValueImpl o Nothing = defaultValueImpl o (Just HintNumber)++functionPrototypeCallImpl :: (Monad m) => InternalCallType m+functionPrototypeCallImpl _ _ _ = return (inj Undefined)++newFunctionObject :: Maybe FormalParamList ->+ FuncBody ->+ LexicalEnvironment ->+ Bool ->+ JavaScriptM Object+newFunctionObject mfpl fb scope strict = do+ i <- createNextInternalId+ function <- Lens.use functionPrototypeObject+ let f = Object i+ names = case mfpl of+ Just fpl ->+ foldFormalParamList (\(Ident (IdentName s)) -> (s:)) [] fpl+ Nothing -> []+ len = length names+ oi = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist function),+ objectInternalClass = "Function",+ objectInternalExtensible = const $ return True,+ objectInternalGet = functionGetImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Just functionConstructImpl,+ objectInternalCall = Just functionCallImpl,+ objectInternalHasInstance = Just functionHasInstanceImpl,+ objectInternalScope = Just $ const $ return scope,+ objectInternalFormalParameters = Just $ const $ return $ List names,+ objectInternalCode = Just $ const $ return fb,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }++ mInternalObject f ?= oi+ defineOwnProperty+ f+ "length"+ def {+ propertyDescriptorValue = Just $ inj (Number $ fromIntegral len),+ propertyDescriptorWritable = Just False,+ propertyDescriptorEnumerable = Just False,+ propertyDescriptorConfigurable = Just False }+ False+ proto <- newObjectObject Nothing+ defineOwnProperty+ proto+ "constructor"+ def {+ propertyDescriptorValue = Just $ inj f,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just False,+ propertyDescriptorConfigurable = Just True }+ False+ defineOwnProperty+ f+ "prototype"+ def {+ propertyDescriptorValue = Just $ inj proto,+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just False,+ propertyDescriptorConfigurable = Just False }+ False+ if strict+ then do+ thrower <- Lens.use throwTypeErrorObject+ defineOwnProperty+ f+ "caller"+ def {+ propertyDescriptorGet = Just thrower,+ propertyDescriptorSet = Just thrower,+ propertyDescriptorEnumerable = Just False,+ propertyDescriptorConfigurable = Just False }+ False+ return f+ else return f+ where+ foldFormalParamList f a (FormalParamList i) = f i a+ foldFormalParamList f a (FormalParamListCons fpl i) =+ f i (foldFormalParamList f a fpl)++functionConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+functionConstructorCallImpl f _ args =+ inj <$>functionConstructorConstructImpl f args++functionConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+functionConstructorConstructImpl f args = error "functionConstructorConstructImpl"++functionCallImpl :: (Functor m, Monad m) => InternalCallType m+functionCallImpl f this args = do+ fpl <- formalParameters f+ enterFunctionContext f this args+ mc <- Lens.use $ internalObject f . internalCode+ result <- case mc of+ Nothing ->+ return $ Completion CompletionTypeNormal (inj Undefined) Nothing+ Just c -> do+ fb <- c f+ interpret fb+ popContext+ case result of+ Completion CompletionTypeThrow (Just v) _ -> jsThrow v+ Completion CompletionTypeReturn (Just v) _ -> return (inj v)+ _ -> return (inj Undefined)++functionGetImpl :: (Functor m, Monad m) => InternalGetType m+functionGetImpl f p = do+ v <- getImpl f p+ return v++functionConstructImpl :: (Functor m, Monad m) => InternalConstructType m+functionConstructImpl f l = do+ i <- createNextInternalId+ proto <- get f "prototype"+ p <- case proto of+ ValueObject o -> return o+ _ -> Lens.use objectPrototypeObject+ let obj = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Object",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject f ?= oi+ result <- call f (inj obj) l+ case result of+ CallValueObject o -> return o+ _ -> return obj++functionHasInstanceImpl :: (Functor m, Monad m) => InternalHasInstanceType m+functionHasInstanceImpl = error "functionHasInstanceImpl"++newArrayObject :: [Value] -> JavaScriptM Object+newArrayObject as = do+ let properties =+ [ ("length", PropertyData $+ def { dataDescriptorValue =+ inj $ Number (fromIntegral $ length as),+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = True,+ dataDescriptorConfigurable = True }) ] +++ (snd $+ foldl+ (\(n, ps) a -> (n+1, (show n, PropertyData $+ def { dataDescriptorValue = a,+ dataDescriptorWritable = True,+ dataDescriptorEnumerable = True,+ dataDescriptorConfigurable = True }):ps))+ (0 :: Int, []) as)+ i <- createNextInternalId+ let a = Object i+ p <- Lens.use arrayPrototypeObject+ let oi = ObjectInternal {+ objectInternalProperties = Map.fromList properties,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Array",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = arrayDefineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject a ?= oi+ return a++arrayConstructorCallImpl :: (Functor m, Monad m) => InternalCallType m+arrayConstructorCallImpl a _ args =+ inj <$> arrayConstructorConstructImpl a args++arrayConstructorConstructImpl :: InternalConstructType m+arrayConstructorConstructImpl a args = undefined++arrayDefineOwnPropertyImpl :: (Functor m, Monad m) =>+ InternalDefineOwnPropertyType m+arrayDefineOwnPropertyImpl a p desc throw = do+ JSJust oldLenDesc <- getOwnProperty a "length" >>= return . toDataDescriptor+ oldLen <- toNumber $ dataDescriptorValue oldLenDesc+ if p == "length"+ then do+ case propertyDescriptorValue desc of+ Nothing -> defineOwnPropertyImpl a p desc throw+ Just v -> do+ newLen <- toUint32 v+ curLen <- toNumber v+ if fromIntegral newLen /= curLen+ then newRangeErrorObject Nothing >>= jsThrow+ else do+ let newLenDesc = desc {+ propertyDescriptorValue = Just (inj $ Number $ fromIntegral newLen) }+ if fromIntegral newLen >= oldLen+ then do+ defineOwnPropertyImpl a "length" newLenDesc throw+ else do+ if not $ dataDescriptorWritable oldLenDesc+ then reject+ else do+ let (newWritable, newLenDesc') =+ case propertyDescriptorWritable newLenDesc of+ Just False -> (False, newLenDesc {+ propertyDescriptorWritable = Just True })+ _ -> (True, newLenDesc)+ succeeded <- defineOwnPropertyImpl a "length" newLenDesc' throw+ if not succeeded+ then return False+ else do+ r <- deleteLoop newLen oldLen newLenDesc' newWritable+ if not r+ then return r+ else do+ when (not newWritable) $ void $+ defineOwnPropertyImpl a "lenght" (def { propertyDescriptorWritable = Just False }) False+ return True+ else do+ iai <- isArrayIndex p+ if iai+ then do+ index <- toUint32 p+ if fromIntegral index >= oldLen && dataDescriptorWritable oldLenDesc == False+ then reject+ else do+ succeeded <- defineOwnPropertyImpl a p desc False+ if not succeeded+ then reject+ else do+ when (fromIntegral index >= oldLen) $ void $ do+ let oldLenDesc' = oldLenDesc {+ dataDescriptorValue = inj $ Number $ fromIntegral (index + 1) }+ defineOwnPropertyImpl a "length" (fromDataDescriptor oldLenDesc') False+ return True+ else defineOwnPropertyImpl a p desc throw++ where+ deleteLoop :: UInt32 -> Number -> PropertyDescriptor -> Bool -> JavaScriptM Bool+ deleteLoop newLen oldLen newLenDesc newWritable = do+ if fromIntegral newLen < oldLen+ then do+ let oldLen' = oldLen - 1+ deleteSucceeded <- toString oldLen >>= \s -> delete a s False+ if (not deleteSucceeded)+ then do+ let writable =+ if not newWritable+ then Just False+ else propertyDescriptorWritable newLenDesc+ newLenDesc' = newLenDesc {+ propertyDescriptorValue = Just $ inj (oldLen' + 1),+ propertyDescriptorWritable = writable }+ defineOwnPropertyImpl a "length" newLenDesc' False+ reject+ else+ deleteLoop newLen oldLen' newLenDesc newWritable+ else return True++ reject :: JavaScriptM Bool+ reject =+ if throw+ then newTypeErrorObject Nothing >>= jsThrow+ else return False++isArrayIndex :: String -> JavaScriptM Bool+isArrayIndex p = do+ ui <- toUint32 p+ c <- toString (Number $ fromIntegral ui)+ return $ c == p && ui /= 2 ^ (32 :: Int) - 1++newBooleanObject :: Value ->+ JavaScriptM Object+newBooleanObject v = do+ i <- createNextInternalId+ boolean <- Lens.use booleanPrototypeObject+ let b = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist boolean),+ objectInternalClass = "Boolean",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just $ const $ return $ inj (toBoolean v),+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject b ?= oi+ return b++booleanConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+booleanConstructorCallImpl _ _ (List vs) = do+ case vs of+ (v:_) -> return . inj $ toBoolean v+ _ -> return (inj False)++booleanConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+booleanConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newBooleanObject v+ _ -> newBooleanObject (inj False)++newNumberObject :: Maybe Value ->+ JavaScriptM Object+newNumberObject mv = do+ i <- createNextInternalId+ nv <- maybe (return (Number 0)) toNumber mv+ number <- Lens.use numberPrototypeObject+ let n = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist number),+ objectInternalClass = "Number",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just $ const $ return $ inj nv,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject n ?= oi+ return n++numberConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+numberConstructorCallImpl _ _ (List vs) = do+ case vs of+ (v:_) -> inj <$> toNumber v+ _ -> return . inj $ Number 0++numberConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+numberConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newNumberObject (Just v)+ _ -> newNumberObject Nothing++newErrorObject :: Maybe Value ->+ JavaScriptM Object+newErrorObject mv = do+ i <- createNextInternalId+ properties <- case mv of+ Nothing -> return []+ Just (ValueUndefined _) -> return []+ Just v -> do+ s <- toString v+ return [ ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj s,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ]+ error <- Lens.use errorPrototypeObject+ let n = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.fromList properties,+ objectInternalPrototype = const $ return (JSExist error),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject n ?= oi+ return n++errorConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+errorConstructorCallImpl e _ args = do+ inj <$> errorConstructorConstructImpl e args++errorConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+errorConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newErrorObject (Just v)+ _ -> newErrorObject Nothing++errorPrototypeToStringCallImpl :: (Functor m, Monad m) => InternalCallType m+errorPrototypeToStringCallImpl _ v _ = do+ case v of+ ValueObject o -> do+ name <- get o "name"+ name' <- case name of+ ValueUndefined _ -> return "Error"+ _ -> toString name+ msg <- get o "message"+ msg' <- case msg of+ ValueUndefined _ -> return ""+ _ -> toString msg+ if null name'+ then return (inj msg')+ else+ if null msg'+ then return (inj name')+ else return (inj $ name' ++ ": " ++ msg')+ _ -> newTypeErrorObject Nothing >>= jsThrow++newEvalErrorObject :: Maybe Value -> JavaScriptM Object+newEvalErrorObject mv = do+ i <- createNextInternalId+ properties <- case mv of+ Nothing -> return []+ Just (ValueUndefined _) -> return []+ Just v -> do+ s <- toString v+ return [ ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj s,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ]+ p <- Lens.use evalErrorPrototypeObject+ let n = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.fromList properties,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject n ?= oi+ return n++evalErrorConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+evalErrorConstructorCallImpl e _ args = do+ inj <$> evalErrorConstructorConstructImpl e args++evalErrorConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+evalErrorConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newEvalErrorObject (Just v)+ _ -> newEvalErrorObject Nothing++newRangeErrorObject :: Maybe Value -> JavaScriptM Object+newRangeErrorObject mv = do+ i <- createNextInternalId+ properties <- case mv of+ Nothing -> return []+ Just (ValueUndefined _) -> return []+ Just v -> do+ s <- toString v+ return [ ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj s,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ]+ p <- Lens.use rangeErrorPrototypeObject+ let n = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.fromList properties,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject n ?= oi+ return n++rangeErrorConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+rangeErrorConstructorCallImpl e _ args = do+ inj <$> rangeErrorConstructorConstructImpl e args++rangeErrorConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+rangeErrorConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newRangeErrorObject (Just v)+ _ -> newRangeErrorObject Nothing++newReferenceErrorObject :: Maybe Value -> JavaScriptM Object+newReferenceErrorObject mv = do+ i <- createNextInternalId+ properties <- case mv of+ Nothing -> return []+ Just (ValueUndefined _) -> return []+ Just v -> do+ s <- toString v+ return [ ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj s,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ]+ p <- Lens.use referenceErrorPrototypeObject+ let n = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.fromList properties,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject n ?= oi+ return n++referenceErrorConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+referenceErrorConstructorCallImpl e _ args = do+ inj <$> referenceErrorConstructorConstructImpl e args++referenceErrorConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+referenceErrorConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newReferenceErrorObject (Just v)+ _ -> newReferenceErrorObject Nothing++newSyntaxErrorObject :: Maybe Value -> JavaScriptM Object+newSyntaxErrorObject mv = do+ i <- createNextInternalId+ properties <- case mv of+ Nothing -> return []+ Just (ValueUndefined _) -> return []+ Just v -> do+ s <- toString v+ return [ ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj s,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ]+ p <- Lens.use syntaxErrorPrototypeObject+ let n = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.fromList properties,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject n ?= oi+ return n++syntaxErrorConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+syntaxErrorConstructorCallImpl e _ args = do+ inj <$> syntaxErrorConstructorConstructImpl e args++syntaxErrorConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+syntaxErrorConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newSyntaxErrorObject (Just v)+ _ -> newSyntaxErrorObject Nothing++newTypeErrorObject :: Maybe Value -> JavaScriptM Object+newTypeErrorObject mv = do+ i <- createNextInternalId+ properties <- case mv of+ Nothing -> return []+ Just (ValueUndefined _) -> return []+ Just v -> do+ s <- toString v+ return [ ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj s,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ]+ p <- Lens.use typeErrorPrototypeObject+ let n = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.fromList properties,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject n ?= oi+ return n++typeErrorConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+typeErrorConstructorCallImpl e _ args = do+ inj <$> typeErrorConstructorConstructImpl e args++typeErrorConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+typeErrorConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newTypeErrorObject (Just v)+ _ -> newTypeErrorObject Nothing++newUriErrorObject :: Maybe Value -> JavaScriptM Object+newUriErrorObject mv = do+ i <- createNextInternalId+ properties <- case mv of+ Nothing -> return []+ Just (ValueUndefined _) -> return []+ Just v -> do+ s <- toString v+ return [ ("message", PropertyData $ DataDescriptor {+ dataDescriptorValue = inj s,+ dataDescriptorWritable = False,+ dataDescriptorEnumerable = False,+ dataDescriptorConfigurable = False }) ]+ p <- Lens.use uriErrorPrototypeObject+ let n = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.fromList properties,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Error",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject n ?= oi+ return n++uriErrorConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+uriErrorConstructorCallImpl e _ args = do+ inj <$> uriErrorConstructorConstructImpl e args++uriErrorConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+uriErrorConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newUriErrorObject (Just v)+ _ -> newUriErrorObject Nothing++newStringObject :: Maybe Value ->+ JavaScriptM Object+newStringObject mv = do+ i <- createNextInternalId+ sv <- maybe (return "") toString mv+ string <- Lens.use stringPrototypeObject+ let s = Object i+ oi = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist string),+ objectInternalClass = "String",+ objectInternalExtensible = const $ return True,+ objectInternalGet = getImpl,+ objectInternalGetOwnProperty = stringGetOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Just $ stringPrimitiveValueImpl mv,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject s ?= oi+ return s++stringConstructorCallImpl :: (Functor m, Monad m) => InternalCallType m+stringConstructorCallImpl s _ (List ss) = do+ case ss of+ (s:_) -> inj <$> toString s+ _ -> return (inj "")++stringConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+stringConstructorConstructImpl s (List vs) = do+ case vs of+ (v:_) -> newStringObject (Just v)+ _ -> newStringObject Nothing++stringGetOwnPropertyImpl :: (Functor m, Monad m) =>+ InternalGetOwnPropertyType m+stringGetOwnPropertyImpl s p = do+ desc <- getOwnPropertyImpl s p+ case desc of+ JSJust d -> return $ JSJust d+ JSNothing -> do+ ns <- toInteger p >>= toString . Number . fromIntegral . abs+ if not (ns == p)+ then return (inj Undefined)+ else do+ PrimitiveString str <- primitiveValue s+ index <- toInteger p+ let len = length str+ if fromIntegral len <= index+ then return (inj Undefined)+ else do+ let resultStr = [str !! fromInteger index]+ return $ JSJust def {+ propertyDescriptorValue = Just (inj resultStr),+ propertyDescriptorWritable = Just False,+ propertyDescriptorEnumerable = Just True,+ propertyDescriptorConfigurable = Just False }+++stringPrimitiveValueImpl :: (Functor m, Monad m) =>+ Maybe Value -> InternalPrimitiveValueType m+stringPrimitiveValueImpl mv _ = do+ case mv of+ Just v -> inj <$> toString v+ Nothing -> return (inj "")++regExpMatchImpl = undefined++createArgumentsObject :: Object ->+ List String ->+ List Value ->+ LexicalEnvironment ->+ Bool ->+ JavaScriptM Object+createArgumentsObject func (List names) (List args) env strict = do+ let len = length args+ obj <- newObjectObject Nothing+ object <- Lens.use objectPrototypeObject+ internalObject obj %= \oi -> oi { objectInternalClass = "Arguments",+ objectInternalPrototype = const $ return (JSExist object) }+ defineOwnProperty+ obj+ "length"+ (def {+ propertyDescriptorValue = Just (inj (Number (fromIntegral len))),+ propertyDescriptorWritable = Just True,+ propertyDescriptorEnumerable = Just False,+ propertyDescriptorConfigurable = Just True })+ False+ return obj++data Code+ = CodeGlobal Program+ | CodeEval (Maybe SourceElements)+ | CodeFunction Object (List Value)++createNextInternalId :: JavaScriptM InternalId+createNextInternalId = do+ next <- Lens.use nextInternalId+ nextInternalId .= succ next+ return next++newObjectObject :: Maybe Value -> JavaScriptM Object+newObjectObject mv =+ case mv of+ Just v ->+ case v of+ ValueObject o -> do+ return o+ _ ->+ if typeOf v == TypeString ||+ typeOf v == TypeBoolean ||+ typeOf v == TypeNumber+ then toObject v+ else createObject+ _ -> createObject+ where+ createObject = do+ i <- createNextInternalId+ let o = Object i+ p <- Lens.use objectPrototypeObject+ let oi = ObjectInternal {+ objectInternalProperties = Map.empty,+ objectInternalPrototype = const $ return (JSExist p),+ objectInternalClass = "Object",+ objectInternalExtensible = const $ return True,+ objectInternalGet = functionGetImpl,+ objectInternalGetOwnProperty = getOwnPropertyImpl,+ objectInternalGetProperty = getPropertyImpl,+ objectInternalPut = putImpl,+ objectInternalCanPut = canPutImpl,+ objectInternalHasProperty = hasPropertyImpl,+ objectInternalDelete = deleteImpl,+ objectInternalDefaultValue = defaultValueImpl,+ objectInternalDefineOwnProperty = defineOwnPropertyImpl,+ objectInternalPrimitiveValue = Nothing,+ objectInternalConstruct = Nothing,+ objectInternalCall = Nothing,+ objectInternalHasInstance = Nothing,+ objectInternalScope = Nothing,+ objectInternalFormalParameters = Nothing,+ objectInternalCode = Nothing,+ objectInternalTargetFunction = Nothing,+ objectInternalBoundThis = Nothing,+ objectInternalBoundArguments = Nothing,+ objectInternalMatch = Nothing,+ objectInternalParameterMap = Nothing }+ mInternalObject o ?= oi+ return o++objectConstructorCallImpl :: (Functor m, Monad m) =>+ InternalCallType m+objectConstructorCallImpl o _ lvs@(List vs) =+ case vs of+ (ValueNull _:_) -> inj <$> objectConstructorConstructImpl o lvs+ (ValueUndefined _:_) -> inj <$> objectConstructorConstructImpl o lvs+ [] -> inj <$> objectConstructorConstructImpl o lvs+ (v:_) -> inj <$> toObject v++objectConstructorConstructImpl :: (Functor m, Monad m) =>+ InternalConstructType m+objectConstructorConstructImpl _ (List vs) = do+ case vs of+ (v:_) -> newObjectObject (Just v)+ _ -> newObjectObject Nothing+++defineOwnPropertyImpl :: (Functor m, Monad m) =>+ InternalDefineOwnPropertyType m+defineOwnPropertyImpl o p desc throw = do+ mCurrent <- getOwnProperty o p+ e <- extensible o+ case (mCurrent, e) of+ (JSNothing, False) -> reject+ (JSNothing, True) -> do+ if isGenericDescriptor (JSJust desc) || isDataDescriptor (JSJust desc)+ then do+ let dp = PropertyData+ DataDescriptor {+ dataDescriptorValue =+ maybe (inj Undefined) id (propertyDescriptorValue desc),+ dataDescriptorWritable =+ maybe False id (propertyDescriptorWritable desc),+ dataDescriptorEnumerable =+ maybe False id (propertyDescriptorEnumerable desc),+ dataDescriptorConfigurable =+ maybe False id (propertyDescriptorConfigurable desc) }+ property o p ?= dp+ else do+ let ap = PropertyAccessor+ AccessorDescriptor {+ accessorDescriptorGet =+ maybe JSNothing JSJust (propertyDescriptorGet desc),+ accessorDescriptorSet =+ maybe JSNothing JSJust (propertyDescriptorSet desc),+ accessorDescriptorEnumerable =+ maybe False id (propertyDescriptorEnumerable desc),+ accessorDescriptorConfigurable =+ maybe False id (propertyDescriptorConfigurable desc) }+ property o p ?= ap+ return True+ (JSJust current, _) -> do+ if (propertyDescriptorValue desc == Nothing ||+ (sameValue <$>+ propertyDescriptorValue desc <*>+ propertyDescriptorValue current) == Just True) &&+ (propertyDescriptorGet desc == Nothing ||+ (sameValue <$>+ propertyDescriptorGet desc <*>+ propertyDescriptorGet current) == Just True) &&+ (propertyDescriptorSet desc == Nothing ||+ (sameValue <$>+ propertyDescriptorSet desc <*>+ propertyDescriptorSet current) == Just True) &&+ (propertyDescriptorWritable desc == Nothing ||+ (sameValue <$>+ propertyDescriptorWritable desc <*>+ propertyDescriptorWritable current) == Just True) &&+ (propertyDescriptorEnumerable desc == Nothing ||+ (sameValue <$>+ propertyDescriptorEnumerable desc <*>+ propertyDescriptorEnumerable current) == Just True) &&+ (propertyDescriptorConfigurable desc == Nothing ||+ (sameValue <$>+ propertyDescriptorConfigurable desc <*>+ propertyDescriptorConfigurable current) == Just True)+ then return True+ else+ if (propertyDescriptorConfigurable current == Just False)+ then+ if (propertyDescriptorConfigurable desc == Just True)+ then reject+ else+ if ((==) <$>+ (propertyDescriptorEnumerable desc) <*>+ (propertyDescriptorEnumerable current)) ==+ Just False+ then reject+ else checkDescriptor current+ else checkDescriptor current+ where+ reject =+ if throw+ then newTypeErrorObject Nothing >>= jsThrow+ else return False+ checkDescriptor current = do+ if isGenericDescriptor (JSJust desc)+ then setValue+ else do+ case (isDataDescriptor (JSJust current), isDataDescriptor (JSJust desc)) of+ (cb, db) | cb /= db -> do+ if propertyDescriptorConfigurable current == Just False+ then reject+ else+ if isDataDescriptor (JSJust current)+ then do+ error "Convert B"+ else do+ error "Convert C"+ (True, True) -> do+ if propertyDescriptorConfigurable current == Just False+ then+ if propertyDescriptorWritable current == Just False &&+ propertyDescriptorWritable desc == Just True+ then reject+ else+ if propertyDescriptorWritable current == Just False &&+ propertyDescriptorWritable desc == Just True+ then reject+ else+ case (propertyDescriptorWritable current,+ propertyDescriptorValue desc,+ propertyDescriptorValue current) of+ (Just False, Just dv, Just cv) | not $ sameValue dv cv -> reject+ _ -> setValue+ else setValue+ _ -> do+ if propertyDescriptorConfigurable current == Just False+ then do+ case (propertyDescriptorSet desc,+ propertyDescriptorSet current) of+ (Just ds, Just cs) | not $ sameValue ds cs -> reject+ _ -> do+ case (propertyDescriptorSet desc,+ propertyDescriptorGet current) of+ (Just dg, Just cg) | not $ sameValue dg cg -> reject+ _ -> setValue+ else setValue+ setValue = do+ property o p %=+ \(Just prop) ->+ Just $+ case prop of+ PropertyData prop ->+ PropertyData prop {+ dataDescriptorValue =+ maybe+ (dataDescriptorValue prop)+ id+ (propertyDescriptorValue desc),+ dataDescriptorWritable =+ maybe+ (dataDescriptorWritable prop)+ id+ (propertyDescriptorWritable desc),+ dataDescriptorEnumerable =+ maybe+ (dataDescriptorEnumerable prop)+ id+ (propertyDescriptorEnumerable desc),+ dataDescriptorConfigurable =+ maybe+ (dataDescriptorConfigurable prop)+ id+ (propertyDescriptorConfigurable desc) }+ PropertyAccessor prop ->+ PropertyAccessor prop {+ accessorDescriptorGet =+ maybe+ (accessorDescriptorGet prop)+ JSJust+ (propertyDescriptorGet desc),+ accessorDescriptorSet =+ maybe+ (accessorDescriptorSet prop)+ JSJust+ (propertyDescriptorSet desc),+ accessorDescriptorEnumerable =+ maybe+ (accessorDescriptorEnumerable prop)+ id+ (propertyDescriptorEnumerable desc),+ accessorDescriptorConfigurable =+ maybe+ (accessorDescriptorConfigurable prop)+ id+ (propertyDescriptorConfigurable desc) }+ return True++toPrimitive :: (SubType v Value) =>+ v -> Maybe Hint -> JavaScriptM Primitive+toPrimitive v mpt =+ case inj v of+ ValueObject o -> defaultValue o mpt+ ValuePrimitive p -> return p++toBoolean :: (SubType v Value) =>+ v -> Bool+toBoolean v =+ case (inj v :: Value) of+ (ValueUndefined _) -> False+ (ValueNull _) -> False+ (ValueBool b) -> b+ (ValueNumber n) ->+ if isNaN n || n == Number 0+ then False+ else True+ (ValueString s) -> not $ null s+ (ValueObject _) -> True++toNumber :: (SubType v Value) =>+ v -> JavaScriptM Number+toNumber v =+ case (inj v :: Value) of+ ValueUndefined _ -> return nan+ ValueNull _ -> return $ Number 0+ ValueBool b -> return $ if b then Number 1 else Number 0+ ValueNumber n -> return n+ ValueString s -> do+ case parseString s of+ Just d -> return $ Number d+ Nothing -> return nan+ ValueObject _ -> toPrimitive v (Just HintNumber) >>= toNumber++toInteger :: (SubType v Value) =>+ v -> JavaScriptM Integer+toInteger v = do+ number <- toNumber v+ if isNaN number+ then return 0+ else return $ floor (signum number) * floor (abs number)++toInt32 :: (SubType v Value) =>+ v -> JavaScriptM Int32+toInt32 v = do+ number <- toNumber v+ if isNaN number || isInfinite number || number == Number 0+ then return 0+ else do+ let posInt = floor (signum number) * floor (abs number)+ int32bit = posInt `mod` 2 ^ (32 :: Int)+ if int32bit >= 2 ^ (31 :: Int)+ then return $ fromInteger $ int32bit - 2 ^ (32 :: Int)+ else return $ fromInteger int32bit++toUint32 :: (SubType v Value) =>+ v -> JavaScriptM UInt32+toUint32 v = do+ number <- toNumber v+ if isNaN number || isInfinite number || number == Number 0+ then return 0+ else do+ let posInt = floor (signum number) * floor (abs number)+ int32bit = posInt `mod` 2 ^ (32 :: Int)+ return $ fromInteger int32bit++toUint16 :: (SubType v Value) =>+ v -> JavaScriptM UInt16+toUint16 v = do+ number <- toNumber v+ if isNaN number || isInfinite number || number == Number 0+ then return 0+ else do+ let posInt = floor (signum number) * floor (abs number)+ int16bit = posInt `mod` 2 ^ (16 :: Int)+ return $ fromInteger int16bit++primitiveToString :: (SubType v Primitive) =>+ v -> String+primitiveToString p =+ case (inj p :: Primitive) of+ PrimitiveUndefined _ -> "undefined"+ PrimitiveNull _ -> "null"+ PrimitiveBool b -> if b then "true" else "false"+ PrimitiveNumber (Number n) -> show n+ PrimitiveString s -> s++toString :: (SubType v Value) =>+ v -> JavaScriptM String+toString v =+ case (inj v :: Value) of+ ValuePrimitive p -> return $ primitiveToString p+ ValueObject _ -> toPrimitive v (Just HintString) >>= toString++toObject :: Value -> JavaScriptM Object+toObject v =+ case v of+ ValueUndefined _ -> newTypeErrorObject Nothing >>= jsThrow+ ValueNull _ -> newTypeErrorObject Nothing >>= jsThrow+ ValueBool b -> newBooleanObject (inj b)+ ValueNumber n -> newNumberObject (inj n)+ ValueString s -> newStringObject (inj s)+ ValueObject o -> return o++checkObjectCoercible :: Value -> JavaScriptM ()+checkObjectCoercible v = void $ toObjectCoercible v++toObjectCoercible :: Value -> JavaScriptM (Object + Number + String + Bool)+toObjectCoercible (ValueUndefined _) = newTypeErrorObject Nothing >>= jsThrow+toObjectCoercible (ValueNull _) = newTypeErrorObject Nothing >>= jsThrow+toObjectCoercible (ValueObject o) = return $ inj o+toObjectCoercible (ValueNumber n) = return $ inj n+toObjectCoercible (ValueString s) = return $ inj s+toObjectCoercible (ValueBool b) = return $ inj b++isCallable :: Value -> JavaScriptM Bool+isCallable v = isJust <$> toCallable v++toCallable :: Value -> JavaScriptM (Maybe Object)+toCallable (ValueObject o) = do+ ObjectInternal {..} <- Lens.use $ internalObject o+ if isJust objectInternalCall+ then return $ Just o+ else return Nothing+toCallable _ = return Nothing++sameValue :: (SubType v1 Value, SubType v2 Value) =>+ v1 -> v2 -> Bool+sameValue x y = do+ case (inj x :: Value, inj y :: Value) of+ (ValueUndefined _, ValueUndefined _) -> True+ (ValueNull _, ValueNull _) -> True+ (ValueNumber (Number nx), ValueNumber (Number ny)) ->+ if isNaN nx && isNaN ny+ then True+ else+ if nx == 0 && isNegativeZero ny ||+ isNegativeZero nx && ny == 0+ then False+ else+ if nx == ny+ then True+ else False+ (ValueString sx, ValueString sy) -> sx == sy+ (ValueBool bx, ValueBool by) -> bx == by+ (ValueObject ox, ValueObject oy) -> ox == oy+ _ -> False++compare :: (SubType v1 Value, SubType v2 Value) =>+ v1 -> v2 -> JavaScriptM Bool+compare x y = do+ case (inj x :: Value, inj y :: Value) of+ (ValueUndefined _, ValueUndefined _) -> return True+ (ValueNull _, ValueNull _) -> return True+ (ValueNumber nx, ValueNumber ny) -> return (nx == ny)+ (ValueString sx, ValueString sy) -> return (sx == sy)+ (ValueBool bx, ValueBool by) -> return (bx == by)+ (ValueObject ox, ValueObject oy) -> return (ox == oy)+ (ValueNull _, ValueUndefined _) -> return True+ (ValueUndefined _, ValueNull _) -> return True+ (ValueNumber nx, ValueString sy) -> do+ ny <- toNumber y+ compare nx ny+ (ValueString sx, ValueNumber ny) -> do+ nx <- toNumber x+ compare nx ny+ (ValueBool bx, _) -> do+ nx <- toNumber bx+ compare nx y+ (_, ValueBool by) -> do+ ny <- toNumber by+ compare x ny+ (ValueString sx, ValueObject oy) -> do+ py <- toPrimitive oy Nothing+ compare sx py+ (ValueNumber nx, ValueObject oy) -> do+ py <- toPrimitive oy Nothing+ compare nx py+ (ValueObject ox, ValueString sy) -> do+ px <- toPrimitive ox Nothing+ compare px sy+ (ValueObject ox, ValueNumber ny) -> do+ px <- toPrimitive ox Nothing+ compare px ny+ _ -> return False++compareStrict :: Value -> Value -> Bool+compareStrict x y = do+ case (x, y) of+ (ValueUndefined _, ValueUndefined _) -> True+ (ValueNull _, ValueNull _) -> True+ (ValueNumber nx, ValueNumber ny) -> (nx == ny)+ (ValueString sx, ValueString sy) -> (sx == sy)+ (ValueBool bx, ValueBool by) -> (bx == by)+ (ValueObject ox, ValueObject oy) -> (ox == oy)+ _ -> False++compareLess :: Value -> Value -> Bool -> JavaScriptM (JSMaybe Bool)+compareLess x y leftFirst = do+ (px, py) <- if leftFirst+ then do+ px <- toPrimitive x (Just HintNumber)+ py <- toPrimitive y (Just HintNumber)+ return (px, py)+ else do+ py <- toPrimitive y (Just HintNumber)+ px <- toPrimitive x (Just HintNumber)+ return (px, py)+ case (px, py) of+ (PrimitiveString sx, PrimitiveString sy) -> do+ return $ JSJust (sx < sy)+ _ -> do+ nx <- toNumber px+ ny <- toNumber py+ if isNaN nx || isNaN ny+ then return JSNothing+ else return $ JSJust (nx < ny)++operatorPlus :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Value+operatorPlus lref rref = do+ lval <- getValue lref+ rval <- getValue rref+ lprim <- toPrimitive lval Nothing+ rprim <- toPrimitive rval Nothing+ if typeOf lprim == TypeString || typeOf rprim == TypeString+ then liftM2 (\l r -> inj $ l ++ r) (toString lprim) (toString rprim)+ else liftM2 (\l r -> inj $ l + r) (toNumber lprim) (toNumber rprim)++operatorMinus :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorMinus lref rref = do+ lval <- getValue lref+ rval <- getValue rref+ lnum <- toNumber lval+ rnum <- toNumber rval+ return $ lnum - rnum++operatorMult :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorMult left right = do+ leftValue <- getValue left+ rightValue <- getValue right+ leftNum <- toNumber leftValue+ rightNum <- toNumber rightValue+ return $ leftNum * rightNum++operatorDiv :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorDiv left right = do+ leftValue <- getValue left+ rightValue <- getValue right+ leftNum <- toNumber leftValue+ rightNum <- toNumber rightValue+ return $ leftNum / rightNum++operatorMod :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorMod left right = do+ leftValue <- getValue left+ rightValue <- getValue right+ leftNum <- toNumber leftValue+ rightNum <- toNumber rightValue+ return $ leftNum `mod'` rightNum++operatorLeftShift :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorLeftShift left right = do+ lval <- getValue left+ rval <- getValue right+ lnum <- toInt32 lval+ rnum <- toUint32 rval+ let shiftCount = fromInteger . Prelude.toInteger $ rnum .&. 0x1F+ return $ Number $ fromIntegral $ shiftL lnum shiftCount++operatorSignedRightShift :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorSignedRightShift left right = do+ lval <- getValue left+ rval <- getValue right+ lnum <- toInt32 lval+ rnum <- toUint32 rval+ let shiftCount = fromInteger . Prelude.toInteger $ rnum .&. 0x1F+ return $ Number $ fromIntegral $ shiftR lnum shiftCount++operatorUnsignedRightShift :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorUnsignedRightShift left right = do+ lval <- getValue left+ rval <- getValue right+ lnum <- toUint32 lval+ rnum <- toUint32 rval+ let shiftCount = fromInteger . Prelude.toInteger $ rnum .&. 0x1F+ return $ Number $ fromIntegral $ shiftR lnum shiftCount++operatorBitwiseAnd :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorBitwiseAnd left right = do+ lval <- getValue left+ rval <- getValue right+ lnum <- toInt32 lval+ rnum <- toInt32 rval+ return $ Number $ fromIntegral $ lnum .&. rnum++operatorBitwiseXor :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorBitwiseXor left right = do+ lval <- getValue left+ rval <- getValue right+ lnum <- toInt32 lval+ rnum <- toInt32 rval+ return $ Number $ fromIntegral $ lnum `xor` rnum++operatorBitwiseOr :: (SubType v1 CallValue, SubType v2 CallValue) =>+ v1 -> v2 -> JavaScriptM Number+operatorBitwiseOr left right = do+ lval <- getValue left+ rval <- getValue right+ lnum <- toInt32 lval+ rnum <- toInt32 rval+ return $ Number $ fromIntegral $ lnum .|. rnum
+ src/Language/JavaScript/Lexer.hs view
@@ -0,0 +1,670 @@+{-# LANGUAGE FlexibleContexts,+ RankNTypes #-}++module Language.JavaScript.Lexer+ where++import Control.Applicative ((<$>), (<*))+import Control.Monad (void)++import Data.Char+import Data.Maybe (mapMaybe)++import Text.Parsec ((<|>),+ SourcePos,+ anyChar, choice, getPosition, many,+ notFollowedBy, optionMaybe, runParser,+ satisfy, skipMany1, string, try)+import Text.Parsec.Char (char, oneOf)+import Text.Parsec.Prim (ParsecT, Stream,+ getState, modifyState)+import Text.Parsec.Token (GenLanguageDef(..), LanguageDef)+import Text.ParserCombinators.Parsec.Prim (GenParser)++import Language.JavaScript.AST++javaScript :: LanguageDef TokenState+javaScript = LanguageDef {+ commentStart = "/*",+ commentEnd = "*/",+ commentLine = "//",+ nestedComments = False,+ identStart = identifierStart,+ identLetter = identifierPart,+ opStart = oneOf "!%&( )*,-.:;<=>?[ ]^{|}~",+ opLetter = oneOf "=+-<>&|",+ reservedNames =+ [ "break", "case", "catch", "continue", "debugger", "default"+ , "delete", "do", "else", "finally", "for", "function", "if"+ , "in" , "instanceof", "new", "return", "this", "throw", "try"+ , "typeof", "var", "void", "while", "with"+ , "class", "const", "enum", "export", "extends", "import", "super"+ , "implements", "interface", "let", "package", "private", "protected"+ , "public", "static", "yield"+ , "null", "true", "false" ],+ reservedOpNames =+ [ "{", "}", "(", ")", "[", "]", ".", ";", ",", "<", ">", "<="+ , ">=", "==", "!=", "===", "!==", "+", "-", "*", "%", "++", "--"+ , "<<", ">>", ">>>", "&", "|", "^", "!", "~", "&&", "||", "?", ":"+ , "=", "+=", "-=", "*=", "%=", "<<=", ">>=", ">>>=", "&=", "|=", "^=" ],+ caseSensitive = True }++data InputElement+ = InputElementIdentName IdentName+ | InputElementLiteral Literal+ | InputElementPunctuator Punctuator+ | InputElementLineTerminator+ deriving (Eq, Show)++data InputElementDiv+ = InputElementDivWhiteSpace+ | InputElementDivLineTerminator+ | InputElementDivComment Comment+ | InputElementDivToken Token+ | InputElementDivDivPunctuator DivPunctuator+ deriving (Eq, Show)++data InputElementRegExp+ = InputElementRegExpWhiteSpace+ | InputElementRegExpLineTerminator+ | InputElementRegExpComment Comment+ | InputElementRegExpToken Token+ | InputElementRegExpRegExpLit RegExpLit+ deriving (Eq, Show)++data Comment+ = CommentMultiLine String+ | CommentSingleLine String+ deriving (Eq, Show)++data Token+ = TokenIdentName IdentName+ | TokenPunctuator Punctuator+ | TokenNumLit NumLit+ | TokenStringLit StringLit+ deriving (Eq, Show)++data Punctuator+ = Punctuator String+ deriving (Eq, Show)++data DivPunctuator+ = DivPunctuator String+ deriving (Eq, Show)++applyRest :: Stream s m t =>+ ParsecT s u m (b -> ParsecT s u m b) -> b -> ParsecT s u m b+applyRest pr a = do+ mr <- optionMaybe $ try pr+ case mr of+ Just r -> r a+ Nothing -> return a++data TokenState+ = TokenState+ { tokenStateLeadingDivAllowed :: Bool }++type TokenParser st a = GenParser Char st a+type TokenSTParser a = GenParser Char TokenState a++newTokenState :: TokenState+newTokenState = TokenState {+ tokenStateLeadingDivAllowed = False }++isLeadingDivAllowed :: TokenSTParser Bool+isLeadingDivAllowed = do+ s <- getState+ return $ tokenStateLeadingDivAllowed s++setLeadingDivAllowed :: TokenSTParser ()+setLeadingDivAllowed =+ modifyState $ \s -> s { tokenStateLeadingDivAllowed = True }++setLeadingDivDisallowed :: TokenSTParser ()+setLeadingDivDisallowed =+ modifyState $ \s -> s { tokenStateLeadingDivAllowed = False }++sourceCharacter :: TokenParser st Char+sourceCharacter = anyChar++inputElementDiv :: TokenSTParser InputElementDiv+inputElementDiv =+ do { void whiteSpace; return InputElementDivWhiteSpace } <|>+ do { void lineTerminator; return InputElementDivLineTerminator } <|>+ do { c <- comment; return $ InputElementDivComment c } <|>+ do { t <- token; return $ InputElementDivToken t } <|>+ do { p <- divPunctuator; return $ InputElementDivDivPunctuator p }++inputElementRegExp :: TokenSTParser InputElementRegExp+inputElementRegExp =+ do { void whiteSpace; return InputElementRegExpWhiteSpace } <|>+ do { void lineTerminator; return InputElementRegExpLineTerminator } <|>+ do { c <- comment; return $ InputElementRegExpComment c } <|>+ do { t <- token; return $ InputElementRegExpToken t } <|>+ do { re <- regularExpressionLiteral; return $ InputElementRegExpRegExpLit re }++whiteSpace :: Stream String m Char => ParsecT [Char] u m Char+whiteSpace =+ do { choice $ char <$>+ [ '\x0009', '\x000B'+ , '\x000C', '\x0020'+ , '\x00A0', '\xFEFF' ] } <|>+ satisfy (\c -> generalCategory c == Space)++lineTerminator :: TokenParser st Char+lineTerminator =+ choice $ char <$>+ [ '\x000A', '\x000D'+ , '\x2028', '\x2029' ]++lineTerminatorSequence :: TokenParser st ()+lineTerminatorSequence =+ skipMany1 $ choice+ [ void $ char '\x000A'+ , void $ try $ do { void $ char '\x000D'; (notFollowedBy $ char '\x000A') }+ , void $ char '\x2028', void $ char '\x2029'+ , void $ string "\x000D\x000A" ]++comment :: TokenParser st Comment+comment =+ multiLineComment <|>+ singleLineComment++multiLineComment :: TokenParser st Comment+multiLineComment =+ do { void . try $ string "/*"; ms <- optionMaybe multiLineCommentChars; void $ string "*/";+ case ms of+ Nothing -> return $ CommentMultiLine ""+ Just s -> return $ CommentMultiLine s }++multiLineCommentChars :: TokenParser st String+multiLineCommentChars =+ do { c <- multiLineNotAsteriskChar; ms <- optionMaybe multiLineCommentChars;+ case ms of+ Nothing -> return [c]+ Just s -> return $ c:s } <|>+ do { c <- try $ do { char '*' <* notFollowedBy (char '/') }; ms <- optionMaybe postAsteriskCommentChars;+ case ms of+ Nothing -> return [c]+ Just s -> return $ c:s }++postAsteriskCommentChars :: TokenParser st String+postAsteriskCommentChars =+ do { c <- multiLineNotForwardSlashOrAsteriskChar; ms <- optionMaybe multiLineCommentChars;+ case ms of+ Nothing -> return [c]+ Just s -> return $ c:s } <|>+ do { c <- char '*'; ms <- optionMaybe postAsteriskCommentChars;+ case ms of+ Nothing -> return [c]+ Just s -> return $ c:s }++multiLineNotAsteriskChar :: TokenParser st Char+multiLineNotAsteriskChar =+ do { notFollowedBy $ char '*'; sourceCharacter }++multiLineNotForwardSlashOrAsteriskChar :: TokenParser st Char+multiLineNotForwardSlashOrAsteriskChar =+ do { notFollowedBy $ char '/' <|> char '*'; sourceCharacter }++singleLineComment :: TokenParser st Comment+singleLineComment =+ do { void . try $ string "//"; ms <- optionMaybe singleLineCommentChars;+ case ms of+ Nothing -> return $ CommentSingleLine ""+ Just s -> return $ CommentSingleLine s }++singleLineCommentChars :: TokenParser st String+singleLineCommentChars =+ do { c <- singleLineCommentChar; ms <- optionMaybe singleLineCommentChars;+ case ms of+ Nothing -> return [c]+ Just s -> return $ c:s }++singleLineCommentChar :: TokenParser st Char+singleLineCommentChar =+ do { notFollowedBy lineTerminator; sourceCharacter }++token :: TokenSTParser Token+token =+ do { i <- identifierName; return $ TokenIdentName i } <|>+ do { p <- punctuator; return $ TokenPunctuator p } <|>+ do { n <- numericLiteral; setLeadingDivAllowed; return $ TokenNumLit n } <|>+ do { s <- stringLiteral; setLeadingDivAllowed; return $ TokenStringLit s }++identifier :: TokenSTParser Ident+identifier =+ do { notFollowedBy reservedWord; i <- identifierName; setLeadingDivAllowed; return $ Ident i; }++identifierName :: TokenSTParser IdentName+identifierName =+ do { c <- identifierStart; applyRest identifierNameRest $ IdentName [c]; }++identifierNameRest :: TokenSTParser (IdentName -> TokenSTParser IdentName)+identifierNameRest =+ do { c <- identifierPart; return $ \(IdentName s) -> applyRest identifierNameRest (IdentName $ s ++ [c]) }++identifierStart :: TokenSTParser Char+identifierStart =+ unicodeLetter <|>+ char '$' <|>+ char '_' <|>+ do { void $ char '\\'; unicodeEscapeSequence }++identifierPart :: TokenSTParser Char+identifierPart =+ identifierStart <|>+ unicodeCombiningMark <|>+ unicodeDigit <|>+ unicodeConnectorPunctuation <|>+ char '\x200C' <|>+ char '\x200D'++unicodeLetter :: TokenParser st Char+unicodeLetter =+ satisfy $ \c -> let cat = generalCategory c in+ cat == UppercaseLetter ||+ cat == LowercaseLetter ||+ cat == TitlecaseLetter ||+ cat == ModifierLetter ||+ cat == OtherLetter ||+ cat == LetterNumber++unicodeCombiningMark :: TokenParser st Char+unicodeCombiningMark =+ satisfy $ \c -> let cat = generalCategory c in+ cat == NonSpacingMark ||+ cat == SpacingCombiningMark++unicodeDigit :: TokenParser st Char+unicodeDigit =+ satisfy $ \c -> let cat = generalCategory c in+ cat == DecimalNumber++unicodeConnectorPunctuation :: TokenParser st Char+unicodeConnectorPunctuation =+ satisfy $ \c -> let cat = generalCategory c+ in cat == ConnectorPunctuation++reservedWord :: TokenParser st ()+reservedWord =+ void keyword <|>+ void futureReservedWord <|>+ void nullLiteral <|>+ void booleanLiteral++keyword :: TokenParser st String+keyword =+ choice $ try . string <$>+ [ "break", "case", "catch", "continue", "debugger", "default", "delete"+ , "do", "else", "finally", "for", "function", "if", "in"+ , "instanceof", "new", "return", "this", "throw", "try"+ , "typeof", "var", "void", "while", "with" ]++futureReservedWord :: TokenParser st String+futureReservedWord =+ choice $ try . string <$>+ [ "class", "const", "enum", "export", "extends", "import", "super"+ , "implements", "interface", "let", "package", "private", "protected"+ , "public", "static", "yield" ]++punctuator :: TokenSTParser Punctuator+punctuator = do+ p <- choice $ try . string <$>+ [ "~", "}", "||", "|=", "|", "{"+ , "^=", "^", "]", "[", "?", ">>>="+ , ">>>", ">>=", ">>", ">=", ">", "==="+ , "==", "=", "<=", "<<=", "<<", "<"+ , ";", ":", ".", "-=", "--", "-", ","+ , "+=", "++", "+", "*=", "*", ")", "("+ , "&=", "&&", "&", "%=", "%", "!==", "!=", "!" ]+ if p `elem` ["]", "--", "++", ")"]+ then setLeadingDivAllowed+ else setLeadingDivDisallowed+ return $ Punctuator p++divPunctuator :: TokenSTParser DivPunctuator+divPunctuator = do+ dp <- try (string "/=") <|> string "/"+ setLeadingDivDisallowed+ return $ DivPunctuator dp++literal :: TokenSTParser Literal+literal =+ do { n <- nullLiteral; setLeadingDivAllowed; return $ LiteralNull n } <|>+ do { b <- booleanLiteral; setLeadingDivAllowed; return $ LiteralBool b } <|>+ do { n <- numericLiteral; setLeadingDivAllowed; setLeadingDivAllowed; return $ LiteralNum n } <|>+ do { s <- stringLiteral; setLeadingDivAllowed; return $ LiteralString s } <|>+ do { r <- regularExpressionLiteral; return $ LiteralRegExp r }++nullLiteral :: TokenParser st NullLit+nullLiteral =+ do { void $ string "null"; return NullLit }++booleanLiteral :: TokenParser st BoolLit+booleanLiteral =+ do { void $ string "true"; return $ BoolLit True } <|>+ do { void $ string "false"; return $ BoolLit False }++numericLiteral :: TokenParser st NumLit+numericLiteral =+ do { mv <- hexIntegerLiteral; return $ NumLit $ fromIntegral mv } <|>+ do { mv <- decimalLiteral; return $ NumLit mv }++decimalLiteral :: TokenParser st Double+decimalLiteral =+ do { mv <- try $ do { decimalIntegerLiteral <* char '.' };+ mdv <- optionMaybe decimalDigits; mev <- optionMaybe exponentPart;+ case mdv of+ Nothing -> do+ case mev of+ Nothing -> return $ fromIntegral mv+ Just ev -> return $ (fromIntegral mv) * 10 ^^ ev+ Just (dv, n) -> do+ case mev of+ Nothing ->+ return $ (fromIntegral mv) + (fromIntegral dv) * 10 ^^ (-n)+ Just ev ->+ return $ ((fromIntegral mv) + (fromIntegral dv) * 10 ^^ (-n)) * 10 ^^ ev } <|>+ do { void $ char '.'; (mv, n) <- decimalDigits; mev <- optionMaybe exponentPart;+ case mev of+ Nothing ->+ return $ (fromIntegral mv) * 10 ^^ (-n)+ Just ev -> do+ return $ (fromIntegral mv) * 10 ^^ (ev - n) } <|>+ do { mv <- decimalIntegerLiteral; mev <- optionMaybe exponentPart;+ case mev of+ Nothing -> return $ fromIntegral mv+ Just ev -> return $ (fromIntegral mv) * 10 ^^ ev }++decimalIntegerLiteral :: TokenParser st Int+decimalIntegerLiteral =+ do { void $ char '0'; return 0 } <|>+ do { mv <- nonZeroDigit; mdv <- optionMaybe decimalDigits;+ case mdv of+ Nothing -> return mv+ Just (dv, n) -> do+ return $ mv * 10 ^ n + dv }++decimalDigits :: TokenParser st (Int, Int)+decimalDigits =+ do { dv <- decimalDigit; applyRest decimalDigitsRest (dv, 1) }++decimalDigitsRest :: TokenParser st ((Int, Int) -> TokenParser st (Int, Int))+decimalDigitsRest =+ do { dv <- decimalDigit; return $ \(mv, n) -> applyRest decimalDigitsRest (mv * 10 + dv, n + 1) }++decimalDigit :: TokenParser st Int+decimalDigit =+ do { void $ char '0'; return 0 } <|>+ do { void $ char '1'; return 1 } <|>+ do { void $ char '2'; return 2 } <|>+ do { void $ char '3'; return 3 } <|>+ do { void $ char '4'; return 4 } <|>+ do { void $ char '5'; return 5 } <|>+ do { void $ char '6'; return 6 } <|>+ do { void $ char '7'; return 7 } <|>+ do { void $ char '8'; return 8 } <|>+ do { void $ char '9'; return 9 }++nonZeroDigit :: TokenParser st Int+nonZeroDigit =+ do { void $ char '1'; return 1 } <|>+ do { void $ char '2'; return 2 } <|>+ do { void $ char '3'; return 3 } <|>+ do { void $ char '4'; return 4 } <|>+ do { void $ char '5'; return 5 } <|>+ do { void $ char '6'; return 6 } <|>+ do { void $ char '7'; return 7 } <|>+ do { void $ char '8'; return 8 } <|>+ do { void $ char '9'; return 9 }++exponentPart :: TokenParser st Int+exponentPart =+ do { void $ exponentIndicator; mv <- signedInteger; return mv }++exponentIndicator :: TokenParser st Char+exponentIndicator =+ char 'e' <|> char 'E'++signedInteger :: TokenParser st Int+signedInteger =+ do { (mv, _) <- decimalDigits; return mv } <|>+ do { void $ char '+'; (mv, _) <- decimalDigits; return mv } <|>+ do { void $ char '-'; (mv, _) <- decimalDigits; return (-mv) }++hexIntegerLiteral :: TokenParser st Int+hexIntegerLiteral =+ do { try (void $ string "0x") <|> try (void $ string "0X"); applyRest hexIntegerLiteralRest 0 }++hexIntegerLiteralRest :: TokenParser st (Int -> TokenParser st Int)+hexIntegerLiteralRest =+ do { dv <- hexDigit; return $ \mv -> applyRest hexIntegerLiteralRest (mv * 16 + dv) }++hexDigit :: TokenParser st Int+hexDigit =+ do { void $ char '0'; return 0 } <|>+ do { void $ char '1'; return 1 } <|>+ do { void $ char '2'; return 2 } <|>+ do { void $ char '3'; return 3 } <|>+ do { void $ char '4'; return 4 } <|>+ do { void $ char '5'; return 5 } <|>+ do { void $ char '6'; return 6 } <|>+ do { void $ char '7'; return 7 } <|>+ do { void $ char '8'; return 8 } <|>+ do { void $ char '9'; return 9 } <|>+ do { void $ char 'a' <|> char 'A'; return 10 } <|>+ do { void $ char 'b' <|> char 'B'; return 11 } <|>+ do { void $ char 'c' <|> char 'C'; return 12 } <|>+ do { void $ char 'd' <|> char 'D'; return 13 } <|>+ do { void $ char 'e' <|> char 'E'; return 14 } <|>+ do { void $ char 'f' <|> char 'F'; return 15 }++stringLiteral :: TokenParser st StringLit+stringLiteral =+ do { void $ char '"'; msv <- optionMaybe doubleStringCharacters; void $ char '"';+ case msv of+ Nothing -> return $ StringLit ""+ Just sv -> return $ StringLit sv } <|>+ do { void $ char '\''; msv <- optionMaybe singleStringCharacters; void $ char '\'';+ case msv of+ Nothing -> return $ StringLit ""+ Just sv -> return $ StringLit sv }++doubleStringCharacters :: TokenParser st String+doubleStringCharacters =+ do { cv <- doubleStringCharacter; msv <- optionMaybe doubleStringCharacters;+ case msv of+ Nothing -> return cv+ Just sv -> return $ cv ++ sv }++singleStringCharacters :: TokenParser st String+singleStringCharacters =+ do { cv <- singleStringCharacter; msv <- optionMaybe singleStringCharacters;+ case msv of+ Nothing -> return cv+ Just sv -> return $ cv ++ sv}++doubleStringCharacter :: TokenParser st String+doubleStringCharacter =+ do { notFollowedBy $ char '"' <|> char '\\' <|> lineTerminator; c <- sourceCharacter; return [c] } <|>+ do { void $ char '\\'; c <- escapeSequence; return [c] } <|>+ do { void $ lineContinuation; return "" }++singleStringCharacter :: TokenParser st String+singleStringCharacter =+ do { notFollowedBy $ char '\'' <|> char '\\' <|> lineTerminator; c <- sourceCharacter; return [c] } <|>+ do { void $ char '\\'; c <- escapeSequence; return [c] } <|>+ do { void $ lineContinuation; return "" }++lineContinuation :: TokenParser st String+lineContinuation =+ do { void $ char '\\'; lineTerminatorSequence; return "" }++escapeSequence :: TokenParser st Char+escapeSequence =+ characterEscapeSequence <|>+ do { void $ char '0'; notFollowedBy decimalDigit; return '\0' } <|>+ hexEscapeSequence <|>+ unicodeEscapeSequence++characterEscapeSequence :: TokenParser st Char+characterEscapeSequence =+ do { ec <- singleEscapeCharacter;+ case ec of+ 'b' -> return '\x0008'+ 't' -> return '\x0009'+ 'n' -> return '\x000A'+ 'v' -> return '\x000B'+ 'f' -> return '\x000C'+ 'r' -> return '\x000D'+ '"' -> return '\x0022'+ '\'' -> return '\x0027'+ '\\' -> return '\x005C'+ _ -> error "panic" {- This Should never happen! -} } <|>+ nonEscapeCharacter++singleEscapeCharacter :: TokenParser st Char+singleEscapeCharacter =+ choice $ char <$>+ [ '\'', '"', '\\', 'b', 'f', 'n', 'r', 't', 'v' ]++nonEscapeCharacter :: TokenParser st Char+nonEscapeCharacter =+ do { notFollowedBy $ escapeCharacter <|> void lineTerminator; sourceCharacter }++escapeCharacter :: TokenParser st ()+escapeCharacter =+ void singleEscapeCharacter <|>+ void decimalDigit <|>+ void (char 'x') <|>+ void (char 'u')++hexEscapeSequence :: TokenParser st Char+hexEscapeSequence =+ do { void $ char 'x'; mv1 <- hexDigit; mv2 <- hexDigit;+ return $ chr $ 16 * mv1 + mv2 }++unicodeEscapeSequence :: TokenParser st Char+unicodeEscapeSequence =+ do { void $ char 'u'; mv1 <- hexDigit; mv2 <- hexDigit; mv3 <- hexDigit; mv4 <- hexDigit;+ return $ chr $ 4096 * mv1 + 256 * mv2 + 16 * mv3 + mv4 }++regularExpressionLiteral :: TokenSTParser RegExpLit+regularExpressionLiteral =+ do { void $ char '/'; pattern <- regularExpressionBody; void $ char '/'; flags <- regularExpressionFlags;+ return $ RegExpLit (pattern, flags) }++regularExpressionBody :: TokenParser st String+regularExpressionBody =+ do { c <- regularExpressionFirstChar; s <- regularExpressionChars; return $ c ++ s }++regularExpressionChars :: TokenParser st String+regularExpressionChars =+ do { c <- regularExpressionChar; s <- regularExpressionChars; return $ c ++ s } <|>+ return ""++regularExpressionFirstChar :: TokenParser st String+regularExpressionFirstChar =+ do { notFollowedBy $ char '*' <|> char '\\' <|> char '/' <|> char '['; c <- regularExpressionNonTerminator;+ return [c] } <|>+ do { c <- regularExpressionBackslashSequence; return [c] } <|>+ regularExpressionClass++regularExpressionChar :: TokenParser st String+regularExpressionChar =+ do { notFollowedBy $ char '\\' <|> char '/' <|> char '['; c <- regularExpressionNonTerminator;+ return [c] } <|>+ do { c <- regularExpressionBackslashSequence; return [c] } <|>+ regularExpressionClass++regularExpressionBackslashSequence :: TokenParser st Char+regularExpressionBackslashSequence =+ do { void $ char '\\'; regularExpressionNonTerminator }++regularExpressionNonTerminator :: TokenParser st Char+regularExpressionNonTerminator =+ do { notFollowedBy lineTerminator; sourceCharacter }++regularExpressionClass :: TokenParser st String+regularExpressionClass =+ do { void $ char '['; s <- regularExpressionClassChars; void $ char ']'; return s }++regularExpressionClassChars :: TokenParser st String+regularExpressionClassChars =+ do { c <- regularExpressionClassChar; s <- regularExpressionClassChars; return $ c:s } <|>+ return ""++regularExpressionClassChar :: TokenParser st Char+regularExpressionClassChar =+ do { notFollowedBy $ char ']' <|> char '\\'; regularExpressionNonTerminator } <|>+ regularExpressionBackslashSequence++regularExpressionFlags :: TokenSTParser String+regularExpressionFlags =+ do { c <- identifierPart; s <- regularExpressionFlags; return $ c:s } <|>+ return ""++lexer :: TokenSTParser [(SourcePos, InputElement)]+lexer = (mapMaybe toInputElement) <$>+ (many $ do+ p <- getPosition;+ da <- isLeadingDivAllowed+ edr <- if da+ then Left <$> inputElementDiv+ else Right <$> inputElementRegExp+ return (p, edr))+ where+ isLineTerminator c = c `elem` [ '\x000A', '\x000D', '\x2028', '\x2029' ]+ toInputElement (p, edr) = do+ case edr of+ Left ied -> toInputElementDiv (p, ied)+ Right ier -> toInputElementRegExp (p, ier)+ toInputElementDiv (p, ied) =+ case ied of+ InputElementDivWhiteSpace -> Nothing+ InputElementDivLineTerminator ->+ Just (p, InputElementLineTerminator)+ InputElementDivComment (CommentSingleLine _) ->+ Nothing+ InputElementDivComment (CommentMultiLine s)+ | any isLineTerminator s -> Just (p, InputElementLineTerminator)+ | otherwise -> Nothing+ InputElementDivToken (TokenIdentName i) ->+ Just (p, InputElementIdentName i)+ InputElementDivToken (TokenPunctuator pu) ->+ Just (p, InputElementPunctuator pu)+ InputElementDivToken (TokenNumLit n) ->+ Just (p, InputElementLiteral $ LiteralNum n)+ InputElementDivToken (TokenStringLit s) ->+ Just (p, InputElementLiteral $ LiteralString s)+ InputElementDivDivPunctuator (DivPunctuator s) ->+ Just (p, InputElementPunctuator $ Punctuator s)+ toInputElementRegExp (p, ier) =+ case ier of+ InputElementRegExpWhiteSpace -> Nothing+ InputElementRegExpLineTerminator ->+ Just (p, InputElementLineTerminator)+ InputElementRegExpComment (CommentSingleLine _) -> Nothing+ InputElementRegExpComment (CommentMultiLine s)+ | any isLineTerminator s -> Just (p, InputElementLineTerminator)+ | otherwise -> Nothing+ InputElementRegExpToken (TokenIdentName i) ->+ Just (p, InputElementIdentName i)+ InputElementRegExpToken (TokenPunctuator pu) ->+ Just (p, InputElementPunctuator pu)+ InputElementRegExpToken (TokenNumLit n) ->+ Just (p, InputElementLiteral $ LiteralNum n)+ InputElementRegExpToken (TokenStringLit s) ->+ Just (p, InputElementLiteral $ LiteralString s)+ InputElementRegExpRegExpLit re ->+ Just (p, InputElementLiteral $ LiteralRegExp re)++runLexer :: String -> [(SourcePos, InputElement)]+runLexer s =+ case runParser lexer newTokenState "" s of+ Right l -> l+ Left _ -> []++lexJavaScript :: String -> [(SourcePos, InputElement)]+lexJavaScript input = runLexer input
+ src/Language/JavaScript/Parser.hs view
@@ -0,0 +1,535 @@+module Language.JavaScript.Parser+ ( parseJavaScript ) where++import Control.Applicative ((<*), (*>))++import Text.Parsec++import Language.JavaScript.AST+import Language.JavaScript.Lexer (lexJavaScript)+import Language.JavaScript.Prim+import Language.JavaScript.Util++chainl1' :: (Stream s m t) =>+ ParsecT s u m a -> ParsecT s u m b -> ParsecT s u m (a -> b -> a) -> ParsecT s u m a+chainl1' pa pb op = do+ a <- pa+ rest a+ where+ rest a = do { f <- op; b <- pb; rest (f a b) } <|> return a++primExpr :: JSParser PrimExpr+primExpr =+ do { identName "this" ; return PrimExprThis } <|>+ do { name <- getIdent; return $ PrimExprIdent name} <|>+ do { l <- getLiteral; return $ PrimExprLiteral l } <|>+ do { a <- arrayLit; return $ PrimExprArray a } <|>+ do { o <- objectLit; return $ PrimExprObject o } <|>+ do { punctuator "("; e <- expr; punctuator ")"; return $ PrimExprParens e }++arrayLit :: JSParser ArrayLit+arrayLit =+ try (do { punctuator "["; me <- optionMaybe elision; punctuator "]"; return $ ArrayLitH me }) <|>+ try (do { punctuator "["; el <- elementList; punctuator "]"; return $ ArrayLit el }) <|>+ do { punctuator "[";+ el <- elementList;+ punctuator ",";+ me <- optionMaybe elision;+ punctuator "]";+ return $ ArrayLitT el me }++elementList :: JSParser ElementList+elementList =+ do { me <- optionMaybe elision; ae <- assignExpr; applyRest elementListRest (ElementList me ae) }++elementListRest :: JSParser (ElementList -> JSParser ElementList)+elementListRest =+ do { punctuator ","; me <- optionMaybe elision; ae <- assignExpr; return $ \el -> applyRest elementListRest (ElementListCons el me ae) }++elision :: JSParser Elision+elision =+ do { punctuator ","; applyRest elisionRest ElisionComma }++elisionRest :: JSParser (Elision -> JSParser Elision)+elisionRest =+ do { punctuator ","; return $ \e -> applyRest elisionRest (ElisionCons e) }++objectLit :: JSParser ObjectLit+objectLit =+ try (do { punctuator "{"; punctuator "}"; return ObjectLitEmpty }) <|>+ do { punctuator "{"; pl <- propList; optional $ punctuator ","; punctuator "}"; return $ ObjectLit pl }++propList :: JSParser PropList+propList =+ do { pa <- propAssign; applyRest propListRest (PropListAssign pa) }++propListRest :: JSParser (PropList -> JSParser PropList)+propListRest =+ do { punctuator ","; pa <- propAssign; return $ \pl -> applyRest propListRest (PropListCons pl pa) }++propAssign :: JSParser PropAssign+propAssign =+ do { pn <- propName; punctuator ":"; ae <- assignExpr; return $ PropAssignField pn ae } <|>+ do { identName "get"; pn <- propName; punctuator "("; punctuator ")"; punctuator "{"; fb <- funcBody; punctuator "}"; return $ PropAssignGet pn fb } <|>+ do { identName "set"; pn <- propName; punctuator "("; pl <- propSetParamList; punctuator ")"; punctuator "{"; fb <- funcBody; punctuator "}"; return $ PropAssignSet pn pl fb }++propName :: JSParser PropName+propName =+ do { name <- getIdentName; return $ PropNameId name } <|>+ do { sl <- getStringLit; return $ PropNameStr sl } <|>+ do { nl <- getNumLit; return $ PropNameNum nl }++propSetParamList :: JSParser PropSetParamList+propSetParamList =+ do { i <- getIdent; return $ PropSetParamList i }++memberExpr :: JSParser MemberExpr+memberExpr =+ do { identName "new"; me <- memberExpr; args <- arguments; applyRest memberExprRest (MemberExprNew me args) } <|>+ do { pe <- primExpr; applyRest memberExprRest (MemberExprPrim pe) } <|>+ do { fe <- funcExpr; applyRest memberExprRest (MemberExprFunc fe) }++memberExprRest :: JSParser (MemberExpr -> JSParser MemberExpr)+memberExprRest =+ do { punctuator "["; e <- expr; punctuator "]"; return $ \me -> applyRest memberExprRest (MemberExprArray me e) } <|>+ do { punctuator "."; name <- getIdentName; return $ \me -> applyRest memberExprRest (MemberExprDot me name) }++newExpr :: JSParser NewExpr+newExpr =+ try (do { me <- memberExpr; return $ NewExprMember me }) <|>+ do { identName "new"; ne <- newExpr; return $ NewExprNew ne }++callExpr :: JSParser CallExpr+callExpr =+ do { me <- memberExpr; args <- arguments; applyRest callExprRest (CallExprMember me args) }++callExprRest :: JSParser (CallExpr -> JSParser CallExpr)+callExprRest =+ do { args <- arguments; return $ \ce -> applyRest callExprRest (CallExprCall ce args) } <|>+ do { punctuator "["; e <- expr; punctuator "]"; return $ \ce -> applyRest callExprRest (CallExprArray ce e) } <|>+ do { punctuator "."; name <- getIdentName; return $ \ce -> applyRest callExprRest (CallExprDot ce name) }++arguments :: JSParser Arguments+arguments =+ try (do { punctuator "("; punctuator ")"; return ArgumentsEmpty }) <|>+ do { punctuator "("; al <- argumentList; punctuator ")"; return $ Arguments al }++argumentList :: JSParser ArgumentList+argumentList =+ chainl1'+ (do { ae <- assignExpr; return $ ArgumentList ae })+ assignExpr+ (do { punctuator ","; return ArgumentListCons })++leftExpr :: JSParser LeftExpr+leftExpr =+ try (do { ce <- callExpr; return $ LeftExprCallExpr ce }) <|>+ do { ne <- newExpr; return $ LeftExprNewExpr ne }++postFixExpr :: JSParser PostFixExpr+postFixExpr = do+ le <- leftExpr+ do { punctuator "++"; return $ PostFixExprPostInc le } <|>+ do { punctuator "--"; return $ PostFixExprPostDec le } <|>+ do { return $ PostFixExprLeftExpr le }++uExpr :: JSParser UExpr+uExpr =+ do { identName "delete"; u <- uExpr; return $ UExprDelete u } <|>+ do { identName "void"; u <- uExpr; return $ UExprVoid u } <|>+ do { identName "typeof"; u <- uExpr; return $ UExprTypeOf u } <|>+ do { punctuator "++"; u <- uExpr; return $ UExprDoublePlus u } <|>+ do { punctuator "--"; u <- uExpr; return $ UExprDoubleMinus u } <|>+ do { punctuator "+"; u <- uExpr; return $ UExprUnaryPlus u } <|>+ do { punctuator "-"; u <- uExpr; return $ UExprUnaryMinus u } <|>+ do { punctuator "~"; u <- uExpr; return $ UExprBitNot u } <|>+ do { punctuator "!"; u <- uExpr; return $ UExprNot u } <|>+ do { pe <- postFixExpr; return $ UExprPostFix pe }++multExpr :: JSParser MultExpr+multExpr =+ chainl1'+ (do { u <- uExpr; return $ MultExpr u })+ uExpr+ (do { punctuator "*"; return MultExprMult } <|>+ do { punctuator "/"; return MultExprDiv } <|>+ do { punctuator "%"; return MultExprMod })++addExpr :: JSParser AddExpr+addExpr =+ chainl1'+ (do { m <- multExpr; return $ AddExpr m })+ multExpr+ (do { punctuator "+"; return AddExprAdd } <|>+ do { punctuator "-"; return AddExprSub })++shiftExpr :: JSParser ShiftExpr+shiftExpr =+ chainl1'+ (do { a <- addExpr; return $ ShiftExpr a })+ addExpr+ (do { punctuator "<<"; return ShiftExprLeft } <|>+ do { punctuator ">>"; return ShiftExprRight } <|>+ do { punctuator ">>>"; return ShiftExprRightZero })++relExpr :: JSParser RelExpr+relExpr =+ chainl1'+ (do { s <- shiftExpr; return $ RelExpr s })+ shiftExpr+ (do { punctuator "<"; return RelExprLess } <|>+ do { punctuator ">"; return RelExprGreater } <|>+ do { punctuator "<="; return RelExprLessEq } <|>+ do { punctuator ">="; return RelExprGreaterEq } <|>+ do { identName "instanceof"; return RelExprInstanceOf } <|>+ do { identName "in"; return RelExprIn })++relExprNoIn :: JSParser RelExprNoIn+relExprNoIn =+ chainl1'+ (do { s <- shiftExpr; return $ RelExprNoIn s })+ shiftExpr+ (do { punctuator "<"; return RelExprNoInLess } <|>+ do { punctuator ">"; return RelExprNoInGreater } <|>+ do { punctuator "<="; return RelExprNoInLessEq } <|>+ do { punctuator ">="; return RelExprNoInGreaterEq } <|>+ do { identName "instanceof"; return RelExprNoInInstanceOf })++eqExpr :: JSParser EqExpr+eqExpr =+ chainl1'+ (do { r <- relExpr; return $ EqExpr r })+ relExpr+ (do { punctuator "=="; return EqExprEq } <|>+ do { punctuator "!="; return EqExprNotEq } <|>+ do { punctuator "==="; return EqExprStrictEq } <|>+ do { punctuator "!=="; return EqExprStrictNotEq })++eqExprNoIn :: JSParser EqExprNoIn+eqExprNoIn =+ chainl1'+ (do { r <- relExprNoIn; return $ EqExprNoIn r })+ relExprNoIn+ (do { punctuator "=="; return EqExprNoInEq } <|>+ do { punctuator "!="; return EqExprNoInNotEq } <|>+ do { punctuator "==="; return EqExprNoInStrictEq } <|>+ do { punctuator "!=="; return EqExprNoInStrictNotEq })++bitAndExpr :: JSParser BitAndExpr+bitAndExpr =+ chainl1'+ (do { e <- eqExpr; return $ BitAndExpr e })+ eqExpr+ (do { punctuator "&"; return $ BitAndExprAnd })++bitAndExprNoIn :: JSParser BitAndExprNoIn+bitAndExprNoIn =+ chainl1'+ (do { e <- eqExprNoIn; return $ BitAndExprNoIn e })+ eqExprNoIn+ (do { punctuator "&"; return $ BitAndExprNoInAnd })++bitXorExpr :: JSParser BitXorExpr+bitXorExpr =+ chainl1'+ (do { bae <- bitAndExpr; return $ BitXorExpr bae })+ bitAndExpr+ (do { punctuator "^"; return $ BitXorExprXor })++bitXorExprNoIn :: JSParser BitXorExprNoIn+bitXorExprNoIn =+ chainl1'+ (do { bae <- bitAndExprNoIn; return $ BitXorExprNoIn bae })+ bitAndExprNoIn+ (do { punctuator "^"; return $ BitXorExprNoInXor })++bitOrExpr :: JSParser BitOrExpr+bitOrExpr =+ chainl1'+ (do { bxe <- bitXorExpr; return $ BitOrExpr bxe })+ bitXorExpr+ (do { punctuator "|"; return $ BitOrExprOr })++bitOrExprNoIn :: JSParser BitOrExprNoIn+bitOrExprNoIn =+ chainl1'+ (do { bxe <- bitXorExprNoIn; return $ BitOrExprNoIn bxe })+ bitXorExprNoIn+ (do { punctuator "|"; return $ BitOrExprNoInOr })++logicalAndExpr :: JSParser LogicalAndExpr+logicalAndExpr =+ chainl1'+ (do { boe <- bitOrExpr; return $ LogicalAndExpr boe })+ bitOrExpr+ (do { punctuator "&&"; return $ LogicalAndExprAnd })++logicalAndExprNoIn :: JSParser LogicalAndExprNoIn+logicalAndExprNoIn =+ chainl1'+ (do { boe <- bitOrExprNoIn; return $ LogicalAndExprNoIn boe })+ bitOrExprNoIn+ (do { punctuator "&&"; return $ LogicalAndExprNoInAnd })++logicalOrExpr :: JSParser LogicalOrExpr+logicalOrExpr =+ chainl1'+ (do { lae <- logicalAndExpr; return $ LogicalOrExpr lae })+ logicalAndExpr+ (do { punctuator "||"; return $ LogicalOrExprOr })++logicalOrExprNoIn :: JSParser LogicalOrExprNoIn+logicalOrExprNoIn =+ chainl1'+ (do { lae <- logicalAndExprNoIn; return $ LogicalOrExprNoIn lae })+ logicalAndExprNoIn+ (do { punctuator "||"; return $ LogicalOrExprNoInOr })++condExpr :: JSParser CondExpr+condExpr = do+ loe <- logicalOrExpr+ do { try $ do { punctuator "?"; }; ae1 <- assignExpr; punctuator ":"; ae2 <- assignExpr; return $ CondExprIf loe ae1 ae2 } <|>+ do { return $ CondExpr loe }++condExprNoIn :: JSParser CondExprNoIn+condExprNoIn = do+ loe <- logicalOrExprNoIn;+ do { try $ do { punctuator "?"; }; ae1 <- assignExpr; punctuator ":"; ae2 <- assignExpr; return $ CondExprNoInIf loe ae1 ae2 } <|>+ do { return $ CondExprNoIn loe }++assignExpr :: JSParser AssignExpr+assignExpr =+ try (do { le <- leftExpr; ao <- assignOp; ae <- assignExpr; return $ AssignExprAssign le ao ae }) <|>+ do { ce <- condExpr; return $ AssignExprCondExpr ce }++assignExprNoIn :: JSParser AssignExprNoIn+assignExprNoIn =+ try (do { le <- leftExpr; ao <- assignOp; ae <- assignExprNoIn; return $ AssignExprNoInAssign le ao ae }) <|>+ do { ce <- condExprNoIn; return $ AssignExprNoInCondExpr ce }++assignOp :: JSParser AssignOp+assignOp =+ do { punctuator "="; return AssignOpNormal } <|>+ do { punctuator "*="; return AssignOpMult } <|>+ do { punctuator "/="; return AssignOpDiv } <|>+ do { punctuator "%="; return AssignOpMod } <|>+ do { punctuator "+="; return AssignOpPlus } <|>+ do { punctuator "-="; return AssignOpMinus } <|>+ do { punctuator "<<="; return AssignOpShiftLeft } <|>+ do { punctuator ">>="; return AssignOpShiftRight } <|>+ do { punctuator ">>>="; return AssignOpShiftRightZero } <|>+ do { punctuator "&="; return AssignOpBitAnd } <|>+ do { punctuator "^="; return AssignOpBitXor } <|>+ do { punctuator "|="; return AssignOpBitOr }++expr :: JSParser Expr+expr =+ chainl1'+ (do { ae <- assignExpr; return $ Expr ae })+ assignExpr+ (do { punctuator ","; return ExprCons })++exprNoIn :: JSParser ExprNoIn+exprNoIn =+ chainl1'+ (do { ae <- assignExprNoIn; return $ ExprNoIn ae })+ assignExprNoIn+ (do { punctuator ","; return ExprNoInCons })++stmt :: JSParser Stmt+stmt =+ do { b <- block; return $ StmtBlock b } <|>+ do { vs <- varStmt; return $ StmtVar vs } <|>+ do { es <- emptyStmt; return $ StmtEmpty es } <|>+ try (do { es <- exprStmt; return $ StmtExpr es }) <|>+ do { ic <- contStmt; return $ StmtCont ic } <|>+ do { is <- ifStmt; return $ StmtIf is } <|>+ do { is <- itStmt; return $ StmtIt is } <|>+ do { bs <- breakStmt; return $ StmtBreak bs } <|>+ do { rs <- returnStmt; return $ StmtReturn rs } <|>+ do { ws <- withStmt; return $ StmtWith ws } <|>+ do { ss <- switchStmt; return $ StmtSwitch ss } <|>+ do { ts <- throwStmt; return $ StmtThrow ts } <|>+ do { ts <- tryStmt; return $ StmtTry ts } <|>+ do { ds <- dbgStmt; return $ StmtDbg ds } <|>+ do { ls <- labelledStmt; return $ StmtLabelled ls }++block :: JSParser Block+block =+ do { punctuator "{"; msl <- optionMaybe stmtList; punctuator "}"; return $ Block msl }++stmtList :: JSParser StmtList+stmtList =+ chainl1'+ (do { s <- stmt; return $ StmtList s })+ stmt+ (do { return StmtListCons })++varStmt :: JSParser VarStmt+varStmt =+ do { identName "var"; vdl <- varDeclList; return $ VarStmt vdl }++varDeclList :: JSParser VarDeclList+varDeclList =+ chainl1'+ (do { vd <- varDecl; return $ VarDeclList vd})+ varDecl+ (do { punctuator ","; return $ VarDeclListCons })++varDeclListNoIn :: JSParser VarDeclListNoIn+varDeclListNoIn =+ chainl1'+ (do { vd <- varDeclNoIn; return $ VarDeclListNoIn vd})+ varDeclNoIn+ (do { punctuator ","; return $ VarDeclListNoInCons})++varDecl :: JSParser VarDecl+varDecl =+ do { i <- getIdent; mInit <- optionMaybe initialiser; return $ VarDecl i mInit }++varDeclNoIn :: JSParser VarDeclNoIn+varDeclNoIn =+ do { i <- getIdent; mInit <- optionMaybe initialiserNoIn; return $ VarDeclNoIn i mInit }++initialiser :: JSParser Initialiser+initialiser =+ do { punctuator "="; ae <- assignExpr; return $ Initialiser ae }++initialiserNoIn :: JSParser InitialiserNoIn+initialiserNoIn =+ do { punctuator "="; ae <- assignExprNoIn; return $ InitialiserNoIn ae }++emptyStmt :: JSParser EmptyStmt+emptyStmt =+ do { punctuator ";"; return EmptyStmt }++exprStmt :: JSParser ExprStmt+exprStmt =+ do { notFollowedBy (try $ punctuator "{" <|> identName "function"); e <- expr; autoSemi; return $ ExprStmt e }++ifStmt :: JSParser IfStmt+ifStmt =+ try (do { identName "if"; punctuator "("; e <- expr; punctuator ")"; s1 <- stmt; identName "else"; s2 <- stmt; return $ IfStmtIfElse e s1 s2 }) <|>+ do { identName "if"; punctuator "("; e <- expr; punctuator ")"; s <- stmt; return $ IfStmtIf e s }++itStmt :: JSParser ItStmt+itStmt =+ try (do { identName "do"; s <- stmt; identName "while"; punctuator "("; e <- expr; punctuator ")"; return $ ItStmtDoWhile s e }) <|>+ try (do { identName "while"; punctuator "("; e <- expr; punctuator ")"; s <- stmt; return $ ItStmtWhile e s }) <|>+ try (do { identName "for"; punctuator "("; me1 <- optionMaybe exprNoIn; punctuator ";"; me2 <- optionMaybe expr; punctuator ";"; me3 <- optionMaybe expr; punctuator ")"; s <- stmt; return $ ItStmtFor me1 me2 me3 s }) <|>+ try (do { identName "for"; punctuator "("; identName "var"; vdl <- varDeclListNoIn; punctuator ";"; me1 <- optionMaybe expr; punctuator ";"; me2 <- optionMaybe expr; punctuator ")"; s <- stmt; return $ ItStmtForVar vdl me1 me2 s }) <|>+ do { identName "for"; punctuator "("; le <- leftExpr; identName "in"; e <- expr; punctuator ")"; s <- stmt; return $ ItStmtForIn le e s } <|>+ do { identName "for"; punctuator "("; identName "var"; vd <- varDeclNoIn; identName "in"; e <- expr; punctuator ")"; s <- stmt; return $ ItStmtForVarIn vd e s }++contStmt :: JSParser ContStmt+contStmt =+ try (do { identName "continue"; autoSemi; return ContStmt }) <|>+ do { identName "continue"; noLineTerminatorHere; i <- getIdent; autoSemi; return $ ContStmtLabelled i }++breakStmt :: JSParser BreakStmt+breakStmt =+ try (do { identName "break"; autoSemi; return BreakStmt }) <|>+ do { identName "break"; noLineTerminatorHere; i <- getIdent; autoSemi; return $ BreakStmtLabelled i }++returnStmt :: JSParser ReturnStmt+returnStmt =+ try (do { identName "return"; autoSemi; return ReturnStmt }) <|>+ do { identName "return"; noLineTerminatorHere; e <- expr; autoSemi; return $ ReturnStmtExpr e }++withStmt :: JSParser WithStmt+withStmt =+ do { identName "with"; punctuator "("; e <- expr; punctuator ")"; s <- stmt; return $ WithStmt e s }++switchStmt :: JSParser SwitchStmt+switchStmt =+ do { identName "switch"; punctuator "("; e <- expr; punctuator ")"; cb <- caseBlock; return $ SwitchStmt e cb }++caseBlock :: JSParser CaseBlock+caseBlock =+ try (do { punctuator "{"; mcc <- optionMaybe caseClauses; punctuator "}"; return $ CaseBlock mcc }) <|>+ do { punctuator "{"; mcc1 <- optionMaybe caseClauses; dc <- defaultClause; mcc2 <- optionMaybe caseClauses; punctuator "}"; return $ CaseBlockDefault mcc1 dc mcc2 }++caseClauses :: JSParser CaseClauses+caseClauses =+ chainl1'+ (do { cc <- caseClause; return $ CaseClauses cc })+ caseClause+ (do { return $ CaseClausesCons })++caseClause :: JSParser CaseClause+caseClause =+ do { identName "case"; e <- expr; punctuator ":"; msl <- optionMaybe stmtList; return $ CaseClause e msl }++defaultClause :: JSParser DefaultClause+defaultClause =+ do { identName "default"; punctuator ":"; msl <- optionMaybe stmtList; return $ DefaultClause msl }++labelledStmt :: JSParser LabelledStmt+labelledStmt =+ do { i <- getIdent; punctuator ":"; s <- stmt; return $ LabelledStmt i s }++throwStmt :: JSParser ThrowStmt+throwStmt =+ do { identName "throw"; noLineTerminatorHere; e <- expr; autoSemi; return $ ThrowStmt e }++tryStmt :: JSParser TryStmt+tryStmt = do+ identName "try"+ b <- block+ do { f <- finally; return $ TryStmtBF b f } <|>+ do { c <- catch;+ do { f <- finally; return $ TryStmtBCF b c f } <|>+ do { return $ TryStmtBC b c }+ }++catch :: JSParser Catch+catch =+ do { identName "catch"; punctuator "("; i <- getIdent; punctuator ")"; b <- block; return $ Catch i b }++finally :: JSParser Finally+finally =+ do { identName "finally"; b <- block; return $ Finally b }++dbgStmt :: JSParser DbgStmt+dbgStmt =+ do { identName "debugger"; autoSemi; return DbgStmt }++funcDecl :: JSParser FuncDecl+funcDecl =+ do { identName "function"; i <- getIdent; punctuator "("; mfpl <- optionMaybe formalParamList; punctuator ")"; punctuator "{"; fb <- funcBody; punctuator "}"; return $ FuncDecl i mfpl fb }++funcExpr :: JSParser FuncExpr+funcExpr =+ do { identName "function"; mi <- optionMaybe getIdent; punctuator "("; mfpl <- optionMaybe formalParamList; punctuator ")"; punctuator "{"; fb <- funcBody; punctuator "}"; return $ FuncExpr mi mfpl fb }++formalParamList :: JSParser FormalParamList+formalParamList =+ chainl1'+ (do { i <- getIdent; return $ FormalParamList i })+ getIdent+ (do { punctuator ","; return $ FormalParamListCons })++funcBody :: JSParser FuncBody+funcBody =+ do { mse <- optionMaybe sourceElements; return $ FuncBody mse }++program :: JSParser Program+program =+ do { mse <- optionMaybe sourceElements; return $ Program mse }++sourceElements :: JSParser SourceElements+sourceElements =+ chainl1'+ (do { se <- sourceElement; return $ SourceElements se })+ sourceElement+ (do { return SourceElementsCons })++sourceElement :: JSParser SourceElement+sourceElement =+ do { s <- stmt; return $ SourceElementStmt s } <|>+ do { fd <- funcDecl; return $ SourceElementFuncDecl fd }++parseJavaScript :: String -> Either ParseError Program+parseJavaScript input =+ let p = many lineTerminator *> program <* many lineTerminator <* eof+ in runParser p newJSPState "" $ lexJavaScript input
+ src/Language/JavaScript/Prim.hs view
@@ -0,0 +1,107 @@+module Language.JavaScript.Prim where++import Control.Monad (guard, void)++import Text.Parsec ((<|>),+ SourcePos,+ eof, many)+import Text.Parsec.Prim (getState, lookAhead, modifyState)+import Text.Parsec.Token (GenLanguageDef(..))+import Text.ParserCombinators.Parsec.Prim (GenParser)+import qualified Text.ParserCombinators.Parsec.Prim as Parsec (token)++import Language.JavaScript.AST+import Language.JavaScript.Lexer hiding (token, lineTerminator, punctuator)++data JSPState+ = JSPState+ { jspStateNLFlag :: Bool }++getNLFlag :: JSParser Bool+getNLFlag = do { s <- getState; return $ jspStateNLFlag s }+setNLFlag :: JSParser ()+setNLFlag = modifyState $ \s -> s { jspStateNLFlag = True }+unsetNLFlag :: JSParser ()+unsetNLFlag = modifyState $ \s -> s { jspStateNLFlag = False }++newJSPState :: JSPState+newJSPState = JSPState {+ jspStateNLFlag = False }++type JSParser a = GenParser (SourcePos, InputElement) JSPState a++lexeme :: JSParser a -> JSParser a+lexeme p =+ do { x <- p; unsetNLFlag; void $ many lineTerminator; return x }++mytoken :: (InputElement -> Maybe a) -> JSParser a+mytoken test =+ Parsec.token showTok posFromTok testTok+ where+ showTok (pos, t) = show t+ posFromTok (pos, t) = pos+ testTok (pos, t) = test t++equal :: InputElement -> JSParser ()+equal test = mytoken (\tok -> if tok == test then Just () else Nothing)++lineTerminator :: JSParser ()+lineTerminator =+ do { equal InputElementLineTerminator; setNLFlag }++noLineTerminatorHere :: JSParser ()+noLineTerminatorHere =+ do { nl <- getNLFlag; guard (not nl) }++priorNL :: JSParser ()+priorNL =+ do { nl <- getNLFlag; guard nl }++autoSemi :: JSParser ()+autoSemi =+ punctuator ";" <|>+ priorNL <|>+ void (lookAhead $ punctuator "}") <|>+ eof++identName :: String -> JSParser ()+identName s = lexeme $ equal $ InputElementIdentName $ IdentName s++getIdentName :: JSParser IdentName+getIdentName = lexeme $ mytoken get+ where+ get (InputElementIdentName i) = Just i+ get _ = Nothing++getIdent :: JSParser Ident+getIdent = lexeme $ mytoken get+ where+ get (InputElementIdentName i@(IdentName n)) =+ if n `elem` reservedNames javaScript+ then Nothing+ else Just $ Ident i+ get _ = Nothing++punctuator :: String -> JSParser ()+punctuator p = lexeme $ equal $ InputElementPunctuator $ Punctuator p++getLiteral :: JSParser Literal+getLiteral = lexeme $ mytoken get+ where+ get (InputElementLiteral l) = Just l+ get (InputElementIdentName (IdentName "null")) = Just $ LiteralNull NullLit+ get (InputElementIdentName (IdentName "true")) = Just $ LiteralBool $ BoolLit True+ get (InputElementIdentName (IdentName "false")) = Just $ LiteralBool $ BoolLit False+ get _ = Nothing++getNumLit :: JSParser NumLit+getNumLit = lexeme $ mytoken get+ where+ get (InputElementLiteral (LiteralNum n)) = Just n+ get _ = Nothing++getStringLit :: JSParser StringLit+getStringLit = lexeme $ mytoken get+ where+ get (InputElementLiteral (LiteralString s)) = Just s+ get _ = Nothing
+ src/Language/JavaScript/String.hs view
@@ -0,0 +1,67 @@+module Language.JavaScript.String+ where++import Control.Applicative ((<*), (<$>))+import Control.Monad (void)++import Text.Parsec+import Text.ParserCombinators.Parsec.Char++import Language.JavaScript.Lexer++stringNumericLiteral :: CharParser st Double+stringNumericLiteral = do+ mb <- optional strWhiteSpace+ do { n <- strNumericLiteral; optional strWhiteSpace; return n } <|>+ do { return 0 }++strWhiteSpace :: CharParser st ()+strWhiteSpace =+ do { strWhiteSpaceChar; void $ optionMaybe strWhiteSpace }++strWhiteSpaceChar :: CharParser st ()+strWhiteSpaceChar = void $+ whiteSpace <|>+ lineTerminator++strNumericLiteral :: CharParser st Double+strNumericLiteral =+ (fromIntegral <$> hexIntegerLiteral) <|>+ strDecimalLiteral++strDecimalLiteral :: CharParser st Double+strDecimalLiteral =+ strUnsignedDecimalLiteral <|>+ do { void $ char '+'; strUnsignedDecimalLiteral } <|>+ do { void $ char '-'; mv <- strUnsignedDecimalLiteral;+ if mv == 0+ then return 0+ else return (-mv) }++strUnsignedDecimalLiteral :: CharParser st Double+strUnsignedDecimalLiteral =+ do { void $ string "Infinity"; return 0 } <|>+ do { (mv, _) <- try $ do { decimalDigits <* char '.' };+ mdv <- optionMaybe decimalDigits;+ mev <- optionMaybe exponentPart;+ case (mdv, mev) of+ (Nothing, Nothing) -> return (fromIntegral mv)+ (Just (dv, n), Nothing) ->+ return $ (fromIntegral mv) + (fromIntegral dv) * 10 ^^ (-n)+ (Nothing, Just ev) -> return $ (fromIntegral mv) * 10 ^^ ev+ (Just (dv, n), Just ev) ->+ return $ ((fromIntegral mv) + (fromIntegral dv) * 10 ^^ (-n)) * 10 ^^ ev} <|>+ do { void $ char '.'; (dv, n) <- decimalDigits; mev <- optionMaybe exponentPart;+ case mev of+ Nothing -> return $ (fromIntegral dv) * 10 ^^ (-n)+ Just ev -> return $ (fromIntegral dv) * 10 ^^ (ev - n) } <|>+ do { (dv, _) <- decimalDigits; mev <- optionMaybe exponentPart;+ case mev of+ Nothing -> return (fromIntegral dv)+ Just ev -> return $ (fromIntegral dv) * 10 ^^ ev }++parseString :: String -> Maybe Double+parseString s =+ case runParser stringNumericLiteral () "" s of+ Right l -> Just l+ Left _ -> Nothing
+ src/Language/JavaScript/SubType.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverlappingInstances,+ FlexibleInstances,+ IncoherentInstances,+ MultiParamTypeClasses,+ TypeOperators,+ TypeSynonymInstances #-}++module Language.JavaScript.SubType+ where++import Control.Monad (join)++type a + b = Either a b+infixr 6 +++class SubType sub sup where+ inj :: sub -> sup+ prj :: sup -> Maybe sub++instance SubType a a where+ inj = id+ prj = Just++instance SubType a (a + b) where+ inj = Left+ prj (Left x) = Just x+ prj _ = Nothing++instance (SubType a c) => SubType a (b + c) where+ inj = Right . inj+ prj (Right c) = prj c+ prj _ = Nothing++instance (SubType b d) => SubType (a + b) (a + c + d) where+ inj (Left a) = Left a+ inj (Right b) = Right . Right $ inj b+ prj (Left a) = Just (Left a)+ prj (Right (Left _)) = Nothing+ prj (Right (Right d)) = Right `fmap` prj d++instance SubType a b => SubType a (Maybe b) where+ inj = Just . inj+ prj a = join $ fmap prj a
+ src/Language/JavaScript/Util.hs view
@@ -0,0 +1,12 @@+module Language.JavaScript.Util+ where++import Text.Parsec++applyRest :: Stream s m t =>+ ParsecT s u m (b -> ParsecT s u m b) -> b -> ParsecT s u m b+applyRest pr a = do+ mr <- optionMaybe $ try pr+ case mr of+ Just r -> r a+ Nothing -> return a