{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}

module Language.JavaScript.Inline.Core.Utils where

import Data.Binary.Get
import Data.Binary.Get.Internal
import qualified Data.ByteString as BS
import Data.ByteString.Builder
import Data.ByteString.Builder.Prim
import Data.ByteString.Builder.Prim.Internal
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Unsafe as BS
import Data.Coerce
import qualified Data.Map.Strict as M
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LT
import Foreign
import GHC.Exts
import GHC.Types
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import System.Directory
import System.FilePath
import System.IO
import System.IO.Unsafe
import Type.Reflection

-- | 'embedFile' takes a file path, and generates a 'BS.ByteString' at
-- compile-time containing the file content. The file path is relative to the
-- package root directory, and should be included as a part of
-- @extra-source-files@ of that package's @.cabal@ metadata.
--
-- We embed the eval server JavaScript source via TH, instead of using
-- @data-files@ at runtime, so that standalone executables using this package
-- should still work fine if the build directory is no longer present.
--
-- A more space-efficient implementation of 'embedFile' which avoids
-- 'StringPrimL' is possible with GHC 8.10+. We stay with 'StringPrimL' to avoid
-- breaking GHC 8.8.
embedFile :: FilePath -> Q Exp
embedFile :: FilePath -> Q Exp
embedFile FilePath
p' = do
  FilePath
src <- Loc -> FilePath
loc_filename (Loc -> FilePath) -> Q Loc -> Q FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
  FilePath
