# LANGUAGE StandaloneDeriving #
# OPTIONS_GHC -fno - warn - orphans #

module Reach.JSOrphans () where

import qualified Data.Text.Lazy as T
import Language.JavaScript.Parser
import Language.JavaScript.Parser.Lexer
import Reach.Texty
import Language.JavaScript.Parser.AST

instance Ord TokenPosn where
  compare (TokenPn x_a x_l x_c) (TokenPn y_a y_l y_c) =
    compare [x_a, x_l, x_c] [y_a, y_l, y_c]

-- | This is fine because the Show instance is derived
deriving instance Read Token

viaJS :: (JSAnnot -> JSAST) -> Doc
viaJS mk = DText $ T.pack $ unwords . words $ T.unpack $ renderToText $ mk JSNoAnnot

instance Pretty JSArrayElement where
  pretty = \case
    JSArrayElement je -> pretty je
    JSArrayComma _ -> ","

instance Pretty JSAssignOp where
  pretty = \case
    JSAssign _ -> "="
    JSTimesAssign _ -> "*="
    JSDivideAssign _ -> "/="
    JSModAssign _ -> "%="
    JSPlusAssign _ -> "+="
    JSMinusAssign _ -> "-="
    JSLshAssign _ -> "<<="
    JSRshAssign _ -> ">>="
    JSUrshAssign _ -> ">>>="
    JSBwAndAssign _ -> "&="
    JSBwXorAssign _ -> "^="
    JSBwOrAssign _ -> "|="

instance Pretty JSBinOp where
  pretty = \case
    JSBinOpAnd _ -> "&&"
    JSBinOpBitAnd _ -> "&"
    JSBinOpBitOr _ -> "|"
    JSBinOpBitXor _ -> "^"
    JSBinOpDivide _ -> "/"
    JSBinOpEq _ -> "=="
    JSBinOpGe _ -> ">="
    JSBinOpGt _ -> ">"
    JSBinOpIn _ -> "in "
    JSBinOpInstanceOf _ -> "instanceof"
    JSBinOpLe _ -> "<="
    JSBinOpLsh _ -> "<<"
    JSBinOpLt _ -> "<"
    JSBinOpMinus _ -> "-"
    JSBinOpMod _ -> "%"
    JSBinOpNeq _ -> "!="
    JSBinOpOf _ -> "of "
    JSBinOpOr _ -> "||"
    JSBinOpPlus _ -> "+"
    JSBinOpRsh _ -> ">>"
    JSBinOpStrictEq _ -> "==="
    JSBinOpStrictNeq _ -> "!=="
    JSBinOpTimes _ -> "*"
    JSBinOpUrsh _ -> ">>>"

instance Pretty JSUnaryOp where
  pretty = \case
    JSUnaryOpDecr _ -> "--"
    JSUnaryOpDelete _ -> "delete"
    JSUnaryOpIncr _ -> "++"
    JSUnaryOpMinus _ -> "-"
    JSUnaryOpNot _ -> "!"
    JSUnaryOpPlus _ -> "+"
    JSUnaryOpTilde _ -> "~"
    JSUnaryOpTypeof _ -> "typeof"
    JSUnaryOpVoid _ -> "void"

instance Pretty a => Pretty (JSCommaList a) where
  pretty = \case
    JSLCons jcl _ a -> pretty jcl <> "," <+> pretty a
    JSLOne a -> pretty a
    JSLNil -> ""

instance Pretty JSIdent where
  pretty = \case
    JSIdentName _ s -> viaShow s
    JSIdentNone -> ""

instance Pretty JSArrowParameterList where
  pretty = \case
    JSUnparenthesizedArrowParameter ji -> pretty ji
    JSParenthesizedArrowParameterList _ jcl _ -> parens (pretty jcl)

instance Pretty JSBlock where
  pretty = \case JSBlock _ jss _ -> braces (hardline <> pretty jss <> hardline)

instance Pretty JSConciseBody where
  pretty = \case
    JSConciseExprBody je -> pretty je
    JSConciseFunBody jb -> pretty jb

