diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,8 +1,14 @@ Copyright (c) 2007-2008 Arjun Guha and Spiridon Eliopoulos. -Contains source code derived from HtmlPrag 0.16 Copyright (c) 2003 - 2005 -Neil W. Van Dyke, licensed under the terms of the GNU Lesser General Public -License 2.1. - WebBits is licensed under the terms of the GNU Lesser General Public License 2.1. + +Contains source code derived from HtmlPrag 0.16, Copyright (c) 2003 - 2005 Neil +W. Van Dyke, licensed under the terms of the GNU Lesser General Public License +2.1. + +Contains source code derived from javascript.plt, Copyright (c) 2008 David +Herman, licensed under the terms of the GNU Lesser General Public License 2.1 + +The tests/ directory contains open-source JavaScript code. Their licenses +are inline. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -6,20 +6,18 @@ > isHaskellFile file = ".lhs" `L.isSuffixOf` file || ".hs" `L.isSuffixOf` file -> moduleName file = "Test." ++ m where -> m = L.takeWhile (\ch -> ch /= '.') file +> moduleName file = L.takeWhile (/= '.') file > testMain _ _ _ _ = do -> files <- getDirectoryContents "src/Test" -> let tests = filter isHaskellFile files -> let testModules = map moduleName tests +> files <- getDirectoryContents "tests" +> let testModules = [moduleName f | f <- files, isHaskellFile f] > let testFuncs = map (++ ".main") testModules > let testExpr = "sequence [ " ++ concat (L.intersperse "," testFuncs) ++ > " ] >>= \\cases -> runTestTT (TestList cases)" > let moduleLine = concat (L.intersperse " " testModules) -> let cmd = "cd src && ghc -fno-monomorphism-restriction -fglasgow-exts " ++ -> "-package HUnit -e \"" ++ testExpr ++ " >> return ()\" " ++ -> moduleLine +> let cmd = "cd tests && ghc -XNoMonomorphismRestriction -fglasgow-exts " ++ +> "-package HUnit -i:../src -e \"" ++ testExpr ++ +> " >> return ()\" " ++ moduleLine > putStrLn "Testing command is:" > putStrLn cmd > putStrLn "\nLoading tests..." diff --git a/WebBits.cabal b/WebBits.cabal --- a/WebBits.cabal +++ b/WebBits.cabal @@ -1,6 +1,6 @@ Name: WebBits -Version: 0.9.3 -Cabal-Version: >= 1.2 +Version: 0.11.0 +Cabal-Version: >= 1.2.3 Copyright: Copyright (c) 2007-2008 Arjun Guha and Spiridon Eliopoulos License: LGPL License-file: LICENSE @@ -47,4 +47,4 @@ WebBits.JavaScript.JavaScript WebBits.JavaScript.Lexer WebBits.JavaScript.Parser WebBits.JavaScript.PrettyPrint WebBits.JavaScript.Syntax WebBits.JavaScript.Environment - WebBits.JavaScript.Crawl + WebBits.JavaScript.Crawl WebBits.JavaScript diff --git a/src/WebBits/JavaScript.hs b/src/WebBits/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/WebBits/JavaScript.hs @@ -0,0 +1,21 @@ +-- |Re-exports commonly used modules. +module WebBits.JavaScript + ( module WebBits.JavaScript.Syntax + , module WebBits.JavaScript.HtmlEmbedding + , module WebBits.JavaScript.Parser + , module WebBits.JavaScript.Combinators + , module WebBits.Common + , module WebBits.JavaScript.Environment + -- JavaScript.Instances exports nothing + ) where + +import WebBits.Common + +import WebBits.JavaScript.Syntax +import WebBits.JavaScript.Parser +import WebBits.JavaScript.PrettyPrint +import WebBits.JavaScript.HtmlEmbedding +import WebBits.JavaScript.Combinators +import WebBits.JavaScript.Environment + +import WebBits.JavaScript.Instances diff --git a/src/WebBits/JavaScript/Environment.hs b/src/WebBits/JavaScript/Environment.hs --- a/src/WebBits/JavaScript/Environment.hs +++ b/src/WebBits/JavaScript/Environment.hs @@ -210,6 +210,17 @@ labelProp e = gmapM labelAny e +labelVarDecl :: VarDecl Ann + -> Z.ZipperT Env (State Int) (VarDecl Ann) +labelVarDecl (VarDecl (_,_,loc) id@(Id _ name) rhs) = do + env <- Z.getNode + case M.lookup name env of + Nothing -> fail $ "WebBits bug: unbound id in labelVarDecl (" ++ name ++ ")" + Just lbl' -> case rhs of + Nothing -> return (VarDecl (env,lbl',loc) id Nothing) + Just expr -> do + expr' <- labelExpr expr + return (VarDecl (env,lbl',loc) id (Just expr')) labelExpr :: Expression Ann -> Z.ZipperT Env (State Int) (Expression Ann) @@ -224,6 +235,11 @@ id' <- labelIdNoVar id expr' <- labelExpr expr return (DotRef (env,lbl,loc) expr' id') +labelExpr (VarRef (_,_,loc) id@(Id _ name)) = do + env <- Z.getNode + case M.lookup name env of + Nothing -> fail $ "WebBits bug : unbound identifer " ++ name + Just lbl' -> return (VarRef (env,lbl',loc) id) labelExpr (FuncExpr (_,_,loc) args stmt) = do env <- Z.getNode lbl <- nextLabel @@ -265,21 +281,24 @@ labelAny :: GenericM (Z.ZipperT Env (State Int)) labelAny a = (labelAny' `extM` labelEnv `extM` labelId `extM` labelProp `extM` - labelExpr `extM` labelStmt) a + labelExpr `extM` labelStmt `extM` labelVarDecl) a +topLevelPartialEnv = (M.empty,S.singleton "this") + -- |Annotates each expression with its static environment. In addition, -- a map of free identifiers is returned, along with the next valid label. staticEnvironment :: [Statement SourcePos] - -> ([Statement Ann],Env,Int) + -> ([Statement Ann],Env,Env,Int) staticEnvironment stmts = let stmts' = explicitThis stmts labelM = do partialEnvTree <- Z.execZipperT (mapM buildStmt stmts') - (Z.toLocation (Z.Node emptyPartialEnv [])) - (envTree,globals) <- runStateT (completeEnvM partialEnvTree) M.empty + (Z.toLocation (Z.Node topLevelPartialEnv [])) + (envTree,freeEnv) <- runStateT (completeEnvM partialEnvTree) M.empty + let globals = M.union freeEnv (Z.rootLabel envTree) let stmts'' = map insertEmptyAnn stmts' labelledStmts <- Z.evalZipperT (mapM labelStmt stmts'') (Z.toLocation envTree) - return (labelledStmts,globals) - ((labelledStmts,globals),nextLabel) = runState labelM 0 - in (labelledStmts,globals,nextLabel) + return (labelledStmts,freeEnv,globals) + ((labelledStmts,freeEnv,globals),nextLabel) = runState labelM 1 + in (labelledStmts,freeEnv,globals,nextLabel) diff --git a/src/WebBits/JavaScript/JavaScript.hs b/src/WebBits/JavaScript/JavaScript.hs --- a/src/WebBits/JavaScript/JavaScript.hs +++ b/src/WebBits/JavaScript/JavaScript.hs @@ -4,10 +4,12 @@ , module WebBits.JavaScript.HtmlEmbedding , module WebBits.JavaScript.Parser , module WebBits.JavaScript.Combinators + , module WebBits.Common -- JavaScript.Instances exports nothing ) where --- +import WebBits.Common + import WebBits.JavaScript.Syntax import WebBits.JavaScript.Parser import WebBits.JavaScript.PrettyPrint diff --git a/src/WebBits/JavaScript/Lexer.hs b/src/WebBits/JavaScript/Lexer.hs --- a/src/WebBits/JavaScript/Lexer.hs +++ b/src/WebBits/JavaScript/Lexer.hs @@ -1,7 +1,7 @@ {- This isn't a lexer in the sense that it provides a JavaScript token-stream. - This module provides character-parsers for various JavaScript tokens. -} -module WebBits.JavaScript.Lexer(identifier,reserved,operator,reservedOp,charLiteral, +module WebBits.JavaScript.Lexer(lexeme,identifier,reserved,operator,reservedOp,charLiteral, stringLiteral,natural,integer,float,naturalOrFloat, decimal,hexadecimal,octal,symbol,whiteSpace,parens, braces,brackets,squares,semi,comma,colon,dot, @@ -61,3 +61,4 @@ colon = T.colon lex dot = T.dot lex brackets = T.brackets lex +lexeme = T.lexeme lex diff --git a/src/WebBits/JavaScript/Parser.hs b/src/WebBits/JavaScript/Parser.hs --- a/src/WebBits/JavaScript/Parser.hs +++ b/src/WebBits/JavaScript/Parser.hs @@ -1,10 +1,16 @@ -module WebBits.JavaScript.Parser(parseScript,parseExpression,parseStatement +module WebBits.JavaScript.Parser(parseScript,parseExpression + , parseString , parseScriptFromString , emptyParsedJavaScript , ParsedStatement , ParsedExpression , parseJavaScriptFromFile , parseSimpleExpr' + , parseBlockStmt + , parseStatement + , StatementParser + , ExpressionParser + , parseAssignExpr ) where import WebBits.JavaScript.Lexer hiding (identifier) @@ -16,18 +22,16 @@ import Control.Monad.Trans (MonadIO,liftIO) import Numeric(readDec,readOct,readHex) import Data.Char(chr) +import Data.Char -- We parameterize the parse tree over source-locations. -type ParsedExpr = Expression SourcePos -type ParsedStmt = Statement SourcePos - type ParsedStatement = Statement SourcePos type ParsedExpression = Expression SourcePos -- These parsers can store some arbitrary state -type StatementParser state = CharParser state ParsedStmt -type ExpressionParser state = CharParser state ParsedExpr +type StatementParser state = CharParser state ParsedStatement +type ExpressionParser state = CharParser state ParsedExpression identifier = liftM2 Id getPosition Lexer.identifier @@ -88,8 +92,8 @@ parseDoWhileStmt = do pos <- getPosition reserved "do" - body <- parseStatement - reserved "while" + body <- parseBlockStmt + reserved "while" "while at the end of a do block" test <- parseParenExpr "parenthesized test-expression in do loop" optional semi return (DoWhileStmt pos body test) @@ -286,16 +290,11 @@ parseBoolLit:: ExpressionParser st -parseBoolLit = - let parseTrueLit = do - pos <- getPosition - reserved "true" - return (BoolLit pos True) - parseFalseLit = do - pos <- getPosition - reserved "false" - return (BoolLit pos False) - in parseTrueLit <|> parseFalseLit +parseBoolLit = do + pos <- getPosition + let parseTrueLit = reserved "true" >> return (BoolLit pos True) + parseFalseLit = reserved "false" >> return (BoolLit pos False) + parseTrueLit <|> parseFalseLit parseVarRef:: ExpressionParser st parseVarRef = liftM2 VarRef getPosition identifier @@ -321,8 +320,8 @@ parseEscapeChar = do c <- oneOf allEscapes - (Just c') <- return $ lookup c escapeChars - return c' + let (Just c') = lookup c escapeChars -- will succeed due to line above + return c' parseAsciiHexChar = do char 'x' @@ -337,6 +336,7 @@ isWhitespace ch = ch `elem` " \t" + -- The endWith argument is either single-quote or double-quote, depending on how -- we opened the string. parseStringLit' endWith = @@ -345,10 +345,12 @@ cs <- parseStringLit' endWith return $ "'" ++ cs) <|> (do char '\\' - c <- (parseEscapeChar <|> parseAsciiHexChar <|> parseUnicodeHexChar <|> char '\r' <|> char '\n') + c <- parseEscapeChar <|> parseAsciiHexChar <|> parseUnicodeHexChar <|> + char '\r' <|> char '\n' cs <- parseStringLit' endWith - -- TODO: Leading whitespace on the new line is probably meant to be ignored. - if c == '\r' || c == '\n' then return (c:(dropWhile isWhitespace cs)) else return cs) <|> + if c == '\r' || c == '\n' + then return (c:(dropWhile isWhitespace cs)) + else return (c:cs)) <|> (liftM2 (:) anyChar (parseStringLit' endWith)) parseStringLit:: ExpressionParser st @@ -356,14 +358,13 @@ pos <- getPosition -- parseStringLit' takes as an argument the quote-character that opened the -- string. - str <- (char '\'' >>= parseStringLit') <|> (char '\"' >>= parseStringLit') + str <- lexeme $ (char '\'' >>= parseStringLit') <|> (char '\"' >>= parseStringLit') -- CRUCIAL: Parsec.Token parsers expect to find their token on the first - -- character, and read whitespaces beyond their tokens. Without this, - -- expressions like: + -- character, and read whitespaces beyond their tokens. Without 'lexeme' + -- above, expressions like: -- var s = "string" ; -- do not parse. - spaces - return (StringLit pos str) + return $ StringLit pos str --}}} @@ -374,7 +375,12 @@ return $ \f -> f ('g' `elem` flags) ('i' `elem` flags) let parseEscape = char '\\' >> anyChar let parseChar = noneOf "/" - let parseRe = (char '/' >> return "") <|> (char '\\' >> liftM2 (:) anyChar parseRe) <|> (liftM2 (:) anyChar parseRe) + let parseRe = (char '/' >> return "") <|> + (do char '\\' + ch <- anyChar -- TOOD: too lenient + rest <- parseRe + return ('\\':ch:rest)) <|> + (liftM2 (:) anyChar parseRe) pos <- getPosition char '/' pat <- parseRe --many1 parseChar @@ -396,7 +402,7 @@ val <- parseAssignExpr return (name,val) in do pos <- getPosition - props <- braces (parseProp `sepBy` comma) "object literal" + props <- braces (parseProp `sepEndBy` comma) "object literal" return $ ObjectLit pos props --{{{ Parsing numbers. From pg. 17-18 of ECMA-262. @@ -407,54 +413,60 @@ [(hex,"")] <- return $ Numeric.readHex digits return hex -decimalDigit = oneOf "0123456789" - -- Creates a decimal value from a whole, fractional and exponent part. mkDecimal:: Double -> Double -> Int -> Double mkDecimal w f e = if (f >= 1.0) then mkDecimal w (f / 10.0) e - else (w+f) * (10.0^e) - -decimalInteger = do - xs <- many1 decimalDigit - spaces - return $ (fst.head.readDec) xs - -{- (try (char '0' >> spaces >> return 0)) <|> - (do xs <- many1 decimalDigit - return $ (fst.head.readDec) xs) -} + else (w + f) * (10.0 ^^ e) exponentPart = do oneOf "eE" - ((char '+' >> many1 decimalDigit >>= return.fst.head.readDec) <|> - (char '-' >> many1 decimalDigit >>= return.negate.fst.head.readDec) <|> - (many1 decimalDigit >>= return.fst.head.readDec)) + (char '+' >> decimal) <|> (char '-' >> negate `fmap` decimal) <|> decimal decLit = - (do whole <- decimalInteger - frac <- option 0 (char '.' >> decimalInteger) + (do whole <- decimal + frac <- option 0 (char '.' >> decimal) exp <- option 0 exponentPart - return $ mkDecimal (fromIntegral whole) (fromIntegral frac) exp) <|> - (do frac <- char '.' >> decimalInteger + return $ mkDecimal (fromIntegral whole) (fromIntegral frac) (fromIntegral exp)) <|> + (do frac <- char '.' >> decimal exp <- option 0 exponentPart - return $ mkDecimal 0.0 (fromIntegral frac) exp) + return $ mkDecimal 0.0 (fromIntegral frac) (fromIntegral exp)) parseNumLit:: ExpressionParser st -parseNumLit = - liftM2 NumLit getPosition - (do x <- hexLit <|> decLit - (notFollowedBy identifierStart "whitespace") - spaces - return x) +parseNumLit = do + pos <- getPosition + num <- lexeme $ hexLit <|> decLit + notFollowedBy identifierStart "whitespace" + return $ NumLit pos num --}}} +------------------------------------------------------------------------------ +-- Position Helper +------------------------------------------------------------------------------ + +withPos cstr p = do { pos <- getPosition; e <- p; return $ cstr pos e } + +------------------------------------------------------------------------------- +-- Compound Expression Parsers +------------------------------------------------------------------------------- + +dotRef e = (reservedOp "." >> withPos cstr identifier) "property.ref" + where cstr pos key = DotRef pos e key + +funcApp e = (parens $ withPos cstr (parseExpression `sepBy` comma)) "(function application)" + where cstr pos args = CallExpr pos e args + +bracketRef e = (brackets $ withPos cstr parseExpression) "[property-ref]" + where cstr pos key = BracketRef pos e key + +------------------------------------------------------------------------------- +-- Expression Parsers +------------------------------------------------------------------------------- + parseParenExpr:: ExpressionParser st -parseParenExpr = do - pos <- getPosition - expr <- parens parseListExpr - return (ParenExpr pos expr) +parseParenExpr = withPos ParenExpr (parens parseListExpr) -- everything above expect functions parseExprForNew = parseThisRef <|> parseNullLit <|> parseBoolLit <|> parseStringLit @@ -475,44 +487,16 @@ return (NewExpr pos constructor arguments)) <|> parseSimpleExpr' -parseSimpleExpr (Just e) = - ((do reservedOp "." "property.ref" - pos <- getPosition - key <- identifier - parseSimpleExpr $ Just (DotRef pos e key)) <|> - (do pos <- getPosition - reservedOp "(" "(function application)" - args <- parseExpression `sepBy` comma - --reservedOp ")" - spaces -- This hack is needed as the token parser parses ")+", ")-", - char ')' -- etc. as a single token. - spaces - parseSimpleExpr $ Just (CallExpr pos e args)) <|> - (do reservedOp "[" "[property-ref]" - pos <- getPosition - key <- parseExpression "expression (2)" - char ']' - spaces - --reservedOp "]" - parseSimpleExpr $ Just (BracketRef pos e key)) <|> - (return e)) +parseSimpleExpr (Just e) = (do + e' <- dotRef e <|> funcApp e <|> bracketRef e + parseSimpleExpr $ Just e') <|> (return e) parseSimpleExpr Nothing = do e <- parseNewExpr "expression (3)" parseSimpleExpr (Just e) - -parseSimpleExprForNew (Just e) = - ((do reservedOp "." "property.ref" - pos <- getPosition - key <- identifier - parseSimpleExprForNew $ Just (DotRef pos e key)) <|> - (do reservedOp "[" "[property-ref]" - pos <- getPosition - key <- parseExpression "expression (2)" - char ']' - spaces - --reservedOp "]" - parseSimpleExprForNew $ Just (BracketRef pos e key)) <|> - (return e)) + +parseSimpleExprForNew (Just e) = (do + e' <- dotRef e <|> bracketRef e + parseSimpleExprForNew $ Just e') <|> (return e) parseSimpleExprForNew Nothing = do e <- parseNewExpr "expression (3)" parseSimpleExprForNew (Just e) @@ -543,32 +527,42 @@ (reservedOp str <|> reserved str) return (PostfixExpr pos constr) -- points-free, returns a function --- apparently, expression tables can't handle multiple prefixes (which makes sense, since chaining ++ and -- doesn't --- make any sense) +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) <|> (reservedOp "~" >> return PrefixBNot) + pos <- getPosition + op <- optionMaybe $ (reservedOp "!" >> return PrefixLNot) <|> + (reservedOp "~" >> return PrefixBNot) <|> + (try (lexeme $ char '-' >> notFollowedBy (char '-')) >> + return PrefixMinus) <|> + (try (lexeme $ char '+' >> notFollowedBy (char '+')) >> + return PrefixPlus) <|> + (reserved "typeof" >> return PrefixTypeof) <|> + (reserved "void" >> return PrefixVoid) <|> + (reserved "delete" >> return PrefixDelete) case op of - Nothing -> parseSimpleExpr Nothing -- new is treated as a simple expr + Nothing -> prefixIncDecExpr -- new is treated as a simple expr Just op -> do innerExpr <- parsePrefixedExpr return (PrefixExpr pos op innerExpr) - -exprTable:: [[Operator Char st ParsedExpr]] + +exprTable:: [[Operator Char st ParsedExpression]] exprTable = [ [makePrefixExpr "++" PrefixInc, makePostfixExpr "++" PostfixInc], [makePrefixExpr "--" PrefixDec, makePostfixExpr "--" PostfixDec], - -- What we really need here is a good, old-fashioned lexer. - [mkPrefix (try $ char '+' >> notFollowedBy (char '+')) PrefixPlus, - mkPrefix (try $ char '-' >> notFollowedBy (char '-')) PrefixMinus], - -- makePrefixExpr "-" PrefixMinus], - [makePrefixExpr "typeof" PrefixTypeof, - makePrefixExpr "void" PrefixVoid, - makePrefixExpr "delete" PrefixDelete], - [makeInfixExpr "*" OpMul, makeInfixExpr "/" OpDiv, makeInfixExpr "%" OpMod], [makeInfixExpr "+" OpAdd, makeInfixExpr "-" OpSub], [makeInfixExpr "<<" OpLShift, makeInfixExpr ">>" OpSpRShift, @@ -590,19 +584,18 @@ --{{{ Parsing ternary operators: left factored -parseTernaryExpr':: CharParser st (Maybe (ParsedExpr,ParsedExpr)) -parseTernaryExpr' = - (do reservedOp "?" - l <- parseTernaryExpr - colon - r <- parseTernaryExpr - return $ Just (l,r)) <|> - (return Nothing) +parseTernaryExpr':: CharParser st (ParsedExpression,ParsedExpression) +parseTernaryExpr' = do + reservedOp "?" + l <- parseAssignExpr + colon + r <- parseAssignExpr + return $(l,r) parseTernaryExpr:: ExpressionParser st parseTernaryExpr = do e <- parseExpression' - e' <- parseTernaryExpr' + e' <- optionMaybe parseTernaryExpr' case e' of Nothing -> return e Just (l,r) -> do p <- getPosition @@ -611,13 +604,13 @@ -- Parsing assignment operations. makeAssignExpr str constr = Infix parser AssocRight where - parser:: CharParser st (ParsedExpr -> ParsedExpr -> ParsedExpr) + parser:: CharParser st (ParsedExpression -> ParsedExpression -> ParsedExpression) parser = do pos <- getPosition reservedOp str return (AssignExpr pos constr) -assignTable:: [[Operator Char st ParsedExpr]] +assignTable:: [[Operator Char st ParsedExpression]] assignTable = [ [makeAssignExpr "=" OpAssign, makeAssignExpr "+=" OpAssignAdd, makeAssignExpr "-=" OpAssignSub, makeAssignExpr "*=" OpAssignMul, @@ -657,3 +650,8 @@ emptyParsedJavaScript = Script (error "Parser.emptyParsedJavaScript--no annotation") [] + +parseString :: String -> [Statement SourcePos] +parseString str = case parse parseScript "" str of + Left err -> error (show err) + Right (Script _ stmts) -> stmts diff --git a/src/WebBits/JavaScript/PrettyPrint.hs b/src/WebBits/JavaScript/PrettyPrint.hs --- a/src/WebBits/JavaScript/PrettyPrint.hs +++ b/src/WebBits/JavaScript/PrettyPrint.hs @@ -40,13 +40,13 @@ instance PrettyPrintable (CaseClause a) where pp (CaseClause _ expr stmts) = - pp expr <+> colon $$ (nest 2 (vcat (map pp stmts))) + text "case" $+$ pp expr <+> colon $$ (nest 2 (vcat (map pp stmts))) pp (CaseDefault _ stmts) = text "default:" $$ (nest 2 (vcat (map pp stmts))) instance PrettyPrintable (CatchClause a) where pp (CatchClause _ id stmt) = - text "catch" <+> (parens.pp) id <+> pp stmt + text "catch" <+> (parens.pp) id <+> inBlock stmt instance PrettyPrintable (VarDecl a) where @@ -74,7 +74,7 @@ pp (ReturnStmt _ expr) = text "return" <+> pp expr <> semi pp (DoWhileStmt _ stmt expr) = - text "do" $$ (nest 2 (pp stmt <+> inParens expr)) + text "do" $$ (nest 2 (pp stmt <+> text "while" <+> inParens expr)) pp (BreakStmt _ Nothing) = text "break;" pp (BreakStmt _ (Just label)) = @@ -92,11 +92,10 @@ text "for" <+> parens (pp init <> semi <+> pp incr <> semi <+> pp test) $$ (nest 2 (pp body)) pp (TryStmt _ stmt catches finally) = - (text "try" $$ pp stmt $$ (vcat (map pp catches)) $$ ppFinally) where - ppFinally = - case finally of - Nothing -> empty - (Just stmt) -> text "finally" <> pp stmt + text "try" $$ inBlock stmt $$ (vcat (map pp catches)) $$ ppFinally where + ppFinally = case finally of + Nothing -> empty + Just stmt -> text "finally" <> inBlock stmt pp (ThrowStmt _ expr) = text "throw" <+> pp expr <> semi pp (WithStmt _ expr stmt) | isParenExpr expr = @@ -112,7 +111,7 @@ instance PrettyPrintable (Prop a) where pp (PropId _ id) = pp id - pp (PropString _ str) = text str + pp (PropString _ str) = doubleQuotes (text (jsEscape str)) pp (PropNum _ n) = text (show n) @@ -198,8 +197,8 @@ -- Based on: -- http://developer.mozilla.org/en/docs/Core_JavaScript_1.5_Guide:Literals jsEscape:: String -> String -jsEscape str = - if str == "" then "" else (sel (head str)) ++ (jsEscape (tail str)) where +jsEscape "" = "" +jsEscape (ch:chs) = (sel ch) ++ jsEscape chs where sel '\b' = "\\b" sel '\f' = "\\f" sel '\n' = "\\n" @@ -208,6 +207,7 @@ sel '\v' = "\\v" sel '\'' = "\\'" sel '\"' = "\\\"" + sel '\\' = "\\\\" sel x = [x] -- We don't have to do anything about \X, \x and \u escape sequences. @@ -242,7 +242,7 @@ pp (InfixExpr _ op left right) = pp left <+> pp op <+> pp right pp (CondExpr _ test cons alt) = - inParens test <+> text "?" <+> inParens cons <+> colon <+> inParens alt + pp test <+> text "?" <+> pp cons <+> colon <+> pp alt pp (AssignExpr _ op l r) = pp l <+> pp op <+> pp r pp (ParenExpr _ expr) =