content: {-# OPTIONS_GHC -Wall #-}
  {-# LANGUAGE OverloadedStrings #-}
  module Generate.JavaScript.Builder
    ( stmtToBuilder
    , exprToBuilder
    , Expr(..), LValue(..)
    , Stmt(..), Case(..)
    , InfixOp(..), PrefixOp(..)
    )
    where
  
  -- Based on the language-ecmascript package.
  -- https://hackage.haskell.org/package/language-ecmascript
  -- They did the hard work of reading the spec to figure out
  -- how all the types should fit together.
  
  import Prelude hiding (lines)
  import qualified Data.List as List
  import qualified Data.ByteString as BS
  import Data.ByteString.Builder as B
  import Data.Monoid ((<>))
  import qualified Generate.JavaScript.Name as Name
  import Generate.JavaScript.Name (Name)
  import qualified Json.Encode as Json
  
  
  
  -- EXPRESSIONS
  
  
  -- NOTE: I tried making this create a B.Builder directly.
  --
  -- The hope was that it'd allocate less and speed things up, but it seemed
  -- to be neutral for perf.
  --
  -- The downside is that Generate.JavaScript.Expression inspects the
  -- structure of Expr and Stmt on some occassions to try to strip out
  -- unnecessary closures. I think these closures are already avoided
  -- by other logic in code gen these days, but I am not 100% certain.
  --
  -- For this to be worth it, I think it would be necessary to avoid
  -- returning tuples when generating expressions.
  --
  data Expr
    = String Builder
    | Float Builder
    | Int Int
    | Bool Bool
    | Null
    | Json Json.Value
    | Array [Expr]
    | Object [(Name, Expr)]
    | Ref Name
    | Access Expr Name -- foo.bar
    | Index  Expr Expr -- foo[bar]
    | Prefix PrefixOp Expr
    | Infix InfixOp Expr Expr
    | If Expr Expr Expr
    | Assign LValue Expr
    | Call Expr [Expr]
    | Function (Maybe Name) [Name] [Stmt]
  
  
  data LValue
    = LRef Name
    | LDot Expr Name
    | LBracket Expr Expr
  
  
  
  -- STATEMENTS
  
  
  data Stmt
    = Block [Stmt]
    | EmptyStmt
    | ExprStmt Expr
    | IfStmt Expr Stmt Stmt
    | Switch Expr [Case]
    | While Expr Stmt
    | Break (Maybe Name)
    | Continue (Maybe Name)
    | Labelled Name Stmt
    | Try Stmt Name Stmt
    | Throw Expr
    | Return Expr
    | Var Name Expr
    | Vars [(Name, Expr)]
    | FunctionStmt Name [Name] [Stmt]
  
  
  data Case
    = Case Expr [Stmt]
    | Default [Stmt]
  
  
  
  -- OPERATORS
  
  
  data InfixOp
    = OpAdd -- +
    | OpSub -- -
    | OpMul -- *
    | OpDiv -- /
    | OpMod -- %
    | OpEq -- ===
    | OpNe -- !==
    | OpLt -- <
    | OpLe -- <=
    | OpGt -- >
    | OpGe -- >=
    | OpAnd -- &&
    | OpOr  -- ||
    | OpBitwiseAnd -- &
    | OpBitwiseXor -- ^
    | OpBitwiseOr  -- |
    | OpLShift     -- <<
    | OpSpRShift   -- >>
    | OpZfRShift   -- >>>
  
  
  data PrefixOp
    = PrefixNot        -- !
    | PrefixNegate     -- -
    | PrefixComplement -- ~
  
  
  
  -- ENCODE
  
  
  stmtToBuilder :: Stmt -> Builder
  stmtToBuilder stmts =
    fromStmt levelZero stmts
  
  
  exprToBuilder :: Expr -> Builder
  exprToBuilder expr =
    snd $ fromExpr levelZero Whatever expr
  
  
  
  -- INDENT LEVEL
  
  
  data Level =
    Level Builder Level
  
  
  levelZero :: Level
  levelZero =
    Level mempty (makeLevel 1 (BS.replicate 16 0x09 {-\t-}))
  
  
  makeLevel :: Int -> BS.ByteString -> Level
  makeLevel level oldTabs =
    let
      tabs =
        if level <= BS.length oldTabs
        then oldTabs
        else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-}
    in
    Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs)
  
  
  
  -- HELPERS
  
  
  commaSep :: [Builder] -> Builder
  commaSep builders =
    mconcat (List.intersperse ", " builders)
  
  
  commaNewlineSep :: Level -> [Builder] -> Builder
  commaNewlineSep (Level _ (Level deeperIndent _)) builders =
    mconcat (List.intersperse (",\n" <> deeperIndent) builders)
  
  
  
  -- STATEMENTS
  
  
  fromStmtBlock :: Level -> [Stmt] -> Builder
  fromStmtBlock level stmts =
    mconcat (map (fromStmt level) stmts)
  
  
  fromStmt :: Level -> Stmt -> Builder
  fromStmt level@(Level indent nextLevel) statement =
    case statement of
      Block stmts ->
        fromStmtBlock level stmts
  
      EmptyStmt ->
        mempty
  
      ExprStmt expr ->
        indent <> snd (fromExpr level Whatever expr) <> ";\n"
  
      IfStmt condition thenStmt elseStmt ->
        mconcat
          [ indent, "if (", snd (fromExpr level Whatever condition), ") {\n"
          , fromStmt nextLevel thenStmt
          , indent, "} else {\n"
          , fromStmt nextLevel elseStmt
          , indent, "}\n"
          ]
  
      Switch expr clauses ->
        mconcat
          [ indent, "switch (", snd (fromExpr level Whatever expr), ") {\n"
          , mconcat (map (fromClause nextLevel) clauses)
          , indent, "}\n"
          ]
  
      While expr stmt ->
        mconcat
          [ indent, "while (", snd (fromExpr level Whatever expr), ") {\n"
          , fromStmt nextLevel stmt
          , indent, "}\n"
          ]
  
      Break Nothing ->
        indent <> "break;\n"
  
      Break (Just label) ->
        indent <> "break " <> Name.toBuilder label <> ";\n"
  
      Continue Nothing ->
        indent <> "continue;\n"
  
      Continue (Just label) ->
        indent <> "continue " <> Name.toBuilder label <> ";\n"
  
      Labelled label stmt ->
        mconcat
          [ indent, Name.toBuilder label, ":\n"
          , fromStmt level stmt
          ]
  
      Try tryStmt errorName catchStmt ->
        mconcat
          [ indent, "try {\n"
          , fromStmt nextLevel tryStmt
          , indent, "} catch (", Name.toBuilder errorName, ") {\n"
          , fromStmt nextLevel catchStmt
          , indent, "}\n"
          ]
  
      Throw expr ->
        indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";"
  
      Return expr ->
        indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n"
  
      Var name expr ->
        indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n"
  
      Vars [] ->
        mempty
  
      Vars vars ->
        indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n"
  
      FunctionStmt name args stmts ->
        indent <> "function " <> Name.toBuilder name <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
        <>
            fromStmtBlock nextLevel stmts
        <>
        indent <> "}\n"
  
  
  
  -- SWITCH CLAUSES
  
  
  fromClause :: Level -> Case -> Builder
  fromClause level@(Level indent nextLevel) clause =
    case clause of
      Case expr stmts ->
        indent <> "case " <> snd (fromExpr level Whatever expr) <> ":\n"
        <> fromStmtBlock nextLevel stmts
  
      Default stmts ->
        indent <> "default:\n"
        <> fromStmtBlock nextLevel stmts
  
  
  
  -- VAR DECLS
  
  
  varToBuilder :: Level -> (Name, Expr) -> Builder
  varToBuilder level (name, expr) =
    Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr)
  
  
  
  -- EXPRESSIONS
  
  
  data Lines = One | Many deriving (Eq)
  
  
  merge :: Lines -> Lines -> Lines
  merge a b =
    if a == Many || b == Many then Many else One
  
  
  linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b])
  linesMap func xs =
    let
      pairs = map func xs
    in
    ( any ((==) Many . fst) pairs
    , map snd pairs
    )
  
  
  data Grouping = Atomic | Whatever
  
  
  parensFor :: Grouping -> Builder -> Builder
  parensFor grouping builder =
    case grouping of
      Atomic ->
        "(" <> builder <> ")"
  
      Whatever ->
        builder
  
  
  fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder)
  fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression =
    case expression of
      String string ->
        ( One, "'" <> string <> "'" )
  
      Float float ->
        ( One, float )
  
      Int n ->
        ( One, B.intDec n )
  
      Bool bool ->
        ( One, if bool then "true" else "false" )
  
      Null ->
        ( One, "null" )
  
      Json json ->
        ( One, Json.encodeUgly json )
  
      Array exprs ->
        (,) Many $
          let
            (anyMany, builders) = linesMap (fromExpr level Whatever) exprs
          in
          if anyMany then
            "[\n"
            <> deeperIndent
            <> commaNewlineSep level builders
            <> "\n" <> indent <> "]"
          else
            "[" <> commaSep builders <> "]"
  
      Object fields ->
        (,) Many $
          let
            (anyMany, builders) = linesMap (fromField nextLevel) fields
          in
          if anyMany then
            "{\n"
            <> deeperIndent
            <> commaNewlineSep level builders
            <> "\n" <> indent <> "}"
          else
            "{" <> commaSep builders <> "}"
  
      Ref name ->
        ( One, Name.toBuilder name )
  
      Access expr field ->
        makeDot level expr field
  
      Index expr bracketedExpr ->
        makeBracketed level expr bracketedExpr
  
      Prefix op expr ->
        let
          (lines, builder) = fromExpr level Atomic expr
        in
        ( lines
        , parensFor grouping (fromPrefix op <> builder)
        )
  
      Infix op leftExpr rightExpr ->
        let
          (leftLines , left ) = fromExpr level Atomic leftExpr
          (rightLines, right) = fromExpr level Atomic rightExpr
        in
        ( merge leftLines rightLines
        , parensFor grouping (left <> fromInfix op <> right)
        )
  
      If condExpr thenExpr elseExpr ->
        let
          condB = snd (fromExpr level Atomic condExpr)
          thenB = snd (fromExpr level Atomic thenExpr)
          elseB = snd (fromExpr level Atomic elseExpr)
        in
        ( Many
        , parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB)
        )
  
      Assign lValue expr ->
        let
          (leftLines , left ) = fromLValue level lValue
          (rightLines, right) = fromExpr level Whatever expr
        in
        ( merge leftLines rightLines
        , parensFor grouping (left <> " = " <> right)
        )
  
      Call function args ->
        (,) Many $
          let
            (_      , funcB) = fromExpr level Atomic function
            (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args
          in
          if anyMany then
            funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")"
          else
            funcB <> "(" <> commaSep argsB <> ")"
  
      Function maybeName args stmts ->
        (,) Many $
          "function " <> maybe mempty Name.toBuilder maybeName <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n"
          <>
              fromStmtBlock nextLevel stmts
          <>
          indent <> "}"
  
  
  
  -- FIELDS
  
  
  fromField :: Level -> (Name, Expr) -> (Lines, Builder)
  fromField level (field, expr) =
    let
      (lines, builder) = fromExpr level Whatever expr
    in
    ( lines
    , Name.toBuilder field <> ": " <> builder
    )
  
  
  
  -- VALUES
  
  
  fromLValue :: Level -> LValue -> (Lines, Builder)
  fromLValue level lValue =
    case lValue of
      LRef name ->
        (One, Name.toBuilder name)
  
      LDot expr field ->
        makeDot level expr field
  
      LBracket expr bracketedExpr ->
        makeBracketed level expr bracketedExpr
  
  
  makeDot :: Level -> Expr -> Name -> (Lines, Builder)
  makeDot level expr field =
    let
      (lines, builder) = fromExpr level Atomic expr
    in
    (lines, builder <> "." <> Name.toBuilder field)
  
  
  makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder)
  makeBracketed level expr bracketedExpr =
    let
      (lines         , builder         ) = fromExpr level Atomic expr
      (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr
    in
    ( merge lines bracketedLines
    , builder <> "[" <> bracketedBuilder <> "]"
    )
  
  
  
  -- OPERATORS
  
  
  fromPrefix :: PrefixOp -> Builder
  fromPrefix op =
    case op of
      PrefixNot        -> "!"
      PrefixNegate     -> "-"
      PrefixComplement -> "~"
  
  
  fromInfix :: InfixOp -> Builder
  fromInfix op =
    case op of
      OpAdd        -> " + "
      OpSub        -> " - "
      OpMul        -> " * "
      OpDiv        -> " / "
      OpMod        -> " % "
      OpEq         -> " === "
      OpNe         -> " !== "
      OpLt         -> " < "
      OpLe         -> " <= "
      OpGt         -> " > "
      OpGe         -> " >= "
      OpAnd        -> " && "
      OpOr         -> " || "
      OpBitwiseAnd -> " & "
      OpBitwiseXor -> " ^ "
      OpBitwiseOr  -> " | "
      OpLShift     -> " << "
      OpSpRShift   -> " >> "
      OpZfRShift   -> " >>> "
  