{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}

module Unison.Runtime.Foreign.Function
  ( ForeignConvention (..),
    foreignCall,
    readsAtError,
    foreignConventionError,
    pseudoConstructors,
    functionReplacements,
    functionUnreplacements,
  )
where

import Control.Concurrent (ThreadId)
import Control.Concurrent as SYS
  ( killThread,
    threadDelay,
  )
import Control.Concurrent.MVar as SYS
import Control.Concurrent.STM qualified as STM
import Control.DeepSeq (NFData)
import Control.Exception
import Control.Exception.Safe qualified as Exception
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Primitive qualified as PA
import Crypto.Error (CryptoError (..), CryptoFailable (..))
import Crypto.Hash qualified as Hash
import Crypto.MAC.HMAC qualified as HMAC
import Crypto.PubKey.Ed25519 qualified as Ed25519
import Crypto.PubKey.RSA.PKCS15 qualified as RSA
import Crypto.Random (getRandomBytes)
import Data.Bits (shiftL, shiftR, (.|.))
import Data.ByteArray qualified as BA
import Data.ByteString (hGet, hGetSome, hPut)
import Data.ByteString.Lazy qualified as L
import Data.Default (def)
import Data.Digest.Murmur64 (asWord64, hash64)
import Data.IP (IP)
import Data.Map.Strict qualified as Map
import Data.Map.Strict.Internal qualified as Map
import Data.PEM (PEM, pemContent, pemParseLBS)
import Data.Sequence qualified as Sq
import Data.Tagged (Tagged (..))
import Data.Text qualified
import Data.Text.IO qualified as Text.IO
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Time.Clock.POSIX as SYS
  ( getPOSIXTime,
    posixSecondsToUTCTime,
    utcTimeToPOSIXSeconds,
  )
import Data.Time.LocalTime (TimeZone (..), getTimeZone)
import Data.X509 qualified as X
import Data.X509.CertificateStore qualified as X
import Data.X509.Memory qualified as X
import GHC.Conc qualified as STM
import GHC.IO (IO (IO))
import Network.Simple.TCP as SYS
  ( HostPreference (..),
    bindSock,
    closeSock,
    connectSock,
    listenSock,
    recv,
    send,
  )
import Network.Socket (Socket)
import Network.Socket as SYS
  ( PortNumber,
    Socket,
    accept,
    socketPort,
  )
import Network.TLS as TLS
import Network.TLS.Extra.Cipher as Cipher
import Network.UDP (UDPSocket)
import Network.UDP as UDP
  ( ClientSockAddr,
    ListenSocket,
    clientSocket,
    close,
    recv,
    recvFrom,
    send,
    sendTo,
    serverSocket,
    stop,
  )
import System.Clock (Clock (..), getTime, nsec, sec)
import System.Directory as SYS
  ( createDirectoryIfMissing,
    doesDirectoryExist,
    doesPathExist,
    getCurrentDirectory,
    getDirectoryContents,
    getFileSize,
    getModificationTime,
    getTemporaryDirectory,
    removeDirectoryRecursive,
    removeFile,
    renameDirectory,
    renameFile,
    setCurrentDirectory,
  )
import System.Environment as SYS
  ( getArgs,
    getEnv,
  )
import System.Exit as SYS (ExitCode (..))
import System.FilePath (isPathSeparator)
import System.IO (BufferMode (..), Handle, IOMode, SeekMode (..))
import System.IO as SYS
  ( IOMode (..),
    hClose,
    hGetBuffering,
    hGetChar,
    hGetEcho,
    hIsEOF,
    hIsOpen,
    hIsSeekable,
    hReady,
    hSeek,
    hSetBuffering,
    hSetEcho,
    hTell,
    openFile,
    stderr,
    stdin,
    stdout,
  )
import System.IO.Temp (createTempDirectory)
import System.Process as SYS
  ( getProcessExitCode,
    proc,
    runInteractiveProcess,
    terminateProcess,
    waitForProcess,
    withCreateProcess,
  )
import System.X509 qualified as X
import Unison.Builtin.Decls qualified as Ty
import Unison.Prelude hiding (Text, some)
import Unison.Reference
import Unison.Referent (Referent, pattern Ref)
import Unison.Runtime.ANF qualified as ANF
import Unison.Runtime.ANF.Rehash (checkGroupHashes)
import Unison.Runtime.ANF.Serialize qualified as ANF
import Unison.Runtime.Array qualified as PA
import Unison.Runtime.Builtin
import Unison.Runtime.Crypto.Rsa qualified as Rsa
import Unison.Runtime.Exception
import Unison.Runtime.Foreign hiding (Failure)
import Unison.Runtime.Foreign qualified as F
import Unison.Runtime.Foreign.Function.Type
  ( ForeignFunc (..),
    foreignFuncBuiltinName,
  )
import Unison.Runtime.MCode
import Unison.Runtime.Stack
import Unison.Runtime.TypeTags qualified as TT
import Unison.Symbol
import Unison.Type
  ( anyRef,
    listRef,
    textRef,
    typeLinkRef,
  )
import Unison.Type qualified as Ty
import Unison.Util.Bytes qualified as Bytes
import Unison.Util.RefPromise
  ( Promise,
    newPromise,
    readPromise,
    tryReadPromise,
    writePromise,
  )
import Unison.Util.Text (Text, pack, unpack)
import Unison.Util.Text qualified as Util.Text
import Unison.Util.Text.Pattern qualified as TPat
import UnliftIO qualified

-- foreignCall is explicitly NOINLINE'd because it's a _huge_ chunk of code and negatively affects code caching.
-- Because we're not inlining it, we need a wrapper using an explicitly unboxed Stack so we don't block the
-- worker-wrapper optimizations in the main eval loop.
-- It looks dump to accept an unboxed stack and then immediately box it up, but GHC is sufficiently smart to
-- unbox all of 'foreignCallHelper' when we write it this way, but it's way less work to use the regular lifted stack
-- in its implementation.
{-# NOINLINE foreignCall #-}
foreignCall :: ForeignFunc -> Args -> XStack -> IOEXStack
foreignCall :: ForeignFunc -> Args -> XStack -> IOEXStack
foreignCall !ForeignFunc
ff !Args
args !XStack
xstk =
  IO (Bool, Stack) -> IOEXStack
estackIOToIOX (IO (Bool, Stack) -> IOEXStack) -> IO (Bool, Stack) -> IOEXStack
forall a b. (a -> b) -> a -> b
$ ForeignFunc -> Args -> Stack -> IO (Bool, Stack)
foreignCallHelper ForeignFunc
ff Args
args (XStack -> Stack
packXStack XStack
xstk)

{-# INLINE foreignCallHelper #-}
foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO (Bool, Stack)
foreignCallHelper :: ForeignFunc -> Args -> Stack -> IO (Bool, Stack)
foreignCallHelper = \case
  ForeignFunc
IO_UDP_clientSocket_impl_v1 -> ((Text, Text) -> IO UDPSocket) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Text, Text) -> IO UDPSocket)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Text, Text) -> IO UDPSocket)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Text
host :: Util.Text.Text, Text
port :: Util.Text.Text) ->
    let hostStr :: [Char]
hostStr = Text -> [Char]
Util.Text.toString Text
host
        portStr :: [Char]
portStr = Text -> [Char]
Util.Text.toString Text
port
     in [Char] -> [Char] -> Bool -> IO UDPSocket
UDP.clientSocket [Char]
hostStr [Char]
portStr Bool
True
  ForeignFunc
IO_UDP_UDPSocket_recv_impl_v1 -> (UDPSocket -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((UDPSocket -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (UDPSocket -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(UDPSocket
sock :: UDPSocket) -> ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (ByteString -> Bytes) -> IO ByteString -> IO Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UDPSocket -> IO ByteString
UDP.recv UDPSocket
sock
  ForeignFunc
IO_UDP_UDPSocket_send_impl_v1 -> ((UDPSocket, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((UDPSocket, Bytes) -> IO ())
 -> Args -> Stack -> IO (Bool, Stack))
-> ((UDPSocket, Bytes) -> IO ())
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(UDPSocket
sock :: UDPSocket, Bytes
bytes :: Bytes.Bytes) ->
      UDPSocket -> ByteString -> IO ()
UDP.send UDPSocket
sock (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
bytes)
  ForeignFunc
IO_UDP_UDPSocket_close_impl_v1 -> (UDPSocket -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((UDPSocket -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (UDPSocket -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(UDPSocket
sock :: UDPSocket) -> UDPSocket -> IO ()
UDP.close UDPSocket
sock
  ForeignFunc
IO_UDP_ListenSocket_close_impl_v1 -> (ListenSocket -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((ListenSocket -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (ListenSocket -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(ListenSocket
sock :: ListenSocket) -> ListenSocket -> IO ()
UDP.stop ListenSocket
sock
  ForeignFunc
IO_UDP_UDPSocket_toText_impl_v1 -> (UDPSocket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((UDPSocket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> (UDPSocket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(UDPSocket
sock :: UDPSocket) -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ UDPSocket -> [Char]
forall a. Show a => a -> [Char]
show UDPSocket
sock
  ForeignFunc
IO_UDP_serverSocket_impl_v1 -> ((Text, Text) -> IO ListenSocket)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Text, Text) -> IO ListenSocket)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Text, Text) -> IO ListenSocket)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Text
ip :: Util.Text.Text, Text
port :: Util.Text.Text) ->
      let maybeIp :: Maybe IP
maybeIp = [Char] -> Maybe IP
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe IP) -> [Char] -> Maybe IP
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Util.Text.toString Text
ip :: Maybe IP
          maybePort :: Maybe PortNumber
maybePort = [Char] -> Maybe PortNumber
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe PortNumber) -> [Char] -> Maybe PortNumber
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Util.Text.toString Text
port :: Maybe PortNumber
       in case (Maybe IP
maybeIp, Maybe PortNumber
maybePort) of
            (Maybe IP
Nothing, Maybe PortNumber
_) -> [Char] -> IO ListenSocket
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid IP Address"
            (Maybe IP
_, Maybe PortNumber
Nothing) -> [Char] -> IO ListenSocket
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid Port Number"
            (Just IP
ip, Just PortNumber
pt) -> (IP, PortNumber) -> IO ListenSocket
UDP.serverSocket (IP
ip, PortNumber
pt)
  ForeignFunc
IO_UDP_ListenSocket_toText_impl_v1 -> (ListenSocket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ListenSocket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> (ListenSocket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(ListenSocket
sock :: ListenSocket) -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ ListenSocket -> [Char]
forall a. Show a => a -> [Char]
show ListenSocket
sock
  ForeignFunc
IO_UDP_ListenSocket_recvFrom_impl_v1 ->
    (ListenSocket -> IO (Bytes, ClientSockAddr))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((ListenSocket -> IO (Bytes, ClientSockAddr))
 -> Args -> Stack -> IO (Bool, Stack))
-> (ListenSocket -> IO (Bytes, ClientSockAddr))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      ((ByteString, ClientSockAddr) -> (Bytes, ClientSockAddr))
-> IO (ByteString, ClientSockAddr) -> IO (Bytes, ClientSockAddr)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> Bytes)
-> (ByteString, ClientSockAddr) -> (Bytes, ClientSockAddr)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray) (IO (ByteString, ClientSockAddr) -> IO (Bytes, ClientSockAddr))
-> (ListenSocket -> IO (ByteString, ClientSockAddr))
-> ListenSocket
-> IO (Bytes, ClientSockAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ListenSocket -> IO (ByteString, ClientSockAddr)
UDP.recvFrom
  ForeignFunc
IO_UDP_ClientSockAddr_toText_v1 -> (ClientSockAddr -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ClientSockAddr -> IO [Char])
 -> Args -> Stack -> IO (Bool, Stack))
-> (ClientSockAddr -> IO [Char])
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(ClientSockAddr
sock :: ClientSockAddr) -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ ClientSockAddr -> [Char]
forall a. Show a => a -> [Char]
show ClientSockAddr
sock
  ForeignFunc
IO_UDP_ListenSocket_sendTo_impl_v1 -> ((ListenSocket, Bytes, ClientSockAddr) -> IO ())
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((ListenSocket, Bytes, ClientSockAddr) -> IO ())
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ListenSocket, Bytes, ClientSockAddr) -> IO ())
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(ListenSocket
socket :: ListenSocket, Bytes
bytes :: Bytes.Bytes, ClientSockAddr
addr :: ClientSockAddr) ->
      ListenSocket -> ByteString -> ClientSockAddr -> IO ()
UDP.sendTo ListenSocket
socket (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
bytes) ClientSockAddr
addr
  ForeignFunc
IO_openFile_impl_v3 -> ((Text, IOMode) -> IO Handle) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Text, IOMode) -> IO Handle)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Text, IOMode) -> IO Handle)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Text
fnameText :: Util.Text.Text, IOMode
mode :: IOMode) ->
    let fname :: [Char]
fname = Text -> [Char]
Util.Text.toString Text
fnameText
     in [Char] -> IOMode -> IO Handle
openFile [Char]
fname IOMode
mode
  ForeignFunc
IO_closeFile_impl_v3 -> (Handle -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Handle -> IO ()
hClose
  ForeignFunc
IO_isFileEOF_impl_v3 -> (Handle -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Handle -> IO Bool
hIsEOF
  ForeignFunc
IO_isFileOpen_impl_v3 -> (Handle -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Handle -> IO Bool
hIsOpen
  ForeignFunc
IO_getEcho_impl_v1 -> (Handle -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Handle -> IO Bool
hGetEcho
  ForeignFunc
IO_ready_impl_v1 -> (Handle -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Handle -> IO Bool
hReady
  ForeignFunc
IO_getChar_impl_v1 -> (Handle -> IO Char) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Handle -> IO Char
hGetChar
  ForeignFunc
IO_isSeekable_impl_v3 -> (Handle -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Handle -> IO Bool
hIsSeekable
  ForeignFunc
IO_seekHandle_impl_v3 -> ((Handle, SeekMode, Int) -> IO ())
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, SeekMode, Int) -> IO ())
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, SeekMode, Int) -> IO ())
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Handle
h, SeekMode
sm, Int
n) -> Handle -> SeekMode -> Integer -> IO ()
hSeek Handle
h SeekMode
sm (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n :: Int))
  ForeignFunc
IO_handlePosition_impl_v3 ->
    -- TODO: truncating integer
    (Handle -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((Handle -> IO Pos) -> Args -> Stack -> IO (Bool, Stack))
-> (Handle -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \Handle
h -> forall a. Num a => Integer -> a
fromInteger @Word64 (Integer -> Pos) -> IO Integer -> IO Pos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Integer
hTell Handle
h
  ForeignFunc
IO_getBuffering_impl_v3 -> (Handle -> IO BufferMode) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Handle -> IO BufferMode
hGetBuffering
  ForeignFunc
IO_setBuffering_impl_v3 ->
    ((Handle, BufferMode) -> IO ())
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, BufferMode) -> IO ())
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, BufferMode) -> IO ())
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      (Handle -> BufferMode -> IO ()) -> (Handle, BufferMode) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Handle -> BufferMode -> IO ()
hSetBuffering
  ForeignFunc
IO_setEcho_impl_v1 -> ((Handle, Bool) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, Bool) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, Bool) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ (Handle -> Bool -> IO ()) -> (Handle, Bool) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Handle -> Bool -> IO ()
hSetEcho
  ForeignFunc
