{-# OPTIONS -fno-warn-orphans     #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Code printers. Can be used to produce both pretty and not
-- pretty output.
--
-- Special constructors and symbols in Haskell are encoded to
-- JavaScript appropriately.
module Fay.Compiler.Print where

import           Fay.Compiler.Prelude

import           Fay.Compiler.PrimOp
import           Fay.Types

import           Data.Aeson
import qualified Data.ByteString.Lazy.UTF8       as UTF8
import           Language.Haskell.Exts hiding (alt, name, op, sym)

--------------------------------------------------------------------------------
-- Printing

-- | Print the JS to a flat string.
printJSString :: Printable a => a -> String
printJSString :: a -> String
printJSString x :: a
x = PrintWriter -> String
pwOutputString (Printer -> PrintReader -> PrintWriter
execPrinter (a -> Printer
forall a. Printable a => a -> Printer
printJS a
x) PrintReader
defaultPrintReader)

-- | Print the JS to a pretty string.
printJSPretty :: Printable a => a -> String
printJSPretty :: a -> String
printJSPretty x :: a
x = PrintWriter -> String
pwOutputString (Printer -> PrintReader -> PrintWriter
execPrinter (a -> Printer
forall a. Printable a => a -> Printer
printJS a
x) PrintReader
defaultPrintReader{ prPretty :: Bool
prPretty = Bool
True })

-- | Encode String to JS-format lterals. Could use the
-- Text.JSON library.
toJsStringLit :: String -> String
toJsStringLit :: String -> String
toJsStringLit = ByteString -> String
UTF8.toString (ByteString -> String)
-> (String -> ByteString) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a. ToJSON a => a -> ByteString
encode

-- | Print literals.
instance Printable JsLit where
  printJS :: JsLit -> Printer
printJS typ :: JsLit
typ = String -> Printer
write (String -> Printer) -> String -> Printer
forall a b. (a -> b) -> a -> b
$ case JsLit
typ of
      (JsChar char :: Char
char)    -> String -> String
toJsStringLit [Char
char]
      (JsStr str :: String
str)      -> String -> String
toJsStringLit String
str
      (JsInt int :: Int
int)      -> Int -> String
forall a. Show a => a -> String
show Int
int
      (JsFloating rat :: Double
rat) -> Double -> String
forall a. Show a => a -> String
show Double
rat
      (JsBool b :: Bool
b)       -> if Bool
b then "true" else "false"

-- | Print (and properly encode to JS) a qualified name.
instance Printable (QName l) where
  printJS :: QName l -> Printer
printJS qname :: QName l
qname =
    case QName l
qname of
      Qual _ (ModuleName _ "Fay$") name :: Name l
name -> "Fay$$" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Name l -> Printer
forall a. Printable a => a -> Printer
printJS Name l
name
      Qual _ moduleName :: ModuleName l
moduleName name :: Name l
name -> ModuleName l -> Printer
forall a. Printable a => a -> Printer
printJS ModuleName l
moduleName Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Name l -> Printer
forall l. Name l -> Printer
printProp Name l
name
      UnQual _ name :: Name l
name -> Name l -> Printer
forall a. Printable a => a -> Printer
printJS Name l
name
      Special _ con :: SpecialCon l
con -> SpecialCon l -> Printer
forall a. Printable a => a -> Printer
printJS SpecialCon l
con

-- | Prints pretty operators.
-- prPrettyOperator flag determines the way of accessing operators (e.g. `($)`) and
-- identifiers with apostrophes (e.g. `length'`). If prPrettyOperators is set true,
-- then these will be accessed with square brackets (e.g. Prelude["$"] or
-- Prelude["length'"]). Otherwise special characters will be escaped and accessed
-- with dot (e.g. Prelude.$36$ or Prelude.length$39$). Alphanumeric_ identifiers are
-- always accessed with dot operator (e.g. Prelude.length)
printProp :: Name l -> Printer
printProp :: Name l -> Printer
printProp name :: Name l
name = (PrintReader -> Bool) -> Printer -> Printer -> Printer
askIf PrintReader -> Bool
prPrettyOperators Printer
pretty Printer
ugly
  where pretty :: Printer
pretty = if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
allowedNameChars) String
nameString then Printer
dot else Printer
brackets
        ugly :: Printer
