js-good-parts 0.0.5 → 0.0.6
raw patch · 3 files changed
+348/−342 lines, 3 files
Files
- js-good-parts.cabal +1/−1
- src/Language/JavaScript/AST.hs +182/−174
- src/Language/JavaScript/Pretty.hs +165/−167
js-good-parts.cabal view
@@ -1,5 +1,5 @@ Name: js-good-parts-Version: 0.0.5+Version: 0.0.6 Cabal-Version: >= 1.6 Synopsis: Javascript: The Good Parts -- AST & Pretty Printer Category: Language, Javascript
src/Language/JavaScript/AST.hs view
@@ -27,28 +27,28 @@ -- -- /Conventions for concrete syntax/ ----- * Non-terminals appear in angle brackets e.g. \<JSName\>+-- * Non-terminals appear in angle brackets e.g. \<Name\> ----- * ? means zero or one. e.g. \<JSExpression\>?+-- * ? means zero or one. e.g. \<Expr\>? ----- * * means zero or more e.g. \<JSStatement\>*+-- * * means zero or more e.g. \<Stmt\>* ----- * + means one or more e.g. \<JSStatement\>++-- * + means one or more e.g. \<Stmt\>+ -- -- * \( \) are meta-brackets used to enclose a concrete-syntax expression so that ?,* or +--- can be applied. e.g. \(= \<JSExpression\>\)*--- This means zero or more repetitions of: = \<JsExpression\>+-- can be applied. e.g. \(= \<Expr\>\)*+-- This means zero or more repetitions of: = \<Expr\> -- -- 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+-- they contain redundancy. For instance, consider the 'ESDelete' constructor which is defined ----- @JSESDelete JSExpression JSInvocation@+-- @ESDelete Expr Invocation@ ----- 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 a 'JSInvocation'.+-- Why not just define it as @ESDelete Expr@ since type @Expr@+-- has a constructor defined as @ExprInvocation Expr Invocation@?+-- The reason is that this would allow incorrect programs. A 'Expr' is+-- not necessarily a 'Invocation'. -- -- /A note on precedence of JavaScript operators/ --@@ -109,36 +109,42 @@ -- @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,+ -- JSString, Name can't be create except with constructors+ JSString, Name, + unString, unName,+ jsString, name, -- * 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(..)+ Number(..),+ VarStmt(..), VarDecl(..), Stmt(..),+ DisruptiveStmt(..), IfStmt(..), SwitchStmt(..),+ CaseAndDisruptive(..), CaseClause(..), ForStmt(..),+ DoStmt(..), WhileStmt(..), TryStmt(..),+ ThrowStmt(..), ReturnStmt(..), BreakStmt(..),+ ExprStmt(..), LValue(..), RValue(..), Expr(..),+ PrefixOperator(..), InfixOperator(..), Invocation(..), Refinement(..),+ Lit(..), ObjectLit(..), ObjectField(..), ArrayLit(..),+ FnLit(..), FnBody(..), Program(..) ) where +--+-- | Abbreviations+--+-- Stmt = Statement, Expr = Expression, Fn = Function, Decl = Declaration+--+ import Language.JavaScript.NonEmptyList -data JSName = JSName { unJSName :: String }+data Name = Name { unName :: String } ----- | 'jsName' is the only way you can create a JSName+-- | 'jsName' is the only way you can create a Name ---jsName :: String -> Either String JSName-jsName = Right . JSName -- FIXME: Return Left on error.+name :: String -> Either String Name+name = Right . Name -- FIXME: Return Left on error. -data JSString = JSString { unJSString :: String }+data JSString = JSString { unString :: String } -- -- | The only way you can create a Javascript string.@@ -149,7 +155,7 @@ jsString = Right . JSString -- FIXME: Return Left on error -newtype JSNumber = JSNumber Double -- 64 bit floating point number+newtype Number = Number Double -- 64 bit floating point number -- -- | Concrete syntax:@@ -158,12 +164,12 @@ -- -- e.g. @var x = 1, y;@ ---data JSVarStatement = JSVarStatement (NonEmptyList JSVarDecl)+data VarStmt = VarStmt (NonEmptyList VarDecl) -- -- | Concrete syntax: ----- 1. @\<JSName\> \(= \<JSExpression\>\)?@+-- 1. @\<Name\> \(= \<Expr\>\)?@ -- -- e.g. --@@ -171,46 +177,46 @@ -- -- 2. @x = 2 + y@ ---data JSVarDecl = JSVarDecl JSName (Maybe JSExpression) -- optional initialization+data VarDecl = VarDecl Name (Maybe Expr) -- optional initialization -- -- | The many different kinds of statements ---data JSStatement- = JSStatementExpression JSExpressionStatement -- ^ @\<JSExpressionStatement\>;@- | JSStatementDisruptive JSDisruptiveStatement -- ^ @\<JSDisruptiveStatement\>@- | JSStatementTry JSTryStatement -- ^ @\<JSTryStatement\>@- | JSStatementIf JSIfStatement -- ^ @\<JSIfStatement\>@+data Stmt+ = StmtExpr ExprStmt -- ^ @\<ExprStmt\>;@+ | StmtDisruptive DisruptiveStmt -- ^ @\<DisruptiveStmt\>@+ | StmtTry TryStmt -- ^ @\<TryStmt\>@+ | StmtIf IfStmt -- ^ @\<IfStmt\>@ - -- | @\(\<JSName\> : \) \<JSSwitchStatement\>@- | JSStatementSwitch (Maybe JSName) JSSwitchStatement- -- | @\(\<JSName\> : \) \<JSWhileStatement\>@- | JSStatementWhile (Maybe JSName) JSWhileStatement- -- | @\(\<JSName\> : \) \<JSForStatement\>@- | JSStatementFor (Maybe JSName) JSForStatement- -- | @\(\<JSName\> : \) \<JSDoStatement\>@- | JSStatementDo (Maybe JSName) JSDoStatement+ -- | @\(\<Name\> : \) \<SwitchStmt\>@+ | StmtSwitch (Maybe Name) SwitchStmt+ -- | @\(\<Name\> : \) \<WhileStmt\>@+ | StmtWhile (Maybe Name) WhileStmt+ -- | @\(\<Name\> : \) \<ForStmt\>@+ | StmtFor (Maybe Name) ForStmt+ -- | @\(\<Name\> : \) \<DoStmt\>@+ | StmtDo (Maybe Name) DoStmt -- -- | Disruptive statements ---data JSDisruptiveStatement- = JSDSBreak JSBreakStatement -- ^ @\<JSBreakStatement\>@- | JSDSReturn JSReturnStatement -- ^ @syntax: \<JSReturnStatement\>@- | JSDSThrow JSThrowStatement -- ^ @syntax: \<JSThrowStatement\>@+data DisruptiveStmt+ = DSBreak BreakStmt -- ^ @\<BreakStmt\>@+ | DSReturn ReturnStmt -- ^ @syntax: \<ReturnStmt\>@+ | DSThrow ThrowStmt -- ^ @syntax: \<ThrowStmt\>@ -- -- | Concrete syntax: ----- @if ( \<JSExpression\> ) { \<JSStatement\>* }@ -- for 'Nothing'+-- @if ( \<Expr\> ) { \<Stmt\>* }@ -- for 'Nothing' -- -- or ----- @if ( \<JSExpression\> ) { \<JSStatement\>* } else { \<JSStatement\>* }@ -- for 'Just . Left'+-- @if ( \<Expr\> ) { \<Stmt\>* } else { \<Stmt\>* }@ -- for 'Just . Left' -- -- or ----- @if ( \<JSExpression\> ) { \<JSStatement\>* } else \<JSIfStatement\>@ -- for 'Just . Right'+-- @if ( \<Expr\> ) { \<Stmt\>* } else \<IfStmt\>@ -- for 'Just . Right' -- -- e.g. --@@ -220,22 +226,22 @@ -- -- 3. @if (x > 0) { y = 20; } else if ( x > 10) { y = 30; } else { y = 10; }@ ---data JSIfStatement = JSIfStatement JSExpression- [JSStatement]- (Maybe (Either [JSStatement] JSIfStatement))+data IfStmt = IfStmt Expr+ [Stmt]+ (Maybe (Either [Stmt] IfStmt)) -- -- | Concrete syntax: ----- @switch ( \<JSExpression\> ) { \<JSCaseClause\> }@+-- @switch ( \<Expr\> ) { \<CaseClause\> }@ -- -- or -- -- @--- switch ( \<JSExpression\> ) {--- \<JSCaseAndDisruptive\>+--- default : \<JSStatement\>*+-- switch ( \<Expr\> ) {+-- \<CaseAndDisruptive\>++-- default : \<Stmt\>* -- } -- @ --@@ -265,12 +271,12 @@ -- } -- @ ---data JSSwitchStatement- = JSSwitchStatementSingleCase JSExpression JSCaseClause- | JSSwitchStatement JSExpression- (NonEmptyList JSCaseAndDisruptive)+data SwitchStmt+ = SwitchStmtSingleCase Expr CaseClause+ | SwitchStmt Expr+ (NonEmptyList CaseAndDisruptive) -- ^ non-default case clauses- [JSStatement]+ [Stmt] -- ^ default clause statements --@@ -278,7 +284,7 @@ -- -- Concrete syntax: ----- @\<JSCaseClause\> \<JSDisruptiveStatement\>@+-- @\<CaseClause\> \<DisruptiveStmt\>@ -- -- e.g. --@@ -289,12 +295,12 @@ -- break; -- @ ---data JSCaseAndDisruptive = JSCaseAndDisruptive JSCaseClause JSDisruptiveStatement+data CaseAndDisruptive = CaseAndDisruptive CaseClause DisruptiveStmt -- -- | Concrete syntax: ----- @case \<JSExpression\> : \<JSStatement\>*@+-- @case \<Expr\> : \<Stmt\>*@ -- -- e.g. --@@ -309,7 +315,7 @@ -- y = 1; -- @ ---data JSCaseClause = JSCaseClause JSExpression [JSStatement]+data CaseClause = CaseClause Expr [Stmt] -- -- | Two style of for-statements -- C-style and In-style.@@ -319,16 +325,16 @@ -- 1. -- -- @--- for (\<JSExpressionStatement\>? ; \<JSExpression\>? ; \<JSExpressionStatement\>? ) {--- \<JSStatement\>*+-- for (\<ExprStmt\>? ; \<Expr\>? ; \<ExprStmt\>? ) {+-- \<Stmt\>* -- } -- @ -- -- 2. -- -- @--- for ( \<JSName\> in \<JSExpression\> ) {--- \<JSStatement\>*+-- for ( \<Name\> in \<Expr\> ) {+-- \<Stmt\>* -- } -- @ --@@ -348,48 +354,49 @@ -- -- 4. @for ( i in indices ) { a[i] = 66; }@ ---data JSForStatement = JSForStatementCStyle- (Maybe JSExpressionStatement)- (Maybe JSExpression)- (Maybe JSExpressionStatement)- [JSStatement]- | JSForStatementInStyle- JSName- JSExpression- [JSStatement]+data ForStmt+ = ForStmtCStyle+ (Maybe ExprStmt)+ (Maybe Expr)+ (Maybe ExprStmt)+ [Stmt]+ | ForStmtInStyle+ Name+ Expr+ [Stmt] -- -- | Concrete syntax: ----- @do { \<JSStatement\>* } while ( \<JSExpression\> );@+-- @do { \<Stmt\>* } while ( \<Expr\> );@ ---data JSDoStatement = JSDoStatement [JSStatement] JSExpression+data DoStmt = DoStmt [Stmt] Expr -- -- | Concrete syntax: ----- @while ( \<JSExpression\>) { \<JSStatement\>* }@+-- @while ( \<Expr\>) { \<Stmt\>* }@ ---data JSWhileStatement = JSWhileStatement JSExpression [JSStatement]+data WhileStmt = WhileStmt Expr [Stmt] -- -- | Concrete syntax: ----- @try { \<JSStatement\>* } catch ( \<JSName\> ) { \<JSStatement\>* }@+-- @try { \<Stmt\>* } catch ( \<Name\> ) { \<Stmt\>* }@ ---data JSTryStatement = JSTryStatement [JSStatement] JSName [JSStatement]+data TryStmt = TryStmt [Stmt] Name [Stmt] -- -- | Concrete syntax: ----- @throw \<JSExpression\>;@+-- @throw \<Expr\>;@ ---data JSThrowStatement = JSThrowStatement JSExpression+data ThrowStmt = ThrowStmt Expr -- -- | Concrete syntax: ----- @return \<JSExpression\>?;@+-- @return \<Expr\>?;@ -- -- e.g. --@@ -397,12 +404,12 @@ -- -- 2. @return 2 + x;@ ---data JSReturnStatement = JSReturnStatement (Maybe JSExpression)+data ReturnStmt = ReturnStmt (Maybe Expr) -- -- | Concrete syntax: ----- @break \<JSName\>?;@+-- @break \<Name\>?;@ -- -- e.g. --@@ -410,25 +417,25 @@ -- -- 2. @break some_label;@ ---data JSBreakStatement = JSBreakStatement (Maybe JSName)+data BreakStmt = BreakStmt (Maybe Name) -- -- | Concrete syntax: ----- @\<JSValue\>+ \<JSRValue\>@+-- @\<Value\>+ \<RValue\>@ -- -- or ----- @delete \<JSExpression\> \<JSRefinement\>@+-- @delete \<Expr\> \<Refinement\>@ ---data JSExpressionStatement- = JSESApply (NonEmptyList JSLValue) JSRValue- | JSESDelete JSExpression JSRefinement+data ExprStmt+ = ESApply (NonEmptyList LValue) RValue+ | ESDelete Expr Refinement -- -- | Concrete syntax: ----- @\<JSName\> \(\<JSInvocation\>* \<JSRefinement\>\)*@+-- @\<Name\> \(\<Invocation\>* \<Refinement\>\)*@ -- -- e.g. --@@ -444,24 +451,24 @@ -- -- 6. @x.fun_field_1(x+2).fun_field_2(y+3).field_3@ ---data JSLValue = JSLValue JSName [([JSInvocation], JSRefinement)]+data LValue = LValue Name [([Invocation], Refinement)] -- -- | Concrete syntax: ----- @= \<JSExpression\>@+-- @= \<Expr\>@ -- -- or ----- @+= \<JSExpression\>@+-- @+= \<Expr\>@ -- -- or ----- @-= \<JSExpression\>@+-- @-= \<Expr\>@ -- -- or ----- @\<JSInvocation\>+@+-- @\<Invocation\>+@ -- -- e.g. --@@ -477,61 +484,62 @@ -- -- 6. @(x,y,z)@ ---data JSRValue- = JSRVAssign JSExpression- | JSRVAddAssign JSExpression- | JSRVSubAssign JSExpression- | JSRVInvoke (NonEmptyList JSInvocation)+data RValue+ = RVAssign Expr+ | RVAddAssign Expr+ | RVSubAssign Expr+ | RVInvoke (NonEmptyList Invocation) -data JSExpression = JSExpressionLiteral JSLiteral -- ^ @\<JSLiteral\>@- | JSExpressionName JSName -- ^ @\<JSName\>@+data Expr + = ExprLit Lit -- ^ @\<Lit\>@+ | ExprName Name -- ^ @\<Name\>@ - -- | @\<JSPrefixOperator> \<JSExpression\>@- | JSExpressionPrefix JSPrefixOperator JSExpression+ -- | @\<PrefixOperator> \<Expr\>@+ | ExprPrefix PrefixOperator Expr - -- | @\<JSExpression\> \<JSInfixOperator\> \<JSExpression\>@- | JSExpressionInfix JSInfixOperator JSExpression JSExpression+ -- | @\<Expr\> \<InfixOperator\> \<Expr\>@+ | ExprInfix InfixOperator Expr Expr - -- | @\<JSExpression\> ? \<JSExpression\> : \<JSExpression\>@- | JSExpressionTernary JSExpression JSExpression JSExpression+ -- | @\<Expr\> ? \<Expr\> : \<Expr\>@+ | ExprTernary Expr Expr Expr - -- | @\<JSExpression\>\<JSInvocation\>@- | JSExpressionInvocation JSExpression JSInvocation+ -- | @\<Expr\>\<Invocation\>@+ | ExprInvocation Expr Invocation - -- | @\<JSExpression\>\<JSRefinement\>@- | JSExpressionRefinement JSExpression JSRefinement+ -- | @\<Expr\>\<Refinement\>@+ | ExprRefinement Expr Refinement - -- | new @\<JSExpression\>\<JSInvocation\>@- | JSExpressionNew JSExpression JSInvocation+ -- | new @\<Expr\>\<Invocation\>@+ | ExprNew Expr Invocation - -- | delete @\<JSExpression\>\<JSRefinement\>@- | JSExpressionDelete JSExpression JSRefinement+ -- | delete @\<Expr\>\<Refinement\>@+ | ExprDelete Expr Refinement -data JSPrefixOperator- = JSTypeOf -- ^ @typeof@- | JSToNumber -- ^ @+@- | JSNegate -- ^ @-@- | JSNot -- ^ @!@+data PrefixOperator+ = TypeOf -- ^ @typeof@+ | ToNumber -- ^ @+@+ | Negate -- ^ @-@+ | Not -- ^ @!@ -data JSInfixOperator- = JSMul -- ^ @*@- | JSDiv -- ^ @/@- | JSMod -- ^ @%@- | JSAdd -- ^ @+@- | JSSub -- ^ @-@- | JSGTE -- ^ @>=@- | JSLTE -- ^ @<=@- | JSGT -- ^ @>@- | JSLT -- ^ @<@- | JSEq -- ^ @===@- | JSNotEq-- ^ @!==@- | JSOr -- ^ @||@- | JSAnd -- ^ @&&@+data InfixOperator+ = Mul -- ^ @*@+ | Div -- ^ @/@+ | Mod -- ^ @%@+ | Add -- ^ @+@+ | Sub -- ^ @-@+ | GTE -- ^ @>=@+ | LTE -- ^ @<=@+ | GT -- ^ @>@+ | LT -- ^ @<@+ | Eq -- ^ @===@+ | NotEq-- ^ @!==@+ | Or -- ^ @||@+ | And -- ^ @&&@ -- -- | Concrete syntax: ----- @\<JSExpression\>*@+-- @\<Expr\>*@ -- -- e.g. --@@ -541,15 +549,15 @@ -- -- 3. @(x,z,y)@ ---data JSInvocation = JSInvocation [JSExpression]+data Invocation = Invocation [Expr] -- | Concrete syntax: ----- @.\<JSName\>@+-- @.\<Name\>@ -- -- or ----- @[\<JSExpression\>]@+-- @[\<Expr\>]@ -- -- e.g. --@@ -557,9 +565,9 @@ -- -- 2. @[i+1]@ ---data JSRefinement- = JSProperty JSName- | JSSubscript JSExpression+data Refinement+ = Property Name+ | Subscript Expr -- -- | Interestingly, the syntax diagrams presented in the book don't include@@ -568,14 +576,14 @@ -- -data JSLiteral- = JSLiteralNumber JSNumber -- ^ @\<JSNumber\>@- | JSLiteralBool Bool -- ^ @\<true | false\>@- | JSLiteralString JSString -- ^ @\<JSString\>@- | JSLiteralObject JSObjectLiteral -- ^ @\<JSObjectLiteral\>@- | JSLiteralArray JSArrayLiteral -- ^ @\<JSArrayLiteral\>@- | JSLiteralFunction JSFunctionLiteral -- ^ @\<JSFunctionLiteral\>@--- | JSLiteralRegexp JSRegexpLiteral -- TODO: Add regexps+data Lit+ = LitNumber Number -- ^ @\<Number\>@+ | LitBool Bool -- ^ @\<true | false\>@+ | LitString JSString -- ^ @\<String\>@+ | LitObject ObjectLit -- ^ @\<ObjectLit\>@+ | LitArray ArrayLit -- ^ @\<ArrayLit\>@+ | LitFn FnLit -- ^ @\<FnLit\>@+-- | LitRegexp RegexpLit -- TODO: Add regexps -- -- | Concrete syntax:@@ -584,18 +592,18 @@ -- -- or ----- @\{\<JSObjectField\> \(, \<JSObjectField\> \)*\}@ -- one or more fields+-- @\{\<ObjectField\> \(, \<ObjectField\> \)*\}@ -- one or more fields ---data JSObjectLiteral = JSObjectLiteral [JSObjectField]+data ObjectLit = ObjectLit [ObjectField] -- -- | Concrete syntax: ----- @\<JSName\>: \<JSExpression\> @ -- for Left+-- @\<Name\>: \<Expr\> @ -- for Left -- -- or ----- @\<JSString\>: \<JSExpression\> @ -- for Right+-- @\<String\>: \<Expr\> @ -- for Right -- -- e.g. --@@ -603,7 +611,7 @@ -- -- 2. @\"value\": 3 - z@ ---data JSObjectField = JSObjectField (Either JSName JSString) JSExpression+data ObjectField = ObjectField (Either Name String) Expr -- -- | Concrete syntax:@@ -612,23 +620,23 @@ -- -- or ----- @[\<JSExpression\> \(, \<JSExpression\>*\) ]@ -- non empty array+-- @[\<Expr\> \(, \<Expr\>*\) ]@ -- non empty array ---data JSArrayLiteral = JSArrayLiteral [JSExpression]+data ArrayLit = ArrayLit [Expr] -- -- | Concrete syntax: ----- @function \<JSName\>? \<JSFunctionBody\>@+-- @function \<Name\>? \<FnBody\>@ ---data JSFunctionLiteral = JSFunctionLiteral (Maybe JSName) [JSName] JSFunctionBody+data FnLit = FnLit (Maybe Name) [Name] FnBody -- -- | Concrete syntax: ----- @{ \<JSVarStatement\>+ \<JSStatement\>+ }@+-- @{ \<VarStmt\>+ \<Stmt\>+ }@ ---data JSFunctionBody = JSFunctionBody [JSVarStatement] [JSStatement]+data FnBody = FnBody [VarStmt] [Stmt] -- | Programs. All variable statements come first.-data JSProgram = JSProgram [JSVarStatement] [JSStatement]+data Program = Program [VarStmt] [Stmt]
src/Language/JavaScript/Pretty.hs view
@@ -7,17 +7,20 @@ -- System libraries import Text.PrettyPrint.Leijen import Text.PrettyPrint.Leijen.PrettyPrec+import Prelude hiding (GT, LT) -- friends import Language.JavaScript.AST import Language.JavaScript.NonEmptyList -- FIXME: This will be a little tricky to get right.+-- If the string contains double quotes you need to escape.+-- If the string contains single quotes you need to escape. instance Pretty JSString where- pretty s = char '"' <> text (unJSString s) <> char '"' -- enclosed in double quotes+ pretty s = char '"' <> text (unString s) <> char '"' -- enclosed in double quotes -instance Pretty JSName where- pretty = text . unJSName+instance Pretty Name where+ pretty = text . unName sepWith :: Pretty a => Doc -> [a] -> Doc sepWith s = encloseSep empty empty s . map pretty@@ -40,8 +43,8 @@ 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+prettyInfixOpApp prec (OpInfo opPrec assoc nm) a b =+ docParen (prec > opPrec) $ bump LeftToRight a <+> text nm <+> bump RightToLeft b where bump assoc' d = prettyPrec opPrec' d where opPrec' = if assoc == assoc' then opPrec else opPrec + 1@@ -50,80 +53,75 @@ docParen True = parens docParen False = id -data OpInfo = OpInfo Int -- recedence+data OpInfo = OpInfo Int -- precedence 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+-- Lower precedence means the operator binds more tightly ---infixOpInfo :: JSInfixOperator -> OpInfo+infixOpInfo :: InfixOperator -> 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 "&&"+ Mul -> go 6 "*"+ Div -> go 6 "/"+ Mod -> go 6 "%"+ Add -> go 5 "+"+ Sub -> go 5 "-"+ GTE -> go 4 ">="+ LTE -> go 4 "<="+ GT -> go 4 ">"+ LT -> go 4 "<"+ Eq -> go 3 "==="+ NotEq -> go 3 "!=="+ Or -> go 1 "||"+ And -> go 2 "&&" where go i s = OpInfo i LeftToRight s ----------------------------------------------------------------------- -instance Pretty JSNumber where- pretty (JSNumber n) = pretty n -- FIXME: Make sure this always produce valid Javascript numbers.+instance Pretty Number where+ pretty (Number n) = pretty n -- FIXME: Make sure this always produce valid Javascript numbers. -instance PrettyPrec JSNumber -- default+instance PrettyPrec Number -- default -instance Pretty JSVarStatement where- pretty (JSVarStatement varDecls) = sepWith' (comma <+> empty) varDecls+instance Pretty VarStmt where+ pretty (VarStmt varDecls) = sepWith' (comma <+> empty) varDecls -instance PrettyPrec JSVarStatement -- default+instance PrettyPrec VarStmt -- default -instance Pretty JSVarDecl where- pretty (JSVarDecl nm Nothing) = pretty nm- pretty (JSVarDecl nm (Just exp')) = pretty nm <+> text "=" <+> pretty exp'+instance Pretty VarDecl where+ pretty (VarDecl nm Nothing) = pretty nm+ pretty (VarDecl nm (Just exp')) = pretty nm <+> text "=" <+> pretty exp' -instance PrettyPrec JSVarDecl -- default+instance PrettyPrec VarDecl -- default -instance Pretty JSStatement where+instance Pretty Stmt 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+ (StmtExpr es) -> pretty es <> semi+ (StmtDisruptive ds) -> pretty ds+ (StmtTry ts) -> pretty ts+ (StmtIf is) -> pretty is+ (StmtSwitch mbLbl ss) -> pp mbLbl ss+ (StmtWhile mbLbl ws) -> pp mbLbl ws+ (StmtFor mbLbl fs) -> pp mbLbl fs+ (StmtDo mbLbl ds) -> pp mbLbl ds where- pp :: Pretty a => Maybe JSName -> a -> Doc+ pp :: Pretty a => Maybe Name -> a -> Doc pp (Just label) doc = pretty label <> colon <+> pretty doc pp Nothing doc = pretty doc -instance PrettyPrec JSStatement-- default+instance PrettyPrec Stmt-- default -instance Pretty JSDisruptiveStatement where+instance Pretty DisruptiveStmt where pretty stmt = case stmt of- JSDSBreak bs -> pretty bs- JSDSReturn rs -> pretty rs- JSDSThrow ts -> pretty ts+ DSBreak bs -> pretty bs+ DSReturn rs -> pretty rs+ DSThrow ts -> pretty ts -instance PrettyPrec JSDisruptiveStatement -- default+instance PrettyPrec DisruptiveStmt -- default -instance Pretty JSIfStatement where- pretty (JSIfStatement cond thenStmts blockOrIf) =+instance Pretty IfStmt where+ pretty (IfStmt cond thenStmts blockOrIf) = text "if" <+> parens (pretty cond) <+> prettyBlock thenStmts <+> ppRest where ppRest = case blockOrIf of@@ -131,194 +129,194 @@ Just (Left elseStmts) -> text "else" <+> prettyBlock elseStmts Just (Right ifStmt) -> pretty ifStmt -instance PrettyPrec JSIfStatement -- default+instance PrettyPrec IfStmt -- default -instance Pretty JSSwitchStatement where- pretty (JSSwitchStatementSingleCase cond caseClause) =+instance Pretty SwitchStmt where+ pretty (SwitchStmtSingleCase cond caseClause) = text "switch" <+> parens (pretty cond) <+> lbrace <$> pretty caseClause <$> rbrace- pretty (JSSwitchStatement cond cds stmts) =+ pretty (SwitchStmt 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 PrettyPrec SwitchStmt -- default -instance Pretty JSCaseAndDisruptive where- pretty (JSCaseAndDisruptive caseClause disruptive) =+instance Pretty CaseAndDisruptive where+ pretty (CaseAndDisruptive caseClause disruptive) = pretty caseClause <$> pretty disruptive -instance PrettyPrec JSCaseAndDisruptive -- default+instance PrettyPrec CaseAndDisruptive -- default -instance Pretty JSCaseClause where- pretty (JSCaseClause exp' stmts) =+instance Pretty CaseClause where+ pretty (CaseClause exp' stmts) = text "case" <+> pretty exp' <> colon <+> endWith semi stmts -instance PrettyPrec JSCaseClause -- default+instance PrettyPrec CaseClause -- default -instance Pretty JSForStatement where- pretty (JSForStatementCStyle init_ cond incr stmts) =+instance Pretty ForStmt where+ pretty (ForStmtCStyle init_ cond incr stmts) = text "for" <+> parens (pretty init_ <> semi <+> pretty cond <> semi <+> pretty incr) <+> prettyBlock stmts- pretty (JSForStatementInStyle name exp' stmts) =- text "for" <+> parens (pretty name <+> text "in" <+> pretty exp') <+> prettyBlock stmts+ pretty (ForStmtInStyle nm exp' stmts) =+ text "for" <+> parens (pretty nm <+> text "in" <+> pretty exp') <+> prettyBlock stmts -instance PrettyPrec JSForStatement -- default+instance PrettyPrec ForStmt -- default -instance Pretty JSDoStatement where- pretty (JSDoStatement stmts cond) =+instance Pretty DoStmt where+ pretty (DoStmt stmts cond) = text "do" <+> prettyBlock stmts <+> text "while" <+> parens (pretty cond) <> semi -instance PrettyPrec JSDoStatement -- default+instance PrettyPrec DoStmt -- default -instance Pretty JSWhileStatement where- pretty (JSWhileStatement cond stmts) =+instance Pretty WhileStmt where+ pretty (WhileStmt cond stmts) = text "while" <+> parens (pretty cond) <+> prettyBlock stmts -instance PrettyPrec JSWhileStatement -- default+instance PrettyPrec WhileStmt -- default -instance Pretty JSTryStatement where- pretty (JSTryStatement tryStmts varName catchStmts) =+instance Pretty TryStmt where+ pretty (TryStmt tryStmts varName catchStmts) = text "try" <+> prettyBlock tryStmts <+> parens (pretty varName) <+> prettyBlock catchStmts -instance PrettyPrec JSTryStatement -- default+instance PrettyPrec TryStmt -- default -instance Pretty JSThrowStatement where- pretty (JSThrowStatement exp_) =+instance Pretty ThrowStmt where+ pretty (ThrowStmt exp_) = text "throw" <+> pretty exp_ <> semi -instance PrettyPrec JSThrowStatement -- default+instance PrettyPrec ThrowStmt -- default -instance Pretty JSReturnStatement where- pretty (JSReturnStatement mbExp) = case mbExp of+instance Pretty ReturnStmt where+ pretty (ReturnStmt mbExp) = case mbExp of Nothing -> text "return;" Just exp_ -> text "return" <+> pretty exp_ <> semi -instance PrettyPrec JSReturnStatement -- default+instance PrettyPrec ReturnStmt -- default -instance Pretty JSBreakStatement where- pretty (JSBreakStatement mbExp) = case mbExp of+instance Pretty BreakStmt where+ pretty (BreakStmt mbExp) = case mbExp of Nothing -> text "break;" Just exp_ -> text "break" <+> pretty exp_ <> semi -instance PrettyPrec JSBreakStatement -- default+instance PrettyPrec BreakStmt -- default -instance Pretty JSExpressionStatement where- pretty (JSESApply lvalues rvalue) =+instance Pretty ExprStmt where+ pretty (ESApply lvalues rvalue) = sepWith' (space <> text "=" <> space) lvalues <+> pretty rvalue- pretty (JSESDelete exp_ refine) =+ pretty (ESDelete exp_ refine) = text "delete" <+> pretty exp_ <> pretty refine -instance PrettyPrec JSExpressionStatement -- default+instance PrettyPrec ExprStmt -- default -instance Pretty JSLValue where- pretty (JSLValue name invsAndRefines) = pretty name <> (hcat . map ppIR $ invsAndRefines)+instance Pretty LValue where+ pretty (LValue nm invsAndRefines) = pretty nm <> (hcat . map ppIR $ invsAndRefines) where ppIR (invs, refine) = (hcat . map pretty $ invs) <> pretty refine -instance PrettyPrec JSLValue -- default+instance PrettyPrec LValue -- default -instance Pretty JSRValue where+instance Pretty RValue 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+ RVAssign e -> text "=" <+> pretty e+ RVAddAssign e -> text "+=" <+> pretty e+ RVSubAssign e -> text "-=" <+> pretty e+ RVInvoke invs -> hcat . toList . fmap pretty $ invs -instance PrettyPrec JSRValue -- default+instance PrettyPrec RValue -- default -instance Pretty JSExpression where+instance Pretty Expr where pretty = prettyPrec 0 -instance PrettyPrec JSExpression where+instance PrettyPrec Expr 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 ->+ ExprLit literal -> pretty literal+ ExprName nm -> pretty nm+ ExprPrefix prefixOp e -> pretty prefixOp <> pretty e+ ExprInfix infixOp e e' -> prettyInfixOpApp i (infixOpInfo infixOp) e e'+ ExprTernary 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+ ExprInvocation e i' -> pretty e <> pretty i'+ ExprRefinement e r -> pretty e <> pretty r+ ExprNew e i' -> text "new" <+> pretty e <> pretty i'+ ExprDelete e r -> text "new" <+> pretty e <> pretty r -instance Pretty JSPrefixOperator where+instance Pretty PrefixOperator where pretty op = case op of- JSTypeOf -> text "typeof" <+> empty- JSToNumber -> char '+'- JSNegate -> char '-'- JSNot -> char '!'+ TypeOf -> text "typeof" <+> empty+ ToNumber -> char '+'+ Negate -> char '-'+ Not -> char '!' -instance PrettyPrec JSPrefixOperator --default+instance PrettyPrec PrefixOperator --default -instance Pretty JSInfixOperator where+instance Pretty InfixOperator where pretty = prettyPrec 0 -instance PrettyPrec JSInfixOperator where+instance PrettyPrec InfixOperator where prettyPrec = error "we never print an operator by itself" -instance Pretty JSInvocation where- pretty (JSInvocation es) = lparen <> sepWith (comma <+> empty) es <> rparen+instance Pretty Invocation where+ pretty (Invocation es) = lparen <> sepWith (comma <+> empty) es <> rparen -instance PrettyPrec JSInvocation -- default+instance PrettyPrec Invocation -- default -instance Pretty JSRefinement where- pretty (JSProperty name) = char '.' <> pretty name- pretty (JSSubscript e) = char '[' <> pretty e <> char ']'+instance Pretty Refinement where+ pretty (Property nm) = char '.' <> pretty nm+ pretty (Subscript e) = char '[' <> pretty e <> char ']' -instance PrettyPrec JSRefinement -- default+instance PrettyPrec Refinement -- default -instance Pretty JSLiteral where+instance Pretty Lit where pretty lit = case lit of- JSLiteralNumber n -> pretty n- JSLiteralBool b -> pretty b- JSLiteralString s -> pretty s- JSLiteralObject o -> pretty o- JSLiteralArray a -> pretty a- JSLiteralFunction f -> pretty f+ LitNumber n -> pretty n+ LitBool b -> pretty b+ LitString s -> pretty s+ LitObject o -> pretty o+ LitArray a -> pretty a+ LitFn f -> pretty f -instance PrettyPrec JSLiteral -- default+instance PrettyPrec Lit -- default -instance Pretty JSObjectLiteral where- pretty (JSObjectLiteral fields) = lbrace <> sepWith (comma <$> empty) fields <> rbrace+instance Pretty ObjectLit where+ pretty (ObjectLit fields) = lbrace <> sepWith (comma <$> empty) fields <> rbrace -instance PrettyPrec JSObjectLiteral -- default+instance PrettyPrec ObjectLit -- default -instance Pretty JSObjectField where- pretty (JSObjectField eitherNameString e) = ppEitherNameString <> colon <+> pretty e+instance Pretty ObjectField where+ pretty (ObjectField eitherNameString e) = ppEitherNameString <> colon <+> pretty e where ppEitherNameString = case eitherNameString of- Left name -> pretty name+ Left nm -> pretty nm Right s -> pretty s -instance PrettyPrec JSObjectField -- default+instance PrettyPrec ObjectField -- default -instance Pretty JSArrayLiteral where- pretty (JSArrayLiteral es) = lbracket <> sepWith (comma <+> empty) es <> rbracket+instance Pretty ArrayLit where+ pretty (ArrayLit es) = lbracket <> sepWith (comma <+> empty) es <> rbracket -instance PrettyPrec JSArrayLiteral -- default+instance PrettyPrec ArrayLit -- default -instance Pretty JSFunctionLiteral where- pretty (JSFunctionLiteral mbName params body) =+instance Pretty FnLit where+ pretty (FnLit 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)+ Just nm -> (\a b -> a <+> pretty nm <> b) Nothing -> (<>) -instance PrettyPrec JSFunctionLiteral -- default+instance PrettyPrec FnLit -- default -instance Pretty JSFunctionBody where- pretty (JSFunctionBody varStmts stmts) =+instance Pretty FnBody where+ pretty (FnBody varStmts stmts) = lbrace <$> indent 2 (sepWith (semi <$> empty) (map pretty varStmts ++ map pretty stmts)) <$> rbrace -instance PrettyPrec JSFunctionBody -- default+instance PrettyPrec FnBody -- default -instance Pretty JSProgram where- pretty (JSProgram varStmts stmts) = vcat (map pretty varStmts ++ map pretty stmts)+instance Pretty Program where+ pretty (Program varStmts stmts) = vcat (map pretty varStmts ++ map pretty stmts) ------------------------ @@ -328,26 +326,26 @@ test2 = add (n 1) (mul (n 2) (n 3)) test2' = ((n 1) `add` (n 2)) `mul` (n 3) -test3 :: JSExpressionStatement+test3 :: ExprStmt test3 = case jsName "x" of Right nm -> case jsName "y" of- Right nm' -> JSESApply ((JSLValue nm' []) <:> singleton (JSLValue nm []))- (JSRVAssign test2')+ Right nm' -> ESApply ((LValue nm' []) <:> singleton (LValue nm []))+ (RVAssign test2') -test4 :: JSStatement-test4 = JSStatementExpression test3+test4 :: Stmt+test4 = StmtExpr test3 --- test4a = JSStatement+-- test4a = Stmt -test5 :: JSProgram-test5 = JSProgram [] [test4, test4]+test5 :: Program+test5 = Program [] [test4, test4] -test6 :: JSFunctionLiteral-test6 = JSFunctionLiteral Nothing [] (JSFunctionBody [] [test4])+test6 :: FnLit+test6 = FnLit Nothing [] (FnBody [] [test4]) -add e e' = JSExpressionInfix JSAdd e e'-mul e e' = JSExpressionInfix JSMul e e'-n x = JSExpressionLiteral (JSLiteralNumber (JSNumber x))+add e e' = ExprInfix Add e e'+mul e e' = ExprInfix Mul e e'+n x = ExprLit (LitNumber (Number x)) -}