IO_getLine_impl_v1 ->
    (Handle -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((Handle -> IO Text) -> Args -> Stack -> IO (Bool, Stack))
-> (Handle -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      (Text -> Text) -> IO Text -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
Util.Text.fromText (IO Text -> IO Text) -> (Handle -> IO Text) -> Handle -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO Text
Text.IO.hGetLine
  ForeignFunc
IO_getBytes_impl_v3 -> ((Handle, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Handle
h, Int
n) -> ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (ByteString -> Bytes) -> IO ByteString -> IO Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Int -> IO ByteString
hGet Handle
h Int
n
  ForeignFunc
IO_getSomeBytes_impl_v1 -> ((Handle, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Handle
h, Int
n) -> ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (ByteString -> Bytes) -> IO ByteString -> IO Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Int -> IO ByteString
hGetSome Handle
h Int
n
  ForeignFunc
IO_putBytes_impl_v3 -> ((Handle, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Handle
h, Bytes
bs) -> Handle -> ByteString -> IO ()
hPut Handle
h (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
bs)
  ForeignFunc
IO_systemTime_impl_v3 -> (() -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((() -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> IO POSIXTime
getPOSIXTime
  ForeignFunc
IO_systemTimeMicroseconds_v1 -> (() -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> (POSIXTime -> POSIXTime) -> IO POSIXTime -> IO POSIXTime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (POSIXTime
1e6 POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
*) IO POSIXTime
getPOSIXTime
  ForeignFunc
Clock_internals_monotonic_v1 -> (() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> Clock -> IO TimeSpec
getTime Clock
Monotonic
  ForeignFunc
Clock_internals_realtime_v1 -> (() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> Clock -> IO TimeSpec
getTime Clock
Realtime
  ForeignFunc
Clock_internals_processCPUTime_v1 -> (() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> Clock -> IO TimeSpec
getTime Clock
ProcessCPUTime
  ForeignFunc
Clock_internals_threadCPUTime_v1 -> (() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO TimeSpec) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> Clock -> IO TimeSpec
getTime Clock
ThreadCPUTime
  ForeignFunc
Clock_internals_sec_v1 -> (TimeSpec -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (\TimeSpec
n -> Pos -> IO Pos
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Pos) -> Int64 -> Pos
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Int64
sec TimeSpec
n :: Word64))
  ForeignFunc
Clock_internals_nsec_v1 -> (TimeSpec -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (\TimeSpec
n -> Pos -> IO Pos
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Pos) -> Int64 -> Pos
forall a b. (a -> b) -> a -> b
$ TimeSpec -> Int64
nsec TimeSpec
n :: Word64))
  ForeignFunc
Clock_internals_systemTimeZone_v1 ->
    (Int -> IO (Int, Bool, [Char]))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign
      ( \Int
secs -> do
          TimeZone Int
offset Bool
summer [Char]
name <- UTCTime -> IO TimeZone
getTimeZone (POSIXTime -> UTCTime
posixSecondsToUTCTime (Int -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
secs :: Int)))
          (Int, Bool, [Char]) -> IO (Int, Bool, [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
offset :: Int, Bool
summer, [Char]
name)
      )
  ForeignFunc
IO_getTempDirectory_impl_v3 ->
    (() -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((() -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \() -> [Char] -> [Char]
chop ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
getTemporaryDirectory
  ForeignFunc
IO_createTempDirectory_impl_v3 -> ([Char] -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (([Char] -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> ([Char] -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \[Char]
prefix -> do
    [Char]
temp <- IO [Char]
getTemporaryDirectory
    [Char] -> [Char]
chop ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> IO [Char]
createTempDirectory [Char]
temp [Char]
prefix
  ForeignFunc
IO_getCurrentDirectory_impl_v3 -> (() -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((() -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> IO [Char]
getCurrentDirectory
  ForeignFunc
IO_setCurrentDirectory_impl_v3 -> ([Char] -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF [Char] -> IO ()
setCurrentDirectory
  ForeignFunc
IO_fileExists_impl_v3 -> ([Char] -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF [Char] -> IO Bool
doesPathExist
  ForeignFunc
IO_getEnv_impl_v1 -> ([Char] -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF [Char] -> IO [Char]
getEnv
  ForeignFunc
IO_getArgs_impl_v1 -> (() -> IO [Text]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((() -> IO [Text]) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO [Text]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Text
Util.Text.pack ([[Char]] -> [Text]) -> IO [[Char]] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [[Char]]
SYS.getArgs
  ForeignFunc
IO_isDirectory_impl_v3 -> ([Char] -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF [Char] -> IO Bool
doesDirectoryExist
  ForeignFunc
IO_createDirectory_impl_v3 ->
    ([Char] -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (([Char] -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> ([Char] -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True
  ForeignFunc
IO_removeDirectory_impl_v3 -> ([Char] -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF [Char] -> IO ()
removeDirectoryRecursive
  ForeignFunc
IO_renameDirectory_impl_v3 ->
    (([Char], [Char]) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((([Char], [Char]) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (([Char], [Char]) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      ([Char] -> [Char] -> IO ()) -> ([Char], [Char]) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> IO ()
renameDirectory
  ForeignFunc
IO_directoryContents_impl_v3 ->
    ([Char] -> IO [Text]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (([Char] -> IO [Text]) -> Args -> Stack -> IO (Bool, Stack))
-> ([Char] -> IO [Text]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      (([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Text
Util.Text.pack ([[Char]] -> [Text]) -> IO [[Char]] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO [[Char]] -> IO [Text])
-> ([Char] -> IO [[Char]]) -> [Char] -> IO [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO [[Char]]
getDirectoryContents
  ForeignFunc
IO_removeFile_impl_v3 -> ([Char] -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF [Char] -> IO ()
removeFile
  ForeignFunc
IO_renameFile_impl_v3 ->
    (([Char], [Char]) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((([Char], [Char]) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (([Char], [Char]) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      ([Char] -> [Char] -> IO ()) -> ([Char], [Char]) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> IO ()
renameFile
  ForeignFunc
IO_getFileTimestamp_impl_v3 ->
    ([Char] -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (([Char] -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack))
-> ([Char] -> IO POSIXTime) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      (UTCTime -> POSIXTime) -> IO UTCTime -> IO POSIXTime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (IO UTCTime -> IO POSIXTime)
-> ([Char] -> IO UTCTime) -> [Char] -> IO POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO UTCTime
getModificationTime
  ForeignFunc
IO_getFileSize_impl_v3 ->
    -- TODO: truncating integer
    ([Char] -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (([Char] -> IO Pos) -> Args -> Stack -> IO (Bool, Stack))
-> ([Char] -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \[Char]
fp -> forall a. Num a => Integer -> a
fromInteger @Word64 (Integer -> Pos) -> IO Integer -> IO Pos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Integer
getFileSize [Char]
fp
  ForeignFunc
IO_serverSocket_impl_v3 ->
    ((Maybe Text, [Char]) -> IO Socket)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Maybe Text, [Char]) -> IO Socket)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Maybe Text, [Char]) -> IO Socket)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \( Maybe Text
mhst :: Maybe Util.Text.Text,
         [Char]
port
         ) ->
          (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst ((Socket, SockAddr) -> Socket)
-> IO (Socket, SockAddr) -> IO Socket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostPreference -> [Char] -> IO (Socket, SockAddr)
forall (m :: * -> *).
MonadIO m =>
HostPreference -> [Char] -> m (Socket, SockAddr)
SYS.bindSock (Maybe Text -> HostPreference
hostPreference Maybe Text
mhst) [Char]
port
  ForeignFunc
Socket_toText -> (Socket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Socket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> (Socket -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Socket
sock :: Socket) -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ Socket -> [Char]
forall a. Show a => a -> [Char]
show Socket
sock
  ForeignFunc
Handle_toText -> (Handle -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Handle -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> (Handle -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Handle
hand :: Handle) -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ Handle -> [Char]
forall a. Show a => a -> [Char]
show Handle
hand
  ForeignFunc
ThreadId_toText -> (ThreadId -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ThreadId -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> (ThreadId -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(ThreadId
threadId :: ThreadId) -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ ThreadId -> [Char]
forall a. Show a => a -> [Char]
show ThreadId
threadId
  ForeignFunc
IO_socketPort_impl_v3 -> (Socket -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((Socket -> IO Pos) -> Args -> Stack -> IO (Bool, Stack))
-> (Socket -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Socket
handle :: Socket) -> do
      PortNumber
n <- Socket -> IO PortNumber
SYS.socketPort Socket
handle
      return (PortNumber -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
n :: Word64)
  ForeignFunc
IO_listen_impl_v3 -> (Socket -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((Socket -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (Socket -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \Socket
sk -> Socket -> Int -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> Int -> m ()
SYS.listenSock Socket
sk Int
2048
  ForeignFunc
IO_clientSocket_impl_v3 ->
    (([Char], [Char]) -> IO Socket)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((([Char], [Char]) -> IO Socket)
 -> Args -> Stack -> IO (Bool, Stack))
-> (([Char], [Char]) -> IO Socket)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      ((Socket, SockAddr) -> Socket)
-> IO (Socket, SockAddr) -> IO Socket
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst (IO (Socket, SockAddr) -> IO Socket)
-> (([Char], [Char]) -> IO (Socket, SockAddr))
-> ([Char], [Char])
-> IO Socket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> IO (Socket, SockAddr))
-> ([Char], [Char]) -> IO (Socket, SockAddr)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> IO (Socket, SockAddr)
forall (m :: * -> *).
MonadIO m =>
[Char] -> [Char] -> m (Socket, SockAddr)
SYS.connectSock
  ForeignFunc
IO_closeSocket_impl_v3 -> (Socket -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Socket -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> m ()
SYS.closeSock
  ForeignFunc
IO_socketAccept_impl_v3 ->
    (Socket -> IO Socket) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((Socket -> IO Socket) -> Args -> Stack -> IO (Bool, Stack))
-> (Socket -> IO Socket) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      ((Socket, SockAddr) -> Socket)
-> IO (Socket, SockAddr) -> IO Socket
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst (IO (Socket, SockAddr) -> IO Socket)
-> (Socket -> IO (Socket, SockAddr)) -> Socket -> IO Socket
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Socket -> IO (Socket, SockAddr)
SYS.accept
  ForeignFunc
IO_socketSend_impl_v3 -> ((Socket, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Socket, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> ((Socket, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Socket
sk, Bytes
bs) -> Socket -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Socket -> ByteString -> m ()
SYS.send Socket
sk (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
bs)
  ForeignFunc
IO_socketReceive_impl_v3 -> ((Socket, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Socket, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> ((Socket, Int) -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Socket
hs, Int
n) ->
      Bytes -> (ByteString -> Bytes) -> Maybe ByteString -> Bytes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bytes
forall a. Monoid a => a
mempty ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (Maybe ByteString -> Bytes) -> IO (Maybe ByteString) -> IO Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO (Maybe ByteString)
forall (m :: * -> *).
MonadIO m =>
Socket -> Int -> m (Maybe ByteString)
SYS.recv Socket
hs Int
n
  ForeignFunc
IO_kill_impl_v3 -> (ThreadId -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ThreadId -> IO ()
killThread
  ForeignFunc
IO_delay_impl_v3 -> (Pos -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF Pos -> IO ()
customDelay
  ForeignFunc
IO_stdHandle -> (StdHnd -> IO Handle) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((StdHnd -> IO Handle) -> Args -> Stack -> IO (Bool, Stack))
-> (StdHnd -> IO Handle) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \case
      StdHnd
StdIn -> Handle -> IO Handle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
SYS.stdin
      StdHnd
StdOut -> Handle -> IO Handle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
SYS.stdout
      StdHnd
StdErr -> Handle -> IO Handle
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Handle
SYS.stderr
  ForeignFunc
IO_process_call -> (([Char], [Text]) -> IO Int) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((([Char], [Text]) -> IO Int) -> Args -> Stack -> IO (Bool, Stack))
-> (([Char], [Text]) -> IO Int)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \([Char]
exe, (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
Util.Text.unpack -> [[Char]]
args) ->
      CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Int)
-> IO Int
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess ([Char] -> [[Char]] -> CreateProcess
proc [Char]
exe [[Char]]
args) ((Maybe Handle
  -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Int)
 -> IO Int)
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO Int)
-> IO Int
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
p ->
        ExitCode -> Int
exitDecode (ExitCode -> Int) -> IO ExitCode -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p
  ForeignFunc
IO_process_start -> (([Char], [Text]) -> IO (Handle, Handle, Handle, ProcessHandle))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((([Char], [Text]) -> IO (Handle, Handle, Handle, ProcessHandle))
 -> Args -> Stack -> IO (Bool, Stack))
-> (([Char], [Text]) -> IO (Handle, Handle, Handle, ProcessHandle))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \([Char]
exe, (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
Util.Text.unpack -> [[Char]]
args) ->
    [Char]
-> [[Char]]
-> Maybe [Char]
-> Maybe [([Char], [Char])]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess [Char]
exe [[Char]]
args Maybe [Char]
forall a. Maybe a
Nothing Maybe [([Char], [Char])]
forall a. Maybe a
Nothing
  ForeignFunc
IO_process_kill -> (ProcessHandle -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ProcessHandle -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (ProcessHandle -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
terminateProcess
  ForeignFunc
IO_process_wait -> (ProcessHandle -> IO Int) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ProcessHandle -> IO Int) -> Args -> Stack -> IO (Bool, Stack))
-> (ProcessHandle -> IO Int) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \ProcessHandle
ph -> ExitCode -> Int
exitDecode (ExitCode -> Int) -> IO ExitCode -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
  ForeignFunc
IO_process_exitCode ->
    (ProcessHandle -> IO (Maybe Int))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ProcessHandle -> IO (Maybe Int))
 -> Args -> Stack -> IO (Bool, Stack))
-> (ProcessHandle -> IO (Maybe Int))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      (Maybe ExitCode -> Maybe Int)
-> IO (Maybe ExitCode) -> IO (Maybe Int)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ExitCode -> Int) -> Maybe ExitCode -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ExitCode -> Int
exitDecode) (IO (Maybe ExitCode) -> IO (Maybe Int))
-> (ProcessHandle -> IO (Maybe ExitCode))
-> ProcessHandle
-> IO (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode
  ForeignFunc
MVar_new -> (Val -> IO (MVar Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Val -> IO (MVar Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (Val -> IO (MVar Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Val
c :: Val) -> Val -> IO (MVar Val)
forall a. a -> IO (MVar a)
newMVar Val
c
  ForeignFunc
MVar_newEmpty_v2 -> (() -> IO (MVar Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO (MVar Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO (MVar Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> forall a. IO (MVar a)
newEmptyMVar @Val
  ForeignFunc
MVar_take_impl_v3 -> (MVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((MVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (MVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MVar Val
mv :: MVar Val) -> MVar Val -> IO Val
forall a. MVar a -> IO a
takeMVar MVar Val
mv
  ForeignFunc
MVar_tryTake -> (MVar Val -> IO (Maybe Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((MVar Val -> IO (Maybe Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (MVar Val -> IO (Maybe Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MVar Val
mv :: MVar Val) -> MVar Val -> IO (Maybe Val)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Val
mv
  ForeignFunc
MVar_put_impl_v3 -> ((MVar Val, Val) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((MVar Val, Val) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> ((MVar Val, Val) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MVar Val
mv :: MVar Val, Val
x) -> MVar Val -> Val -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Val
mv Val
x
  ForeignFunc
MVar_tryPut_impl_v3 -> ((MVar Val, Val) -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((MVar Val, Val) -> IO Bool) -> Args -> Stack -> IO (Bool, Stack))
-> ((MVar Val, Val) -> IO Bool)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MVar Val
mv :: MVar Val, Val
x) -> MVar Val -> Val -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar Val
mv Val
x
  ForeignFunc
MVar_swap_impl_v3 -> ((MVar Val, Val) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((MVar Val, Val) -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> ((MVar Val, Val) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MVar Val
mv :: MVar Val, Val
x) -> MVar Val -> Val -> IO Val
forall a. MVar a -> a -> IO a
swapMVar MVar Val
mv Val
x
  ForeignFunc
MVar_isEmpty -> (MVar Val -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((MVar Val -> IO Bool) -> Args -> Stack -> IO (Bool, Stack))
-> (MVar Val -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MVar Val
mv :: MVar Val) -> MVar Val -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar MVar Val
mv
  ForeignFunc
MVar_read_impl_v3 -> (MVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((MVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (MVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MVar Val
mv :: MVar Val) -> MVar Val -> IO Val
forall a. MVar a -> IO a
readMVar MVar Val
mv
  ForeignFunc
MVar_tryRead_impl_v3 -> (MVar Val -> IO (Maybe Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF ((MVar Val -> IO (Maybe Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (MVar Val -> IO (Maybe Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MVar Val
mv :: MVar Val) -> MVar Val -> IO (Maybe Val)
forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar Val
mv
  ForeignFunc
Char_toText -> (Char -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Char -> IO Text) -> Args -> Stack -> IO (Bool, Stack))
-> (Char -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Char
ch :: Char) -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Text
Util.Text.singleton Char
ch)
  ForeignFunc
Text_repeat -> ((Pos, Text) -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Pos, Text) -> IO Text) -> Args -> Stack -> IO (Bool, Stack))
-> ((Pos, Text) -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Pos
n :: Word64, Text
txt :: Util.Text.Text) -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Text -> Text
Util.Text.replicate (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
n) Text
txt)
  ForeignFunc
Text_reverse ->
    (Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (Text -> Text) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.Text.reverse
  ForeignFunc
Text_toUppercase ->
    (Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (Text -> Text) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.Text.toUppercase
  ForeignFunc
Text_toLowercase ->
    (Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (Text -> Text) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.Text.toLowercase
  ForeignFunc
Text_toUtf8 ->
    (Text -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Text -> Bytes) -> Text -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bytes
Util.Text.toUtf8
  ForeignFunc
Text_fromUtf8_impl_v3 ->
    (Bytes -> IO (Either (Failure Val) Text))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either (Failure Val) Text))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either (Failure Val) Text))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either (Failure Val) Text -> IO (Either (Failure Val) Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Text -> IO (Either (Failure Val) Text))
-> (Bytes -> Either (Failure Val) Text)
-> Bytes
-> IO (Either (Failure Val) Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Failure Val)
-> Either [Char] Text -> Either (Failure Val) Text
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (\[Char]
t -> Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.ioFailureRef ([Char] -> Text
Util.Text.pack [Char]
t) Val
unitValue) (Either [Char] Text -> Either (Failure Val) Text)
-> (Bytes -> Either [Char] Text)
-> Bytes
-> Either (Failure Val) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Either [Char] Text
Util.Text.fromUtf8
  ForeignFunc
Tls_ClientConfig_default -> ((Text, Bytes) -> IO ClientParams)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Text, Bytes) -> IO ClientParams)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Text, Bytes) -> IO ClientParams)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Text
hostName :: Util.Text.Text, Bytes
serverId :: Bytes.Bytes) ->
      (CertificateStore -> ClientParams)
-> IO CertificateStore -> IO ClientParams
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( \CertificateStore
store ->
            ([Char] -> ByteString -> ClientParams
defaultParamsClient (Text -> [Char]
Util.Text.unpack Text
hostName) (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
serverId))
              { TLS.clientSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong},
                TLS.clientShared = def {TLS.sharedCAStore = store}
              }
        )
        IO CertificateStore
X.getSystemCertificateStore
  ForeignFunc
Tls_ServerConfig_default ->
    (([SignedCertificate], PrivKey) -> IO ServerParams)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((([SignedCertificate], PrivKey) -> IO ServerParams)
 -> Args -> Stack -> IO (Bool, Stack))
-> (([SignedCertificate], PrivKey) -> IO ServerParams)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \([SignedCertificate]
certs :: [X.SignedCertificate], PrivKey
key :: X.PrivKey) ->
        ServerParams -> IO ServerParams
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerParams -> IO ServerParams)
-> ServerParams -> IO ServerParams
forall a b. (a -> b) -> a -> b
$
          (ServerParams
forall a. Default a => a
def :: TLS.ServerParams)
            { TLS.serverSupported = def {TLS.supportedCiphers = Cipher.ciphersuite_strong},
              TLS.serverShared = def {TLS.sharedCredentials = Credentials [(X.CertificateChain certs, key)]}
            }
  ForeignFunc
Tls_ClientConfig_certificates_set ->
    let updateClient :: X.CertificateStore -> TLS.ClientParams -> TLS.ClientParams
        updateClient :: CertificateStore -> ClientParams -> ClientParams
updateClient CertificateStore
certs ClientParams
client = ClientParams
client {TLS.clientShared = ((clientShared client) {TLS.sharedCAStore = certs})}
     in (([SignedCertificate], ClientParams) -> IO ClientParams)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((([SignedCertificate], ClientParams) -> IO ClientParams)
 -> Args -> Stack -> IO (Bool, Stack))
-> (([SignedCertificate], ClientParams) -> IO ClientParams)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
          \([SignedCertificate]
certs :: [X.SignedCertificate], ClientParams
params :: ClientParams) -> ClientParams -> IO ClientParams
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientParams -> IO ClientParams)
-> ClientParams -> IO ClientParams
forall a b. (a -> b) -> a -> b
$ CertificateStore -> ClientParams -> ClientParams
updateClient ([SignedCertificate] -> CertificateStore
X.makeCertificateStore [SignedCertificate]
certs) ClientParams
params
  ForeignFunc
Tls_ServerConfig_certificates_set ->
    let updateServer :: X.CertificateStore -> TLS.ServerParams -> TLS.ServerParams
        updateServer :: CertificateStore -> ServerParams -> ServerParams
updateServer CertificateStore
certs ServerParams
client = ServerParams
client {TLS.serverShared = ((serverShared client) {TLS.sharedCAStore = certs})}
     in (([SignedCertificate], ServerParams) -> IO ServerParams)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((([SignedCertificate], ServerParams) -> IO ServerParams)
 -> Args -> Stack -> IO (Bool, Stack))
-> (([SignedCertificate], ServerParams) -> IO ServerParams)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
          \([SignedCertificate]
certs :: [X.SignedCertificate], ServerParams
params :: ServerParams) -> ServerParams -> IO ServerParams
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerParams -> IO ServerParams)
-> ServerParams -> IO ServerParams
forall a b. (a -> b) -> a -> b
$ CertificateStore -> ServerParams -> ServerParams
updateServer ([SignedCertificate] -> CertificateStore
X.makeCertificateStore [SignedCertificate]
certs) ServerParams
params
  ForeignFunc
TVar_new -> (Val -> IO (TVar Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Val -> IO (TVar Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (Val -> IO (TVar Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Val
c :: Val) -> STM (TVar Val) -> IO (TVar Val)
forall a. STM a -> IO a
unsafeSTMToIO (STM (TVar Val) -> IO (TVar Val))
-> STM (TVar Val) -> IO (TVar Val)
forall a b. (a -> b) -> a -> b
$ Val -> STM (TVar Val)
forall a. a -> STM (TVar a)
STM.newTVar Val
c
  ForeignFunc
TVar_read -> (TVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((TVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (TVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TVar Val
v :: STM.TVar Val) -> STM Val -> IO Val
forall a. STM a -> IO a
unsafeSTMToIO (STM Val -> IO Val) -> STM Val -> IO Val
forall a b. (a -> b) -> a -> b
$ TVar Val -> STM Val
forall a. TVar a -> STM a
STM.readTVar TVar Val
v
  ForeignFunc
TVar_write -> ((TVar Val, Val) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((TVar Val, Val) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> ((TVar Val, Val) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TVar Val
v :: STM.TVar Val, Val
c :: Val) ->
      STM () -> IO ()
forall a. STM a -> IO a
unsafeSTMToIO (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Val -> Val -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Val
v Val
c
  ForeignFunc
TVar_newIO -> (Val -> IO (TVar Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Val -> IO (TVar Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (Val -> IO (TVar Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Val
c :: Val) -> Val -> IO (TVar Val)
forall a. a -> IO (TVar a)
STM.newTVarIO Val
c
  ForeignFunc
TVar_readIO -> (TVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((TVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (TVar Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TVar Val
v :: STM.TVar Val) -> TVar Val -> IO Val
forall a. TVar a -> IO a
STM.readTVarIO TVar Val
v
  ForeignFunc
TVar_swap -> ((TVar Val, Val) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((TVar Val, Val) -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> ((TVar Val, Val) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TVar Val
v, Val
c :: Val) -> STM Val -> IO Val
forall a. STM a -> IO a
unsafeSTMToIO (STM Val -> IO Val) -> STM Val -> IO Val
forall a b. (a -> b) -> a -> b
$ TVar Val -> Val -> STM Val
forall a. TVar a -> a -> STM a
STM.swapTVar TVar Val
v Val
c
  ForeignFunc
STM_retry -> (() -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> STM Val -> IO Val
forall a. STM a -> IO a
unsafeSTMToIO STM Val
forall a. STM a
STM.retry :: IO Val
  ForeignFunc
Promise_new -> (() -> IO (Promise Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO (Promise Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO (Promise Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \() -> forall a. IO (Promise a)
newPromise @Val
  ForeignFunc
Promise_read -> (Promise Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Promise Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Promise Val -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Promise Val
p :: Promise Val) -> Promise Val -> IO Val
forall a. Promise a -> IO a
readPromise Promise Val
p
  ForeignFunc
Promise_tryRead -> (Promise Val -> IO (Maybe Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Promise Val -> IO (Maybe Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Promise Val -> IO (Maybe Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Promise Val
p :: Promise Val) -> Promise Val -> IO (Maybe Val)
forall a. Promise a -> IO (Maybe a)
tryReadPromise Promise Val
p
  ForeignFunc
Promise_write -> ((Promise Val, Val) -> IO Bool)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Promise Val, Val) -> IO Bool)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Promise Val, Val) -> IO Bool)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Promise Val
p :: Promise Val, Val
a :: Val) -> Promise Val -> Val -> IO Bool
forall a. Promise a -> a -> IO Bool
writePromise Promise Val
p Val
a
  ForeignFunc
Tls_newClient_impl_v3 ->
    ((ClientParams, Socket) -> IO Context)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls (((ClientParams, Socket) -> IO Context)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ClientParams, Socket) -> IO Context)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \( ClientParams
config :: TLS.ClientParams,
         Socket
socket :: SYS.Socket
         ) -> Socket -> ClientParams -> IO Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
TLS.contextNew Socket
socket ClientParams
config
  ForeignFunc
Tls_newServer_impl_v3 ->
    ((ServerParams, Socket) -> IO Context)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls (((ServerParams, Socket) -> IO Context)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ServerParams, Socket) -> IO Context)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \( ServerParams
config :: TLS.ServerParams,
         Socket
socket :: SYS.Socket
         ) -> Socket -> ServerParams -> IO Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
TLS.contextNew Socket
socket ServerParams
config
  ForeignFunc
Tls_handshake_impl_v3 -> (Context -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls ((Context -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (Context -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Context
tls :: TLS.Context) -> Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.handshake Context
tls
  ForeignFunc
Tls_send_impl_v3 ->
    ((Context, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls (((Context, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> ((Context, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \( Context
tls :: TLS.Context,
         Bytes
bytes :: Bytes.Bytes
         ) -> Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Context
tls (Bytes -> ByteString
Bytes.toLazyByteString Bytes
bytes)
  ForeignFunc
Tls_decodeCert_impl_v3 ->
    let wrapFailure :: [Char] -> Failure Val
wrapFailure [Char]
t = Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.tlsFailureRef ([Char] -> Text
Util.Text.pack [Char]
t) Val
unitValue
        decoded :: Bytes.Bytes -> Either String PEM
        decoded :: Bytes -> Either [Char] PEM
decoded Bytes
bytes = case ByteString -> Either [Char] [PEM]
pemParseLBS (ByteString -> Either [Char] [PEM])
-> ByteString -> Either [Char] [PEM]
forall a b. (a -> b) -> a -> b
$ Bytes -> ByteString
Bytes.toLazyByteString Bytes
bytes of
          Right (PEM
pem : [PEM]
_) -> PEM -> Either [Char] PEM
forall a b. b -> Either a b
Right PEM
pem
          Right [] -> [Char] -> Either [Char] PEM
forall a b. a -> Either a b
Left [Char]
"no PEM found"
          Left [Char]
l -> [Char] -> Either [Char] PEM
forall a b. a -> Either a b
Left [Char]
l
        asCert :: PEM -> Either String X.SignedCertificate
        asCert :: PEM -> Either [Char] SignedCertificate
asCert PEM
pem = ByteString -> Either [Char] SignedCertificate
X.decodeSignedCertificate (ByteString -> Either [Char] SignedCertificate)
-> ByteString -> Either [Char] SignedCertificate
forall a b. (a -> b) -> a -> b
$ PEM -> ByteString
pemContent PEM
pem
     in (Bytes -> IO (Either (Failure Val) SignedCertificate))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO (Either (Failure Val) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignTlsE ((Bytes -> IO (Either (Failure Val) SignedCertificate))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either (Failure Val) SignedCertificate))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
          \(Bytes
bytes :: Bytes.Bytes) -> Either (Failure Val) SignedCertificate
-> IO (Either (Failure Val) SignedCertificate)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) SignedCertificate
 -> IO (Either (Failure Val) SignedCertificate))
-> Either (Failure Val) SignedCertificate
-> IO (Either (Failure Val) SignedCertificate)
forall a b. (a -> b) -> a -> b
$ ([Char] -> Failure Val)
-> Either [Char] SignedCertificate
-> Either (Failure Val) SignedCertificate
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft [Char] -> Failure Val
wrapFailure (Either [Char] SignedCertificate
 -> Either (Failure Val) SignedCertificate)
-> Either [Char] SignedCertificate
-> Either (Failure Val) SignedCertificate
forall a b. (a -> b) -> a -> b
$ (Bytes -> Either [Char] PEM
decoded (Bytes -> Either [Char] PEM)
-> (PEM -> Either [Char] SignedCertificate)
-> Bytes
-> Either [Char] SignedCertificate
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> PEM -> Either [Char] SignedCertificate
asCert) Bytes
bytes
  ForeignFunc
Tls_encodeCert -> (SignedCertificate -> IO Bytes)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((SignedCertificate -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> (SignedCertificate -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(SignedCertificate
cert :: X.SignedCertificate) -> Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> Bytes -> IO Bytes
forall a b. (a -> b) -> a -> b
$ ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (ByteString -> Bytes) -> ByteString -> Bytes
forall a b. (a -> b) -> a -> b
$ SignedCertificate -> ByteString
forall a.
(Show a, Eq a, ASN1Object a) =>
SignedExact a -> ByteString
X.encodeSignedObject SignedCertificate
cert
  ForeignFunc
Tls_decodePrivateKey -> (Bytes -> IO [PrivKey]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO [PrivKey]) -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO [PrivKey]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Bytes
bytes :: Bytes.Bytes) -> [PrivKey] -> IO [PrivKey]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PrivKey] -> IO [PrivKey]) -> [PrivKey] -> IO [PrivKey]
forall a b. (a -> b) -> a -> b
$ ByteString -> [PrivKey]
X.readKeyFileFromMemory (ByteString -> [PrivKey]) -> ByteString -> [PrivKey]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
L.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Bytes -> ByteString
Bytes.toLazyByteString Bytes
bytes
  ForeignFunc
Tls_encodePrivateKey -> (PrivKey -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((PrivKey -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (PrivKey -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(PrivKey
privateKey :: X.PrivKey) -> Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> Bytes -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Text -> Bytes
Util.Text.toUtf8 (Text -> Bytes) -> Text -> Bytes
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Util.Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ PrivKey -> [Char]
forall a. Show a => a -> [Char]
show PrivKey
privateKey
  ForeignFunc
Tls_receive_impl_v3 -> (Context -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls ((Context -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Context -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Context
tls :: TLS.Context) -> do
      ByteString
bs <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
TLS.recvData Context
tls
      pure $ ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray ByteString
bs
  ForeignFunc
Tls_terminate_impl_v3 -> (Context -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls ((Context -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (Context -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Context
tls :: TLS.Context) -> Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.bye Context
tls
  ForeignFunc
Code_validateLinks -> ([(Referent, Code)]
 -> IO (Either (Failure [Referent]) (Either [Referent] [Referent])))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (([(Referent, Code)]
  -> IO (Either (Failure [Referent]) (Either [Referent] [Referent])))
 -> Args -> Stack -> IO (Bool, Stack))
-> ([(Referent, Code)]
    -> IO (Either (Failure [Referent]) (Either [Referent] [Referent])))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \([(Referent, Code)]
lsgs0 :: [(Referent, ANF.Code)]) -> do
      let f :: (Text, a) -> Failure a
f (Text
msg, a
rs) =
            Reference -> Text -> a -> Failure a
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.miscFailureRef (Text -> Text
Util.Text.fromText Text
msg) a
rs
      Either (Failure [Referent]) (Either [Referent] [Referent])
-> IO (Either (Failure [Referent]) (Either [Referent] [Referent]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure [Referent]) (Either [Referent] [Referent])
 -> IO (Either (Failure [Referent]) (Either [Referent] [Referent])))
-> (Either (Text, [Referent]) (Either [Referent] [Referent])
    -> Either (Failure [Referent]) (Either [Referent] [Referent]))
-> Either (Text, [Referent]) (Either [Referent] [Referent])
-> IO (Either (Failure [Referent]) (Either [Referent] [Referent]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [Referent]) -> Failure [Referent])
-> Either (Text, [Referent]) (Either [Referent] [Referent])
-> Either (Failure [Referent]) (Either [Referent] [Referent])
forall a c b. (a -> c) -> Either a b -> Either c b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text, [Referent]) -> Failure [Referent]
forall {a}. (Text, a) -> Failure a
f (Either (Text, [Referent]) (Either [Referent] [Referent])
 -> IO (Either (Failure [Referent]) (Either [Referent] [Referent])))
-> Either (Text, [Referent]) (Either [Referent] [Referent])
-> IO (Either (Failure [Referent]) (Either [Referent] [Referent]))
forall a b. (a -> b) -> a -> b
$ [(Referent, Code)]
-> Either (Text, [Referent]) (Either [Referent] [Referent])
checkGroupHashes [(Referent, Code)]
lsgs0
  ForeignFunc
Code_dependencies -> (Code -> IO [Foreign]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Code -> IO [Foreign]) -> Args -> Stack -> IO (Bool, Stack))
-> (Code -> IO [Foreign]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(ANF.CodeRep SuperGroup Symbol
sg Cacheability
_) ->
      [Foreign] -> IO [Foreign]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Foreign] -> IO [Foreign]) -> [Foreign] -> IO [Foreign]
forall a b. (a -> b) -> a -> b
$ Reference -> Referent -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Ty.termLinkRef (Referent -> Foreign)
-> (Reference -> Referent) -> Reference -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent
Ref (Reference -> Foreign) -> [Reference] -> [Foreign]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SuperGroup Symbol -> [Reference]
forall v. Var v => SuperGroup v -> [Reference]
ANF.groupTermLinks SuperGroup Symbol
sg
  ForeignFunc
Code_serialize -> (Code -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Code -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Code -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Code
co :: ANF.Code) ->
      Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes)
-> (ByteString -> Bytes) -> ByteString -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (ByteString -> IO Bytes) -> ByteString -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Map ForeignFunc Text -> Code -> ByteString
ANF.serializeCode Map ForeignFunc Text
builtinForeignNames Code
co
  ForeignFunc
Code_deserialize ->
    (Bytes -> IO (Either [Char] Code))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either [Char] Code))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either [Char] Code))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either [Char] Code -> IO (Either [Char] Code)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] Code -> IO (Either [Char] Code))
-> (Bytes -> Either [Char] Code)
-> Bytes
-> IO (Either [Char] Code)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] Code
ANF.deserializeCode (ByteString -> Either [Char] Code)
-> (Bytes -> ByteString) -> Bytes -> Either [Char] Code
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray
  ForeignFunc
Code_display -> ((Text, Code) -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Text, Code) -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack))
-> ((Text, Code) -> IO [Char]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Text
nm, (ANF.CodeRep SuperGroup Symbol
sg Cacheability
_)) ->
      [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$ forall v. Var v => [Char] -> SuperGroup v -> [Char] -> [Char]
ANF.prettyGroup @Symbol (Text -> [Char]
Util.Text.unpack Text
nm) SuperGroup Symbol
sg [Char]
""
  ForeignFunc
Value_dependencies ->
    (Value -> IO [Foreign]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Value -> IO [Foreign]) -> Args -> Stack -> IO (Bool, Stack))
-> (Value -> IO [Foreign]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      [Foreign] -> IO [Foreign]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Foreign] -> IO [Foreign])
-> (Value -> [Foreign]) -> Value -> IO [Foreign]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> Foreign) -> [Reference] -> [Foreign]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Reference -> Referent -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
Ty.termLinkRef (Referent -> Foreign)
-> (Reference -> Referent) -> Reference -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Referent
Ref) ([Reference] -> [Foreign])
-> (Value -> [Reference]) -> Value -> [Foreign]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [Reference]
ANF.valueTermLinks
  ForeignFunc
Value_serialize ->
    (Value -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Value -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Value -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Value -> Bytes) -> Value -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (ByteString -> Bytes) -> (Value -> ByteString) -> Value -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
ANF.serializeValue
  ForeignFunc
Value_deserialize ->
    (Bytes -> IO (Either [Char] Value))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either [Char] Value))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either [Char] Value))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either [Char] Value -> IO (Either [Char] Value)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] Value -> IO (Either [Char] Value))
-> (Bytes -> Either [Char] Value)
-> Bytes
-> IO (Either [Char] Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] Value
ANF.deserializeValue (ByteString -> Either [Char] Value)
-> (Bytes -> ByteString) -> Bytes -> Either [Char] Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray
  ForeignFunc
Crypto_HashAlgorithm_Sha3_512 -> Text -> SHA3_512 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Sha3_512" SHA3_512
Hash.SHA3_512
  ForeignFunc
Crypto_HashAlgorithm_Sha3_256 -> Text -> SHA3_256 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Sha3_256" SHA3_256
Hash.SHA3_256
  ForeignFunc
Crypto_HashAlgorithm_Sha2_512 -> Text -> SHA512 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Sha2_512" SHA512
Hash.SHA512
  ForeignFunc
Crypto_HashAlgorithm_Sha2_256 -> Text -> SHA256 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Sha2_256" SHA256
Hash.SHA256
  ForeignFunc
Crypto_HashAlgorithm_Sha1 -> Text -> SHA1 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Sha1" SHA1
Hash.SHA1
  ForeignFunc
Crypto_HashAlgorithm_Blake2b_512 -> Text -> Blake2b_512 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Blake2b_512" Blake2b_512
Hash.Blake2b_512
  ForeignFunc
Crypto_HashAlgorithm_Blake2b_256 -> Text -> Blake2b_256 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Blake2b_256" Blake2b_256
Hash.Blake2b_256
  ForeignFunc
Crypto_HashAlgorithm_Blake2s_256 -> Text -> Blake2s_256 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Blake2s_256" Blake2s_256
Hash.Blake2s_256
  ForeignFunc
Crypto_HashAlgorithm_Md5 -> Text -> MD5 -> Args -> Stack -> IO (Bool, Stack)
forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
"Md5" MD5
Hash.MD5
  ForeignFunc
Crypto_hashBytes -> ((HashAlgorithm, Bytes) -> IO Bytes)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((HashAlgorithm, Bytes) -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((HashAlgorithm, Bytes) -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(HashAlgorithm Reference
_ a
alg, Bytes
b :: Bytes.Bytes) ->
      let ctx :: Context a
ctx = a -> Context a
forall alg. HashAlgorithm alg => alg -> Context alg
Hash.hashInitWith a
alg
       in Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes)
-> (Context a -> Bytes) -> Context a -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest a -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (Digest a -> Bytes)
-> (Context a -> Digest a) -> Context a -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context a -> Digest a
forall a. HashAlgorithm a => Context a -> Digest a
Hash.hashFinalize (Context a -> IO Bytes) -> Context a -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Context a -> [ByteString] -> Context a
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
Hash.hashUpdates Context a
ctx (Bytes -> [ByteString]
Bytes.byteStringChunks Bytes
b)
  ForeignFunc
Crypto_hmacBytes -> ((HashAlgorithm, Bytes, Bytes) -> IO Bytes)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((HashAlgorithm, Bytes, Bytes) -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((HashAlgorithm, Bytes, Bytes) -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(HashAlgorithm Reference
_ a
alg, Bytes
key :: Bytes.Bytes, Bytes
msg :: Bytes.Bytes) ->
      let out :: HMAC a
out = a -> HMAC a -> HMAC a
forall a. a -> HMAC a -> HMAC a
u a
alg (HMAC a -> HMAC a) -> HMAC a -> HMAC a
forall a b. (a -> b) -> a -> b
$ Bytes -> Bytes -> HMAC a
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
HMAC.hmac (forall b. ByteArray b => Bytes -> b
Bytes.toArray @BA.Bytes Bytes
key) (forall b. ByteArray b => Bytes -> b
Bytes.toArray @BA.Bytes Bytes
msg)
          u :: a -> HMAC.HMAC a -> HMAC.HMAC a
          u :: forall a. a -> HMAC a -> HMAC a
u a
_ HMAC a
h = HMAC a
h -- to help typechecker along
       in Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> Bytes -> IO Bytes
forall a b. (a -> b) -> a -> b
$ HMAC a -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray HMAC a
out
  ForeignFunc
Crypto_hash -> ((HashAlgorithm, Value) -> IO Bytes)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((HashAlgorithm, Value) -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((HashAlgorithm, Value) -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(HashAlgorithm Reference
_ a
alg, Value
x) ->
      let hashlazy ::
            (Hash.HashAlgorithm a) =>
            a ->
            L.ByteString ->
            Hash.Digest a
          hashlazy :: forall a. HashAlgorithm a => a -> ByteString -> Digest a
hashlazy a
_ ByteString
l = ByteString -> Digest a
forall a. HashAlgorithm a => ByteString -> Digest a
Hash.hashlazy ByteString
l
       in Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes)
-> (ByteString -> Bytes) -> ByteString -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest a -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (Digest a -> Bytes)
-> (ByteString -> Digest a) -> ByteString -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString -> Digest a
forall a. HashAlgorithm a => a -> ByteString -> Digest a
hashlazy a
alg (ByteString -> IO Bytes) -> ByteString -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
ANF.serializeValueForHash Value
x
  ForeignFunc
Crypto_hmac -> ((HashAlgorithm, Bytes, Value) -> IO Bytes)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((HashAlgorithm, Bytes, Value) -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((HashAlgorithm, Bytes, Value) -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(HashAlgorithm Reference
_ a
alg, Bytes
key, Value
x) ->
      let hmac ::
            (Hash.HashAlgorithm a) => a -> L.ByteString -> HMAC.HMAC a
          hmac :: forall a. HashAlgorithm a => a -> ByteString -> HMAC a
hmac a
_ ByteString
s =
            Context a -> HMAC a
forall a. HashAlgorithm a => Context a -> HMAC a
HMAC.finalize
              (Context a -> HMAC a)
-> ([ByteString] -> Context a) -> [ByteString] -> HMAC a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context a -> [ByteString] -> Context a
forall message a.
(ByteArrayAccess message, HashAlgorithm a) =>
Context a -> [message] -> Context a
HMAC.updates
                (Bytes -> Context a
forall key a.
(ByteArrayAccess key, HashAlgorithm a) =>
key -> Context a
HMAC.initialize (Bytes -> Context a) -> Bytes -> Context a
forall a b. (a -> b) -> a -> b
$ forall b. ByteArray b => Bytes -> b
Bytes.toArray @BA.Bytes Bytes
key)
              ([ByteString] -> HMAC a) -> [ByteString] -> HMAC a
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
s
       in Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes)
-> (ByteString -> Bytes) -> ByteString -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HMAC a -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (HMAC a -> Bytes) -> (ByteString -> HMAC a) -> ByteString -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString -> HMAC a
forall a. HashAlgorithm a => a -> ByteString -> HMAC a
hmac a
alg (ByteString -> IO Bytes) -> ByteString -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
ANF.serializeValueForHash Value
x
  ForeignFunc
Crypto_Ed25519_sign_impl ->
    ((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bytes))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either (Failure Val) Bytes -> IO (Either (Failure Val) Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Bytes -> IO (Either (Failure Val) Bytes))
-> ((Bytes, Bytes, Bytes) -> Either (Failure Val) Bytes)
-> (Bytes, Bytes, Bytes)
-> IO (Either (Failure Val) Bytes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bytes, Bytes, Bytes) -> Either (Failure Val) Bytes
signEd25519Wrapper
  ForeignFunc
Crypto_Ed25519_verify_impl ->
    ((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bool))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bool))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bool))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either (Failure Val) Bool -> IO (Either (Failure Val) Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Bool -> IO (Either (Failure Val) Bool))
-> ((Bytes, Bytes, Bytes) -> Either (Failure Val) Bool)
-> (Bytes, Bytes, Bytes)
-> IO (Either (Failure Val) Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bytes, Bytes, Bytes) -> Either (Failure Val) Bool
verifyEd25519Wrapper
  ForeignFunc
Crypto_Rsa_sign_impl ->
    ((Bytes, Bytes) -> IO (Either (Failure Val) Bytes))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Bytes, Bytes) -> IO (Either (Failure Val) Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Bytes, Bytes) -> IO (Either (Failure Val) Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either (Failure Val) Bytes -> IO (Either (Failure Val) Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Bytes -> IO (Either (Failure Val) Bytes))
-> ((Bytes, Bytes) -> Either (Failure Val) Bytes)
-> (Bytes, Bytes)
-> IO (Either (Failure Val) Bytes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bytes, Bytes) -> Either (Failure Val) Bytes
signRsaWrapper
  ForeignFunc
Crypto_Rsa_verify_impl ->
    ((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bool))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bool))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Bytes, Bytes, Bytes) -> IO (Either (Failure Val) Bool))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either (Failure Val) Bool -> IO (Either (Failure Val) Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Bool -> IO (Either (Failure Val) Bool))
-> ((Bytes, Bytes, Bytes) -> Either (Failure Val) Bool)
-> (Bytes, Bytes, Bytes)
-> IO (Either (Failure Val) Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bytes, Bytes, Bytes) -> Either (Failure Val) Bool
verifyRsaWrapper
  ForeignFunc
Universal_murmurHash ->
    (Value -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Value -> IO Pos) -> Args -> Stack -> IO (Bool, Stack))
-> (Value -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Pos -> IO Pos
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos -> IO Pos) -> (Value -> Pos) -> Value -> IO Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash64 -> Pos
asWord64 (Hash64 -> Pos) -> (Value -> Hash64) -> Value -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash64
forall a. Hashable64 a => a -> Hash64
hash64 (ByteString -> Hash64) -> (Value -> ByteString) -> Value -> Hash64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
ANF.serializeValueForHash
  ForeignFunc
IO_randomBytes -> (Int -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Int -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Int -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \Int
n -> ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (ByteString -> Bytes) -> IO ByteString -> IO Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes @IO @ByteString Int
n
  ForeignFunc
Bytes_zlib_compress -> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Bytes -> Bytes) -> Bytes -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Bytes
Bytes.zlibCompress
  ForeignFunc
Bytes_gzip_compress -> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Bytes -> Bytes) -> Bytes -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Bytes
Bytes.gzipCompress
  ForeignFunc
Bytes_zlib_decompress -> (Bytes -> IO (Either Text Bytes))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either Text Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either Text Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \Bytes
bs ->
    IO Bytes -> IO (Either Text Bytes)
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m, NFData a) =>
m a -> m (Either Text a)
catchAll (Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Bytes
Bytes.zlibDecompress Bytes
bs))
  ForeignFunc
Bytes_gzip_decompress -> (Bytes -> IO (Either Text Bytes))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either Text Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either Text Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \Bytes
bs ->
    IO Bytes -> IO (Either Text Bytes)
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m, NFData a) =>
m a -> m (Either Text a)
catchAll (Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Bytes
Bytes.gzipDecompress Bytes
bs))
  ForeignFunc
Bytes_toBase16 -> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Bytes -> Bytes) -> Bytes -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Bytes
Bytes.toBase16
  ForeignFunc
Bytes_toBase32 -> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Bytes -> Bytes) -> Bytes -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Bytes
Bytes.toBase32
  ForeignFunc
Bytes_toBase64 -> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Bytes -> Bytes) -> Bytes -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Bytes
Bytes.toBase64
  ForeignFunc
Bytes_toBase64UrlUnpadded -> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Bytes -> Bytes) -> Bytes -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Bytes
Bytes.toBase64UrlUnpadded
  ForeignFunc
Bytes_fromBase16 ->
    (Bytes -> IO (Either Text Bytes))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either Text Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either Text Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either Text Bytes -> IO (Either Text Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Bytes -> IO (Either Text Bytes))
-> (Bytes -> Either Text Bytes) -> Bytes -> IO (Either Text Bytes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> Either Text Bytes -> Either Text Bytes
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft Text -> Text
Util.Text.fromText (Either Text Bytes -> Either Text Bytes)
-> (Bytes -> Either Text Bytes) -> Bytes -> Either Text Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Either Text Bytes
Bytes.fromBase16
  ForeignFunc
Bytes_fromBase32 ->
    (Bytes -> IO (Either Text Bytes))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either Text Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either Text Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either Text Bytes -> IO (Either Text Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Bytes -> IO (Either Text Bytes))
-> (Bytes -> Either Text Bytes) -> Bytes -> IO (Either Text Bytes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> Either Text Bytes -> Either Text Bytes
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft Text -> Text
Util.Text.fromText (Either Text Bytes -> Either Text Bytes)
-> (Bytes -> Either Text Bytes) -> Bytes -> Either Text Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Either Text Bytes
Bytes.fromBase32
  ForeignFunc
Bytes_fromBase64 ->
    (Bytes -> IO (Either Text Bytes))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either Text Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either Text Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either Text Bytes -> IO (Either Text Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Bytes -> IO (Either Text Bytes))
-> (Bytes -> Either Text Bytes) -> Bytes -> IO (Either Text Bytes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> Either Text Bytes -> Either Text Bytes
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft Text -> Text
Util.Text.fromText (Either Text Bytes -> Either Text Bytes)
-> (Bytes -> Either Text Bytes) -> Bytes -> Either Text Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Either Text Bytes
Bytes.fromBase64
  ForeignFunc
Bytes_fromBase64UrlUnpadded ->
    (Bytes -> IO (Either Text Bytes))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Either Text Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either Text Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either Text Bytes -> IO (Either Text Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Bytes -> IO (Either Text Bytes))
-> (Bytes -> Either Text Bytes) -> Bytes -> IO (Either Text Bytes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> Either Text Bytes -> Either Text Bytes
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft Text -> Text
Util.Text.fromText (Either Text Bytes -> Either Text Bytes)
-> (Bytes -> Either Text Bytes) -> Bytes -> Either Text Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Either Text Bytes
Bytes.fromBase64UrlUnpadded
  ForeignFunc
Bytes_decodeNat64be -> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Maybe (Pos, Bytes)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes)))
-> (Bytes -> Maybe (Pos, Bytes))
-> Bytes
-> IO (Maybe (Pos, Bytes))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Maybe (Pos, Bytes)
Bytes.decodeNat64be
  ForeignFunc
Bytes_decodeNat64le -> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Maybe (Pos, Bytes)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes)))
-> (Bytes -> Maybe (Pos, Bytes))
-> Bytes
-> IO (Maybe (Pos, Bytes))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Maybe (Pos, Bytes)
Bytes.decodeNat64le
  ForeignFunc
Bytes_decodeNat32be -> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Maybe (Pos, Bytes)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes)))
-> (Bytes -> Maybe (Pos, Bytes))
-> Bytes
-> IO (Maybe (Pos, Bytes))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Maybe (Pos, Bytes)
Bytes.decodeNat32be
  ForeignFunc
Bytes_decodeNat32le -> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Maybe (Pos, Bytes)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes)))
-> (Bytes -> Maybe (Pos, Bytes))
-> Bytes
-> IO (Maybe (Pos, Bytes))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Maybe (Pos, Bytes)
Bytes.decodeNat32le
  ForeignFunc
Bytes_decodeNat16be -> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Maybe (Pos, Bytes)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes)))
-> (Bytes -> Maybe (Pos, Bytes))
-> Bytes
-> IO (Maybe (Pos, Bytes))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Maybe (Pos, Bytes)
Bytes.decodeNat16be
  ForeignFunc
Bytes_decodeNat16le -> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO (Maybe (Pos, Bytes)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Maybe (Pos, Bytes)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Pos, Bytes) -> IO (Maybe (Pos, Bytes)))
-> (Bytes -> Maybe (Pos, Bytes))
-> Bytes
-> IO (Maybe (Pos, Bytes))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Maybe (Pos, Bytes)
Bytes.decodeNat16le
  ForeignFunc
Bytes_encodeNat64be -> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Pos -> Bytes) -> Pos -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Bytes
Bytes.encodeNat64be
  ForeignFunc
Bytes_encodeNat64le -> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Pos -> Bytes) -> Pos -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Bytes
Bytes.encodeNat64le
  ForeignFunc
Bytes_encodeNat32be -> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Pos -> Bytes) -> Pos -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Bytes
Bytes.encodeNat32be
  ForeignFunc
Bytes_encodeNat32le -> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Pos -> Bytes) -> Pos -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Bytes
Bytes.encodeNat32le
  ForeignFunc
Bytes_encodeNat16be -> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Pos -> Bytes) -> Pos -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Bytes
Bytes.encodeNat16be
  ForeignFunc
Bytes_encodeNat16le -> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Pos -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Bytes -> IO Bytes
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> IO Bytes) -> (Pos -> Bytes) -> Pos -> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Bytes
Bytes.encodeNat16le
  ForeignFunc
MutableArray_copyTo_force -> ((MutableArray RealWorld Val, Pos, MutableArray RealWorld Val, Pos,
  Pos)
 -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableArray RealWorld Val, Pos, MutableArray RealWorld Val,
   Pos, Pos)
  -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableArray RealWorld Val, Pos, MutableArray RealWorld Val,
     Pos, Pos)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MutableArray RealWorld Val
dst, Pos
doff, MutableArray RealWorld Val
src, Pos
soff, Pos
l) ->
      let name :: Text
name = Text
"MutableArray.copyTo!"
       in if Pos
l Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
0
            then Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())
            else
              Text
-> Int
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds Text
name (MutableArray RealWorld Val -> Int
forall s a. MutableArray s a -> Int
PA.sizeofMutableArray MutableArray RealWorld Val
dst) (Pos
doff Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
l Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
- Pos
1) (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$
                Text
-> Int
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds Text
name (MutableArray RealWorld Val -> Int
forall s a. MutableArray s a -> Int
PA.sizeofMutableArray MutableArray RealWorld Val
src) (Pos
soff Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
l Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
- Pos
1) (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$
                  () -> Either (Failure Val) ()
forall a b. b -> Either a b
Right
                    (() -> Either (Failure Val) ())
-> IO () -> IO (Either (Failure Val) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> MutableArray (PrimState m) a -> Int -> Int -> m ()
PA.copyMutableArray @IO @Val
                      MutableArray RealWorld Val
MutableArray RW Val
dst
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
doff)
                      MutableArray RealWorld Val
MutableArray RW Val
src
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
soff)
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
l)
  ForeignFunc
MutableByteArray_copyTo_force -> ((MutableByteArray RealWorld, Pos, MutableByteArray RealWorld, Pos,
  Pos)
 -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RealWorld, Pos, MutableByteArray RealWorld,
   Pos, Pos)
  -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RealWorld, Pos, MutableByteArray RealWorld,
     Pos, Pos)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MutableByteArray RealWorld
dst, Pos
doff, MutableByteArray RealWorld
src, Pos
soff, Pos
l) ->
      let name :: Text
name = Text
"MutableByteArray.copyTo!"
       in if Pos
l Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
0
            then Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())
            else
              Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
dst) (Pos
doff Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
l) Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$
                Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
src) (Pos
soff Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
l) Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$
                  () -> Either (Failure Val) ()
forall a b. b -> Either a b
Right
                    (() -> Either (Failure Val) ())
-> IO () -> IO (Either (Failure Val) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> MutableByteArray (PrimState m) -> Int -> Int -> m ()
PA.copyMutableByteArray @IO
                      MutableByteArray RealWorld
MutableByteArray RW
dst
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
doff)
                      MutableByteArray RealWorld
MutableByteArray RW
src
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
soff)
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
l)
  ForeignFunc
ImmutableArray_copyTo_force -> ((MutableArray RealWorld Val, Pos, Array Val, Pos, Pos)
 -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableArray RealWorld Val, Pos, Array Val, Pos, Pos)
  -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableArray RealWorld Val, Pos, Array Val, Pos, Pos)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MutableArray RealWorld Val
dst, Pos
doff, Array Val
src, Pos
soff, Pos
l) ->
      let name :: Text
name = Text
"ImmutableArray.copyTo!"
       in if Pos
l Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
0
            then Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())
            else
              Text
-> Int
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds Text
name (MutableArray RealWorld Val -> Int
forall s a. MutableArray s a -> Int
PA.sizeofMutableArray MutableArray RealWorld Val
dst) (Pos
doff Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
l Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
- Pos
1) (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$
                Text
-> Int
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds Text
name (Array Val -> Int
forall a. Array a -> Int
PA.sizeofArray Array Val
src) (Pos
soff Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
l Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
- Pos
1) (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$
                  () -> Either (Failure Val) ()
forall a b. b -> Either a b
Right
                    (() -> Either (Failure Val) ())
-> IO () -> IO (Either (Failure Val) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a
-> Int -> Array a -> Int -> Int -> m ()
PA.copyArray @IO @Val
                      MutableArray RealWorld Val
MutableArray RW Val
dst
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
doff)
                      Array Val
src
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
soff)
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
l)
  ForeignFunc
ImmutableArray_size ->
    (Array Val -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Array Val -> IO Pos) -> Args -> Stack -> IO (Bool, Stack))
-> (Array Val -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Pos -> IO Pos
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos -> IO Pos) -> (Array Val -> Pos) -> Array Val -> IO Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word64 (Int -> Pos) -> (Array Val -> Int) -> Array Val -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Array a -> Int
PA.sizeofArray @Val
  ForeignFunc
MutableArray_size ->
    (MutableArray RealWorld Val -> IO Pos)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((MutableArray RealWorld Val -> IO Pos)
 -> Args -> Stack -> IO (Bool, Stack))
-> (MutableArray RealWorld Val -> IO Pos)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Pos -> IO Pos
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos -> IO Pos)
-> (MutableArray RealWorld Val -> Pos)
-> MutableArray RealWorld Val
-> IO Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word64 (Int -> Pos)
-> (MutableArray RealWorld Val -> Int)
-> MutableArray RealWorld Val
-> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. MutableArray s a -> Int
PA.sizeofMutableArray @PA.RealWorld @Val
  ForeignFunc
ImmutableByteArray_size ->
    (ByteArray -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ByteArray -> IO Pos) -> Args -> Stack -> IO (Bool, Stack))
-> (ByteArray -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Pos -> IO Pos
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos -> IO Pos) -> (ByteArray -> Pos) -> ByteArray -> IO Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word64 (Int -> Pos) -> (ByteArray -> Int) -> ByteArray -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteArray -> Int
PA.sizeofByteArray
  ForeignFunc
MutableByteArray_size ->
    (MutableByteArray RealWorld -> IO Pos)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((MutableByteArray RealWorld -> IO Pos)
 -> Args -> Stack -> IO (Bool, Stack))
-> (MutableByteArray RealWorld -> IO Pos)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Pos -> IO Pos
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pos -> IO Pos)
-> (MutableByteArray RealWorld -> Pos)
-> MutableByteArray RealWorld
-> IO Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word64 (Int -> Pos)
-> (MutableByteArray RealWorld -> Int)
-> MutableByteArray RealWorld
-> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray @PA.RealWorld
  ForeignFunc
ImmutableByteArray_copyTo_force -> ((MutableByteArray RealWorld, Pos, ByteArray, Pos, Pos)
 -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RealWorld, Pos, ByteArray, Pos, Pos)
  -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RealWorld, Pos, ByteArray, Pos, Pos)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MutableByteArray RealWorld
dst, Pos
doff, ByteArray
src, Pos
soff, Pos
l) ->
      let name :: Text
name = Text
"ImmutableByteArray.copyTo!"
       in if Pos
l Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
0
            then Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())
            else
              Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
dst) (Pos
doff Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
l) Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$
                Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (ByteArray -> Int
PA.sizeofByteArray ByteArray
src) (Pos
soff Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
l) Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$
                  () -> Either (Failure Val) ()
forall a b. b -> Either a b
Right
                    (() -> Either (Failure Val) ())
-> IO () -> IO (Either (Failure Val) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(() :: Constraint, PrimMonad m) =>
MutableByteArray (PrimState m)
-> Int -> ByteArray -> Int -> Int -> m ()
PA.copyByteArray @IO
                      MutableByteArray RealWorld
MutableByteArray RW
dst
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
doff)
                      ByteArray
src
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
soff)
                      (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
l)
  ForeignFunc
MutableArray_read ->
    ((MutableArray RW Val, Pos) -> IO (Either (Failure Val) Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableArray RW Val, Pos) -> IO (Either (Failure Val) Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableArray RW Val, Pos) -> IO (Either (Failure Val) Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (MutableArray RW Val, Pos) -> IO (Either (Failure Val) Val)
checkedRead Text
"MutableArray.read"
  ForeignFunc
MutableByteArray_read8 ->
    ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead8 Text
"MutableByteArray.read8"
  ForeignFunc
MutableByteArray_read16be ->
    ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead16 Text
"MutableByteArray.read16be"
  ForeignFunc
MutableByteArray_read24be ->
    ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead24 Text
"MutableByteArray.read24be"
  ForeignFunc
MutableByteArray_read32be ->
    ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead32 Text
"MutableByteArray.read32be"
  ForeignFunc
MutableByteArray_read40be ->
    ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead40 Text
"MutableByteArray.read40be"
  ForeignFunc
MutableByteArray_read64be ->
    ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead64 Text
"MutableByteArray.read64be"
  ForeignFunc
MutableArray_write ->
    ((MutableArray RW Val, Pos, Val) -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableArray RW Val, Pos, Val) -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableArray RW Val, Pos, Val)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text
-> (MutableArray RW Val, Pos, Val) -> IO (Either (Failure Val) ())
checkedWrite Text
"MutableArray.write"
  ForeignFunc
MutableByteArray_write8 ->
    ((MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos, Pos)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text
-> (MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ())
checkedWrite8 Text
"MutableByteArray.write8"
  ForeignFunc
MutableByteArray_write16be ->
    ((MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos, Pos)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text
-> (MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ())
checkedWrite16 Text
"MutableByteArray.write16be"
  ForeignFunc
MutableByteArray_write32be ->
    ((MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos, Pos)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text
-> (MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ())
checkedWrite32 Text
"MutableByteArray.write32be"
  ForeignFunc
MutableByteArray_write64be ->
    ((MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ()))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ()))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RW, Pos, Pos)
    -> IO (Either (Failure Val) ()))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text
-> (MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ())
checkedWrite64 Text
"MutableByteArray.write64be"
  ForeignFunc
ImmutableArray_read ->
    ((Array Val, Pos) -> IO (Either (Failure Val) Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((Array Val, Pos) -> IO (Either (Failure Val) Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Array Val, Pos) -> IO (Either (Failure Val) Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (Array Val, Pos) -> IO (Either (Failure Val) Val)
checkedIndex Text
"ImmutableArray.read"
  ForeignFunc
ImmutableByteArray_read8 ->
    ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex8 Text
"ImmutableByteArray.read8"
  ForeignFunc
ImmutableByteArray_read16be ->
    ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex16 Text
"ImmutableByteArray.read16be"
  ForeignFunc
ImmutableByteArray_read24be ->
    ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex24 Text
"ImmutableByteArray.read24be"
  ForeignFunc
ImmutableByteArray_read32be ->
    ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex32 Text
"ImmutableByteArray.read32be"
  ForeignFunc
ImmutableByteArray_read40be ->
    ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex40 Text
"ImmutableByteArray.read40be"
  ForeignFunc
ImmutableByteArray_read64be ->
    ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ByteArray, Pos) -> IO (Either (Failure Val) Pos))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex64 Text
"ImmutableByteArray.read64be"
  ForeignFunc
MutableByteArray_freeze_force ->
    (MutableByteArray RealWorld -> IO ByteArray)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((MutableByteArray RealWorld -> IO ByteArray)
 -> Args -> Stack -> IO (Bool, Stack))
-> (MutableByteArray RealWorld -> IO ByteArray)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      MutableByteArray RealWorld -> IO ByteArray
MutableByteArray RW -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
PA.unsafeFreezeByteArray
  ForeignFunc
MutableArray_freeze_force ->
    (MutableArray RW Val -> IO (Array Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((MutableArray RW Val -> IO (Array Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> (MutableArray RW Val -> IO (Array Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
PA.unsafeFreezeArray @IO @Val
  ForeignFunc
MutableByteArray_freeze -> ((MutableByteArray RealWorld, Pos, Pos)
 -> IO (Either (Failure Val) ByteArray))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableByteArray RealWorld, Pos, Pos)
  -> IO (Either (Failure Val) ByteArray))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableByteArray RealWorld, Pos, Pos)
    -> IO (Either (Failure Val) ByteArray))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MutableByteArray RealWorld
src, Pos
off, Pos
len) ->
      if Pos
len Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
0
        then (ByteArray -> Either (Failure Val) ByteArray)
-> IO ByteArray -> IO (Either (Failure Val) ByteArray)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteArray -> Either (Failure Val) ByteArray
forall a b. b -> Either a b
Right (IO ByteArray -> IO (Either (Failure Val) ByteArray))
-> (MutableByteArray RealWorld -> IO ByteArray)
-> MutableByteArray RealWorld
-> IO (Either (Failure Val) ByteArray)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutableByteArray RealWorld -> IO ByteArray
MutableByteArray RW -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
PA.unsafeFreezeByteArray (MutableByteArray RealWorld -> IO (Either (Failure Val) ByteArray))
-> IO (MutableByteArray RealWorld)
-> IO (Either (Failure Val) ByteArray)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO (MutableByteArray RW)
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PA.newByteArray Int
0
        else
          Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ByteArray)
-> IO (Either (Failure Val) ByteArray)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim
            Text
"MutableByteArray.freeze"
            (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
src)
            (Pos
off Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
len)
            Pos
0
            (IO (Either (Failure Val) ByteArray)
 -> IO (Either (Failure Val) ByteArray))
-> IO (Either (Failure Val) ByteArray)
-> IO (Either (Failure Val) ByteArray)
forall a b. (a -> b) -> a -> b
$ ByteArray -> Either (Failure Val) ByteArray
forall a b. b -> Either a b
Right (ByteArray -> Either (Failure Val) ByteArray)
-> IO ByteArray -> IO (Either (Failure Val) ByteArray)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableByteArray RW -> Int -> Int -> IO ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> Int -> Int -> m ByteArray
PA.freezeByteArray MutableByteArray RealWorld
MutableByteArray RW
src (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
off) (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
len)
  ForeignFunc
MutableArray_freeze -> ((MutableArray RealWorld Val, Pos, Pos)
 -> IO (Either (Failure Val) (Array Val)))
-> Args -> Stack -> IO (Bool, Stack)
forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn (((MutableArray RealWorld Val, Pos, Pos)
  -> IO (Either (Failure Val) (Array Val)))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((MutableArray RealWorld Val, Pos, Pos)
    -> IO (Either (Failure Val) (Array Val)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(MutableArray RealWorld Val
src :: PA.MutableArray PA.RealWorld Val, Pos
off, Pos
len) ->
      if Pos
len Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
0
        then (Array Val -> Either (Failure Val) (Array Val))
-> IO (Array Val) -> IO (Either (Failure Val) (Array Val))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Array Val -> Either (Failure Val) (Array Val)
forall a b. b -> Either a b
Right (IO (Array Val) -> IO (Either (Failure Val) (Array Val)))
-> (MutableArray RealWorld Val -> IO (Array Val))
-> MutableArray RealWorld Val
-> IO (Either (Failure Val) (Array Val))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutableArray RealWorld Val -> IO (Array Val)
MutableArray RW Val -> IO (Array Val)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> m (Array a)
PA.unsafeFreezeArray (MutableArray RealWorld Val
 -> IO (Either (Failure Val) (Array Val)))
-> IO (MutableArray RealWorld Val)
-> IO (Either (Failure Val) (Array Val))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Val -> IO (MutableArray RW Val)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
PA.newArray Int
0 Val
emptyVal
        else
          Text
-> Int
-> Pos
-> IO (Either (Failure Val) (Array Val))
-> IO (Either (Failure Val) (Array Val))
forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds
            Text
"MutableArray.freeze"
            (MutableArray RealWorld Val -> Int
forall s a. MutableArray s a -> Int
PA.sizeofMutableArray MutableArray RealWorld Val
src)
            (Pos
off Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
len Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
- Pos
1)
            (IO (Either (Failure Val) (Array Val))
 -> IO (Either (Failure Val) (Array Val)))
-> IO (Either (Failure Val) (Array Val))
-> IO (Either (Failure Val) (Array Val))
forall a b. (a -> b) -> a -> b
$ Array Val -> Either (Failure Val) (Array Val)
forall a b. b -> Either a b
Right (Array Val -> Either (Failure Val) (Array Val))
-> IO (Array Val) -> IO (Either (Failure Val) (Array Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray RW Val -> Int -> Int -> IO (Array Val)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> Int -> m (Array a)
PA.freezeArray MutableArray RealWorld Val
MutableArray RW Val
src (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
off) (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
len)
  ForeignFunc
MutableByteArray_length ->
    (MutableByteArray RealWorld -> IO Int)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((MutableByteArray RealWorld -> IO Int)
 -> Args -> Stack -> IO (Bool, Stack))
-> (MutableByteArray RealWorld -> IO Int)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IO Int)
-> (MutableByteArray RealWorld -> Int)
-> MutableByteArray RealWorld
-> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray @PA.RealWorld
  ForeignFunc
ImmutableByteArray_length ->
    (ByteArray -> IO Int) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ByteArray -> IO Int) -> Args -> Stack -> IO (Bool, Stack))
-> (ByteArray -> IO Int) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IO Int) -> (ByteArray -> Int) -> ByteArray -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteArray -> Int
PA.sizeofByteArray
  ForeignFunc
IO_array -> (Int -> IO (MutableArray RealWorld Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Int -> IO (MutableArray RealWorld Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Int -> IO (MutableArray RealWorld Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \Int
n -> Int -> Val -> IO (MutableArray RW Val)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
PA.newArray Int
n Val
emptyVal
  ForeignFunc
IO_arrayOf -> ((Val, Int) -> IO (MutableArray RealWorld Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Val, Int) -> IO (MutableArray RealWorld Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Val, Int) -> IO (MutableArray RealWorld Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Val
v :: Val, Int
n) -> Int -> Val -> IO (MutableArray RW Val)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
PA.newArray Int
n Val
v
  ForeignFunc
IO_bytearray -> (Int -> IO (MutableByteArray RealWorld))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Int -> IO (MutableByteArray RealWorld))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Int -> IO (MutableByteArray RealWorld))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Int -> IO (MutableByteArray RealWorld)
Int -> IO (MutableByteArray RW)
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PA.newByteArray
  ForeignFunc
IO_bytearrayOf -> ((Word8, Int) -> IO (MutableByteArray RealWorld))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Word8, Int) -> IO (MutableByteArray RealWorld))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Word8, Int) -> IO (MutableByteArray RealWorld))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Word8
init, Int
sz) -> do
      MutableByteArray RealWorld
arr <- Int -> IO (MutableByteArray RW)
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PA.newByteArray Int
sz
      MutableByteArray RW -> Int -> Int -> Word8 -> IO ()
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> Int -> Int -> Word8 -> m ()
PA.fillByteArray MutableByteArray RealWorld
MutableByteArray RW
arr Int
0 Int
sz Word8
init
      pure MutableByteArray RealWorld
arr
  ForeignFunc
Scope_array -> (Int -> IO (MutableArray RealWorld Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Int -> IO (MutableArray RealWorld Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Int -> IO (MutableArray RealWorld Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \Int
n -> Int -> Val -> IO (MutableArray RW Val)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
PA.newArray Int
n Val
emptyVal
  ForeignFunc
Scope_arrayOf -> ((Val, Int) -> IO (MutableArray RealWorld Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Val, Int) -> IO (MutableArray RealWorld Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Val, Int) -> IO (MutableArray RealWorld Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Val
v :: Val, Int
n) -> Int -> Val -> IO (MutableArray RW Val)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
PA.newArray Int
n Val
v
  ForeignFunc
Scope_bytearray -> (Int -> IO (MutableByteArray RealWorld))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Int -> IO (MutableByteArray RealWorld))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Int -> IO (MutableByteArray RealWorld))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ Int -> IO (MutableByteArray RealWorld)
Int -> IO (MutableByteArray RW)
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PA.newByteArray
  ForeignFunc
Scope_bytearrayOf -> ((Word8, Int) -> IO (MutableByteArray RealWorld))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Word8, Int) -> IO (MutableByteArray RealWorld))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Word8, Int) -> IO (MutableByteArray RealWorld))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Word8
init, Int
sz) -> do
      MutableByteArray RealWorld
arr <- Int -> IO (MutableByteArray RW)
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
PA.newByteArray Int
sz
      MutableByteArray RW -> Int -> Int -> Word8 -> IO ()
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> Int -> Int -> Word8 -> m ()
PA.fillByteArray MutableByteArray RealWorld
MutableByteArray RW
arr Int
0 Int
sz Word8
init
      pure MutableByteArray RealWorld
arr
  ForeignFunc
Text_patterns_literal -> (Text -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \Text
txt -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Text -> Pattern
TPat.Literal Text
txt
  ForeignFunc
Text_patterns_digit ->
    (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern (CharPattern -> Pattern
TPat.Char (Char -> Char -> CharPattern
TPat.CharRange Char
'0' Char
'9')) in \() -> CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Text_patterns_letter ->
    (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern (CharPattern -> Pattern
TPat.Char (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Letter)) in \() -> CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Text_patterns_space ->
    (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern (CharPattern -> Pattern
TPat.Char (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Whitespace)) in \() -> CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Text_patterns_punctuation ->
    (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern (CharPattern -> Pattern
TPat.Char (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Punctuation)) in \() -> CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Text_patterns_anyChar ->
    (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern (CharPattern -> Pattern
TPat.Char CharPattern
TPat.Any) in \() -> CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Text_patterns_eof ->
    (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern Pattern
TPat.Eof in \() -> CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Text_patterns_charRange -> ((Char, Char) -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Char, Char) -> IO CPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Char, Char) -> IO CPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Char
beg, Char
end) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (CharPattern -> CPattern) -> CharPattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> CPattern)
-> (CharPattern -> Pattern) -> CharPattern -> CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPattern -> Pattern
TPat.Char (CharPattern -> IO CPattern) -> CharPattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Char -> Char -> CharPattern
TPat.CharRange Char
beg Char
end
  ForeignFunc
Text_patterns_notCharRange -> ((Char, Char) -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Char, Char) -> IO CPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Char, Char) -> IO CPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Char
beg, Char
end) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (CharPattern -> CPattern) -> CharPattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> CPattern)
-> (CharPattern -> Pattern) -> CharPattern -> CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPattern -> Pattern
TPat.Char (CharPattern -> Pattern)
-> (CharPattern -> CharPattern) -> CharPattern -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPattern -> CharPattern
TPat.Not (CharPattern -> IO CPattern) -> CharPattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Char -> Char -> CharPattern
TPat.CharRange Char
beg Char
end
  ForeignFunc
Text_patterns_charIn -> ([Val] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (([Val] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> ([Val] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \[Val]
ccs -> do
    [Char]
cs <- [Val] -> (Val -> IO Char) -> IO [Char]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Val]
ccs ((Val -> IO Char) -> IO [Char]) -> (Val -> IO Char) -> IO [Char]
forall a b. (a -> b) -> a -> b
$ \case
      CharVal Char
c -> Char -> IO Char
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
      Val
_ -> [Char] -> IO Char
forall a. HasCallStack => [Char] -> IO a
die [Char]
"Text.patterns.charIn: non-character closure"
    CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (CharPattern -> CPattern) -> CharPattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> CPattern)
-> (CharPattern -> Pattern) -> CharPattern -> CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPattern -> Pattern
TPat.Char (CharPattern -> IO CPattern) -> CharPattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ [Char] -> CharPattern
TPat.CharSet [Char]
cs
  ForeignFunc
Text_patterns_notCharIn -> ([Val] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (([Val] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> ([Val] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \[Val]
ccs -> do
    [Char]
cs <- [Val] -> (Val -> IO Char) -> IO [Char]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Val]
ccs ((Val -> IO Char) -> IO [Char]) -> (Val -> IO Char) -> IO [Char]
forall a b. (a -> b) -> a -> b
$ \case
      CharVal Char
c -> Char -> IO Char
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
      Val
_ -> [Char] -> IO Char
forall a. HasCallStack => [Char] -> IO a
die [Char]
"Text.patterns.notCharIn: non-character closure"
    CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (CharPattern -> CPattern) -> CharPattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> CPattern)
-> (CharPattern -> Pattern) -> CharPattern -> CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPattern -> Pattern
TPat.Char (CharPattern -> Pattern)
-> (CharPattern -> CharPattern) -> CharPattern -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPattern -> CharPattern
TPat.Not (CharPattern -> IO CPattern) -> CharPattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ [Char] -> CharPattern
TPat.CharSet [Char]
cs
  ForeignFunc
Pattern_many -> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TPat.CP Pattern
p Text -> Maybe ([Text], Text)
_) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Bool -> Pattern -> Pattern
TPat.Many Bool
False Pattern
p
  ForeignFunc
Pattern_many_corrected -> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TPat.CP Pattern
p Text -> Maybe ([Text], Text)
_) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Bool -> Pattern -> Pattern
TPat.Many Bool
True Pattern
p
  ForeignFunc
Pattern_capture -> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TPat.CP Pattern
p Text -> Maybe ([Text], Text)
_) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Pattern -> Pattern
TPat.Capture Pattern
p
  ForeignFunc
Pattern_captureAs -> ((Text, CPattern) -> IO CPattern)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Text, CPattern) -> IO CPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Text, CPattern) -> IO CPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Text
t, (TPat.CP Pattern
p Text -> Maybe ([Text], Text)
_)) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Text -> Pattern -> Pattern
TPat.CaptureAs Text
t Pattern
p
  ForeignFunc
Pattern_join -> ([CPattern] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (([CPattern] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> ([CPattern] -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \[CPattern]
ps ->
    CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> ([Pattern] -> CPattern) -> [Pattern] -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> CPattern)
-> ([Pattern] -> Pattern) -> [Pattern] -> CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pattern] -> Pattern
TPat.Join ([Pattern] -> IO CPattern) -> [Pattern] -> IO CPattern
forall a b. (a -> b) -> a -> b
$ (CPattern -> Pattern) -> [CPattern] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map (\(TPat.CP Pattern
p Text -> Maybe ([Text], Text)
_) -> Pattern
p) [CPattern]
ps
  ForeignFunc
Pattern_or -> ((CPattern, CPattern) -> IO CPattern)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((CPattern, CPattern) -> IO CPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((CPattern, CPattern) -> IO CPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TPat.CP Pattern
l Text -> Maybe ([Text], Text)
_, TPat.CP Pattern
r Text -> Maybe ([Text], Text)
_) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Pattern -> Pattern -> Pattern
TPat.Or Pattern
l Pattern
r
  ForeignFunc
Pattern_lookahead -> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TPat.CP Pattern
p Text -> Maybe ([Text], Text)
_) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Pattern -> Pattern
TPat.Lookahead Pattern
p
  ForeignFunc
Pattern_negativeLookahead -> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (CPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TPat.CP Pattern
p Text -> Maybe ([Text], Text)
_) -> CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Pattern -> Pattern
TPat.NegativeLookahead Pattern
p
  ForeignFunc
Pattern_replicate -> ((Pos, Pos, CPattern) -> IO CPattern)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Pos, Pos, CPattern) -> IO CPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Pos, Pos, CPattern) -> IO CPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Pos
m0 :: Word64, Pos
n0 :: Word64, TPat.CP Pattern
p Text -> Maybe ([Text], Text)
_) ->
      let m :: Int
m = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
m0; n :: Int
n = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
n0
       in CPattern -> IO CPattern
forall a. a -> IO a
evaluate (CPattern -> IO CPattern)
-> (Pattern -> CPattern) -> Pattern -> IO CPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> CPattern
TPat.cpattern (Pattern -> IO CPattern) -> Pattern -> IO CPattern
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pattern -> Pattern
TPat.Replicate Int
m Int
n Pattern
p
  ForeignFunc
Pattern_run -> ((CPattern, Text) -> IO (Maybe ([Text], Text)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((CPattern, Text) -> IO (Maybe ([Text], Text)))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((CPattern, Text) -> IO (Maybe ([Text], Text)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TPat.CP Pattern
_ Text -> Maybe ([Text], Text)
matcher, Text
input :: Text) -> Maybe ([Text], Text) -> IO (Maybe ([Text], Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ([Text], Text) -> IO (Maybe ([Text], Text)))
-> Maybe ([Text], Text) -> IO (Maybe ([Text], Text))
forall a b. (a -> b) -> a -> b
$ Text -> Maybe ([Text], Text)
matcher Text
input
  ForeignFunc
Pattern_isMatch -> ((CPattern, Text) -> IO Bool) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((CPattern, Text) -> IO Bool)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((CPattern, Text) -> IO Bool)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(TPat.CP Pattern
_ Text -> Maybe ([Text], Text)
matcher, Text
input :: Text) -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool)
-> (Maybe ([Text], Text) -> Bool)
-> Maybe ([Text], Text)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ([Text], Text) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ([Text], Text) -> IO Bool)
-> Maybe ([Text], Text) -> IO Bool
forall a b. (a -> b) -> a -> b
$ Text -> Maybe ([Text], Text)
matcher Text
input
  ForeignFunc
Char_Class_any -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CharPattern
TPat.Any
  ForeignFunc
Char_Class_not -> (CharPattern -> IO CharPattern)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CharPattern -> IO CharPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> (CharPattern -> IO CharPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharPattern -> IO CharPattern)
-> (CharPattern -> CharPattern) -> CharPattern -> IO CharPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPattern -> CharPattern
TPat.Not
  ForeignFunc
Char_Class_and -> ((CharPattern, CharPattern) -> IO CharPattern)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((CharPattern, CharPattern) -> IO CharPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((CharPattern, CharPattern) -> IO CharPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(CharPattern
a, CharPattern
b) -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharPattern -> IO CharPattern) -> CharPattern -> IO CharPattern
forall a b. (a -> b) -> a -> b
$ CharPattern -> CharPattern -> CharPattern
TPat.Intersect CharPattern
a CharPattern
b
  ForeignFunc
Char_Class_or -> ((CharPattern, CharPattern) -> IO CharPattern)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((CharPattern, CharPattern) -> IO CharPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((CharPattern, CharPattern) -> IO CharPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(CharPattern
a, CharPattern
b) -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharPattern -> IO CharPattern) -> CharPattern -> IO CharPattern
forall a b. (a -> b) -> a -> b
$ CharPattern -> CharPattern -> CharPattern
TPat.Union CharPattern
a CharPattern
b
  ForeignFunc
Char_Class_range -> ((Char, Char) -> IO CharPattern)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Char, Char) -> IO CharPattern)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Char, Char) -> IO CharPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Char
a, Char
b) -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharPattern -> IO CharPattern) -> CharPattern -> IO CharPattern
forall a b. (a -> b) -> a -> b
$ Char -> Char -> CharPattern
TPat.CharRange Char
a Char
b
  ForeignFunc
Char_Class_anyOf -> ([Val] -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (([Val] -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> ([Val] -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \[Val]
ccs -> do
    [Char]
cs <- [Val] -> (Val -> IO Char) -> IO [Char]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Val]
ccs ((Val -> IO Char) -> IO [Char]) -> (Val -> IO Char) -> IO [Char]
forall a b. (a -> b) -> a -> b
$ \case
      CharVal Char
c -> Char -> IO Char
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
      Val
_ -> [Char] -> IO Char
forall a. HasCallStack => [Char] -> IO a
die [Char]
"Text.patterns.charIn: non-character closure"
    CharPattern -> IO CharPattern
forall a. a -> IO a
evaluate (CharPattern -> IO CharPattern) -> CharPattern -> IO CharPattern
forall a b. (a -> b) -> a -> b
$ [Char] -> CharPattern
TPat.CharSet [Char]
cs
  ForeignFunc
Char_Class_alphanumeric -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.AlphaNum)
  ForeignFunc
Char_Class_upper -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Upper)
  ForeignFunc
Char_Class_lower -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Lower)
  ForeignFunc
Char_Class_whitespace -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Whitespace)
  ForeignFunc
Char_Class_control -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Control)
  ForeignFunc
Char_Class_printable -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Printable)
  ForeignFunc
Char_Class_mark -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.MarkChar)
  ForeignFunc
Char_Class_number -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Number)
  ForeignFunc
Char_Class_punctuation -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Punctuation)
  ForeignFunc
Char_Class_symbol -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Symbol)
  ForeignFunc
Char_Class_separator -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Separator)
  ForeignFunc
Char_Class_letter -> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO CharPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> CharPattern -> IO CharPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CharClass -> CharPattern
TPat.CharClass CharClass
TPat.Letter)
  ForeignFunc
Char_Class_is -> ((CharPattern, Char) -> IO Bool)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((CharPattern, Char) -> IO Bool)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((CharPattern, Char) -> IO Bool)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(CharPattern
cl, Char
c) -> Bool -> IO Bool
forall a. a -> IO a
evaluate (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CharPattern -> Char -> Bool
TPat.charPatternPred CharPattern
cl Char
c
  ForeignFunc
Text_patterns_char -> (CharPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CharPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (CharPattern -> IO CPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \CharPattern
c ->
    let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern (CharPattern -> Pattern
TPat.Char CharPattern
c) in CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Text_patterns_lookbehind1 -> (CharPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CharPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (CharPattern -> IO CPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \CharPattern
cp ->
    let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern (CharPattern -> Pattern
TPat.Lookbehind1 CharPattern
cp) in CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Text_patterns_negativeLookbehind1 -> (CharPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((CharPattern -> IO CPattern) -> Args -> Stack -> IO (Bool, Stack))
-> (CharPattern -> IO CPattern)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \CharPattern
cp ->
    let v :: CPattern
v = Pattern -> CPattern
TPat.cpattern (CharPattern -> Pattern
TPat.NegativeLookbehind1 CharPattern
cp) in CPattern -> IO CPattern
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CPattern
v
  ForeignFunc
Map_tip -> (() -> IO (Map Any Any)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO (Map Any Any)) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO (Map Any Any)) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> Map Any Any -> IO (Map Any Any)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Any Any
forall k a. Map k a
Map.empty
  ForeignFunc
Map_bin -> ((Pos, Val, Val, Map Val Val, Map Val Val) -> IO (Map Val Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Pos, Val, Val, Map Val Val, Map Val Val) -> IO (Map Val Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Pos, Val, Val, Map Val Val, Map Val Val) -> IO (Map Val Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Pos
sz :: Word64, Val
k :: Val, Val
v :: Val, Map Val Val
l, Map Val Val
r) ->
    Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Val -> Val -> Map Val Val -> Map Val Val -> Map Val Val
forall k a. Int -> k -> a -> Map k a -> Map k a -> Map k a
Map.Bin (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
sz) Val
k Val
v Map Val Val
l Map Val Val
r)
  ForeignFunc
Map_insert -> ((Val, Val, Map Val Val) -> IO (Map Val Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Val, Val, Map Val Val) -> IO (Map Val Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Val, Val, Map Val Val) -> IO (Map Val Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Val
k :: Val, Val
v :: Val, Map Val Val
m :: Map Val Val) ->
    Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
evaluate (Map Val Val -> IO (Map Val Val))
-> Map Val Val -> IO (Map Val Val)
forall a b. (a -> b) -> a -> b
$ Val -> Val -> Map Val Val -> Map Val Val
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Val
k Val
v Map Val Val
m
  ForeignFunc
Map_lookup -> ((Val, Map Val Val) -> IO (Maybe Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Val, Map Val Val) -> IO (Maybe Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Val, Map Val Val) -> IO (Maybe Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Val
k :: Val, Map Val Val
v :: Map Val Val) ->
    Maybe Val -> IO (Maybe Val)
forall a. a -> IO a
evaluate (Maybe Val -> IO (Maybe Val)) -> Maybe Val -> IO (Maybe Val)
forall a b. (a -> b) -> a -> b
$ Val -> Map Val Val -> Maybe Val
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Val
k Map Val Val
v
  ForeignFunc
Map_fromList -> ([(Val, Val)] -> IO (Map Val Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (([(Val, Val)] -> IO (Map Val Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ([(Val, Val)] -> IO (Map Val Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \([(Val, Val)]
l :: [(Val, Val)]) ->
    Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
evaluate (Map Val Val -> IO (Map Val Val))
-> Map Val Val -> IO (Map Val Val)
forall a b. (a -> b) -> a -> b
$ [(Val, Val)] -> Map Val Val
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Val, Val)]
l
  ForeignFunc
Map_eq -> ((Map Val Val, Map Val Val) -> IO Bool)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Map Val Val, Map Val Val) -> IO Bool)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Map Val Val, Map Val Val) -> IO Bool)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Map Val Val
l :: Map Val Val, Map Val Val
r :: Map Val Val) ->
    Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Map Val Val
l Map Val Val -> Map Val Val -> Bool
forall a. Eq a => a -> a -> Bool
== Map Val Val
r
  ForeignFunc
Map_union -> ((Map Val Val, Map Val Val) -> IO (Map Val Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Map Val Val, Map Val Val) -> IO (Map Val Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Map Val Val, Map Val Val) -> IO (Map Val Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Map Val Val
l :: Map Val Val, Map Val Val
r :: Map Val Val) ->
    Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
evaluate (Map Val Val -> IO (Map Val Val))
-> Map Val Val -> IO (Map Val Val)
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Map Val Val -> Map Val Val
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Val Val
l Map Val Val
r
  ForeignFunc
Map_intersect -> ((Map Val Val, Map Val Val) -> IO (Map Val Val))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Map Val Val, Map Val Val) -> IO (Map Val Val))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Map Val Val, Map Val Val) -> IO (Map Val Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Map Val Val
l :: Map Val Val, Map Val Val
r :: Map Val Val) ->
    Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
evaluate (Map Val Val -> IO (Map Val Val))
-> Map Val Val -> IO (Map Val Val)
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Map Val Val -> Map Val Val
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map Val Val
l Map Val Val
r
  ForeignFunc
Map_toList -> (Map Val Val -> IO [(Val, Val)])
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Map Val Val -> IO [(Val, Val)])
 -> Args -> Stack -> IO (Bool, Stack))
-> (Map Val Val -> IO [(Val, Val)])
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Map Val Val
m :: Map Val Val) ->
    [(Val, Val)] -> IO [(Val, Val)]
forall a. a -> IO a
evaluate ([(Val, Val)] -> IO [(Val, Val)])
-> ([(Val, Val)] -> [(Val, Val)])
-> [(Val, Val)]
-> IO [(Val, Val)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Val, Val)] -> [(Val, Val)]
forall {t :: * -> *} {a}. Foldable t => t a -> t a
forceListSpine ([(Val, Val)] -> IO [(Val, Val)])
-> [(Val, Val)] -> IO [(Val, Val)]
forall a b. (a -> b) -> a -> b
$ Map Val Val -> [(Val, Val)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Val Val
m
  ForeignFunc
List_range -> ((Pos, Pos) -> IO (Seq Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Pos, Pos) -> IO (Seq Val)) -> Args -> Stack -> IO (Bool, Stack))
-> ((Pos, Pos) -> IO (Seq Val))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Pos
m :: Word64, Pos
n :: Word64) ->
    let sz :: Int
sz
          | Pos
m Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
n = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ Pos
n Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
- Pos
m
          | Bool
otherwise = Int
0
        mk :: Int -> Val
mk Int
i = Pos -> Val
NatVal (Pos -> Val) -> Pos -> Val
forall a b. (a -> b) -> a -> b
$ Pos
m Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Int -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
     in Seq Val -> IO (Seq Val)
forall a. a -> IO a
evaluate (Seq Val -> IO (Seq Val))
-> (Seq Val -> Seq Val) -> Seq Val -> IO (Seq Val)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Val -> Seq Val
forall {t :: * -> *} {a}. Foldable t => t a -> t a
forceListSpine (Seq Val -> IO (Seq Val)) -> Seq Val -> IO (Seq Val)
forall a b. (a -> b) -> a -> b
$ Int -> (Int -> Val) -> Seq Val
forall a. Int -> (Int -> a) -> Seq a
Sq.fromFunction Int
sz Int -> Val
mk
  ForeignFunc
List_sort -> (Seq Val -> IO (Seq Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Seq Val -> IO (Seq Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (Seq Val -> IO (Seq Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Seq Val
l :: Seq Val) -> Seq Val -> IO (Seq Val)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Val -> IO (Seq Val)) -> Seq Val -> IO (Seq Val)
forall a b. (a -> b) -> a -> b
$ Seq Val -> Seq Val
forall a. Ord a => Seq a -> Seq a
Sq.unstableSort Seq Val
l
  ForeignFunc
Multimap_fromList -> ([(Val, Val)] -> IO (Map Val (Seq Val)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (([(Val, Val)] -> IO (Map Val (Seq Val)))
 -> Args -> Stack -> IO (Bool, Stack))
-> ([(Val, Val)] -> IO (Map Val (Seq Val)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \([(Val, Val)]
l :: [(Val, Val)]) -> do
    let listVals :: [(Val, Seq Val)]
listVals = [(Val, Val)]
l [(Val, Val)] -> ((Val, Val) -> (Val, Seq Val)) -> [(Val, Seq Val)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Val
k, Val
v) -> (Val
k, Val -> Seq Val
forall a. a -> Seq a
Sq.singleton Val
v)
    Map Val (Seq Val) -> IO (Map Val (Seq Val))
forall a. a -> IO a
evaluate (Map Val (Seq Val) -> IO (Map Val (Seq Val)))
-> Map Val (Seq Val) -> IO (Map Val (Seq Val))
forall a b. (a -> b) -> a -> b
$ (Seq Val -> Seq Val -> Seq Val)
-> [(Val, Seq Val)] -> Map Val (Seq Val)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Seq Val -> Seq Val -> Seq Val
forall a. Semigroup a => a -> a -> a
(<>) [(Val, Seq Val)]
listVals
  ForeignFunc
Set_fromList -> ([Val] -> IO Closure) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (([Val] -> IO Closure) -> Args -> Stack -> IO (Bool, Stack))
-> ([Val] -> IO Closure) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \([Val]
l :: [Val]) -> do
    Map Val Val
m <- Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
evaluate (Map Val Val -> IO (Map Val Val))
-> Map Val Val -> IO (Map Val Val)
forall a b. (a -> b) -> a -> b
$ [(Val, Val)] -> Map Val Val
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Val, Val)] -> Map Val Val) -> [(Val, Val)] -> Map Val Val
forall a b. (a -> b) -> a -> b
$ [Val] -> [Val] -> [(Val, Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Val]
l (Val -> [Val]
forall a. a -> [a]
repeat Val
unitValue)
    Closure -> IO Closure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> (Val -> Closure) -> Val -> IO Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.setRef PackedTag
TT.setWrapTag (Val -> IO Closure) -> Val -> IO Closure
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Map Val Val
m
  ForeignFunc
Set_union -> ((Closure, Closure) -> IO Closure)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Closure, Closure) -> IO Closure)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Closure, Closure) -> IO Closure)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \case
    (Data1 Reference
_ PackedTag
_ Val
vl, Data1 Reference
_ PackedTag
_ Val
vr) -> do
      (Map Val Val
l :: Map Val Val) <- Val -> IO (Map Val Val)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
vl
      (Map Val Val
r :: Map Val Val) <- Val -> IO (Map Val Val)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
vr
      Map Val Val
m <- Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
evaluate (Map Val Val -> IO (Map Val Val))
-> Map Val Val -> IO (Map Val Val)
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Map Val Val -> Map Val Val
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Val Val
l Map Val Val
r
      Closure -> IO Closure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> (Val -> Closure) -> Val -> IO Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.setRef PackedTag
TT.setWrapTag (Val -> IO Closure) -> Val -> IO Closure
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Map Val Val
m
    (Closure, Closure)
_ -> [Char] -> IO Closure
forall a. HasCallStack => [Char] -> IO a
die [Char]
"Set.union: bad closure"
  ForeignFunc
Set_intersect -> ((Closure, Closure) -> IO Closure)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Closure, Closure) -> IO Closure)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Closure, Closure) -> IO Closure)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \case
    (Data1 Reference
_ PackedTag
_ Val
vl, Data1 Reference
_ PackedTag
_ Val
vr) -> do
      (Map Val Val
l :: Map Val Val) <- Val -> IO (Map Val Val)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
vl
      (Map Val Val
r :: Map Val Val) <- Val -> IO (Map Val Val)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
vr
      Map Val Val
m <- Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
evaluate (Map Val Val -> IO (Map Val Val))
-> Map Val Val -> IO (Map Val Val)
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Map Val Val -> Map Val Val
forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection Map Val Val
l Map Val Val
r
      Closure -> IO Closure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> IO Closure) -> (Val -> Closure) -> Val -> IO Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.setRef PackedTag
TT.setWrapTag (Val -> IO Closure) -> Val -> IO Closure
forall a b. (a -> b) -> a -> b
$ Map Val Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Map Val Val
m
    (Closure, Closure)
_ -> [Char] -> IO Closure
forall a. HasCallStack => [Char] -> IO a
die [Char]
"Set.insersect: bad closure"
  ForeignFunc
Set_toList -> (Closure -> IO [Val]) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Closure -> IO [Val]) -> Args -> Stack -> IO (Bool, Stack))
-> (Closure -> IO [Val]) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \case
    (Data1 Reference
_ PackedTag
_ Val
vs) -> do
      (Map Val Val
s :: Map Val Val) <- Val -> IO (Map Val Val)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
vs
      [Val] -> IO [Val]
forall a. a -> IO a
evaluate ([Val] -> IO [Val]) -> ([Val] -> [Val]) -> [Val] -> IO [Val]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> [Val]
forall {t :: * -> *} {a}. Foldable t => t a -> t a
forceListSpine ([Val] -> IO [Val]) -> [Val] -> IO [Val]
forall a b. (a -> b) -> a -> b
$ Map Val Val -> [Val]
forall k a. Map k a -> [k]
Map.keys Map Val Val
s
    Closure
_ -> [Char] -> IO [Val]
forall a. HasCallStack => [Char] -> IO a
die [Char]
"Set.toList: bad closure"
  where
    forceListSpine :: t a -> t a
forceListSpine t a
xs = (t a -> a -> t a) -> t a -> t a -> t a
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\t a
u a
x -> a
x a -> t a -> t a
forall a b. a -> b -> b
`seq` t a
u) t a
xs t a
xs
    chop :: [Char] -> [Char]
chop = [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isPathSeparator ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse

    hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference
    hostPreference :: Maybe Text -> HostPreference
hostPreference Maybe Text
Nothing = HostPreference
SYS.HostAny
    hostPreference (Just Text
host) = [Char] -> HostPreference
SYS.Host ([Char] -> HostPreference) -> [Char] -> HostPreference
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Util.Text.unpack Text
host

    mx :: Word64
    mx :: Pos
mx = Int -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
forall a. Bounded a => a
maxBound :: Int)

    customDelay :: Word64 -> IO ()
    customDelay :: Pos -> IO ()
customDelay Pos
n
      | Pos
n Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
mx = Int -> IO ()
threadDelay (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
n)
      | Bool
otherwise = Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pos -> IO ()
customDelay (Pos
n Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
- Pos
mx)

    exitDecode :: ExitCode -> Int
exitDecode ExitCode
ExitSuccess = Int
0
    exitDecode (ExitFailure Int
n) = Int
n

    catchAll :: (MonadCatch m, MonadIO m, NFData a) => m a -> m (Either Util.Text.Text a)
    catchAll :: forall (m :: * -> *) a.
(MonadCatch m, MonadIO m, NFData a) =>
m a -> m (Either Text a)
catchAll m a
e = do
      Either SomeException a
e <- m a -> m (Either SomeException a)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m, MonadIO m, NFData a) =>
m a -> m (Either SomeException a)
Exception.tryAnyDeep m a
e
      pure $ case Either SomeException a
e of
        Left SomeException
se -> Text -> Either Text a
forall a b. a -> Either a b
Left ([Char] -> Text
Util.Text.pack (SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
se))
        Right a
a -> a -> Either Text a
forall a b. b -> Either a b
Right a
a

{-# INLINE mkHashAlgorithm #-}
mkHashAlgorithm :: forall alg. (Hash.HashAlgorithm alg) => Data.Text.Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm :: forall alg.
HashAlgorithm alg =>
Text -> alg -> Args -> Stack -> IO (Bool, Stack)
mkHashAlgorithm Text
txt alg
alg =
  let algoRef :: Reference
algoRef = Text -> Reference
forall t h. t -> Reference' t h
Builtin (Text
"crypto.HashAlgorithm." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt)
   in (() -> IO HashAlgorithm) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO HashAlgorithm) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO HashAlgorithm) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> HashAlgorithm -> IO HashAlgorithm
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reference -> alg -> HashAlgorithm
forall a. HashAlgorithm a => Reference -> a -> HashAlgorithm
HashAlgorithm Reference
algoRef alg
alg)

{-# INLINE mkForeign #-}
mkForeign :: (ForeignConvention a, ForeignConvention b) => (a -> IO b) -> Args -> Stack -> IO (Bool, Stack)
mkForeign :: forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign !a -> IO b
f !Args
args !Stack
stk = do
  b
r <- a -> IO b
f (a -> IO b) -> IO a -> IO b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack -> Args -> IO a
forall a. ForeignConvention a => Stack -> Args -> IO a
readsAt Stack
stk Args
args
  Stack
stk <- Stack -> IO Stack
bump Stack
stk
  (Bool
False, Stack
stk) (Bool, Stack) -> IO () -> IO (Bool, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack -> b -> IO ()
forall a. ForeignConvention a => Stack -> a -> IO ()
writeBack Stack
stk b
r

{-# INLINE mkForeignIOF #-}
mkForeignIOF ::
  (ForeignConvention a, ForeignConvention r) =>
  (a -> IO r) ->
  Args ->
  Stack ->
  IO (Bool, Stack)
mkForeignIOF :: forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF a -> IO r
f = (a -> IO (Either (Failure Val) r))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((a -> IO (Either (Failure Val) r))
 -> Args -> Stack -> IO (Bool, Stack))
-> (a -> IO (Either (Failure Val) r))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \a
a -> IO r -> IO (Either (Failure Val) r)
forall a. IO a -> IO (Either (Failure Val) a)
tryIOE (a -> IO r
f a
a)
  where
    tryIOE :: IO a -> IO (Either (F.Failure Val) a)
    tryIOE :: forall a. IO a -> IO (Either (Failure Val) a)
tryIOE = (Either IOException a -> Either (Failure Val) a)
-> IO (Either IOException a) -> IO (Either (Failure Val) a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either IOException a -> Either (Failure Val) a
forall a. Either IOException a -> Either (Failure Val) a
handleIOE (IO (Either IOException a) -> IO (Either (Failure Val) a))
-> (IO a -> IO (Either IOException a))
-> IO a
-> IO (Either (Failure Val) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either IOException a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try
    handleIOE :: Either IOException a -> Either (F.Failure Val) a
    handleIOE :: forall a. Either IOException a -> Either (Failure Val) a
handleIOE (Left IOException
e) = Failure Val -> Either (Failure Val) a
forall a b. a -> Either a b
Left (Failure Val -> Either (Failure Val) a)
-> Failure Val -> Either (Failure Val) a
forall a b. (a -> b) -> a -> b
$ Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.ioFailureRef ([Char] -> Text
Util.Text.pack (IOException -> [Char]
forall a. Show a => a -> [Char]
show IOException
e)) Val
unitValue
    handleIOE (Right a
a) = a -> Either (Failure Val) a
forall a b. b -> Either a b
Right a
a

{-# INLINE mkForeignExn #-}
mkForeignExn ::
  (ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
  (a -> IO (Either (F.Failure e) r)) ->
  Args ->
  Stack ->
  IO (Bool, Stack)
mkForeignExn :: forall a e r.
(ForeignConvention a, ForeignConvention e, ForeignConvention r) =>
(a -> IO (Either (Failure e) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignExn a -> IO (Either (Failure e) r)
f Args
args Stack
stk =
  Stack -> Args -> IO a
forall a. ForeignConvention a => Stack -> Args -> IO a
readsAt Stack
stk Args
args IO a
-> (a -> IO (Either (Failure e) r)) -> IO (Either (Failure e) r)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO (Either (Failure e) r)
f IO (Either (Failure e) r)
-> (Either (Failure e) r -> IO (Bool, Stack)) -> IO (Bool, Stack)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Failure e
e -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (Bool
True, Stack
stk) (Bool, Stack) -> IO () -> IO (Bool, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack -> Failure e -> IO ()
forall a. ForeignConvention a => Stack -> a -> IO ()
writeBack Stack
stk Failure e
e
    Right r
r -> do
      Stack
stk <- Stack -> IO Stack
bump Stack
stk
      (Bool
False, Stack
stk) (Bool, Stack) -> IO () -> IO (Bool, Stack)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Stack -> r -> IO ()
forall a. ForeignConvention a => Stack -> a -> IO ()
writeBack Stack
stk r
r

{-# INLINE mkForeignTls #-}
mkForeignTls ::
  forall a r.
  (ForeignConvention a, ForeignConvention r) =>
  (a -> IO r) ->
  Args ->
  Stack ->
  IO (Bool, Stack)
mkForeignTls :: forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls a -> IO r
f = (a -> IO (Either (Failure Val) r))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((a -> IO (Either (Failure Val) r))
 -> Args -> Stack -> IO (Bool, Stack))
-> (a -> IO (Either (Failure Val) r))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \a
a -> (Either IOException (Either TLSException r)
 -> Either (Failure Val) r)
-> IO (Either IOException (Either TLSException r))
-> IO (Either (Failure Val) r)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either IOException (Either TLSException r)
-> Either (Failure Val) r
flatten (IO (Either TLSException r)
-> IO (Either IOException (Either TLSException r))
tryIO2 (IO r -> IO (Either TLSException r)
tryIO1 (a -> IO r
f a
a)))
  where
    tryIO1 :: IO r -> IO (Either TLS.TLSException r)
    tryIO1 :: IO r -> IO (Either TLSException r)
tryIO1 = IO r -> IO (Either TLSException r)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try
    tryIO2 :: IO (Either TLS.TLSException r) -> IO (Either IOException (Either TLS.TLSException r))
    tryIO2 :: IO (Either TLSException r)
-> IO (Either IOException (Either TLSException r))
tryIO2 = IO (Either TLSException r)
-> IO (Either IOException (Either TLSException r))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try
    flatten :: Either IOException (Either TLS.TLSException r) -> Either ((F.Failure Val)) r
    flatten :: Either IOException (Either TLSException r)
-> Either (Failure Val) r
flatten (Left IOException
e) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left (Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.ioFailureRef ([Char] -> Text
Util.Text.pack (IOException -> [Char]
forall a. Show a => a -> [Char]
show IOException
e)) Val
unitValue)
    flatten (Right (Left TLSException
e)) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left (Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.tlsFailureRef ([Char] -> Text
Util.Text.pack (TLSException -> [Char]
forall a. Show a => a -> [Char]
show TLSException
e)) Val
unitValue)
    flatten (Right (Right r
a)) = r -> Either (Failure Val) r
forall a b. b -> Either a b
Right r
a

{-# INLINE mkForeignTlsE #-}
mkForeignTlsE ::
  forall a r.
  (ForeignConvention a, ForeignConvention r) =>
  (a -> IO (Either Failure r)) ->
  Args ->
  Stack ->
  IO (Bool, Stack)
mkForeignTlsE :: forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO (Either (Failure Val) r))
-> Args -> Stack -> IO (Bool, Stack)
mkForeignTlsE a -> IO (Either (Failure Val) r)
f = (a -> IO (Either (Failure Val) r))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((a -> IO (Either (Failure Val) r))
 -> Args -> Stack -> IO (Bool, Stack))
-> (a -> IO (Either (Failure Val) r))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \a
a -> (Either IOException (Either TLSException (Either (Failure Val) r))
 -> Either (Failure Val) r)
-> IO
     (Either IOException (Either TLSException (Either (Failure Val) r)))
-> IO (Either (Failure Val) r)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either IOException (Either TLSException (Either (Failure Val) r))
-> Either (Failure Val) r
flatten (IO (Either TLSException (Either (Failure Val) r))
-> IO
     (Either IOException (Either TLSException (Either (Failure Val) r)))
tryIO2 (IO (Either (Failure Val) r)
-> IO (Either TLSException (Either (Failure Val) r))
tryIO1 (a -> IO (Either (Failure Val) r)
f a
a)))
  where
    tryIO1 :: IO (Either Failure r) -> IO (Either TLS.TLSException (Either Failure r))
    tryIO1 :: IO (Either (Failure Val) r)
-> IO (Either TLSException (Either (Failure Val) r))
tryIO1 = IO (Either (Failure Val) r)
-> IO (Either TLSException (Either (Failure Val) r))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try
    tryIO2 :: IO (Either TLS.TLSException (Either Failure r)) -> IO (Either IOException (Either TLS.TLSException (Either Failure r)))
    tryIO2 :: IO (Either TLSException (Either (Failure Val) r))
-> IO
     (Either IOException (Either TLSException (Either (Failure Val) r)))
tryIO2 = IO (Either TLSException (Either (Failure Val) r))
-> IO
     (Either IOException (Either TLSException (Either (Failure Val) r)))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
UnliftIO.try
    flatten :: Either IOException (Either TLS.TLSException (Either Failure r)) -> Either Failure r
    flatten :: Either IOException (Either TLSException (Either (Failure Val) r))
-> Either (Failure Val) r
flatten (Left IOException
e) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left (Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.ioFailureRef ([Char] -> Text
Util.Text.pack (IOException -> [Char]
forall a. Show a => a -> [Char]
show IOException
e)) Val
unitValue)
    flatten (Right (Left TLSException
e)) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left (Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.tlsFailureRef ([Char] -> Text
Util.Text.pack (TLSException -> [Char]
forall a. Show a => a -> [Char]
show TLSException
e)) Val
unitValue)
    flatten (Right (Right (Left Failure Val
e))) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left Failure Val
e
    flatten (Right (Right (Right r
a))) = r -> Either (Failure Val) r
forall a b. b -> Either a b
Right r
a

{-# INLINE unsafeSTMToIO #-}
unsafeSTMToIO :: STM.STM a -> IO a
unsafeSTMToIO :: forall a. STM a -> IO a
unsafeSTMToIO (STM.STM State# RealWorld -> (# State# RealWorld, a #)
m) = (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO State# RealWorld -> (# State# RealWorld, a #)
m

signEd25519Wrapper ::
  (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes
signEd25519Wrapper :: (Bytes, Bytes, Bytes) -> Either (Failure Val) Bytes
signEd25519Wrapper (Bytes
secret0, Bytes
public0, Bytes
msg0) = case CryptoFailable (SecretKey, PublicKey)
validated of
  CryptoFailed CryptoError
err ->
    Failure Val -> Either (Failure Val) Bytes
forall a b. a -> Either a b
Left (Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.cryptoFailureRef (CryptoError -> Text
forall {a}. IsString a => CryptoError -> a
errMsg CryptoError
err) Val
unitValue)
  CryptoPassed (SecretKey
secret, PublicKey
public) ->
    Bytes -> Either (Failure Val) Bytes
forall a b. b -> Either a b
Right (Bytes -> Either (Failure Val) Bytes)
-> (Signature -> Bytes) -> Signature -> Either (Failure Val) Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray (Signature -> Either (Failure Val) Bytes)
-> Signature -> Either (Failure Val) Bytes
forall a b. (a -> b) -> a -> b
$ SecretKey -> PublicKey -> ByteString -> Signature
forall ba.
ByteArrayAccess ba =>
SecretKey -> PublicKey -> ba -> Signature
Ed25519.sign SecretKey
secret PublicKey
public ByteString
msg
  where
    msg :: ByteString
msg = Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
msg0 :: ByteString
    validated :: CryptoFailable (SecretKey, PublicKey)
validated =
      (,)
        (SecretKey -> PublicKey -> (SecretKey, PublicKey))
-> CryptoFailable SecretKey
-> CryptoFailable (PublicKey -> (SecretKey, PublicKey))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> CryptoFailable SecretKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable SecretKey
Ed25519.secretKey (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
secret0 :: ByteString)
        CryptoFailable (PublicKey -> (SecretKey, PublicKey))
-> CryptoFailable PublicKey
-> CryptoFailable (SecretKey, PublicKey)
forall a b.
CryptoFailable (a -> b) -> CryptoFailable a -> CryptoFailable b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> CryptoFailable PublicKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed25519.publicKey (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
public0 :: ByteString)

    errMsg :: CryptoError -> a
errMsg CryptoError
CryptoError_PublicKeySizeInvalid =
      a
"ed25519: Public key size invalid"
    errMsg CryptoError
CryptoError_SecretKeySizeInvalid =
      a
"ed25519: Secret key size invalid"
    errMsg CryptoError
CryptoError_SecretKeyStructureInvalid =
      a
"ed25519: Secret key structure invalid"
    errMsg CryptoError
_ = a
"ed25519: unexpected error"

verifyEd25519Wrapper ::
  (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool
verifyEd25519Wrapper :: (Bytes, Bytes, Bytes) -> Either (Failure Val) Bool
verifyEd25519Wrapper (Bytes
public0, Bytes
msg0, Bytes
sig0) = case CryptoFailable (PublicKey, Signature)
validated of
  CryptoFailed CryptoError
err ->
    Failure Val -> Either (Failure Val) Bool
forall a b. a -> Either a b
Left (Failure Val -> Either (Failure Val) Bool)
-> Failure Val -> Either (Failure Val) Bool
forall a b. (a -> b) -> a -> b
$ Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.cryptoFailureRef (CryptoError -> Text
forall {a}. IsString a => CryptoError -> a
errMsg CryptoError
err) Val
unitValue
  CryptoPassed (PublicKey
public, Signature
sig) ->
    Bool -> Either (Failure Val) Bool
forall a b. b -> Either a b
Right (Bool -> Either (Failure Val) Bool)
-> Bool -> Either (Failure Val) Bool
forall a b. (a -> b) -> a -> b
$ PublicKey -> ByteString -> Signature -> Bool
forall ba.
ByteArrayAccess ba =>
PublicKey -> ba -> Signature -> Bool
Ed25519.verify PublicKey
public ByteString
msg Signature
sig
  where
    msg :: ByteString
msg = Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
msg0 :: ByteString
    validated :: CryptoFailable (PublicKey, Signature)
validated =
      (,)
        (PublicKey -> Signature -> (PublicKey, Signature))
-> CryptoFailable PublicKey
-> CryptoFailable (Signature -> (PublicKey, Signature))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> CryptoFailable PublicKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed25519.publicKey (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
public0 :: ByteString)
        CryptoFailable (Signature -> (PublicKey, Signature))
-> CryptoFailable Signature
-> CryptoFailable (PublicKey, Signature)
forall a b.
CryptoFailable (a -> b) -> CryptoFailable a -> CryptoFailable b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> CryptoFailable Signature
forall ba. ByteArrayAccess ba => ba -> CryptoFailable Signature
Ed25519.signature (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
sig0 :: ByteString)

    errMsg :: CryptoError -> a
errMsg CryptoError
CryptoError_PublicKeySizeInvalid =
      a
"ed25519: Public key size invalid"
    errMsg CryptoError
CryptoError_SecretKeySizeInvalid =
      a
"ed25519: Secret key size invalid"
    errMsg CryptoError
CryptoError_SecretKeyStructureInvalid =
      a
"ed25519: Secret key structure invalid"
    errMsg CryptoError
_ = a
"ed25519: unexpected error"

signRsaWrapper ::
  (Bytes.Bytes, Bytes.Bytes) -> Either Failure Bytes.Bytes
signRsaWrapper :: (Bytes, Bytes) -> Either (Failure Val) Bytes
signRsaWrapper (Bytes
secret0, Bytes
msg0) = case Either Text PrivateKey
validated of
  Left Text
err ->
    Failure Val -> Either (Failure Val) Bytes
forall a b. a -> Either a b
Left (Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.cryptoFailureRef Text
err Val
unitValue)
  Right PrivateKey
secret ->
    case Maybe Blinder
-> Maybe SHA256
-> PrivateKey
-> ByteString
-> Either Error ByteString
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe Blinder
-> Maybe hashAlg
-> PrivateKey
-> ByteString
-> Either Error ByteString
RSA.sign Maybe Blinder
forall a. Maybe a
Nothing (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
Hash.SHA256) PrivateKey
secret ByteString
msg of
      Left Error
err -> Failure Val -> Either (Failure Val) Bytes
forall a b. a -> Either a b
Left (Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.cryptoFailureRef (Error -> Text
Rsa.rsaErrorToText Error
err) Val
unitValue)
      Right ByteString
signature -> Bytes -> Either (Failure Val) Bytes
forall a b. b -> Either a b
Right (Bytes -> Either (Failure Val) Bytes)
-> Bytes -> Either (Failure Val) Bytes
forall a b. (a -> b) -> a -> b
$ ByteString -> Bytes
Bytes.fromByteString ByteString
signature
  where
    msg :: ByteString
msg = Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
msg0 :: ByteString
    validated :: Either Text PrivateKey
validated = ByteString -> Either Text PrivateKey
Rsa.parseRsaPrivateKey (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
secret0 :: ByteString)

verifyRsaWrapper ::
  (Bytes.Bytes, Bytes.Bytes, Bytes.Bytes) -> Either Failure Bool
verifyRsaWrapper :: (Bytes, Bytes, Bytes) -> Either (Failure Val) Bool
verifyRsaWrapper (Bytes
public0, Bytes
msg0, Bytes
sig0) = case Either Text PublicKey
validated of
  Left Text
err ->
    Failure Val -> Either (Failure Val) Bool
forall a b. a -> Either a b
Left (Failure Val -> Either (Failure Val) Bool)
-> Failure Val -> Either (Failure Val) Bool
forall a b. (a -> b) -> a -> b
$ Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.cryptoFailureRef Text
err Val
unitValue
  Right PublicKey
public ->
    Bool -> Either (Failure Val) Bool
forall a b. b -> Either a b
Right (Bool -> Either (Failure Val) Bool)
-> Bool -> Either (Failure Val) Bool
forall a b. (a -> b) -> a -> b
$ Maybe SHA256 -> PublicKey -> ByteString -> ByteString -> Bool
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe hashAlg -> PublicKey -> ByteString -> ByteString -> Bool
RSA.verify (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
Hash.SHA256) PublicKey
public ByteString
msg ByteString
sig
  where
    msg :: ByteString
msg = Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
msg0 :: ByteString
    sig :: ByteString
sig = Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
sig0 :: ByteString
    validated :: Either Text PublicKey
validated = ByteString -> Either Text PublicKey
Rsa.parseRsaPublicKey (Bytes -> ByteString
forall b. ByteArray b => Bytes -> b
Bytes.toArray Bytes
public0 :: ByteString)

type Failure = F.Failure Val

checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b)
checkBounds :: forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds Text
name Int
l Pos
w IO (Either (Failure Val) b)
act
  | Pos
w Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l = IO (Either (Failure Val) b)
act
  | Bool
otherwise = Either (Failure Val) b -> IO (Either (Failure Val) b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) b -> IO (Either (Failure Val) b))
-> Either (Failure Val) b -> IO (Either (Failure Val) b)
forall a b. (a -> b) -> a -> b
$ Failure Val -> Either (Failure Val) b
forall a b. a -> Either a b
Left Failure Val
err
  where
    msg :: Text
msg = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": array index out of bounds"
    err :: Failure Val
err = Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.arrayFailureRef Text
msg (Pos -> Val
natValue Pos
w)

-- Performs a bounds check on a byte array. Strategy is as follows:
--
--   isz = signed array size-in-bytes
--   off = unsigned byte offset into the array
--   esz = unsigned number of bytes to be read
--
--   1. Turn the signed size-in-bytes of the array unsigned
--   2. Add the offset to the to-be-read number to get the maximum size needed
--   3. Check that the actual array size is at least as big as the needed size
--   4. Check that the offset is less than the size
--
-- Step 4 ensures that step 3 has not overflowed. Since an actual array size can
-- only be 63 bits (since it is signed), the only way for 3 to overflow is if
-- the offset is larger than a possible array size, since it would need to be
-- 2^64-k, where k is the small (<=8) number of bytes to be read.
checkBoundsPrim ::
  Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b)
checkBoundsPrim :: forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name Int
isz Pos
off Pos
esz IO (Either (Failure Val) b)
act
  | Pos
w Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
> Pos
bsz Bool -> Bool -> Bool
|| Pos
off Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
> Pos
bsz = Either (Failure Val) b -> IO (Either (Failure Val) b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) b -> IO (Either (Failure Val) b))
-> Either (Failure Val) b -> IO (Either (Failure Val) b)
forall a b. (a -> b) -> a -> b
$ Failure Val -> Either (Failure Val) b
forall a b. a -> Either a b
Left Failure Val
err
  | Bool
otherwise = IO (Either (Failure Val) b)
act
  where
    msg :: Text
msg = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": array index out of bounds"
    err :: Failure Val
err = Reference -> Text -> Val -> Failure Val
forall a. Reference -> Text -> a -> Failure a
F.Failure Reference
Ty.arrayFailureRef Text
msg (Pos -> Val
natValue Pos
off)

    bsz :: Pos
bsz = Int -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
isz
    w :: Pos
w = Pos
off Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
esz

type RW = PA.PrimState IO

checkedRead ::
  Text -> (PA.MutableArray RW Val, Word64) -> IO (Either Failure Val)
checkedRead :: Text -> (MutableArray RW Val, Pos) -> IO (Either (Failure Val) Val)
checkedRead Text
name (MutableArray RW Val
arr, Pos
w) =
  Text
-> Int
-> Pos
-> IO (Either (Failure Val) Val)
-> IO (Either (Failure Val) Val)
forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds
    Text
name
    (MutableArray RealWorld Val -> Int
forall s a. MutableArray s a -> Int
PA.sizeofMutableArray MutableArray RealWorld Val
MutableArray RW Val
arr)
    Pos
w
    (Val -> Either (Failure Val) Val
forall a b. b -> Either a b
Right (Val -> Either (Failure Val) Val)
-> IO Val -> IO (Either (Failure Val) Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray RW Val -> Int -> IO Val
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> m a
PA.readArray MutableArray RW Val
arr (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
w))

checkedWrite ::
  Text -> (PA.MutableArray RW Val, Word64, Val) -> IO (Either Failure ())
checkedWrite :: Text
-> (MutableArray RW Val, Pos, Val) -> IO (Either (Failure Val) ())
checkedWrite Text
name (MutableArray RW Val
arr, Pos
w, Val
v) =
  Text
-> Int
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds
    Text
name
    (MutableArray RealWorld Val -> Int
forall s a. MutableArray s a -> Int
PA.sizeofMutableArray MutableArray RealWorld Val
MutableArray RW Val
arr)
    Pos
w
    (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right (() -> Either (Failure Val) ())
-> IO () -> IO (Either (Failure Val) ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray RW Val -> Int -> Val -> IO ()
forall (m :: * -> *) a.
(() :: Constraint, PrimMonad m) =>
MutableArray (PrimState m) a -> Int -> a -> m ()
PA.writeArray MutableArray RW Val
arr (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
w) Val
v)

checkedIndex ::
  Text -> (PA.Array Val, Word64) -> IO (Either Failure Val)
checkedIndex :: Text -> (Array Val, Pos) -> IO (Either (Failure Val) Val)
checkedIndex Text
name (Array Val
arr, Pos
w) =
  Text
-> Int
-> Pos
-> IO (Either (Failure Val) Val)
-> IO (Either (Failure Val) Val)
forall b.
Text
-> Int
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBounds
    Text
name
    (Array Val -> Int
forall a. Array a -> Int
PA.sizeofArray Array Val
arr)
    Pos
w
    (Val -> Either (Failure Val) Val
forall a b. b -> Either a b
Right (Val -> Either (Failure Val) Val)
-> IO Val -> IO (Either (Failure Val) Val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array Val -> Int -> IO Val
forall (m :: * -> *) a. Monad m => Array a -> Int -> m a
PA.indexArrayM Array Val
arr (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
w))

checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead8 :: Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead8 Text
name (MutableByteArray RW
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
1 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    (Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Either (Failure Val) Pos)
-> (Word8 -> Pos) -> Word8 -> Either (Failure Val) Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Either (Failure Val) Pos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr Int
j
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead16 :: Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead16 Text
name (MutableByteArray RW
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
2 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    Word8 -> Word8 -> Either (Failure Val) Pos
mk16
      (Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Either (Failure Val) Pos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr Int
j
      IO (Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead24 :: Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead24 Text
name (MutableByteArray RW
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
3 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk24
      (Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Word8 -> Either (Failure Val) Pos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr Int
j
      IO (Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      IO (Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead32 :: Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead32 Text
name (MutableByteArray RW
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
4 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk32
      (Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8
-> IO (Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr Int
j
      IO (Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      IO (Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
      IO (Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead40 :: Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead40 Text
name (MutableByteArray RW
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
6 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    Word8
-> Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk40
      (Word8
 -> Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8
-> IO
     (Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr Int
j
      IO (Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8
-> IO (Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      IO (Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
      IO (Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
      IO (Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead64 :: Text -> (MutableByteArray RW, Pos) -> IO (Either (Failure Val) Pos)
checkedRead64 Text
name (MutableByteArray RW
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
8 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Either (Failure Val) Pos
mk64
      (Word8
 -> Word8
 -> Word8
 -> Word8
 -> Word8
 -> Word8
 -> Word8
 -> Word8
 -> Either (Failure Val) Pos)
-> IO Word8
-> IO
     (Word8
      -> Word8
      -> Word8
      -> Word8
      -> Word8
      -> Word8
      -> Word8
      -> Either (Failure Val) Pos)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr Int
j
      IO
  (Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Either (Failure Val) Pos)
-> IO Word8
-> IO
     (Word8
      -> Word8
      -> Word8
      -> Word8
      -> Word8
      -> Word8
      -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      IO
  (Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Word8
   -> Either (Failure Val) Pos)
-> IO Word8
-> IO
     (Word8
      -> Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
      IO
  (Word8
   -> Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8
-> IO
     (Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
      IO (Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8
-> IO (Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
      IO (Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5)
      IO (Word8 -> Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Word8 -> Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6)
      IO (Word8 -> Either (Failure Val) Pos)
-> IO Word8 -> IO (Either (Failure Val) Pos)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7)
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

mk16 :: Word8 -> Word8 -> Either Failure Word64
mk16 :: Word8 -> Word8 -> Either (Failure Val) Pos
mk16 Word8
b0 Word8
b1 = Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Either (Failure Val) Pos)
-> Pos -> Either (Failure Val) Pos
forall a b. (a -> b) -> a -> b
$ (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1)

mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64
mk24 :: Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk24 Word8
b0 Word8
b1 Word8
b2 =
  Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Either (Failure Val) Pos)
-> Pos -> Either (Failure Val) Pos
forall a b. (a -> b) -> a -> b
$
    (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b2)

mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64
mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk32 Word8
b0 Word8
b1 Word8
b2 Word8
b3 =
  Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Either (Failure Val) Pos)
-> Pos -> Either (Failure Val) Pos
forall a b. (a -> b) -> a -> b
$
    (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b2 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b3)

mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64
mk40 :: Word8
-> Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk40 Word8
b0 Word8
b1 Word8
b2 Word8
b3 Word8
b4 =
  Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Either (Failure Val) Pos)
-> Pos -> Either (Failure Val) Pos
forall a b. (a -> b) -> a -> b
$
    (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
32)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b2 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b3 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b4)

mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64
mk64 :: Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Either (Failure Val) Pos
mk64 Word8
b0 Word8
b1 Word8
b2 Word8
b3 Word8
b4 Word8
b5 Word8
b6 Word8
b7 =
  Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Either (Failure Val) Pos)
-> Pos -> Either (Failure Val) Pos
forall a b. (a -> b) -> a -> b
$
    (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b0 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
56)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
48)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b2 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
40)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b3 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
32)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b4 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b5 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b6 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
      Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b7)

checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ())
checkedWrite8 :: Text
-> (MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ())
checkedWrite8 Text
name (MutableByteArray RW
arr, Pos
i, Pos
v) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
1 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr Int
j (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v :: Word8)
    pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ())
checkedWrite16 :: Text
-> (MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ())
checkedWrite16 Text
name (MutableByteArray RW
arr, Pos
i, Pos
v) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
2 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr Int
j (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
8 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v :: Word8)
    pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ())
checkedWrite32 :: Text
-> (MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ())
checkedWrite32 Text
name (MutableByteArray RW
arr, Pos
i, Pos
v) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
4 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr Int
j (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
24 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
16 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
8 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v :: Word8)
    pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ())
checkedWrite64 :: Text
-> (MutableByteArray RW, Pos, Pos) -> IO (Either (Failure Val) ())
checkedWrite64 Text
name (MutableByteArray RW
arr, Pos
i, Pos
v) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) ())
-> IO (Either (Failure Val) ())
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
MutableByteArray RW
arr) Pos
i Pos
8 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ())
forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr Int
j (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
56 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
48 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
40 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
32 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
24 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
16 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> Pos -> Word8
forall a b. (a -> b) -> a -> b
$ Pos
v Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftR` Int
8 :: Word8)
    MutableByteArray RW -> Int -> Word8 -> IO ()
forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
PA.writeByteArray MutableByteArray RW
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) (Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v :: Word8)
    pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())
  where
    j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i

-- index single byte
checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex8 :: Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex8 Text
name (ByteArray
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (ByteArray -> Int
PA.sizeofByteArray ByteArray
arr) Pos
i Pos
1 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos
-> IO (Either (Failure Val) Pos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    let j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i
     in Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Either (Failure Val) Pos)
-> (Word8 -> Pos) -> Word8 -> Either (Failure Val) Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Either (Failure Val) Pos)
-> Word8 -> Either (Failure Val) Pos
forall a b. (a -> b) -> a -> b
$ forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray @Word8 ByteArray
arr Int
j

-- index 16 big-endian
checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex16 :: Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex16 Text
name (ByteArray
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (ByteArray -> Int
PA.sizeofByteArray ByteArray
arr) Pos
i Pos
2 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos
-> IO (Either (Failure Val) Pos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    let j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i
     in Word8 -> Word8 -> Either (Failure Val) Pos
mk16 (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr Int
j) (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

-- index 32 big-endian
checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex24 :: Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex24 Text
name (ByteArray
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (ByteArray -> Int
PA.sizeofByteArray ByteArray
arr) Pos
i Pos
3 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos
-> IO (Either (Failure Val) Pos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    let j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i
     in Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk24
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr Int
j)
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))

-- index 32 big-endian
checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex32 :: Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex32 Text
name (ByteArray
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (ByteArray -> Int
PA.sizeofByteArray ByteArray
arr) Pos
i Pos
4 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos
-> IO (Either (Failure Val) Pos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    let j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i
     in Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk32
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr Int
j)
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3))

-- index 40 big-endian
checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex40 :: Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex40 Text
name (ByteArray
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (ByteArray -> Int
PA.sizeofByteArray ByteArray
arr) Pos
i Pos
5 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos
-> IO (Either (Failure Val) Pos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    let j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i
     in Word8
-> Word8 -> Word8 -> Word8 -> Word8 -> Either (Failure Val) Pos
mk40
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr Int
j)
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4))

-- index 64 big-endian
checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex64 :: Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex64 Text
name (ByteArray
arr, Pos
i) =
  Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Pos)
-> IO (Either (Failure Val) Pos)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim Text
name (ByteArray -> Int
PA.sizeofByteArray ByteArray
arr) Pos
i Pos
8 (IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos))
-> (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos
-> IO (Either (Failure Val) Pos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) Pos -> IO (Either (Failure Val) Pos))
-> Either (Failure Val) Pos -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$
    let j :: Int
j = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i
     in Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Word8
-> Either (Failure Val) Pos
mk64
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr Int
j)
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
5))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6))
          (ByteArray -> Int -> Word8
forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray ByteArray
arr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7))

-- A ForeignConvention explains how to encode foreign values as
-- unison types. Depending on the situation, this can take three
-- forms.
--
--   1. Reading/writing directly from/to the stack
--   2. Reading a tuple directly from the stack
--   3. Translating a standalone value
--
-- The first is used when the value in question is the one that is
-- going to be directly on the stack, to allow for slight
-- optimization (e.g. an `Either` only requires reading/writing the
-- boxed portion of the stack). For compound types, though, it's
-- necessary to be able to de/encode a value that was nested inside
-- something else.
--
-- The second is used for multi-argument foreign functions. The
-- default implementation expects a single argument, and reads at
-- that specific index. But, tuples and the unit type can override
-- to read multiple arguments directly from the stack. This works
-- out better than having a separate class with a default
-- ForeignConvention instance, because the latter requires
-- incoherence to work as expected.
--
-- We can give a default implementation of the stack operations in
-- terms of the other coding.
class ForeignConvention a where
  readAtIndex :: Stack -> Int -> IO a
  readsAt :: Stack -> Args -> IO a
  decodeVal :: Val -> IO a

  readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff Stack
stk Int
i IO Val -> (Val -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal

  readsAt Stack
stk (VArg1 Int
i) = Stack -> Int -> IO a
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk Int
i
  readsAt Stack
_ Args
args = [Char] -> Args -> IO a
forall a. [Char] -> Args -> IO a
readsAtError [Char]
"one argument" Args
args

  writeBack :: Stack -> a -> IO ()
  encodeVal :: a -> Val

  writeBack Stack
stk a
v = (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke Stack
stk (a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
v)

readsAtError :: String -> Args -> IO a
readsAtError :: forall a. [Char] -> Args -> IO a
readsAtError [Char]
expect Args
args = RuntimePanic -> IO a
forall e a. Exception e => e -> IO a
throwIO (RuntimePanic -> IO a) -> RuntimePanic -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe Val -> RuntimePanic
Panic [Char]
msg Maybe Val
forall a. Maybe a
Nothing
  where
    msg :: [Char]
msg = [Char]
"readsAt: expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
expect [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Args -> [Char]
forall a. Show a => a -> [Char]
show Args
args

foreignConventionError :: String -> Val -> IO a
foreignConventionError :: forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
ty Val
v = RuntimePanic -> IO a
forall e a. Exception e => e -> IO a
throwIO (RuntimePanic -> IO a) -> RuntimePanic -> IO a
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe Val -> RuntimePanic
Panic [Char]
msg (Val -> Maybe Val
forall a. a -> Maybe a
Just Val
v)
  where
    msg :: [Char]
msg = [Char]
"mismatched foreign calling convention for `" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
ty [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"`"

instance
  ( ForeignConvention a,
    ForeignConvention b
  ) =>
  ForeignConvention (Either a b)
  where
  decodeVal :: Val -> IO (Either a b)
decodeVal (BoxedVal (Data1 Reference
_ PackedTag
t Val
v))
    | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.leftTag = a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> IO a -> IO (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v
    | Bool
otherwise = b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> IO b -> IO (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO b
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v
  decodeVal Val
v = [Char] -> Val -> IO (Either a b)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Either" Val
v

  encodeVal :: Either a b -> Val
encodeVal (Left a
x) =
    Closure -> Val
BoxedVal (Closure -> Val) -> (Val -> Closure) -> Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.eitherRef PackedTag
TT.leftTag (Val -> Val) -> Val -> Val
forall a b. (a -> b) -> a -> b
$ a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
x
  encodeVal (Right b
y) =
    Closure -> Val
BoxedVal (Closure -> Val) -> (Val -> Closure) -> Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.eitherRef PackedTag
TT.rightTag (Val -> Val) -> Val -> Val
forall a b. (a -> b) -> a -> b
$ b -> Val
forall a. ForeignConvention a => a -> Val
encodeVal b
y

  readAtIndex :: Stack -> Int -> IO (Either a b)
readAtIndex Stack
stk Int
i =
    (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO (Either a b)) -> IO (Either a b)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Data1 Reference
_ PackedTag
t Val
v
        | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.leftTag -> a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> IO a -> IO (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v
        | Bool
otherwise -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> IO b -> IO (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO b
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v
      Closure
c -> [Char] -> Val -> IO (Either a b)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Either" (Closure -> Val
BoxedVal Closure
c)

  writeBack :: Stack -> Either a b -> IO ()
writeBack Stack
stk (Left a
x) =
    (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> (Val -> Closure) -> Val -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.eitherRef PackedTag
TT.leftTag (Val -> IO ()) -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
x
  writeBack Stack
stk (Right b
y) =
    (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> (Val -> Closure) -> Val -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.eitherRef PackedTag
TT.rightTag (Val -> IO ()) -> Val -> IO ()
forall a b. (a -> b) -> a -> b
$ b -> Val
forall a. ForeignConvention a => a -> Val
encodeVal b
y

instance (ForeignConvention a) => ForeignConvention (Maybe a) where
  decodeVal :: Val -> IO (Maybe a)
decodeVal (BoxedVal (Enum Reference
_ PackedTag
_)) = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  decodeVal (BoxedVal (Data1 Reference
_ PackedTag
_ Val
v)) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v
  decodeVal Val
v = [Char] -> Val -> IO (Maybe a)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Maybe" Val
v

  encodeVal :: Maybe a -> Val
encodeVal Maybe a
Nothing = Val
noneVal
  encodeVal (Just a
v) = Val -> Val
someVal (a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
v)

  readAtIndex :: Stack -> Int -> IO (Maybe a)
readAtIndex Stack
stk Int
i =
    (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO (Maybe a)) -> IO (Maybe a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Data1 Reference
_ PackedTag
_ Val
v -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v
      Enum Reference
_ PackedTag
_ -> Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
      Closure
c -> [Char] -> Val -> IO (Maybe a)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Maybe" (Closure -> Val
BoxedVal Closure
c)

  writeBack :: Stack -> Maybe a -> IO ()
writeBack Stack
stk Maybe a
Nothing = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk Closure
noneClo
  writeBack Stack
stk (Just a
v) = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Val -> Closure
someClo (a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
v))

noneClo :: Closure
noneClo :: Closure
noneClo = Reference -> PackedTag -> Closure
Enum Reference
Ty.optionalRef PackedTag
TT.noneTag

noneVal :: Val
noneVal :: Val
noneVal = Closure -> Val
BoxedVal Closure
noneClo

someClo :: Val -> Closure
someClo :: Val -> Closure
someClo Val
v = Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.optionalRef PackedTag
TT.someTag Val
v

someVal :: Val -> Val
someVal :: Val -> Val
someVal Val
v = Closure -> Val
BoxedVal (Val -> Closure
someClo Val
v)

instance ForeignConvention Int where
  decodeVal :: Val -> IO Int
decodeVal (IntVal Int
v) = Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
v
  decodeVal Val
v = [Char] -> Val -> IO Int
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Int" Val
v
  encodeVal :: Int -> Val
encodeVal = Int -> Val
IntVal

  readAtIndex :: Stack -> Int -> IO Int
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  writeBack :: Stack -> Int -> IO ()
writeBack Stack
stk Int
v = (() :: Constraint) => Stack -> Int -> Closure -> IO ()
Stack -> Int -> Closure -> IO ()
upokeT Stack
stk Int
v Closure
intTypeTag

-- We don't have a clear mapping from these types to Unison types, most are just mapped to Nats.

instance ForeignConvention Word8 where
  decodeVal :: Val -> IO Word8
decodeVal (NatVal Pos
v) = Word8 -> IO Word8
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> IO Word8) -> Word8 -> IO Word8
forall a b. (a -> b) -> a -> b
$ Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v
  decodeVal Val
v = [Char] -> Val -> IO Word8
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Word8" Val
v
  encodeVal :: Word8 -> Val
encodeVal Word8
w = Pos -> Val
NatVal (Pos -> Val) -> Pos -> Val
forall a b. (a -> b) -> a -> b
$ Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w

  readAtIndex :: Stack -> Int -> IO Word8
readAtIndex Stack
stk Int
i = Pos -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word8) -> IO Pos -> IO Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Int -> IO Pos
peekOffN Stack
stk Int
i
  writeBack :: Stack -> Word8 -> IO ()
writeBack Stack
stk Word8
v = Stack -> Pos -> IO ()
pokeN Stack
stk (Pos -> IO ()) -> Pos -> IO ()
forall a b. (a -> b) -> a -> b
$ Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
v

instance ForeignConvention Word16 where
  decodeVal :: Val -> IO Word16
decodeVal (NatVal Pos
v) = Word16 -> IO Word16
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word16 -> IO Word16) -> Word16 -> IO Word16
forall a b. (a -> b) -> a -> b
$ Pos -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v
  decodeVal Val
v = [Char] -> Val -> IO Word16
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Word16" Val
v
  encodeVal :: Word16 -> Val
encodeVal Word16
w = Pos -> Val
NatVal (Pos -> Val) -> Pos -> Val
forall a b. (a -> b) -> a -> b
$ Word16 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w

  readAtIndex :: Stack -> Int -> IO Word16
readAtIndex Stack
stk Int
i = Pos -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Word16) -> IO Pos -> IO Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Int -> IO Pos
peekOffN Stack
stk Int
i
  writeBack :: Stack -> Word16 -> IO ()
writeBack Stack
stk Word16
v = Stack -> Pos -> IO ()
pokeN Stack
stk (Pos -> IO ()) -> Pos -> IO ()
forall a b. (a -> b) -> a -> b
$ Word16 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
v

instance ForeignConvention Word32 where
  decodeVal :: Val -> IO Word32
decodeVal (NatVal Pos
v) = Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> IO Word32) -> Word32 -> IO Word32
forall a b. (a -> b) -> a -> b
$ Pos -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v
  decodeVal Val
v = [Char] -> Val -> IO Word32
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Word32" Val
v
  encodeVal :: Word32 -> Val
encodeVal Word32
w = Pos -> Val
NatVal (Pos -> Val) -> Pos -> Val
forall a b. (a -> b) -> a -> b
$ Word32 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w

  readAtIndex :: Stack -> Int -> IO Word32
readAtIndex Stack
stk Int
i = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> IO Int -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
upeekOff Stack
stk Int
i
  writeBack :: Stack -> Word32 -> IO ()
writeBack Stack
stk Word32
v = Stack -> Pos -> IO ()
pokeN Stack
stk (Pos -> IO ()) -> Pos -> IO ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
v

instance ForeignConvention Word64 where
  decodeVal :: Val -> IO Pos
decodeVal (NatVal Pos
w) = Pos -> IO Pos
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pos
w
  decodeVal Val
v = [Char] -> Val -> IO Pos
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Word64" Val
v
  encodeVal :: Pos -> Val
encodeVal Pos
w = Pos -> Val
NatVal Pos
w

  readAtIndex :: Stack -> Int -> IO Pos
readAtIndex Stack
stk Int
i = Stack -> Int -> IO Pos
peekOffN Stack
stk Int
i
  writeBack :: Stack -> Pos -> IO ()
writeBack Stack
stk Pos
w = Stack -> Pos -> IO ()
pokeN Stack
stk Pos
w

instance ForeignConvention Char where
  decodeVal :: Val -> IO Char
decodeVal (CharVal Char
c) = Char -> IO Char
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
  decodeVal Val
v = [Char] -> Val -> IO Char
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Char" Val
v

  encodeVal :: Char -> Val
encodeVal Char
c = Char -> Val
CharVal Char
c

  readAtIndex :: Stack -> Int -> IO Char
readAtIndex = Stack -> Int -> IO Char
peekOffC
  writeBack :: Stack -> Char -> IO ()
writeBack = Stack -> Char -> IO ()
pokeC

unitClo :: Closure
unitClo :: Closure
unitClo = Reference -> PackedTag -> Closure
Enum Reference
Ty.unitRef PackedTag
TT.unitTag

unitVal :: Val
unitVal :: Val
unitVal = Closure -> Val
BoxedVal Closure
unitClo

instance ForeignConvention () where
  decodeVal :: Val -> IO ()
decodeVal Val
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  encodeVal :: () -> Val
encodeVal ()
_ = Val
unitVal

  readsAt :: Stack -> Args -> IO ()
readsAt Stack
_ Args
ZArgs = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  readsAt Stack
_ Args
as = [Char] -> Args -> IO ()
forall a. [Char] -> Args -> IO a
readsAtError [Char]
"zero arguments" Args
as

  readAtIndex :: Stack -> Int -> IO ()
readAtIndex Stack
_ Int
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  writeBack :: Stack -> () -> IO ()
writeBack Stack
stk ()
_ = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Closure
unitClo

pattern ConsC :: Val -> Val -> Closure
pattern $mConsC :: forall {r}. Closure -> (Val -> Val -> r) -> ((# #) -> r) -> r
$bConsC :: Val -> Val -> Closure
ConsC x y <- Data2 _ _ x y
  where
    ConsC Val
x Val
y = Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef PackedTag
TT.pairTag Val
x Val
y

pattern $mConsV :: forall {r}. Val -> (Val -> Val -> r) -> ((# #) -> r) -> r
$bConsV :: Val -> Val -> Val
ConsV x y = BoxedVal (ConsC x y)

pattern Tup2C :: Val -> Val -> Closure
pattern $mTup2C :: forall {r}. Closure -> (Val -> Val -> r) -> ((# #) -> r) -> r
$bTup2C :: Val -> Val -> Closure
Tup2C x y <- ConsC x (ConsV y _)
  where
    Tup2C Val
x Val
y = Val -> Val -> Closure
ConsC Val
x (Val -> Val -> Val
ConsV Val
y Val
unitVal)

pattern $mTup2V :: forall {r}. Val -> (Val -> Val -> r) -> ((# #) -> r) -> r
$bTup2V :: Val -> Val -> Val
Tup2V x y = BoxedVal (Tup2C x y)

decodeTup2 :: (ForeignConvention a, ForeignConvention b) => Closure -> IO (a, b)
decodeTup2 :: forall a b.
(ForeignConvention a, ForeignConvention b) =>
Closure -> IO (a, b)
decodeTup2 (Tup2C Val
x Val
y) = (,) (a -> b -> (a, b)) -> IO a -> IO (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
x IO (b -> (a, b)) -> IO b -> IO (a, b)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO b
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
y
decodeTup2 Closure
c = [Char] -> Val -> IO (a, b)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Pair" (Closure -> Val
BoxedVal Closure
c)

encodeTup2 :: (ForeignConvention a, ForeignConvention b) => (a, b) -> Closure
encodeTup2 :: forall a b.
(ForeignConvention a, ForeignConvention b) =>
(a, b) -> Closure
encodeTup2 (a
x, b
y) = Val -> Val -> Closure
Tup2C (a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
x) (b -> Val
forall a. ForeignConvention a => a -> Val
encodeVal b
y)

instance
  ( ForeignConvention a,
    ForeignConvention b
  ) =>
  ForeignConvention (a, b)
  where
  decodeVal :: Val -> IO (a, b)
decodeVal (BoxedVal Closure
v) = Closure -> IO (a, b)
forall a b.
(ForeignConvention a, ForeignConvention b) =>
Closure -> IO (a, b)
decodeTup2 Closure
v
  decodeVal Val
v = [Char] -> Val -> IO (a, b)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Pair" Val
v
  encodeVal :: (a, b) -> Val
encodeVal (a, b)
p = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ (a, b) -> Closure
forall a b.
(ForeignConvention a, ForeignConvention b) =>
(a, b) -> Closure
encodeTup2 (a, b)
p

  readsAt :: Stack -> Args -> IO (a, b)
readsAt Stack
stk (VArg2 Int
i Int
j) =
    (,)
      (a -> b -> (a, b)) -> IO a -> IO (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Int -> IO a
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk Int
i
      IO (b -> (a, b)) -> IO b -> IO (a, b)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO b
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk Int
j
  readsAt Stack
_ Args
as = [Char] -> Args -> IO (a, b)
forall a. [Char] -> Args -> IO a
readsAtError [Char]
"two arguments" Args
as

  readAtIndex :: Stack -> Int -> IO (a, b)
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO (a, b)) -> IO (a, b)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO (a, b)
forall a b.
(ForeignConvention a, ForeignConvention b) =>
Closure -> IO (a, b)
decodeTup2
  writeBack :: Stack -> (a, b) -> IO ()
writeBack Stack
stk (a, b)
p = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ (a, b) -> Closure
forall a b.
(ForeignConvention a, ForeignConvention b) =>
(a, b) -> Closure
encodeTup2 (a, b)
p

pattern $mTup3C :: forall {r}.
Closure -> (Val -> Val -> Val -> r) -> ((# #) -> r) -> r
$bTup3C :: Val -> Val -> Val -> Closure
Tup3C x y z = ConsC x (Tup2V y z)

pattern $mTup3V :: forall {r}. Val -> (Val -> Val -> Val -> r) -> ((# #) -> r) -> r
$bTup3V :: Val -> Val -> Val -> Val
Tup3V x y z = BoxedVal (Tup3C x y z)

decodeTup3 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c) => Closure -> IO (a, b, c)
decodeTup3 :: forall a b c.
(ForeignConvention a, ForeignConvention b, ForeignConvention c) =>
Closure -> IO (a, b, c)
decodeTup3 (Tup3C Val
x Val
y Val
z) =
  (,,) (a -> b -> c -> (a, b, c)) -> IO a -> IO (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
x IO (b -> c -> (a, b, c)) -> IO b -> IO (c -> (a, b, c))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO b
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
y IO (c -> (a, b, c)) -> IO c -> IO (a, b, c)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO c
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
z
decodeTup3 Closure
c = [Char] -> Val -> IO (a, b, c)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Triple" (Closure -> Val
BoxedVal Closure
c)

encodeTup3 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c) => (a, b, c) -> Closure
encodeTup3 :: forall a b c.
(ForeignConvention a, ForeignConvention b, ForeignConvention c) =>
(a, b, c) -> Closure
encodeTup3 (a
x, b
y, c
z) = Val -> Val -> Val -> Closure
Tup3C (a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
x) (b -> Val
forall a. ForeignConvention a => a -> Val
encodeVal b
y) (c -> Val
forall a. ForeignConvention a => a -> Val
encodeVal c
z)

instance
  ( ForeignConvention a,
    ForeignConvention b,
    ForeignConvention c
  ) =>
  ForeignConvention (a, b, c)
  where
  decodeVal :: Val -> IO (a, b, c)
decodeVal (BoxedVal Closure
v) = Closure -> IO (a, b, c)
forall a b c.
(ForeignConvention a, ForeignConvention b, ForeignConvention c) =>
Closure -> IO (a, b, c)
decodeTup3 Closure
v
  decodeVal Val
v = [Char] -> Val -> IO (a, b, c)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Triple" Val
v
  encodeVal :: (a, b, c) -> Val
encodeVal (a, b, c)
p = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ (a, b, c) -> Closure
forall a b c.
(ForeignConvention a, ForeignConvention b, ForeignConvention c) =>
(a, b, c) -> Closure
encodeTup3 (a, b, c)
p

  readsAt :: Stack -> Args -> IO (a, b, c)
readsAt Stack
stk (VArgN PrimArray Int
v) =
    (,,)
      (a -> b -> c -> (a, b, c)) -> IO a -> IO (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Int -> IO a
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
0)
      IO (b -> c -> (a, b, c)) -> IO b -> IO (c -> (a, b, c))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO b
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
1)
      IO (c -> (a, b, c)) -> IO c -> IO (a, b, c)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO c
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
2)
  readsAt Stack
_ Args
as = [Char] -> Args -> IO (a, b, c)
forall a. [Char] -> Args -> IO a
readsAtError [Char]
"three arguments" Args
as

  readAtIndex :: Stack -> Int -> IO (a, b, c)
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO (a, b, c)) -> IO (a, b, c)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO (a, b, c)
forall a b c.
(ForeignConvention a, ForeignConvention b, ForeignConvention c) =>
Closure -> IO (a, b, c)
decodeTup3
  writeBack :: Stack -> (a, b, c) -> IO ()
writeBack Stack
stk (a, b, c)
p = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ (a, b, c) -> Closure
forall a b c.
(ForeignConvention a, ForeignConvention b, ForeignConvention c) =>
(a, b, c) -> Closure
encodeTup3 (a, b, c)
p

pattern $mTup4C :: forall {r}.
Closure -> (Val -> Val -> Val -> Val -> r) -> ((# #) -> r) -> r
$bTup4C :: Val -> Val -> Val -> Val -> Closure
Tup4C w x y z = ConsC w (Tup3V x y z)

pattern $mTup4V :: forall {r}.
Val -> (Val -> Val -> Val -> Val -> r) -> ((# #) -> r) -> r
$bTup4V :: Val -> Val -> Val -> Val -> Val
Tup4V w x y z = BoxedVal (Tup4C w x y z)

decodeTup4 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d) => Closure -> IO (a, b, c, d)
decodeTup4 :: forall a b c d.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d) =>
Closure -> IO (a, b, c, d)
decodeTup4 (Tup4C Val
w Val
x Val
y Val
z) =
  (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> IO a -> IO (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
w IO (b -> c -> d -> (a, b, c, d))
-> IO b -> IO (c -> d -> (a, b, c, d))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO b
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
x IO (c -> d -> (a, b, c, d)) -> IO c -> IO (d -> (a, b, c, d))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO c
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
y IO (d -> (a, b, c, d)) -> IO d -> IO (a, b, c, d)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO d
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
z
decodeTup4 Closure
c = [Char] -> Val -> IO (a, b, c, d)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Quadruple" (Closure -> Val
BoxedVal Closure
c)

encodeTup4 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d) => (a, b, c, d) -> Closure
encodeTup4 :: forall a b c d.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d) =>
(a, b, c, d) -> Closure
encodeTup4 (a
w, b
x, c
y, d
z) =
  Val -> Val -> Val -> Val -> Closure
Tup4C (a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
w) (b -> Val
forall a. ForeignConvention a => a -> Val
encodeVal b
x) (c -> Val
forall a. ForeignConvention a => a -> Val
encodeVal c
y) (d -> Val
forall a. ForeignConvention a => a -> Val
encodeVal d
z)

instance
  ( ForeignConvention a,
    ForeignConvention b,
    ForeignConvention c,
    ForeignConvention d
  ) =>
  ForeignConvention (a, b, c, d)
  where
  decodeVal :: Val -> IO (a, b, c, d)
decodeVal (BoxedVal Closure
v) = Closure -> IO (a, b, c, d)
forall a b c d.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d) =>
Closure -> IO (a, b, c, d)
decodeTup4 Closure
v
  decodeVal Val
v = [Char] -> Val -> IO (a, b, c, d)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Quadruple" Val
v

  encodeVal :: (a, b, c, d) -> Val
encodeVal (a, b, c, d)
p = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ (a, b, c, d) -> Closure
forall a b c d.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d) =>
(a, b, c, d) -> Closure
encodeTup4 (a, b, c, d)
p

  readsAt :: Stack -> Args -> IO (a, b, c, d)
readsAt Stack
stk (VArgN PrimArray Int
v) =
    (,,,)
      (a -> b -> c -> d -> (a, b, c, d))
-> IO a -> IO (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Int -> IO a
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
0)
      IO (b -> c -> d -> (a, b, c, d))
-> IO b -> IO (c -> d -> (a, b, c, d))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO b
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
1)
      IO (c -> d -> (a, b, c, d)) -> IO c -> IO (d -> (a, b, c, d))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO c
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
2)
      IO (d -> (a, b, c, d)) -> IO d -> IO (a, b, c, d)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO d
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
3)
  readsAt Stack
_ Args
as = [Char] -> Args -> IO (a, b, c, d)
forall a. [Char] -> Args -> IO a
readsAtError [Char]
"four arguments" Args
as

  readAtIndex :: Stack -> Int -> IO (a, b, c, d)
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO (a, b, c, d)) -> IO (a, b, c, d)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO (a, b, c, d)
forall a b c d.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d) =>
Closure -> IO (a, b, c, d)
decodeTup4
  writeBack :: Stack -> (a, b, c, d) -> IO ()
writeBack Stack
stk (a, b, c, d)
p = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ (a, b, c, d) -> Closure
forall a b c d.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d) =>
(a, b, c, d) -> Closure
encodeTup4 (a, b, c, d)
p

pattern $mTup5C :: forall {r}.
Closure
-> (Val -> Val -> Val -> Val -> Val -> r) -> ((# #) -> r) -> r
$bTup5C :: Val -> Val -> Val -> Val -> Val -> Closure
Tup5C v w x y z = ConsC v (Tup4V w x y z)

decodeTup5 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d, ForeignConvention e) => Closure -> IO (a, b, c, d, e)
decodeTup5 :: forall a b c d e.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d, ForeignConvention e) =>
Closure -> IO (a, b, c, d, e)
decodeTup5 (Tup5C Val
v Val
w Val
x Val
y Val
z) =
  (,,,,) (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> IO a -> IO (b -> c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v IO (b -> c -> d -> e -> (a, b, c, d, e))
-> IO b -> IO (c -> d -> e -> (a, b, c, d, e))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO b
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
w IO (c -> d -> e -> (a, b, c, d, e))
-> IO c -> IO (d -> e -> (a, b, c, d, e))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO c
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
x IO (d -> e -> (a, b, c, d, e)) -> IO d -> IO (e -> (a, b, c, d, e))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO d
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
y IO (e -> (a, b, c, d, e)) -> IO e -> IO (a, b, c, d, e)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Val -> IO e
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
z
decodeTup5 Closure
c = [Char] -> Val -> IO (a, b, c, d, e)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Quintuple" (Closure -> Val
BoxedVal Closure
c)

encodeTup5 :: (ForeignConvention a, ForeignConvention b, ForeignConvention c, ForeignConvention d, ForeignConvention e) => (a, b, c, d, e) -> Closure
encodeTup5 :: forall a b c d e.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d, ForeignConvention e) =>
(a, b, c, d, e) -> Closure
encodeTup5 (a
v, b
w, c
x, d
y, e
z) =
  Val -> Val -> Val -> Val -> Val -> Closure
Tup5C (a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
v) (b -> Val
forall a. ForeignConvention a => a -> Val
encodeVal b
w) (c -> Val
forall a. ForeignConvention a => a -> Val
encodeVal c
x) (d -> Val
forall a. ForeignConvention a => a -> Val
encodeVal d
y) (e -> Val
forall a. ForeignConvention a => a -> Val
encodeVal e
z)

instance
  ( ForeignConvention a,
    ForeignConvention b,
    ForeignConvention c,
    ForeignConvention d,
    ForeignConvention e
  ) =>
  ForeignConvention (a, b, c, d, e)
  where
  decodeVal :: Val -> IO (a, b, c, d, e)
decodeVal (BoxedVal Closure
c) = Closure -> IO (a, b, c, d, e)
forall a b c d e.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d, ForeignConvention e) =>
Closure -> IO (a, b, c, d, e)
decodeTup5 Closure
c
  decodeVal Val
v = [Char] -> Val -> IO (a, b, c, d, e)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Quintuple" Val
v

  encodeVal :: (a, b, c, d, e) -> Val
encodeVal = Closure -> Val
BoxedVal (Closure -> Val)
-> ((a, b, c, d, e) -> Closure) -> (a, b, c, d, e) -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b, c, d, e) -> Closure
forall a b c d e.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d, ForeignConvention e) =>
(a, b, c, d, e) -> Closure
encodeTup5

  readsAt :: Stack -> Args -> IO (a, b, c, d, e)
readsAt Stack
stk (VArgN PrimArray Int
v) =
    (,,,,)
      (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> IO a -> IO (b -> c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Int -> IO a
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
0)
      IO (b -> c -> d -> e -> (a, b, c, d, e))
-> IO b -> IO (c -> d -> e -> (a, b, c, d, e))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO b
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
1)
      IO (c -> d -> e -> (a, b, c, d, e))
-> IO c -> IO (d -> e -> (a, b, c, d, e))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO c
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
2)
      IO (d -> e -> (a, b, c, d, e)) -> IO d -> IO (e -> (a, b, c, d, e))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO d
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
3)
      IO (e -> (a, b, c, d, e)) -> IO e -> IO (a, b, c, d, e)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Stack -> Int -> IO e
forall a. ForeignConvention a => Stack -> Int -> IO a
readAtIndex Stack
stk (PrimArray Int -> Int -> Int
forall a. (() :: Constraint, Prim a) => PrimArray a -> Int -> a
PA.indexPrimArray PrimArray Int
v Int
4)
  readsAt Stack
_ Args
as = [Char] -> Args -> IO (a, b, c, d, e)
forall a. [Char] -> Args -> IO a
readsAtError [Char]
"five arguments" Args
as

  readAtIndex :: Stack -> Int -> IO (a, b, c, d, e)
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO (a, b, c, d, e)) -> IO (a, b, c, d, e)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO (a, b, c, d, e)
forall a b c d e.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d, ForeignConvention e) =>
Closure -> IO (a, b, c, d, e)
decodeTup5
  writeBack :: Stack -> (a, b, c, d, e) -> IO ()
writeBack Stack
stk (a, b, c, d, e)
p = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ (a, b, c, d, e) -> Closure
forall a b c d e.
(ForeignConvention a, ForeignConvention b, ForeignConvention c,
 ForeignConvention d, ForeignConvention e) =>
(a, b, c, d, e) -> Closure
encodeTup5 (a, b, c, d, e)
p

decodeFailure :: (ForeignConvention a) => Closure -> IO (F.Failure a)
decodeFailure :: forall a. ForeignConvention a => Closure -> IO (Failure a)
decodeFailure (DataG Reference
_ PackedTag
_ (ByteArray
_, BSeg
args)) =
  Reference -> Text -> a -> Failure a
forall a. Reference -> Text -> a -> Failure a
F.Failure
    (Reference -> Text -> a -> Failure a)
-> IO Reference -> IO (Text -> a -> Failure a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Reference
decodeTypeLink (BSeg -> Int -> Closure
forall a. Array a -> Int -> a
PA.indexArray BSeg
args Int
0)
    IO (Text -> a -> Failure a) -> IO Text -> IO (a -> Failure a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Closure -> IO Text
decodeText (BSeg -> Int -> Closure
forall a. Array a -> Int -> a
PA.indexArray BSeg
args Int
1)
    IO (a -> Failure a) -> IO a -> IO (Failure a)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Closure -> IO a
forall a. ForeignConvention a => Closure -> IO a
decodeAny (BSeg -> Int -> Closure
forall a. Array a -> Int -> a
PA.indexArray BSeg
args Int
2)
decodeFailure Closure
c = [Char] -> Val -> IO (Failure a)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Failure" (Closure -> Val
BoxedVal Closure
c)

encodeFailure :: (ForeignConvention a) => F.Failure a -> Closure
encodeFailure :: forall a. ForeignConvention a => Failure a -> Closure
encodeFailure (F.Failure Reference
r Text
msg a
v) = Reference -> PackedTag -> (ByteArray, BSeg) -> Closure
DataG Reference
Ty.failureRef PackedTag
TT.failureTag (ByteArray, BSeg)
payload
  where
    payload :: (ByteArray, BSeg)
payload = [Closure] -> (ByteArray, BSeg)
boxedSeg [Reference -> Closure
encodeTypeLink Reference
r, Text -> Closure
encodeText Text
msg, a -> Closure
forall a. ForeignConvention a => a -> Closure
encodeAny a
v]

boxedSeg :: [Closure] -> Seg
boxedSeg :: [Closure] -> (ByteArray, BSeg)
boxedSeg [Closure]
cs = ([Int] -> ByteArray
useg (Int
0 Int -> [Closure] -> [Int]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Closure]
cs), [Closure] -> BSeg
bseg [Closure]
cs)

decodeTypeLink :: Closure -> IO Reference
decodeTypeLink :: Closure -> IO Reference
decodeTypeLink = Closure -> IO Reference
forall a. HasCallStack => Closure -> IO a
marshalUnwrapForeignIO

encodeTypeLink :: Reference -> Closure
encodeTypeLink :: Reference -> Closure
encodeTypeLink Reference
rf = Foreign -> Closure
Foreign (Reference -> Reference -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
typeLinkRef Reference
rf)

encodeAny :: (ForeignConvention a) => a -> Closure
encodeAny :: forall a. ForeignConvention a => a -> Closure
encodeAny a
v = Reference -> PackedTag -> Val -> Closure
Data1 Reference
anyRef PackedTag
TT.anyTag (a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal a
v)

decodeAny :: (ForeignConvention a) => Closure -> IO a
decodeAny :: forall a. ForeignConvention a => Closure -> IO a
decodeAny (Data1 Reference
_ PackedTag
_ Val
v) = Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v
decodeAny Closure
c = [Char] -> Val -> IO a
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Any" (Closure -> Val
BoxedVal Closure
c)

decodeText :: Closure -> IO Text
decodeText :: Closure -> IO Text
decodeText = Closure -> IO Text
forall a. HasCallStack => Closure -> IO a
marshalUnwrapForeignIO

encodeText :: Text -> Closure
encodeText :: Text -> Closure
encodeText Text
tx = Foreign -> Closure
Foreign (Reference -> Text -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
textRef Text
tx)

instance (ForeignConvention a) => ForeignConvention (F.Failure a) where
  decodeVal :: Val -> IO (Failure a)
decodeVal (BoxedVal Closure
v) = Closure -> IO (Failure a)
forall a. ForeignConvention a => Closure -> IO (Failure a)
decodeFailure Closure
v
  decodeVal Val
v = [Char] -> Val -> IO (Failure a)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Failure" Val
v
  encodeVal :: Failure a -> Val
encodeVal Failure a
v = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Failure a -> Closure
forall a. ForeignConvention a => Failure a -> Closure
encodeFailure Failure a
v

  readAtIndex :: Stack -> Int -> IO (Failure a)
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO (Failure a)) -> IO (Failure a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO (Failure a)
forall a. ForeignConvention a => Closure -> IO (Failure a)
decodeFailure
  writeBack :: Stack -> Failure a -> IO ()
writeBack Stack
stk Failure a
f = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> Closure -> IO ()
forall a b. (a -> b) -> a -> b
$ Failure a -> Closure
forall a. ForeignConvention a => Failure a -> Closure
encodeFailure Failure a
f

decodeForeignClo :: String -> Closure -> IO a
decodeForeignClo :: forall a. [Char] -> Closure -> IO a
decodeForeignClo [Char]
_ (Foreign Foreign
x) = a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Foreign -> a
forall a. Foreign -> a
unwrapForeign Foreign
x
decodeForeignClo [Char]
ty Closure
c = [Char] -> Val -> IO a
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
ty (Closure -> Val
BoxedVal Closure
c)

encodeForeignClo :: Reference -> a -> Closure
encodeForeignClo :: forall a. Reference -> a -> Closure
encodeForeignClo Reference
r = Foreign -> Closure
Foreign (Foreign -> Closure) -> (a -> Foreign) -> a -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> a -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
r

decodeBuiltin :: forall a. (BuiltinForeign a) => Val -> IO a
decodeBuiltin :: forall a. BuiltinForeign a => Val -> IO a
decodeBuiltin Val
v
  | BoxedVal Closure
c <- Val
v = [Char] -> Closure -> IO a
forall a. [Char] -> Closure -> IO a
decodeForeignClo [Char]
ty Closure
c
  | Bool
otherwise = [Char] -> Val -> IO a
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
ty Val
v
  where
    Tagged [Char]
ty = Tagged a [Char]
forall f. BuiltinForeign f => Tagged f [Char]
foreignName :: Tagged a String

encodeBuiltin :: forall a. (BuiltinForeign a) => a -> Val
encodeBuiltin :: forall a. BuiltinForeign a => a -> Val
encodeBuiltin = Closure -> Val
BoxedVal (Closure -> Val) -> (a -> Closure) -> a -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> a -> Closure
forall a. Reference -> a -> Closure
encodeForeignClo Reference
r
  where
    Tagged Reference
r = Tagged a Reference
forall f. BuiltinForeign f => Tagged f Reference
foreignRef :: Tagged a Reference

readBuiltinAt :: forall a. (BuiltinForeign a) => Stack -> Int -> IO a
readBuiltinAt :: forall a. BuiltinForeign a => Stack -> Int -> IO a
readBuiltinAt Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Closure -> IO a
forall a. [Char] -> Closure -> IO a
decodeForeignClo [Char]
ty
  where
    Tagged [Char]
ty = Tagged a [Char]
forall f. BuiltinForeign f => Tagged f [Char]
foreignName :: Tagged a String

writeBuiltin :: forall a. (BuiltinForeign a) => Stack -> a -> IO ()
writeBuiltin :: forall a. BuiltinForeign a => Stack -> a -> IO ()
writeBuiltin Stack
stk = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> (a -> Closure) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> a -> Closure
forall a. Reference -> a -> Closure
encodeForeignClo Reference
r
  where
    Tagged Reference
r = Tagged a Reference
forall f. BuiltinForeign f => Tagged f Reference
foreignRef :: Tagged a Reference

decodeAsBuiltin :: (BuiltinForeign t) => (t -> a) -> Val -> IO a
decodeAsBuiltin :: forall t a. BuiltinForeign t => (t -> a) -> Val -> IO a
decodeAsBuiltin t -> a
k = (t -> a) -> IO t -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> a
k (IO t -> IO a) -> (Val -> IO t) -> Val -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> IO t
forall a. BuiltinForeign a => Val -> IO a
decodeBuiltin

encodeAsBuiltin :: (BuiltinForeign t) => (a -> t) -> a -> Val
encodeAsBuiltin :: forall t a. BuiltinForeign t => (a -> t) -> a -> Val
encodeAsBuiltin a -> t
k = t -> Val
forall a. BuiltinForeign a => a -> Val
encodeBuiltin (t -> Val) -> (a -> t) -> a -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t
k

readAsBuiltin ::
  (BuiltinForeign t) => (t -> a) -> Stack -> Int -> IO a
readAsBuiltin :: forall t a. BuiltinForeign t => (t -> a) -> Stack -> Int -> IO a
readAsBuiltin t -> a
k Stack
stk Int
i = t -> a
k (t -> a) -> IO t -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Stack -> Int -> IO t
forall a. BuiltinForeign a => Stack -> Int -> IO a
readBuiltinAt Stack
stk Int
i

writeAsBuiltin :: (BuiltinForeign t) => (a -> t) -> Stack -> a -> IO ()
writeAsBuiltin :: forall t a. BuiltinForeign t => (a -> t) -> Stack -> a -> IO ()
writeAsBuiltin a -> t
k Stack
stk = Stack -> t -> IO ()
forall a. BuiltinForeign a => Stack -> a -> IO ()
writeBuiltin Stack
stk (t -> IO ()) -> (a -> t) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> t
k

instance ForeignConvention POSIXTime where
  decodeVal :: Val -> IO POSIXTime
decodeVal (IntVal Int
i) = POSIXTime -> IO POSIXTime
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
  decodeVal Val
v = [Char] -> Val -> IO POSIXTime
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"POSIXTime" Val
v
  encodeVal :: POSIXTime -> Val
encodeVal POSIXTime
pt = Int -> Val
IntVal (POSIXTime -> Int
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round POSIXTime
pt)
  readAtIndex :: Stack -> Int -> IO POSIXTime
readAtIndex Stack
stk Int
i = Int -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> POSIXTime) -> IO Int -> IO POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (() :: Constraint) => Stack -> Int -> IO Int
Stack -> Int -> IO Int
peekOffI Stack
stk Int
i
  writeBack :: Stack -> POSIXTime -> IO ()
writeBack Stack
stk POSIXTime
pt = Stack -> Int -> IO ()
pokeI Stack
stk (POSIXTime -> Int
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round POSIXTime
pt)

decodeBufferMode :: Closure -> IO BufferMode
decodeBufferMode :: Closure -> IO BufferMode
decodeBufferMode (Enum Reference
_ PackedTag
t)
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.noBufTag = BufferMode -> IO BufferMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BufferMode
NoBuffering
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.lineBufTag = BufferMode -> IO BufferMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BufferMode
LineBuffering
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.blockBufTag = BufferMode -> IO BufferMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BufferMode -> IO BufferMode) -> BufferMode -> IO BufferMode
forall a b. (a -> b) -> a -> b
$ Maybe Int -> BufferMode
BlockBuffering Maybe Int
forall a. Maybe a
Nothing
decodeBufferMode (Data1 Reference
_ PackedTag
t (NatVal Pos
i))
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.sizedBlockBufTag = BufferMode -> IO BufferMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BufferMode -> IO BufferMode)
-> (Maybe Int -> BufferMode) -> Maybe Int -> IO BufferMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> BufferMode
BlockBuffering (Maybe Int -> IO BufferMode) -> Maybe Int -> IO BufferMode
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i)
decodeBufferMode Closure
c = [Char] -> Val -> IO BufferMode
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"BufferMode" (Closure -> Val
BoxedVal Closure
c)

encodeBufferMode :: BufferMode -> Closure
encodeBufferMode :: BufferMode -> Closure
encodeBufferMode BufferMode
NoBuffering = Closure
no'buf
encodeBufferMode BufferMode
LineBuffering = Closure
line'buf
encodeBufferMode (BlockBuffering Maybe Int
Nothing) = Closure
block'buf
encodeBufferMode (BlockBuffering (Just Int
n)) =
  Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.bufferModeRef PackedTag
TT.sizedBlockBufTag (Val -> Closure) -> (Pos -> Val) -> Pos -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Val
NatVal (Pos -> Closure) -> Pos -> Closure
forall a b. (a -> b) -> a -> b
$ Int -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n

no'buf, line'buf, block'buf :: Closure
no'buf :: Closure
no'buf = Reference -> PackedTag -> Closure
Enum Reference
Ty.bufferModeRef PackedTag
TT.noBufTag
line'buf :: Closure
line'buf = Reference -> PackedTag -> Closure
Enum Reference
Ty.bufferModeRef PackedTag
TT.lineBufTag
block'buf :: Closure
block'buf = Reference -> PackedTag -> Closure
Enum Reference
Ty.bufferModeRef PackedTag
TT.blockBufTag

instance ForeignConvention BufferMode where
  decodeVal :: Val -> IO BufferMode
decodeVal (BoxedVal Closure
c) = Closure -> IO BufferMode
decodeBufferMode Closure
c
  decodeVal Val
v = [Char] -> Val -> IO BufferMode
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"BufferMode" Val
v

  encodeVal :: BufferMode -> Val
encodeVal = Closure -> Val
BoxedVal (Closure -> Val) -> (BufferMode -> Closure) -> BufferMode -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BufferMode -> Closure
encodeBufferMode

  readAtIndex :: Stack -> Int -> IO BufferMode
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO BufferMode) -> IO BufferMode
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO BufferMode
decodeBufferMode
  writeBack :: Stack -> BufferMode -> IO ()
writeBack Stack
stk BufferMode
bm = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (BufferMode -> Closure
encodeBufferMode BufferMode
bm)

decodeIOMode :: Closure -> IO IOMode
decodeIOMode :: Closure -> IO IOMode
decodeIOMode (Enum Reference
_ PackedTag
t)
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.readModeTag = IOMode -> IO IOMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IOMode
ReadMode
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.writeModeTag = IOMode -> IO IOMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IOMode
WriteMode
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.appendModeTag = IOMode -> IO IOMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IOMode
AppendMode
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.readWriteModeTag = IOMode -> IO IOMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IOMode
ReadWriteMode
decodeIOMode Closure
c = [Char] -> Val -> IO IOMode
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"IOMode" (Closure -> Val
BoxedVal Closure
c)

encodeIOMode :: IOMode -> Closure
encodeIOMode :: IOMode -> Closure
encodeIOMode IOMode
ReadMode = Closure
read'mode
encodeIOMode IOMode
WriteMode = Closure
write'mode
encodeIOMode IOMode
AppendMode = Closure
append'mode
encodeIOMode IOMode
ReadWriteMode = Closure
read'write'mode

read'mode, write'mode, append'mode, read'write'mode :: Closure
read'mode :: Closure
read'mode = Reference -> PackedTag -> Closure
Enum Reference
Ty.bufferModeRef PackedTag
TT.readModeTag
write'mode :: Closure
write'mode = Reference -> PackedTag -> Closure
Enum Reference
Ty.bufferModeRef PackedTag
TT.writeModeTag
append'mode :: Closure
append'mode = Reference -> PackedTag -> Closure
Enum Reference
Ty.bufferModeRef PackedTag
TT.appendModeTag
read'write'mode :: Closure
read'write'mode = Reference -> PackedTag -> Closure
Enum Reference
Ty.bufferModeRef PackedTag
TT.readWriteModeTag

instance ForeignConvention IOMode where
  decodeVal :: Val -> IO IOMode
decodeVal (BoxedVal Closure
c) = Closure -> IO IOMode
decodeIOMode Closure
c
  decodeVal Val
v = [Char] -> Val -> IO IOMode
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"IOMode" Val
v

  encodeVal :: IOMode -> Val
encodeVal = Closure -> Val
BoxedVal (Closure -> Val) -> (IOMode -> Closure) -> IOMode -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOMode -> Closure
encodeIOMode

  readAtIndex :: Stack -> Int -> IO IOMode
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO IOMode) -> IO IOMode
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO IOMode
decodeIOMode
  writeBack :: Stack -> IOMode -> IO ()
writeBack Stack
stk IOMode
im = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (IOMode -> Closure
encodeIOMode IOMode
im)

decodeSeekMode :: Closure -> IO SeekMode
decodeSeekMode :: Closure -> IO SeekMode
decodeSeekMode (Enum Reference
_ PackedTag
t)
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.seekAbsoluteTag = SeekMode -> IO SeekMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeekMode
AbsoluteSeek
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.seekRelativeTag = SeekMode -> IO SeekMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeekMode
RelativeSeek
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.seekEndTag = SeekMode -> IO SeekMode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SeekMode
SeekFromEnd
decodeSeekMode Closure
v = [Char] -> Val -> IO SeekMode
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"SeekMode" (Closure -> Val
BoxedVal Closure
v)

encodeSeekMode :: SeekMode -> Closure
encodeSeekMode :: SeekMode -> Closure
encodeSeekMode SeekMode
AbsoluteSeek = Closure
absolute'seek
encodeSeekMode SeekMode
RelativeSeek = Closure
relative'seek
encodeSeekMode SeekMode
SeekFromEnd = Closure
seek'from'end

absolute'seek, relative'seek, seek'from'end :: Closure
absolute'seek :: Closure
absolute'seek = Reference -> PackedTag -> Closure
Enum Reference
Ty.seekModeRef PackedTag
TT.seekAbsoluteTag
relative'seek :: Closure
relative'seek = Reference -> PackedTag -> Closure
Enum Reference
Ty.seekModeRef PackedTag
TT.seekRelativeTag
seek'from'end :: Closure
seek'from'end = Reference -> PackedTag -> Closure
Enum Reference
Ty.seekModeRef PackedTag
TT.seekEndTag

instance ForeignConvention SeekMode where
  decodeVal :: Val -> IO SeekMode
decodeVal (BoxedVal Closure
c) = Closure -> IO SeekMode
decodeSeekMode Closure
c
  decodeVal Val
v = [Char] -> Val -> IO SeekMode
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"SeekMode" Val
v

  encodeVal :: SeekMode -> Val
encodeVal = Closure -> Val
BoxedVal (Closure -> Val) -> (SeekMode -> Closure) -> SeekMode -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeekMode -> Closure
encodeSeekMode

  readAtIndex :: Stack -> Int -> IO SeekMode
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO SeekMode) -> IO SeekMode
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO SeekMode
decodeSeekMode
  writeBack :: Stack -> SeekMode -> IO ()
writeBack Stack
stk SeekMode
sm = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (SeekMode -> Closure
encodeSeekMode SeekMode
sm)

data StdHnd = StdIn | StdOut | StdErr

decodeStdHnd :: Closure -> IO StdHnd
decodeStdHnd :: Closure -> IO StdHnd
decodeStdHnd (Enum Reference
_ PackedTag
t)
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.stdInTag = StdHnd -> IO StdHnd
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StdHnd
StdIn
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.stdOutTag = StdHnd -> IO StdHnd
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StdHnd
StdOut
  | PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.stdErrTag = StdHnd -> IO StdHnd
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StdHnd
StdErr
decodeStdHnd Closure
c = [Char] -> Val -> IO StdHnd
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"StdHandle" (Closure -> Val
BoxedVal Closure
c)

encodeStdHnd :: StdHnd -> Closure
encodeStdHnd :: StdHnd -> Closure
encodeStdHnd StdHnd
StdIn = Closure
std'in
encodeStdHnd StdHnd
StdOut = Closure
std'out
encodeStdHnd StdHnd
StdErr = Closure
std'err

std'in, std'out, std'err :: Closure
std'in :: Closure
std'in = Reference -> PackedTag -> Closure
Enum Reference
Ty.stdHandleRef PackedTag
TT.stdInTag
std'out :: Closure
std'out = Reference -> PackedTag -> Closure
Enum Reference
Ty.stdHandleRef PackedTag
TT.stdOutTag
std'err :: Closure
std'err = Reference -> PackedTag -> Closure
Enum Reference
Ty.stdHandleRef PackedTag
TT.stdErrTag

instance ForeignConvention StdHnd where
  decodeVal :: Val -> IO StdHnd
decodeVal (BoxedVal Closure
c) = Closure -> IO StdHnd
decodeStdHnd Closure
c
  decodeVal Val
v = [Char] -> Val -> IO StdHnd
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"StdHandle" Val
v

  encodeVal :: StdHnd -> Val
encodeVal = Closure -> Val
BoxedVal (Closure -> Val) -> (StdHnd -> Closure) -> StdHnd -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdHnd -> Closure
encodeStdHnd

  readAtIndex :: Stack -> Int -> IO StdHnd
readAtIndex Stack
stk Int
i = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO StdHnd) -> IO StdHnd
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Closure -> IO StdHnd
decodeStdHnd
  writeBack :: Stack -> StdHnd -> IO ()
writeBack Stack
stk = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Closure -> IO ()) -> (StdHnd -> Closure) -> StdHnd -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdHnd -> Closure
encodeStdHnd

-- In reality this fixes the type to be 'RClosure', but allows us to defer
-- the typechecker a bit and avoid a bunch of annoying type annotations.
-- instance {-# OVERLAPPING #-} ForeignConvention [Val] where
--   decodeVal = decode
--   readForeign (i : args) stk =
--     (args,) . toList <$> peekOffS stk i
--   readForeign _ _ = foreignCCError "[Val]"
--   writeForeign stk l = do
--     stk <- bump stk
--     stk <$ pokeS stk (Sq.fromList l)

-- In reality this fixes the type to be 'RClosure', but allows us to defer
-- the typechecker a bit and avoid a bunch of annoying type annotations.
-- instance {-# OVERLAPPING #-} ForeignConvention [Closure] where
--   readForeign (i : args) stk =
--     (args,) . fmap getBoxedVal . toList <$> peekOffS stk i
--   readForeign _ _ = foreignCCError "[Closure]"
--   writeForeign stk l = do
--     stk <- bump stk
--     stk <$ pokeS stk (Sq.fromList . fmap BoxedVal $ l)
--
-- instance ForeignConvention [Foreign] where
--   readForeign = readForeignAs (fmap marshalToForeign)
--   writeForeign = writeForeignAs (fmap Foreign)
--

instance {-# OVERLAPPING #-} ForeignConvention String where
  decodeVal :: Val -> IO [Char]
decodeVal = (Text -> [Char]) -> Val -> IO [Char]
forall t a. BuiltinForeign t => (t -> a) -> Val -> IO a
decodeAsBuiltin Text -> [Char]
unpack
  encodeVal :: [Char] -> Val
encodeVal = ([Char] -> Text) -> [Char] -> Val
forall t a. BuiltinForeign t => (a -> t) -> a -> Val
encodeAsBuiltin [Char] -> Text
pack

  readAtIndex :: Stack -> Int -> IO [Char]
readAtIndex = (Text -> [Char]) -> Stack -> Int -> IO [Char]
forall t a. BuiltinForeign t => (t -> a) -> Stack -> Int -> IO a
readAsBuiltin Text -> [Char]
unpack
  writeBack :: Stack -> [Char] -> IO ()
writeBack = ([Char] -> Text) -> Stack -> [Char] -> IO ()
forall t a. BuiltinForeign t => (a -> t) -> Stack -> a -> IO ()
writeAsBuiltin [Char] -> Text
pack

instance ForeignConvention Bool where
  decodeVal :: Val -> IO Bool
decodeVal (BoolVal Bool
b) = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
b
  decodeVal Val
v = [Char] -> Val -> IO Bool
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Bool" Val
v

  encodeVal :: Bool -> Val
encodeVal = Bool -> Val
BoolVal

  readAtIndex :: Stack -> Int -> IO Bool
readAtIndex = Stack -> Int -> IO Bool
peekOffBool
  writeBack :: Stack -> Bool -> IO ()
writeBack = (() :: Constraint) => Stack -> Bool -> IO ()
Stack -> Bool -> IO ()
pokeBool

instance ForeignConvention Double where
  decodeVal :: Val -> IO Double
decodeVal (DoubleVal Double
d) = Double -> IO Double
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
d
  decodeVal Val
v = [Char] -> Val -> IO Double
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Double" Val
v

  encodeVal :: Double -> Val
encodeVal = Double -> Val
DoubleVal

  readAtIndex :: Stack -> Int -> IO Double
readAtIndex = Stack -> Int -> IO Double
peekOffD
  writeBack :: Stack -> Double -> IO ()
writeBack = Stack -> Double -> IO ()
pokeD

instance ForeignConvention Val where
  decodeVal :: Val -> IO Val
decodeVal = Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  encodeVal :: Val -> Val
encodeVal = Val -> Val
forall a. a -> a
id

  readAtIndex :: Stack -> Int -> IO Val
readAtIndex = (() :: Constraint) => Stack -> Int -> IO Val
Stack -> Int -> IO Val
peekOff
  writeBack :: Stack -> Val -> IO ()
writeBack = (() :: Constraint) => Stack -> Val -> IO ()
Stack -> Val -> IO ()
poke

instance ForeignConvention Closure where
  decodeVal :: Val -> IO Closure
decodeVal (BoxedVal Closure
c) = Closure -> IO Closure
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Closure
c
  decodeVal Val
v = [Char] -> Val -> IO Closure
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Closure" Val
v

  encodeVal :: Closure -> Val
encodeVal = Closure -> Val
BoxedVal

  readAtIndex :: Stack -> Int -> IO Closure
readAtIndex = (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff
  writeBack :: Stack -> Closure -> IO ()
writeBack = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke

instance ForeignConvention Foreign where
  decodeVal :: Val -> IO Foreign
decodeVal (BoxedVal (Foreign Foreign
f)) = Foreign -> IO Foreign
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Foreign
f
  decodeVal Val
v = [Char] -> Val -> IO Foreign
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Foreign" Val
v
  encodeVal :: Foreign -> Val
encodeVal Foreign
f = Closure -> Val
BoxedVal (Foreign -> Closure
Foreign Foreign
f)

  readAtIndex :: Stack -> Int -> IO Foreign
readAtIndex Stack
stk Int
i =
    (() :: Constraint) => Stack -> Int -> IO Closure
Stack -> Int -> IO Closure
bpeekOff Stack
stk Int
i IO Closure -> (Closure -> IO Foreign) -> IO Foreign
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Foreign Foreign
f -> Foreign -> IO Foreign
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Foreign
f
      Closure
c -> [Char] -> Val -> IO Foreign
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Foreign" (Closure -> Val
BoxedVal Closure
c)
  writeBack :: Stack -> Foreign -> IO ()
writeBack Stack
stk Foreign
f = (() :: Constraint) => Stack -> Closure -> IO ()
Stack -> Closure -> IO ()
bpoke Stack
stk (Foreign -> Closure
Foreign Foreign
f)

instance ForeignConvention (Seq Val) where
  decodeVal :: Val -> IO (Seq Val)
decodeVal (BoxedVal (Foreign Foreign
f)) = Foreign -> IO (Seq Val)
forall a. Foreign -> a
unwrapForeign Foreign
f
  decodeVal Val
v = [Char] -> Val -> IO (Seq Val)
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"Seq" Val
v

  encodeVal :: Seq Val -> Val
encodeVal = Closure -> Val
BoxedVal (Closure -> Val) -> (Seq Val -> Closure) -> Seq Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure) -> (Seq Val -> Foreign) -> Seq Val -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Seq Val -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
listRef

  readAtIndex :: Stack -> Int -> IO (Seq Val)
readAtIndex = Stack -> Int -> IO (Seq Val)
peekOffS

  writeBack :: Stack -> Seq Val -> IO ()
writeBack = Stack -> Seq Val -> IO ()
pokeS

instance (ForeignConvention a) => ForeignConvention [a] where
  decodeVal :: Val -> IO [a]
decodeVal (BoxedVal (Foreign Foreign
f))
    | (Seq Val
sq :: Sq.Seq Val) <- Foreign -> Seq Val
forall a. Foreign -> a
unwrapForeign Foreign
f = (Val -> IO a) -> [Val] -> IO [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal (Seq Val -> [Val]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Val
sq)
  decodeVal Val
v = [Char] -> Val -> IO [a]
forall a. [Char] -> Val -> IO a
foreignConventionError [Char]
"List" Val
v

  encodeVal :: [a] -> Val
encodeVal [a]
l =
    Closure -> Val
BoxedVal (Closure -> Val) -> ([Val] -> Closure) -> [Val] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Foreign -> Closure
Foreign (Foreign -> Closure) -> ([Val] -> Foreign) -> [Val] -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> Seq Val -> Foreign
forall e. Reference -> e -> Foreign
Wrap Reference
listRef (Seq Val -> Foreign) -> ([Val] -> Seq Val) -> [Val] -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> Seq Val
forall a. [a] -> Seq a
Sq.fromList ([Val] -> Val) -> [Val] -> Val
forall a b. (a -> b) -> a -> b
$ a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (a -> Val) -> [a] -> [Val]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
l

  readAtIndex :: Stack -> Int -> IO [a]
readAtIndex Stack
stk Int
i = (Val -> IO a) -> [Val] -> IO [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Val -> IO a
forall a. ForeignConvention a => Val -> IO a
decodeVal ([Val] -> IO [a]) -> (Seq Val -> [Val]) -> Seq Val -> IO [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Val -> [Val]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq Val -> IO [a]) -> IO (Seq Val) -> IO [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Stack -> Int -> IO (Seq Val)
peekOffS Stack
stk Int
i

  writeBack :: Stack -> [a] -> IO ()
writeBack Stack
stk [a]
sq = Stack -> Seq Val -> IO ()
pokeS Stack
stk (Seq Val -> IO ()) -> ([Val] -> Seq Val) -> [Val] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Val] -> Seq Val
forall a. [a] -> Seq a
Sq.fromList ([Val] -> IO ()) -> [Val] -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (a -> Val) -> [a] -> [Val]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
sq

instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where
  decodeVal :: Val -> IO b
decodeVal = Val -> IO b
forall a. BuiltinForeign a => Val -> IO a
decodeBuiltin
  encodeVal :: b -> Val
encodeVal = b -> Val
forall a. BuiltinForeign a => a -> Val
encodeBuiltin
  readAtIndex :: Stack -> Int -> IO b
readAtIndex = Stack -> Int -> IO b
forall a. BuiltinForeign a => Stack -> Int -> IO a
readBuiltinAt
  writeBack :: Stack -> b -> IO ()
writeBack = Stack -> b -> IO ()
forall a. BuiltinForeign a => Stack -> a -> IO ()
writeBuiltin

-- Replacing Functions/Data Types
--
-- Below are mappings that replace unison definitions with direct
-- implementations in the interpreter. It is possible both to
-- replace data types and to replace functions with custom
-- implementations.
--
-- For data types, they will presumably be replaced by analogous
-- builtin types represented as wrapped 'foreign' values. For
-- instance, below the unison Map is replaced with Maps from the
-- containers library. To do this, the following steps are
-- necessary:
--
--   1. Create a builtin reference for the foreign type. See e.g.
--      `hmapRef` from the Map example. Note that it is _not_
--      necessary to add these to e.g. `Unison.Builtin`, because
--      they are not intended to be visible to unison users, just
--      implementation details.
--   2. Create new foreign function cases corresponding to the
--      unison type's constructors. These should take the same
--      arguments and produce the builtin value. Adding the cases
--      to the ForeignFunc type will trigger errors where you need
--      to supply implementations and such.
--   3. Add these foreign functions to the `pseudoConstructors`
--      mapping below. This maps the unison reference of the type
--      to be replaced to a mapping from its constructor tags to
--      their replacements. You may need to add the unison type
--      definition to the `Unison.Builtin.Decls` module to arrange
--      for this.
--   4. In the `dataBranch` function in `Unison.Runtime.Machine`,
--      add cases that make the wrapped builtin value behave like a
--      data type.
--   5. In `formDataReplaced` in `Unison.Runtime.Stack`, add cases
--      for building the builtin type when reifying the unison
--      data.
--   6. In `reflectValue` in `Unison.Runtime.Machine`, add a case
--      that reflects the builtin values as values of the original
--      unison type. These last two steps ensure that sending
--      values between machines doesn't need to know anything about
--      replacements.
--   7. Implement `universalCompare` and `universalEq` cases for
--      the builtin values.
--   8. Add a case in `Unison.Runtime.Decompile` to decompile the
--      builtin values as the original unison values.
--
-- With these steps done, the unison data type will be implemented
-- with the builtin values behind the scenes. In my testing, this
-- didn't seem to perform much worse than the unison data types
-- when running unison code, so this can be done without slowing
-- down pure unison functions much.
--
--
-- To replace unison _functions_, follow these steps:
--
--   1. Create a new foreign function case for the function you
--      want to replace. It is _not_ necessary to add to
--      `Unison.Builtin`, because they shouldn't be visible to the
--      user. Adding the case will give errors where it's necessary
--      for you to add implementations and such.
--   2. Add `declareForeign` statements in `Unison.Runtime.Builtin`
--      for your new foreign functions. These do not cause the
--      functions to be visible to users, but they make the runtime
--      aware of them.
--   3. Add your foreign function to the `functionReplacementList`
--      below. This requires that you find the _runtime hash_ of
--      the function you want to replace, in base32hex. You can
--      find this information using the @unison/internal library,
--      by calling:
--
--        Reference.toText (Reference.fromTermLink! (termLink ...))
--
-- Note: in the last step, pay special attention to the reference.
-- If it is _not_ just a string of base32 letters/numbers, and
-- instead ends with something like `.N`, then the reference is
-- part of a mutually recursive binding group, and it is not the
-- primary member of the group. The code below assumes that all
-- replacements _are_ the primary member of the group, so the code
-- needs to be augmented if this is ever not the case. Contact Dan
-- if you run into this.
--
-- With these steps done, any calls to the unison function should
-- instead execute the builtin, hopefully with significantly
-- improved performance.
--
-- It is not necessarily the case that all types involved need to
-- be replaced to replace a function. It should be possible to
-- replace a function by acting directly on the unison
-- representation of the arguments. This would involve taking `Val`
-- arguments to the foreign function and matching on the `Closure`
-- cases and so on. This might not be pleasant, however.

pseudoConstructors :: Map Reference (Map TT.CTag ForeignFunc)
pseudoConstructors :: Map Reference (Map CTag ForeignFunc)
pseudoConstructors =
  Reference
-> Map CTag ForeignFunc -> Map Reference (Map CTag ForeignFunc)
forall k a. k -> a -> Map k a
Map.singleton Reference
Ty.mapRef (Map CTag ForeignFunc -> Map Reference (Map CTag ForeignFunc))
-> Map CTag ForeignFunc -> Map Reference (Map CTag ForeignFunc)
forall a b. (a -> b) -> a -> b
$
    [(CTag, ForeignFunc)] -> Map CTag ForeignFunc
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Pos -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
Ty.mapTip, ForeignFunc
Map_tip),
        (Pos -> CTag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
Ty.mapBin, ForeignFunc
Map_bin)
      ]

functionReplacementList :: [(Data.Text.Text, ForeignFunc)]
functionReplacementList :: [(Text, ForeignFunc)]
functionReplacementList =
  [ ( Text
"03hqp8knrcgdc733mitcunjlug4cpi9headkggu8h9d87nfgneo6e",
      ForeignFunc
Map_insert
    ),
    ( Text
"03g44bb2bp3g5eld8eh07g6e8iq7oiqiplapeb6jerbs7ee3icq9s",
      ForeignFunc
Map_lookup
    ),
    ( Text
"005mc1fq7ojq72c238qlm2rspjgqo2furjodf28icruv316odu6du",
      ForeignFunc
Map_fromList
    ),
    ( Text
"01qqpul0ttlgjhr5i2gtmdr2uarns2hbtnjpipmk1575ipkrlug42",
      ForeignFunc
Map_union
    ),
    ( Text
"00c363e340il8q0fai6peiv3586o931nojj98qfek09hg1tjkm9ma",
      ForeignFunc
Map_intersect
    ),
    ( Text
"03pjq0jijrr7ebf6s3tuqi4d5hi5mrv19nagp7ql2j9ltm55c32ek",
      ForeignFunc
Map_toList
    ),
    ( Text
"03putoun7i5n0lhf8iu990u9p08laklnp668i170dka2itckmadlq",
      ForeignFunc
Multimap_fromList
    ),
    ( Text
"03q6giac0qlva6u4mja29tr7mv0jqnsugk8paibatdrns8lhqqb92",
      ForeignFunc
Set_fromList
    ),
    ( Text
"03362vaalqq28lcrmmsjhha637is312j01jme3juj980ugd93up28",
      ForeignFunc
Set_union
    ),
    ( Text
"01lm6ejo31na1ti6u85bv0klliefll7q0c0da2qnefvcrq1l8rlqe",
      ForeignFunc
Set_intersect
    ),
    ( Text
"01p7ot36tg62na408mnk1psve6rc7fog30gv6n7thkrv6t3na2gdm",
      ForeignFunc
Set_toList
    ),
    ( Text
"03c559iihi2vj0qps6cln48nv31ajup2srhas4pd05b9k46ds8jvk",
      ForeignFunc
Map_eq
    ),
    ( Text
"01f446li3b0j5gcnj7fa99jfqir43shs0jqu779oo0npb7v8d3v22",
      ForeignFunc
List_range
    ),
    ( Text
"00jh7o3l67okqqalho1sqgl4ei9n2sdhrpqobgkf7j390v4e938km",
      ForeignFunc
List_sort
    )
  ]

functionReplacements :: Map Reference Reference
functionReplacements :: Map Reference Reference
functionReplacements =
  [(Reference, Reference)] -> Map Reference Reference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Reference, Reference)] -> Map Reference Reference)
-> [(Reference, Reference)] -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ ((Text, ForeignFunc) -> (Reference, Reference))
-> [(Text, ForeignFunc)] -> [(Reference, Reference)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, ForeignFunc) -> (Reference, Reference)
process [(Text, ForeignFunc)]
functionReplacementList

functionUnreplacements :: Map Reference Reference
functionUnreplacements :: Map Reference Reference
functionUnreplacements =
  [(Reference, Reference)] -> Map Reference Reference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Reference, Reference)] -> Map Reference Reference)
-> ([(Text, ForeignFunc)] -> [(Reference, Reference)])
-> [(Text, ForeignFunc)]
-> Map Reference Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, ForeignFunc) -> (Reference, Reference))
-> [(Text, ForeignFunc)] -> [(Reference, Reference)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Reference, Reference) -> (Reference, Reference)
forall {b} {a}. (b, a) -> (a, b)
swap ((Reference, Reference) -> (Reference, Reference))
-> ((Text, ForeignFunc) -> (Reference, Reference))
-> (Text, ForeignFunc)
-> (Reference, Reference)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, ForeignFunc) -> (Reference, Reference)
process) ([(Text, ForeignFunc)] -> Map Reference Reference)
-> [(Text, ForeignFunc)] -> Map Reference Reference
forall a b. (a -> b) -> a -> b
$ [(Text, ForeignFunc)]
functionReplacementList
  where
    swap :: (b, a) -> (a, b)
swap (b
x, a
y) = (a
y, b
x)

-- Note: using index 0 right now. Generalize if ever replacing
-- part of a mutually recursive group.
process :: (Data.Text.Text, ForeignFunc) -> (Reference, Reference)
process :: (Text, ForeignFunc) -> (Reference, Reference)
process (Text
str, ForeignFunc
ff) = case Text -> Pos -> Maybe Reference
derivedBase32Hex Text
str Pos
0 of
  Maybe Reference
Nothing -> [Char] -> (Reference, Reference)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (Reference, Reference))
-> [Char] -> (Reference, Reference)
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not create reference for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
sname
  Just Reference
r -> (Reference
r, Text -> Reference
forall t h. t -> Reference' t h
Builtin Text
name)
  where
    name :: Text
name = ForeignFunc -> Text
foreignFuncBuiltinName ForeignFunc
ff
    sname :: [Char]
sname = Text -> [Char]
Data.Text.unpack Text
name