content: {-# 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 x = pwOutputString (execPrinter (printJS x) defaultPrintReader)
  
  -- | Print the JS to a pretty string.
  printJSPretty :: Printable a => a -> String
  printJSPretty x = pwOutputString (execPrinter (printJS x) defaultPrintReader{ prPretty = True })
  
  -- | Encode String to JS-format lterals. Could use the
  -- Text.JSON library.
  toJsStringLit :: String -> String
  toJsStringLit = UTF8.toString . encode
  
  -- | Print literals.
  instance Printable JsLit where
    printJS typ = write $ case typ of
        (JsChar char)    -> toJsStringLit [char]
        (JsStr str)      -> toJsStringLit str
        (JsInt int)      -> show int
        (JsFloating rat) -> show rat
        (JsBool b)       -> if b then "true" else "false"
  
  -- | Print (and properly encode to JS) a qualified name.
  instance Printable (QName l) where
    printJS qname =
      case qname of
        Qual _ (ModuleName _ "Fay$") name -> "Fay$$" <> printJS name
        Qual _ moduleName name -> printJS moduleName <> printProp name
        UnQual _ name -> printJS name
        Special _ con -> printJS 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 = askIf prPrettyOperators pretty ugly
    where pretty = if all (`elem` allowedNameChars) nameString then dot else brackets
          ugly = dot
          dot = "." <> printJS name
          brackets = "[" <> write (toJsStringLit nameString) <> "]"
          nameString = case name of
            Ident _ s  -> s
            Symbol _ s -> s
  
  -- | Print module name.
  instance Printable (ModuleName l) where
    printJS (ModuleName _ "Fay$") = "Fay$"
    printJS (ModuleName _ moduleName) = write $ go moduleName
      where go ('.':xs) = '.' : go xs
            go (x:xs) = normalizeName [x] ++ go xs
            go [] = []
  
  -- | Print (and properly encode) a name.
  instance Printable (Name l) where
    printJS = write . encodeName
  
  
  -- | Print special constructors (tuples, list, etc.)
  instance Printable (SpecialCon l) where
    printJS specialCon =
      printJS $ fayBuiltin () $
        case specialCon of
          UnitCon _ -> "unit"
          Cons    _ -> "cons"
          _         -> error $ "Special constructor not supported: " ++
                     show (void specialCon)
  
  
  -- | Print a list of statements.
  printStmts :: [JsStmt] -> Printer
  printStmts = mconcat . map printJS
  
  -- | Print a single statement.
  instance Printable JsStmt where
    printJS (JsExpStmt e) =
      printJS e <> ";" <> newline
    printJS (JsBlock stmts) =
      "{ " <> printStmts stmts <> "}"
    printJS (JsMapVar name expr) =
      "var " <> printJS name <> " : {[key: string]: any;} = " <> printJS expr <> ";" <> newline
    printJS (JsVar name expr) =
      "var " <> printJS name <> " = " <> printJS expr <> ";" <> newline
    printJS (JsUpdate name expr) =
      printJS name <> " = " <> printJS expr <> ";" <> newline
    printJS (JsSetProp name prop expr) =
      printJS name <> "." <> printJS prop <> " = " <> printJS expr <> ";" <> newline
    printJS (JsSetQName msrcloc name expr) =
      maybe mempty mapping msrcloc <> printJS name <> " = " <> printJS expr <> ";" <> newline
    printJS (JsSetConstructor name expr) =
      printCons name <> " = " <> printJS expr <> ";" <> newline <>
      -- The unqualifiedness here is bad.
      printCons name <> ".prototype.instance = \"" <> printConsUnQual name <> "\";" <> newline
    printJS (JsSetModule mp expr) =
      printJS mp <> " = " <> printJS expr <> ";" <> newline
    printJS (JsSetPropExtern name prop expr) =
      printJS name <> "['" <> printJS prop <> "'] = " <> printJS expr <> ";" <> newline
    printJS (JsIf expr thens elses) =
      "if (" <> printJS expr <> ") {" <> newline <>
      indented (printStmts thens) <>
      "}" <>
      (if null elses
        then mempty
        else " else {" <> newline <>
             indented (printStmts elses) <>
             "}") <> newline
    printJS (JsEarlyReturn expr) =
      "return " <> printJS expr <> ";" <> newline
    printJS (JsThrow expr) =
      "throw " <> printJS expr <> ";" <> newline
    printJS (JsWhile cond stmts) =
      "while (" <> printJS cond <> ") {" <> newline <>
      indented (printStmts stmts) <>
      "}" <> newline
    printJS JsContinue = "continue;" <> newline
  
  -- | Print a module path.
  instance Printable ModulePath where
    printJS = write . intercalate "." . unModulePath
  
  -- | Print an expression.
  instance Printable JsExp where
    printJS (JsSeq es) = "(" <> mintercalate "," (map printJS es) <> ")"
    printJS (JsRawExp e) = write e
    printJS (JsName name) = printJS name
    printJS (JsThrowExp expr) = "(function(){ throw (" <> printJS expr <> "); })()"
    printJS JsNull = "null"
    printJS JsUndefined = "undefined"
    printJS (JsLit lit) = printJS lit
    printJS (JsParen expr) = "(" <> printJS expr <> ")"
    printJS (JsList exprs) = "[" <> mintercalate "," (map printJS exprs) <> "]"
    printJS (JsNew name args) = "new " <> printJS (JsApp (JsName name) args)
    printJS (JsIndex i expr) = "(" <> printJS expr <> ")[" <> write (show i) <> "]"
    printJS (JsEq expr1 expr2) = printJS expr1 <> " === " <> printJS expr2
    printJS (JsNeq expr1 expr2) = printJS expr1 <> " !== " <> printJS expr2
    printJS (JsGetProp expr prop) = printJS expr <> "." <> printJS prop
    printJS (JsLookup expr1 expr2) = printJS expr1 <> "[" <> printJS expr2 <> "]"
    printJS (JsUpdateProp name prop expr) =
      "(" <> printJS name <> "." <> printJS prop <> " = " <> printJS expr <> ")"
    printJS (JsInfix op x y) = printJS x <> " " <> write op <> " " <> printJS y
    printJS (JsGetPropExtern expr prop) =
      printJS expr <> "[" <> write (toJsStringLit prop) <> "]"
    printJS (JsUpdatePropExtern name prop expr) =
      "(" <> printJS name <> "['" <> printJS prop <> "'] = " <> printJS expr <> ")"
    printJS (JsTernaryIf cond conseq alt) =
      printJS cond <> " ? " <> printJS conseq <> " : " <> printJS alt
    printJS (JsInstanceOf expr classname) =
      printJS expr <> " instanceof " <> printJS classname
    printJS (JsObj assoc) =
      "{" <> mintercalate "," (map cons assoc) <> "}"
        where cons (key,value) = write (toJsStringLit key) <> ": " <> printJS value
    printJS (JsLitObj assoc) = "{" <> mintercalate "," (map cons assoc) <> "}"
        where cons (key,value) = "\"" <> printJS key <> ": " <> printJS value
    printJS (JsFun nm params stmts ret) =
         "function"
      <> maybe mempty ((" " <>) . printJS . ident) nm
      <> "("
      <> mintercalate "," (map printJS params)
      <> "){" <> newline
      <> indented (printStmts stmts <>
                   case ret of
                     Just ret' -> "return " <> printJS ret' <> ";" <> newline
                     Nothing   -> mempty)
      <> "}"
    printJS (JsApp op args) =
      printJS (case op of JsFun {} -> JsParen op; _ -> op)
      <> "("
      <> mintercalate "," (map printJS args)
      <> ")"
    printJS (JsNegApp args) = "(-(" <> printJS args <> "))"
    printJS (JsAnd a b) = printJS a <> "&&" <> printJS b
    printJS (JsOr a b) = printJS a <> "||" <> printJS b
  
  -- | Unqualify a JsName.
  ident :: JsName -> JsName
  ident n = case n of
    JsConstructor (Qual _ _ s) -> JsNameVar $ UnQual () s
    a                          -> a
  
  -- | Print one of the kinds of names.
  instance Printable JsName where
    printJS name =
      case name of
        JsNameVar qname     -> printJS qname
        JsThis              -> "this"
        JsThunk             -> askIf prPrettyThunks "$" "Fay$$$"
        JsForce             -> askIf prPrettyThunks "_" "Fay$$_"
        JsApply             -> askIf prPrettyThunks "__" "Fay$$__"
        JsParam i           -> "$p" <> write (show i)
        JsTmp i             -> "$tmp" <> write (show i)
        JsConstructor qname -> printCons qname
        JsBuiltIn qname     -> "Fay$$" <> printJS qname
        JsParametrizedType  -> "type"
        JsModuleName (ModuleName _ m) -> write m
  
  -- | Print a constructor name given a QName.
  printCons :: QName l -> Printer
  printCons (UnQual _ n) = printConsName n
  printCons (Qual _ (ModuleName _ m) n) = write m <> "." <> printConsName n
  printCons Special {} = error "qname2String Special"
  
  -- | Print an unqualified name.
  printConsUnQual :: QName l -> Printer
  printConsUnQual (UnQual _ x) = printJS x
  printConsUnQual (Qual _ _ n) = printJS n
  printConsUnQual Special {} = error "printConsUnqual Special"
  
  -- | Print a constructor name given a Name. Helper for printCons.
  printConsName :: Name l -> Printer
  printConsName = ("_" <>) . printJS
  
  --------------------------------------------------------------------------------
  -- Name encoding
  
  -- | Words reserved in haskell as well are not needed here:
  -- case, class, do, else, if, import, in, let
  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.
     ++ ["__defineGetter__", "__defineSetter__", "__lookupGetter__", "__lookupSetter__", "constructor", "force", "forced", "hasOwnProperty", "isPrototypeOf", "propertyIsEnumerable", "toLocaleString", "toString", "value", "valueOf"]
  
  allowedNameChars :: String
  allowedNameChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"
  
  -- | 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 n = case n of
                   (Ident  _ idn) -> encodeString idn
                   (Symbol _ sym) -> encodeString sym
    where encodeString ('$':'g':'e':'n':name) = "$gen_" ++ normalizeName name
          encodeString name
            | name `elem` reservedWords = "$_" ++ normalizeName name
            | otherwise                 = normalizeName name
  
  -- | Normalize the given name to JavaScript-valid names.
  normalizeName :: String -> String
  normalizeName = concatMap encodeChar
    where
      encodeChar c | c `elem` allowedNameChars = [c]
                   | otherwise                 = escapeChar c
      escapeChar c = "$" ++ charId c ++ "$"
      charId c = show (fromEnum c)
  
  -- | Intercalate monoids.
  mintercalate :: String -> [Printer] -> Printer
  mintercalate str xs = mconcat $ intersperse (write str) xs
  