{-# 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 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 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 JsLit
typ = String -> Printer
write (String -> Printer) -> String -> Printer
forall a b. (a -> b) -> a -> b
$ case JsLit
typ of
      (JsChar Char
char)    -> String -> String
toJsStringLit [Char
char]
      (JsStr String
str)      -> String -> String
toJsStringLit String
str
      (JsInt Int
int)      -> Int -> String
forall a. Show a => a -> String
show Int
int
      (JsFloating Double
rat) -> Double -> String
forall a. Show a => a -> String
show Double
rat
      (JsBool Bool
b)       -> if Bool
b then String
"true" else String
"false"

-- | Print (and properly encode to JS) a qualified name.
instance Printable (QName l) where
  printJS :: QName l -> Printer
printJS QName l
qname =
    case QName l
qname of
      Qual l
_ (ModuleName l
_ String
"Fay$") Name l
name -> Printer
"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 l
_ ModuleName l
moduleName 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 l
_ Name l
name -> Name l -> Printer
forall a. Printable a => a -> Printer
printJS Name l
name
      Special l
_ 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 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 -> 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 -> 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
<> Printer
"]"
        nameString :: String
nameString = case Name l
name of
          Ident l
_ String
s  -> String
s
          Symbol l
_ String
s -> String
s

-- | Print module name.
instance Printable (ModuleName l) where
  printJS :: ModuleName l -> Printer
printJS (ModuleName l
_ String
"Fay$") = Printer
"Fay$"
  printJS (ModuleName l
_ 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 (Char
'.':String
xs) = Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
          go (Char
x: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 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 l
_ -> String
"unit"
        Cons    l
_ -> String
"cons"
        SpecialCon l
_         -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"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 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsBlock [JsStmt]
stmts) =
    Printer
"{ " 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
<> Printer
"}"
  printJS (JsMapVar JsName
name JsExp
expr) =
    Printer
"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
" : {[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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsVar JsName
name JsExp
expr) =
    Printer
"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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsUpdate JsName
name 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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetProp JsName
name JsName
prop 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 -> 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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetQName Maybe SrcSpan
msrcloc QName ()
name 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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetConstructor QName ()
name 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 -> 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 -> 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
<> Printer
".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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetModule ModulePath
mp 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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsSetPropExtern JsName
name JsName
prop 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 -> 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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsIf JsExp
expr [JsStmt]
thens [JsStmt]
elses) =
    Printer
"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 -> 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 -> 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 Printer
" 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsEarlyReturn JsExp
expr) =
    Printer
"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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsThrow JsExp
expr) =
    Printer
"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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS (JsWhile JsExp
cond [JsStmt]
stmts) =
    Printer
"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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
  printJS JsStmt
