{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module GHC.StgToJS.Literal
  ( genLit
  , genStaticLit
  )
where

import GHC.Prelude

import GHC.JS.Syntax
import GHC.JS.Make

import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Ids
import GHC.StgToJS.Symbols

import GHC.Data.FastString
import GHC.Types.Literal
import GHC.Types.Basic
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Float

import Data.Bits as Bits
import Data.Char (ord)

-- | Generate JS expressions for a Literal
--
-- Literals represented with 2 values:
--  * Addr# (Null and Strings): array and offset
--  * 64-bit values: high 32-bit, low 32-bit
--  * labels: call to h$mkFunctionPtr and 0, or function name and 0
genLit :: HasDebugCallStack => Literal -> G [JExpr]
genLit :: HasDebugCallStack => Literal -> G [JExpr]
genLit = \case
  LitChar Char
c     -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr (Char -> Int
ord Char
c) ]
  LitString ByteString
str ->
    G Ident
freshIdent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \strLit :: Ident
strLit@(TxtI FastString
strLitT) ->
      G Ident
freshIdent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \strOff :: Ident
strOff@(TxtI FastString
strOffT) -> do
        FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
strLitT (StaticUnboxed -> StaticVal
StaticUnboxed (ByteString -> StaticUnboxed
StaticUnboxedString ByteString
str)) forall a. Maybe a
Nothing
        FastString -> StaticVal -> Maybe Ident -> G ()
emitStatic FastString
strOffT (StaticUnboxed -> StaticVal
StaticUnboxed (ByteString -> StaticUnboxed
StaticUnboxedStringOffset ByteString
str)) forall a. Maybe a
Nothing
        forall (m :: * -> *) a. Monad m => a -> m a
return [ JVal -> JExpr
ValExpr (Ident -> JVal
JVar Ident
strLit), JVal -> JExpr
ValExpr (Ident -> JVal
JVar Ident
strOff) ]
  Literal
LitNullAddr              -> forall (m :: * -> *) a. Monad m => a -> m a
return [ JExpr
null_, JVal -> JExpr
ValExpr (Integer -> JVal
JInt Integer
0) ]
  LitNumber LitNumType
nt Integer
v           -> case LitNumType
nt of
    LitNumType
LitNumInt     -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr Integer
v ]
    LitNumType
LitNumInt8    -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr Integer
v ]
    LitNumType
LitNumInt16   -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr Integer
v ]
    LitNumType
LitNumInt32   -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr Integer
v ]
    LitNumType
LitNumInt64   -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr (forall a. Bits a => a -> Int -> a
Bits.shiftR Integer
v Int
32), Integer -> JExpr
toU32Expr Integer
v ]
    LitNumType
LitNumWord    -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JExpr
toU32Expr Integer
v ]
    LitNumType
LitNumWord8   -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JExpr
toU32Expr Integer
v ]
    LitNumType
LitNumWord16  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JExpr
toU32Expr Integer
v ]
    LitNumType
LitNumWord32  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JExpr
toU32Expr Integer
v ]
    LitNumType
LitNumWord64  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> JExpr
toU32Expr (forall a. Bits a => a -> Int -> a
Bits.shiftR Integer
v Int
32), Integer -> JExpr
toU32Expr Integer
v ]
    LitNumType
LitNumBigNat  -> forall a. HasCallStack => String -> a
panic String
"genLit: unexpected BigNat that should have been removed in CorePrep"
  LitFloat Rational
r               -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr (Rational -> Double
r2f Rational
r) ]
  LitDouble Rational
r              -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr (Rational -> Double
r2d Rational
r) ]
  LitLabel FastString
name Maybe Int
_size FunctionOrData
fod
    | FunctionOrData
fod forall a. Eq a => a -> a -> Bool
== FunctionOrData
IsFunction      -> forall (m :: * -> *) a. Monad m => a -> m a
return [ JExpr -> [JExpr] -> JExpr
ApplExpr (FastString -> JExpr
var FastString
"h$mkFunctionPtr")
                                                  [FastString -> JExpr
var (Bool -> FastString -> FastString
mkRawSymbol Bool
True FastString
name)]
                                       , JVal -> JExpr
ValExpr (Integer -> JVal
JInt Integer
0)
                                       ]
    | Bool