ugly = Printer
dot
        dot :: Printer
dot = "." Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Name l -> Printer
forall a. Printable a => a -> Printer
printJS Name l
name
        brackets :: Printer
brackets = "[" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> Printer
write (String -> String
toJsStringLit String
nameString) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "]"
        nameString :: String
nameString = case Name l
name of
          Ident _ s :: String
s  -> String
s
          Symbol _ s :: String
s -> String
s

-- | Print module name.
instance Printable (ModuleName l) where
  printJS :: ModuleName l -> Printer
printJS (ModuleName _ "Fay$") = "Fay$"
  printJS (ModuleName _ moduleName :: String
moduleName) = String -> Printer
write (String -> Printer) -> String -> Printer
forall a b. (a -> b) -> a -> b
$ String -> String
go String
moduleName
    where go :: String -> String
go ('.':xs :: String
xs) = '.' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
          go (x :: Char
x:xs :: String
xs) = String -> String
normalizeName [Char
x] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
go String
xs
          go [] = []

-- | Print (and properly encode) a name.
instance Printable (Name l) where
  printJS :: Name l -> Printer
printJS = String -> Printer
write (String -> Printer) -> (Name l -> String) -> Name l -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name l -> String
forall l. Name l -> String
encodeName


-- | Print special constructors (tuples, list, etc.)
instance Printable (SpecialCon l) where
  printJS :: SpecialCon l -> Printer
printJS specialCon :: SpecialCon l
specialCon =
    QName () -> Printer
forall a. Printable a => a -> Printer
printJS (QName () -> Printer) -> QName () -> Printer
forall a b. (a -> b) -> a -> b
$ () -> String -> QName ()
forall a. a -> String -> QName a
fayBuiltin () (String -> QName ()) -> String -> QName ()
forall a b. (a -> b) -> a -> b
$
      case SpecialCon l
specialCon of
        UnitCon _ -> "unit"
        Cons    _ -> "cons"
        _         -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "Special constructor not supported: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   SpecialCon () -> String
forall a. Show a => a -> String
show (SpecialCon l -> SpecialCon ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void SpecialCon l
specialCon)


-- | Print a list of statements.
printStmts :: [JsStmt] -> Printer
printStmts :: [JsStmt] -> Printer
printStmts = [Printer] -> Printer
forall a. Monoid a => [a] -> a
mconcat ([Printer] -> Printer)
-> ([JsStmt] -> [Printer]) -> [JsStmt] -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JsStmt -> Printer) -> [JsStmt] -> [Printer]
forall a b. (a -> b) -> [a] -> [b]
map JsStmt -> Printer
forall a. Printable a => a -> Printer
printJS

-- | Print a single statement.
instance Printable JsStmt where
  printJS :: JsStmt -> Printer
printJS (JsExpStmt e :: JsExp
e) =
    JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
e Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsBlock stmts :: [JsStmt]
stmts) =
    "{ " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> [JsStmt] -> Printer
printStmts [JsStmt]
stmts Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "}"
  printJS (JsMapVar name :: JsName
name expr :: JsExp
expr) =
    "var " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " : {[key: string]: any;} = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsVar name :: JsName
name expr :: JsExp
expr) =
    "var " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsUpdate name :: JsName
name expr :: JsExp
expr) =
    JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetProp name :: JsName
name prop :: JsName
prop expr :: JsExp
expr) =
    JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "." Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
prop Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetQName msrcloc :: Maybe SrcSpan
msrcloc name :: QName ()
name expr :: JsExp
expr) =
    Printer -> (SrcSpan -> Printer) -> Maybe SrcSpan -> Printer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Printer
