{-# LANGUAGE PatternGuards #-}

module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where

import Idris.AbsSyntax
import IRTS.Bytecode
import IRTS.Lang
import IRTS.Simplified
import IRTS.CodegenCommon
import Core.TT
import Paths_idris
import Util.System

import Control.Arrow
import Data.Char
import Data.List
import qualified Data.Map as Map
import System.IO
import System.Directory

idrNamespace :: String
idrNamespace = "__IDR__"
idrRTNamespace = "__IDRRT__"

data JSTarget = Node | JavaScript deriving Eq

codegenJavaScript
  :: JSTarget
  -> [(Name, SDecl)]
  -> FilePath
  -> OutputType
  -> IO ()
codegenJavaScript target definitions filename outputType = do
  let (header, runtime) = case target of
                               Node ->
                                 ("#!/usr/bin/env node\n", "-node")
                               JavaScript ->
                                 ("", "-browser")
  path <- getDataDir
  idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
  tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
  writeFile filename ( header
                   ++ idrRuntime
                   ++ tgtRuntime
                   ++ functions
                   ++ mainLoop)

  setPermissions filename (emptyPermissions { readable   = True
                                            , executable = target == Node
                                            , writable   = True
                                            })
  where
    def = map (first translateNamespace) definitions
 
    functions = concatMap translateDeclaration def

    mainLoop :: String
    mainLoop = intercalate "\n" [ "\nfunction main() {"
                                , createTailcall "__IDR__runMain0()"
                                , "}\n\nmain();\n"
                                ]

translateIdentifier :: String -> String
translateIdentifier =
  replaceReserved . concatMap replaceBadChars
  where replaceBadChars :: Char -> String
        replaceBadChars c
          | ' ' <- c = "_"
          | '_' <- c = "__"
          | isDigit c = "_" ++ [c] ++ "_"
          | not (isLetter c && isAscii c) = '_' : show (ord c)
          | otherwise = [c]
        replaceReserved s
          | s `elem` reserved = '_' : s
          | otherwise         = s
        reserved = [ "break"
                   , "case"
                   , "catch"
                   , "continue"
                   , "debugger"
                   , "default"
                   , "delete"
                   , "do"
                   , "else"
                   , "finally"
                   , "for"
                   , "function"
                   , "if"
                   , "in"
                   , "instanceof"
                   , "new"
                   , "return"
                   , "switch"
                   , "this"
                   , "throw"
                   , "try"
                   , "typeof"
                   , "var"
                   , "void"
                   , "while"
                   , "with"
                   
                   , "class"
                   , "enum"
                   , "export"
                   , "extends"
                   , "import"
                   , "super"
                   
                   , "implements"
                   , "interface"
                   , "let"
                   , "package"
                   , "private"
                   , "protected"
                   , "public"
                   , "static"
                   , "yield"
                   ]

translateNamespace :: Name -> String
translateNamespace (UN _)    = idrNamespace
translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
translateNamespace (MN _ _)  = idrNamespace

translateName :: Name -> String
translateName (UN name)   = translateIdentifier name
translateName (NS name _) = translateName name
translateName (MN i name) = translateIdentifier name ++ show i

translateConstant :: Const -> String
translateConstant (I i)   = show i
translateConstant (BI i)  = idrRTNamespace ++ "bigInt('" ++ show i ++ "')"
translateConstant (Fl f)  = show f
translateConstant (Ch c)  = show c
translateConstant (Str s) = show s
translateConstant (AType (ATInt ITNative)) = idrRTNamespace ++ "Int"
translateConstant StrType = idrRTNamespace ++ "String"
translateConstant (AType (ATInt ITBig)) = idrRTNamespace ++ "Integer"
translateConstant (AType ATFloat)  = idrRTNamespace ++ "Float"
translateConstant (AType (ATInt ITChar)) = idrRTNamespace ++ "Char"
translateConstant PtrType = idrRTNamespace ++ "Ptr"
translateConstant Forgot  = idrRTNamespace ++ "Forgot"
translateConstant c       =
  "(function(){throw 'Unimplemented Const: " ++ show c ++ "';})()"

translateParameterlist =
  map translateParameter
  where translateParameter (MN i name) = translateIdentifier name ++ show i
        translateParameter (UN name) = translateIdentifier name

translateDeclaration :: (String, SDecl) -> String
translateDeclaration (path, SFun name params stackSize body) =
     "var " ++ path ++ translateName name
  ++ " = function("
  ++ intercalate "," p
  ++ "){\n"
  ++ concatMap assignVar (zip [0..] p)
  ++ concatMap allocVar [numP..(numP+stackSize-1)]
  ++ "return "
  ++ translateExpression body
  ++ ";\n};\n"
  where 
    numP :: Int
    numP = length params

    allocVar :: Int -> String
    allocVar n = "var __var_" ++ show n ++ ";\n"

    assignVar :: (Int, String) -> String
    assignVar (n, s) = "var __var_" ++ show n ++ " = " ++ s ++ ";\n"

    p :: [String]
    p = translateParameterlist params

translateVariableName :: LVar -> String
translateVariableName (Loc i) =
  "__var_" ++ show i

translateExpression :: SExp -> String
translateExpression (SLet name value body) =
     "(function("
  ++ translateVariableName name
  ++ "){\nreturn "
  ++ translateExpression body
  ++ ";\n})("
  ++ translateExpression value
  ++ ")"

translateExpression (SConst cst) =
  translateConstant cst

translateExpression (SV var) =
  translateVariableName var

translateExpression (SApp False name vars) =
  createTailcall $ translateFunctionCall name vars

translateExpression (SApp True name vars) =
     "new " ++ idrRTNamespace ++ "Tailcall("
  ++ "function(){\n"
  ++ "return " ++ translateFunctionCall name vars
  ++ ";\n})"

translateExpression (SOp op vars)
  | LNoOp <- op = translateVariableName (last vars)

  | (LZExt _ ITBig) <- op =
      idrRTNamespace ++ "bigInt(" ++ translateVariableName (last vars) ++ ")"

  | (LPlus (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs  ++ ")"
  | (LMinus (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
  | (LTimes (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
  | (LSDiv (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
  | (LSRem (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
  | (LEq (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
  | (LLt (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
  | (LLe (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
  | (LGt (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
  | (LGe (ATInt ITBig)) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"

  | (LPlus ATFloat)  <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
  | (LMinus ATFloat) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
  | (LTimes ATFloat) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
  | (LSDiv ATFloat)  <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
  | (LEq ATFloat) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
  | (LLt ATFloat) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
  | (LLe ATFloat) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
  | (LGt ATFloat) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
  | (LGe ATFloat) <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs

  | (LPlus _)   <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
  | (LMinus _)  <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
  | (LTimes _)  <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
  | (LSDiv _)   <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
  | (LSRem _)   <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
  | (LEq _)     <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
  | (LLt _)     <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
  | (LLe _)     <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
  | (LGt _)     <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
  | (LGe _)     <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
  | (LAnd _)    <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
  | (LOr _)     <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
  | (LXOr _)    <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
  | (LSHL _)    <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
  | (LASHR _)   <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
  | (LCompl _)  <- op
  , (arg:_)     <- vars = '~' : translateVariableName arg

  | LStrConcat  <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
  | LStrEq      <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
  | LStrLt      <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
  | LStrLen     <- op
  , (arg:_)     <- vars = translateVariableName arg ++ ".length"

  | (LStrInt ITNative) <- op
  , (arg:_)     <- vars = "parseInt(" ++ translateVariableName arg ++ ")"
  | (LIntStr ITNative) <- op
  , (arg:_)     <- vars = "String(" ++ translateVariableName arg ++ ")"
  | (LSExt ITNative ITBig) <- op
  , (arg:_)     <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")"
  | (LTrunc ITBig ITNative) <- op
  , (arg:_)     <- vars = translateVariableName arg ++ ".valueOf()"
  | (LIntStr ITBig) <- op
  , (arg:_)     <- vars = translateVariableName arg ++ ".toString()"
  | (LStrInt ITBig) <- op
  , (arg:_)     <- vars = idrRTNamespace ++ "bigInt(" ++ translateVariableName arg ++ ")"
  | LFloatStr   <- op
  , (arg:_)     <- vars = "String(" ++ translateVariableName arg ++ ")"
  | LStrFloat   <- op
  , (arg:_)     <- vars = "parseFloat(" ++ translateVariableName arg ++ ")"
  | (LIntFloat ITNative) <- op
  , (arg:_)     <- vars = translateVariableName arg
  | (LFloatInt ITNative) <- op
  , (arg:_)     <- vars = translateVariableName arg
  | (LChInt ITNative) <- op
  , (arg:_)     <- vars = translateVariableName arg ++ ".charCodeAt(0)"
  | (LIntCh ITNative) <- op
  , (arg:_)     <- vars =
    "String.fromCharCode(" ++ translateVariableName arg ++ ")"

  | LFExp       <- op
  , (arg:_)     <- vars = "Math.exp(" ++ translateVariableName arg ++ ")"
  | LFLog       <- op
  , (arg:_)     <- vars = "Math.log(" ++ translateVariableName arg ++ ")"
  | LFSin       <- op
  , (arg:_)     <- vars = "Math.sin(" ++ translateVariableName arg ++ ")"
  | LFCos       <- op
  , (arg:_)     <- vars = "Math.cos(" ++ translateVariableName arg ++ ")"
  | LFTan       <- op
  , (arg:_)     <- vars = "Math.tan(" ++ translateVariableName arg ++ ")"
  | LFASin      <- op
  , (arg:_)     <- vars = "Math.asin(" ++ translateVariableName arg ++ ")"
  | LFACos      <- op
  , (arg:_)     <- vars = "Math.acos(" ++ translateVariableName arg ++ ")"
  | LFATan      <- op
  , (arg:_)     <- vars = "Math.atan(" ++ translateVariableName arg ++ ")"
  | LFSqrt      <- op
  , (arg:_)     <- vars = "Math.sqrt(" ++ translateVariableName arg ++ ")"
  | LFFloor     <- op
  , (arg:_)     <- vars = "Math.floor(" ++ translateVariableName arg ++ ")"
  | LFCeil      <- op
  , (arg:_)     <- vars = "Math.ceil(" ++ translateVariableName arg ++ ")"

  | LStrCons    <- op
  , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
  | LStrHead    <- op
  , (arg:_)     <- vars = translateVariableName arg ++ "[0]"
  | LStrRev     <- op
  , (arg:_)     <- vars = let v = translateVariableName arg in
                              v ++ ".split('').reverse().join('')"
  | LStrIndex   <- op
  , (lhs:rhs:_) <- vars = let l = translateVariableName lhs
                              r = translateVariableName rhs in
                              l ++ "[" ++ r ++ "]"
  | LStrTail    <- op
  , (arg:_)     <- vars = let v = translateVariableName arg in
                              v ++ ".substr(1," ++ v ++ ".length-1)"
  where
    translateBinaryOp :: String -> LVar -> LVar -> String
    translateBinaryOp f lhs rhs =
         translateVariableName lhs
      ++ f
      ++ translateVariableName rhs

translateExpression (SError msg) =
  "(function(){throw \'" ++ msg ++ "\';})()"

translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
  idrRTNamespace ++ "print(" ++ translateVariableName var ++ ")"

translateExpression (SForeign _ _ fun args)
  | "[]=" `isSuffixOf` fun
  , (obj:idx:val:[]) <- args =
    concat [object obj, index idx, assign val]

  | "[]" `isSuffixOf` fun
  , (obj:idx:[]) <- args =
    object obj ++ index idx

  | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
  , (obj:val:[]) <- args =
    concat [object obj, '[' : name ++ "]", assign val]

  | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
  , (obj:[]) <- args =
    object obj ++ '[' : name ++ "]"

  | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
  , (obj:val:[]) <- args =
    concat [object obj, field, assign val]

  | "." `isPrefixOf` fun
  , (obj:[]) <- args =
    object obj ++ field

  | "." `isPrefixOf` fun
  , (obj:[(FUnit, _)]) <- args =
    concat [object obj, method, "()"]
    
  | "." `isPrefixOf` fun
  , (obj:as) <- args =
    concat [object obj, method, arguments as]

  | "[]=" `isSuffixOf` fun
  , (idx:val:[]) <- args =
    concat [array, index idx, assign val]

  | "[]" `isSuffixOf` fun
  , (idx:[]) <- args =
    array ++ index idx

  | otherwise = fun ++ arguments args
  where
    name         = filter (`notElem` "[]=") fun
    method       = name
    field        = name
    array        = name
    object o     = translateVariableName (snd o)
    index  i     = "[" ++ translateVariableName (snd i) ++ "]"
    assign v     = '=' : generateWrapper v
    arguments as =
      '(' : intercalate "," (map generateWrapper as) ++ ")"

    generateWrapper (ffunc, name)
      | FFunction   <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
      | FFunctionIO <- ffunc = idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"

    generateWrapper (_, name) =
      translateVariableName name

translateExpression (SChkCase var cases) =
     "(function(e){\n"
  ++ intercalate " else " (map (translateCase "e") cases)
  ++ "\n})("
  ++ translateVariableName var
  ++ ")"

translateExpression (SCase var cases) = 
     "(function(e){\n"
  ++ intercalate " else " (map (translateCase "e") cases)
  ++ "\n})("
  ++ translateVariableName var
  ++ ")"

translateExpression (SCon i name vars) =
  concat [ "new " ++ idrRTNamespace ++ "Con("
         , show i
         , ",["
         , intercalate "," $ map translateVariableName vars
         , "])"
         ]

translateExpression (SUpdate var e) =
  translateVariableName var ++ " = " ++ translateExpression e

translateExpression (SProj var i) =
  translateVariableName var ++ ".vars[" ++ show i ++"]"

translateExpression SNothing = "null"

translateExpression e =
     "(function(){throw 'Not yet implemented: "
  ++ filter (/= '\'') (show e)
  ++ "';})()"

translateCase :: String -> SAlt -> String
translateCase _ (SDefaultCase e) =
  createIfBlock "true" (translateExpression e)

translateCase var (SConstCase ty e)
  | StrType <- ty = matchHelper "String"
  | PtrType <- ty = matchHelper "Ptr"
  | Forgot  <- ty = matchHelper "Forgot"
  | (AType ATFloat) <- ty = matchHelper "Float"
  | (AType (ATInt ITBig)) <- ty = matchHelper "Integer"
  | (AType (ATInt ITNative)) <- ty = matchHelper "Int"
  | (AType (ATInt ITChar))  <- ty = matchHelper "Char"
  where
    matchHelper tyName = translateTypeMatch var tyName e

translateCase var (SConstCase cst@(BI _) e) =
  let cond = idrRTNamespace ++ "bigInt(" ++ var ++ ").equals(" ++ translateConstant cst ++ ")" in
      createIfBlock cond (translateExpression e)

translateCase var (SConstCase cst e) =
  let cond = var ++ " == " ++ translateConstant cst in
      createIfBlock cond (translateExpression e)

translateCase var (SConCase a i name vars e) =
  let isCon = var ++ " instanceof " ++ idrRTNamespace ++ "Con"
      isI = show i ++ " == " ++ var ++ ".i"
      params = intercalate "," $ map (("__var_" ++) . show) [a..(a+length vars)]
      args = ".apply(this," ++ var ++ ".vars)"
      f b =
           "(function("
        ++ params 
        ++ "){\nreturn " ++ b ++ "\n})" ++ args
      cond = intercalate " && " [isCon, isI] in
      createIfBlock cond $ f (translateExpression e)

translateTypeMatch :: String -> String -> SExp -> String
translateTypeMatch var ty exp =
  let e = translateExpression exp in
      createIfBlock (var
                  ++ " instanceof " ++ idrRTNamespace ++ "Type && "
                  ++ var ++ ".type == '"++ ty ++"'") e


createIfBlock cond e =
     "if (" ++ cond ++") {\n"
  ++ "return " ++ e
  ++ ";\n}"

createTailcall call =
  idrRTNamespace ++ "tailcall(function(){return " ++ call ++ "})"

translateFunctionCall name vars =
     translateNamespace name
  ++ translateName name
  ++ "("
  ++ intercalate "," (map translateVariableName vars)
  ++ ")"