otherwise              -> forall (m :: * -> *) a. Monad m => a -> m a
return [ forall a. ToJExpr a => a -> JExpr
toJExpr (FastString -> Ident
TxtI (Bool -> FastString -> FastString
mkRawSymbol Bool
True FastString
name))
                                       , JVal -> JExpr
ValExpr (Integer -> JVal
JInt Integer
0)
                                       ]
  LitRubbish {} -> forall (m :: * -> *) a. Monad m => a -> m a
return [ JExpr
null_ ]

-- | generate a literal for the static init tables
genStaticLit :: Literal -> G [StaticLit]
genStaticLit :: Literal -> G [StaticLit]
genStaticLit = \case
  LitChar Char
c                -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c) ]
  LitString ByteString
str
    | Bool
True                 -> forall (m :: * -> *) a. Monad m => a -> m a
return [ FastString -> StaticLit
StringLit (ByteString -> FastString
mkFastStringByteString ByteString
str), Integer -> StaticLit
IntLit Integer
0]
    -- \|  invalid UTF8         -> return [ BinLit str, IntLit 0]
  Literal
LitNullAddr              -> forall (m :: * -> *) a. Monad m => a -> m a
return [ StaticLit
NullLit, Integer -> StaticLit
IntLit Integer
0 ]
  LitNumber LitNumType
nt Integer
v           -> case LitNumType
nt of
    LitNumType
LitNumInt     -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit Integer
v ]
    LitNumType
LitNumInt8    -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit Integer
v ]
    LitNumType
LitNumInt16   -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit Integer
v ]
    LitNumType
LitNumInt32   -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit Integer
v ]
    LitNumType
LitNumInt64   -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
IntLit (Integer
v forall a. Bits a => a -> Int -> a
`Bits.shiftR` Int
32), Integer -> StaticLit
toU32Lit Integer
v ]
    LitNumType
LitNumWord    -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit Integer
v ]
    LitNumType
LitNumWord8   -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit Integer
v ]
    LitNumType
LitNumWord16  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit Integer
v ]
    LitNumType
LitNumWord32  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit Integer
v ]
    LitNumType
LitNumWord64  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Integer -> StaticLit
toU32Lit (Integer
v forall a. Bits a => a -> Int -> a
`Bits.shiftR` Int
32), Integer -> StaticLit
toU32Lit Integer
v ]
    LitNumType
LitNumBigNat  -> forall a. HasCallStack => String -> a
panic String
"genStaticLit: unexpected BigNat that should have been removed in CorePrep"
  LitFloat Rational
r               -> forall (m :: * -> *) a. Monad m => a -> m a
return [ SaneDouble -> StaticLit
DoubleLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> SaneDouble
SaneDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Double
r2f forall a b. (a -> b) -> a -> b
$ Rational
r ]
  LitDouble Rational
r              -> forall (m :: * -> *) a. Monad m => a -> m a
return [ SaneDouble -> StaticLit
DoubleLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> SaneDouble
SaneDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Double
r2d forall a b. (a -> b) -> a -> b
$ Rational
r ]
  LitLabel FastString
name Maybe Int
_size FunctionOrData
fod  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ Bool -> FastString -> StaticLit
LabelLit (FunctionOrData
fod forall a. Eq a => a -> a -> Bool
== FunctionOrData
IsFunction) (Bool -> FastString -> FastString
mkRawSymbol Bool
True FastString
name)
                                     , Integer -> StaticLit
IntLit Integer
0 ]
  Literal
l -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genStaticLit" (forall a. Outputable a => a -> SDoc
ppr Literal
l)

-- make an unsigned 32 bit number from this unsigned one, lower 32 bits
toU32Expr :: Integer -> JExpr
toU32Expr :: Integer -> JExpr
toU32Expr Integer
i = Integer -> JExpr
Int (Integer
i forall a. Bits a => a -> a -> a
Bits..&. Integer
0xFFFFFFFF) JExpr -> JExpr -> JExpr
.>>>. JExpr
0

-- make an unsigned 32 bit number from this unsigned one, lower 32 bits
toU32Lit :: Integer -> StaticLit
toU32Lit :: Integer -> StaticLit
toU32Lit Integer
i = Integer -> StaticLit
IntLit (Integer
i forall a. Bits a => a -> a -> a
Bits..&. Integer
0xFFFFFFFF)

r2d :: Rational -> Double
r2d :: Rational -> Double
r2d = forall a b. (Real a, Fractional b) => a -> b
realToFrac

r2f :: Rational -> Double
r2f :: Rational -> Double
r2f = Float -> Double
float2Double forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac