diff --git a/Text/Jasmine/Parse.hs b/Text/Jasmine/Parse.hs --- a/Text/Jasmine/Parse.hs +++ b/Text/Jasmine/Parse.hs @@ -23,16 +23,17 @@ import Control.Applicative ( (<|>) ) import Control.Monad import Data.Attoparsec.Lazy (eitherResult,parse,Result(..)) -import Data.Attoparsec.Char8 (char, satisfy, try, Parser, (), endOfInput, many, sepBy, sepBy1, many1) +import Data.Attoparsec.Char8 (char, satisfy, try, Parser, (), endOfInput, many, sepBy, sepBy1, many1, takeWhile) import Data.Char import Data.Data -import Data.List -import Prelude hiding (catch) +import Data.List hiding (takeWhile) +import Prelude hiding (catch, takeWhile) import System.Environment import qualified Data.ByteString.Lazy as LB import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Text.Jasmine.Token as P +import qualified Data.ByteString.Char8 as S8 -- --------------------------------------------------------------------- {- @@ -129,16 +130,18 @@ return (JSIdentifier val)} autoSemi :: Parser JSNode -autoSemi = try (do { v1 <- P.autoSemi; - return (JSLiteral v1);}) +autoSemi = fmap JSLiteral P.autoSemi autoSemi' :: Parser JSNode -autoSemi' = try (do { v1 <- P.autoSemi'; - return (JSLiteral v1);}) +autoSemi' = fmap JSLiteral P.autoSemi' +-- TODO: Maybe? get rid of these, and call them directly via the full name. +-- BUT, compiler optimisation should get rid of them anyway rOp :: String -> Parser () rOp = P.rOp +lChar :: Char -> Parser () +lChar = P.lChar -- --------------------------------------------------------------------- -- Make Attoparsec work with parsec @@ -157,19 +160,14 @@ --Modified from HJS stringLiteral :: Parser JSNode -stringLiteral = P.lexeme $ - try( do { _ <- char '"'; val<- many stringCharDouble; _ <- char '"'; - return (JSStringLiteral '"' val)}) - <|> do { _ <- char '\''; val<- many stringCharSingle; _ <- char '\''; - return (JSStringLiteral '\'' val)} - -stringCharDouble :: Parser Char -stringCharDouble = satisfy (\c -> isPrint c && c /= '"') - -stringCharSingle :: Parser Char -stringCharSingle = satisfy (\c -> isPrint c && c /= '\'') - - +stringLiteral = + P.lexeme $ go '"' <|> go '\'' + where + go c = do + _ <- char c + s <- takeWhile $ \x -> isPrint x && x /= c + _ <- char c + return $ JSStringLiteral c $ S8.unpack s -- ------------------------------------------------------------ @@ -390,16 +388,16 @@ -- | '.' Identifier -- | 'new' memberExpression :: Parser [JSNode] -memberExpression = try(do{ P.reserved "new"; v1 <- memberExpression; v2 <- arguments; +memberExpression = (do{ P.reserved "new"; v1 <- memberExpression; v2 <- arguments; return (((JSLiteral "new "):v1)++[v2])}) -- xxxx <|> memberExpression' --memberExpression' :: GenParser Char P.JSPState [JSNode] memberExpression' :: Parser [JSNode] -memberExpression' = try(do{v1 <- primaryExpression; v2 <- rest; - return (v1:v2)}) - <|> try(do{v1 <- functionExpression; v2 <- rest; - return (v1:v2)}) +memberExpression' = do + v1 <- functionExpression <|> primaryExpression + v2 <- rest + return $ v1 : v2 where rest = do{ rOp "["; v1 <- expression; rOp "]"; v2 <- rest; @@ -455,26 +453,31 @@ -} -- --------------------------------------------------------------------- +lparen, rparen, comma :: Char +lparen = '(' +rparen = ')' +comma = ',' -- ::= '(' ')' -- | '(' ')' arguments :: Parser JSNode -arguments = try(do{ rOp "("; rOp ")"; - return (JSArguments [[]])}) - <|> do{ rOp "("; v1 <- argumentList; rOp ")"; - return (JSArguments v1)} +arguments = do + _ <- lChar lparen + x <- ((lChar rparen) >> return [[]]) + <|> (do x <- argumentList + _ <- lChar rparen + return x) + return $ JSArguments x -- ::= -- | ',' argumentList :: Parser [[JSNode]] -argumentList = do{ vals <- sepBy1 assignmentExpression (rOp ","); - return vals} - +argumentList = sepBy1 assignmentExpression $ lChar comma -- ::= -- | leftHandSideExpression :: Parser [JSNode] -leftHandSideExpression = try (callExpression) +leftHandSideExpression = callExpression <|> newExpression "leftHandSideExpression" @@ -610,58 +613,53 @@ -- | '===' -- | '!==' equalityExpression :: Parser [JSNode] -equalityExpression = do{ v1 <- relationalExpression; v2 <- rest; - return (v1++v2)} - -- TODO: more efficient parsing here, without all the backtracking - where - rest = - try(do{ rOp "=="; v2 <- relationalExpression; v3 <- rest; - return [(JSExpressionBinary "==" v2 v3)]}) - <|> try(do{ rOp "!="; v2 <- relationalExpression; v3 <- rest; - return [(JSExpressionBinary "!=" v2 v3)]}) - <|> try(do{ rOp "==="; v2 <- relationalExpression; v3 <- rest; - return [(JSExpressionBinary "===" v2 v3)]}) - <|> try(do{ rOp "!=="; v2 <- relationalExpression; v3 <- rest; - return [(JSExpressionBinary "!==" v2 v3)]}) - <|> return [] - +equalityExpression = do + v1 <- relationalExpression + v2 <- rest + return $ v1 ++ v2 + where + rest = equals <|> exclaim <|> return [] + equals = do + _ <- char '=' + _ <- char '=' + sign <- P.lexeme $ (char '=' >> return "===") <|> return "==" + v2 <- relationalExpression + v3 <- rest + return [JSExpressionBinary sign v2 v3] + exclaim = do + _ <- char '!' + _ <- char '=' + sign <- P.lexeme $ (char '=' >> return "!==") <|> return "!=" + v2 <- relationalExpression + v3 <- rest + return [JSExpressionBinary sign v2 v3] +bitwiseExpression :: Parser [JSNode] -> Char -> Parser [JSNode] +bitwiseExpression prev op = do + v1 <- prev + v2 <- rest + return $ v1 ++ v2 + where + rest = (do + _ <- P.lexeme $ char op + v2 <- equalityExpression + v3 <- rest + return [JSExpressionBinary [op] v2 v3]) <|> return [] + -- ::= -- | '&' bitwiseAndExpression :: Parser [JSNode] -bitwiseAndExpression = do{ v1 <- equalityExpression; v2 <- rest; - return (v1++v2)} - where - rest = - try(do{ rOp "&"; v2 <- equalityExpression; v3 <- rest; - return [(JSExpressionBinary "&" v2 v3)]}) - <|> return [] - +bitwiseAndExpression = bitwiseExpression equalityExpression '&' -- ::= -- | '^' bitwiseXOrExpression :: Parser [JSNode] -bitwiseXOrExpression = do{ v1 <- bitwiseAndExpression; v2 <- rest; - return (v1++v2)} - where - rest = - do{ rOp "^"; v2 <- bitwiseAndExpression; v3 <- rest; - return [(JSExpressionBinary "^" v2 v3)]} - <|> return [] - +bitwiseXOrExpression = bitwiseExpression bitwiseAndExpression '^' -- ::= -- | '|' bitwiseOrExpression :: Parser [JSNode] -bitwiseOrExpression = do{ v1 <- bitwiseXOrExpression; v2 <- rest; - return (v1++v2)} - where - rest = - try(do{ rOp "|"; v2 <- bitwiseXOrExpression; v3 <- rest; - return [(JSExpressionBinary "|" v2 v3)]}) - <|> return [] - - +bitwiseOrExpression = bitwiseExpression bitwiseXOrExpression '|' -- ::= -- | '&&' @@ -684,7 +682,7 @@ return (v1++v2)} where rest = - try(do{ rOp "||"; v2 <- logicalAndExpression; v3 <- rest; + (do{ rOp "||"; v2 <- logicalAndExpression; v3 <- rest; return [(JSExpressionBinary "||" v2 v3)]}) <|> return [] @@ -704,7 +702,7 @@ -- ::= -- | assignmentExpression :: Parser [JSNode] -assignmentExpression = try (do {v1 <- assignmentStart; v2 <- assignmentExpression; +assignmentExpression = try (do {v1 <- assignmentStart; v2 <- assignmentExpression; -- FIXME unintuitive, but tests pass after removing this try return [(JSElement "assignmentExpression" (v1++v2))]}) <|> conditionalExpression @@ -713,6 +711,7 @@ return (v1++[v2])} -- ::= '=' | '*=' | '/=' | '%=' | '+=' | '-=' | '<<=' | '>>=' | '>>>=' | '&=' | '^=' | '|=' +-- TODO : unwind this lot into some sort of deterministic processing, DFA style. assignmentOperator :: Parser JSNode assignmentOperator = rOp' "=" <|> rOp' "*=" <|> rOp' "/=" <|> rOp' "%=" <|> rOp' "+=" <|> rOp' "-=" <|> rOp' "<<=" <|> rOp' ">>=" <|> rOp' ">>>=" <|> rOp' "&=" <|> rOp' "^=" <|> rOp' "|=" @@ -750,11 +749,11 @@ -- | statement :: Parser JSNode statement = statementBlock - <|> try(labelledStatement) + <|> labelledStatement <|> expression <|> variableStatement <|> emptyStatement - <|> try(ifElseStatement) + <|> ifElseStatement <|> ifStatement <|> iterationStatement <|> continueStatement @@ -773,21 +772,27 @@ -- ::= '{' '}' -- | '{' '}' statementBlock' :: Parser [JSNode] -statementBlock' = try (do {rOp "{"; rOp "}"; - return []}) - <|> do {rOp "{"; val <- statementList; rOp "}"; - return (if (val == (JSStatementList [JSLiteral ";"])) then ([]) else [(JSBlock val)])} - "statementBlock" +statementBlock' = (do + _ <- P.lexeme $ char '{' + (P.lexeme (char '}') >> return []) <|> (do + val <- statementList + _ <- P.lexeme $ char '}' + return $ + if val == JSStatementList [JSLiteral ";"] + then [] + else [JSBlock val]) + ) "statementBlock" -- ::= '{' '}' -- | '{' '}' block :: Parser JSNode -block = try (do {rOp "{"; rOp "}"; - return (JSBlock (JSStatementList []))}) - <|> do {rOp "{"; val <- statementList; rOp "}"; - return (JSBlock val)} - "block" - +block = (do + _ <- P.lexeme $ char '{' + x <- (P.lexeme (char '}') >> return (JSStatementList [])) <|> (do + val <- statementList + _ <- P.lexeme $ char '}' + return val) + return $ JSBlock x) "block" -- ::= -- | @@ -841,7 +846,7 @@ -- ::= 'if' '(' ')' 'else' ifElseStatement :: Parser JSNode -ifElseStatement = do{ P.reserved "if"; rOp "("; v1 <- expression; rOp ")"; v2 <- statementSemi; P.reserved "else"; v3 <- statement ; +ifElseStatement = do{ try $ P.reserved "if"; rOp "("; v1 <- expression; rOp ")"; v2 <- statementSemi; P.reserved "else"; v3 <- statement ; -- FIXME can this try be removed? return (JSIfElse v1 v2 v3) } statementSemi :: Parser JSNode @@ -949,19 +954,13 @@ -- | '{' '}' -- TODO: get rid of the try clauses by unwinding this caseBlock :: Parser [JSNode] -caseBlock = try(do{ rOp "{"; rOp "}"; - return []}) - <|> try(do{ rOp "{"; v1 <- caseClauses; rOp "}"; - return v1}) - <|> try(do{ rOp "{"; v1 <- caseClauses; v2 <- defaultClause; rOp "}"; - return (v1++[v2])}) - <|> try(do{ rOp "{"; v1 <- caseClauses; v2 <- defaultClause; v3 <- caseClauses; rOp "}"; - return (v1++[v2]++v3)}) - <|> try(do{ rOp "{"; v1 <- defaultClause; v2 <- caseClauses; rOp "}"; - return (v1:v2)}) - <|> do{ rOp "{"; v1 <- defaultClause; rOp "}"; - return [v1]} - +caseBlock = do + _ <- P.lexeme $ char '{' + a <- caseClauses <|> return [] + b <- fmap return defaultClause <|> return [] + c <- caseClauses <|> return [] + _ <- P.lexeme $ char '}' + return $ concat [a, b, c] -- ::= -- | @@ -990,7 +989,7 @@ -- ::= Identifier ':' labelledStatement :: Parser JSNode -labelledStatement = do { v1 <- identifier; rOp ":"; v2 <- statement; +labelledStatement = do { v1 <- try identifier; rOp ":"; v2 <- statement; -- FIXME can this try be removed? return (JSLabelled v1 v2)} -- ::= 'throw' diff --git a/Text/Jasmine/Token.hs b/Text/Jasmine/Token.hs --- a/Text/Jasmine/Token.hs +++ b/Text/Jasmine/Token.hs @@ -8,26 +8,29 @@ , autoSemi , autoSemi' , rOp + , lChar , lexeme -- Testing - , oneLineComment , isAlpha ) where -- --------------------------------------------------------------------- import Control.Applicative ( (<|>) ) -import Data.Attoparsec.Char8 (isSpace, hexadecimal, decimal, char, Parser, satisfy, try, many, (), skipMany, skipMany1, isDigit) -import Data.Char ( isAlpha ) -import Data.List ( nub, sort) +import Data.Attoparsec.Char8 (hexadecimal, decimal, char, Parser, satisfy, try, many, (), skipMany, skipMany1, isDigit, string, skipWhile, anyChar) +import Data.Char ( isAlpha, isSpace ) +import qualified Data.Set as Set +import qualified Data.ByteString.Char8 as S8 -- --------------------------------------------------------------------- -- Do not use the lexer, it is greedy and consumes subsequent symbols, -- e.g. "!" in a==!b rOp :: String -> Parser () -rOp x = lexeme $ do { _ <- myString x; return () } +rOp x = lexeme $ do { _ <- string $ S8.pack x; return () } +lChar :: Char -> Parser () +lChar x = lexeme $ do { _ <- char x; return () } -- --------------------------------------------------------------------- @@ -66,25 +69,11 @@ "identifier" isReservedName :: String -> Bool -isReservedName name = isReserved theReservedNames name - - -isReserved :: [String] -> String -> Bool -isReserved names name - = scan names - where - scan [] = False - scan (r:rs) = case (compare r name) of - LT -> scan rs - EQ -> True - GT -> False - -theReservedNames :: [String] -theReservedNames = sort reservedNames +isReservedName = flip Set.member reservedNames -- TODO: fix trailing characters test reserved :: String -> Parser () -reserved name = lexeme $ do { _ <- myString name; return () } +reserved name = lexeme $ do { _ <- string $ S8.pack name; return () } {- reserved name = lexeme $ try $ @@ -96,64 +85,31 @@ --whiteSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") --whiteSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <|> do { _ <- char '\n'; setNLFlag} "") whiteSpace :: Parser () -whiteSpace = skipMany (do { _ <- myString "\n"; return ()} <|> simpleSpace <|> oneLineComment <|> multiLineComment "") +whiteSpace = skipMany (do { _ <- string $ S8.pack "\n"; return ()} <|> simpleSpace <|> comment "") -- whiteSpace = try $ many $ (do { equal TokenWhite } <|> do { (equal TokenNL); setNLFlag}) ---simpleSpace = skipMany1 (satisfy isSpace) simpleSpace :: Parser () -simpleSpace = skipMany1 (satisfy (\c -> isSpace c && c /= '\n')) -- From HJS - - -oneLineComment :: Parser () -oneLineComment = - do{ _ <- myString commentLine - ; skipMany (satisfy (/= '\n')) - -- ; word8 10 - ; return () - } +-- Note : Data.Char.isSpace includes a variety of non-breaking space chars, and unicode variants +simpleSpace = skipMany1 $ (satisfy isSpace) -multiLineComment :: Parser () -multiLineComment = - do { _ <- try (myString commentStart) - ; inComment - } +comment :: Parser () +comment = do + isMulti <- try $ do + _ <- char fslash + (char asterisk >> return True) <|> (char fslash >> return False) + if isMulti then inComment else skipWhile (/= linefeed) inComment :: Parser () -inComment - | nestedComments = inCommentMulti - | otherwise = inCommentSingle - -inCommentMulti :: Parser () -inCommentMulti - = do{ _ <- try (myString commentEnd) ; return () } - <|> do{ multiLineComment ; inCommentMulti } - <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti } - <|> do{ _ <- oneOf startEnd ; inCommentMulti } - "end of comment" - where - startEnd = nub (commentEnd ++ commentStart) - -inCommentSingle :: Parser () -inCommentSingle - = do{ _ <- try (myString commentEnd) ; return () } - <|> do{ skipMany1 (noneOf startEnd) ; inCommentSingle } - <|> do{ _ <- oneOf startEnd ; inCommentSingle } - "end of comment" - where - startEnd = nub (commentEnd ++ commentStart) - -commentStart :: [Char] -commentStart = "/*" - -commentEnd :: [Char] -commentEnd = "*/" - -commentLine :: [Char] -commentLine = "//" +inComment = + theEnd <|> (anyChar >> inComment) "end of comment" + where + theEnd = char asterisk >> (char fslash >> return ()) <|> inComment -nestedComments :: Bool -nestedComments = True +fslash, asterisk, linefeed :: Char +fslash = '/' +asterisk = '*' +linefeed = '\n' identLetter :: Parser Char identLetter = alphaNum <|> oneOf "_" @@ -161,8 +117,8 @@ identStart :: Parser Char identStart = letter <|> oneOf "_$" -reservedNames :: [String] -reservedNames = [ +reservedNames :: Set.Set String +reservedNames = Set.fromAscList [ "break", "case", "catch", "const", "continue", "debugger", "default", "delete", "do", @@ -200,7 +156,6 @@ -- > ; return (sum ds) -- > } ---lexeme p = do{ x <- p; whiteSpace; return x } lexeme :: Parser b -> Parser b lexeme p = do{ x <- p; whiteSpace; return x } @@ -215,18 +170,9 @@ -- > vowel = oneOf "aeiou" oneOf :: String -> Parser Char -oneOf cs = satisfy (\c -> elem c cs) +oneOf = satisfy . flip elem --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" - -noneOf :: String -> Parser Char -noneOf cs = satisfy (\c -> not (elem c cs)) - -- | Parses a letter or digit (a character between \'0\' and \'9\'). -- Returns the parsed character. @@ -245,11 +191,8 @@ -- | Parses a hexadecimal digit (a digit or a letter between \'a\' and -- \'f\' or \'A\' and \'F\'). Returns the parsed character. -myString :: String -> Parser String -myString s = mapM (\c -> char c) s - isAlphaNum :: Char -> Bool -isAlphaNum c = isAlpha c || isDigit c +isAlphaNum c = isAlpha c || isDigit c -- --------------------------------------------------------------------- {- diff --git a/hjsmin.cabal b/hjsmin.cabal --- a/hjsmin.cabal +++ b/hjsmin.cabal @@ -1,5 +1,5 @@ name: hjsmin -version: 0.0.3 +version: 0.0.4 license: BSD3 license-file: LICENSE author: Alan Zimmerman @@ -29,6 +29,7 @@ , attoparsec >= 0.8 && < 0.9 , blaze-builder >= 0.2 && < 1 , text >= 0.8 && < 1 + , containers >= 0.2 && < 0.5 exposed-modules: Text.Jasmine other-modules: Text.Jasmine.Parse, Text.Jasmine.Pretty, Text.Jasmine.Token ghc-options: -Wall