Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

WebBits-0.16

The syntax and parser treat l-values correctly.
  • Loading branch information...
commit efedb13c2f09c8a878c83caf7e30a33b89938f0e 1 parent 2edc346
Arjun Guha authored
View
9 WebBits.cabal
@@ -1,5 +1,5 @@
Name: WebBits
-Version: 0.15
+Version: 0.16
Cabal-Version: >= 1.2.3
Copyright: Copyright (c) 2007-2009 Arjun Guha and Spiridon Eliopoulos
License: LGPL
@@ -31,7 +31,12 @@ Library
Hs-Source-Dirs:
src
Build-Depends:
- base>=4, mtl>=1.1.0.1, parsec<3.0.0, pretty>=0.1, containers>=0.1, syb>=0.1
+ base >= 4,
+ mtl >= 1.1.0.1,
+ parsec < 3.0.0,
+ pretty>=0.1,
+ containers >= 0.1,
+ syb >= 0.1
ghc-options:
-fwarn-incomplete-patterns
Extensions:
View
12 src/BrownPLT/JavaScript/Environment.hs
@@ -43,6 +43,13 @@ unions ps = Partial (M.unions (map partialLocals ps))
javascript :: JavaScript SourcePos -> Partial
javascript (Script _ ss) = unions (map stmt ss)
+
+lvalue :: LValue SourcePos -> Partial
+lvalue lv = case lv of
+ LVar p x -> ref (Id p x)
+ LDot _ e _ -> expr e
+ LBracket _ e1 e2 -> unions [expr e1, expr e2]
+
expr :: Expression SourcePos -> Partial
expr e = case e of
StringLit _ _ -> empty
@@ -58,12 +65,11 @@ expr e = case e of
DotRef _ e _ -> expr e
BracketRef _ e1 e2 -> unions [expr e1, expr e2]
NewExpr _ e1 es -> unions [expr e1, unions $ map expr es]
- PostfixExpr _ _ e -> expr e
PrefixExpr _ _ e -> expr e
InfixExpr _ _ e1 e2 -> unions [expr e1, expr e2]
CondExpr _ e1 e2 e3 -> unions [expr e1, expr e2, expr e3]
- AssignExpr _ _ (VarRef _ id) e -> unions [ref id, expr e]
- AssignExpr _ _ e1 e2 -> unions [expr e1, expr e2]
+ AssignExpr _ _ lv e -> unions [lvalue lv, expr e]
+ UnaryAssignExpr _ _ lv -> lvalue lv
ParenExpr _ e -> expr e
ListExpr _ es -> unions (map expr es)
CallExpr _ e es -> unions [expr e, unions $ map expr es]
View
25 src/BrownPLT/JavaScript/Instances.hs
@@ -39,6 +39,12 @@ instance Functor Prop where
fmap f (PropString a s) = PropString (f a) s
fmap f (PropNum a n) = PropNum (f a) n
+instance Functor LValue where
+ fmap f lv = case lv of
+ LVar a x -> LVar (f a) x
+ LDot a e x -> LDot (f a) (fmap f e) x
+ LBracket a e1 e2 -> LBracket (f a) (fmap f e1) (fmap f e2)
+
instance Functor Expression where
fmap f expression =
case expression of
@@ -56,11 +62,11 @@ instance Functor Expression where
DotRef a e id -> DotRef (f a) (fmap f e) (fmap f id)
BracketRef a e1 e2 -> BracketRef (f a) (fmap f e1) (fmap f e2)
NewExpr a e es -> NewExpr (f a) (fmap f e) (map (fmap f) es)
- PostfixExpr a op e -> PostfixExpr (f a) op (fmap f e)
PrefixExpr a op e -> PrefixExpr (f a) op (fmap f e)
InfixExpr a op e1 e2 -> InfixExpr (f a) op (fmap f e1) (fmap f e2)
CondExpr a e1 e2 e3 -> CondExpr (f a) (fmap f e1) (fmap f e2) (fmap f e3)
AssignExpr a op e1 e2 -> AssignExpr (f a) op (fmap f e1) (fmap f e2)
+ UnaryAssignExpr a op e -> UnaryAssignExpr (f a) op (fmap f e)
ParenExpr a e -> ParenExpr (f a) (fmap f e)
ListExpr a es -> ListExpr (f a) (map (fmap f) es)
CallExpr a e es -> CallExpr (f a) (fmap f e) (map (fmap f) es)
@@ -122,6 +128,12 @@ instance Foldable Prop where
foldr f b (PropId a id) = f a (foldr f b id)
foldr f b (PropString a _) = f a b
foldr f b (PropNum a _) = f a b
+
+instance Foldable LValue where
+ foldr f b (LVar a x) = f a b
+ foldr f b (LDot a e x) = f a (foldr f b e)
+ foldr f b (LBracket a e1 e2) = f a (foldr f (foldr f b e2) e1)
+
instance Foldable Expression where
-- foldr:: (a -> b -> b) -> b -> Expression a -> b
@@ -141,11 +153,11 @@ instance Foldable Expression where
DotRef a e id -> f a (foldr f (foldr f b id) e)
BracketRef a e1 e2 -> f a (foldr f (foldr f b e2) e1)
NewExpr a e es -> f a (foldr f (Prelude.foldr (flip $ foldr f) b es) e)
- PostfixExpr a _ e -> f a $ foldr f b e
PrefixExpr a _ e -> f a $ foldr f b e
InfixExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1
CondExpr a e1 e2 e3 -> f a $ foldr f (foldr f (foldr f b e3) e2) e1
AssignExpr a _ e1 e2 -> f a $ foldr f (foldr f b e2) e1
+ UnaryAssignExpr a _ lv -> f a (foldr f b lv)
ParenExpr a e -> f a $ foldr f b e
ListExpr a es -> f a $ Prelude.foldr (flip $ foldr f) b es
CallExpr a e es -> f a $ foldr f (Prelude.foldr (flip $ foldr f) b es) e
@@ -204,6 +216,12 @@ instance Traversable Prop where
traverse f (PropId a id) = PropId <$> f a <*> traverse f id
traverse f (PropString a s) = PropString <$> f a <*> pure s
traverse f (PropNum a n) = PropNum <$> f a <*> pure n
+
+instance Traversable LValue where
+ traverse f lv = case lv of
+ LVar a x -> LVar <$> f a <*> pure x
+ LDot a e x -> LDot <$> f a <*> traverse f e <*> pure x
+ LBracket a e1 e2 -> LBracket <$> f a <*> traverse f e1 <*> traverse f e2
instance Traversable Expression where
traverse f expression =
@@ -224,7 +242,6 @@ instance Traversable Expression where
DotRef a e id -> DotRef <$> f a <*> traverse f e <*> traverse f id
BracketRef a e es -> BracketRef <$> f a <*> traverse f e <*> traverse f es
NewExpr a e es -> NewExpr <$> f a <*> traverse f e <*> ltraverse f es
- PostfixExpr a op e -> PostfixExpr <$> f a <*> pure op <*> traverse f e
PrefixExpr a op e -> PrefixExpr <$> f a <*> pure op <*> traverse f e
InfixExpr a op e1 e2 -> InfixExpr <$> f a <*> pure op <*> traverse f e1
<*> traverse f e2
@@ -232,6 +249,8 @@ instance Traversable Expression where
CondExpr <$> f a <*> traverse f e1 <*> traverse f e2 <*> traverse f e3
AssignExpr a op e1 e2 -> AssignExpr <$> f a <*> pure op <*> traverse f e1
<*> traverse f e2
+ UnaryAssignExpr a op e ->
+ UnaryAssignExpr <$> f a <*> pure op <*> traverse f e
ParenExpr a e -> ParenExpr <$> f a <*> traverse f e
ListExpr a es -> ListExpr <$> f a <*> ltraverse f es
CallExpr a e es -> CallExpr <$> f a <*> traverse f e <*> ltraverse f es
View
132 src/BrownPLT/JavaScript/Parser.hs
@@ -12,7 +12,7 @@ module BrownPLT.JavaScript.Parser
, parseStatement
, StatementParser
, ExpressionParser
- , parseAssignExpr
+ , assignExpr
) where
import BrownPLT.JavaScript.Lexer hiding (identifier)
@@ -401,7 +401,7 @@ parseObjectLit =
<|> (liftM2 PropId getPosition identifier)
<|> (liftM2 PropNum getPosition decimal)
colon
- val <- parseAssignExpr
+ val <- assignExpr
return (name,val)
in do pos <- getPosition
props <- braces (parseProp `sepEndBy` comma) <?> "object literal"
@@ -520,35 +520,8 @@ makeInfixExpr str constr = Infix parser AssocLeft where
reservedOp str
return (InfixExpr pos constr) -- points-free, returns a function
-makePrefixExpr str constr = Prefix parser where
- parser = do
- pos <- getPosition
- (reservedOp str <|> reserved str)
- return (PrefixExpr pos constr) -- points-free, returns a function
-
-mkPrefix operator constr = Prefix $ do
- pos <- getPosition
- operator
- return (\operand -> PrefixExpr pos constr operand)
-
-makePostfixExpr str constr = Postfix parser where
- parser = do
- pos <- getPosition
- (reservedOp str <|> reserved str)
- return (PostfixExpr pos constr) -- points-free, returns a function
-
-prefixIncDecExpr = do
- pos <- getPosition
- op <- optionMaybe $ (reservedOp "++" >> return PrefixInc) <|>
- (reservedOp "--" >> return PrefixDec)
- case op of
- Nothing -> parseSimpleExpr Nothing
- Just op -> do
- innerExpr <- parseSimpleExpr Nothing -- TODO: must be an l-val, I think
- return (PrefixExpr pos op innerExpr)
-- apparently, expression tables can't handle immediately-nested prefixes
-
parsePrefixedExpr = do
pos <- getPosition
op <- optionMaybe $ (reservedOp "!" >> return PrefixLNot) <|>
@@ -561,7 +534,7 @@ parsePrefixedExpr = do
(reserved "void" >> return PrefixVoid) <|>
(reserved "delete" >> return PrefixDelete)
case op of
- Nothing -> prefixIncDecExpr -- new is treated as a simple expr
+ Nothing -> unaryAssignExpr
Just op -> do
innerExpr <- parsePrefixedExpr
return (PrefixExpr pos op innerExpr)
@@ -569,10 +542,6 @@ parsePrefixedExpr = do
exprTable:: [[Operator Char st ParsedExpression]]
exprTable =
[
- [makePrefixExpr "++" PrefixInc,
- makePostfixExpr "++" PostfixInc],
- [makePrefixExpr "--" PrefixDec,
- makePostfixExpr "--" PostfixDec],
[makeInfixExpr "*" OpMul, makeInfixExpr "/" OpDiv, makeInfixExpr "%" OpMod],
[makeInfixExpr "+" OpAdd, makeInfixExpr "-" OpSub],
[makeInfixExpr "<<" OpLShift, makeInfixExpr ">>" OpSpRShift,
@@ -588,18 +557,53 @@ exprTable =
[makeInfixExpr "==" OpEq, makeInfixExpr "!=" OpNEq,
makeInfixExpr "===" OpStrictEq, makeInfixExpr "!==" OpStrictNEq]
]
-
+
parseExpression' =
buildExpressionParser exprTable parsePrefixedExpr <?> "simple expression"
---{{{ Parsing ternary operators: left factored
+asLValue :: SourcePos
+ -> Expression SourcePos
+ -> CharParser st (LValue SourcePos)
+asLValue p' e = case e of
+ VarRef p (Id _ x) -> return (LVar p x)
+ DotRef p e (Id _ x) -> return (LDot p e x)
+ BracketRef p e1 e2 -> return (LBracket p e1 e2)
+ otherwise -> fail $ "expeceted l-value at " ++ show p'
+
+lvalue :: CharParser st (LValue SourcePos)
+lvalue = do
+ p <- getPosition
+ e <- parseSimpleExpr Nothing
+ asLValue p e
+
+
+unaryAssignExpr :: CharParser st ParsedExpression
+unaryAssignExpr = do
+ p <- getPosition
+ let prefixInc = do
+ reservedOp "++"
+ liftM (UnaryAssignExpr p PrefixInc) lvalue
+ let prefixDec = do
+ reservedOp "--"
+ liftM (UnaryAssignExpr p PrefixDec) lvalue
+ let postfixInc e = do
+ reservedOp "++"
+ liftM (UnaryAssignExpr p PostfixInc) (asLValue p e)
+ let postfixDec e = do
+ reservedOp "--"
+ liftM (UnaryAssignExpr p PostfixDec) (asLValue p e)
+ let other = do
+ e <- parseSimpleExpr Nothing
+ postfixInc e <|> postfixDec e <|> return e
+ prefixInc <|> prefixDec <|> other
+
parseTernaryExpr':: CharParser st (ParsedExpression,ParsedExpression)
parseTernaryExpr' = do
reservedOp "?"
- l <- parseAssignExpr
+ l <- assignExpr
colon
- r <- parseAssignExpr
+ r <- assignExpr
return $(l,r)
parseTernaryExpr:: ExpressionParser st
@@ -610,37 +614,43 @@ parseTernaryExpr = do
Nothing -> return e
Just (l,r) -> do p <- getPosition
return $ CondExpr p e l r
---}}}
--- Parsing assignment operations.
-makeAssignExpr str constr = Infix parser AssocRight where
- parser:: CharParser st (ParsedExpression -> ParsedExpression -> ParsedExpression)
- parser = do
- pos <- getPosition
- reservedOp str
- return (AssignExpr pos constr)
-
-assignTable:: [[Operator Char st ParsedExpression]]
-assignTable = [
- [makeAssignExpr "=" OpAssign, makeAssignExpr "+=" OpAssignAdd,
- makeAssignExpr "-=" OpAssignSub, makeAssignExpr "*=" OpAssignMul,
- makeAssignExpr "/=" OpAssignDiv, makeAssignExpr "%=" OpAssignMod,
- makeAssignExpr "<<=" OpAssignLShift, makeAssignExpr ">>=" OpAssignSpRShift,
- makeAssignExpr ">>>=" OpAssignZfRShift, makeAssignExpr "&=" OpAssignBAnd,
- makeAssignExpr "^=" OpAssignBXor, makeAssignExpr "|=" OpAssignBOr
- ]]
+assignOp :: CharParser st AssignOp
+assignOp =
+ (reservedOp "=" >> return OpAssign) <|>
+ (reservedOp "+=" >> return OpAssignAdd) <|>
+ (reservedOp "-=" >> return OpAssignSub) <|>
+ (reservedOp "*=" >> return OpAssignMul) <|>
+ (reservedOp "/=" >> return OpAssignDiv) <|>
+ (reservedOp "%=" >> return OpAssignMod) <|>
+ (reservedOp "<<=" >> return OpAssignLShift) <|>
+ (reservedOp ">>=" >> return OpAssignSpRShift) <|>
+ (reservedOp ">>>=" >> return OpAssignZfRShift) <|>
+ (reservedOp "&=" >> return OpAssignBAnd) <|>
+ (reservedOp "^=" >> return OpAssignBXor) <|>
+ (reservedOp "|=" >> return OpAssignBOr)
+
+
+assignExpr :: ExpressionParser st
+assignExpr = do
+ p <- getPosition
+ lhs <- parseTernaryExpr
+ let assign = do
+ op <- assignOp
+ lhs <- asLValue p lhs
+ rhs <- assignExpr
+ return (AssignExpr p op lhs rhs)
+ assign <|> (return lhs)
-parseAssignExpr:: ExpressionParser st
-parseAssignExpr = buildExpressionParser assignTable parseTernaryExpr
parseExpression:: ExpressionParser st
-parseExpression = parseAssignExpr
+parseExpression = assignExpr
+
parseListExpr =
- liftM2 ListExpr getPosition (parseAssignExpr `sepBy1` comma)
+ liftM2 ListExpr getPosition (assignExpr `sepBy1` comma)
---}}}
parseScript:: CharParser state (JavaScript SourcePos)
parseScript = do
View
21 src/BrownPLT/JavaScript/PrettyPrint.hs
@@ -143,8 +143,6 @@ infixOp op = text $ case op of
prefixOp op = text $ case op of
- PrefixInc -> "++"
- PrefixDec -> "--"
PrefixLNot -> "!"
PrefixBNot -> "~"
PrefixPlus -> "+"
@@ -154,11 +152,6 @@ prefixOp op = text $ case op of
PrefixDelete -> "delete"
-postfixOp op = text $ case op of
- PostfixInc -> "++"
- PostfixDec -> "--"
-
-
assignOp op = text $ case op of
OpAssign -> "="
OpAssignAdd -> "+="
@@ -191,6 +184,12 @@ jsEscape (ch:chs) = (sel ch) ++ jsEscape chs where
sel x = [x]
-- We don't have to do anything about \X, \x and \u escape sequences.
+
+lvalue :: LValue a -> Doc
+lvalue (LVar _ x) = text x
+lvalue (LDot _ e x) = expr e <> text "." <> text x
+lvalue (LBracket _ e1 e2) = expr e1 <> brackets (expr e2)
+
expr :: Expression a -> Doc
expr e = case e of
@@ -216,11 +215,15 @@ expr e = case e of
text "new" <+> expr constr <>
(parens $ cat $ punctuate comma (map expr args))
PrefixExpr _ op e' -> prefixOp op <+> expr e'
- PostfixExpr _ op e' -> expr e' <+> postfixOp op
InfixExpr _ op left right -> expr left <+> infixOp op <+> expr right
CondExpr _ test cons alt ->
expr test <+> text "?" <+> expr cons <+> colon <+> expr alt
- AssignExpr _ op l r -> expr l <+> assignOp op <+> expr r
+ AssignExpr _ op l r -> lvalue l <+> assignOp op <+> expr r
+ UnaryAssignExpr _ op e' -> case op of
+ PrefixInc -> text "++" <> lvalue e'
+ PrefixDec -> text "--" <> lvalue e'
+ PostfixInc -> lvalue e' <> text "++"
+ PostfixDec -> lvalue e' <> text "--"
ParenExpr _ e' -> parens (expr e')
ListExpr _ es -> cat $ punctuate comma (map expr es)
CallExpr _ f args ->
View
27 src/BrownPLT/JavaScript/Syntax.hs
@@ -1,8 +1,11 @@
-- |JavaScript's syntax.
module BrownPLT.JavaScript.Syntax(Expression(..),CaseClause(..),Statement(..),
InfixOp(..),CatchClause(..),VarDecl(..),JavaScript(..),
- AssignOp(..),Id(..),PrefixOp(..),PostfixOp(..),Prop(..),
- ForInit(..),ForInInit(..),unId) where
+ AssignOp(..),Id(..),PrefixOp(..),Prop(..),
+ ForInit(..),ForInInit(..),unId
+ , UnaryAssignOp (..)
+ , LValue (..)
+ ) where
import Text.ParserCombinators.Parsec(SourcePos) -- used by data JavaScript
import Data.Generics(Data,Typeable)
@@ -32,17 +35,23 @@ data AssignOp = OpAssign | OpAssignAdd | OpAssignSub | OpAssignMul | OpAssignDiv
| OpAssignBAnd | OpAssignBXor | OpAssignBOr
deriving (Show,Data,Typeable,Eq,Ord)
-data PrefixOp = PrefixInc | PrefixDec | PrefixLNot | PrefixBNot | PrefixPlus
+data UnaryAssignOp
+ = PrefixInc | PrefixDec | PostfixInc | PostfixDec
+ deriving (Show, Data, Typeable, Eq, Ord)
+
+data PrefixOp = PrefixLNot | PrefixBNot | PrefixPlus
| PrefixMinus | PrefixTypeof | PrefixVoid | PrefixDelete
deriving (Show,Data,Typeable,Eq,Ord)
-data PostfixOp
- = PostfixInc | PostfixDec
- deriving (Show,Data,Typeable,Eq,Ord)
-
data Prop a
= PropId a (Id a) | PropString a String | PropNum a Integer
deriving (Show,Data,Typeable,Eq,Ord)
+
+data LValue a
+ = LVar a String
+ | LDot a (Expression a) String
+ | LBracket a (Expression a) (Expression a)
+ deriving (Show, Eq, Ord, Data, Typeable)
data Expression a
= StringLit a String
@@ -58,11 +67,11 @@ data Expression a
| DotRef a (Expression a) (Id a)
| BracketRef a (Expression a) {- container -} (Expression a) {- key -}
| NewExpr a (Expression a) {- constructor -} [Expression a]
- | PostfixExpr a PostfixOp (Expression a)
| PrefixExpr a PrefixOp (Expression a)
+ | UnaryAssignExpr a UnaryAssignOp (LValue a)
| InfixExpr a InfixOp (Expression a) (Expression a)
| CondExpr a (Expression a) (Expression a) (Expression a)
- | AssignExpr a AssignOp (Expression a) (Expression a)
+ | AssignExpr a AssignOp (LValue a) (Expression a)
| ParenExpr a (Expression a)
| ListExpr a [Expression a]
| CallExpr a (Expression a) [Expression a]
Please sign in to comment.
Something went wrong with that request. Please try again.