JsContinue = Printer
"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] -> 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 [JsExp]
es) = Printer
"(" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate String
"," ((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
<> Printer
")"
  printJS (JsRawExp String
e) = String -> Printer
write String
e
  printJS (JsName JsName
name) = JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
name
  printJS (JsThrowExp JsExp
expr) = Printer
"(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
<> Printer
"); })()"
  printJS JsExp
JsNull = Printer
"null"
  printJS JsExp
JsUndefined = Printer
"undefined"
  printJS (JsLit JsLit
lit) = JsLit -> Printer
forall a. Printable a => a -> Printer
printJS JsLit
lit
  printJS (JsParen JsExp
expr) = Printer
"(" 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
")"
  printJS (JsList [JsExp]
exprs) = Printer
"[" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate String
"," ((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
<> Printer
"]"
  printJS (JsNew JsName
name [JsExp]
args) = Printer
"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 Int
i JsExp
expr) = Printer
"(" 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 -> 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
<> Printer
"]"
  printJS (JsEq JsExp
expr1 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr2
  printJS (JsNeq JsExp
expr1 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr2
  printJS (JsGetProp JsExp
expr 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
prop
  printJS (JsLookup JsExp
expr1 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 -> 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
<> Printer
"]"
  printJS (JsUpdateProp JsExp
name JsName
prop JsExp
expr) =
    Printer
"(" 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 -> 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 -> 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
")"
  printJS (JsInfix String
op JsExp
x 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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
y
  printJS (JsGetPropExtern JsExp
expr 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 -> 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
<> Printer
"]"
  printJS (JsUpdatePropExtern JsExp
name JsName
prop JsExp
expr) =
    Printer
"(" 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 -> 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 -> 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
")"
  printJS (JsTernaryIf JsExp
cond JsExp
conseq 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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
alt
  printJS (JsInstanceOf JsExp
expr JsName
classname) =
    JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
expr Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
" instanceof " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> JsName -> Printer
forall a. Printable a => a -> Printer
printJS JsName
classname
  printJS (JsObj [(String, JsExp)]
assoc) =
    Printer
"{" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate String
"," (((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
<> Printer
"}"
      where cons :: (String, a) -> Printer
cons (String
key,a
value) = String -> Printer
write (String -> String
toJsStringLit String
key) Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
": " Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> a -> Printer
forall a. Printable a => a -> Printer
printJS a
value
  printJS (JsLitObj [(Name, JsExp)]
assoc) = Printer
"{" Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate String
"," (((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
<> Printer
"}"
      where cons :: (a, a) -> Printer
cons (a
key,a
value) = Printer
"\"" 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> a -> Printer
forall a. Printable a => a -> Printer
printJS a
value
  printJS (JsFun Maybe JsName
nm [JsName]
params [JsStmt]
stmts Maybe JsExp
ret) =
       Printer
"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 -> 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate String
"," ((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 -> 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 JsExp
ret' -> Printer
"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 -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
newline
                   Maybe JsExp
Nothing   -> Printer
forall a. Monoid a => a
mempty)
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
"}"
  printJS (JsApp JsExp
op [JsExp]
args) =
    JsExp -> Printer
forall a. Printable a => a -> Printer
printJS (case JsExp
op of JsFun {} -> JsExp -> JsExp
JsParen JsExp
op; JsExp
_ -> JsExp
op)
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> Printer
"("
    Printer -> Printer -> Printer
forall a. Semigroup a => a -> a -> a
<> String -> [Printer] -> Printer
mintercalate String
"," ((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
<> Printer
")"
  printJS (JsNegApp JsExp
args) = Printer
"(-(" 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
<> Printer
"))"
  printJS (JsAnd JsExp
a 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 -> Printer
forall a. Semigroup a => a -> a -> a
<> JsExp -> Printer
forall a. Printable a => a -> Printer
printJS JsExp
b
  printJS (JsOr JsExp
a 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 -> 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 JsName
n = case JsName
n of
  JsConstructor (Qual ()
_ ModuleName ()
_ 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
  JsName
a                          -> JsName
a

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

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

-- | Print an unqualified name.
printConsUnQual :: QName l -> Printer
printConsUnQual :: QName l -> Printer
printConsUnQual (UnQual l
_ Name l
x) = Name l -> Printer
forall a. Printable a => a -> Printer
printJS Name l
x
printConsUnQual (Qual l
_ ModuleName l
_ 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 String
"printConsUnqual Special"

-- | Print a constructor name given a Name. Helper for printCons.
printConsName :: Name l -> Printer
printConsName :: Name l -> Printer
printConsName = (Printer
"_" 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 =
  [String
"abstract",String
"boolean",String
"break",String
"byte",String
"case",String
"catch",String
"char",String
"class"
  ,String
"comment",String
"const",String
"continue",String
"debugger",String
"default",String
"delete",String
"do",String
"double"
  ,String
"else",String
"enum",String
"export",String
"extends",String
"false",String
"final",String
"finally",String
"float"
  ,String
"for",String
"function",String
"global",String
"goto",String
"if",String
"implements",String
"import",String
"in"
  ,String
"instanceOf",String
"instanceof",String
"int",String
"interface",String
"label",String
"long",String
"native"
  ,String
"new",String
"null",String
"package",String
"private",String
"protected",String
"public",String
"return",String
"short"
  ,String
"static",String
"super",String
"switch",String
"synchronized",String
"this",String
"throw",String
"throws"
  ,String
"transient",String
"true",String
"try",String
"typeof",String
"undefined",String
"var",String
"void",String
"while"
  ,String
"window",String
"with",String
"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]
++ [String
"__defineGetter__", String
"__defineSetter__", String
"__lookupGetter__", String
"__lookupSetter__", String
"constructor", String
"force", String
"forced", String
"hasOwnProperty", String
"isPrototypeOf", String
"propertyIsEnumerable", String
"toLocaleString", String
"toString", String
"value", String
"valueOf"]

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

-- | 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 Name l
n = case Name l
n of
                 (Ident  l
_ String
idn) -> String -> String
encodeString String
idn
                 (Symbol l
_ String
sym) -> String -> String
encodeString String
sym
  where encodeString :: String -> String
encodeString (Char
'$':Char
'g':Char
'e':Char
'n':String
name) = String
"$gen_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
normalizeName String
name
        encodeString String
name
          | String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
reservedWords = String
"$_" 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 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 a
c = String
"$" 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]
++ String
"$"
    charId :: a -> String
charId 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 String
str [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