forall a. Monoid a => a
mempty SrcSpan -> Printer
mapping Maybe SrcSpan
msrcloc Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> QName () -> Printer
forall a. Printable a => a -> Printer
printJS QName ()
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetConstructor name :: QName ()
name expr :: JsExp
expr) =
    QName () -> Printer
forall l. QName l -> Printer
printCons QName ()
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
    -- The unqualifiedness here is bad.
    QName () -> Printer
forall l. QName l -> Printer
printCons QName ()
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ".prototype.instance = \"" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> QName () -> Printer
forall l. QName l -> Printer
printConsUnQual QName ()
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "\";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetModule mp :: ModulePath
mp expr :: JsExp
expr) =
    ModulePath -> Printer
forall a. Printable a => a -> Printer
printJS ModulePath
mp Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetPropExtern name :: JsName
name prop :: JsName
prop expr :: JsExp
expr) =
    JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "['" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
prop Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "'] = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsIf expr :: JsExp
expr thens :: [JsStmt]
thens elses :: [JsStmt]
elses) =
    "if (" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ") {" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
    Printer -> Printer
indented ([JsStmt] -> Printer
printStmts [JsStmt]
thens) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
    "}" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
    (if [JsStmt] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JsStmt]
elses
      then Printer
forall a. Monoid a => a
mempty
      else " else {" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
           Printer -> Printer
indented ([JsStmt] -> Printer
printStmts [JsStmt]
elses) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
           "}") Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsEarlyReturn expr :: JsExp
expr) =
    "return " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsThrow expr :: JsExp
expr) =
    "throw " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsWhile cond :: JsExp
cond stmts :: [JsStmt]
stmts) =
    "while (" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
cond Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ") {" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
    Printer -> Printer
indented ([JsStmt] -> Printer
printStmts [JsStmt]
stmts) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
    "}" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS JsContinue = "continue;" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline

-- | Print a module path.
instance Printable ModulePath where
  printJS :: ModulePath -> Printer
printJS = String -> Printer
write (String -> Printer)
-> (ModulePath -> String) -> ModulePath -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." ([String] -> String)
-> (ModulePath -> [String]) -> ModulePath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModulePath -> [String]
unModulePath

-- | Print an expression.
instance Printable JsExp where
  printJS :: JsExp -> Printer
printJS (JsSeq es :: [JsExp]
es) = "(" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate "," ((JsExp -> Printer) -> [JsExp] -> [Printer]
forall a b. (a -> b) -> [a] -> [b]
map JsExp -> Printer
forall a. Printable a => a -> Printer
printJS [JsExp]
es) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ")"
  printJS (JsRawExp e :: String
e) = String -> Printer
write String
e
  printJS (JsName name :: JsName
name) = JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
name
  printJS (JsThrowExp expr :: JsExp
expr) = "(function(){ throw (" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "); })()"
  printJS JsNull = "null"
  printJS JsUndefined = "undefined"
  printJS (JsLit lit :: JsLit
lit) = JsLit -> Printer
forall a. Printable a => a -> Printer
printJS JsLit
lit
  printJS (JsParen expr :: JsExp
expr) = "(" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ")"
  printJS (JsList exprs :: [JsExp]
exprs) = "[" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate "," ((JsExp -> Printer) -> [JsExp] -> [Printer]
forall a b. (a -> b) -> [a] -> [b]
map JsExp -> Printer
forall a. Printable a => a -> Printer
printJS [JsExp]
exprs) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "]"
  printJS (JsNew name :: JsName
name args :: [JsExp]
args) = "new " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS (JsExp -> [JsExp] -> JsExp
JsApp (JsName -> JsExp
JsName JsName
name) [JsExp]
args)
  printJS (JsIndex i :: Int
i expr :: JsExp
expr) = "(" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ")[" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> Printer
write (Int -> String
forall a. Show a => a -> String
show Int
i) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "]"
  printJS (JsEq expr1 :: JsExp
expr1 expr2 :: JsExp
expr2) = JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr1 Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " === " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr2
  printJS (JsNeq expr1 :: JsExp
expr1 expr2 :: JsExp
expr2) = JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr1 Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " !== " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr2
  printJS (JsGetProp expr :: JsExp
expr prop :: JsName
prop) = JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "." Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
prop
  printJS (JsLookup expr1 :: JsExp
expr1 expr2 :: JsExp
expr2) = JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr1 Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "[" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr2 Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "]"
  printJS (JsUpdateProp name :: JsExp
name prop :: JsName
prop expr :: JsExp
expr) =
    "(" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "." Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
