{-|
Module      : IRTS.JavaScript.PrimOp
Description : The JavaScript primitive operations.

License     : BSD3
Maintainer  : The Idris Community.
-}

{-# LANGUAGE OverloadedStrings, PatternGuards, StandaloneDeriving #-}

module IRTS.JavaScript.PrimOp
  ( PrimF
  , PrimDec
  , JsPrimTy(..)
  , primDB
  , jsPrimCoerce
  ) where

import qualified Data.Map.Strict as Map
import Idris.Core.TT
import IRTS.JavaScript.AST
import IRTS.Lang

data JsPrimTy = PTBool | PTAny deriving (Eq, Ord)

type PrimF = [JsExpr] -> JsExpr
type PrimDec = (Bool, JsPrimTy, PrimF) -- the bool indicates if bigint library is used or not

primDB :: Map.Map PrimFn PrimDec
primDB =
  Map.fromList [
    item (LPlus ATFloat) False PTAny $ binop "+"
  , item (LPlus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) + %1.charCodeAt(0))"
  , item (LPlus (ATInt ITNative)) False PTAny $ binop "+"
  , item (LPlus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 + %1 & 0xFF"
  , item (LPlus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 + %1 & 0xFFFF"
  , item (LPlus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0+%1|0"
  , item (LPlus (ATInt ITBig)) True PTAny $ method "add"
  , item (LPlus (ATInt (ITFixed IT64))) True PTAny $
    \[l, r] -> JsForeign "%0.add(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
  , item (LMinus ATFloat) False PTAny $ binop "-"
  , item (LMinus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) - %1.charCodeAt(0))"
  , item (LMinus (ATInt ITNative)) False PTAny $ binop "-"
  , item (LMinus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 - %1 & 0xFF"
  , item (LMinus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 - %1 & 0xFFFF"
  , item (LMinus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0-%1|0"
  , item (LMinus (ATInt ITBig)) True PTAny $ method "subtract"
  , item (LMinus (ATInt (ITFixed IT64))) True PTAny $
    \[l, r] -> JsForeign "%0.subtract(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
  , item (LTimes ATFloat) False PTAny $ binop "*"
  , item (LTimes (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) * %1.charCodeAt(0))"
  , item (LTimes (ATInt ITNative)) False PTAny $ binop "*"
  , item (LTimes (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 * %1 & 0xFF"
  , item (LTimes (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 * %1 & 0xFFFF"
  , item (LTimes (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0*%1|0"
  , item (LTimes (ATInt ITBig)) True PTAny $ method "multiply"
  , item (LTimes (ATInt (ITFixed IT64))) True PTAny $
    \[l, r] -> JsForeign "%0.multiply(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
  , item (LUDiv (ITFixed IT8)) False PTAny $ JsForeign "%0 / %1"
  , item (LUDiv (ITFixed IT16)) False PTAny $ JsForeign "%0 / %1"
  , item (LUDiv (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0)  / (%1>>>0) |0"
  , item (LUDiv (ITFixed IT64)) True PTAny $ JsForeign "%0.divide(%1)"
  , item (LSDiv ATFloat) False PTAny $ binop "/"
  , item (LSDiv (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 / %1"
  , item (LSDiv (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 / %1"
  , item (LSDiv (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0  / %1 |0"
  , item (LSDiv (ATInt (ITFixed IT64))) True PTAny $ JsForeign "%0.divide(%1)"
  , item (LSDiv (ATInt ITNative)) False PTAny $ JsForeign "%0/%1|0" -- we need "|0" in this
  , item (LSDiv (ATInt ITBig)) True PTAny $ method "divide"
  , item (LURem (ITFixed IT8)) False PTAny $ JsForeign "%0 % %1"
  , item (LURem (ITFixed IT16)) False PTAny $ JsForeign "%0 % %1"
  , item (LURem (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0) % (%1>>>0) |0"
  , item (LURem (ITFixed IT64)) True PTAny $ method "remainder"
  , item (LSRem ATFloat) False PTAny $ binop "%"
  , item (LSRem (ATInt ITNative)) False PTAny $ binop "%"
  , item (LSRem (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 % %1"
  , item (LSRem (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 % %1"
  , item (LSRem (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0 % %1 |0"
  , item (LSRem (ATInt (ITFixed IT64))) True PTAny $ method "remainder"
  , item (LSRem (ATInt ITBig)) True PTAny $ method "remainder"
  , item (LAnd ITNative) False PTAny $ JsForeign "%0 & %1"
  , item (LAnd (ITFixed IT8)) False PTAny $ JsForeign "%0 & %1"
  , item (LAnd (ITFixed IT16)) False PTAny $ JsForeign "%0 & %1"
  , item (LAnd (ITFixed IT32)) False PTAny $ JsForeign "%0  & %1"
  , item (LAnd (ITFixed IT64)) True PTAny $ method "and"
  , item (LAnd ITBig) True PTAny $ method "and"
  , item (LOr ITNative) False PTAny $ JsForeign "%0 | %1"
  , item (LOr (ITFixed IT8)) False PTAny $ JsForeign "%0 | %1"
  , item (LOr (ITFixed IT16)) False PTAny $ JsForeign "%0 | %1"
  , item (LOr (ITFixed IT32)) False PTAny $ JsForeign "%0 | %1"
  , item (LOr (ITFixed IT64)) True PTAny $ method "or"
  , item (LOr ITBig) True PTAny $ method "or"
  , item (LXOr ITNative) False PTAny $ JsForeign "%0 ^ %1"
  , item (LXOr (ITFixed IT8)) False PTAny $ JsForeign "%0 ^ %1"
  , item (LXOr (ITFixed IT16)) False PTAny $ JsForeign "%0 ^ %1"
  , item (LXOr (ITFixed IT32)) False PTAny $ JsForeign "%0 ^ %1"
  , item (LXOr (ITFixed IT64)) True PTAny $ method "xor"
  , item (LXOr ITBig) True PTAny $ method "xor"
  , item (LSHL ITNative) False PTAny $ JsForeign "%0 << %1 |0"
  , item (LSHL (ITFixed IT8)) False PTAny $ JsForeign "%0 << %1 & 0xFF"
  , item (LSHL (ITFixed IT16)) False PTAny $ JsForeign "%0 << %1 & 0xFFFF"
  , item (LSHL (ITFixed IT32)) False PTAny $ JsForeign "%0 << %1 | 0"
  , item (LSHL (ITFixed IT64)) True PTAny $
    \[l, r] -> JsForeign "%0.shiftLeft(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
  , item (LSHL ITBig) True PTAny $ method "shiftLeft"
  , item (LLSHR ITNative) False PTAny $ JsForeign "%0 >> %1 |0"
  , item (LLSHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >> %1"
  , item (LLSHR (ITFixed IT16)) False PTAny $ JsForeign "%0 >> %1"
  , item (LLSHR (ITFixed IT32)) False PTAny $ JsForeign "%0 >> %1|0"
  , item (LLSHR (ITFixed IT64)) True PTAny $ JsForeign "%0.shiftRight(%1)"
  , item (LASHR ITNative) False PTAny $ JsForeign "%0 >> %1 |0"
  , item (LASHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >> %1"
  , item (LASHR (ITFixed IT16)) False PTAny $ JsForeign "%0 >> %1"
  , item (LASHR (ITFixed IT32)) False PTAny $ JsForeign "%0 >> %1|0"
  , item (LASHR (ITFixed IT64)) True PTAny $ JsForeign "%0.shiftRight(%1)"
  , item (LCompl (ITFixed IT8)) False PTAny $ JsForeign "~%0"
  , item (LCompl (ITFixed IT16)) False PTAny $ JsForeign "~%0"
  , item (LCompl (ITFixed IT32)) False PTAny $ JsForeign "~%0|0"
  , item (LCompl (ITFixed IT64)) True PTAny $ method "not"
  , item (LEq ATFloat) False PTBool $ binop "==="
  , item (LEq (ATInt ITNative)) False PTBool $ binop "==="
  , item (LEq (ATInt ITChar)) False PTBool $ binop "==="
  , item (LEq (ATInt ITBig)) True PTBool $ method "equals"
  , item (LEq (ATInt (ITFixed IT8))) False PTBool $ binop "==="
  , item (LEq (ATInt (ITFixed IT16))) False PTBool $ binop "==="
  , item (LEq (ATInt (ITFixed IT32))) False PTBool $ binop "==="
  , item (LEq (ATInt (ITFixed IT64))) True PTBool $ method "equals"
  , item (LLt (ITFixed IT8)) False PTBool $ JsForeign "%0 < %1"
  , item (LLt (ITFixed IT16)) False PTBool $ JsForeign "%0 < %1"
  , item (LLt (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) < (%1>>>0)"
  , item (LLt (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
  , item (LLe (ITFixed IT8)) False PTBool $ JsForeign "%0 <= %1"
  , item (LLe (ITFixed IT16)) False PTBool $ JsForeign "%0 <= %1"
  , item (LLe (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) <= (%1>>>0)"
  , item (LLe (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
  , item (LGt (ITFixed IT8)) False PTBool $ JsForeign "%0 > %1"
  , item (LGt (ITFixed IT16)) False PTBool $ JsForeign "%0 > %1"
  , item (LGt (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) > (%1>>>0)"
  , item (LGt (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
  , item (LGe (ITFixed IT8)) False PTBool $ JsForeign "%0 >= %1"
  , item (LGe (ITFixed IT16)) False PTBool $ JsForeign "%0 >= %1"
  , item (LGe (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) >= (%1>>>0)"
  , item (LGe (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
  , item (LSLt ATFloat) False PTBool $ binop "<"
  , item (LSLt (ATInt ITChar)) False PTBool $ binop "<"
  , item (LSLt (ATInt ITNative)) False PTBool $ binop "<"
  , item (LSLt (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
  , item (LSLt (ATInt (ITFixed IT8))) False PTBool $ binop "<"
  , item (LSLt (ATInt (ITFixed IT16))) False PTBool $ binop "<"
  , item (LSLt (ATInt (ITFixed IT32))) False PTBool $ binop "<"
  , item (LSLt (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
  , item (LSLe ATFloat) False PTBool $ binop "<="
  , item (LSLe (ATInt ITNative)) False PTBool $ binop "<="
  , item (LSLe (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
  , item (LSLe (ATInt (ITFixed IT8))) False PTBool $ binop "<="
  , item (LSLe (ATInt (ITFixed IT16))) False PTBool $ binop "<="
  , item (LSLe (ATInt (ITFixed IT32))) False PTBool $ binop "<="
  , item (LSLe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
  , item (LSGt ATFloat) False PTBool $ binop ">"
  , item (LSGt (ATInt ITNative)) False PTBool $ binop ">"
  , item (LSGt (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
  , item (LSGt (ATInt (ITFixed IT8))) False PTBool $ binop ">"
  , item (LSGt (ATInt (ITFixed IT16))) False PTBool $ binop ">"
  , item (LSGt (ATInt (ITFixed IT32))) False PTBool $ binop ">"
  , item (LSGt (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
  , item (LSGe ATFloat) False PTBool $ binop ">="
  , item (LSGe (ATInt ITNative)) False PTBool $ binop ">="
  , item (LSGe (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
  , item (LSGe (ATInt (ITFixed IT8))) False PTBool $ binop ">="
  , item (LSGe (ATInt (ITFixed IT16))) False PTBool $ binop ">="
  , item (LSGe (ATInt (ITFixed IT32))) False PTBool $ binop ">="
  , item (LSGe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
  , item (LSExt ITNative ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
  , item (LZExt (ITFixed IT8) ITNative) False PTAny $ head
  , item (LZExt (ITFixed IT16) ITNative) False PTAny $ head
  , item (LZExt (ITFixed IT32) ITNative) False PTAny $ head
  , item (LZExt ITNative ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
  , item (LZExt (ITFixed IT8) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
  , item (LZExt (ITFixed IT16) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
  , item (LZExt (ITFixed IT32) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
  , item (LZExt (ITFixed IT64) ITBig) True PTAny $ head
  , item (LTrunc ITBig ITNative) True PTAny $ JsForeign "%0.intValue()|0"
  , item (LTrunc ITBig (ITFixed IT8)) True PTAny $ JsForeign "%0.intValue() & 0xFF"
  , item (LTrunc ITBig (ITFixed IT16)) True PTAny $ JsForeign "%0.intValue() & 0xFFFF"
  , item (LTrunc ITBig (ITFixed IT32)) True PTAny $ JsForeign "%0.intValue() & 0xFFFFFFFF"
  , item (LTrunc ITBig (ITFixed IT64)) True PTAny $
    \[x] -> JsForeign "%0.and(new $JSRTS.jsbn.BigInteger(%1))" [x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
  , item (LTrunc (ITFixed IT16) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"
  , item (LTrunc (ITFixed IT32) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"
  , item (LTrunc (ITFixed IT64) (ITFixed IT8)) True PTAny $ JsForeign "%0.intValue() & 0xFF"
  , item (LTrunc (ITFixed IT32) (ITFixed IT16)) False PTAny $ JsForeign "%0 & 0xFFFF"
  , item (LTrunc (ITFixed IT64) (ITFixed IT16)) True PTAny $ JsForeign "%0.intValue() & 0xFFFF"
  , item (LTrunc (ITFixed IT64) (ITFixed IT32)) True PTAny $ JsForeign "%0.intValue() & 0xFFFFFFFF"
  , item LStrConcat False PTAny $ binop "+"
  , item LStrLt False PTBool $ binop "<"
  , item LStrEq False PTBool $ binop "=="
  , item LStrLen False PTAny $ JsForeign "%0.length"
  , item (LIntFloat ITNative) False PTAny $ head
  , item (LIntFloat ITBig) True PTAny $ JsForeign "%0.intValue()"
  , item (LFloatInt ITNative) False PTAny $ JsForeign "%0|0"
  , item (LFloatInt ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(Math.trunc(%0)+ '')"
  , item (LIntStr ITNative) False PTAny $ JsForeign "''+%0"
  , item (LIntStr ITBig) True PTAny $ JsForeign "%0.toString()"
  , item (LStrInt ITNative) False PTAny $ JsForeign "parseInt(%0)|0"
  , item (LStrInt ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)"
  , item (LFloatStr) False PTAny $ JsForeign "''+%0"
  , item (LStrFloat) False PTAny $ jsAppN "parseFloat"
  , item (LChInt ITNative) False PTAny $ JsForeign "%0.charCodeAt(0)|0"
  , item (LIntCh ITNative) False PTAny $ jsAppN "String.fromCharCode"
  , item LFExp False PTAny $ jsAppN "Math.exp"
  , item LFLog False PTAny $ jsAppN "Math.log"
  , item LFSin False PTAny $ jsAppN "Math.sin"
  , item LFCos False PTAny $ jsAppN "Math.cos"
  , item LFTan False PTAny $ jsAppN "Math.tan"
  , item LFASin False PTAny $ jsAppN "Math.asin"
  , item LFACos False PTAny $ jsAppN "Math.acos"
  , item LFATan False PTAny $ jsAppN "Math.atan"
  , item LFATan2 False PTAny $ jsAppN "Math.atan2"
  , item LFSqrt False PTAny $ jsAppN "Math.sqrt"
  , item LFFloor False PTAny $ jsAppN "Math.floor"
  , item LFCeil False PTAny $ jsAppN "Math.ceil"
  , item LFNegate False PTAny $ JsForeign "-%0"
  , item LStrHead False PTAny $ \[x] -> JsArrayProj (JsInt 0) x
  , item LStrTail False PTAny $ \[x] -> JsMethod x "slice" [JsInt 1]
  , item LStrCons False PTAny $ JsForeign "%0+%1"
  , item LStrIndex False PTAny $ \[x, y] -> JsArrayProj y x
  , item LStrRev False PTAny $ JsForeign "%0.split('').reverse().join('')"
  , item LStrSubstr False PTAny $ JsForeign "$JSRTS.prim_strSubstr(%0, %1, %2)"
  , item LSystemInfo False PTAny $ JsApp (JsProp (JsVar "$JSRTS") "prim_systemInfo")
  , item LCrash False PTAny $ \[l] -> JsErrorExp l
  , item LReadStr False PTAny $ \[_] -> JsApp (JsProp (JsVar "$JSRTS") "prim_readStr") []
  , item LWriteStr False PTAny $ \[_, str] -> JsApp (JsProp (JsVar "$JSRTS") "prim_writeStr") [str]
  , item LNoOp False PTAny $ head
  ]
  where
    item :: PrimFn -> Bool -> JsPrimTy -> PrimF -> (PrimFn, PrimDec)
    item fn ubi pty c = (fn, (ubi, pty, c))
    binop op [l, r] = JsBinOp op l r
    method op (l:r) = JsMethod l op r

jsB2I :: JsExpr -> JsExpr
jsB2I x = JsForeign "%0 ? 1|0 : 0|0" [x]

jsPrimCoerce :: JsPrimTy -> JsPrimTy -> JsExpr -> JsExpr
jsPrimCoerce PTBool PTAny x = jsB2I x
jsPrimCoerce _ _ x = x