{-# 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 :: 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
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'