prop Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ")"
  printJS (JsInfix op :: String
op x :: JsExp
x y :: JsExp
y) = JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
x Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> Printer
write String
op Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
y
  printJS (JsGetPropExtern expr :: JsExp
expr prop :: String
prop) =
    JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "[" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> Printer
write (String -> String
toJsStringLit String
prop) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "]"
  printJS (JsUpdatePropExtern name :: JsExp
name prop :: JsName
prop expr :: JsExp
expr) =
    "(" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
name Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "['" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
prop Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "'] = " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ")"
  printJS (JsTernaryIf cond :: JsExp
cond conseq :: JsExp
conseq alt :: JsExp
alt) =
    JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
cond Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " ? " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
conseq Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " : " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
alt
  printJS (JsInstanceOf expr :: JsExp
expr classname :: JsName
classname) =
    JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> " instanceof " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
classname
  printJS (JsObj assoc :: [(String, JsExp)]
assoc) =
    "{" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate "," (((String, JsExp) -> Printer) -> [(String, JsExp)] -> [Printer]
forall a b. (a -> b) -> [a] -> [b]
map (String, JsExp) -> Printer
forall a. Printable a => (String, a) -> Printer
cons [(String, JsExp)]
assoc) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "}"
      where cons :: (String, a) -> Printer
cons (key :: String
key,value :: a
value) = String -> Printer
write (String -> String
toJsStringLit String
key) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ": " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> a -> Printer
forall a. Printable a => a -> Printer
printJS a
value
  printJS (JsLitObj assoc :: [(Name, JsExp)]
assoc) = "{" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate "," (((Name, JsExp) -> Printer) -> [(Name, JsExp)] -> [Printer]
forall a b. (a -> b) -> [a] -> [b]
map (Name, JsExp) -> Printer
forall a a. (Printable a, Printable a) => (a, a) -> Printer
cons [(Name, JsExp)]
assoc) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "}"
      where cons :: (a, a) -> Printer
cons (key :: a
key,value :: a
value) = "\"" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> a -> Printer
forall a. Printable a => a -> Printer
printJS a
key Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ": " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> a -> Printer
forall a. Printable a => a -> Printer
printJS a
value
  printJS (JsFun nm :: Maybe JsName
nm params :: [JsName]
params stmts :: [JsStmt]
stmts ret :: Maybe JsExp
ret) =
       "function"
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer -> (JsName -> Printer) -> Maybe JsName -> Printer
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Printer
forall a. Monoid a => a
mempty ((" " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>) (Printer -> Printer) -> (JsName -> Printer) -> JsName -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsName -> Printer
forall a. Printable a => a -> Printer
printJS (JsName -> Printer) -> (JsName -> JsName) -> JsName -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsName -> JsName
ident) Maybe JsName
nm
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "("
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate "," ((JsName -> Printer) -> [JsName] -> [Printer]
forall a b. (a -> b) -> [a] -> [b]
map JsName -> Printer
forall a. Printable a => a -> Printer
printJS [JsName]
params)
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "){" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer -> Printer
indented ([JsStmt] -> Printer
printStmts [JsStmt]
stmts Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>
                 case Maybe JsExp
ret of
                   Just ret' :: JsExp
ret' -> "return " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
ret' Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ";" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
                   Nothing   -> Printer
forall a. Monoid a => a
mempty)
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "}"
  printJS (JsApp op :: JsExp
op args :: [JsExp]
args) =
    JsExp -> Printer