instance Pretty JSPropertyName where
  pretty = \case
    JSPropertyIdent _ s -> pretty s
    JSPropertyString _ s -> pretty s
    JSPropertyNumber _ s -> pretty s
    JSPropertyComputed _ je _' -> pretty je

instance Pretty JSMethodDefinition where
  pretty = \case
    JSMethodDefinition jpn _ jcl _ jb -> pretty jpn <+> parens (pretty jcl) <+> pretty jb
    JSGeneratorMethodDefinition {} -> "<generator method>"
    JSPropertyAccessor {} -> "<property accessor>"

instance Pretty JSObjectProperty where
  pretty = \case
    JSPropertyNameandValue jpn _ (je:[]) -> pretty jpn <+> ":" <+> pretty je
    JSPropertyNameandValue jpn _ jes -> pretty jpn <+> ":" <+> pretty jes
    JSPropertyIdentRef _ s -> pretty s
    JSObjectMethod jmd -> pretty jmd
    JSObjectSpread _ je -> "..." <> pretty je

instance Pretty JSObjectPropertyList where
  pretty = \case
    JSCTLComma jcl _ -> pretty jcl
    JSCTLNone jcl -> pretty jcl

instance Pretty JSVarInitializer where
  pretty = \case
    JSVarInit _ je -> "=" <+> pretty je
    JSVarInitNone -> ""