pkg <- IO FilePath -> Q FilePath
forall a. IO a -> Q a
runIO (IO FilePath -> Q FilePath) -> IO FilePath -> Q FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
pkgDir (FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO FilePath
makeAbsolute FilePath
src
  let p :: FilePath
p = FilePath
pkg FilePath -> FilePath -> FilePath
</> FilePath
p'
  FilePath -> Q ()
addDependentFile FilePath
p
  ByteString
s <- IO ByteString -> Q ByteString
forall a. IO a -> Q a
runIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ByteString
BS.readFile FilePath
p
  let len :: Int
len = ByteString -> Int
BS.length ByteString
s
  [|
    unsafePerformIO $
      BS.unsafePackAddressLen len $(litE $ stringPrimL $ BS.unpack s)
    |]
  where
    pkgDir :: FilePath -> IO FilePath
pkgDir FilePath
p = do
      let d :: FilePath
d = FilePath -> FilePath
takeDirectory FilePath
p
      [FilePath]
fs <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
d
      if (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal") (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension) [FilePath]
fs
        then FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
d
        else FilePath -> IO FilePath
pkgDir FilePath
d

-- | Deduplicate an association list in a left-biased manner; if the same key
-- appears more than once, the left-most key/value pair is preserved.
kvDedup :: Ord k => [(k, a)] -> [(k, a)]
kvDedup :: [(k, a)] -> [(k, a)]
kvDedup = Map k a -> [(k, a)]
forall k a. Map k a -> [(k, a)]
M.toList (Map k a -> [(k, a)])
-> ([(k, a)] -> Map k a) -> [(k, a)] -> [(k, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a) -> [(k, a)] -> Map k a
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith (\a
_ a
a -> a
a)

storableGet ::
  forall a.
  Storable a =>
  Get a
storableGet :: Get a
storableGet =
  Int -> (ByteString -> a) -> Get a
forall a. Int -> (ByteString -> a) -> Get a
readN (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)) ((ByteString -> a) -> Get a) -> (ByteString -> a) -> Get a
forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
    IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> (CString -> IO a) -> IO a
forall a. ByteString -> (CString -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs ((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr a -> IO a) -> (CString -> Ptr a) -> CString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr

storablePut :: Storable a => a -> Builder
storablePut :: a -> Builder
storablePut = FixedPrim a -> a -> Builder
forall a. FixedPrim a -> a -> Builder
primFixed FixedPrim a
forall a. Storable a => FixedPrim a
storableToF

intFromStablePtr :: StablePtr a -> Int
intFromStablePtr :: StablePtr a -> Int
intFromStablePtr = IntPtr -> Int
coerce (IntPtr -> Int) -> (StablePtr a -> IntPtr) -> StablePtr a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr () -> IntPtr
forall a. Ptr a -> IntPtr
ptrToIntPtr (Ptr () -> IntPtr)
-> (StablePtr a -> Ptr ()) -> StablePtr a -> IntPtr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr

intToStablePtr :: Int -> StablePtr a
intToStablePtr :: Int -> StablePtr a
intToStablePtr = Ptr () -> StablePtr a
forall a. Ptr () -> StablePtr a
castPtrToStablePtr (Ptr () -> StablePtr a) -> (Int -> Ptr ()) -> Int -> StablePtr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntPtr -> Ptr ()
forall a. IntPtr -> Ptr a
intPtrToPtr (IntPtr -> Ptr ()) -> (Int -> IntPtr) -> Int -> Ptr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntPtr
coerce

word64FromStablePtr :: StablePtr a -> Word64
word64FromStablePtr :: StablePtr a -> Word64
word64FromStablePtr = WordPtr -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (WordPtr -> Word64)
-> (StablePtr a -> WordPtr) -> StablePtr a -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr () -> WordPtr
forall a. Ptr a -> WordPtr
ptrToWordPtr (Ptr () -> WordPtr)
-> (StablePtr a -> Ptr ()) -> StablePtr a -> WordPtr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr

word64ToStablePtr :: Word64 -> StablePtr a
word64ToStablePtr :: Word64 -> StablePtr a
word64ToStablePtr = Ptr () -> StablePtr a
forall a. Ptr () -> StablePtr a
castPtrToStablePtr (Ptr () -> StablePtr a)
-> (Word64 -> Ptr ()) -> Word64 -> StablePtr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordPtr -> Ptr ()
forall a. WordPtr -> Ptr a
wordPtrToPtr (WordPtr -> Ptr ()) -> (Word64 -> WordPtr) -> Word64 -> Ptr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> WordPtr
forall a b. (Integral a, Num b) => a -> b
fromIntegral

stringFromLBS :: LBS.ByteString -> String
stringFromLBS :: ByteString -> FilePath
stringFromLBS = Text -> FilePath
LT.unpack (Text -> FilePath)
-> (ByteString -> Text) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
LT.decodeUtf8

stringToLBS :: String -> LBS.ByteString
stringToLBS :: FilePath -> ByteString
stringToLBS = Text -> ByteString
LT.encodeUtf8 (Text -> ByteString)
-> (FilePath -> Text) -> FilePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
LT.pack

hGetExact :: Handle -> Int -> IO LBS.ByteString
hGetExact :: Handle -> Int -> IO ByteString
hGetExact Handle
h Int
len_expected = do
  ByteString
r <- Handle -> Int -> IO ByteString
LBS.hGet Handle
h Int
len_expected
  let len_actual :: Int
len_actual = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length ByteString
r
  if Int
len_actual Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len_expected
    then ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
r
    else
      FilePath -> IO ByteString
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$
        FilePath
"hGetExact: expected "
          FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
len_expected
          FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" bytes, got "
          FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
len_actual

runGetExact ::
  forall a.
  Typeable a =>
  Get a ->
  LBS.ByteString ->
  IO a
runGetExact :: Get a -> ByteString -> IO a
runGetExact Get a
g ByteString
buf =
  case Get a
-> ByteString
-> Either (ByteString, Int64, FilePath) (ByteString, Int64, a)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, FilePath) (ByteString, Int64, a)
runGetOrFail Get a
g ByteString
buf of
    Right (ByteString -> Bool
LBS.null -> Bool
True, Int64
_, a
r) -> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
    Either (ByteString, Int64, FilePath) (ByteString, Int64, a)
_ -> FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$ FilePath
"runGetExact failed on type " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> TypeRep a -> FilePath
forall a. Show a => a -> FilePath
show (Typeable a => TypeRep a
forall k (a :: k). Typeable a => TypeRep a
typeRep @a)

{-# NOINLINE touch #-}
touch :: a -> IO ()
touch :: a -> IO ()
touch a
a =
  (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
    case a -> State# RealWorld -> State# RealWorld
forall a. a -> State# RealWorld -> State# RealWorld
touch# a
a State# RealWorld
s0 of
      State# RealWorld
s1 -> (# State# RealWorld
s1, () #)

split :: (a -> Bool) -> [a] -> [[a]]
split :: (a -> Bool) -> [a] -> [[a]]
split a -> Bool
f [a]
l =
  case (a -> [[a]] -> [[a]]) -> [[a]] -> [a] -> [[a]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> [[a]] -> [[a]]
w [] [a]
l of
    [] : [[a]]
r -> [[a]]
r
    [[a]]
r -> [[a]]
r
  where
    w :: a -> [[a]] -> [[a]]
w a
x [[a]]
acc
      | a -> Bool
f a
x =
        case [[a]]
acc of
          (a
_ : [a]
_) : [[a]]
_ -> [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
acc
          [[a]]
_ -> [[a]]
acc
      | Bool
otherwise =
        case [[a]]
acc of
          [] -> [[a
x]]
          [a]
xs : [[a]]
acc' -> (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs) [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
acc'