forall a. Printable a => a -> Printer
printJS (case JsExp
op of JsFun {} -> JsExp -> JsExp
JsParen JsExp
op; _ -> JsExp
op)
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "("
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate "," ((JsExp -> Printer) -> [JsExp] -> [Printer]
forall a b. (a -> b) -> [a] -> [b]
map JsExp -> Printer
forall a. Printable a => a -> Printer
printJS [JsExp]
args)
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> ")"
  printJS (JsNegApp args :: JsExp
args) = "(-(" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
args Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "))"
  printJS (JsAnd a :: JsExp
a b :: JsExp
b) = JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
a Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "&&" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
b
  printJS (JsOr a :: JsExp
a b :: JsExp
b) = JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
a Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "||" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
b

-- | Unqualify a JsName.
ident :: JsName -> JsName
ident :: JsName -> JsName
ident n :: JsName
n = case JsName
n of
  JsConstructor (Qual _ _ s :: Name
s) -> QName () -> JsName
JsNameVar (QName () -> JsName) -> QName () -> JsName
forall a b. (a -> b) -> a -> b
$ () -> Name -> QName ()
forall l. l -> Name l -> QName l
UnQual () Name
s
  a :: JsName
a                          -> JsName
a

-- | Print one of the kinds of names.
instance Printable JsName where
  printJS :: JsName -> Printer
printJS name :: JsName
name =
    case JsName
name of
      JsNameVar qname :: QName ()
qname     -> QName () -> Printer
forall a. Printable a => a -> Printer
printJS QName ()
qname
      JsThis              -> "this"
      JsThunk             -> (PrintReader -> Bool) -> Printer -> Printer -> Printer
askIf PrintReader -> Bool
prPrettyThunks "$" "Fay$$$"
      JsForce             -> (PrintReader -> Bool) -> Printer -> Printer -> Printer
askIf PrintReader -> Bool
prPrettyThunks "_" "Fay$$_"
      JsApply             -> (PrintReader -> Bool) -> Printer -> Printer -> Printer
askIf PrintReader -> Bool
prPrettyThunks "__" "Fay$$__"
      JsParam i :: Integer
i           -> "$p" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> Printer
write (Integer -> String
forall a. Show a => a -> String
show Integer
i)
      JsTmp i :: Integer
i             -> "$tmp" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> Printer
write (Integer -> String
forall a. Show a => a -> String
show Integer
i)
      JsConstructor qname :: QName ()
qname -> QName () -> Printer
forall l. QName l -> Printer
printCons QName ()
qname
      JsBuiltIn qname :: Name
qname     -> "Fay$$" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Name -> Printer
forall a. Printable a => a -> Printer
printJS Name
qname
      JsParametrizedType  -> "type"
      JsModuleName (ModuleName _ m :: String
m) -> String -> Printer
write String
m

-- | Print a constructor name given a QName.
printCons :: QName l -> Printer
printCons :: QName l -> Printer
printCons (UnQual _ n :: Name l
n) = Name l -> Printer
forall l. Name l -> Printer
printConsName Name l
n
printCons (Qual _ (ModuleName _ m :: String
m) n :: Name l
n) = String -> Printer
write String
m Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> "." Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Name l -> Printer
forall l. Name l -> Printer
printConsName Name l
n
printCons Special {} = String -> Printer
forall a. HasCallStack => String -> a
error "qname2String Special"

-- | Print an unqualified name.
printConsUnQual :: QName l -> Printer
printConsUnQual :: QName l -> Printer
printConsUnQual (UnQual _ x :: Name l
x) = Name l -> Printer
forall a. Printable a => a -> Printer
printJS Name l
x
printConsUnQual (Qual _ _ n :: Name l
n) = Name l -> Printer
forall a. Printable a => a -> Printer
printJS Name l
n
printConsUnQual Special {} = String -> Printer
forall a. HasCallStack => String -> a
error "printConsUnqual Special"

