diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Alan Zimmerman + +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. + + * Neither the name of Alan Zimmerman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +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 +OWNER 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. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,31 @@ +hjsmin +====== + +Haskell implementation of a javascript minifier + +It is intended to be used in conjunction with Hamlet, part of Yesod. + +As such, much of the structure of the package is shamelessly copied from Hamlet. + +See http://github.com/snoyberg/hamlet + + +How to build +------------ + +Library: + +cabal clean && cabal configure && cabal build + +Tests: + +cabal clean && cabal configure -fbuildtests && cabal build + +Running the tests + +./dist/build/runtests/runtests + + + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO.txt b/TODO.txt new file mode 100644 --- /dev/null +++ b/TODO.txt @@ -0,0 +1,67 @@ +Testing: + +The following Lint has a sctrict parser + http://www.javascriptlint.com/online_lint.php + +This one does not + http://www.jslint.com/ + +--- + +Language reference https://developer.mozilla.org/en/JavaScript/Reference +http://msdn.microsoft.com/en-us/library/ttyab5c8.aspx + +--- + +Look at + + http://dean.edwards.name/download/#packer + + http://code.google.com/p/minify/ + +Examples of parsers + + JSon parser in Parsec + http://snippets.dzone.com/posts/show/3660 + +GOLD Parser, using the Javascript.grm from +http://www.devincook.com/GOLDParser/grammars/index.htm + +http://oss.org.cn/ossdocs/web/js/js20/formal/parser-grammar.html + +------------------------- + +- Generate output using standard pretty print library, so it can be + used with various backends + + +- Sort out semicolon insertion, as per http://oss.org.cn/ossdocs/web/js/js20/rationale/syntax.html + Also: http://inimino.org/~inimino/blog/javascript_semicolons + + Grammatical Semicolon Insertion + + Semicolons before a closing } and the end of the program are + optional in both JavaScript 1.5 and 2.0. In addition, the + JavaScript 2.0 parser allows semicolons to be omitted before the + else of an if-else statement and before the while of a do-while + statement. + + Line-Break Semicolon Insertion + + If the first through the nth tokens of a JavaScript program form + are grammatically valid but the first through the n+1st tokens are + not and there is a line break between the nth tokens and the n+1st + tokens, then the parser tries to parse the program again after + inserting a VirtualSemicolon token between the nth and the n+1st + tokens. + +- remove un-needed semicolons in pretty printer + +- put in tests for all cases of elementList + +-- Look at "in" keyword, as used : if (x in list) {} + +------------ + + +EOF diff --git a/Text/Jasmine.hs b/Text/Jasmine.hs new file mode 100644 --- /dev/null +++ b/Text/Jasmine.hs @@ -0,0 +1,32 @@ +module Text.Jasmine + ( + minify + , minifym + , minifyFile + ) where + +import Text.Jasmine.Parse +import Text.Jasmine.Pretty +import qualified Blaze.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString as B + +-- TODO: consider using option 4 of http://www.randomhacks.net/articles/2007/03/10/haskell-8-ways-to-report-errors +minifym :: B.ByteString -> Either String LB.ByteString +minifym s = case readJsm s of + Left msg -> Left msg + Right p -> Right $ BB.toLazyByteString $ renderJS p + +minify :: B.ByteString -> LB.ByteString +minify s = BB.toLazyByteString $ renderJS $ readJs s + +_minify' :: B.ByteString -> BB.Builder +_minify' s = renderJS $ readJs s + +minifyFile :: FilePath -> IO LB.ByteString +minifyFile filename = + do + x <- B.readFile (filename) + return $ minify x + +-- EOF diff --git a/Text/Jasmine/Parse.hs b/Text/Jasmine/Parse.hs new file mode 100644 --- /dev/null +++ b/Text/Jasmine/Parse.hs @@ -0,0 +1,1175 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Text.Jasmine.Parse + ( + readJs + , readJsm + , JasmineSettings (..) + , defaultJasmineSettings + , JSNode(..) + , parseFile + , parseString + -- For testing + , doParse + , program + , functionDeclaration + , identifier + , statementList + , iterationStatement + , main + ) where + +-- --------------------------------------------------------------------- + +import Control.Applicative ( (<|>) ) +import Control.Monad +import Data.Attoparsec (eitherResult) +import Data.Attoparsec.Char8 (char, satisfy, try, feed, Parser, Result(..), (), endOfInput, many, parse, sepBy, sepBy1, many1) +import Data.Char +import Data.Data +import Data.List +import Prelude hiding (catch) +import System.Environment +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import qualified Text.Jasmine.Token as P + +-- --------------------------------------------------------------------- +{- +data Result v = Error String | Ok v + deriving (Show, Eq, Read, Data, Typeable) +instance Monad Result where + return = Ok + Error s >>= _ = Error s + Ok v >>= f = f v + fail = Error +instance Functor Result where + fmap = liftM +instance Applicative Result where + pure = return + (<*>) = ap +-} + +-- --------------------------------------------------------------------- + +data JSNode = JSArguments [[JSNode]] + | JSArrayLiteral [JSNode] + | JSBlock JSNode + | JSBreak [JSNode] [JSNode] + | JSCallExpression String [JSNode] -- type : ., (), []; rest + | JSCase JSNode JSNode + | JSCatch JSNode [JSNode] JSNode + | JSContinue [JSNode] + | JSDecimal Integer + | JSDefault JSNode + | JSDoWhile JSNode JSNode JSNode + | JSElement String [JSNode] + | JSElementList [JSNode] + | JSElision [JSNode] + | JSEmpty JSNode + | JSExpression [JSNode] + | JSExpressionBinary String [JSNode] [JSNode] + | JSExpressionParen JSNode + | JSExpressionPostfix String [JSNode] + | JSExpressionTernary [JSNode] [JSNode] [JSNode] + | JSFinally JSNode + | JSFor [JSNode] [JSNode] [JSNode] JSNode + | JSForIn [JSNode] JSNode JSNode + | JSForVar [JSNode] [JSNode] [JSNode] JSNode + | JSForVarIn JSNode JSNode JSNode + | JSFunction JSNode [JSNode] JSNode -- name, parameter list, body + | JSFunctionBody [JSNode] + | JSFunctionExpression [JSNode] JSNode -- name, parameter list, body + | JSHexInteger Integer + | JSIdentifier String + | JSIf JSNode JSNode + | JSIfElse JSNode JSNode JSNode + | JSLabelled JSNode JSNode + | JSLiteral String + | JSMemberDot [JSNode] + | JSMemberSquare JSNode [JSNode] + | JSObjectLiteral [JSNode] + | JSOperator String + | JSPropertyNameandValue JSNode [JSNode] + | JSRegEx String + | JSReturn [JSNode] + | JSSourceElements [JSNode] + | JSSourceElementsTop [JSNode] + | JSStatementList [JSNode] + | JSStringLiteral Char [Char] + | JSSwitch JSNode [JSNode] + | JSThrow JSNode + | JSTry JSNode [JSNode] + | JSUnary String + | JSVarDecl JSNode [JSNode] + | JSVariables String [JSNode] + | JSWhile JSNode JSNode + | JSWith JSNode [JSNode] + deriving (Show, Eq, Read, Data, Typeable) + + +-- --------------------------------------------------------------------- +-- | Settings for parsing of a javascript document. +data JasmineSettings = JasmineSettings + { + -- | Placeholder in the structure, no actual settings yet + hjsminPlaceholder :: String + } + +-- --------------------------------------------------------------------- +-- | Defaults settings: settings not currently used +defaultJasmineSettings :: JasmineSettings +defaultJasmineSettings = JasmineSettings "foo" + +-- --------------------------------------------------------------------- +-- Interface to the Tokeniser + +identifier :: Parser JSNode +identifier = do{ val <- P.identifier; + return (JSIdentifier val)} + +autoSemi :: Parser JSNode +autoSemi = try (do { v1 <- P.autoSemi; + return (JSLiteral v1);}) + +autoSemi' :: Parser JSNode +autoSemi' = try (do { v1 <- P.autoSemi'; + return (JSLiteral v1);}) + +rOp :: String -> Parser () +rOp = P.rOp + + +-- --------------------------------------------------------------------- +-- Make Attoparsec work with parsec + +letter :: Parser Char +letter = satisfy isAlpha "letter" + +eof :: Parser () +eof = endOfInput + +-- --------------------------------------------------------------------- +-- The parser, based on the gold parser for Javascript +-- http://www.devincook.com/GOLDParser/grammars/files/JavaScript.zip + +-- ------------------------------------------------------------ +--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 /= '\'') + + + +-- ------------------------------------------------------------ + + +decimalLiteral :: Parser Integer +decimalLiteral = P.dec + +hexIntegerLiteral :: Parser Integer +hexIntegerLiteral = P.hex + +-- {String Chars1} = {Printable} + {HT} - ["\] +-- {RegExp Chars} = {Letter}+{Digit}+['^']+['$']+['*']+['+']+['?']+['{']+['}']+['|']+['-']+['.']+[',']+['#']+['[']+[']']+['_']+['<']+['>'] +-- {Non Terminator} = {String Chars1} - {CR} - {LF} +-- RegExp = '/' ({RegExp Chars} | '\' {Non Terminator})+ '/' ( 'g' | 'i' | 'm' )* + +-- --------------------------------------------------------------------- +-- From HJS + +regex :: Parser [Char] +regex = do { _ <- char '/'; body <- do { c <- firstchar; cs <- many otherchar; return $ concat (c:cs) }; _ <- char '/'; + flg <- identPart; return $ ("/"++body++"/"++flg) } + +firstchar :: Parser [Char] +firstchar = do { c <- satisfy (\c -> isPrint c && c /= '*' && c /= '\\' && c /= '/'); + return [c]} <|> escapeseq + + +escapeseq :: Parser [Char] +escapeseq = do { _ <- char '\\'; c <- satisfy (\cc -> isPrint cc); return ['\\',c]} + +otherchar :: Parser [Char] +otherchar = do { c <- satisfy (\c -> isPrint c && c /= '\\' && c /= '/'); + return [c]} <|> escapeseq + +identPart :: Parser [Char] +identPart = many letter + +-- --------------------------------------------------------------------- + + +regExp :: Parser JSNode +regExp = P.lexeme $ do { v1 <- regex; + return (JSRegEx v1)} + +-- ::= +-- | +-- | +-- | StringLiteral +literal :: Parser JSNode +literal = nullLiteral + <|> booleanLiteral + <|> numericLiteral + <|> stringLiteral + +-- ::= null +nullLiteral :: Parser JSNode +nullLiteral = do { _ <- P.reserved "null"; + return (JSLiteral "null")} + +-- ::= 'true' +-- | 'false' +booleanLiteral :: Parser JSNode +booleanLiteral = do{ _ <- P.reserved "true" ; + return (JSLiteral "true")} + <|> do{ P.reserved "false"; + return (JSLiteral "false")} + +-- ::= DecimalLiteral +-- | HexIntegerLiteral +numericLiteral :: Parser JSNode +numericLiteral = do {val <- decimalLiteral; + return (JSDecimal val)} + <|> do {val <- hexIntegerLiteral; + return (JSHexInteger val)} + + +-- ::= RegExp +regularExpressionLiteral :: Parser JSNode +regularExpressionLiteral = regExp + + +-- ::= 'this' +-- | Identifier +-- | +-- | +-- | +-- | '(' ')' +-- | +primaryExpression :: Parser JSNode +primaryExpression = do {P.reserved "this"; + -- return [""]} + return (JSLiteral "this")} + <|> identifier + <|> literal + <|> arrayLiteral + <|> objectLiteral + <|> do{ rOp "("; val <- expression; rOp ")"; + return (JSExpressionParen val)} + <|> regularExpressionLiteral + +-- --------------------------------------------------------------------- +-- Rework array literal + + +-- ::= '[' ']' +-- | '[' ']' +-- | '[' ']' +-- | '[' ',' ']' + +-- ::= ',' +-- | ',' + +-- ::= +-- | ',' +-- | ',' +-- | + +-------- +--so + +-- ::= '[' many (',' <|> assignment) ']' + + +-- --------------------------------------------------------------------- + +-- ::= '[' ']' +-- | '[' ']' +-- | '[' ']' +-- | '[' ',' ']' +arrayLiteral :: Parser JSNode +arrayLiteral = do {rOp "["; v1 <- many (do { rOp ","; return [(JSElision [])]} <|> assignmentExpression); rOp "]"; + return (JSArrayLiteral (flatten v1)) } + +{- +arrayLiteral :: GenParser Char P.JSPState JSNode +arrayLiteral = do {rOp "["; + do { + do { rOp "]"; + return (JSArrayLiteral [])} + <|> do { v1 <- elision; rOp "]"; + return (JSArrayLiteral [v1])} + <|> do { v1 <- elementList; rOp "]"; + do { + do { rOp ","; v2 <- elision; rOp "]"; + return (JSArrayLiteral (v1++[v2]))} + <|> return (JSArrayLiteral v1) + } + } + } + } + + +-- ::= ',' +-- | ',' +elision :: GenParser Char P.JSPState JSNode +elision = do{ rOp ","; + return (JSElision [])} + <|> do{ v1 <- elision; rOp ","; + return (JSElision [v1])} + + +-- ::= +-- | ',' +-- | ',' +-- | +elementList :: GenParser Char P.JSPState [JSNode] +elementList = do { v1 <- elision; v2 <- assignmentExpression; v3 <-rest; + return [(JSElementList (v1:(v2++v3)))] } + <|> do { v1 <- assignmentExpression; v2 <- rest; + return [(JSElementList (v1++v2))]} + where + rest = + do {rOp ","; + do { + do { v2 <- elision; v3 <- assignmentExpression; + return [] {- ([v2]++v3)-}} + <|> do { v2 <- assignmentExpression; + return [] {-v2-}} + } + } + <|> do {return []} +-} + +-- ::= '{' '}' +objectLiteral :: Parser JSNode +objectLiteral = do{ rOp "{"; val <- propertyNameandValueList; rOp "}"; + return (JSObjectLiteral val)} + +-- ::= ':' +-- | ',' ':' +propertyNameandValueList :: Parser [JSNode] +propertyNameandValueList = do{ val <- sepBy propertyNameandValue (rOp ","); -- Note: can be zero elements + return val} + +-- Seems we can have function declarations in the value part too +propertyNameandValue :: Parser JSNode +propertyNameandValue = do{ v1 <- propertyName; rOp ":"; + do { + do {v2 <- assignmentExpression; + return (JSPropertyNameandValue v1 v2)} + <|> do {v2 <- functionDeclaration; + return (JSPropertyNameandValue v1 [v2])} + } + } + +-- ::= Identifier +-- | StringLiteral +-- | +propertyName :: Parser JSNode +propertyName = identifier + <|> stringLiteral + <|> numericLiteral + + +-- ::= +-- | +-- | '[' ']' +-- | '.' Identifier +-- | 'new' +memberExpression :: Parser [JSNode] +memberExpression = try(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)}) + + where + rest = do{ rOp "["; v1 <- expression; rOp "]"; v2 <- rest; + return [JSMemberSquare v1 v2]} + <|> do{ rOp "."; v1 <- identifier ; v2 <- rest; + return [JSMemberDot (v1:v2)]} + <|> return [] + + + +-- ::= +-- | new +newExpression :: Parser [JSNode] +newExpression = memberExpression + <|> do{ P.reserved "new"; val <- newExpression; + return ((JSLiteral "new "):val)} + +-- ::= +-- | +-- | '[' ']' +-- | '.' Identifier + +callExpression :: Parser [JSNode] +callExpression = do{ v1 <- memberExpression; v2 <- arguments; + do { v3 <- rest; + return (v1++[v2]++v3)} + <|> do {return (v1++[v2] )} + } + where + rest = + do{ v4 <- arguments ; v5 <- rest; + return ([(JSCallExpression "()" [v4])]++v5)} + <|> do{ rOp "["; v4 <- expression; rOp "]"; v5 <- rest; + return ([JSCallExpression "[]" [v4]]++v5)} + <|> do{ rOp "."; v4 <- identifier; v5 <- rest; + return ([JSCallExpression "." [v4]]++v5)} + <|> return [] -- As per HJS, seems to extend the syntax + +-- --------------------------------------------------------------------- +-- From HJS +{- +callExpr = do { x <- memberExpr; + do {rOp "("; whiteSpace; args <- commaSep assigne; whiteSpace; rOp ")"; rest $ CallMember x args } + <|> do { return $ CallPrim x } + <|> do { rOp "++"; return $ CallPrim x } + } + where + rest x = + try (do { rOp "("; args <- commaSep assigne; rOp ")" ; rest $ CallCall x args }) + <|> try (do { rOp "."; i <- identifier; rest $ CallDot x i }) + <|> try (do { rOp "["; e <- expr; rOp "]"; rest $ CallSquare x e }) + <|> return x +-} +-- --------------------------------------------------------------------- + + +-- ::= '(' ')' +-- | '(' ')' +arguments :: Parser JSNode +arguments = try(do{ rOp "("; rOp ")"; + return (JSArguments [[]])}) + <|> do{ rOp "("; v1 <- argumentList; rOp ")"; + return (JSArguments v1)} + +-- ::= +-- | ',' +argumentList :: Parser [[JSNode]] +argumentList = do{ vals <- sepBy1 assignmentExpression (rOp ","); + return vals} + + +-- ::= +-- | +leftHandSideExpression :: Parser [JSNode] +leftHandSideExpression = try (callExpression) + <|> newExpression + "leftHandSideExpression" + + +-- ::= +-- | '++' +-- | '--' +postfixExpression :: Parser [JSNode] +postfixExpression = do{ v1 <- leftHandSideExpression; + do { + do{ rOp "++"; return [(JSExpressionPostfix "++" v1)]} + <|> do{ rOp "--"; return [(JSExpressionPostfix "--" v1)]} + <|> return v1 + } + } + +-- ::= +-- | 'delete' +-- | 'void' +-- | 'typeof' +-- | '++' +-- | '--' +-- | '+' +-- | '-' +-- | '~' +-- | '!' +unaryExpression :: Parser [JSNode] +unaryExpression = do{ v1 <- postfixExpression; + return v1} + <|> do{ P.reserved "delete"; v1 <- unaryExpression; + return ((JSUnary "delete "):v1)} + <|> do{ P.reserved "void"; v1 <- unaryExpression; + return ((JSUnary "void"):v1)} + <|> do{ P.reserved "typeof"; v1 <- unaryExpression; + return ((JSUnary "typeof "):v1)} -- TODO: should the space always be there? + <|> do{ rOp "++"; v1 <- unaryExpression; + return ((JSUnary "++"):v1)} + <|> do{ rOp "--"; v1 <- unaryExpression; + return ((JSUnary "--"):v1)} + <|> do{ rOp "+"; v1 <- unaryExpression; + return ((JSUnary "+"):v1)} + <|> do{ rOp "-"; v1 <- unaryExpression; + return ((JSUnary "-"):v1)} + <|> do{ rOp "~"; v1 <- unaryExpression; + return ((JSUnary "~"):v1)} + <|> do{ rOp "!"; v1 <- unaryExpression; + return ((JSUnary "!"):v1)} + +-- ::= +-- | '*' +-- | '/' +-- | '%' +multiplicativeExpression :: Parser [JSNode] +multiplicativeExpression = do{ v1 <- unaryExpression; v2 <- rest; + return (v1++v2)} + where + rest = + do{ rOp "*"; v2 <- multiplicativeExpression; v3 <- rest; + return [(JSExpressionBinary "*" v2 v3)]} + <|> do{ rOp "/"; v2 <- multiplicativeExpression; v3 <- rest; + return [(JSExpressionBinary "/" v2 v3)]} + <|> do{ rOp "%"; v2 <- multiplicativeExpression; v3 <- rest; + return [(JSExpressionBinary "%" v2 v3)]} + <|> return [] + + +-- ::= '+' +-- | '-' +-- | +additiveExpression :: Parser [JSNode] +additiveExpression = do{ v1 <- multiplicativeExpression; v2 <- rest; + return (v1++v2)} + where + rest = + do { rOp "+"; v2 <- multiplicativeExpression; v3 <- rest; + return ([(JSExpressionBinary "+" v2 v3)])} + <|> do { rOp "-"; v2 <- multiplicativeExpression; v3 <- rest; + return ([(JSExpressionBinary "-" v2 v3)])} + <|> return [] + + +-- ::= '<<' +-- | '>>' +-- | '>>>' +-- | +shiftExpression :: Parser [JSNode] +shiftExpression = do{ v1 <- additiveExpression; v2 <- rest; + return (v1++v2)} + where + rest = + do{ rOp "<<"; v2 <- additiveExpression; v3 <- rest; + return [(JSExpressionBinary "<<" v2 v3)]} + <|> do{ rOp ">>>"; v2 <- additiveExpression; v3 <- rest; + return [(JSExpressionBinary ">>>" v2 v3)]} + <|> do{ rOp ">>"; v2 <- additiveExpression; v3 <- rest; + return [(JSExpressionBinary ">>" v2 v3)]} + <|> return [] + + +-- ::= +-- | '<' +-- | '>' +-- | '<=' +-- | '>=' +-- | 'instanceof' +relationalExpression :: Parser [JSNode] +relationalExpression = do{ v1 <- shiftExpression; v2 <- rest; + return (v1++v2)} + where + rest = + do{ rOp "<="; v2 <- shiftExpression; v3 <- rest; + return [(JSExpressionBinary "<=" v2 v3)]} + <|> do{ rOp ">="; v2 <- shiftExpression; v3 <- rest; + return [(JSExpressionBinary ">=" v2 v3)]} + + <|> do{ rOp "<"; v2 <- shiftExpression; v3 <- rest; + return [(JSExpressionBinary "<" v2 v3)]} + <|> do{ rOp ">"; v2 <- shiftExpression; v3 <- rest; + return [(JSExpressionBinary ">" v2 v3)]} + <|> do{ P.reserved "instanceof"; v2 <- shiftExpression; v3 <- rest; + return [(JSExpressionBinary " instanceof " v2 v3)]} + -- Strictly speaking should have all the NoIn variants of expressions, + -- but we assume syntax is checked so no problem. Cross fingers. + <|> do{ P.reserved "in"; v2 <- shiftExpression; v3 <- rest; + return [(JSExpressionBinary " in " v2 v3)]} + <|> return [] + + + +-- ::= +-- | '==' +-- | '!=' +-- | '===' +-- | '!==' +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 [] + + +-- ::= +-- | '&' +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 [] + + +-- ::= +-- | '^' +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 [] + + +-- ::= +-- | '|' +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 [] + + + +-- ::= +-- | '&&' +logicalAndExpression :: Parser [JSNode] +logicalAndExpression = do{ v1 <- bitwiseOrExpression; v2 <- rest; + return (v1++v2)} + where + rest = + do{ rOp "&&"; v2 <- bitwiseOrExpression; v3 <- rest; + return [(JSExpressionBinary "&&" v2 v3)]} + <|> return [] + + + + +-- ::= +-- | '||' +logicalOrExpression :: Parser [JSNode] +logicalOrExpression = do{ v1 <- logicalAndExpression; v2 <- rest; + return (v1++v2)} + where + rest = + try(do{ rOp "||"; v2 <- logicalAndExpression; v3 <- rest; + return [(JSExpressionBinary "||" v2 v3)]}) + <|> return [] + + +-- ::= +-- | '?' ':' +conditionalExpression :: Parser [JSNode] +conditionalExpression = do{ v1 <- logicalOrExpression; + do { + do{ rOp "?"; v2 <- assignmentExpression; rOp ":"; v3 <- assignmentExpression; + return [(JSExpressionTernary v1 v2 v3)]} + <|> return v1 + } + } + + +-- ::= +-- | +assignmentExpression :: Parser [JSNode] +assignmentExpression = try (do {v1 <- assignmentStart; v2 <- assignmentExpression; + return [(JSElement "assignmentExpression" (v1++v2))]}) + <|> conditionalExpression + +assignmentStart :: Parser [JSNode] +assignmentStart = do {v1 <- leftHandSideExpression; v2 <- assignmentOperator; + return (v1++[v2])} + +-- ::= '=' | '*=' | '/=' | '%=' | '+=' | '-=' | '<<=' | '>>=' | '>>>=' | '&=' | '^=' | '|=' +assignmentOperator :: Parser JSNode +assignmentOperator = rOp' "=" <|> rOp' "*=" <|> rOp' "/=" <|> rOp' "%=" <|> rOp' "+=" <|> rOp' "-=" + <|> rOp' "<<=" <|> rOp' ">>=" <|> rOp' ">>>=" <|> rOp' "&=" <|> rOp' "^=" <|> rOp' "|=" + +rOp' :: String -> Parser JSNode +rOp' x = do{ rOp x; return $ JSOperator x} + +-- ::= +-- | ',' +expression :: Parser JSNode +expression = do{ val <- sepBy1 assignmentExpression (rOp ","); + return (JSExpression (flattenExpression val))} + + +flattenExpression :: [[JSNode]] -> [JSNode] +flattenExpression val = flatten $ intersperse litComma val + where + litComma :: [JSNode] + litComma = [(JSLiteral ",")] + +-- ::= +-- | +-- | +-- | +-- | +-- | +-- | +-- | +-- | +-- | +-- | +-- | +-- | +-- | +-- | +statement :: Parser JSNode +statement = statementBlock + <|> try(labelledStatement) + <|> expression + <|> variableStatement + <|> emptyStatement + <|> try(ifElseStatement) + <|> ifStatement + <|> iterationStatement + <|> continueStatement + <|> breakStatement + <|> returnStatement + <|> withStatement + <|> switchStatement + <|> throwStatement + <|> tryStatement + "statement" + + +statementBlock :: Parser JSNode +statementBlock = do {v1 <- statementBlock'; return (if (v1 == []) then (JSLiteral ";") else (head v1))} + +-- ::= '{' '}' +-- | '{' '}' +statementBlock' :: Parser [JSNode] +statementBlock' = try (do {rOp "{"; rOp "}"; + return []}) + <|> do {rOp "{"; val <- statementList; rOp "}"; + 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" + + +-- ::= +-- | +statementList :: Parser JSNode +statementList = do {v1 <- many1 statement; + return (JSStatementList v1)} + + +-- ::= var ';' +-- Note: Mozilla introduced const declarations, not part of official spec +variableStatement :: Parser JSNode +variableStatement = do {P.reserved "var"; val <- variableDeclarationList; + return (JSVariables "var" val)} + <|> do {P.reserved "const"; val <- variableDeclarationList; + return (JSVariables "const" val)} + + +-- ::= +-- | ',' +variableDeclarationList :: Parser [JSNode] +variableDeclarationList = do{ val <- sepBy1 variableDeclaration (rOp ","); + return val } + + +-- ::= Identifier +-- | Identifier +variableDeclaration :: Parser JSNode +variableDeclaration = do{ v1 <- identifier; + do { + do {v2 <- initializer; + return (JSVarDecl v1 v2)} + <|> return (JSVarDecl v1 []) + } + } + +-- ::= '=' +initializer :: Parser [JSNode] +initializer = do {rOp "="; val <- assignmentExpression; + return val} + +-- ::= ';' +emptyStatement :: Parser JSNode +--emptyStatement = do { v1 <- autoSemi'; return (JSEmpty v1)} +emptyStatement = do { v1 <- autoSemi'; return v1} + + +-- ::= 'if' '(' ')' +ifStatement :: Parser JSNode +ifStatement = do{ P.reserved "if"; rOp "("; v1 <- expression; rOp ")"; v2 <- statement; + return (JSIf v1 v2) } + +-- ::= 'if' '(' ')' 'else' +ifElseStatement :: Parser JSNode +ifElseStatement = do{ P.reserved "if"; rOp "("; v1 <- expression; rOp ")"; v2 <- statementSemi; P.reserved "else"; v3 <- statement ; + return (JSIfElse v1 v2 v3) } + +statementSemi :: Parser JSNode +statementSemi = do { v1 <- statement; + do { + do { rOp ";"; return (JSBlock (JSStatementList [v1]))} + <|> return v1 + } + } + + +-- ::= 'do' 'while' '(' ')' ';' +-- | 'while' '(' ')' +-- | 'for' '(' ';' ';' ')' +-- | 'for' '(' 'var' ';' ';' ')' +-- | 'for' '(' in ')' +-- | 'for' '(' 'var' in ')' +iterationStatement :: Parser JSNode +iterationStatement = do{ P.reserved "do"; v1 <- statement; P.reserved "while"; rOp "("; v2 <- expression; rOp ")"; v3 <- autoSemi ; + return (JSDoWhile v1 v2 v3)} + <|> do{ P.reserved "while"; rOp "("; v1 <- expression; rOp ")"; v2 <- statement; + return (JSWhile v1 v2)} + + <|> do{ P.reserved "for"; rOp "("; + do { + do{ P.reserved "var"; v1 <- variableDeclaration; + do { + do { rOp ","; v1' <- variableDeclarationList; rOp ";"; v2 <- optionalExpression ";"; + v3 <- optionalExpression ")"; v4 <- statement; + return (JSForVar (v1:v1') v2 v3 v4)} + <|> do { rOp ";"; v2 <- optionalExpression ";"; + v3 <- optionalExpression ")"; v4 <- statement; + return (JSForVar [v1] v2 v3 v4)} + <|> do { P.reserved "in"; v2 <- expression; rOp ")"; v3 <- statement; + return (JSForVarIn v1 v2 v3)} + } + } + <|> try(do{ v1 <- leftHandSideExpression; P.reserved "in"; v2 <- expression; rOp ")"; + v3 <- statement; + return (JSForIn v1 v2 v3)}) + <|> do { v1 <- optionalExpression ";"; v2 <- optionalExpression ";"; + v3 <- optionalExpression ")"; v4 <- statement; + return (JSFor v1 v2 v3 v4)} + } + } + "iterationStatement" + +optionalExpression :: [Char] -> Parser [JSNode] +optionalExpression s = do { rOp s; + return []} + <|> do { v1 <- expression; rOp s ; + return [v1]} + +-- ::= 'continue' ';' +-- | 'continue' Identifier ';' +continueStatement :: Parser JSNode +continueStatement = do {P.reserved "continue"; v1 <- autoSemi; + return (JSContinue [v1])} + <|> do {P.reserved "continue"; v1 <- identifier; v2 <- autoSemi; + return (JSContinue [v1,v2])} + + +-- ::= 'break' ';' +-- | 'break' Identifier ';' +breakStatement :: Parser JSNode +breakStatement = do {P.reserved "break"; + do { + do {v1 <- identifier; v2 <- autoSemi; + return (JSBreak [v1] [v2])} + <|> do {v1 <- autoSemi; + return (if (v1 == JSLiteral "") then (JSBreak [] []) else (JSBreak [] [v1]))} + } + } + + +-- ::= 'return' ';' +-- | 'return' ';' +returnStatement :: Parser JSNode +returnStatement = do {P.reserved "return"; + do{ + do {v1 <- expression; v2 <- autoSemi; + return (JSReturn [v1,v2])} + <|> do {v1 <- autoSemi; return (JSReturn [v1])} + + } + } + + +-- ::= 'with' '(' ')' ';' +withStatement :: Parser JSNode +withStatement = do{ P.reserved "with"; rOp "("; v1 <- expression; rOp ")"; v2 <- statement; v3 <- autoSemi; + return (JSWith v1 [v2,v3])} + + +-- ::= 'switch' '(' ')' +switchStatement :: Parser JSNode +switchStatement = do{ P.reserved "switch"; rOp "("; v1 <- expression; rOp ")"; v2 <- caseBlock; + return (JSSwitch v1 v2)} + +-- ::= '{' '}' +-- | '{' '}' +-- | '{' '}' +-- | '{' '}' +-- | '{' '}' +-- | '{' '}' +-- 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]} + + +-- ::= +-- | +caseClauses :: Parser [JSNode] +caseClauses = do{ val <- many1 caseClause; + return val} + +-- ::= 'case' ':' +-- | 'case' ':' +caseClause :: Parser JSNode +caseClause = do { P.reserved "case"; v1 <- expression; rOp ":"; + do { + do { v2 <- statementList; + return (JSCase v1 v2)} + <|> return (JSCase v1 (JSStatementList [])) + } + } + +-- ::= 'default' ':' +-- | 'default' ':' +defaultClause :: Parser JSNode +defaultClause = do{ P.reserved "default"; rOp ":"; v1 <- statementList; + return (JSDefault v1)} + <|> do{ P.reserved "default"; rOp ":"; + return (JSDefault (JSStatementList []))} + +-- ::= Identifier ':' +labelledStatement :: Parser JSNode +labelledStatement = do { v1 <- identifier; rOp ":"; v2 <- statement; + return (JSLabelled v1 v2)} + +-- ::= 'throw' +throwStatement :: Parser JSNode +throwStatement = do{ P.reserved "throw"; val <- expression; + return (JSThrow val)} + +-- Note: worked in updated syntax as per https://developer.mozilla.org/en/JavaScript/Reference/Statements/try...catch +-- ::= 'try' +-- | 'try' +-- | 'try' +tryStatement :: Parser JSNode +tryStatement = do{ P.reserved "try"; v1 <- block; + do { + do { v2 <- many1 catch; + do { v3 <- finally; + return (JSTry v1 (v2++[v3]))} + <|> return (JSTry v1 v2) + } + <|> do{ v2 <- finally; + return (JSTry v1 [v2])} + } + } + +-- Note: worked in updated syntax as per https://developer.mozilla.org/en/JavaScript/Reference/Statements/try...catch +-- ::= 'catch' '(' Identifier ')' +-- becomes +-- ::= 'catch' '(' Identifier ')' +-- | 'catch' '(' Identifier 'if' Condition ')' +catch :: Parser JSNode +catch = do{ P.reserved "catch"; rOp "("; v1 <- identifier; + do { + do { rOp ")"; v3 <- block; + return (JSCatch v1 [] v3)} + <|> do { P.reserved "if"; v2 <- conditionalExpression; rOp ")"; v3 <- block; + return (JSCatch v1 v2 v3)} + } + } + +-- ::= 'finally' +finally :: Parser JSNode +finally = do{ P.reserved "finally"; v1 <- block; + return (JSFinally v1)} + +-- ::= 'function' Identifier '(' ')' '{' '}' +-- | 'function' Identifier '(' ')' '{' '}' +functionDeclaration :: Parser JSNode +functionDeclaration = do {P.reserved "function"; v1 <- identifier; rOp "("; v2 <- formalParameterList; rOp ")"; + v3 <- functionBody; + return (JSFunction v1 v2 v3) } + "functionDeclaration" + + +-- ::= 'function' '(' ')' '{' '}' +--- | 'function' '(' ')' '{' '}' +functionExpression :: Parser JSNode +functionExpression = do{ P.reserved "function"; rOp "("; + do { + do { rOp ")"; v2 <- functionBody; + return (JSFunctionExpression [] v2)} + <|> do {v1 <- formalParameterList; rOp ")"; v2 <- functionBody; + return (JSFunctionExpression v1 v2)} + } + } + +-- ::= Identifier +-- | ',' Identifier +formalParameterList :: Parser [JSNode] +formalParameterList = sepBy identifier (rOp ",") + +-- ::= '{' '}' +-- | '{' '}' +functionBody :: Parser JSNode +functionBody = do{ rOp "{"; + do { + do{ rOp "}"; + return (JSFunctionBody []) } + <|> do{ v1 <- sourceElements; rOp "}"; + return (JSFunctionBody [v1]) } + } + } + "functionBody" + +-- ::= +program :: Parser JSNode +program = do {P.whiteSpace; val <- sourceElementsTop; eof; + return val} + + +-- ::= +-- | +sourceElements :: Parser JSNode +sourceElements = do{ val <- many1 sourceElement; + return (JSSourceElements val)} + +sourceElementsTop :: Parser JSNode +sourceElementsTop = do{ val <- many1 sourceElement; + return (JSSourceElementsTop val)} + + +-- ::= +-- | +sourceElement :: Parser JSNode +sourceElement = functionDeclaration + <|> statement + "sourceElement" + + + +-- --------------------------------------------------------------- +-- Testing + +-- --------------------------------------------------------------------- + +flatten :: [[a]] -> [a] +flatten xs = foldl' (++) [] xs + +-- --------------------------------------------------------------------- + +main :: IO () +main = + do args <- getArgs + x <- B.readFile (args !! 0) + putStrLn (show $ doParse program x) + + +-- --------------------------------------------------------------------- + +readJs :: B.ByteString -> JSNode +readJs input = case doParse program input of + Fail _unparsed contexts err -> error("Parse failed" ++ show(contexts) ++ ":" ++ show err) + Partial _f -> error("Unexpected partial") + Done _unparsed val -> val + +-- --------------------------------------------------------------------- + +{- +readJsm :: (Monad m) => B.ByteString -> m JSNode +readJsm input = case eitherResult $ doParse program input of + Left msg -> fail ("Parse failed:" ++ msg) + Right val -> return val +-} +--readJsm :: (Monad m) => B.ByteString -> m JSNode +readJsm :: B.ByteString -> Either String JSNode +readJsm input = eitherResult $ doParse program input + +-- --------------------------------------------------------------------- + +_doParse' :: Parser a -> String -> a +_doParse' p input = case parse (p' p) (E.encodeUtf8 $ T.pack input) of + Fail _unparsed contexts err -> error("Parse failed" ++ show(contexts) ++ ":" ++ show err) + Partial _f -> error("Unexpected partial") + Done _unparsed val -> val + +doParse :: Parser r -> B.ByteString -> Result r +doParse p input = {-maybeResult $-} feed (parse (p' p) input) B.empty + +parseString :: Parser r -> String -> Result r +parseString p input = doParse p (E.encodeUtf8 $ T.pack input) + +-- --------------------------------------------------------------------- + +p' :: Parser b -> Parser b +p' p = do {val <- p; eof; return val} + +-- --------------------------------------------------------------------- + +_showFile :: FilePath -> IO String +_showFile filename = + do + x <- readFile (filename) + return $ (show x) + +-- --------------------------------------------------------------------- + +parseFile :: FilePath -> IO JSNode +parseFile filename = + do + x <- B.readFile (filename) + return $ (readJs x) + +-- EOF diff --git a/Text/Jasmine/Pretty.hs b/Text/Jasmine/Pretty.hs new file mode 100644 --- /dev/null +++ b/Text/Jasmine/Pretty.hs @@ -0,0 +1,701 @@ +module Text.Jasmine.Pretty + ( + renderJS + ) where + +import Data.Char +import Data.List +import Data.Monoid +import Text.Jasmine.Parse +import qualified Blaze.ByteString.Builder as BB +import qualified Blaze.ByteString.Builder.Char.Utf8 as BS +import qualified Data.ByteString.Lazy as LB + +-- --------------------------------------------------------------------- +-- Pretty printer stuff via blaze-builder + +(<>) :: BB.Builder -> BB.Builder -> BB.Builder +(<>) a b = mappend a b + +(<+>) :: BB.Builder -> BB.Builder -> BB.Builder +(<+>) a b = mconcat [a, (text " "), b] + +hcat :: (Monoid a) => [a] -> a +hcat xs = mconcat xs + +empty :: BB.Builder +empty = mempty + +text :: String -> BB.Builder +text s = BS.fromString s + +char :: Char -> BB.Builder +char c = BS.fromChar c + +comma :: BB.Builder +comma = BS.fromChar ',' + +punctuate :: a -> [a] -> [a] +punctuate p xs = intersperse p xs + +-- --------------------------------------------------------------------- + + +renderJS :: JSNode -> BB.Builder +renderJS (JSEmpty l) = (renderJS l) +renderJS (JSIdentifier s) = text s +renderJS (JSDecimal i) = text $ show i +renderJS (JSOperator s) = text s +renderJS (JSExpression xs) = rJS xs +renderJS (JSSourceElements xs) = rJS (map fixBlock $ fixSourceElements xs) +renderJS (JSSourceElementsTop xs)= rJS (fixTop $ map fixBlock $ fixSourceElements xs) +renderJS (JSElement _s xs) = rJS $ fixLiterals xs +renderJS (JSFunction s p xs) = (text "function") <+> (renderJS s) <> (text "(") <> (commaList p) <> (text ")") <> (renderJS xs) +renderJS (JSFunctionBody xs) = (text "{") <> (rJS xs) <> (text "}") +renderJS (JSFunctionExpression as s) = (text "function") <> (text "(") <> (commaList as) <> (text ")") <> (renderJS s) +renderJS (JSArguments xs) = (text "(") <> (commaListList $ map fixLiterals xs) <> (text ")") + +renderJS (JSBlock x) = (text "{") <> (renderJS x) <> (text "}") + +renderJS (JSIf c (JSLiteral ";"))= (text "if") <> (text "(") <> (renderJS c) <> (text ")") +renderJS (JSIf c t) = (text "if") <> (text "(") <> (renderJS c) <> (text ")") <> (renderJS $ fixBlock t) + +renderJS (JSIfElse c t (JSLiteral ";")) = (text "if") <> (text "(") <> (renderJS c) <> (text ")") <> (renderJS t) + <> (text "else") +renderJS (JSIfElse c t e) = (text "if") <> (text "(") <> (renderJS c) <> (text ")") <> (renderJS t) + <> (text "else") <> (spaceOrBlock $ fixBlock e) +renderJS (JSMemberDot xs) = (text ".") <> (rJS xs) +renderJS (JSMemberSquare x xs) = (text "[") <> (renderJS x) <> (text "]") <> (rJS xs) +renderJS (JSLiteral l) = (text l) +renderJS (JSStringLiteral s l) = empty <> (char s) <> (text l) <> (char s) +renderJS (JSUnary l ) = text l +renderJS (JSArrayLiteral xs) = (text "[") <> (rJS xs) <> (text "]") + +renderJS (JSBreak [] []) = (text "break") +renderJS (JSBreak [] _xs) = (text "break") -- <> (rJS xs) -- <> (text ";") +renderJS (JSBreak is _xs) = (text "break") <+> (rJS is) -- <> (rJS xs) + +renderJS (JSCallExpression "()" xs) = (rJS xs) +renderJS (JSCallExpression t xs) = (char $ head t) <> (rJS xs) <> (if ((length t) > 1) then (char $ last t) else empty) + +-- No space between 'case' and string literal. TODO: what about expression in parentheses? +renderJS (JSCase (JSExpression [JSStringLiteral sepa s]) xs) = (text "case") <> (renderJS (JSStringLiteral sepa s)) + <> (char ':') <> (renderJS xs) +renderJS (JSCase e xs) = (text "case") <+> (renderJS e) <> (char ':') <> (renderJS xs) -- <> (text ";"); + +renderJS (JSCatch i [] s) = (text "catch") <> (char '(') <> (renderJS i) <> (char ')') <> (renderJS s) +renderJS (JSCatch i c s) = (text "catch") <> (char '(') <> (renderJS i) <> + (text " if ") <> (rJS c) <> (char ')') <> (renderJS s) + +renderJS (JSContinue is) = (text "continue") <> (rJS is) -- <> (char ';') +renderJS (JSDefault xs) = (text "default") <> (char ':') <> (renderJS xs) +renderJS (JSDoWhile s e _ms) = (text "do") <> (renderJS s) <> (text "while") <> (char '(') <> (renderJS e) <> (char ')') -- <> (renderJS ms) +renderJS (JSElementList xs) = rJS xs +renderJS (JSElision xs) = (char ',') <> (rJS xs) +--renderJS (JSExpressionBinary o e1 e2) = (rJS e1) <> (text o) <> (rJS e2) +renderJS (JSExpressionBinary o e1 e2) = (text o) <> (rJS e1) <> (rJS e2) +renderJS (JSExpressionParen e) = (char '(') <> (renderJS e) <> (char ')') +renderJS (JSExpressionPostfix o e) = (rJS e) <> (text o) +renderJS (JSExpressionTernary c v1 v2) = (rJS c) <> (char '?') <> (rJS v1) <> (char ':') <> (rJS v2) +renderJS (JSFinally b) = (text "finally") <> (renderJS b) + +renderJS (JSFor e1 e2 e3 s) = (text "for") <> (char '(') <> (commaList e1) <> (char ';') + <> (rJS e2) <> (char ';') <> (rJS e3) <> (char ')') <> (renderJS $ fixBlock s) +renderJS (JSForIn e1 e2 s) = (text "for") <> (char '(') <> (rJS e1) <+> (text "in") + <+> (renderJS e2) <> (char ')') <> (renderJS $ fixBlock s) +renderJS (JSForVar e1 e2 e3 s) = (text "for") <> (char '(') <> (text "var") <+> (commaList e1) <> (char ';') + <> (rJS e2) <> (char ';') <> (rJS e3) <> (char ')') <> (renderJS $ fixBlock s) +renderJS (JSForVarIn e1 e2 s) = (text "for") <> (char '(') <> (text "var") <+> (renderJS e1) <+> (text "in") + <+> (renderJS e2) <> (char ')') <> (renderJS $ fixBlock s) + +renderJS (JSHexInteger i) = (text $ show i) -- TODO: need to tweak this +renderJS (JSLabelled l v) = (renderJS l) <> (text ":") <> (renderJS v) +renderJS (JSObjectLiteral xs) = (text "{") <> (commaList xs) <> (text "}") +renderJS (JSPropertyNameandValue n vs) = (renderJS n) <> (text ":") <> (rJS vs) +renderJS (JSRegEx s) = (text s) + +renderJS (JSReturn []) = (text "return") +renderJS (JSReturn [JSLiteral ";"]) = (text "return;") +renderJS (JSReturn xs) = (text "return") <> (if (spaceNeeded xs) then (text " ") else (empty)) <> (rJS $ fixSourceElements xs) + +renderJS (JSThrow e) = (text "throw") <+> (renderJS e) + +renderJS (JSStatementList xs) = rJS (fixSourceElements $ map fixBlock xs) + +renderJS (JSSwitch e xs) = (text "switch") <> (char '(') <> (renderJS e) <> (char ')') <> + (char '{') <> (rJS $ fixSemis xs) <> (char '}') +renderJS (JSTry e xs) = (text "try") <> (renderJS e) <> (rJS xs) + +renderJS (JSVarDecl i []) = (renderJS i) +renderJS (JSVarDecl i xs) = (renderJS i) <> (text "=") <> (rJS xs) + +renderJS (JSVariables kw xs) = (text kw) <+> (commaList xs) + +renderJS (JSWhile e (JSLiteral ";")) = (text "while") <> (char '(') <> (renderJS e) <> (char ')') -- <> (renderJS s) +renderJS (JSWhile e s) = (text "while") <> (char '(') <> (renderJS e) <> (char ')') <> (renderJS s) + +renderJS (JSWith e s) = (text "with") <> (char '(') <> (renderJS e) <> (char ')') <> (rJS s) + +-- Helper functions +rJS :: [JSNode] -> BB.Builder +rJS xs = hcat $ map renderJS xs + +commaList :: [JSNode] -> BB.Builder +commaList xs = (hcat $ (punctuate comma (toDoc xs))) + +commaListList :: [[JSNode]] -> BB.Builder +commaListList xs = (hcat $ punctuate comma $ map rJS xs) + +toDoc :: [JSNode] -> [BB.Builder] +toDoc xs = map renderJS xs + +spaceOrBlock :: JSNode -> BB.Builder +spaceOrBlock (JSBlock xs) = renderJS (JSBlock xs) +spaceOrBlock x = (text " ") <> (renderJS x) + +-- --------------------------------------------------------------- +-- Utility stuff + + +fixTop :: [JSNode] -> [JSNode] +fixTop [] = [] +fixTop xs = if (last xs == (JSLiteral ";")) then (init xs) else (xs) + +-- Fix semicolons in output of sourceelements and statementlist + +fixSourceElements :: [JSNode] -> [JSNode] +fixSourceElements xs = fixSemis $ myFix xs + +myFix :: [JSNode] -> [JSNode] +myFix [] = [] +myFix [x] = [x] +myFix (x:(JSFunction v1 v2 v3):xs) = x : (JSLiteral "\n") : myFix ((JSFunction v1 v2 v3) : xs) +-- Messy way, but it works, until the 3rd element arrives .. +myFix ((JSExpression x):(JSExpression y):xs) = (JSExpression x):(JSLiteral ";"):myFix ((JSExpression y):xs) +myFix ((JSExpression x):(JSBlock y):xs) = (JSExpression x):(JSLiteral ";"):myFix ((JSBlock y):xs) +myFix ((JSBlock x) :(JSBlock y):xs) = (JSBlock x) :(JSLiteral ";"):myFix ((JSBlock y):xs) +myFix ((JSBlock x) :(JSExpression y):xs) = (JSBlock x) :(JSLiteral ";"):myFix ((JSExpression y):xs) + +-- Merge adjacent variable declarations, but only of the same type +myFix ((JSVariables t1 x1s):(JSLiteral l):(JSVariables t2 x2s):xs) + | t1 == t2 = myFix ((JSVariables t1 (x1s++x2s)):xs) + | otherwise = (JSVariables t1 x1s):myFix ((JSLiteral l):(JSVariables t2 x2s):xs) + +-- Merge adjacent semi colons +myFix ((JSLiteral ";"):(JSLiteral ";"):xs) = myFix ((JSLiteral ";"):xs) +myFix ((JSLiteral ";"):(JSLiteral "" ):xs) = myFix ((JSLiteral ""):xs) + +myFix (x:xs) = x : myFix xs + +-- Merge strings split over lines and using "+" +fixLiterals :: [JSNode] -> [JSNode] +fixLiterals [] = [] +fixLiterals [x] = [x] +fixLiterals ((JSStringLiteral d1 s1):(JSExpressionBinary "+" [JSStringLiteral d2 s2] r):xs) + | d1 == d2 = fixLiterals ((JSStringLiteral d1 (s1++s2)):(r++xs)) + | otherwise = (JSStringLiteral d1 s1):fixLiterals ((JSExpressionBinary "+" [JSStringLiteral d2 s2] r):xs) + +fixLiterals (x:xs) = x:fixLiterals xs + +-- Sort out Semicolons +fixSemis :: [JSNode] -> [JSNode] +fixSemis xs = fixSemis' $ filter (\x -> x /= JSLiteral ";" && x /= JSLiteral "") xs + +fixSemis' :: [JSNode] -> [JSNode] +fixSemis' [] = [] +fixSemis' [JSContinue [JSLiteral ";"]] = [JSContinue []] +fixSemis' [x] = [x] +fixSemis' ((JSIf c (JSReturn [JSLiteral ";"])):xs) = (JSIf c (JSReturn [JSLiteral ";"])):(fixSemis' xs) +fixSemis' ((JSIf c (JSContinue [JSLiteral ";"])):xs) = (JSIf c (JSContinue [JSLiteral ";"])):(fixSemis' xs) +fixSemis' (x:(JSLiteral "\n"):xs) = x:(JSLiteral "\n"):(fixSemis' xs) +fixSemis' ((JSCase e1 ((JSStatementList []))):(JSCase e2 x):xs) = (JSCase e1 ((JSStatementList []))):fixSemis' ((JSCase e2 x):xs) +fixSemis' (x:xs) = x:(JSLiteral ";"):fixSemis' xs + +-- Remove extraneous braces around blocks +fixBlock :: JSNode -> JSNode +fixBlock (JSBlock (JSStatementList [x])) = x +fixBlock (JSBlock (JSStatementList xs)) = fixBlock' (JSBlock (JSStatementList (fixSourceElements xs))) +fixBlock x = x + +fixBlock' :: JSNode -> JSNode +fixBlock' (JSBlock (JSStatementList [x])) = x +fixBlock' (JSBlock (JSStatementList [x,JSLiteral ""])) = x -- TODO: fix parser to not emit this case +fixBlock' x = x + +-- A space is needed if this expression starts with an identifier etc, but not if with a '(' +spaceNeeded :: [JSNode] -> Bool +spaceNeeded xs = + let + -- str = show $ rJS xs + str = LB.unpack $ BB.toLazyByteString $ rJS xs + in + head str /= (fromIntegral $ ord '(') + +-- --------------------------------------------------------------------- +-- Test stuff + +-- readJs "x=1;" +_case0 :: JSNode +_case0 = JSSourceElements + [ + JSExpression [JSElement "assignmentExpression" [JSIdentifier "x",JSOperator "=",JSDecimal 1]], + JSEmpty (JSLiteral ";") + ] + +-- doParse statementList "a=1;" +_case1 :: [JSNode] +_case1 = [JSExpression + [JSElement "assignmentExpression" + [JSIdentifier "a",JSOperator "=",JSDecimal 1] + ] + ,JSEmpty (JSLiteral ";") + ] + +_case2 :: JSNode +_case2 = JSFunctionExpression [] (JSFunctionBody + [JSSourceElements + [JSReturn [JSExpression + [JSLiteral "this",JSMemberDot [JSIdentifier "name"]], + JSLiteral ""]]] + ) + -- ]],JSEmpty (JSLiteral ";") + + +-- doParse expression "opTypeNames={'\\n':\"NEWLINE\",';':\"SEMICOLON\",',':\"COMMA\"}" +_case4 :: JSNode +_case4 = JSExpression + [ + JSElement "assignmentExpression" + [ + JSIdentifier "opTypeNames", + JSOperator "=", + JSObjectLiteral + [JSPropertyNameandValue (JSStringLiteral '\'' "\\n") [JSStringLiteral '"' "NEWLINE"], + JSPropertyNameandValue (JSStringLiteral '\'' ";") [JSStringLiteral '"' "SEMICOLON"], + JSPropertyNameandValue (JSStringLiteral '\'' ",") [JSStringLiteral '"' "COMMA"] + ] + ] + ] + + +-- doParse program "function load(s){if(typeof s!=\"string\")return s;a=1}" +_case5 :: JSNode +_case5 = JSSourceElements + [JSFunction (JSIdentifier "load") + [JSIdentifier "s"] + (JSFunctionBody + [ + JSSourceElements + [ + JSIf + (JSExpression [JSUnary "typeof ",JSIdentifier "s", + JSExpressionBinary "!=" [JSStringLiteral '"' "string"] []]) + (JSReturn [JSExpression [JSIdentifier "s"],JSLiteral ";"]) + ,JSLiteral ";" + ,JSExpression [JSElement "assignmentExpression" [JSIdentifier "a",JSOperator "=",JSDecimal 1]] + ] + ] + ) + ] + +-- doParse program "{if(typeof s!=\"string\")return s;evaluate(1)}" +_case6 :: JSNode +_case6 = JSSourceElements [] + +--doParse program "function load(s){if(typeof s!=\"string\")return s;evaluate(1)}" +_case7 :: JSNode +_case7 = JSSourceElements + [ + JSFunction (JSIdentifier "load") [JSIdentifier "s"] + (JSFunctionBody + [JSSourceElements + [JSIf + (JSExpression [JSUnary "typeof ",JSIdentifier "s",JSExpressionBinary "!=" [JSStringLiteral '"' "string"] []]) + (JSReturn [JSExpression [JSIdentifier "s"],JSLiteral ";"]) + , + JSExpression [JSIdentifier "evaluate",JSArguments [[JSDecimal 1]]] + ] + ] + ) + ] + +--doParse program "for(i=0,j=assignOps.length;i=0)s+=t;" +_case18 :: JSNode +_case18 = JSSourceElementsTop + [ + JSIf + (JSExpression [JSUnary "typeof ",JSIdentifier "s",JSExpressionBinary "!=" [JSStringLiteral '"' "string"] []]) + (JSReturn [JSLiteral ";"]), + JSWhile (JSExpression [JSUnary "--",JSIdentifier "n",JSExpressionBinary ">=" [JSDecimal 0] []]) + (JSExpression + [ + JSElement "assignmentExpression" + [JSIdentifier "s",JSOperator "+=",JSIdentifier "t"] + ] + ), + JSLiteral ";" + ] + +-- doParse program "function f(){return n;\nx=1}" +_case19 :: JSNode +_case19 = JSSourceElementsTop + [ + JSFunction (JSIdentifier "f") [] + (JSFunctionBody + [ + JSSourceElements + [ + JSReturn [JSExpression [JSIdentifier "n"],JSLiteral ";"], + JSExpression + [JSElement "assignmentExpression" + [ + JSIdentifier "x",JSOperator "=",JSDecimal 1 + ] + ] + ] + ] + ) + ] + +--fixSourceElements ([JSReturn [JSExpression [JSIdentifier "n"],JSLiteral ";"],JSExpression [JSElement "assignmentExpression" [JSIdentifier "x",JSOperator "=",JSDecimal 1]]]) +_case20 :: [JSNode] +_case20 = [ + JSReturn [JSExpression [JSIdentifier "n"],JSLiteral ";"], + JSExpression + [JSElement "assignmentExpression" [JSIdentifier "x",JSOperator "=",JSDecimal 1]] + ] + +--doParse program "if(!u)continue;t=n" +_case21 :: JSNode +_case21 = JSSourceElementsTop + [ + JSIf (JSExpression [JSUnary "!",JSIdentifier "u"]) + (JSContinue [JSLiteral ";"]), + JSExpression [JSElement "assignmentExpression" [JSIdentifier "t",JSOperator "=",JSIdentifier "n"]] + ] + +--doParse program "if (!v.base){throw new ReferenceError(v.propertyName + \" is not defined\");};x=1" +_case22 :: JSNode +_case22 = JSSourceElementsTop + [ + JSIf (JSExpression [JSUnary "!",JSIdentifier "v",JSMemberDot [JSIdentifier "base"]]) + (JSBlock (JSStatementList + [ + JSThrow (JSExpression + [ + JSLiteral "new ", + JSIdentifier "ReferenceError", + JSArguments + [ + [ + JSIdentifier "v", + JSMemberDot [JSIdentifier "propertyName"], + JSExpressionBinary "+" [JSStringLiteral '"' " is not defined"] [] + ] + ] + ] + ), + JSLiteral "" + ] + ) + ), + JSLiteral ";",JSExpression [JSElement "assignmentExpression" [JSIdentifier "x",JSOperator "=",JSDecimal 1]]] + +--parseString program "{throw new TypeError(\"Function.prototype.apply called on\"+\n\" uncallable object\");}" +_case23 :: JSNode +_case23 = JSSourceElementsTop + [ + JSBlock + ( + JSStatementList + [ + JSThrow + (JSExpression + [ + JSLiteral "new ", + JSIdentifier "TypeError", + JSArguments + [ + [ + JSStringLiteral '"' "Function.prototype.apply called on", + JSExpressionBinary "+" + [ + JSStringLiteral '"' " uncallable object" + ] + [] + ] + ] + ] + ), + JSLiteral "" + ] + ) + ] + + +--doParse program "x=\"hello \" + \"world\";" +_case24 :: JSNode +_case24 = JSSourceElementsTop + [ + JSExpression + [ + JSElement "assignmentExpression" + [JSIdentifier "x", + JSOperator "=", + JSStringLiteral '"' "hello ", + JSExpressionBinary "+" + [JSStringLiteral '"' "world"] [] + ] + ], + JSLiteral ";" + ] + +--doParse program (U.fromString "try{}catch(e){continue;}") +_case25 :: JSNode +_case25 = JSSourceElementsTop + [ + JSTry + (JSBlock (JSStatementList [])) + [ + JSCatch + (JSIdentifier "e") + [] + (JSBlock + (JSStatementList + [ + JSContinue [JSLiteral ";"] + ] + ) + ) + ] + ] + +-- EOF + diff --git a/Text/Jasmine/Token.hs b/Text/Jasmine/Token.hs new file mode 100644 --- /dev/null +++ b/Text/Jasmine/Token.hs @@ -0,0 +1,324 @@ +module Text.Jasmine.Token + ( + identifier + , reserved + , whiteSpace + , dec + , hex + , autoSemi + , autoSemi' + , rOp + , 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) + +-- --------------------------------------------------------------------- + +-- 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 () } + + +-- --------------------------------------------------------------------- + +-- Need to deal with the following cases +-- 1. Missing semi, because following } => empty +-- 2. Additional semi, with following } => empty +-- 3. semi with no following } => semi +-- 4. no semi, but prior NL => semi + +autoSemi :: Parser [Char] +autoSemi = do{ _ <- rOp ";"; return (";");} + <|> return ("") + + +autoSemi' :: Parser [Char] +autoSemi' = do{ _ <- rOp ";"; return (";");} + +-- --------------------------------------------------------------------- + +--identifier = lexeme $ many1 (letter <|> oneOf "_") +identifier :: Parser String +identifier = + lexeme $ try $ + do{ name <- ident + ; if (isReservedName name) + then fail ("reserved word " ++ show name) + else return name + } + +ident :: Parser [Char] +ident + = do{ c <- identStart + ; cs <- many identLetter + ; return (c:cs) + } + "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 + +-- TODO: fix trailing characters test +reserved :: String -> Parser () +reserved name = lexeme $ do { _ <- myString name; return () } +{- +reserved name = + lexeme $ try $ + do{ _ <- string name + ; notFollowedBy identLetter ("end of " ++ show name) + } +-} + +--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 = 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 () + } + +multiLineComment :: Parser () +multiLineComment = + do { _ <- try (myString commentStart) + ; inComment + } + +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 = "//" + +nestedComments :: Bool +nestedComments = True + +identLetter :: Parser Char +identLetter = alphaNum <|> oneOf "_" + +identStart :: Parser Char +identStart = letter <|> oneOf "_$" + +reservedNames :: [String] +reservedNames = [ + "break", + "case", "catch", "const", "continue", + "debugger", "default", "delete", "do", + "else", "enum", + "false", "finally", "for", "function", + "if", "in", "instanceof", + "new", "null", + "return", + "switch", + "this", "throw", "true", "try", "typeof", + "var", "void", + "while", "with" + ] + + +hex :: Parser Integer +hex = lexeme $ do{ _ <- oneOf "xX"; hexadecimal } + +dec :: Parser Integer +dec = lexeme $ decimal + +-- | @lexeme p@ first applies parser @p@ and than the 'whiteSpace' +-- parser, returning the value of @p@. Every lexical +-- token (lexeme) is defined using @lexeme@, this way every parse +-- starts at a point without white space. Parsers that use @lexeme@ are +-- called /lexeme/ parsers in this document. +-- +-- The only point where the 'whiteSpace' parser should be +-- called explicitly is the start of the main parser in order to skip +-- any leading white space. +-- +-- > mainParser = do{ whiteSpace +-- > ; ds <- many (lexeme digit) +-- > ; eof +-- > ; return (sum ds) +-- > } + +--lexeme p = do{ x <- p; whiteSpace; return x } +lexeme :: Parser b -> Parser b +lexeme p = do{ x <- p; whiteSpace; return x } + +-- --------------------------------------------------------------------- +-- Stuff from Parsec needed to make Attoparsec work + + +-- | @oneOf cs@ succeeds if the current character is in the supplied +-- list of characters @cs@. Returns the parsed character. See also +-- 'satisfy'. +-- +-- > vowel = oneOf "aeiou" + +oneOf :: String -> Parser Char +oneOf cs = satisfy (\c -> elem c cs) + + +-- | 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. + +alphaNum :: Parser Char +alphaNum = satisfy isAlphaNum "letter or digit" + +-- | Parses a letter (an upper case or lower case character). Returns the +-- parsed character. + +letter :: Parser Char +letter = satisfy isAlpha "letter" + +-- | Parses a digit. Returns the parsed character. + + +-- | 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 + +-- --------------------------------------------------------------------- +{- +javascriptDef :: LanguageDef st +javascriptDef = javaStyle + { reservedNames = [ + "break", + "case", "catch", "const", "continue", + "debugger", "default", "delete", "do", + "else", "enum", + "false", "finally", "for", "function", + "if", "in", "instanceof", + "new", "null", + "return", + "switch", + "this", "throw", "true", "try", "typeof", + "var", "void", + "while", "with" + ] + -- TODO: make the following constants, so the parser defn is simpler. e,g op_COMMA = "," + , reservedOpNames= [ + ";" , -- "SEMICOLON", + "," , -- "COMMA", + "?" , -- "HOOK", + ":" , -- "COLON", + "||" , -- "OR", + "&&" , -- "AND", + "|" , -- "BITWISE_OR", + "^" , -- "BITWISE_XOR", + "&" , -- "BITWISE_AND", + "===" , -- "STRICT_EQ", + "==" , -- "EQ", + "=" , -- "ASSIGN", + "!==" , -- "STRICT_NE", + "!=" , -- "NE", + "<<" , -- "LSH", + "<=" , -- "LE", + "<" , -- "LT", + ">>>" , -- "URSH", + ">>" , -- "RSH", + ">=" , -- "GE", + ">" , -- "GT", + "++" , -- "INCREMENT", + "--" , -- "DECREMENT", + "+" , -- "PLUS", + "-" , -- "MINUS", + "*" , -- "MUL", + "/" , -- "DIV", + "%" , -- "MOD", + "!" , -- "NOT", + "~" , -- "BITWISE_NOT", + "." , -- "DOT", + "[" , -- "LEFT_BRACKET", + "]" , -- "RIGHT_BRACKET", + "{" , -- "LEFT_CURLY", + "}" , -- "RIGHT_CURLY", + "(" , -- "LEFT_PAREN", + ")" , -- "RIGHT_PAREN", + "@*/" -- "CONDCOMMENT_END" + ] + , opLetter = oneOf "!%&()*+,-./:;<=>?[]^{|}~" + , opStart = opLetter javascriptDef + , identStart = letter <|> oneOf "_" + , identLetter = alphaNum <|> oneOf "_" + + , caseSensitive = True + } + + +-} + +-- EOF diff --git a/buildall.sh b/buildall.sh new file mode 100644 --- /dev/null +++ b/buildall.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +# do a clean build of all, including the tests +cabal clean && cabal configure -fbuildtests && cabal build && cabal haddock + + diff --git a/hjsmin.cabal b/hjsmin.cabal new file mode 100644 --- /dev/null +++ b/hjsmin.cabal @@ -0,0 +1,50 @@ +name: hjsmin +version: 0.0.1 +license: BSD3 +license-file: LICENSE +author: Alan Zimmerman +maintainer: Alan Zimmerman +synopsis: Haskell implementation of a javascript minifier +description: + Reduces size of javascript files by stripping out extraneous whitespace and + other syntactic elements, without changing the semantics. +category: Web +stability: unstable +cabal-version: >= 1.6 +build-type: Simple +homepage: http://github.com/alanz/hjsmin +bug-reports: http://github.com/alanz/hjsmin/issues + +Extra-source-files: + TODO.txt, README.markdown, buildall.sh + + +flag buildtests + description: Build the executable to run unit tests + default: False + +library + build-depends: base >= 4 && < 5 + , bytestring >= 0.9 && < 0.10 + , attoparsec >= 0.8 && < 0.9 + , blaze-builder >= 0.2 && < 1 + , text >= 0.8 && < 1 + exposed-modules: Text.Jasmine + other-modules: Text.Jasmine.Parse, Text.Jasmine.Pretty, Text.Jasmine.Token + ghc-options: -Wall + +executable runtests + if flag(buildtests) + Buildable: True + cpp-options: -DTEST + build-depends: QuickCheck >= 2 && < 3, + HUnit, + test-framework-hunit, + test-framework + else + Buildable: False + main-is: runtests.hs + +source-repository head + type: git + location: git://github.com/alanz/hjsmin.git diff --git a/runtests.hs b/runtests.hs new file mode 100644 --- /dev/null +++ b/runtests.hs @@ -0,0 +1,236 @@ + +import Test.Framework (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + +import Data.Char +import Text.Jasmine +import Text.Jasmine.Parse hiding (main) +import Text.Jasmine.Pretty +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as T +import qualified Data.Text.Encoding as E + +main :: IO () +main = defaultMain [testSuite,testSuiteMin,testSuiteFiles,testSuiteFilesUnminified] + +testSuite :: Test +testSuite = testGroup "Text.Jasmine.Parse" + [ + testCase "helloWorld" caseHelloWorld + , testCase "helloWorld2" caseHelloWorld2 + , testCase "simpleAssignment" caseSimpleAssignment + , testCase "emptyFor" caseEmptyFor + , testCase "fullFor" caseFullFor + , testCase "forVarFull" caseForVarFull + , testCase "ifelse1" caseIfElse1 + , testCase "ifelse2" caseIfElse2 + , testCase "0_f.js" case0_f + , testCase "01_semi1.js" case01_semi1 + , testCase "min_100_animals" case_min_100_animals + , testCase "nestedSquare" caseNestedSquare + ] + +testSuiteMin :: Test +testSuiteMin = testGroup "Text.Jasmine.Pretty" + [ testCase "helloWorld" caseMinHelloWorld + , testCase "helloWorld2" caseMinHelloWorld2 + , testCase "simpleAssignment" caseMinSimpleAssignment + , testCase "ifelse1" caseMinIfElse1 + , testCase "ifelse2" caseMinIfElse2 + , testCase "0_f.js" caseMin0_f + , testCase "01_semi1.js" caseMin01_semi1 + , testCase "min_100_animals" caseMin_min_100_animals + , testCase "minNestedSquare" caseMinNestedSquare + , testCase "EitherLeft" caseEitherLeft + , testCase "EitherRight" caseEitherRight + ] + +testSuiteFiles :: Test +testSuiteFiles = testGroup "Text.Jasmine.Pretty files" + [ testCase "00_f.js" (testFile "./test/pminified/00_f.js") + , testCase "01_semi1.js" (testFile "./test/pminified/01_semi1.js") + , testCase "02_sm.js" (testFile "./test/pminified/02_sm.js") + , testCase "03_sm.js" (testFile "./test/pminified/03_sm.js") + , testCase "04_if.js" (testFile "./test/pminified/04_if.js") + , testCase "05_comments_simple.js" (testFile "./test/pminified/05_comments_simple.js") + , testCase "05_regex.js" (testFile "./test/pminified/05_regex.js") + , testCase "06_callexpr.js" (testFile "./test/pminified/06_callexpr.js") + , testCase "06_newexpr.js" (testFile "./test/pminified/06_newexpr.js") + , testCase "06_var.js" (testFile "./test/pminified/06_var.js") + , testCase "07_expr.js" (testFile "./test/pminified/07_expr.js") + , testCase "10_switch.js" (testFile "./test/pminified/10_switch.js") + , testCase "14_labelled_stmts.js" (testFile "./test/pminified/14_labelled_stmts.js") + , testCase "15_literals.js" (testFile "./test/pminified/15_literals.js") + , testCase "16_literals.js" (testFile "./test/pminified/16_literals.js") + , testCase "20_statements.js" (testFile "./test/pminified/20_statements.js") + , testCase "25_trycatch.js" (testFile "./test/pminified/25_trycatch.js") + , testCase "40_functions.js" (testFile "./test/pminified/40_functions.js") + , testCase "67_bob.js" (testFile "./test/pminified/67_bob.js") + , testCase "110_perfect.js" (testFile "./test/pminified/110_perfect.js") + , testCase "120_js.js" (testFile "./test/pminified/120_js.js") + , testCase "121_jsdefs.js" (testFile "./test/pminified/121_jsdefs.js") + , testCase "122_jsexec.js" (testFile "./test/pminified/122_jsexec.js") + , testCase "122_jsexec2.js" (testFile "./test/pminified/122_jsexec2.js") + , testCase "122_jsexec3.js" (testFile "./test/pminified/122_jsexec3.js") + -- , testCase "123_jsparse.js" (testFile "./test/pminified/123_jsparse.js") + -- TODO: something strange here, assigning code block to variable? + -- See http://msdn.microsoft.com/en-us/library/77kz8hy0.aspx, get/set keywords for object accessors + + --, testCase "130_htojs2.js" (testFile "./test/parsingonly/130_htojs2.js") + --, testCase "" (testFile "./test/pminified/") + ] + +testSuiteFilesUnminified :: Test +testSuiteFilesUnminified = testGroup "Text.Jasmine.Pretty filesUnminified" + [ testCase "00_f.js" (testFileUnminified "00_f.js") + , testCase "01_semi1.js" (testFileUnminified "01_semi1.js") + , testCase "02_sm.js" (testFileUnminified "02_sm.js") + , testCase "03_sm.js" (testFileUnminified "03_sm.js") + , testCase "04_if.js" (testFileUnminified "04_if.js") + , testCase "05_comments_simple.js" (testFileUnminified "05_comments_simple.js") + , testCase "05_regex.js" (testFileUnminified "05_regex.js") + , testCase "06_callexpr.js" (testFileUnminified "06_callexpr.js") + , testCase "06_newexpr.js" (testFileUnminified "06_newexpr.js") + , testCase "06_var.js" (testFileUnminified "06_var.js") + , testCase "07_expr.js" (testFileUnminified "07_expr.js") + , testCase "10_switch.js" (testFileUnminified "10_switch.js") + , testCase "14_labelled_stmts.js" (testFileUnminified "14_labelled_stmts.js") + , testCase "15_literals.js" (testFileUnminified "15_literals.js") + , testCase "16_literals.js" (testFileUnminified "16_literals.js") + , testCase "20_statements.js" (testFileUnminified "20_statements.js") + , testCase "25_trycatch.js" (testFileUnminified "25_trycatch.js") + , testCase "40_functions.js" (testFileUnminified "40_functions.js") + , testCase "67_bob.js" (testFileUnminified "67_bob.js") + , testCase "110_perfect.js" (testFileUnminified "110_perfect.js") + , testCase "120_js.js" (testFileUnminified "120_js.js") + , testCase "121_jsdefs.js" (testFileUnminified "121_jsdefs.js") + , testCase "122_jsexec.js" (testFileUnminified "122_jsexec.js") + + --, testCase "122_jsexec2.js" (testFileUnminified "122_jsexec2.js") + ] + +srcHelloWorld = "function Hello(a) {}" +caseHelloWorld = + "Done \"\" JSFunction (JSIdentifier \"Hello\") [JSIdentifier \"a\"] (JSFunctionBody [])" + @=? (show $ parseString functionDeclaration srcHelloWorld) +caseMinHelloWorld = + -- "function Hello(a){}" @=? (minify (U.fromString srcHelloWorld)) + testMinify "function Hello(a){}" srcHelloWorld + +srcHelloWorld2 = "function Hello(a) {b=1}" +caseHelloWorld2 = + "Done \"\" JSFunction (JSIdentifier \"Hello\") [JSIdentifier \"a\"] (JSFunctionBody [JSSourceElements [JSExpression [JSElement \"assignmentExpression\" [JSIdentifier \"b\",JSOperator \"=\",JSDecimal 1]]]])" + @=? (show $ parseString functionDeclaration srcHelloWorld2) +caseMinHelloWorld2 = + -- "function Hello(a){b=1}" @=? (minify (U.fromString srcHelloWorld2)) + testMinify "function Hello(a){b=1}" srcHelloWorld2 + +srcSimpleAssignment = "a=1;" +caseSimpleAssignment = + "Done \"\" JSStatementList [JSExpression [JSElement \"assignmentExpression\" [JSIdentifier \"a\",JSOperator \"=\",JSDecimal 1]],JSLiteral \";\"]" + @=? (show $ parseString statementList srcSimpleAssignment) +caseMinSimpleAssignment = + testMinify "a=1" srcSimpleAssignment + +srcEmptyFor = "for (i = 0;;){}" +caseEmptyFor = + "Done \"\" JSFor [JSExpression [JSElement \"assignmentExpression\" [JSIdentifier \"i\",JSOperator \"=\",JSDecimal 0]]] [] [] (JSLiteral \";\")" + @=? (show $ parseString iterationStatement srcEmptyFor) +srcFullFor = "for (i = 0;i<10;i++){}" +caseFullFor = + "Done \"\" JSFor [JSExpression [JSElement \"assignmentExpression\" [JSIdentifier \"i\",JSOperator \"=\",JSDecimal 0]]] [JSExpression [JSIdentifier \"i\",JSExpressionBinary \"<\" [JSDecimal 10] []]] [JSExpression [JSExpressionPostfix \"++\" [JSIdentifier \"i\"]]] (JSLiteral \";\")" + @=? (show $ parseString iterationStatement srcFullFor) + +srcForVarFull = "for(var i=0,j=tokens.length;i IO () +testFile filename = + do + x <- readFile (filename) + let x' = trim x + -- x' @=? (minify (U.fromString x') ) + testMinify x' x' + + +testFileUnminified :: FilePath -> IO () +testFileUnminified filename = + do + x <- readFile ("./test/pminified/" ++ filename) + y <- readFile ("./test/parsingonly/" ++ filename) + let x' = trim x + -- x' @=? (minify (U.fromString y)) + testMinify x' y + + + + +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +-- EOF