instance Pretty JSExpression where
  pretty = \case
    JSIdentifier _ ('.':s') -> pretty $ "internal_" <> s'
    JSIdentifier _ s -> pretty s
    JSDecimal _ s -> pretty s
    JSLiteral _ ".null" -> "secret(null)"
    JSLiteral _ s -> pretty s
    JSHexInteger _ s -> pretty s
    JSOctal _ s -> pretty s
    JSStringLiteral _ s -> pretty s
    JSRegEx _ s -> pretty s
    JSArrayLiteral _ jaes _' -> brackets (hcat $ map pretty jaes)
    JSAssignExpression je jao je' -> pretty je <+> pretty jao <+> pretty je'
    JSAwaitExpression _ je -> "await" <+> pretty je
    JSCallExpression (je@JSArrowExpression {}) _ jcl _' -> parens (pretty je) <> parens (pretty jcl)
    JSCallExpression je _ jcl _' -> pretty je <> parens (pretty jcl)
    JSExpressionBinary je jbo je' -> pretty je <+> pretty jbo <+> pretty je'
    JSExpressionParen _ je _' -> parens (pretty je)
    JSExpressionTernary je _ je' _' je2 -> pretty je <+> "?" <+> pretty je' <+> ":" <+> pretty je2
    JSArrowExpression japl _ jcb -> pretty japl <+> "=>" <+> pretty jcb
    JSFunctionExpression _ ji _' jcl _ jb -> "function" <+> pretty ji <+> parens (pretty jcl) <+> pretty jb
    JSMemberDot je _ je' -> pretty je <> "." <> pretty je'
    JSMemberExpression je _ jcl _' -> pretty je <> parens (pretty jcl)
    JSSpreadExpression _ je -> "..." <> pretty je
    JSMemberSquare je _ je' _' -> pretty je <> brackets (pretty je')
    JSNewExpression _ je -> "new" <+> pretty je
    JSObjectLiteral _ jctl _' -> braces (pretty jctl)
    JSUnaryExpression juo je -> pretty juo <+> pretty je
    JSVarInitExpression je jvi -> pretty je <+> pretty jvi
    ow -> viaJS $ JSAstExpression ow

instance Pretty [JSStatement] where
  pretty ss = do
    let ss' = map pretty ss
    concatWith (\ l r -> l <> hardline <> r) ss'

instance Pretty JSSwitchParts where
  pretty = \case
    JSCase _ je _' jss -> "case" <+> pretty je <> ":" <+> braces (pretty jss)
    JSDefault _ _' jss -> "default:" <+> pretty jss

instance Pretty [JSSwitchParts] where
  pretty ss = do
    let ss' = map pretty ss
    concatWith (\ l r -> l <> hardline <> r) ss'

instance Pretty JSTryCatch where
  pretty = \case
    JSCatch _ _' je _ jb -> "catch" <+> parens (pretty je) <+> pretty jb
    JSCatchIf {} -> "<catch if>"

instance Pretty JSStatement where
  pretty = (<> ";") . \case
    JSStatementBlock _ jss _' _ -> pretty jss
    JSBreak _ ji _ -> "break" <+> pretty ji
    JSLet _ jcl _ -> "let" <+> pretty jcl
    JSConstant _ jcl _ -> "const" <+> pretty jcl
    JSContinue _ ji _ -> "continue" <+> pretty ji
    JSFunction _ ji _' jcl _ jb _ -> "function" <+> pretty ji <+> parens (pretty jcl) <+> pretty jb
    JSIf _ _' je _ t -> "if" <+> pretty je <+> braces (pretty t)
    JSIfElse _ _' je _ a _ b -> "if" <+> pretty je <+> braces (pretty a) <+> "else" <+> braces (pretty b)
    JSExpressionStatement je _ -> pretty je
    JSAssignStatement je jao je' _ -> pretty je <+> pretty jao <+> pretty je'
    JSMethodCall je _ jcl _' _ -> pretty je <+> parens (pretty jcl)
    JSReturn _ (Just je) _ -> "return" <+> pretty je
    JSReturn _ _ _ -> "return"
    JSSwitch _ _' je _ _ jsps _ _ -> "switch" <+> parens (pretty je) <+> braces (pretty jsps)
    JSThrow _ je _ -> "throw" <+> pretty je
    JSTry _ jb jtcs _ -> "try" <+> pretty jb <+> pretty jtcs
    JSVariable _ jcl _ -> pretty jcl
    JSWhile _ _' je _ s -> "while" <+> parens (pretty je) <+> pretty s
    ow -> viaJS $ JSAstStatement ow

 | This is fine because the Show instance is derived
# LANGUAGE StandaloneDeriving #
# OPTIONS_GHC -fno - warn - orphans #

module Reach.JSOrphans () where

import qualified Data.Text.Lazy as T
import Language.JavaScript.Parser
import Language.JavaScript.Parser.Lexer
import Reach.Texty
import Language.JavaScript.Parser.AST

instance Ord TokenPosn where
  compare (TokenPn x_a x_l x_c) (TokenPn y_a y_l y_c) =
    compare [x_a, x_l, x_c] [y_a, y_l, y_c]

deriving instance Read Token

viaJS :: (JSAnnot -> JSAST) -> Doc
viaJS mk = DText $ T.pack $ unwords . words $ T.unpack $ renderToText $ mk JSNoAnnot

instance Pretty JSArrayElement where
  pretty = \case
    JSArrayElement je -> pretty je
    JSArrayComma _ -> ","

instance Pretty JSAssignOp where
  pretty = \case
    JSAssign _ -> "="
    JSTimesAssign _ -> "*="
    JSDivideAssign _ -> "/="
    JSModAssign _ -> "%="
    JSPlusAssign _ -> "+="
    JSMinusAssign _ -> "-="
    JSLshAssign _ -> "<<="
    JSRshAssign _ -> ">>="
    JSUrshAssign _ -> ">>>="
    JSBwAndAssign _ -> "&="
    JSBwXorAssign _ -> "^="
    JSBwOrAssign _ -> "|="

instance Pretty JSBinOp where
  pretty = \case
    JSBinOpAnd _ -> "&&"
    JSBinOpBitAnd _ -> "&"
    JSBinOpBitOr _ -> "|"
    JSBinOpBitXor _ -> "^"
    JSBinOpDivide _ -> "/"
    JSBinOpEq _ -> "=="
    JSBinOpGe _ -> ">="
    JSBinOpGt _ -> ">"
    JSBinOpIn _ -> "in "
    JSBinOpInstanceOf _ -> "instanceof"
    JSBinOpLe _ -> "<="
    JSBinOpLsh _ -> "<<"
    JSBinOpLt _ -> "<"
    JSBinOpMinus _ -> "-"
    JSBinOpMod _ -> "%"
    JSBinOpNeq _ -> "!="
    JSBinOpOf _ -> "of "
    JSBinOpOr _ -> "||"
    JSBinOpPlus _ -> "+"
    JSBinOpRsh _ -> ">>"
    JSBinOpStrictEq _ -> "==="
    JSBinOpStrictNeq _ -> "!=="
    JSBinOpTimes _ -> "*"
    JSBinOpUrsh _ -> ">>>"

instance Pretty JSUnaryOp where
  pretty = \case
    JSUnaryOpDecr _ -> "--"
    JSUnaryOpDelete _ -> "delete"
    JSUnaryOpIncr _ -> "++"
    JSUnaryOpMinus _ -> "-"
    JSUnaryOpNot _ -> "!"
    JSUnaryOpPlus _ -> "+"
    JSUnaryOpTilde _ -> "~"
    JSUnaryOpTypeof _ -> "typeof"
    JSUnaryOpVoid _ -> "void"

instance Pretty a => Pretty (JSCommaList a) where
  pretty = \case
    JSLCons jcl _ a -> pretty jcl <> "," <+> pretty a
    JSLOne a -> pretty a
    JSLNil -> ""

instance Pretty JSIdent where
  pretty = \case
    JSIdentName _ s -> viaShow s
    JSIdentNone -> ""

instance Pretty JSArrowParameterList where
  pretty = \case
    JSUnparenthesizedArrowParameter ji -> pretty ji
    JSParenthesizedArrowParameterList _ jcl _ -> parens (pretty jcl)

instance Pretty JSBlock where
  pretty = \case JSBlock _ jss _ -> braces (hardline <> pretty jss <> hardline)

instance Pretty JSConciseBody where
  pretty = \case
    JSConciseExprBody je -> pretty je
    JSConciseFunBody jb -> pretty jb

instance Pretty JSPropertyName where
  pretty = \case
    JSPropertyIdent _ s -> pretty s
    JSPropertyString _ s -> pretty s
    JSPropertyNumber _ s -> pretty s
    JSPropertyComputed _ je _' -> pretty je

instance Pretty JSMethodDefinition where
  pretty = \case
    JSMethodDefinition jpn _ jcl _ jb -> pretty jpn <+> parens (pretty jcl) <+> pretty jb
    JSGeneratorMethodDefinition {} -> "<generator method>"
    JSPropertyAccessor {} -> "<property accessor>"

instance Pretty JSObjectProperty where
  pretty = \case
    JSPropertyNameandValue jpn _ (je:[]) -> pretty jpn <+> ":" <+> pretty je
    JSPropertyNameandValue jpn _ jes -> pretty jpn <+> ":" <+> pretty jes
    JSPropertyIdentRef _ s -> pretty s
    JSObjectMethod jmd -> pretty jmd
    JSObjectSpread _ je -> "..." <> pretty je

instance Pretty JSObjectPropertyList where
  pretty = \case
    JSCTLComma jcl _ -> pretty jcl
    JSCTLNone jcl -> pretty jcl

instance Pretty JSVarInitializer where
  pretty = \case
    JSVarInit _ je -> "=" <+> pretty je
    JSVarInitNone -> ""

instance Pretty JSExpression where
  pretty = \case
    JSIdentifier _ ('.':s') -> pretty $ "internal_" <> s'
    JSIdentifier _ s -> pretty s
    JSDecimal _ s -> pretty s
    JSLiteral _ ".null" -> "secret(null)"
    JSLiteral _ s -> pretty s
    JSHexInteger _ s -> pretty s
    JSOctal _ s -> pretty s
    JSStringLiteral _ s -> pretty s
    JSRegEx _ s -> pretty s
    JSArrayLiteral _ jaes _' -> brackets (hcat $ map pretty jaes)
    JSAssignExpression je jao je' -> pretty je <+> pretty jao <+> pretty je'
    JSAwaitExpression _ je -> "await" <+> pretty je
    JSCallExpression (je@JSArrowExpression {}) _ jcl _' -> parens (pretty je) <> parens (pretty jcl)
    JSCallExpression je _ jcl _' -> pretty je <> parens (pretty jcl)
    JSExpressionBinary je jbo je' -> pretty je <+> pretty jbo <+> pretty je'
    JSExpressionParen _ je _' -> parens (pretty je)
    JSExpressionTernary je _ je' _' je2 -> pretty je <+> "?" <+> pretty je' <+> ":" <+> pretty je2
    JSArrowExpression japl _ jcb -> pretty japl <+> "=>" <+> pretty jcb
    JSFunctionExpression _ ji _' jcl _ jb -> "function" <+> pretty ji <+> parens (pretty jcl) <+> pretty jb
    JSMemberDot je _ je' -> pretty je <> "." <> pretty je'
    JSMemberExpression je _ jcl _' -> pretty je <> parens (pretty jcl)
    JSSpreadExpression _ je -> "..." <> pretty je
    JSMemberSquare je _ je' _' -> pretty je <> brackets (pretty je')
    JSNewExpression _ je -> "new" <+> pretty je
    JSObjectLiteral _ jctl _' -> braces (pretty jctl)
    JSUnaryExpression juo je -> pretty juo <+> pretty je
    JSVarInitExpression je jvi -> pretty je <+> pretty jvi
    ow -> viaJS $ JSAstExpression ow

instance Pretty [JSStatement] where
  pretty ss = do
    let ss' = map pretty ss
    concatWith (\ l r -> l <> hardline <> r) ss'

instance Pretty JSSwitchParts where
  pretty = \case
    JSCase _ je _' jss -> "case" <+> pretty je <> ":" <+> braces (pretty jss)
    JSDefault _ _' jss -> "default:" <+> pretty jss

instance Pretty [JSSwitchParts] where
  pretty ss = do
    let ss' = map pretty ss
    concatWith (\ l r -> l <> hardline <> r) ss'

instance Pretty JSTryCatch where
  pretty = \case
    JSCatch _ _' je _ jb -> "catch" <+> parens (pretty je) <+> pretty jb
    JSCatchIf {} -> "<catch if>"

instance Pretty JSStatement where
  pretty = (<> ";") . \case
    JSStatementBlock _ jss _' _ -> pretty jss
    JSBreak _ ji _ -> "break" <+> pretty ji
    JSLet _ jcl _ -> "let" <+> pretty jcl
    JSConstant _ jcl _ -> "const" <+> pretty jcl
    JSContinue _ ji _ -> "continue" <+> pretty ji
    JSFunction _ ji _' jcl _ jb _ -> "function" <+> pretty ji <+> parens (pretty jcl) <+> pretty jb
    JSIf _ _' je _ t -> "if" <+> pretty je <+> braces (pretty t)
    JSIfElse _ _' je _ a _ b -> "if" <+> pretty je <+> braces (pretty a) <+> "else" <+> braces (pretty b)
    JSExpressionStatement je _ -> pretty je
    JSAssignStatement je jao je' _ -> pretty je <+> pretty jao <+> pretty je'
    JSMethodCall je _ jcl _' _ -> pretty je <+> parens (pretty jcl)
    JSReturn _ (Just je) _ -> "return" <+> pretty je
    JSReturn _ _ _ -> "return"
    JSSwitch _ _' je _ _ jsps _ _ -> "switch" <+> parens (pretty je) <+> braces (pretty jsps)
    JSThrow _ je _ -> "throw" <+> pretty je
    JSTry _ jb jtcs _ -> "try" <+> pretty jb <+> pretty jtcs
    JSVariable _ jcl _ -> pretty jcl
    JSWhile _ _' je _ s -> "while" <+> parens (pretty je) <+> pretty s
    ow -> viaJS $ JSAstStatement ow