-- | Print a constructor name given a Name. Helper for printCons.
printConsName :: Name l -> Printer
printConsName :: Name l -> Printer
printConsName = ("_" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<>) (Printer -> Printer) -> (Name l -> Printer) -> Name l -> Printer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name l -> Printer
forall a. Printable a => a -> Printer
printJS

--------------------------------------------------------------------------------
-- Name encoding

-- | Words reserved in haskell as well are not needed here:
-- case, class, do, else, if, import, in, let
reservedWords :: [String]
reservedWords :: [String]
reservedWords =
  ["abstract","boolean","break","byte","case","catch","char","class"
  ,"comment","const","continue","debugger","default","delete","do","double"
  ,"else","enum","export","extends","false","final","finally","float"
  ,"for","function","global","goto","if","implements","import","in"
  ,"instanceOf","instanceof","int","interface","label","long","native"
  ,"new","null","package","private","protected","public","return","short"
  ,"static","super","switch","synchronized","this","throw","throws"
  ,"transient","true","try","typeof","undefined","var","void","while"
  ,"window","with","yield"]
  -- These are not reserved, but they exist on thunks (inherited from Object) meaning they shouldn't be overridden.
  -- The problem only occurs if there is a module A.B and a constructor B in module A.
   [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["__defineGetter__", "__defineSetter__", "__lookupGetter__", "__lookupSetter__", "constructor", "force", "forced", "hasOwnProperty", "isPrototypeOf", "propertyIsEnumerable", "toLocaleString", "toString", "value", "valueOf"]

allowedNameChars :: String
allowedNameChars :: String
allowedNameChars = ['a'..'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ ['A'..'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ ['0'..'9'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ "_"

-- | Encode a Haskell name to JavaScript.
encodeName :: Name l -> String

-- | This is a hack for names generated in the Haskell AST. Should be
-- removed once it's no longer needed.
encodeName :: Name l -> String
encodeName n :: Name l
n = case Name l
n of
                 (Ident  _ idn :: String
idn) -> String -> String
encodeString String
idn
                 (Symbol _ sym :: String
sym) -> String -> String
encodeString String
sym
  where encodeString :: String -> String
encodeString ('$':'g':'e':'n':name :: String
name) = "$gen_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalizeName String
name
        encodeString name :: String
name
          | String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reservedWords = "$_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalizeName String
name
          | Bool
otherwise                 = String -> String
normalizeName String
name

-- | Normalize the given name to JavaScript-valid names.
normalizeName :: String -> String
normalizeName :: String -> String
normalizeName = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
encodeChar
  where
    encodeChar :: Char -> String
encodeChar c :: Char
c | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
allowedNameChars = [Char
c]
                 | Bool
otherwise                 = Char -> String
forall a. Enum a => a -> String
escapeChar Char
c
    escapeChar :: a -> String
escapeChar c :: a
c = "$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Enum a => a -> String
charId a
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ "$"
    charId :: a -> String
charId c :: a
c = Int -> String
forall a. Show a => a -> String
show (a -> Int
forall a. Enum a => a -> Int
fromEnum a
c)

-- | Intercalate monoids.
mintercalate :: String -> [Printer] -> Printer
mintercalate :: String -> [Printer] -> Printer
mintercalate str :: String
str xs :: [Printer]
xs = [Printer] -> Printer
forall a. Monoid a => [a] -> a
mconcat ([Printer] -> Printer) -> [Printer] -> Printer
forall a b. (a -> b) -> a -> b
$ Printer -> [Printer] -> [Printer]
forall a. a -> [a] -> [a]
intersperse (String -> Printer
write String
str) [Printer]
xs