diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +See the AUTHORS file for a list of copyright holders. + +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 the copyright holders 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/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/js-good-parts.cabal b/js-good-parts.cabal new file mode 100644 --- /dev/null +++ b/js-good-parts.cabal @@ -0,0 +1,29 @@ +Name: js-good-parts +Version: 0.0.1 +Cabal-Version: >= 1.6 +Synopsis: Javascript: The Good Parts -- AST & Pretty Printer +Category: Language, Javascript +Description: + An AST for the "the good parts" of Javascript (as defined by Douglas Crockford) + and a pretty printer for that AST. Designed to be the target of a code generator. + Does not include a parser. + +Author: Sean Seefried +Maintainer: sean.seefried@gmail.com +Homepage: http://github.com/sseefried/js-good-parts.git +Copyright: (c) by Sean Seefried +License: BSD3 +License-File: LICENSE +Stability: experimental +build-type: Simple +Source-Repository head + type: git + location: git://github.com/sseefried/js-tgp.git + +Library + hs-Source-Dirs: src + Build-Depends: base >=4 && < 5, + wl-pprint >= 1.1 + + Exposed-Modules: Language.JavaScript.AST + Language.JavaScript.Pretty diff --git a/src/Language/JavaScript/AST.hs b/src/Language/JavaScript/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/JavaScript/AST.hs @@ -0,0 +1,473 @@ +{-# OPTIONS_GHC -Wall #-} +-- +-- Module: Language.Javascript.AST +-- Author: Sean Seefried +-- +-- © 2012 +-- +-- In Chapter 2 of "JavaScript: The Good Parts", Douglas Crockford presents a +-- concrete grammar for "the good parts" of JavaScript. +-- +-- This module provides an abstract grammar for those good parts. We will abbreviate this +-- language to JS:TGP +-- +-- Crockford presents the grammar as a series of railroad diagrams. +-- The correspondence between the concrete grammar and the abstract grammar +-- in this module is NOT one-to-one. However, the following property does hold: the +-- pretty printing of an abstract syntax tree will be parseable by the concrete grammar. i.e. +-- For each valid program produced by the concrete grammar there is a corresponding +-- abstract syntax tree that when pretty printed will produce that program (modulo whitespace). +-- +-- The abstract grammar: +-- * removes unnecessary characters such as parentheses (normal, curly and square) +-- * represents JavaScript's string, name and number literals directly in Haskell as +-- 'String', 'String' and 'Double' respectively. +-- +-- Conventions for concrete syntax: +-- - Non-terminals appear in angle brackets e.g. +-- - ? means zero or one. e.g. ? +-- - * means zero or more e.g. * +-- - + means one or more e.g. + +-- - \( \) are meta-brackets used to enclose a concrete-syntax expression so that ?,* or + +-- can be applied. e.g. \(= \)* +-- This means zero or more repetitions of: = +-- +-- The data structure ensures no incorrect JS:TGP programs +-- ------------------------------------------------------- +-- This library was designed so that it would be impossible, save for name, string literals +-- to construct an incorrect JS:TGP program. +-- +-- To this end some of the data structures may look like they contain redundancy. +-- For instance, consider the 'JSESDelete' constructor which is defined +-- +-- JSESDelete JSExpression JSInvocation +-- +-- Why not just define it as 'JSESDelete JSExpression' since type 'JSExpression' +-- has a constructor defined as 'JSExpressionInvocation JSExpression JSInvocation'? +-- The reason is that this would allow incorrect programs. A 'JSExpression' is +-- not necessarily an invocation. +-- +-- However, even though none of the programs are incorrect there are still some things +-- it cannot check for. Although labels can appear before any statement, they should +-- only be used on statements that interact with a switch, while, do, or for statement. +-- This cannot be checked except by a second pass over the AST. This library does not +-- provide this functionality. +-- +-- A note on precedence of JavaScript operators +-- -------------------------------------------- +-- Interestingly, the precedence of JavaScript operators is +-- not defined in the ECMAScript standard. The precedence used in this library comes from +-- the Mozilla Developer's Network pages. +-- (https://developer.mozilla.org/en/JavaScript/Reference/Operators/Operator_Precedence) +-- +-- I have not used the precise precedence numbers from that page since in this module +-- a lower precedence means the operator binds more tightly (as opposed to the page where +-- a higher precedence does the same). Also, we have need for less precedence values so they +-- have been normalised to what we are using in JS:TGP +-- +-- You will also note that we don't even consider the associativity/precedence of +-- "=", "+=", "-=" etc. In JS:TGP the notion of expression statements is quite different +-- to that of expressions. It simply isn't legal to write an expression statement like +-- +-- (a += 2) -= 3 +-- OR +-- a = (b = c) = (c = d) +-- +-- although it is perfectly legal to write +-- +-- a = b = c = d += 2 +-- +-- which if we add brackets to disambiguate is really +-- +-- a = (b = (c = (d += 2))) +-- +-- +-- Interesting aspects of "the good parts" +-- --------------------------------------- +-- +-- A JS:TGP program is a collection of statements. You'll note that there is no +-- statement to declare a function in JS:TGP. However you can assign a function literal +-- to a variable. +-- +-- e.g. var fun = function(x) { return x + 1;} +-- +-- What about recursive functions then? There is the option to give the function a name which is +-- local to the literal. +-- +-- e.g. var factorial = function f(n) { +-- if ( n > 0 ) { +-- return n * f(n - 1); +-- } else { +-- return 1; +-- } +-- } +-- +-- 'f' is local. It will not be in scope outside of the function body. +-- +module Language.JavaScript.AST ( + -- JSString, JSName can't be create except with constructors + JSString, JSName, + unJSString, unJSName, + jsString, jsName, + + -- Data types + JSNumber(..), + JSVarStatement(..), JSVarDecl(..), JSStatement(..), + JSDisruptiveStatement(..), JSIfStatement(..), JSSwitchStatement(..), + JSCaseAndDisruptive(..), JSCaseClause(..), JSForStatement(..), + JSDoStatement(..), JSWhileStatement(..), JSTryStatement(..), + JSThrowStatement(..), JSReturnStatement(..), JSBreakStatement(..), + JSExpressionStatement(..), JSLValue(..), JSRValue(..), JSExpression(..), + JSPrefixOperator(..), JSInfixOperator(..), JSInvocation(..), JSRefinement(..), + JSLiteral(..), JSObjectLiteral(..), JSObjectField(..), JSArrayLiteral(..), + JSFunctionLiteral(..), JSFunctionBody(..), JSProgram(..) +) where + +import Language.JavaScript.NonEmptyList + + +data JSName = JSName { unJSName :: String } + +-- +-- The only way you can create a JSName +-- +jsName :: String -> Either String JSName +jsName = Right . JSName -- FIXME: Return Left on error. + +data JSString = JSString { unJSString :: String } + +-- +-- The only way you can create a Javascript string. +-- This function needs to correctly encode all special characters. +-- See p9 of "JavaScript: The Good Parts" +-- +jsString :: String -> Either String JSString +jsString = Right . JSString -- FIXME: Return Left on error + + +newtype JSNumber = JSNumber Double -- 64 bit floating point number + +-- +-- Concrete syntax: var [, ]* ; +-- +-- e.g. var x = 1, y; +-- +data JSVarStatement = JSVarStatement (NonEmptyList JSVarDecl) + +-- +-- | Concrete syntax: +-- 1. \(= \)? +-- +-- e.g. +-- 1. x +-- 2. x = 2 + y +-- +data JSVarDecl = JSVarDecl JSName (Maybe JSExpression) -- optional initialization + +-- +-- | The many different kinds of statements +-- +data JSStatement + = JSStatementExpression JSExpressionStatement -- ^ syntax: ; + | JSStatementDisruptive JSDisruptiveStatement -- ^ syntax: + | JSStatementTry JSTryStatement -- ^ syntax: + | JSStatementIf JSIfStatement -- ^ syntax: + -- | syntax: \( : \) + | JSStatementSwitch (Maybe JSName) JSSwitchStatement + -- | syntax: \( : \) + | JSStatementWhile (Maybe JSName) JSWhileStatement + -- | syntax: \( : \) + | JSStatementFor (Maybe JSName) JSForStatement + -- | syntax: \( : \) + | JSStatementDo (Maybe JSName) JSDoStatement + +-- +-- | Disruptive statements +-- +data JSDisruptiveStatement + = JSDSBreak JSBreakStatement -- syntax: + | JSDSReturn JSReturnStatement -- syntax: + | JSDSThrow JSThrowStatement -- syntax: + +-- +-- | Concrete syntax: +-- if ( ) { * } -- for 'Nothing' +-- OR +-- if ( ) { * } else { * } -- for 'Just . Left' +-- OR +-- if ( ) { * } else -- for 'Just . Right' +-- +-- e.g. +-- if (x > 3) { y = 2; } +-- OR +-- if (x < 2) { y = 1; } else { y = 3; z = 2; } +-- OR +-- if (x > 0) { y = 20; } else if ( x > 10) { y = 30; } else { y = 10; } +-- +data JSIfStatement = JSIfStatement JSExpression [JSStatement] (Maybe (Either [JSStatement] JSIfStatement)) + +-- +-- | Concrete syntax: +-- switch ( ) { } +-- OR +-- switch ( ) { + +-- default : * } +-- e.g. +-- 1. switch ( x ) { +-- case 1: +-- y = 2; +-- } +-- 2. switch ( x ) { +-- case 1: +-- y = 2; +-- break; +-- case 2: +-- y = 3; +-- break; +-- default: +-- y = 4; +-- } +-- +data JSSwitchStatement + = JSSwitchStatementSingleCase JSExpression JSCaseClause + | JSSwitchStatement JSExpression + (NonEmptyList JSCaseAndDisruptive) -- non-default case clauses + [JSStatement] -- default clause statements + +-- +-- | A case clause followed by a disruptive statement +-- +-- Concrete syntax: +-- +-- e.g. +-- 1. case 2: +-- y = 2; +-- break; +-- +data JSCaseAndDisruptive = JSCaseAndDisruptive JSCaseClause JSDisruptiveStatement + +-- +-- | Concrete syntax: +-- case : * +-- +-- e.g. +-- 1. case 2: // zero statements following the case expression is valid. +-- 2. case 2: +-- y = 1; +-- +data JSCaseClause = JSCaseClause JSExpression [JSStatement] + +-- +-- | Two style of for-statements -- C-style and In-style. +-- +-- Concrete syntax: +-- +-- 1. for (? ; ? ; ? ) { +-- * +-- } +-- 2. for ( in ) { +-- * +-- } +-- +-- e.g. +-- 1. for ( ; ; ) { } +-- 2. for ( ; x < 10 ;) { x += 1; } +-- 3. for (i = 0; i < 10; i += 1) { +-- x += i; +-- } +-- 4. for ( i in indices ) { a[i] = 66; } +-- +data JSForStatement = JSForStatementCStyle + (Maybe JSExpressionStatement) -- initialization + (Maybe JSExpression) -- condition + (Maybe JSExpressionStatement) -- increment + [JSStatement] -- body + | JSForStatementInStyle + JSName + JSExpression + [JSStatement] + +-- +-- | Concrete syntax: +-- do { * } while ( ); +-- +data JSDoStatement = JSDoStatement [JSStatement] JSExpression + +-- +-- | Concrete syntax: +-- while ( ) { * } +-- +data JSWhileStatement = JSWhileStatement JSExpression [JSStatement] + +-- +-- | Concrete syntax: +-- try { * } catch ( ) { * } +-- +data JSTryStatement = JSTryStatement [JSStatement] JSName [JSStatement] + +-- +-- | Concrete syntax: +-- throw ; +-- +data JSThrowStatement = JSThrowStatement JSExpression + +-- +-- | Concrete syntax: +-- return ?; +-- e.g. +-- 1. return; +-- 2. return 2 + x; +-- +data JSReturnStatement = JSReturnStatement (Maybe JSExpression) + +-- +-- | Concrete syntax: +-- break ?; +-- e.g. +-- 1. break; +-- 2. break some_label; +-- +data JSBreakStatement = JSBreakStatement (Maybe JSName) + +-- +-- | Concrete syntax: +-- +-- + +data JSExpressionStatement + = JSESApply (NonEmptyList JSLValue) JSRValue + | JSESDelete JSExpression JSRefinement + +-- +-- | Concrete syntax: +-- \(* \)* +-- e.g. +-- 1. x +-- 2. x.field_1 +-- 3. fun().field_1 +-- 4. fun(1)(2) +-- 5. fun(1)(2).field_1 +-- 5. x.fun_field_1(x+2).fun_field_2(y+3).field_3 +-- +data JSLValue = JSLValue JSName [([JSInvocation], JSRefinement)] + +-- +-- | Concrete syntax: +-- 1. = +-- 2. += +-- 3. -= +-- 4. + +-- +-- e.g. +-- 1. = 2 +-- 2. += 3 +-- 3. -= (4 + y) +-- 4a. () +-- 4b. (1) +-- 4c. (x,y,z) +-- +data JSRValue + = JSRVAssign JSExpression + | JSRVAddAssign JSExpression + | JSRVSubAssign JSExpression + | JSRVInvoke (NonEmptyList JSInvocation) + +data JSExpression = JSExpressionLiteral JSLiteral + | JSExpressionName JSName + | JSExpressionPrefix JSPrefixOperator JSExpression + | JSExpressionInfix JSInfixOperator JSExpression JSExpression + | JSExpressionTernary JSExpression JSExpression JSExpression + | JSExpressionInvocation JSExpression JSInvocation + | JSExpressionRefinement JSExpression JSRefinement + | JSExpressionNew JSExpression JSInvocation + | JSExpressionDelete JSExpression JSRefinement + +data JSPrefixOperator + = JSTypeOf -- syntax: typeof + | JSToNumber -- syntax: + + | JSNegate -- syntax: - + | JSNot -- syntax: ! + +data JSInfixOperator + = JSMul -- syntax: * + | JSDiv -- syntax: / + | JSMod -- syntax: % + | JSAdd -- syntax: + + | JSSub -- syntax: - + | JSGTE -- syntax: >= + | JSLTE -- syntax: <= + | JSGT -- syntax: > + | JSLT -- syntax: < + | JSEq -- syntax: === + | JSNotEq-- syntax: !== + | JSOr -- syntax: || + | JSAnd -- syntax: && + +-- +-- | Concrete syntax: +-- * +-- e.g. +-- 1. () +-- 2. (1) +-- 3. (x,z,y) +-- +data JSInvocation = JSInvocation [JSExpression] + +-- e.g. +-- 1. .field_1 +-- 2. [i+1] +-- +data JSRefinement + -- | syntax: . + -- e.g. .field_1 + = JSProperty JSName + -- | syntax: [] + -- e.g. [x+3] + | JSSubscript JSExpression + +data JSLiteral + = JSLiteralNumber JSNumber + | JSLiteralString JSString + | JSLiteralObject JSObjectLiteral + | JSLiteralArray JSArrayLiteral + | JSLiteralFunction JSFunctionLiteral +-- | JSLiteralRegexp JSRegexpLiteral -- TODO: Add regexps + +-- +-- | Concrete syntax: +-- 1. {} // no fields +-- 2. { \(, \)*} // one or more fields +-- +data JSObjectLiteral = JSObjectLiteral [JSObjectField] + +-- +-- | Concrete syntax: +-- 1. : // for Left +-- 2. : // for Right +-- +-- e.g. +-- 1. x: y + 3 +-- 2. "value": 3 - z +-- +data JSObjectField = JSObjectField (Either JSName JSString) JSExpression + +-- +-- | Concrete syntax: +-- 1. [] // empty array +-- 2. [ \(, *\) ] +-- +data JSArrayLiteral = JSArrayLiteral [JSExpression] + +-- +-- | Concrete syntax: +-- function ? +-- +data JSFunctionLiteral = JSFunctionLiteral (Maybe JSName) [JSName] JSFunctionBody + +-- +-- | Concrete syntax: +-- { + + } +-- +data JSFunctionBody = JSFunctionBody [JSVarStatement] [JSStatement] + +data JSProgram = JSProgram [JSVarStatement] [JSStatement] diff --git a/src/Language/JavaScript/Pretty.hs b/src/Language/JavaScript/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/JavaScript/Pretty.hs @@ -0,0 +1,372 @@ +module Language.JavaScript.Pretty where + +-- System libraries +import Text.PrettyPrint.Leijen +import Text.PrettyPrint.Leijen.PrettyPrec + +-- friends +import Language.JavaScript.AST +import Language.JavaScript.NonEmptyList + +-- FIXME: This will be a little tricky to get right. +instance Pretty JSString where + pretty s = char '"' <> text (unJSString s) <> char '"' -- enclosed in double quotes + +instance Pretty JSName where + pretty = text . unJSName + +sepWith :: Pretty a => Doc -> [a] -> Doc +sepWith s = encloseSep empty empty s . map pretty + +endWith :: Pretty a => Doc -> [a] -> Doc +endWith s xs = sepWith s xs <> s + +sepWith' :: Pretty a => Doc -> NonEmptyList a -> Doc +sepWith' s = encloseSep empty empty s . map pretty . toList + +endWith' :: Pretty a => Doc -> NonEmptyList a -> Doc +endWith' s xs = sepWith' s xs <> s + +prettyBlock :: Pretty a => [a] -> Doc +prettyBlock stmts = lbrace <$> indent 2 (endWith (semi <$> empty) stmts) <$> rbrace + +------------------------------------------------------------------------ +-- +-- Associativity +-- + +data Associativity = LeftToRight | RightToLeft deriving Eq +type Fixity = (Associativity, Int) + +assoc :: Associativity -> Int -> Fixity +assoc ass n = (ass, n) + +leftToRight, rightToLeft :: Int -> Fixity + +leftToRight = assoc LeftToRight +rightToLeft = assoc RightToLeft + + +prettyInfixOpApp :: (PrettyPrec a, PrettyPrec b) => Int -> OpInfo -> a -> b -> Doc +prettyInfixOpApp prec (OpInfo opPrec assoc name) a b = + docParen (prec > opPrec) $ bump LeftToRight a <+> text name <+> bump RightToLeft b + where + bump assoc' d = prettyPrec opPrec' d + where opPrec' = if assoc == assoc' then opPrec else opPrec + 1 + +-- LAST: Check that bump works in 'prettyInfixOpApp' and do the right thing for prefix ops. +-- +prettyPrefixOpApp :: PrettyPrec a => Int -> OpInfo -> a -> Doc +prettyPrefixOpApp prec (OpInfo opPrec assoc name) a = + text name <> docParen (prec > opPrec) (prettyPrec prec a) + + +docParen :: Bool -> Doc -> Doc +docParen True = parens +docParen False = id + +data OpInfo = OpInfo Int -- recedence + Associativity -- associativity + String -- name +-- +-- FIXME: What about the associativity of +=, -=, etc. It's not defined in your +-- grammar. How will you handle it? Is it even defined in JS:TGP? Answer this question +-- and then write a note about it. +-- + +-- +-- Lower precedence means the operatorbinds more tightly +-- +infixOpInfo :: JSInfixOperator -> OpInfo +infixOpInfo op = case op of + JSMul -> go 6 "*" + JSDiv -> go 6 "/" + JSMod -> go 6 "%" + JSAdd -> go 5 "+" + JSSub -> go 5 "-" + JSGTE -> go 4 ">=" + JSLTE -> go 4 "<=" + JSGT -> go 4 ">" + JSLT -> go 4 "<" + JSEq -> go 3 "===" + JSNotEq -> go 3 "!==" + JSOr -> go 1 "||" + JSAnd -> go 2 "&&" + where go i s = OpInfo i LeftToRight s + +prefixOpInfo :: JSPrefixOperator -> OpInfo +prefixOpInfo op = case op of + JSTypeOf -> go 7 "typeof" + JSToNumber -> go 7 "+" + JSNegate -> go 7 "-" + JSNot -> go 7 "!" + where go i s = OpInfo i RightToLeft s + +----------------------------------------------------------------------- + +instance Pretty JSNumber where + pretty (JSNumber n) = pretty n -- FIXME: Make sure this always produce valid Javascript numbers. + +instance PrettyPrec JSNumber -- default + +instance Pretty JSVarStatement where + pretty (JSVarStatement varDecls) = sepWith' (text ", ") varDecls + +instance PrettyPrec JSVarStatement -- default + +instance Pretty JSVarDecl where + pretty (JSVarDecl nm Nothing) = pretty nm + pretty (JSVarDecl nm (Just exp)) = pretty nm <+> text "=" <+> pretty exp + +instance PrettyPrec JSVarDecl -- default + +instance Pretty JSStatement where + pretty stmt = case stmt of + (JSStatementExpression es) -> pretty es <> semi + (JSStatementDisruptive ds) -> pretty ds + (JSStatementTry ts) -> pretty ts + (JSStatementIf is) -> pretty is + (JSStatementSwitch mbLbl ss) -> pp mbLbl ss + (JSStatementWhile mbLbl ws) -> pp mbLbl ws + (JSStatementFor mbLbl fs) -> pp mbLbl fs + (JSStatementDo mbLbl ds) -> pp mbLbl ds + where + pp :: Pretty a => Maybe JSName -> a -> Doc + pp (Just label) doc = pretty label <> colon <+> pretty doc + pp Nothing doc = pretty doc + +instance PrettyPrec JSStatement-- default + +instance Pretty JSDisruptiveStatement where + pretty stmt = case stmt of + JSDSBreak bs -> pretty bs + JSDSReturn rs -> pretty rs + JSDSThrow ts -> pretty ts + +instance PrettyPrec JSDisruptiveStatement -- default + +instance Pretty JSIfStatement where + pretty (JSIfStatement cond thenStmts blockOrIf) = + text "if" <+> parens (pretty cond) <+> prettyBlock thenStmts <+> ppRest + where + ppRest = case blockOrIf of + Nothing -> empty + Just (Left elseStmts) -> text "else" <+> prettyBlock elseStmts + Just (Right ifStmt) -> pretty ifStmt + +instance PrettyPrec JSIfStatement -- default + +instance Pretty JSSwitchStatement where + pretty (JSSwitchStatementSingleCase cond caseClause) = + text "switch" <+> parens (pretty cond) <+> lbrace <$> pretty caseClause <$> rbrace + pretty (JSSwitchStatement cond cds stmts) = + text "switch" <+> parens (pretty cond) <+> lbrace <$> + indent 2 (vcat (toList . fmap pretty $ cds) <$> + (text "default:" <$> + indent 2 (endWith semi stmts))) <$> + rbrace + +instance PrettyPrec JSSwitchStatement -- default + +instance Pretty JSCaseAndDisruptive where + pretty (JSCaseAndDisruptive caseClause disruptive) = + pretty caseClause <$> pretty disruptive + +instance PrettyPrec JSCaseAndDisruptive -- default + +instance Pretty JSCaseClause where + pretty (JSCaseClause exp stmts) = + text "case" <+> pretty exp <> colon <+> endWith semi stmts + +instance PrettyPrec JSCaseClause -- default + +instance Pretty JSForStatement where + pretty (JSForStatementCStyle init cond incr stmts) = + text "for" <+> parens (pretty init <> semi <+> pretty cond <> semi <+> + pretty incr) <+> prettyBlock stmts + +instance PrettyPrec JSForStatement -- default + +instance Pretty JSDoStatement where + pretty (JSDoStatement stmts cond) = + text "do" <+> prettyBlock stmts <+> text "while" <+> + parens (pretty cond) <> semi + +instance PrettyPrec JSDoStatement -- default + +instance Pretty JSWhileStatement where + pretty (JSWhileStatement cond stmts) = + text "while" <+> parens (pretty cond) <+> prettyBlock stmts + +instance PrettyPrec JSWhileStatement -- default + +instance Pretty JSTryStatement where + pretty (JSTryStatement tryStmts varName catchStmts) = + text "try" <+> prettyBlock tryStmts <+> parens (pretty varName) <+> prettyBlock catchStmts + +instance PrettyPrec JSTryStatement -- default + +instance Pretty JSThrowStatement where + pretty (JSThrowStatement exp) = + text "throw" <+> pretty exp <> semi + +instance PrettyPrec JSThrowStatement -- default + +instance Pretty JSReturnStatement where + pretty (JSReturnStatement mbExp) = case mbExp of + Nothing -> text "return;" + Just exp -> text "return" <+> pretty exp <> semi + +instance PrettyPrec JSReturnStatement -- default + +instance Pretty JSBreakStatement where + pretty (JSBreakStatement mbExp) = case mbExp of + Nothing -> text "break;" + Just exp -> text "break" <+> pretty exp <> semi + +instance PrettyPrec JSBreakStatement -- default + +instance Pretty JSExpressionStatement where + pretty (JSESApply lvalues rvalue) = + sepWith' (space <> text "=" <> space) lvalues <+> pretty rvalue + pretty (JSESDelete exp refine) = + text "delete" <+> pretty exp <> pretty refine + +instance PrettyPrec JSExpressionStatement -- default + +instance Pretty JSLValue where + pretty (JSLValue name invsAndRefines) = pretty name <> (hcat . map ppIR $ invsAndRefines) + where + ppIR (invs, refine) = (hcat . map pretty $ invs) <> pretty refine + +instance PrettyPrec JSLValue -- default + +instance Pretty JSRValue where + pretty rvalue = case rvalue of + JSRVAssign e -> text "=" <+> pretty e + JSRVAddAssign e -> text "+=" <+> pretty e + JSRVSubAssign e -> text "-=" <+> pretty e + JSRVInvoke invs -> hcat . toList . fmap pretty $ invs + +instance PrettyPrec JSRValue -- default + +instance Pretty JSExpression where + pretty = prettyPrec 0 + +instance PrettyPrec JSExpression where + prettyPrec i exp = case exp of + JSExpressionLiteral literal -> pretty literal + JSExpressionName name -> pretty name + JSExpressionPrefix prefixOp e -> pretty prefixOp <> pretty e + JSExpressionInfix infixOp e e' -> prettyInfixOpApp i (infixOpInfo infixOp) e e' + JSExpressionTernary cond thn els -> + pretty cond <+> char '?' <+> pretty thn <+> colon <+> pretty els + JSExpressionInvocation e i -> pretty e <> pretty i + JSExpressionRefinement e r -> pretty e <> pretty r + JSExpressionNew e i -> text "new" <+> pretty e <> pretty i + JSExpressionDelete e r -> text "new" <+> pretty e <> pretty r + +instance Pretty JSPrefixOperator where + pretty op = case op of + JSTypeOf -> text "typeof" <+> empty + JSToNumber -> char '+' + JSNegate -> char '-' + JSNot -> char '!' + +instance PrettyPrec JSPrefixOperator --default + +instance Pretty JSInfixOperator where + pretty = prettyPrec 0 + +instance PrettyPrec JSInfixOperator where + prettyPrec = error "we never print an operator by itself" + +instance Pretty JSInvocation where + pretty = error "undefined" + +instance PrettyPrec JSInvocation -- default + +instance Pretty JSRefinement where + pretty (JSProperty name) = char '.' <> pretty name + pretty (JSSubscript e) = char '[' <> pretty e <> char ']' + +instance PrettyPrec JSRefinement -- default + +instance Pretty JSLiteral where + pretty lit = case lit of + JSLiteralNumber n -> pretty n + JSLiteralString s -> pretty s + JSLiteralObject o -> pretty o + JSLiteralArray a -> pretty a + JSLiteralFunction f -> pretty f + +instance PrettyPrec JSLiteral -- default + +instance Pretty JSObjectLiteral where + pretty (JSObjectLiteral fields) = lbrace <> sepWith (comma <$> empty) fields <> rbrace + +instance PrettyPrec JSObjectLiteral -- default + +instance Pretty JSObjectField where + pretty (JSObjectField eitherNameString e) = ppEitherNameString <> colon <+> pretty e + where ppEitherNameString = case eitherNameString of + Left name -> pretty name + Right s -> pretty s + +instance PrettyPrec JSObjectField -- default + +instance Pretty JSArrayLiteral where + pretty (JSArrayLiteral es) = sepWith (comma <+> empty) es + +instance PrettyPrec JSArrayLiteral -- default + +instance Pretty JSFunctionLiteral where + pretty (JSFunctionLiteral mbName params body) = + text "function" `join` (parens . hcat . map pretty $ params) <+> pretty body + where join = case mbName of + Just name -> (\a b -> a <+> pretty name <> b) + Nothing -> (<>) + +instance PrettyPrec JSFunctionLiteral -- default + +instance Pretty JSFunctionBody where + pretty (JSFunctionBody varStmts stmts) = + lbrace <$> + indent 2 (sepWith (semi <$> empty) (map pretty varStmts ++ map pretty stmts)) <$> + rbrace + +instance PrettyPrec JSFunctionBody -- default + +instance Pretty JSProgram where + pretty (JSProgram varStmts stmts) = vcat (map pretty varStmts ++ map pretty stmts) + +------------------------ + + +test1 = add (n 1) (add (n 2) (add (add (n 3) (n 4)) (n 5))) + +test2 = add (n 1) (mul (n 2) (n 3)) +test2' = ((n 1) `add` (n 2)) `mul` (n 3) + +test3 :: JSExpressionStatement +test3 = case jsName "x" of + Right nm -> + case jsName "y" of + Right nm' -> JSESApply ((JSLValue nm' []) <:> singleton (JSLValue nm [])) + (JSRVAssign test2') + + +test4 :: JSStatement +test4 = JSStatementExpression test3 + +-- test4a = JSStatement + +test5 :: JSProgram +test5 = JSProgram [] [test4, test4] + +test6 :: JSFunctionLiteral +test6 = JSFunctionLiteral Nothing [] (JSFunctionBody [] [test4]) + +add e e' = JSExpressionInfix JSAdd e e' +mul e e' = JSExpressionInfix JSMul e e' +n x = JSExpressionLiteral (JSLiteralNumber (JSNumber x))