diff --git a/js-good-parts.cabal b/js-good-parts.cabal --- a/js-good-parts.cabal +++ b/js-good-parts.cabal @@ -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 diff --git a/src/Language/JavaScript/AST.hs b/src/Language/JavaScript/AST.hs --- a/src/Language/JavaScript/AST.hs +++ b/src/Language/JavaScript/AST.hs @@ -27,28 +27,28 @@ -- -- /Conventions for concrete syntax/ -- --- * Non-terminals appear in angle brackets e.g. \ +-- * Non-terminals appear in angle brackets e.g. \ -- --- * ? means zero or one. e.g. \? +-- * ? means zero or one. e.g. \? -- --- * * means zero or more e.g. \* +-- * * means zero or more e.g. \* -- --- * + means one 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: = \ +-- can be applied. e.g. \(= \\)* +-- This means zero or more repetitions of: = \ -- -- 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. @\ \(= \\)?@ +-- 1. @\ \(= \\)?@ -- -- 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 -- ^ @\;@ - | JSStatementDisruptive JSDisruptiveStatement -- ^ @\@ - | JSStatementTry JSTryStatement -- ^ @\@ - | JSStatementIf JSIfStatement -- ^ @\@ +data Stmt + = StmtExpr ExprStmt -- ^ @\;@ + | StmtDisruptive DisruptiveStmt -- ^ @\@ + | StmtTry TryStmt -- ^ @\@ + | StmtIf IfStmt -- ^ @\@ - -- | @\(\ : \) \@ - | JSStatementSwitch (Maybe JSName) JSSwitchStatement - -- | @\(\ : \) \@ - | JSStatementWhile (Maybe JSName) JSWhileStatement - -- | @\(\ : \) \@ - | JSStatementFor (Maybe JSName) JSForStatement - -- | @\(\ : \) \@ - | JSStatementDo (Maybe JSName) JSDoStatement + -- | @\(\ : \) \@ + | StmtSwitch (Maybe Name) SwitchStmt + -- | @\(\ : \) \@ + | StmtWhile (Maybe Name) WhileStmt + -- | @\(\ : \) \@ + | StmtFor (Maybe Name) ForStmt + -- | @\(\ : \) \@ + | StmtDo (Maybe Name) DoStmt -- -- | Disruptive statements -- -data JSDisruptiveStatement - = JSDSBreak JSBreakStatement -- ^ @\@ - | JSDSReturn JSReturnStatement -- ^ @syntax: \@ - | JSDSThrow JSThrowStatement -- ^ @syntax: \@ +data DisruptiveStmt + = DSBreak BreakStmt -- ^ @\@ + | DSReturn ReturnStmt -- ^ @syntax: \@ + | DSThrow ThrowStmt -- ^ @syntax: \@ -- -- | Concrete syntax: -- --- @if ( \ ) { \* }@ -- for 'Nothing' +-- @if ( \ ) { \* }@ -- for 'Nothing' -- -- or -- --- @if ( \ ) { \* } else { \* }@ -- for 'Just . Left' +-- @if ( \ ) { \* } else { \* }@ -- for 'Just . Left' -- -- or -- --- @if ( \ ) { \* } else \@ -- for 'Just . Right' +-- @if ( \ ) { \* } else \@ -- 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 ( \ ) { \ }@ +-- @switch ( \ ) { \ }@ -- -- or -- -- @ --- switch ( \ ) { --- \+ --- default : \* +-- switch ( \ ) { +-- \+ +-- default : \* -- } -- @ -- @@ -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: -- --- @\ \@ +-- @\ \@ -- -- e.g. -- @@ -289,12 +295,12 @@ -- break; -- @ -- -data JSCaseAndDisruptive = JSCaseAndDisruptive JSCaseClause JSDisruptiveStatement +data CaseAndDisruptive = CaseAndDisruptive CaseClause DisruptiveStmt -- -- | Concrete syntax: -- --- @case \ : \*@ +-- @case \ : \*@ -- -- 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 (\? ; \? ; \? ) { --- \* +-- for (\? ; \? ; \? ) { +-- \* -- } -- @ -- -- 2. -- -- @ --- for ( \ in \ ) { --- \* +-- for ( \ in \ ) { +-- \* -- } -- @ -- @@ -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 { \* } while ( \ );@ +-- @do { \* } while ( \ );@ -- -data JSDoStatement = JSDoStatement [JSStatement] JSExpression +data DoStmt = DoStmt [Stmt] Expr -- -- | Concrete syntax: -- --- @while ( \) { \* }@ +-- @while ( \) { \* }@ -- -data JSWhileStatement = JSWhileStatement JSExpression [JSStatement] +data WhileStmt = WhileStmt Expr [Stmt] -- -- | Concrete syntax: -- --- @try { \* } catch ( \ ) { \* }@ +-- @try { \* } catch ( \ ) { \* }@ -- -data JSTryStatement = JSTryStatement [JSStatement] JSName [JSStatement] +data TryStmt = TryStmt [Stmt] Name [Stmt] -- -- | Concrete syntax: -- --- @throw \;@ +-- @throw \;@ -- -data JSThrowStatement = JSThrowStatement JSExpression +data ThrowStmt = ThrowStmt Expr -- -- | Concrete syntax: -- --- @return \?;@ +-- @return \?;@ -- -- e.g. -- @@ -397,12 +404,12 @@ -- -- 2. @return 2 + x;@ -- -data JSReturnStatement = JSReturnStatement (Maybe JSExpression) +data ReturnStmt = ReturnStmt (Maybe Expr) -- -- | Concrete syntax: -- --- @break \?;@ +-- @break \?;@ -- -- e.g. -- @@ -410,25 +417,25 @@ -- -- 2. @break some_label;@ -- -data JSBreakStatement = JSBreakStatement (Maybe JSName) +data BreakStmt = BreakStmt (Maybe Name) -- -- | Concrete syntax: -- --- @\+ \@ +-- @\+ \@ -- -- or -- --- @delete \ \@ +-- @delete \ \@ -- -data JSExpressionStatement - = JSESApply (NonEmptyList JSLValue) JSRValue - | JSESDelete JSExpression JSRefinement +data ExprStmt + = ESApply (NonEmptyList LValue) RValue + | ESDelete Expr Refinement -- -- | Concrete syntax: -- --- @\ \(\* \\)*@ +-- @\ \(\* \\)*@ -- -- 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: -- --- @= \@ +-- @= \@ -- -- or -- --- @+= \@ +-- @+= \@ -- -- or -- --- @-= \@ +-- @-= \@ -- -- or -- --- @\+@ +-- @\+@ -- -- 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 -- ^ @\@ - | JSExpressionName JSName -- ^ @\@ +data Expr + = ExprLit Lit -- ^ @\@ + | ExprName Name -- ^ @\@ - -- | @\ \@ - | JSExpressionPrefix JSPrefixOperator JSExpression + -- | @\ \@ + | ExprPrefix PrefixOperator Expr - -- | @\ \ \@ - | JSExpressionInfix JSInfixOperator JSExpression JSExpression + -- | @\ \ \@ + | ExprInfix InfixOperator Expr Expr - -- | @\ ? \ : \@ - | JSExpressionTernary JSExpression JSExpression JSExpression + -- | @\ ? \ : \@ + | ExprTernary Expr Expr Expr - -- | @\\@ - | JSExpressionInvocation JSExpression JSInvocation + -- | @\\@ + | ExprInvocation Expr Invocation - -- | @\\@ - | JSExpressionRefinement JSExpression JSRefinement + -- | @\\@ + | ExprRefinement Expr Refinement - -- | new @\\@ - | JSExpressionNew JSExpression JSInvocation + -- | new @\\@ + | ExprNew Expr Invocation - -- | delete @\\@ - | JSExpressionDelete JSExpression JSRefinement + -- | delete @\\@ + | 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: -- --- @\*@ +-- @\*@ -- -- e.g. -- @@ -541,15 +549,15 @@ -- -- 3. @(x,z,y)@ -- -data JSInvocation = JSInvocation [JSExpression] +data Invocation = Invocation [Expr] -- | Concrete syntax: -- --- @.\@ +-- @.\@ -- -- or -- --- @[\]@ +-- @[\]@ -- -- 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 -- ^ @\@ - | JSLiteralBool Bool -- ^ @\@ - | JSLiteralString JSString -- ^ @\@ - | JSLiteralObject JSObjectLiteral -- ^ @\@ - | JSLiteralArray JSArrayLiteral -- ^ @\@ - | JSLiteralFunction JSFunctionLiteral -- ^ @\@ --- | JSLiteralRegexp JSRegexpLiteral -- TODO: Add regexps +data Lit + = LitNumber Number -- ^ @\@ + | LitBool Bool -- ^ @\@ + | LitString JSString -- ^ @\@ + | LitObject ObjectLit -- ^ @\@ + | LitArray ArrayLit -- ^ @\@ + | LitFn FnLit -- ^ @\@ +-- | LitRegexp RegexpLit -- TODO: Add regexps -- -- | Concrete syntax: @@ -584,18 +592,18 @@ -- -- or -- --- @\{\ \(, \ \)*\}@ -- one or more fields +-- @\{\ \(, \ \)*\}@ -- one or more fields -- -data JSObjectLiteral = JSObjectLiteral [JSObjectField] +data ObjectLit = ObjectLit [ObjectField] -- -- | Concrete syntax: -- --- @\: \ @ -- for Left +-- @\: \ @ -- for Left -- -- or -- --- @\: \ @ -- for Right +-- @\: \ @ -- 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 -- --- @[\ \(, \*\) ]@ -- non empty array +-- @[\ \(, \*\) ]@ -- non empty array -- -data JSArrayLiteral = JSArrayLiteral [JSExpression] +data ArrayLit = ArrayLit [Expr] -- -- | Concrete syntax: -- --- @function \? \@ +-- @function \? \@ -- -data JSFunctionLiteral = JSFunctionLiteral (Maybe JSName) [JSName] JSFunctionBody +data FnLit = FnLit (Maybe Name) [Name] FnBody -- -- | Concrete syntax: -- --- @{ \+ \+ }@ +-- @{ \+ \+ }@ -- -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] diff --git a/src/Language/JavaScript/Pretty.hs b/src/Language/JavaScript/Pretty.hs --- a/src/Language/JavaScript/Pretty.hs +++ b/src/Language/JavaScript/Pretty.hs @@ -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)) -}