hjsmin 0.0.3 → 0.0.4
raw patch · 3 files changed
+135/−192 lines, 3 filesdep +containersPVP ok
version bump matches the API change (PVP)
Dependencies added: containers
API changes (from Hackage documentation)
Files
- Text/Jasmine/Parse.hs +102/−103
- Text/Jasmine/Token.hs +31/−88
- hjsmin.cabal +2/−1
Text/Jasmine/Parse.hs view
@@ -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 @@ -- | <Member Expression> '.' Identifier -- | 'new' <Member Expression> <Arguments> 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> ::= '(' ')' -- | '(' <Argument List> ')' 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 -- <Argument List> ::= <Assignment Expression> -- | <Argument List> ',' <Assignment Expression> argumentList :: Parser [[JSNode]]-argumentList = do{ vals <- sepBy1 assignmentExpression (rOp ",");- return vals}-+argumentList = sepBy1 assignmentExpression $ lChar comma -- <Left Hand Side Expression> ::= <New Expression> -- | <Call Expression> leftHandSideExpression :: Parser [JSNode]-leftHandSideExpression = try (callExpression)+leftHandSideExpression = callExpression <|> newExpression <?> "leftHandSideExpression" @@ -610,58 +613,53 @@ -- | <Equality Expression> '===' <Relational Expression> -- | <Equality Expression> '!==' <Relational Expression> 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 []+ -- <Bitwise And Expression> ::= <Equality Expression> -- | <Bitwise And Expression> '&' <Equality Expression> 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 '&' -- <Bitwise XOr Expression> ::= <Bitwise And Expression> -- | <Bitwise XOr Expression> '^' <Bitwise And Expression> 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 '^' -- <Bitwise Or Expression> ::= <Bitwise XOr Expression> -- | <Bitwise Or Expression> '|' <Bitwise XOr Expression> 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 '|' -- <Logical And Expression> ::= <Bitwise Or Expression> -- | <Logical And Expression> '&&' <Bitwise Or Expression>@@ -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 @@ -- <Assignment Expression> ::= <Conditional Expression> -- | <Left Hand Side Expression> <Assignment Operator> <Assignment Expression> 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])} -- <Assignment Operator> ::= '=' | '*=' | '/=' | '%=' | '+=' | '-=' | '<<=' | '>>=' | '>>>=' | '&=' | '^=' | '|='+-- 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 @@ -- | <Expression> statement :: Parser JSNode statement = statementBlock- <|> try(labelledStatement)+ <|> labelledStatement <|> expression <|> variableStatement <|> emptyStatement - <|> try(ifElseStatement)+ <|> ifElseStatement <|> ifStatement <|> iterationStatement <|> continueStatement @@ -773,21 +772,27 @@ -- <Block > ::= '{' '}' -- | '{' <Statement List> '}' 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 > ::= '{' '}' -- | '{' <Statement List> '}' 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" -- <Statement List> ::= <Statement> -- | <Statement List> <Statement>@@ -841,7 +846,7 @@ -- <If Else Statement> ::= 'if' '(' <Expression> ')' <Statement> 'else' <Statement> 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 @@ -- | '{' <Default Clause> '}' -- 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] -- <Case Clauses> ::= <Case Clause> -- | <Case Clauses> <Case Clause>@@ -990,7 +989,7 @@ -- <Labelled Statement> ::= Identifier ':' <Statement> 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 Statement> ::= 'throw' <Expression>
Text/Jasmine/Token.hs view
@@ -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 -- --------------------------------------------------------------------- {-
hjsmin.cabal view
@@ -1,5 +1,5 @@ name: hjsmin-version: 0.0.3+version: 0.0.4 license: BSD3 license-file: LICENSE author: Alan Zimmerman <alan.zimm@gmail.com>@@ -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