{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# 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.Avro qualified as Avro
import Data.Avro.Encoding.FromAvro qualified as FromAvro
import Data.Avro.Schema.ReadSchema qualified as ReadSchema
import Data.Avro.Schema.Schema qualified as AvroSchema
import Data.Binary.Get qualified as Get
import Data.Bitraversable (bimapM)
import Data.Bits (popCount, shiftL, shiftR, xor, (.&.), (.|.))
import Data.ByteArray qualified as BA
import Data.ByteString (hGet, hGetSome, hPut)
import Data.ByteString.Lazy qualified as L
import Data.Char (chr, digitToInt, isDigit, ord)
import Data.Default (def)
import Data.Digest.Murmur64 (asWord64, hash64)
import Data.HashMap.Strict qualified as HashMap
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.Text.Lazy qualified as TL
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Time.Clock.POSIX as SYS
  ( getPOSIXTime,
    posixSecondsToUTCTime,
    utcTimeToPOSIXSeconds,
  )
import Data.Time.LocalTime (TimeZone (..), getTimeZone)
import Data.Vector qualified as Vector
import Data.X509 qualified as X
import Data.X509.CertificateStore qualified as X
import Data.X509.Memory qualified as X
import Data.X509.Validation as X
import GHC.ByteOrder (ByteOrder (..), targetByteOrder)
import GHC.Conc qualified as STM
import GHC.Exts (Int (..), indexWord8ArrayAsWord16#, indexWord8ArrayAsWord32#, indexWord8ArrayAsWord64#, readWord8ArrayAsWord16#, readWord8ArrayAsWord32#, readWord8ArrayAsWord64#, writeWord8ArrayAsWord16#, writeWord8ArrayAsWord32#, writeWord8ArrayAsWord64#)
import GHC.Float (double2Float, float2Double)
import GHC.IO (IO (IO))
import GHC.Ptr (Ptr (..))
import GHC.Word (Word16 (W16#), Word32 (W32#), Word64 (W64#))
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,
    recvBuf,
    sendBuf,
    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 Numeric (showHex)
import Numeric.Natural (Natural)
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,
    hGetBuf,
    hGetBufSome,
    hGetBuffering,
    hGetChar,
    hGetEcho,
    hIsEOF,
    hIsOpen,
    hIsSeekable,
    hPutBuf,
    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 (die)
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.Referenced (Referenced, dereference)
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, fromLazyText, pack, toLazyText, unpack)
import Unison.Util.Text qualified as Util.Text
import Unison.Util.Text.Pattern qualified as TPat
import UnliftIO qualified

withMutableByteArrayContents :: (PA.PrimBase m) => PA.MutableByteArray (PA.PrimState m) -> (Ptr Word8 -> m a) -> m a
{-# INLINE withMutableByteArrayContents #-}
withMutableByteArrayContents :: forall (m :: * -> *) a.
PrimBase m =>
MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a
withMutableByteArrayContents MutableByteArray (PrimState m)
mba Ptr Word8 -> m a
f =
  MutableByteArray (PrimState m)
-> (MutableByteArray (PrimState m) -> m a) -> m a
forall (m :: * -> *) a r. PrimBase m => a -> (a -> m r) -> m r
PA.keepAlive MutableByteArray (PrimState m)
mba (Ptr Word8 -> m a
f (Ptr Word8 -> m a)
-> (MutableByteArray (PrimState m) -> Ptr Word8)
-> MutableByteArray (PrimState m)
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MutableByteArray (PrimState m) -> Ptr Word8
forall s. MutableByteArray s -> Ptr Word8
PA.mutableByteArrayContents)

-- 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)
  -- TODO: Use `PA.withMutableByteArrayContents` here once we have Data.Primitive v9.
  ForeignFunc
IO_fillBuf_impl_v1 -> ((Handle, MutableByteArray RealWorld, Pos) -> IO Int)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, MutableByteArray RealWorld, Pos) -> IO Int)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, MutableByteArray RealWorld, Pos) -> IO Int)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Handle
h, MutableByteArray RealWorld
arr, Pos
n) -> do
    Either (Failure Val) ()
r <- 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
"IO.fillBuf.impl.v1" (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
arr) Pos
n Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> Either (Failure Val) ()
-> IO (Either (Failure Val) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> 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 ()
    case Either (Failure Val) ()
r of
      Left (F.Failure TermReference
_ Text
err Val
_) -> IOError -> IO Int
forall a. IOError -> IO a
ioError ([Char] -> IOError
userError (Text -> [Char]
Util.Text.unpack Text
err))
      Right ()
_ -> MutableByteArray RW -> (Ptr Word8 -> IO Int) -> IO Int
forall (m :: * -> *) a.
PrimBase m =>
MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a
withMutableByteArrayContents MutableByteArray RealWorld
MutableByteArray RW
arr (\Ptr Word8
ptr -> Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBuf Handle
h Ptr Word8
ptr (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
n))
  ForeignFunc
IO_putBuf_impl_v1 -> ((Handle, MutableByteArray RealWorld, Pos) -> IO ())
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, MutableByteArray RealWorld, Pos) -> IO ())
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, MutableByteArray RealWorld, Pos) -> IO ())
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Handle
h, MutableByteArray RealWorld
arr, Pos
n) -> do
    Either (Failure Val) ()
r <- 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
"IO.putBuf.impl.v1" (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
arr) Pos
n Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> Either (Failure Val) ()
-> IO (Either (Failure Val) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> 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 ()
    case Either (Failure Val) ()
r of
      Left (F.Failure TermReference
_ Text
err Val
_) -> IOError -> IO ()
forall a. IOError -> IO a
ioError ([Char] -> IOError
userError (Text -> [Char]
Util.Text.unpack Text
err))
      Right ()
_ -> MutableByteArray RW -> (Ptr Word8 -> IO ()) -> IO ()
forall (m :: * -> *) a.
PrimBase m =>
MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a
withMutableByteArrayContents MutableByteArray RealWorld
MutableByteArray RW
arr (\Ptr Word8
ptr -> Handle -> Ptr Word8 -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
h Ptr Word8
ptr (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
n))
  ForeignFunc
IO_getBufSome_impl_v1 -> ((Handle, MutableByteArray RealWorld, Pos) -> IO Int)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Handle, MutableByteArray RealWorld, Pos) -> IO Int)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Handle, MutableByteArray RealWorld, Pos) -> IO Int)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Handle
h, MutableByteArray RealWorld
arr, Pos
n) -> do
    Either (Failure Val) ()
r <- 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
"IO.getBufSome.impl.v1" (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
arr) Pos
n Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> Either (Failure Val) ()
-> IO (Either (Failure Val) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> 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 ()
    case Either (Failure Val) ()
r of
      Left (F.Failure TermReference
_ Text
err Val
_) -> IOError -> IO Int
forall a. IOError -> IO a
ioError ([Char] -> IOError
userError (Text -> [Char]
Util.Text.unpack Text
err))
      Right ()
_ -> MutableByteArray RW -> (Ptr Word8 -> IO Int) -> IO Int
forall (m :: * -> *) a.
PrimBase m =>
MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a
withMutableByteArrayContents MutableByteArray RealWorld
MutableByteArray RW
arr (\Ptr Word8
ptr -> Handle -> Ptr Word8 -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufSome Handle
h Ptr Word8
ptr (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
n))
  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_socketSendBuf_impl_v1 -> ((Socket, MutableByteArray RealWorld, Pos) -> IO Int)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Socket, MutableByteArray RealWorld, Pos) -> IO Int)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Socket, MutableByteArray RealWorld, Pos) -> IO Int)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Socket
sk, MutableByteArray RealWorld
buf, Pos
n) -> do
      Either (Failure Val) ()
r <- 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
"IO.socketSendBuf.impl.v1" (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
buf) Pos
n Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> Either (Failure Val) ()
-> IO (Either (Failure Val) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> 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 ()
      case Either (Failure Val) ()
r of
        Left (F.Failure TermReference
_ Text
err Val
_) -> IOError -> IO Int
forall a. IOError -> IO a
ioError ([Char] -> IOError
userError (Text -> [Char]
Util.Text.unpack Text
err))
        Right ()
_ -> MutableByteArray RW -> (Ptr Word8 -> IO Int) -> IO Int
forall (m :: * -> *) a.
PrimBase m =>
MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a
withMutableByteArrayContents MutableByteArray RealWorld
MutableByteArray RW
buf (\Ptr Word8
ptr -> Socket -> Ptr Word8 -> Int -> IO Int
SYS.sendBuf Socket
sk Ptr Word8
ptr (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
n))
  ForeignFunc
IO_socketReceiveBuf_impl_v1 -> ((Socket, MutableByteArray RealWorld, Pos) -> IO Int)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignIOF (((Socket, MutableByteArray RealWorld, Pos) -> IO Int)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Socket, MutableByteArray RealWorld, Pos) -> IO Int)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Socket
sk, MutableByteArray RealWorld
buf, Pos
n) -> do
      Either (Failure Val) ()
r <- 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
"IO.socketReceiveBuf.impl.v1" (MutableByteArray RealWorld -> Int
forall s. MutableByteArray s -> Int
PA.sizeofMutableByteArray MutableByteArray RealWorld
buf) Pos
n Pos
0 (IO (Either (Failure Val) ()) -> IO (Either (Failure Val) ()))
-> (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> Either (Failure Val) ()
-> IO (Either (Failure Val) ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Failure Val) () -> IO (Either (Failure Val) ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) () -> IO (Either (Failure Val) ()))
-> 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 ()
      case Either (Failure Val) ()
r of
        Left (F.Failure TermReference
_ Text
err Val
_) -> IOError -> IO Int
forall a. IOError -> IO a
ioError ([Char] -> IOError
userError (Text -> [Char]
Util.Text.unpack Text
err))
        Right ()
_ -> MutableByteArray RW -> (Ptr Word8 -> IO Int) -> IO Int
forall (m :: * -> *) a.
PrimBase m =>
MutableByteArray (PrimState m) -> (Ptr Word8 -> m a) -> m a
withMutableByteArrayContents MutableByteArray RealWorld
MutableByteArray RW
buf (\Ptr Word8
ptr -> Socket -> Ptr Word8 -> Int -> IO Int
SYS.recvBuf Socket
sk Ptr Word8
ptr (Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
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 -> TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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_ClientConfig_certificates_get ->
    (ClientParams -> IO [SignedCertificate])
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ClientParams -> IO [SignedCertificate])
 -> Args -> Stack -> IO (Bool, Stack))
-> (ClientParams -> IO [SignedCertificate])
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \(ClientParams
client :: TLS.ClientParams) -> [SignedCertificate] -> IO [SignedCertificate]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SignedCertificate] -> IO [SignedCertificate])
-> [SignedCertificate] -> IO [SignedCertificate]
forall a b. (a -> b) -> a -> b
$ CertificateStore -> [SignedCertificate]
X.listCertificates (CertificateStore -> [SignedCertificate])
-> CertificateStore -> [SignedCertificate]
forall a b. (a -> b) -> a -> b
$ Shared -> CertificateStore
TLS.sharedCAStore (Shared -> CertificateStore) -> Shared -> CertificateStore
forall a b. (a -> b) -> a -> b
$ ClientParams -> Shared
TLS.clientShared ClientParams
client
  ForeignFunc
Tls_ClientConfig_validation_disableHostNameValidation ->
    let customChecks :: ValidationChecks
customChecks = ValidationChecks
X.defaultChecks {checkFQHN = False}
        customHooks :: ClientHooks
customHooks = ClientHooks
forall a. Default a => a
def {TLS.onServerCertificate = X.validate X.HashSHA256 defaultHooks customChecks}
     in (ClientParams -> IO ClientParams)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ClientParams -> IO ClientParams)
 -> Args -> Stack -> IO (Bool, Stack))
-> (ClientParams -> IO ClientParams)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
          \(ClientParams
params :: TLS.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
$ ClientParams
params {TLS.clientHooks = customHooks}
  ForeignFunc
Tls_ClientConfig_validation_disableCertificateValidation ->
    let customHooks :: ClientHooks
customHooks = ClientHooks
forall a. Default a => a
def {TLS.onServerCertificate = \CertificateStore
_ ValidationCache
_ ServiceID
_ CertificateChain
_ -> [FailedReason] -> IO [FailedReason]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []}
     in (ClientParams -> IO ClientParams)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ClientParams -> IO ClientParams)
 -> Args -> Stack -> IO (Bool, Stack))
-> (ClientParams -> IO ClientParams)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
          \(ClientParams
params :: TLS.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
$ ClientParams
params {TLS.clientHooks = customHooks}
  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
Tls_ServerConfig_certificates_get ->
    (ServerParams -> IO [SignedCertificate])
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((ServerParams -> IO [SignedCertificate])
 -> Args -> Stack -> IO (Bool, Stack))
-> (ServerParams -> IO [SignedCertificate])
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \(ServerParams
params :: ServerParams) -> [SignedCertificate] -> IO [SignedCertificate]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SignedCertificate] -> IO [SignedCertificate])
-> [SignedCertificate] -> IO [SignedCertificate]
forall a b. (a -> b) -> a -> b
$ CertificateStore -> [SignedCertificate]
X.listCertificates (CertificateStore -> [SignedCertificate])
-> CertificateStore -> [SignedCertificate]
forall a b. (a -> b) -> a -> b
$ Shared -> CertificateStore
TLS.sharedCAStore (Shared -> CertificateStore) -> Shared -> CertificateStore
forall a b. (a -> b) -> a -> b
$ ServerParams -> Shared
serverShared 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 Tls)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls (((ClientParams, Socket) -> IO Tls)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ClientParams, Socket) -> IO Tls)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \( ClientParams
config :: TLS.ClientParams,
         Socket
socket :: SYS.Socket
         ) -> Socket -> Context -> Tls
Tls Socket
socket (Context -> Tls) -> IO Context -> IO Tls
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 Tls)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls (((ServerParams, Socket) -> IO Tls)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ServerParams, Socket) -> IO Tls)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \( ServerParams
config :: TLS.ServerParams,
         Socket
socket :: SYS.Socket
         ) -> Socket -> Context -> Tls
Tls Socket
socket (Context -> Tls) -> IO Context -> IO Tls
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 -> (Tls -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls ((Tls -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (Tls -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Tls
tls :: Tls) -> Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.handshake Tls
tls.context
  ForeignFunc
Tls_send_impl_v3 ->
    ((Tls, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls (((Tls, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> ((Tls, Bytes) -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      \( Tls
tls :: Tls,
         Bytes
bytes :: Bytes.Bytes
         ) -> Context -> ByteString -> IO ()
forall (m :: * -> *). MonadIO m => Context -> ByteString -> m ()
TLS.sendData Tls
tls.context (Bytes -> ByteString
Bytes.toLazyByteString Bytes
bytes)
  ForeignFunc
Tls_decodeCert_impl_v3 ->
    let wrapFailure :: [Char] -> Failure Val
wrapFailure [Char]
t = TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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 -> (Tls -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls ((Tls -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack))
-> (Tls -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Tls
tls :: Tls) -> do
      ByteString
bs <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
TLS.recvData Tls
tls.context
      pure $ ByteString -> Bytes
forall b. ByteArrayAccess b => b -> Bytes
Bytes.fromArray ByteString
bs
  ForeignFunc
Tls_terminate_impl_v3 -> (Tls -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeignTls ((Tls -> IO ()) -> Args -> Stack -> IO (Bool, Stack))
-> (Tls -> IO ()) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Tls
tls :: Tls) -> Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
TLS.bye Tls
tls.context
  ForeignFunc
Code_validateLinks -> ([(Referent, Referenced 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, Referenced Code)]
  -> IO (Either (Failure [Referent]) (Either [Referent] [Referent])))
 -> Args -> Stack -> IO (Bool, Stack))
-> ([(Referent, Referenced Code)]
    -> IO (Either (Failure [Referent]) (Either [Referent] [Referent])))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \([(Referent, Referenced Code)]
lsgs0 :: [(Referent, Referenced ANF.Code)]) -> do
      let f :: (Text, a) -> Failure a
f (Text
msg, a
rs) =
            TermReference -> Text -> a -> Failure a
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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])))
-> ([(Referent, Code TermReference)]
    -> Either (Failure [Referent]) (Either [Referent] [Referent]))
-> [(Referent, Code TermReference)]
-> 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])
 -> Either (Failure [Referent]) (Either [Referent] [Referent]))
-> ([(Referent, Code TermReference)]
    -> Either (Text, [Referent]) (Either [Referent] [Referent]))
-> [(Referent, Code TermReference)]
-> Either (Failure [Referent]) (Either [Referent] [Referent])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Referent, Code TermReference)]
-> Either (Text, [Referent]) (Either [Referent] [Referent])
checkGroupHashes ([(Referent, Code TermReference)]
 -> IO (Either (Failure [Referent]) (Either [Referent] [Referent])))
-> [(Referent, Code TermReference)]
-> IO (Either (Failure [Referent]) (Either [Referent] [Referent]))
forall a b. (a -> b) -> a -> b
$ (Referenced Code -> Code TermReference)
-> (Referent, Referenced Code) -> (Referent, Code TermReference)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Referenced Code -> Code TermReference
forall (t :: * -> *).
Referential t =>
Referenced t -> t TermReference
dereference ((Referent, Referenced Code) -> (Referent, Code TermReference))
-> [(Referent, Referenced Code)]
-> [(Referent, Code TermReference)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Referent, Referenced Code)]
lsgs0
  ForeignFunc
Code_dependencies -> (Referenced Code -> IO [Referent])
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Referenced Code -> IO [Referent])
 -> Args -> Stack -> IO (Bool, Stack))
-> (Referenced Code -> IO [Referent])
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Referenced Code -> Code TermReference
forall (t :: * -> *).
Referential t =>
Referenced t -> t TermReference
dereference -> ANF.CodeRep SuperGroup TermReference Symbol
sg Cacheability
_) ->
      -- note: it's not correct to use the stored references of a
      -- `Referenced Code` because they may over-estimate the actual
      -- occurrences.
      [Referent] -> IO [Referent]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Referent] -> IO [Referent]) -> [Referent] -> IO [Referent]
forall a b. (a -> b) -> a -> b
$ TermReference -> Referent
Ref (TermReference -> Referent) -> [TermReference] -> [Referent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SuperGroup TermReference Symbol -> [TermReference]
forall ref v. (Ord ref, Var v) => SuperGroup ref v -> [ref]
ANF.groupTermLinks SuperGroup TermReference Symbol
sg
  ForeignFunc
Code_serialize -> (Referenced Code -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Referenced Code -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> (Referenced Code -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Referenced Code
co :: Referenced 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
$ Bool -> Referenced Code -> ByteString
ANF.serializeCode Bool
False Referenced Code
co
  ForeignFunc
Code_serialize_versioned -> ((Pos, Referenced Code) -> IO Bytes)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Pos, Referenced Code) -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Pos, Referenced Code) -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Pos
ver :: Word64, Referenced Code
co :: Referenced ANF.Code) ->
      Pos -> Bool -> Referenced Code -> IO (Either [Char] ByteString)
ANF.serializeCodeWithVersion Pos
ver Bool
False Referenced Code
co IO (Either [Char] ByteString)
-> (Either [Char] ByteString -> IO Bytes) -> IO Bytes
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 [Char]
err -> [Word] -> [Char] -> IO Bytes
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
err
        Right ByteString
bs -> 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
Bytes.fromLazyByteString ByteString
bs
  ForeignFunc
Code_deserialize ->
    (Bytes -> IO (Either [Char] (Referenced 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] (Referenced Code)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either [Char] (Referenced Code)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either [Char] (Referenced Code)
-> IO (Either [Char] (Referenced Code))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] (Referenced Code)
 -> IO (Either [Char] (Referenced Code)))
-> (Bytes -> Either [Char] (Referenced Code))
-> Bytes
-> IO (Either [Char] (Referenced Code))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] (Referenced Code)
ANF.deserializeCode (ByteString -> Either [Char] (Referenced Code))
-> (Bytes -> ByteString)
-> Bytes
-> Either [Char] (Referenced 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, Referenced 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, Referenced Code) -> IO [Char])
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Text, Referenced Code) -> IO [Char])
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(Text
nm, (Referenced Code -> Code TermReference
forall (t :: * -> *).
Referential t =>
Referenced t -> t TermReference
dereference -> ANF.CodeRep SuperGroup TermReference 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 TermReference v -> [Char] -> [Char]
ANF.prettyGroup @Symbol (Text -> [Char]
Util.Text.unpack Text
nm) SuperGroup TermReference Symbol
sg [Char]
""
  ForeignFunc
Value_dependencies ->
    (Referenced Value -> IO [Foreign])
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Referenced Value -> IO [Foreign])
 -> Args -> Stack -> IO (Bool, Stack))
-> (Referenced 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])
-> (Referenced Value -> [Foreign])
-> Referenced Value
-> IO [Foreign]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermReference -> Foreign) -> [TermReference] -> [Foreign]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TermReference -> Referent -> Foreign
forall e. TermReference -> e -> Foreign
Wrap TermReference
Ty.termLinkRef (Referent -> Foreign)
-> (TermReference -> Referent) -> TermReference -> Foreign
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermReference -> Referent
Ref) ([TermReference] -> [Foreign])
-> (Referenced Value -> [TermReference])
-> Referenced Value
-> [Foreign]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value TermReference -> [TermReference]
forall ref. Ord ref => Value ref -> [ref]
ANF.valueTermLinks (Value TermReference -> [TermReference])
-> (Referenced Value -> Value TermReference)
-> Referenced Value
-> [TermReference]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Referenced Value -> Value TermReference
forall (t :: * -> *).
Referential t =>
Referenced t -> t TermReference
dereference
  ForeignFunc
Value_serialize ->
    (Referenced Value -> IO Bytes) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Referenced Value -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> (Referenced 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)
-> (Referenced Value -> Bytes) -> Referenced 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)
-> (Referenced Value -> ByteString) -> Referenced Value -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Referenced Value -> ByteString
ANF.serializeValue
  ForeignFunc
Value_serialize_versioned ->
    ((Pos, Referenced Value) -> IO Bytes)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Pos, Referenced Value) -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Pos, Referenced Value) -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      (ByteString -> Bytes) -> IO ByteString -> IO Bytes
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Bytes
Bytes.fromLazyByteString (IO ByteString -> IO Bytes)
-> ((Pos, Referenced Value) -> IO ByteString)
-> (Pos, Referenced Value)
-> IO Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pos -> Referenced Value -> IO ByteString)
-> (Pos, Referenced Value) -> IO ByteString
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Pos -> Referenced Value -> IO ByteString
ANF.serializeValueWithVersion
  ForeignFunc
Value_deserialize ->
    (Bytes -> IO (Either [Char] (Referenced 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] (Referenced Value)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO (Either [Char] (Referenced Value)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
      Either [Char] (Referenced Value)
-> IO (Either [Char] (Referenced Value))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] (Referenced Value)
 -> IO (Either [Char] (Referenced Value)))
-> (Bytes -> Either [Char] (Referenced Value))
-> Bytes
-> IO (Either [Char] (Referenced Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] (Referenced Value)
ANF.deserializeValue (ByteString -> Either [Char] (Referenced Value))
-> (Bytes -> ByteString)
-> Bytes
-> Either [Char] (Referenced Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> ByteString
Bytes.toLazyByteString
  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 TermReference
_ 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 TermReference
_ 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, Referenced 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, Referenced Value) -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((HashAlgorithm, Referenced Value) -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(HashAlgorithm TermReference
_ a
alg, Referenced 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)
-> (Value TermReference -> Bytes)
-> Value TermReference
-> 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)
-> (Value TermReference -> Digest a)
-> Value TermReference
-> 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 -> Digest a)
-> (Value TermReference -> ByteString)
-> Value TermReference
-> Digest a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value TermReference -> ByteString
ANF.serializeValueForHash (Value TermReference -> IO Bytes)
-> Value TermReference -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Referenced Value -> Value TermReference
forall (t :: * -> *).
Referential t =>
Referenced t -> t TermReference
dereference Referenced Value
x
  ForeignFunc
Crypto_hmac -> ((HashAlgorithm, Bytes, Referenced 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, Referenced Value) -> IO Bytes)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((HashAlgorithm, Bytes, Referenced Value) -> IO Bytes)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$
    \(HashAlgorithm TermReference
_ a
alg, Bytes
key, Referenced 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)
-> (Value TermReference -> Bytes)
-> Value TermReference
-> 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)
-> (Value TermReference -> HMAC a) -> Value TermReference -> 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 -> HMAC a)
-> (Value TermReference -> ByteString)
-> Value TermReference
-> HMAC a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value TermReference -> ByteString
ANF.serializeValueForHash (Value TermReference -> IO Bytes)
-> Value TermReference -> IO Bytes
forall a b. (a -> b) -> a -> b
$ Referenced Value -> Value TermReference
forall (t :: * -> *).
Referential t =>
Referenced t -> t TermReference
dereference Referenced 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 ->
    (Referenced Value -> IO Pos) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Referenced Value -> IO Pos) -> Args -> Stack -> IO (Bool, Stack))
-> (Referenced 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)
-> (Referenced Value -> Pos) -> Referenced Value -> IO Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash64 -> Pos
asWord64 (Hash64 -> Pos)
-> (Referenced Value -> Hash64) -> Referenced Value -> Pos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Hash64
forall a. Hashable64 a => a -> Hash64
hash64 (ByteString -> Hash64)
-> (Referenced Value -> ByteString) -> Referenced Value -> Hash64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value TermReference -> ByteString
ANF.serializeValueForHash (Value TermReference -> ByteString)
-> (Referenced Value -> Value TermReference)
-> Referenced Value
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Referenced Value -> Value TermReference
forall (t :: * -> *).
Referential t =>
Referenced t -> t TermReference
dereference
  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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead16 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead24 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead32 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead40 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead64 ByteOrder
BigEndian Text
"MutableByteArray.read64be"
  ForeignFunc
MutableByteArray_read16le ->
    ((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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead16 ByteOrder
LittleEndian Text
"MutableByteArray.read16le"
  ForeignFunc
MutableByteArray_read24le ->
    ((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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead24 ByteOrder
LittleEndian Text
"MutableByteArray.read24le"
  ForeignFunc
MutableByteArray_read32le ->
    ((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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead32 ByteOrder
LittleEndian Text
"MutableByteArray.read32le"
  ForeignFunc
MutableByteArray_read40le ->
    ((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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead40 ByteOrder
LittleEndian Text
"MutableByteArray.read40le"
  ForeignFunc
MutableByteArray_read64le ->
    ((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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead64 ByteOrder
LittleEndian Text
"MutableByteArray.read64le"
  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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite16 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite32 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite64 ByteOrder
BigEndian Text
"MutableByteArray.write64be"
  ForeignFunc
MutableByteArray_write16le ->
    ((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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite16 ByteOrder
LittleEndian Text
"MutableByteArray.write16le"
  ForeignFunc
MutableByteArray_write32le ->
    ((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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite32 ByteOrder
LittleEndian Text
"MutableByteArray.write32le"
  ForeignFunc
MutableByteArray_write64le ->
    ((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
$
      ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite64 ByteOrder
LittleEndian Text
"MutableByteArray.write64le"
  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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex16 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex24 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex32 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex40 ByteOrder
BigEndian 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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex64 ByteOrder
BigEndian Text
"ImmutableByteArray.read64be"
  ForeignFunc
ImmutableByteArray_read16le ->
    ((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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex16 ByteOrder
LittleEndian Text
"ImmutableByteArray.read16le"
  ForeignFunc
ImmutableByteArray_read24le ->
    ((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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex24 ByteOrder
LittleEndian Text
"ImmutableByteArray.read24le"
  ForeignFunc
ImmutableByteArray_read32le ->
    ((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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex32 ByteOrder
LittleEndian Text
"ImmutableByteArray.read32le"
  ForeignFunc
ImmutableByteArray_read40le ->
    ((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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex40 ByteOrder
LittleEndian Text
"ImmutableByteArray.read40le"
  ForeignFunc
ImmutableByteArray_read64le ->
    ((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
$
      ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex64 ByteOrder
LittleEndian Text
"ImmutableByteArray.read64le"
  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
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
ImmutableByteArray_toBytes -> ((ByteArray, Pos, Pos) -> IO (Either (Failure Val) Bytes))
-> 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, Pos) -> IO (Either (Failure Val) Bytes))
 -> Args -> Stack -> IO (Bool, Stack))
-> ((ByteArray, Pos, Pos) -> IO (Either (Failure Val) Bytes))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(ByteArray
ba :: PA.ByteArray, Pos
off, Pos
len) ->
    if Pos
len Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
0
      then Either (Failure Val) Bytes -> IO (Either (Failure Val) Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Either (Failure Val) Bytes
forall a b. b -> Either a b
Right Bytes
Bytes.empty)
      else
        Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) Bytes)
-> IO (Either (Failure Val) Bytes)
forall b.
Text
-> Int
-> Pos
-> Pos
-> IO (Either (Failure Val) b)
-> IO (Either (Failure Val) b)
checkBoundsPrim
          Text
"ImmutableByteArray_toBytes"
          (ByteArray -> Int
PA.sizeofByteArray ByteArray
ba)
          (Pos
off Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
len)
          Pos
0
          (IO (Either (Failure Val) Bytes)
 -> IO (Either (Failure Val) Bytes))
-> IO (Either (Failure Val) Bytes)
-> IO (Either (Failure Val) Bytes)
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))
-> Either (Failure Val) Bytes -> IO (Either (Failure Val) Bytes)
forall a b. (a -> b) -> a -> b
$ 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
$ Int -> Int -> ByteArray -> Bytes
Bytes.fromByteArray (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) ByteArray
ba
  ForeignFunc
ImmutableByteArray_fromBytes -> (Bytes -> IO ByteArray) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Bytes -> IO ByteArray) -> Args -> Stack -> IO (Bool, Stack))
-> (Bytes -> IO ByteArray) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Bytes
ba :: Bytes.Bytes) -> Bytes -> IO ByteArray
forall (m :: * -> *). PrimMonad m => Bytes -> m ByteArray
Bytes.toByteArray Bytes
ba
  ForeignFunc
PinnedByteArray_cast -> (MutableByteArray RealWorld -> IO (MutableByteArray RealWorld))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((MutableByteArray RealWorld -> IO (MutableByteArray RealWorld))
 -> Args -> Stack -> IO (Bool, Stack))
-> (MutableByteArray RealWorld -> IO (MutableByteArray RealWorld))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(MutableByteArray RealWorld
ba :: PA.MutableByteArray PA.RealWorld) -> MutableByteArray RealWorld -> IO (MutableByteArray RealWorld)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MutableByteArray RealWorld
ba
  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
IO_pinnedByteArray -> (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.newPinnedByteArray
  ForeignFunc
IO_pinnedByteArrayOf -> ((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.newPinnedByteArray 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
Scope_pinnedByteArray -> (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.newPinnedByteArray
  ForeignFunc
Scope_pinnedByteArrayOf -> ((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.newPinnedByteArray 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
_ -> [Word] -> [Char] -> IO Char
forall a. HasCallStack => [Word] -> [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
_ -> [Word] -> [Char] -> IO Char
forall a. HasCallStack => [Word] -> [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
_ -> [Word] -> [Char] -> IO Char
forall a. HasCallStack => [Word] -> [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 Val Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((() -> IO (Map Val Val)) -> Args -> Stack -> IO (Bool, Stack))
-> (() -> IO (Map Val Val)) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \() -> Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall k a. Map k a
Map.empty @Val @Val)
  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 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)]) -> 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)
    -- Haskell Map.fromList calls the semigroup in reverse order, so we correct for it by flipping.
    let Map Val Val
result :: Map Val Val = (Seq Val -> Val) -> Map Val (Seq Val) -> Map Val Val
forall a b. (a -> b) -> Map Val a -> Map Val b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Map Val (Seq Val) -> Map Val Val)
-> Map Val (Seq Val) -> Map Val 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) -> Seq Val -> Seq Val -> Seq Val
forall a b c. (a -> b -> c) -> b -> a -> c
flip Seq Val -> Seq Val -> Seq Val
forall a. Semigroup a => a -> a -> a
(<>)) [(Val, Seq Val)]
listVals
    Map Val Val -> IO (Map Val Val)
forall a. a -> IO a
evaluate Map Val Val
result
  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
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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 TermReference
_ PackedTag
_ Val
vl, Data1 TermReference
_ 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
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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)
_ -> [Word] -> [Char] -> IO Closure
forall a. HasCallStack => [Word] -> [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 TermReference
_ PackedTag
_ Val
vl, Data1 TermReference
_ 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
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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)
_ -> [Word] -> [Char] -> IO Closure
forall a. HasCallStack => [Word] -> [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 TermReference
_ 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
_ -> [Word] -> [Char] -> IO [Val]
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"Set.toList: bad closure"
  ForeignFunc
Json_toText -> (Closure -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Closure -> IO Text) -> Args -> Stack -> IO (Bool, Stack))
-> (Closure -> IO Text) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Closure
clo :: Closure) -> do
    Text -> IO Text
forall a. a -> IO a
evaluate (Text -> IO Text) -> IO Text -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Closure -> IO Text
emitJson Closure
clo
  ForeignFunc
Json_unconsText -> (Text -> IO (Either (Failure Val) (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 ((Text -> IO (Either (Failure Val) (Val, Val)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO (Either (Failure Val) (Val, Val)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Text
txt :: Text) ->
    Either (Failure Val) (Val, Val)
-> IO (Either (Failure Val) (Val, Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure Val) (Val, Val)
 -> IO (Either (Failure Val) (Val, Val)))
-> (Either JsonParseError (Val, Text)
    -> Either (Failure Val) (Val, Val))
-> Either JsonParseError (Val, Text)
-> IO (Either (Failure Val) (Val, Val))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JsonParseError -> Failure Val)
-> ((Val, Text) -> (Val, Val))
-> Either JsonParseError (Val, Text)
-> Either (Failure Val) (Val, Val)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap JsonParseError -> Failure Val
mkErr ((Text -> Val) -> (Val, Text) -> (Val, Val)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal) (Either JsonParseError (Val, Text)
 -> IO (Either (Failure Val) (Val, Val)))
-> Either JsonParseError (Val, Text)
-> IO (Either (Failure Val) (Val, Val))
forall a b. (a -> b) -> a -> b
$ Text -> Either JsonParseError (Val, Text)
parseJson Text
txt
    where
      mkErr :: JsonParseError -> Failure Val
mkErr JsonParseError
err = TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
Ty.parseErrorRef Text
msg Val
errv
        where
          msg :: Text
msg = JsonParseError -> Text
renderJsonParseError JsonParseError
err
          errv :: Val
errv = JsonParseError -> Val
encodeJsonParseError JsonParseError
err
  ForeignFunc
Json_tryUnconsText -> (Text -> IO (Either Val (Val, Val)))
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO (Either Val (Val, Val)))
 -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO (Either Val (Val, Val)))
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Text
txt :: Text) ->
    Either Val (Val, Val) -> IO (Either Val (Val, Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Val (Val, Val) -> IO (Either Val (Val, Val)))
-> (Either JsonParseError (Val, Text) -> Either Val (Val, Val))
-> Either JsonParseError (Val, Text)
-> IO (Either Val (Val, Val))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (JsonParseError -> Val)
-> ((Val, Text) -> (Val, Val))
-> Either JsonParseError (Val, Text)
-> Either Val (Val, Val)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap JsonParseError -> Val
encodeJsonParseError ((Text -> Val) -> (Val, Text) -> (Val, Val)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal) (Either JsonParseError (Val, Text) -> IO (Either Val (Val, Val)))
-> Either JsonParseError (Val, Text) -> IO (Either Val (Val, Val))
forall a b. (a -> b) -> a -> b
$ Text -> Either JsonParseError (Val, Text)
parseJson Text
txt
  ForeignFunc
Avro_decodeBinary -> ((Closure, Closure, Bytes) -> IO Val)
-> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Closure, Closure, Bytes) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Closure, Closure, Bytes) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Closure
env :: Closure, Closure
readSchema :: Closure, Bytes
bytes :: Bytes.Bytes) -> do
    Closure -> Closure -> Bytes -> IO Val
avroDecodeBinary Closure
env Closure
readSchema Bytes
bytes
  ForeignFunc
Integer_fromText -> (Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Text
txt :: Text) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Val -> Val) -> Val -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ case ([Char] -> Maybe Integer
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
unpack Text
txt) :: Maybe Integer) of
    Just Integer
n -> Val -> Val
someVal (Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Integer
n)
    Maybe Integer
Nothing -> Val
noneVal
  ForeignFunc
Integer_unsafeFromText -> (Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Text
txt :: Text) -> case [Char] -> Maybe Integer
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
unpack Text
txt) of
    Just Integer
n -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
n :: Integer)
    Maybe Integer
Nothing -> [Word] -> [Char] -> IO Val
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"Integer.unsafeFromText: invalid integer"
  ForeignFunc
Integer_toText -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ [Char] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
n)
  ForeignFunc
Integer_fromInt -> (Int -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Int -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Int -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Int
n :: Int) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Integer)
  ForeignFunc
Integer_toInt -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n :: Int)
  ForeignFunc
Integer_add -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
r)
  ForeignFunc
Integer_sub -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
r)
  ForeignFunc
Integer_mul -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
r)
  ForeignFunc
Integer_div -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
r)
  ForeignFunc
Integer_mod -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
r)
  ForeignFunc
Integer_pow -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
r)
  ForeignFunc
Integer_shl -> ((Integer, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Int
r) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
r)
  ForeignFunc
Integer_shr -> ((Integer, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Int
r) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
r)
  ForeignFunc
Integer_and -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
r)
  ForeignFunc
Integer_or -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
r)
  ForeignFunc
Integer_xor -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
`xor` Integer
r)
  ForeignFunc
Integer_popCount -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a. Bits a => a -> Int
popCount Integer
n)
  ForeignFunc
Integer_truncate0 -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 Integer
n) :: Natural)
  ForeignFunc
Integer_isEven -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Bool
forall a. Integral a => a -> Bool
even Integer
n)
  ForeignFunc
Integer_isOdd -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Bool
forall a. Integral a => a -> Bool
odd Integer
n)
  ForeignFunc
Integer_eq -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
r)
  ForeignFunc
Integer_lt -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
r)
  ForeignFunc
Integer_le -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
r)
  ForeignFunc
Integer_gt -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
r)
  ForeignFunc
Integer_ge -> ((Integer, Integer) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Integer, Integer) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Integer, Integer) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
l :: Integer, Integer
r :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer
l Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
r)
  ForeignFunc
Integer_neg -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (-Integer
n)
  ForeignFunc
Integer_abs -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Integer
forall a. Num a => a -> a
abs Integer
n)
  ForeignFunc
Integer_signum -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Integer -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Integer
forall a. Num a => a -> a
signum Integer
n)
  ForeignFunc
Integer_toFloat -> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Integer -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Integer
n :: Integer) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Double -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n :: Double)
  ForeignFunc
Natural_unsafeFromText -> (Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Text
txt :: Text) -> case [Char] -> Maybe Natural
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
unpack Text
txt) of
    Just Natural
n -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
n :: Natural)
    Maybe Natural
Nothing -> [Word] -> [Char] -> IO Val
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] [Char]
"Natural.unsafeFromText: invalid natural"
  ForeignFunc
Natural_fromText -> (Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Text -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Text
txt :: Text) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> (Val -> Val) -> Val -> IO Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ case ([Char] -> Maybe Natural
forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
unpack Text
txt) :: Maybe Natural) of
    Just Natural
n -> Val -> Val
someVal (Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Natural
n)
    Maybe Natural
Nothing -> Val
noneVal
  ForeignFunc
Natural_toText -> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
n :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ [Char] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural -> [Char]
forall a. Show a => a -> [Char]
show Natural
n)
  ForeignFunc
Natural_fromNat -> (Pos -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Pos -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Pos -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Pos
n :: Word64) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Pos -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
n :: Natural)
  ForeignFunc
Natural_toNat -> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
n :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Pos -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n :: Word64)
  ForeignFunc
Natural_toFloat -> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
n :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Double -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n :: Double)
  ForeignFunc
Natural_add -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
r)
  ForeignFunc
Natural_sub -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
r)
  ForeignFunc
Natural_mul -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
r)
  ForeignFunc
Natural_div -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a. Integral a => a -> a -> a
`div` Natural
r)
  ForeignFunc
Natural_mod -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a. Integral a => a -> a -> a
`mod` Natural
r)
  ForeignFunc
Natural_pow -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a b. (Num a, Integral b) => a -> b -> a
^ Natural
r)
  ForeignFunc
Natural_shl -> ((Natural, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Int
r) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
`shiftL` Int
r)
  ForeignFunc
Natural_shr -> ((Natural, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Int) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Int
r) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Int -> Natural
forall a. Bits a => a -> Int -> a
`shiftR` Int
r)
  ForeignFunc
Natural_and -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.&. Natural
r)
  ForeignFunc
Natural_or -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
.|. Natural
r)
  ForeignFunc
Natural_xor -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Natural -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Natural
forall a. Bits a => a -> a -> a
`xor` Natural
r)
  ForeignFunc
Natural_popCount -> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
n :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural -> Int
forall a. Bits a => a -> Int
popCount Natural
n)
  ForeignFunc
Natural_isEven -> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
n :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural -> Bool
forall a. Integral a => a -> Bool
even Natural
n)
  ForeignFunc
Natural_isOdd -> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign ((Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack))
-> (Natural -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
n :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural -> Bool
forall a. Integral a => a -> Bool
odd Natural
n)
  ForeignFunc
Natural_eq -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
r)
  ForeignFunc
Natural_lt -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Natural
r)
  ForeignFunc
Natural_le -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
r)
  ForeignFunc
Natural_gt -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
r)
  ForeignFunc
Natural_ge -> ((Natural, Natural) -> IO Val) -> Args -> Stack -> IO (Bool, Stack)
forall a r.
(ForeignConvention a, ForeignConvention r) =>
(a -> IO r) -> Args -> Stack -> IO (Bool, Stack)
mkForeign (((Natural, Natural) -> IO Val)
 -> Args -> Stack -> IO (Bool, Stack))
-> ((Natural, Natural) -> IO Val)
-> Args
-> Stack
-> IO (Bool, Stack)
forall a b. (a -> b) -> a -> b
$ \(Natural
l :: Natural, Natural
r :: Natural) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Natural
l Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Natural
r)
  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 :: TermReference
algoRef = Text -> TermReference
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 (TermReference -> alg -> HashAlgorithm
forall a. HashAlgorithm a => TermReference -> a -> HashAlgorithm
HashAlgorithm TermReference
algoRef alg
alg)

-- | mkForeign is the most basic helper for implementing a Unison foreign function.
--   It takes a function from Unison arguments (decoded from the stack) to an IO result,
--   writes the result back to the stack, and returns a tuple indicating whether an exception occurred (always False here).
{-# 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

-- | mkForeignIOF is like mkForeign, but it wraps the IO action in exception handling for IOExceptions.
--   If an IOException occurs, it returns a Failure value; otherwise, it returns the result.
--   This is useful for foreign functions that may throw IOExceptions, and you want to propagate those as Unison failures.
{-# 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 IOError a -> Either (Failure Val) a)
-> IO (Either IOError 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 IOError a -> Either (Failure Val) a
forall a. Either IOError a -> Either (Failure Val) a
handleIOE (IO (Either IOError a) -> IO (Either (Failure Val) a))
-> (IO a -> IO (Either IOError a))
-> IO a
-> IO (Either (Failure Val) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either IOError 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 IOError a -> Either (Failure Val) a
handleIOE (Left IOError
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
$ TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
Ty.ioFailureRef ([Char] -> Text
Util.Text.pack (IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
e)) Val
unitValue
    handleIOE (Right a
a) = a -> Either (Failure Val) a
forall a b. b -> Either a b
Right a
a

-- | mkForeignExn is for foreign functions that may return either a failure or a result (as an Either).
--   If the function returns a Left (failure), it writes the failure to the stack and returns (True, stack).
--   If it returns a Right (result), it writes the result and returns (False, stack).
--   This is for functions that have their own error reporting, not just IOExceptions.
{-# 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

-- | mkForeignTls is for foreign functions that may throw TLS-specific exceptions or IOExceptions.
--   It wraps the IO action in two layers of exception handling: first for TLS exceptions, then for IOExceptions.
--   If an exception occurs, it returns a Failure value with the appropriate type (ioFailureRef or tlsFailureRef).
--   Otherwise, it returns the result.
{-# 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 IOError (Either TLSException r) -> Either (Failure Val) r)
-> IO (Either IOError (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 IOError (Either TLSException r) -> Either (Failure Val) r
flatten (IO (Either TLSException r)
-> IO (Either IOError (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 IOError (Either TLSException r))
tryIO2 = IO (Either TLSException r)
-> IO (Either IOError (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 IOError (Either TLSException r) -> Either (Failure Val) r
flatten (Left IOError
e) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left (TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
Ty.ioFailureRef ([Char] -> Text
Util.Text.pack (IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
e)) Val
unitValue)
    flatten (Right (Left TLSException
e)) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left (TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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

-- | mkForeignTlsE is like mkForeignTls, but for functions that may return an Either Failure r,
--   in addition to possibly throwing TLS or IO exceptions.
--   It flattens all three error sources (IO, TLS, and custom Failure) into a single Either Failure r.
{-# 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 IOError (Either TLSException (Either (Failure Val) r))
 -> Either (Failure Val) r)
-> IO
     (Either IOError (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 IOError (Either TLSException (Either (Failure Val) r))
-> Either (Failure Val) r
flatten (IO (Either TLSException (Either (Failure Val) r))
-> IO
     (Either IOError (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 IOError (Either TLSException (Either (Failure Val) r)))
tryIO2 = IO (Either TLSException (Either (Failure Val) r))
-> IO
     (Either IOError (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 IOError (Either TLSException (Either (Failure Val) r))
-> Either (Failure Val) r
flatten (Left IOError
e) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left (TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
Ty.ioFailureRef ([Char] -> Text
Util.Text.pack (IOError -> [Char]
forall a. Show a => a -> [Char]
show IOError
e)) Val
unitValue)
    flatten (Right (Left TLSException
e)) = Failure Val -> Either (Failure Val) r
forall a b. a -> Either a b
Left (TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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 (TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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
$ TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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 (TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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 (TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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
$ TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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 = TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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 = TermReference -> Text -> Val -> Failure Val
forall a. TermReference -> Text -> a -> Failure a
F.Failure TermReference
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

uncheckedRead16 ::
  ByteOrder -> -- desired byte order
  PA.MutableByteArray RW ->
  Int -> -- byte offset
  IO Word16
uncheckedRead16 :: ByteOrder -> MutableByteArray RW -> Int -> IO Word16
uncheckedRead16 ByteOrder
byteOrder MutableByteArray RW
arr Int
off = do
  let fixEndianness :: Word16 -> Word16
      fixEndianness :: Word16 -> Word16
fixEndianness Word16
w =
        if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder then Word16
w else Word16 -> Word16
byteSwap16 Word16
w
  Word16
w <- (State# RW -> (# State# RW, Word16 #)) -> IO Word16
forall a. (State# RW -> (# State# RW, a #)) -> IO a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
PA.primitive ((State# RW -> (# State# RW, Word16 #)) -> IO Word16)
-> (State# RW -> (# State# RW, Word16 #)) -> IO Word16
forall a b. (a -> b) -> a -> b
$ \State# RW
s0 ->
    case MutableByteArray RW
arr of
      PA.MutableByteArray MutableByteArray# RW
mba# ->
        case Int
off of
          I# Int#
off# ->
            case MutableByteArray# RealWorld
-> Int# -> State# RealWorld -> (# State# RealWorld, Word16# #)
forall d.
MutableByteArray# d -> Int# -> State# d -> (# State# d, Word16# #)
readWord8ArrayAsWord16# MutableByteArray# RealWorld
MutableByteArray# RW
mba# Int#
off# State# RealWorld
State# RW
s0 of
              (# State# RealWorld
s1, Word16#
w16# #) -> (# State# RealWorld
State# RW
s1, Word16# -> Word16
W16# Word16#
w16# #)
  pure (Word16 -> Word16
fixEndianness Word16
w)

checkedRead16 ::
  ByteOrder -> -- desired byte order
  Text ->
  (PA.MutableByteArray RW, Word64) -> -- (array, byte offset)
  IO (Either Failure Word64)
checkedRead16 :: ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead16 ByteOrder
byteOrder Text
name (MutableByteArray RW
arr, Pos
iW) =
  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
iW 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
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
    Word16
w <- ByteOrder -> MutableByteArray RW -> Int -> IO Word16
uncheckedRead16 ByteOrder
byteOrder MutableByteArray RW
arr Int
off
    pure $ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Word16 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w)

checkedRead24 ::
  ByteOrder ->
  Text ->
  (PA.MutableByteArray RW, Word64) ->
  IO (Either Failure Word64)
checkedRead24 :: ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead24 ByteOrder
byteOrder Text
name (MutableByteArray RW
arr, Pos
iW) =
  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
iW 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
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
    Word16
w16 <- ByteOrder -> MutableByteArray RW -> Int -> IO Word16
uncheckedRead16 ByteOrder
byteOrder MutableByteArray RW
arr Int
off
    Word8
w8 <- forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
    let result :: Pos
result =
          if ByteOrder
byteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
BigEndian
            then (Word16 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w16 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
w8
            else (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. Word16 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w16
    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
$ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right Pos
result

uncheckedRead32 ::
  ByteOrder -> -- desired byte order
  PA.MutableByteArray RW ->
  Int -> -- byte offset
  IO Word32
uncheckedRead32 :: ByteOrder -> MutableByteArray RW -> Int -> IO Word32
uncheckedRead32 ByteOrder
byteOrder MutableByteArray RW
arr Int
off = do
  let fixEndianness :: Word32 -> Word32
      fixEndianness :: Word32 -> Word32
fixEndianness Word32
w =
        if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder then Word32
w else Word32 -> Word32
byteSwap32 Word32
w
  Word32
w <- (State# RW -> (# State# RW, Word32 #)) -> IO Word32
forall a. (State# RW -> (# State# RW, a #)) -> IO a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
PA.primitive ((State# RW -> (# State# RW, Word32 #)) -> IO Word32)
-> (State# RW -> (# State# RW, Word32 #)) -> IO Word32
forall a b. (a -> b) -> a -> b
$ \State# RW
s0 ->
    case MutableByteArray RW
arr of
      PA.MutableByteArray MutableByteArray# RW
mba# ->
        case Int
off of
          I# Int#
off# ->
            case MutableByteArray# RealWorld
-> Int# -> State# RealWorld -> (# State# RealWorld, Word32# #)
forall d.
MutableByteArray# d -> Int# -> State# d -> (# State# d, Word32# #)
readWord8ArrayAsWord32# MutableByteArray# RealWorld
MutableByteArray# RW
mba# Int#
off# State# RealWorld
State# RW
s0 of
              (# State# RealWorld
s1, Word32#
w32# #) -> (# State# RealWorld
State# RW
s1, Word32# -> Word32
W32# Word32#
w32# #)
  pure (Word32 -> Word32
fixEndianness Word32
w)

checkedRead32 :: ByteOrder -> Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead32 :: ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead32 ByteOrder
byteOrder Text
name (MutableByteArray RW
arr, Pos
iW) =
  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
iW 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
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
    Word32
w <- ByteOrder -> MutableByteArray RW -> Int -> IO Word32
uncheckedRead32 ByteOrder
byteOrder MutableByteArray RW
arr Int
off
    pure $ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Word32 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)

checkedRead40 :: ByteOrder -> Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead40 :: ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead40 ByteOrder
byteOrder Text
name (MutableByteArray RW
arr, Pos
iW) =
  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
iW Pos
5 (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
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
    Word32
w32 <- ByteOrder -> MutableByteArray RW -> Int -> IO Word32
uncheckedRead32 ByteOrder
byteOrder MutableByteArray RW
arr Int
off
    Word8
w8 <- forall a (m :: * -> *).
(() :: Constraint, PrimMonad m, Prim a) =>
MutableByteArray (PrimState m) -> Int -> m a
PA.readByteArray @Word8 MutableByteArray RW
arr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
    let result :: Pos
result =
          if ByteOrder
byteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
BigEndian
            then (Word32 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w32 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
w8
            else (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
32) Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. Word32 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w32
    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
$ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right Pos
result

checkedRead64 :: ByteOrder -> Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64)
checkedRead64 :: ByteOrder
-> Text
-> (MutableByteArray RW, Pos)
-> IO (Either (Failure Val) Pos)
checkedRead64 ByteOrder
byteOrder 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
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i :: Int
        fixEndianness :: Word64 -> Word64
        fixEndianness :: Pos -> Pos
fixEndianness Pos
w =
          if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder then Pos
w else Pos -> Pos
byteSwap64 Pos
w
    Pos
w <- (State# RW -> (# State# RW, Pos #)) -> IO Pos
forall a. (State# RW -> (# State# RW, a #)) -> IO a
forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
PA.primitive ((State# RW -> (# State# RW, Pos #)) -> IO Pos)
-> (State# RW -> (# State# RW, Pos #)) -> IO Pos
forall a b. (a -> b) -> a -> b
$ \State# RW
s0 ->
      case MutableByteArray RW
arr of
        PA.MutableByteArray MutableByteArray# RW
mba# ->
          case Int
off of
            I# Int#
off# ->
              case MutableByteArray# RealWorld
-> Int# -> State# RealWorld -> (# State# RealWorld, Word64# #)
forall d.
MutableByteArray# d -> Int# -> State# d -> (# State# d, Word64# #)
readWord8ArrayAsWord64# MutableByteArray# RealWorld
MutableByteArray# RW
mba# Int#
off# State# RealWorld
State# RW
s0 of
                (# State# RealWorld
s1, Word64#
w64# #) -> (# State# RealWorld
State# RW
s1, Word64# -> Pos
W64# Word64#
w64# #)
    pure $ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Pos
fixEndianness Pos
w))

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 :: ByteOrder -> Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ())
checkedWrite16 :: ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite16 ByteOrder
byteOrder Text
name (MutableByteArray RW
arr, Pos
iW, Pos
v0) =
  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
iW 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
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
        !vBE :: Word16
vBE =
          if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder
            then Pos -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v0 :: Word16
            else Word16 -> Word16
byteSwap16 (Pos -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v0 :: Word16)
    (State# RW -> State# RW) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
PA.primitive_ ((State# RW -> State# RW) -> IO ())
-> (State# RW -> State# RW) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RW
s0 ->
      case MutableByteArray RW
arr of
        PA.MutableByteArray MutableByteArray# RW
mba# ->
          case Int
off of
            I# Int#
off# ->
              case Word16
vBE of
                W16# Word16#
w# ->
                  MutableByteArray# RealWorld
-> Int# -> Word16# -> State# RealWorld -> State# RealWorld
forall d.
MutableByteArray# d -> Int# -> Word16# -> State# d -> State# d
writeWord8ArrayAsWord16# MutableByteArray# RealWorld
MutableByteArray# RW
mba# Int#
off# Word16#
w# State# RealWorld
State# RW
s0
    pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())

checkedWrite32 :: ByteOrder -> Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ())
checkedWrite32 :: ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite32 ByteOrder
byteOrder Text
name (MutableByteArray RW
arr, Pos
iW, Pos
v0) =
  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
iW 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
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
        !vBE :: Word32
vBE =
          if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder
            then Pos -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v0 :: Word32
            else Word32 -> Word32
byteSwap32 (Pos -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v0 :: Word32)
    (State# RW -> State# RW) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
PA.primitive_ ((State# RW -> State# RW) -> IO ())
-> (State# RW -> State# RW) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RW
s0 ->
      case MutableByteArray RW
arr of
        PA.MutableByteArray MutableByteArray# RW
mba# ->
          case Int
off of
            I# Int#
off# ->
              case Word32
vBE of
                W32# Word32#
w# ->
                  MutableByteArray# RealWorld
-> Int# -> Word32# -> State# RealWorld -> State# RealWorld
forall d.
MutableByteArray# d -> Int# -> Word32# -> State# d -> State# d
writeWord8ArrayAsWord32# MutableByteArray# RealWorld
MutableByteArray# RW
mba# Int#
off# Word32#
w# State# RealWorld
State# RW
s0
    pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())

checkedWrite64 :: ByteOrder -> Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ())
checkedWrite64 :: ByteOrder
-> Text
-> (MutableByteArray RW, Pos, Pos)
-> IO (Either (Failure Val) ())
checkedWrite64 ByteOrder
byteOrder Text
name (MutableByteArray RW
arr, Pos
iW, Pos
v0) =
  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
iW 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
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
        !vBE :: Pos
vBE =
          if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder
            then Pos -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v0 :: Word64
            else Pos -> Pos
byteSwap64 (Pos -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
v0 :: Word64)
    (State# RW -> State# RW) -> IO ()
forall (m :: * -> *).
PrimMonad m =>
(State# (PrimState m) -> State# (PrimState m)) -> m ()
PA.primitive_ ((State# RW -> State# RW) -> IO ())
-> (State# RW -> State# RW) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RW
s0 ->
      case MutableByteArray RW
arr of
        PA.MutableByteArray MutableByteArray# RW
mba# ->
          case Int
off of
            I# Int#
off# ->
              case Pos
vBE of
                W64# Word64#
w# ->
                  MutableByteArray# RealWorld
-> Int# -> Word64# -> State# RealWorld -> State# RealWorld
forall d.
MutableByteArray# d -> Int# -> Word64# -> State# d -> State# d
writeWord8ArrayAsWord64# MutableByteArray# RealWorld
MutableByteArray# RW
mba# Int#
off# Word64#
w# State# RealWorld
State# RW
s0
    pure (() -> Either (Failure Val) ()
forall a b. b -> Either a b
Right ())

-- 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

uncheckedIndex16 ::
  ByteOrder -> -- desired byte order
  PA.ByteArray ->
  Int -> -- byte offset
  IO Word16
uncheckedIndex16 :: ByteOrder -> ByteArray -> Int -> IO Word16
uncheckedIndex16 ByteOrder
byteOrder ByteArray
arr Int
off = do
  let fixEndianness :: Word16 -> Word16
      fixEndianness :: Word16 -> Word16
fixEndianness Word16
w =
        if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder then Word16
w else Word16 -> Word16
byteSwap16 Word16
w
  let w :: Word16
w = case ByteArray
arr of
        PA.ByteArray ByteArray#
ba# ->
          case Int
off of
            I# Int#
off# ->
              Word16# -> Word16
W16# (ByteArray# -> Int# -> Word16#
indexWord8ArrayAsWord16# ByteArray#
ba# Int#
off#)
  Word16 -> IO Word16
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word16 -> Word16
fixEndianness Word16
w)

-- index 16 big-endian
checkedIndex16 :: ByteOrder -> Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex16 :: ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex16 ByteOrder
byteOrder Text
name (ByteArray
arr, Pos
iW) =
  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
iW 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
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
    Word16
w <- ByteOrder -> ByteArray -> Int -> IO Word16
uncheckedIndex16 ByteOrder
byteOrder ByteArray
arr Int
off
    pure $ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Word16 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w)

-- index 24 big-endian
checkedIndex24 :: ByteOrder -> Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex24 :: ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex24 ByteOrder
byteOrder 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))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i :: Int
    Word16
w16 <- ByteOrder -> ByteArray -> Int -> IO Word16
uncheckedIndex16 ByteOrder
byteOrder ByteArray
arr Int
off
    let w8 :: Word8
w8 = forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray @Word8 ByteArray
arr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
    let result :: Pos
result =
          if ByteOrder
byteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
BigEndian
            then (Word16 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w16 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
w8
            else (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. Word16 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
w16
    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
$ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right Pos
result

uncheckedIndex32 ::
  ByteOrder -> -- desired byte order
  PA.ByteArray ->
  Int -> -- byte offset
  IO Word32
uncheckedIndex32 :: ByteOrder -> ByteArray -> Int -> IO Word32
uncheckedIndex32 ByteOrder
byteOrder ByteArray
arr Int
off = do
  let fixEndianness :: Word32 -> Word32
      fixEndianness :: Word32 -> Word32
fixEndianness Word32
w =
        if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder then Word32
w else Word32 -> Word32
byteSwap32 Word32
w
  let w :: Word32
w = case ByteArray
arr of
        PA.ByteArray ByteArray#
ba# ->
          case Int
off of
            I# Int#
off# ->
              Word32# -> Word32
W32# (ByteArray# -> Int# -> Word32#
indexWord8ArrayAsWord32# ByteArray#
ba# Int#
off#)
  Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word32 -> Word32
fixEndianness Word32
w)

-- index 32 big-endian
checkedIndex32 :: ByteOrder -> Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex32 :: ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex32 ByteOrder
byteOrder Text
name (ByteArray
arr, Pos
iW) =
  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
iW 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
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
iW :: Int
    Word32
w <- ByteOrder -> ByteArray -> Int -> IO Word32
uncheckedIndex32 ByteOrder
byteOrder ByteArray
arr Int
off
    pure $ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Word32 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)

-- index 40 big-endian
checkedIndex40 :: ByteOrder -> Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex40 :: ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex40 ByteOrder
byteOrder 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))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i :: Int
    Word32
w32 <- ByteOrder -> ByteArray -> Int -> IO Word32
uncheckedIndex32 ByteOrder
byteOrder ByteArray
arr Int
off
    let w8 :: Word8
w8 = forall a. (() :: Constraint, Prim a) => ByteArray -> Int -> a
PA.indexByteArray @Word8 ByteArray
arr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
    let result :: Pos
result =
          if ByteOrder
byteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
BigEndian
            then (Word32 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w32 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
w8
            else (Word8 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8 Pos -> Int -> Pos
forall a. Bits a => a -> Int -> a
`shiftL` Int
32) Pos -> Pos -> Pos
forall a. Bits a => a -> a -> a
.|. Word32 -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w32
    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
$ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right Pos
result

-- index 64 big-endian
checkedIndex64 :: ByteOrder -> Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64)
checkedIndex64 :: ByteOrder
-> Text -> (ByteArray, Pos) -> IO (Either (Failure Val) Pos)
checkedIndex64 ByteOrder
byteOrder 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))
-> IO (Either (Failure Val) Pos) -> IO (Either (Failure Val) Pos)
forall a b. (a -> b) -> a -> b
$ do
    let !off :: Int
off = Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
i :: Int
        fixEndianness :: Word64 -> Word64
        fixEndianness :: Pos -> Pos
fixEndianness Pos
w =
          if ByteOrder
targetByteOrder ByteOrder -> ByteOrder -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOrder
byteOrder then Pos
w else Pos -> Pos
byteSwap64 Pos
w
    let w :: Pos
w = case ByteArray
arr of
          PA.ByteArray ByteArray#
ba# ->
            case Int
off of
              I# Int#
off# ->
                Word64# -> Pos
W64# (ByteArray# -> Int# -> Word64#
indexWord8ArrayAsWord64# ByteArray#
ba# Int#
off#)
    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
$ Pos -> Either (Failure Val) Pos
forall a b. b -> Either a b
Right (Pos -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> Pos
fixEndianness Pos
w))

-- JSON replacement implementations
jsonNull, jsonTrue, jsonFalse :: Val
jsonNull :: Val
jsonNull = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.jsonRef PackedTag
TT.jsonNullTag
jsonTrue :: Val
jsonTrue = Closure -> Val
BoxedVal (Closure -> Val) -> (Val -> Closure) -> Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.jsonRef PackedTag
TT.jsonBoolTag (Val -> Val) -> Val -> Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
BoolVal Bool
True
jsonFalse :: Val
jsonFalse = Closure -> Val
BoxedVal (Closure -> Val) -> (Val -> Closure) -> Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.jsonRef PackedTag
TT.jsonBoolTag (Val -> Val) -> Val -> Val
forall a b. (a -> b) -> a -> b
$ Bool -> Val
BoolVal Bool
False

jsonArr, jsonObj :: Seq Val -> Val
jsonArr :: Seq Val -> Val
jsonArr Seq Val
sq = Closure -> Val
BoxedVal (Closure -> Val) -> (Val -> Closure) -> Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.jsonRef PackedTag
TT.jsonArrTag (Val -> Val) -> Val -> Val
forall a b. (a -> b) -> a -> b
$ Seq Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Seq Val
sq
jsonObj :: Seq Val -> Val
jsonObj Seq Val
sq = Closure -> Val
BoxedVal (Closure -> Val) -> (Val -> Closure) -> Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.jsonRef PackedTag
TT.jsonObjTag (Val -> Val) -> Val -> Val
forall a b. (a -> b) -> a -> b
$ Seq Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Seq Val
sq

jsonNum :: TL.Text -> Val
jsonNum :: Text -> Val
jsonNum Text
n = Closure -> Val
BoxedVal (Closure -> Val) -> (Val -> Closure) -> Val -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.jsonRef PackedTag
TT.jsonNumTag (Val -> Val) -> Val -> Val
forall a b. (a -> b) -> a -> b
$ Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Text
n

jsonText :: Val -> Val
jsonText :: Val -> Val
jsonText Val
v = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.jsonRef PackedTag
TT.jsonTextTag Val
v

data JsonParseError = JPErr Text Int TL.Text

renderJsonParseError :: JsonParseError -> Text
renderJsonParseError :: JsonParseError -> Text
renderJsonParseError (JPErr Text
msg Int
pos Text
rem) =
  Text
"JSON parsing error at position "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
pos)
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n  Remainder of line: "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
fromLazyText Text
line
  where
    line :: Text
line = (Char -> Bool) -> Text -> Text
TL.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')) Text
rem

encodeJsonParseError :: JsonParseError -> Val
encodeJsonParseError :: JsonParseError -> Val
encodeJsonParseError (JPErr Text
msg Int
pos Text
rem) =
  Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$
    TermReference -> PackedTag -> [Val] -> Closure
DataC
      TermReference
Ty.parseErrorRef
      PackedTag
TT.jsonParseErrorTag
      [Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Text
msg, Pos -> Val
NatVal Pos
n, Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Text
rem]
  where
    n :: Pos
n
      | Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = Pos
0
      | Bool
otherwise = Int -> Pos
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pos

parseJson :: Text -> Either JsonParseError (Val, Text)
parseJson :: Text -> Either JsonParseError (Val, Text)
parseJson Text
initial =
  (Text -> Text) -> (Val, Text) -> (Val, Text)
forall a b. (a -> b) -> (Val, a) -> (Val, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
fromLazyText ((Val, Text) -> (Val, Text))
-> Either JsonParseError (Val, Text)
-> Either JsonParseError (Val, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either JsonParseError (Val, Text)
root (Text -> Text
toLazyText Text
initial)
  where
    err :: Text -> TL.Text -> Either JsonParseError a
    err :: forall a. Text -> Text -> Either JsonParseError a
err Text
msg Text
rest = JsonParseError -> Either JsonParseError a
forall a b. a -> Either a b
Left (JsonParseError -> Either JsonParseError a)
-> JsonParseError -> Either JsonParseError a
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Text -> JsonParseError
JPErr Text
msg Int
pos Text
rest
      where
        pos :: Int
pos = Text -> Int
Util.Text.size Text
initial Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Text -> Int64
TL.length Text
rest)

    root :: Text -> Either JsonParseError (Val, Text)
root = Text -> Either JsonParseError (Val, Text)
main (Text -> Either JsonParseError (Val, Text))
-> (Text -> Text) -> Text -> Either JsonParseError (Val, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.stripStart

    numberStart :: Char -> Bool
numberStart Char
'-' = Bool
True
    numberStart Char
c = Char -> Bool
isDigit Char
c

    number :: Text -> Maybe (Text, Text)
number Text
txt = case Text -> Int64
sign Text
txt of
      Int64
0 -> Maybe (Text, Text)
forall a. Maybe a
Nothing
      Int64
n -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Int64 -> Text -> (Text, Text)
TL.splitAt Int64
n Text
txt)

    sign :: Text -> Int64
sign Text
txt = case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
      Just (Char
'-', Text
txt) -> Int64 -> Text -> Int64
firstDigit Int64
1 Text
txt
      Maybe (Char, Text)
_ -> Int64 -> Text -> Int64
firstDigit Int64
0 Text
txt

    firstDigit :: Int64 -> Text -> Int64
firstDigit !Int64
n Text
txt = case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
      Just (Char
'0', Text
txt) -> Int64 -> Text -> Int64
decimal (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) Text
txt
      Just (Char
c, Text
txt)
        | Char
'1' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c, Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' -> Int64 -> Text -> Int64
whole (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) Text
txt
      Maybe (Char, Text)
_ -> Int64
0

    whole :: Int64 -> Text -> Int64
whole !Int64
n ((Char -> Bool) -> Text -> (Text, Text)
TL.span Char -> Bool
isDigit -> (Text
pre, Text
txt)) =
      Int64 -> Text -> Int64
decimal (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Text -> Int64
TL.length Text
pre) Text
txt

    decimal :: Int64 -> Text -> Int64
decimal !Int64
n Text
txt = case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
      Just (Char
'.', Text
txt)
        | (Text
pre, Text
txt) <- (Char -> Bool) -> Text -> (Text, Text)
TL.span Char -> Bool
isDigit Text
txt,
          Bool -> Bool
not (Text -> Bool
TL.null Text
pre) ->
            Int64 -> Text -> Int64
exponent (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Text -> Int64
TL.length Text
pre) Text
txt
      Maybe (Char, Text)
_ -> Int64 -> Text -> Int64
exponent Int64
n Text
txt

    exponent :: Int64 -> Text -> Int64
exponent !Int64
n Text
txt = case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
      Just (Char
c, Text
txt) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'e' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'E' -> case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
        Just (Char
c, Text
txt) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' -> Int64 -> Text -> Int64
digits (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
2) Text
txt
        Maybe (Char, Text)
_ -> Int64 -> Text -> Int64
digits (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) Text
txt
      Maybe (Char, Text)
_ -> Int64
n

    digits :: Int64 -> Text -> Int64
digits !Int64
n ((Char -> Bool) -> Text -> Text
TL.takeWhile Char -> Bool
isDigit -> Text
pre) = Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Text -> Int64
TL.length Text
pre

    main :: Text -> Either JsonParseError (Val, Text)
main Text
txt0 = case Text -> Maybe (Char, Text)
TL.uncons Text
txt0 of
      Maybe (Char, Text)
Nothing -> Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"unexpected end of file" Text
txt0
      Just (Char
'{', Text
txt) -> Seq Val -> Text -> Either JsonParseError (Val, Text)
obj Seq Val
forall a. Seq a
Sq.empty Text
txt
      Just (Char
'[', Text
txt) -> Seq Val -> Text -> Either JsonParseError (Val, Text)
array Seq Val
forall a. Seq a
Sq.empty Text
txt
      Just (Char
'"', Text
_) -> (Val -> Val) -> (Val, Text) -> (Val, Text)
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 Val -> Val
jsonText ((Val, Text) -> (Val, Text))
-> Either JsonParseError (Val, Text)
-> Either JsonParseError (Val, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either JsonParseError (Val, Text)
textLit Text
txt0
      Just (Char
'n', Text
txt)
        | (Text
pre, Text
post) <- Int64 -> Text -> (Text, Text)
TL.splitAt Int64
3 Text
txt ->
            if Text
pre Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"ull"
              then (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val
jsonNull, Text
post)
              else Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected null" Text
txt0
      Just (Char
't', Text
txt)
        | (Text
pre, Text
post) <- Int64 -> Text -> (Text, Text)
TL.splitAt Int64
3 Text
txt ->
            if Text
pre Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"rue"
              then (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val
jsonTrue, Text
post)
              else Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected true" Text
txt0
      Just (Char
'f', Text
txt)
        | (Text
pre, Text
post) <- Int64 -> Text -> (Text, Text)
TL.splitAt Int64
4 Text
txt ->
            if Text
pre Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"alse"
              then (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val
jsonFalse, Text
post)
              else Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected false" Text
txt0
      Just (Char
c, Text
_)
        | Char -> Bool
numberStart Char
c,
          Just (Text
n, Text
rest) <- Text -> Maybe (Text, Text)
number Text
txt0 ->
            (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Val
jsonNum Text
n, Text
rest)
      Maybe (Char, Text)
_ -> Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err (Text
"unknown token: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tok) Text
txt0
        where
          tok :: Text
tok = Text -> Text
fromLazyText (Int64 -> Text -> Text
TL.take Int64
10 Text
txt0)

    array :: Sq.Seq Val -> TL.Text -> Either JsonParseError (Val, TL.Text)
    array :: Seq Val -> Text -> Either JsonParseError (Val, Text)
array Seq Val
acc (Text -> Text
TL.stripStart -> Text
txt) = case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
      Maybe (Char, Text)
Nothing ->
        Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"unexpected end of file while parsing an array" Text
txt
      Just (Char
']', Text
rest) ->
        (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Val -> Val
jsonArr Seq Val
acc, Text
rest)
      Maybe (Char, Text)
_ ->
        Text -> Either JsonParseError (Val, Text)
main Text
txt Either JsonParseError (Val, Text)
-> ((Val, Text) -> Either JsonParseError (Val, Text))
-> Either JsonParseError (Val, Text)
forall a b.
Either JsonParseError a
-> (a -> Either JsonParseError b) -> Either JsonParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          (Val
el, Text -> Text
TL.stripStart -> Text
rest) -> case Text -> Maybe (Char, Text)
TL.uncons Text
rest of
            Just (Char
',', Text
rest) -> Seq Val -> Text -> Either JsonParseError (Val, Text)
array (Seq Val
acc Seq Val -> Val -> Seq Val
forall a. Seq a -> a -> Seq a
Sq.|> Val
el) Text
rest
            Just (Char
']', Text
rest) -> (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Val -> Val
jsonArr (Seq Val -> Val) -> Seq Val -> Val
forall a b. (a -> b) -> a -> b
$ Seq Val
acc Seq Val -> Val -> Seq Val
forall a. Seq a -> a -> Seq a
Sq.|> Val
el, Text
rest)
            Maybe (Char, Text)
_ ->
              Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected ',' or ']'" Text
rest

    obj :: Sq.Seq Val -> TL.Text -> Either JsonParseError (Val, TL.Text)
    obj :: Seq Val -> Text -> Either JsonParseError (Val, Text)
obj Seq Val
acc (Text -> Text
TL.stripStart -> Text
txt) = case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
      Maybe (Char, Text)
Nothing ->
        Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"unexpected end of file while parsing an object" Text
txt
      Just (Char
'}', Text
rest) ->
        (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Val -> Val
jsonObj Seq Val
acc, Text
rest)
      Maybe (Char, Text)
_ ->
        Text -> Either JsonParseError (Val, Text)
entry Text
txt Either JsonParseError (Val, Text)
-> ((Val, Text) -> Either JsonParseError (Val, Text))
-> Either JsonParseError (Val, Text)
forall a b.
Either JsonParseError a
-> (a -> Either JsonParseError b) -> Either JsonParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          (Val
el, Text -> Text
TL.stripStart -> Text
rest) -> case Text -> Maybe (Char, Text)
TL.uncons Text
rest of
            Just (Char
',', Text
rest) -> Seq Val -> Text -> Either JsonParseError (Val, Text)
obj (Seq Val
acc Seq Val -> Val -> Seq Val
forall a. Seq a -> a -> Seq a
Sq.|> Val
el) Text
rest
            Just (Char
'}', Text
rest) -> (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Val -> Val
jsonObj (Seq Val -> Val) -> Seq Val -> Val
forall a b. (a -> b) -> a -> b
$ Seq Val
acc Seq Val -> Val -> Seq Val
forall a. Seq a -> a -> Seq a
Sq.|> Val
el, Text
rest)
            Maybe (Char, Text)
_ -> Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected ',' or '}'" Text
rest

    entry :: Text -> Either JsonParseError (Val, Text)
entry Text
txt =
      Text -> Either JsonParseError (Val, Text)
textLit Text
txt Either JsonParseError (Val, Text)
-> ((Val, Text) -> Either JsonParseError (Val, Text))
-> Either JsonParseError (Val, Text)
forall a b.
Either JsonParseError a
-> (a -> Either JsonParseError b) -> Either JsonParseError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Val
key, Text -> Text
TL.stripStart -> Text
txt) -> case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
          Just (Char
':', Text
txt) ->
            (Val -> Val) -> (Val, Text) -> (Val, Text)
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 (Val -> Val -> Val
Tup2V Val
key) ((Val, Text) -> (Val, Text))
-> Either JsonParseError (Val, Text)
-> Either JsonParseError (Val, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either JsonParseError (Val, Text)
root Text
txt
          Maybe (Char, Text)
_ -> Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected ':'" Text
txt

    textLit :: TL.Text -> Either JsonParseError (Val, TL.Text)
    textLit :: Text -> Either JsonParseError (Val, Text)
textLit Text
txt = case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
      Just (Char
'"', Text
rest) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt [] Text
rest
      Maybe (Char, Text)
_ -> Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected text literal" Text
txt

    hexDig :: Text -> Maybe (Int, Text)
hexDig Text
txt =
      Text -> Maybe (Char, Text)
TL.uncons Text
txt Maybe (Char, Text)
-> ((Char, Text) -> Maybe (Int, Text)) -> Maybe (Int, Text)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Char
c, Text
rest)
          | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c, Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' -> (Int, Text) -> Maybe (Int, Text)
forall a. a -> Maybe a
Just (Char -> Int
digitToInt Char
c, Text
rest)
          | Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c, Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' -> (Int, Text) -> Maybe (Int, Text)
forall a. a -> Maybe a
Just (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a'), Text
rest)
          | Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c, Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F' -> (Int, Text) -> Maybe (Int, Text)
forall a. a -> Maybe a
Just (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A'), Text
rest)
          | Bool
otherwise -> Maybe (Int, Text)
forall a. Maybe a
Nothing

    uescape :: Text -> Maybe (Int, Text)
uescape Text
txt = do
      (Int
a, Text
txt) <- Text -> Maybe (Int, Text)
hexDig Text
txt
      (Int
b, Text
txt) <- Text -> Maybe (Int, Text)
hexDig Text
txt
      (Int
c, Text
txt) <- Text -> Maybe (Int, Text)
hexDig Text
txt
      (Int
d, Text
txt) <- Text -> Maybe (Int, Text)
hexDig Text
txt
      (Int, Text) -> Maybe (Int, Text)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((((Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
c) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d, Text
txt)

    special :: Char -> Bool
special Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'

    textBody :: TL.Text -> [TL.Text] -> TL.Text -> Either JsonParseError (Val, TL.Text)
    textBody :: Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 [Text]
acc Text
txt
      | (Text
pre, Text
txt) <- (Char -> Bool) -> Text -> (Text, Text)
TL.break Char -> Bool
special Text
txt,
        [Text]
acc <- Text
pre Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc =
          case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
            Just (Char
'"', Text
txt) ->
              (Val, Text) -> Either JsonParseError (Val, Text)
forall a. a -> Either JsonParseError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. ForeignConvention a => a -> Val
encodeVal @TL.Text (Text -> Val) -> ([Text] -> Text) -> [Text] -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
TL.concat ([Text] -> Val) -> [Text] -> Val
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc, Text
txt)
            Just (Char
'\\', Text
txt) -> case Text -> Maybe (Char, Text)
TL.uncons Text
txt of
              Just (Char
'f', Text
txt) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Text
"\f" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Just (Char
'n', Text
txt) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Text
"\n" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Just (Char
'r', Text
txt) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Text
"\r" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Just (Char
't', Text
txt) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Text
"\t" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Just (Char
'b', Text
txt) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Text
"\b" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Just (Char
'/', Text
txt) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Text
"/" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Just (Char
'\\', Text
txt) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Text
"\\" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Just (Char
'"', Text
txt) -> Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Text
"\"" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Just (Char
'u', Text
txt)
                | Just (Int
n, Text
txt) <- Text -> Maybe (Int, Text)
uescape Text
txt ->
                    Text -> [Text] -> Text -> Either JsonParseError (Val, Text)
textBody Text
txt0 (Char -> Text
TL.singleton (Int -> Char
chr Int
n) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
txt
              Maybe (Char, Text)
_ -> Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected text literal" Text
txt0
            Maybe (Char, Text)
_ -> Text -> Text -> Either JsonParseError (Val, Text)
forall a. Text -> Text -> Either JsonParseError a
err Text
"expected text literal" Text
txt0

emitJson :: Closure -> IO Text
emitJson :: Closure -> IO Text
emitJson = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.jsonNullTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"null"
  Data1 TermReference
_ PackedTag
t Val
v
    | PackedTag
TT.jsonBoolTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t,
      BoolVal Bool
b <- Val
v ->
        Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ if Bool
b then Text
"true" else Text
"false"
    | PackedTag
TT.jsonNumTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t ->
        forall a. ForeignConvention a => Val -> IO a
decodeVal @Text Val
v
    | PackedTag
TT.jsonObjTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t ->
        (Seq Text -> Text) -> IO (Seq 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 Seq Text -> Text
renderObject (IO (Seq Text) -> IO Text)
-> (Seq Val -> IO (Seq Text)) -> Seq Val -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Val -> IO Text) -> Seq Val -> IO (Seq Text)
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) -> Seq a -> f (Seq b)
traverse Val -> IO Text
emitPair (Seq Val -> IO Text) -> IO (Seq Val) -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. ForeignConvention a => Val -> IO a
decodeVal @(Seq Val) Val
v
    | PackedTag
TT.jsonTextTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t ->
        Text -> Text
literalForm (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ForeignConvention a => Val -> IO a
decodeVal @Text Val
v
    | PackedTag
TT.jsonArrTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t ->
        (Seq Text -> Text) -> IO (Seq 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 Seq Text -> Text
renderArray (IO (Seq Text) -> IO Text)
-> (Seq Val -> IO (Seq Text)) -> Seq Val -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Val -> IO Text) -> Seq Val -> IO (Seq Text)
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) -> Seq a -> f (Seq b)
traverse Val -> IO Text
emitJsonVal (Seq Val -> IO Text) -> IO (Seq Val) -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. ForeignConvention a => Val -> IO a
decodeVal @(Seq Val) Val
v
  Closure
c -> [Word] -> [Char] -> IO Text
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Text) -> [Char] -> IO Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Json.toText: unrecognized Json value: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
c
  where
    emitJsonVal :: Val -> IO Text
emitJsonVal (BoxedVal Closure
c) = Closure -> IO Text
emitJson Closure
c
    emitJsonVal Val
v =
      [Word] -> [Char] -> IO Text
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Text) -> [Char] -> IO Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Json.toText: unrecognized Json value: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v

    commaSep :: Seq Text -> Text
commaSep = Seq Text -> Text
forall m. Monoid m => Seq m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Seq Text -> Text) -> (Seq Text -> Seq Text) -> Seq Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Seq Text -> Seq Text
forall a. a -> Seq a -> Seq a
Sq.intersperse Text
","
    renderArray :: Seq Text -> Text
renderArray Seq Text
s = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Seq Text -> Text
commaSep Seq Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    renderObject :: Seq Text -> Text
renderObject Seq Text
s = Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Seq Text -> Text
commaSep Seq Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"

    emitPair :: Val -> IO Text
emitPair (Tup2V Val
x Val
y) =
      Text -> Text -> Text
mapping (Text -> Text -> Text) -> IO Text -> IO (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ForeignConvention a => Val -> IO a
decodeVal @Text Val
x IO (Text -> Text) -> IO Text -> IO Text
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 Text
emitJsonVal Val
y
    emitPair Val
v =
      [Word] -> [Char] -> IO Text
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Text) -> [Char] -> IO Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Json.toText: unrecognized Json object pair: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v

    mapping :: Text -> Text -> Text
mapping Text
key Text
val = Text -> Text
literalForm Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
val

    special :: Char -> Bool
special Char
c = (Char -> Bool) -> Text -> Bool
TL.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) Text
"\"\\/\b\f\n\r\t" Bool -> Bool -> Bool
|| Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31

    literalForm :: Text -> Text
literalForm Text
tx =
      Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
fromLazyText ([Text] -> Text -> Text
escape [] (Text -> Text
toLazyText Text
tx)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

    escape :: [Text] -> Text -> Text
escape [Text]
acc Text
tx
      | Text -> Bool
TL.null Text
tx = [Text] -> Text
TL.concat ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc)
      | (Text
pre, Text
rest) <- (Char -> Bool) -> Text -> (Text, Text)
TL.break Char -> Bool
special Text
tx =
          [Text] -> Text -> Text
escape1 (Text
pre Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
rest

    hexCode :: Char -> Text
hexCode Char
c = [Char] -> Text
TL.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s) Char
'0' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
      where
        s :: [Char]
s = Int -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showHex (Char -> Int
ord Char
c) [Char]
""

    escape1 :: [Text] -> Text -> Text
escape1 [Text]
acc Text
tx = case Text -> Maybe (Char, Text)
TL.uncons Text
tx of
      Maybe (Char, Text)
Nothing -> [Text] -> Text
TL.concat ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc)
      Just (Char
c, Text
rest) -> [Text] -> Text -> Text
escape (Text
chs Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc) Text
rest
        where
          chs :: Text
chs
            | Char
'"' <- Char
c = Text
"\\\""
            | Char
'\\' <- Char
c = Text
"\\\\"
            | Char
'\b' <- Char
c = Text
"\\b"
            | Char
'\f' <- Char
c = Text
"\\f"
            | Char
'\n' <- Char
c = Text
"\\n"
            | Char
'\r' <- Char
c = Text
"\\r"
            | Char
'\t' <- Char
c = Text
"\\t"
            | Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31 = Text
"\\u00" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
hexCode Char
c
            | Bool
otherwise = Char -> Text
TL.singleton Char
c

-- Avro replacement implementations
avroNull, avroTrue, avroFalse :: Val
avroNull :: Val
avroNull = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroRef PackedTag
TT.avroNullTag
avroTrue :: Val
avroTrue = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroRef PackedTag
TT.avroBooleanTag (Val -> Closure) -> Val -> Closure
forall a b. (a -> b) -> a -> b
$ Bool -> Val
BoolVal Bool
True
avroFalse :: Val
avroFalse = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroRef PackedTag
TT.avroBooleanTag (Val -> Closure) -> Val -> Closure
forall a b. (a -> b) -> a -> b
$ Bool -> Val
BoolVal Bool
False

avroDecodeReadSchema :: Closure -> IO Avro.ReadSchema
avroDecodeReadSchema :: Closure -> IO ReadSchema
avroDecodeReadSchema = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroReadSchemaNullTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadSchema -> IO ReadSchema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadSchema
ReadSchema.Null
    | PackedTag
TT.avroReadSchemaBooleanTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadSchema -> IO ReadSchema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadSchema
ReadSchema.Boolean
  Data1 TermReference
_ PackedTag
t v :: Val
v@(BoxedVal Closure
c)
    | PackedTag
TT.avroReadSchemaIntTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Maybe LogicalTypeInt -> ReadSchema
ReadSchema.Int (Maybe LogicalTypeInt -> ReadSchema)
-> IO (Maybe LogicalTypeInt) -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Closure -> IO LogicalTypeInt)
-> Closure -> IO (Maybe LogicalTypeInt)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeInt
avroDecodeLogicalInt Closure
c
    | PackedTag
TT.avroReadSchemaFloatTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadFloat -> ReadSchema
ReadSchema.Float (ReadFloat -> ReadSchema) -> IO ReadFloat -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO ReadFloat
avroDecodeReadFloat Closure
c
    | PackedTag
TT.avroReadSchemaDoubleTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadDouble -> ReadSchema
ReadSchema.Double (ReadDouble -> ReadSchema) -> IO ReadDouble -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO ReadDouble
avroDecodeReadDouble Closure
c
    | PackedTag
TT.avroReadSchemaBytesTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Maybe LogicalTypeBytes -> ReadSchema
ReadSchema.Bytes (Maybe LogicalTypeBytes -> ReadSchema)
-> IO (Maybe LogicalTypeBytes) -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Closure -> IO LogicalTypeBytes)
-> Closure -> IO (Maybe LogicalTypeBytes)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeBytes
avroDecodeLogicalBytes Closure
c
    | PackedTag
TT.avroReadSchemaStringTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Maybe LogicalTypeString -> ReadSchema
ReadSchema.String (Maybe LogicalTypeString -> ReadSchema)
-> IO (Maybe LogicalTypeString) -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Closure -> IO LogicalTypeString)
-> Closure -> IO (Maybe LogicalTypeString)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeString
avroDecodeLogicalString Closure
c
    | PackedTag
TT.avroReadSchemaNamedTypeTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> TypeName -> ReadSchema
ReadSchema.NamedType (TypeName -> ReadSchema) -> IO TypeName -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO TypeName
avroDecodeTypeName Closure
c
    | PackedTag
TT.avroReadSchemaUnionTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Vector (Int, ReadSchema) -> ReadSchema
ReadSchema.Union (Vector (Int, ReadSchema) -> ReadSchema)
-> ([(Int, ReadSchema)] -> Vector (Int, ReadSchema))
-> [(Int, ReadSchema)]
-> ReadSchema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, ReadSchema)] -> Vector (Int, ReadSchema)
forall a. [a] -> Vector a
Vector.fromList ([(Int, ReadSchema)] -> ReadSchema)
-> IO [(Int, ReadSchema)] -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Val -> IO [(Int, Closure)]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v :: IO [(Int, Closure)]) IO [(Int, Closure)]
-> ([(Int, Closure)] -> IO [(Int, ReadSchema)])
-> IO [(Int, ReadSchema)]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Int, Closure) -> IO (Int, ReadSchema))
-> [(Int, Closure)] -> IO [(Int, ReadSchema)]
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 (\case (Int
ix, Closure
c) -> (Int
ix,) (ReadSchema -> (Int, ReadSchema))
-> IO ReadSchema -> IO (Int, ReadSchema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO ReadSchema
avroDecodeReadSchema Closure
c))
    | PackedTag
TT.avroReadSchemaRecordTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Closure -> IO ReadSchema
avroDecodeReadRecord Closure
c
    | PackedTag
TT.avroReadSchemaEnumTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> do
        (TypeName
name, [TypeName]
aliases, Maybe Text
doc, Vector Text
symbols) <- Closure -> IO (TypeName, [TypeName], Maybe Text, Vector Text)
avroDecodeEnum Closure
c
        ReadSchema -> IO ReadSchema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReadSchema -> IO ReadSchema) -> ReadSchema -> IO ReadSchema
forall a b. (a -> b) -> a -> b
$ TypeName -> [TypeName] -> Maybe Text -> Vector Text -> ReadSchema
ReadSchema.Enum TypeName
name [TypeName]
aliases Maybe Text
doc Vector Text
symbols
    | PackedTag
TT.avroReadSchemaFixedTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> do
        (TypeName
name, [TypeName]
aliases, Int
size, Maybe LogicalTypeFixed
logicalType) <- Closure -> IO (TypeName, [TypeName], Int, Maybe LogicalTypeFixed)
avroDecodeFixed Closure
c
        ReadSchema -> IO ReadSchema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReadSchema -> IO ReadSchema) -> ReadSchema -> IO ReadSchema
forall a b. (a -> b) -> a -> b
$ TypeName
-> [TypeName] -> Int -> Maybe LogicalTypeFixed -> ReadSchema
ReadSchema.Fixed TypeName
name [TypeName]
aliases Int
size Maybe LogicalTypeFixed
logicalType
    | PackedTag
TT.avroReadSchemaNullTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaBooleanTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaStringTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaFloatTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaFixedTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaDoubleTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaBytesTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaNamedTypeTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaArrayTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaMapTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaLongTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaFreeUnionTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaEnumTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaUnionTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t Bool -> Bool -> Bool
|| PackedTag
TT.avroReadSchemaArrayTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t ->
        [Word] -> [Char] -> IO ReadSchema
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ReadSchema) -> [Char] -> IO ReadSchema
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadSchema: type error: mismatched data1 tag " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackedTag -> [Char]
forall a. Show a => a -> [Char]
show PackedTag
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v
    | Bool
otherwise -> [Word] -> [Char] -> IO ReadSchema
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ReadSchema) -> [Char] -> IO ReadSchema
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadSchema: type error: unknown data1 tag " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PackedTag -> [Char]
forall a. Show a => a -> [Char]
show PackedTag
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Val -> [Char]
forall a. Show a => a -> [Char]
show Val
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (RTag, CTag) -> [Char]
forall a. Show a => a -> [Char]
show (PackedTag -> (RTag, CTag)
TT.unpackTags PackedTag
t)
  Data2 TermReference
_ PackedTag
t (BoxedVal Closure
c1) (BoxedVal Closure
c2)
    | PackedTag
TT.avroReadSchemaArrayTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadSchema -> ReadSchema
ReadSchema.Array (ReadSchema -> ReadSchema) -> IO ReadSchema -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO ReadSchema
avroDecodeReadSchema Closure
c1
    | PackedTag
TT.avroReadSchemaMapTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadSchema -> ReadSchema
ReadSchema.Map (ReadSchema -> ReadSchema) -> IO ReadSchema -> IO ReadSchema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO ReadSchema
avroDecodeReadSchema Closure
c1
    | PackedTag
TT.avroReadSchemaLongTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadLong -> Maybe LogicalTypeLong -> ReadSchema
ReadSchema.Long (ReadLong -> Maybe LogicalTypeLong -> ReadSchema)
-> IO ReadLong -> IO (Maybe LogicalTypeLong -> ReadSchema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO ReadLong
avroDecodeReadLong Closure
c1 IO (Maybe LogicalTypeLong -> ReadSchema)
-> IO (Maybe LogicalTypeLong) -> IO ReadSchema
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 LogicalTypeLong)
-> Closure -> IO (Maybe LogicalTypeLong)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeLong
avroDecodeLogicalTypeLong Closure
c2
  Data2 TermReference
_ PackedTag
t Val
v1 (BoxedVal Closure
c2)
    | PackedTag
TT.avroReadSchemaFreeUnionTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Int -> ReadSchema -> ReadSchema
ReadSchema.FreeUnion (Int -> ReadSchema -> ReadSchema)
-> IO Int -> IO (ReadSchema -> ReadSchema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Int
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v1 IO (ReadSchema -> ReadSchema) -> IO ReadSchema -> IO ReadSchema
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 ReadSchema
avroDecodeReadSchema Closure
c2
  Closure
d -> [Word] -> [Char] -> IO ReadSchema
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ReadSchema) -> [Char] -> IO ReadSchema
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadSchema: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeSchema :: Closure -> IO AvroSchema.Schema
avroDecodeSchema :: Closure -> IO Schema
avroDecodeSchema = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroSchemaNullTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> IO Schema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
AvroSchema.Null
    | PackedTag
TT.avroSchemaBooleanTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> IO Schema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
AvroSchema.Boolean
    | PackedTag
TT.avroSchemaFloatTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> IO Schema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
AvroSchema.Float
    | PackedTag
TT.avroSchemaDoubleTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> IO Schema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
AvroSchema.Double
  Data1 TermReference
_ PackedTag
t v :: Val
v@(BoxedVal Closure
c)
    | PackedTag
TT.avroSchemaIntTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Maybe LogicalTypeInt -> Schema
AvroSchema.Int (Maybe LogicalTypeInt -> Schema)
-> IO (Maybe LogicalTypeInt) -> IO Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Closure -> IO LogicalTypeInt)
-> Closure -> IO (Maybe LogicalTypeInt)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeInt
avroDecodeLogicalInt Closure
c
    | PackedTag
TT.avroSchemaLongTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Maybe LogicalTypeLong -> Schema
AvroSchema.Long (Maybe LogicalTypeLong -> Schema)
-> IO (Maybe LogicalTypeLong) -> IO Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Closure -> IO LogicalTypeLong)
-> Closure -> IO (Maybe LogicalTypeLong)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeLong
avroDecodeLogicalTypeLong Closure
c
    | PackedTag
TT.avroSchemaStringTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Maybe LogicalTypeString -> Schema
AvroSchema.String (Maybe LogicalTypeString -> Schema)
-> IO (Maybe LogicalTypeString) -> IO Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Closure -> IO LogicalTypeString)
-> Closure -> IO (Maybe LogicalTypeString)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeString
avroDecodeLogicalString Closure
c
    | PackedTag
TT.avroSchemaBytesTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Maybe LogicalTypeBytes -> Schema
AvroSchema.Bytes (Maybe LogicalTypeBytes -> Schema)
-> IO (Maybe LogicalTypeBytes) -> IO Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Closure -> IO LogicalTypeBytes)
-> Closure -> IO (Maybe LogicalTypeBytes)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeBytes
avroDecodeLogicalBytes Closure
c
    | PackedTag
TT.avroSchemaFixedTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> do
        (TypeName
name, [TypeName]
aliases, Int
size, Maybe LogicalTypeFixed
logicalType) <- Closure -> IO (TypeName, [TypeName], Int, Maybe LogicalTypeFixed)
avroDecodeFixed Closure
c
        Schema -> IO Schema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> IO Schema) -> Schema -> IO Schema
forall a b. (a -> b) -> a -> b
$ TypeName -> [TypeName] -> Int -> Maybe LogicalTypeFixed -> Schema
AvroSchema.Fixed TypeName
name [TypeName]
aliases Int
size Maybe LogicalTypeFixed
logicalType
    | PackedTag
TT.avroSchemaEnumTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> do
        (TypeName
name, [TypeName]
aliases, Maybe Text
doc, Vector Text
symbols) <- Closure -> IO (TypeName, [TypeName], Maybe Text, Vector Text)
avroDecodeEnum Closure
c
        Schema -> IO Schema
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> IO Schema) -> Schema -> IO Schema
forall a b. (a -> b) -> a -> b
$ TypeName -> [TypeName] -> Maybe Text -> Vector Text -> Schema
AvroSchema.Enum TypeName
name [TypeName]
aliases Maybe Text
doc Vector Text
symbols
    | PackedTag
TT.avroSchemaRecordTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Closure -> IO Schema
avroDecodeRecord Closure
c
    | PackedTag
TT.avroSchemaMapTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> Schema
AvroSchema.Map (Schema -> Schema) -> IO Schema -> IO Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c
    | PackedTag
TT.avroSchemaArrayTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> Schema
AvroSchema.Array (Schema -> Schema) -> IO Schema -> IO Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c
    | PackedTag
TT.avroSchemaNamedTypeTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> TypeName -> Schema
AvroSchema.NamedType (TypeName -> Schema) -> IO TypeName -> IO Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO TypeName
avroDecodeTypeName Closure
c
    | PackedTag
TT.avroSchemaUnionTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Vector Schema -> Schema
AvroSchema.Union (Vector Schema -> Schema)
-> ([Schema] -> Vector Schema) -> [Schema] -> Schema
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Schema] -> Vector Schema
forall a. [a] -> Vector a
Vector.fromList ([Schema] -> Schema) -> IO [Schema] -> IO Schema
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Closure -> IO Schema) -> [Closure] -> IO [Schema]
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 Closure -> IO Schema
avroDecodeSchema ([Closure] -> IO [Schema]) -> IO [Closure] -> IO [Schema]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v)
  Closure
d -> [Word] -> [Char] -> IO Schema
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Schema) -> [Char] -> IO Schema
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeSchema: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeLogicalTypeLong :: Closure -> IO ReadSchema.LogicalTypeLong
avroDecodeLogicalTypeLong :: Closure -> IO LogicalTypeLong
avroDecodeLogicalTypeLong = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroLogicalLongTimeMicrosTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeLong -> IO LogicalTypeLong
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeLong
ReadSchema.TimeMicros
    | PackedTag
TT.avroLogicalLongTimestampMillisTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeLong -> IO LogicalTypeLong
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeLong
ReadSchema.TimestampMillis
    | PackedTag
TT.avroLogicalLongTimestampMicrosTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeLong -> IO LogicalTypeLong
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeLong
ReadSchema.TimestampMicros
    | PackedTag
TT.avroLogicalLongLocalTimestampMillisTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeLong -> IO LogicalTypeLong
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeLong
ReadSchema.LocalTimestampMillis
    | PackedTag
TT.avroLogicalLongLocalTimestampMicrosTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeLong -> IO LogicalTypeLong
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeLong
ReadSchema.LocalTimestampMicros
  Data1 TermReference
_ PackedTag
_ (BoxedVal Closure
c) -> Decimal -> LogicalTypeLong
ReadSchema.DecimalL (Decimal -> LogicalTypeLong) -> IO Decimal -> IO LogicalTypeLong
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Decimal
avroDecodeDecimal Closure
c
  Closure
d -> [Word] -> [Char] -> IO LogicalTypeLong
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO LogicalTypeLong) -> [Char] -> IO LogicalTypeLong
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeLogicalTypeLong: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeReadRecord :: Closure -> IO ReadSchema.ReadSchema
avroDecodeReadRecord :: Closure -> IO ReadSchema
avroDecodeReadRecord = \case
  DataC TermReference
_ PackedTag
_ [BoxedVal Closure
name, Val
aliases, Val
doc, Val
fields] -> do
    TypeName
name' <- Closure -> IO TypeName
avroDecodeTypeName Closure
name
    [TypeName]
aliases' <- (Closure -> IO TypeName) -> [Closure] -> IO [TypeName]
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 Closure -> IO TypeName
avroDecodeTypeName ([Closure] -> IO [TypeName]) -> IO [Closure] -> IO [TypeName]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
aliases :: IO [Closure])
    Maybe Text
doc' <- (Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
Util.Text.toText (Maybe Text -> Maybe Text) -> IO (Maybe Text) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO (Maybe Text)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
doc
    [ReadField]
fields' <- (Closure -> IO ReadField) -> [Closure] -> IO [ReadField]
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 Closure -> IO ReadField
avroDecodeReadField ([Closure] -> IO [ReadField]) -> IO [Closure] -> IO [ReadField]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
fields :: IO [Closure])
    pure $ TypeName -> [TypeName] -> Maybe Text -> [ReadField] -> ReadSchema
ReadSchema.Record TypeName
name' [TypeName]
aliases' Maybe Text
doc' [ReadField]
fields'
  Closure
d -> [Word] -> [Char] -> IO ReadSchema
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ReadSchema) -> [Char] -> IO ReadSchema
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadRecord: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeRecord :: Closure -> IO AvroSchema.Schema
avroDecodeRecord :: Closure -> IO Schema
avroDecodeRecord = \case
  DataC TermReference
_ PackedTag
_ [BoxedVal Closure
name, Val
aliases, Val
doc, Val
fields] -> TypeName -> [TypeName] -> Maybe Text -> [Field] -> Schema
AvroSchema.Record (TypeName -> [TypeName] -> Maybe Text -> [Field] -> Schema)
-> IO TypeName
-> IO ([TypeName] -> Maybe Text -> [Field] -> Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO TypeName
avroDecodeTypeName Closure
name IO ([TypeName] -> Maybe Text -> [Field] -> Schema)
-> IO [TypeName] -> IO (Maybe Text -> [Field] -> Schema)
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 TypeName) -> [Closure] -> IO [TypeName]
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 Closure -> IO TypeName
avroDecodeTypeName ([Closure] -> IO [TypeName]) -> IO [Closure] -> IO [TypeName]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
aliases :: IO [Closure])) IO (Maybe Text -> [Field] -> Schema)
-> IO (Maybe Text) -> IO ([Field] -> Schema)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
Util.Text.toText (Maybe Text -> Maybe Text) -> IO (Maybe Text) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO (Maybe Text)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
doc) IO ([Field] -> Schema) -> IO [Field] -> IO Schema
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 Field) -> [Closure] -> IO [Field]
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 Closure -> IO Field
avroDecodeField ([Closure] -> IO [Field]) -> IO [Closure] -> IO [Field]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
fields :: IO [Closure]))
  Closure
d -> [Word] -> [Char] -> IO Schema
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Schema) -> [Char] -> IO Schema
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadRecord: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeReadField :: Closure -> IO ReadSchema.ReadField
avroDecodeReadField :: Closure -> IO ReadField
avroDecodeReadField = \case
  DataC TermReference
_ PackedTag
_ [Val
name, Val
aliases, Val
doc, BoxedVal Closure
typ, BoxedVal Closure
status, BoxedVal Closure
order, BoxedVal Closure
def] -> (Text
-> [Text]
-> Maybe Text
-> Maybe Order
-> FieldStatus
-> ReadSchema
-> Maybe DefaultValue
-> ReadField
ReadSchema.ReadField (Text
 -> [Text]
 -> Maybe Text
 -> Maybe Order
 -> FieldStatus
 -> ReadSchema
 -> Maybe DefaultValue
 -> ReadField)
-> (Text -> Text)
-> Text
-> [Text]
-> Maybe Text
-> Maybe Order
-> FieldStatus
-> ReadSchema
-> Maybe DefaultValue
-> ReadField
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.Text.toText (Text
 -> [Text]
 -> Maybe Text
 -> Maybe Order
 -> FieldStatus
 -> ReadSchema
 -> Maybe DefaultValue
 -> ReadField)
-> IO Text
-> IO
     ([Text]
      -> Maybe Text
      -> Maybe Order
      -> FieldStatus
      -> ReadSchema
      -> Maybe DefaultValue
      -> ReadField)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Text
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
name) IO
  ([Text]
   -> Maybe Text
   -> Maybe Order
   -> FieldStatus
   -> ReadSchema
   -> Maybe DefaultValue
   -> ReadField)
-> IO [Text]
-> IO
     (Maybe Text
      -> Maybe Order
      -> FieldStatus
      -> ReadSchema
      -> Maybe DefaultValue
      -> ReadField)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.toText ([Text] -> [Text]) -> IO [Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO [Text]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
aliases) IO
  (Maybe Text
   -> Maybe Order
   -> FieldStatus
   -> ReadSchema
   -> Maybe DefaultValue
   -> ReadField)
-> IO (Maybe Text)
-> IO
     (Maybe Order
      -> FieldStatus -> ReadSchema -> Maybe DefaultValue -> ReadField)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
Util.Text.toText (Maybe Text -> Maybe Text) -> IO (Maybe Text) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO (Maybe Text)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
doc) IO
  (Maybe Order
   -> FieldStatus -> ReadSchema -> Maybe DefaultValue -> ReadField)
-> IO (Maybe Order)
-> IO
     (FieldStatus -> ReadSchema -> Maybe DefaultValue -> ReadField)
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 Order) -> Closure -> IO (Maybe Order)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO Order
avroDecodeOrder Closure
order IO (FieldStatus -> ReadSchema -> Maybe DefaultValue -> ReadField)
-> IO FieldStatus
-> IO (ReadSchema -> Maybe DefaultValue -> ReadField)
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 FieldStatus
avroDecodeFieldStatus Closure
status IO (ReadSchema -> Maybe DefaultValue -> ReadField)
-> IO ReadSchema -> IO (Maybe DefaultValue -> ReadField)
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 ReadSchema
avroDecodeReadSchema Closure
typ IO (Maybe DefaultValue -> ReadField)
-> IO (Maybe DefaultValue) -> IO ReadField
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 DefaultValue) -> Closure -> IO (Maybe DefaultValue)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO DefaultValue
avroDecodeDefaultValue Closure
def
  Closure
d -> [Word] -> [Char] -> IO ReadField
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ReadField) -> [Char] -> IO ReadField
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadField: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeField :: Closure -> IO AvroSchema.Field
avroDecodeField :: Closure -> IO Field
avroDecodeField = \case
  DataC TermReference
_ PackedTag
_ [Val
name, Val
doc, BoxedVal Closure
typ, Val
aliases, BoxedVal Closure
order, BoxedVal Closure
def] -> (Text
-> [Text]
-> Maybe Text
-> Maybe Order
-> Schema
-> Maybe DefaultValue
-> Field
AvroSchema.Field (Text
 -> [Text]
 -> Maybe Text
 -> Maybe Order
 -> Schema
 -> Maybe DefaultValue
 -> Field)
-> (Text -> Text)
-> Text
-> [Text]
-> Maybe Text
-> Maybe Order
-> Schema
-> Maybe DefaultValue
-> Field
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.Text.toText (Text
 -> [Text]
 -> Maybe Text
 -> Maybe Order
 -> Schema
 -> Maybe DefaultValue
 -> Field)
-> IO Text
-> IO
     ([Text]
      -> Maybe Text
      -> Maybe Order
      -> Schema
      -> Maybe DefaultValue
      -> Field)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Text
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
name) IO
  ([Text]
   -> Maybe Text
   -> Maybe Order
   -> Schema
   -> Maybe DefaultValue
   -> Field)
-> IO [Text]
-> IO
     (Maybe Text
      -> Maybe Order -> Schema -> Maybe DefaultValue -> Field)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.toText ([Text] -> [Text]) -> IO [Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO [Text]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
aliases) IO
  (Maybe Text
   -> Maybe Order -> Schema -> Maybe DefaultValue -> Field)
-> IO (Maybe Text)
-> IO (Maybe Order -> Schema -> Maybe DefaultValue -> Field)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
Util.Text.toText (Maybe Text -> Maybe Text) -> IO (Maybe Text) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO (Maybe Text)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
doc) IO (Maybe Order -> Schema -> Maybe DefaultValue -> Field)
-> IO (Maybe Order) -> IO (Schema -> Maybe DefaultValue -> Field)
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 Order) -> Closure -> IO (Maybe Order)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO Order
avroDecodeOrder Closure
order IO (Schema -> Maybe DefaultValue -> Field)
-> IO Schema -> IO (Maybe DefaultValue -> Field)
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 Schema
avroDecodeSchema Closure
typ IO (Maybe DefaultValue -> Field)
-> IO (Maybe DefaultValue) -> IO Field
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 DefaultValue) -> Closure -> IO (Maybe DefaultValue)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO DefaultValue
avroDecodeDefaultValue Closure
def
  Closure
d -> [Word] -> [Char] -> IO Field
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Field) -> [Char] -> IO Field
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeField: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeEnum :: Closure -> IO (AvroSchema.TypeName, [AvroSchema.TypeName], Maybe Data.Text.Text, Vector.Vector Data.Text.Text)
avroDecodeEnum :: Closure -> IO (TypeName, [TypeName], Maybe Text, Vector Text)
avroDecodeEnum = \case
  DataC TermReference
_ PackedTag
_ [BoxedVal Closure
name, Val
doc, Val
aliases, Val
symbols, Val
_] -> do
    TypeName
name' <- Closure -> IO TypeName
avroDecodeTypeName Closure
name
    [TypeName]
aliases' <- (Closure -> IO TypeName) -> [Closure] -> IO [TypeName]
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 Closure -> IO TypeName
avroDecodeTypeName ([Closure] -> IO [TypeName]) -> IO [Closure] -> IO [TypeName]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
aliases :: IO [Closure])
    Maybe Text
doc' <- (Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
Util.Text.toText (Maybe Text -> Maybe Text) -> IO (Maybe Text) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO (Maybe Text)
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
doc
    Vector Text
symbols' <- [Text] -> Vector Text
forall a. [a] -> Vector a
Vector.fromList ([Text] -> Vector Text)
-> ([Text] -> [Text]) -> [Text] -> Vector Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.toText ([Text] -> Vector Text) -> IO [Text] -> IO (Vector Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO [Text]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
symbols
    pure (TypeName
name', [TypeName]
aliases', Maybe Text
doc', Vector Text
symbols')
  Closure
d -> [Word]
-> [Char] -> IO (TypeName, [TypeName], Maybe Text, Vector Text)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (TypeName, [TypeName], Maybe Text, Vector Text))
-> [Char] -> IO (TypeName, [TypeName], Maybe Text, Vector Text)
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeEnum: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeFixed :: Closure -> IO (Avro.TypeName, [Avro.TypeName], Int, Maybe ReadSchema.LogicalTypeFixed)
avroDecodeFixed :: Closure -> IO (TypeName, [TypeName], Int, Maybe LogicalTypeFixed)
avroDecodeFixed = \case
  DataC TermReference
_ PackedTag
_ [BoxedVal Closure
name, Val
_, Val
aliases, Val
size, BoxedVal Closure
logicalType] -> do
    TypeName
name' <- Closure -> IO TypeName
avroDecodeTypeName Closure
name
    [TypeName]
aliases' <- (Closure -> IO TypeName) -> [Closure] -> IO [TypeName]
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 Closure -> IO TypeName
avroDecodeTypeName ([Closure] -> IO [TypeName]) -> IO [Closure] -> IO [TypeName]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
aliases :: IO [Closure])
    Int
size' <- Val -> IO Int
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
size
    Maybe LogicalTypeFixed
logicalType' <- (Closure -> IO LogicalTypeFixed)
-> Closure -> IO (Maybe LogicalTypeFixed)
forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO LogicalTypeFixed
avroDecodeLogicalFixed Closure
logicalType
    pure (TypeName
name', [TypeName]
aliases', Int
size', Maybe LogicalTypeFixed
logicalType')
  Closure
d -> [Word]
-> [Char] -> IO (TypeName, [TypeName], Int, Maybe LogicalTypeFixed)
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO (TypeName, [TypeName], Int, Maybe LogicalTypeFixed))
-> [Char] -> IO (TypeName, [TypeName], Int, Maybe LogicalTypeFixed)
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeFixed: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeLogicalFixed :: Closure -> IO ReadSchema.LogicalTypeFixed
avroDecodeLogicalFixed :: Closure -> IO LogicalTypeFixed
avroDecodeLogicalFixed = \case
  Enum TermReference
_ PackedTag
t | PackedTag
TT.avroLogicalFixedDurationTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeFixed -> IO LogicalTypeFixed
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeFixed
ReadSchema.Duration
  Data1 TermReference
_ PackedTag
t (BoxedVal Closure
v) | PackedTag
TT.avroLogicalFixedDecimalTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Decimal -> LogicalTypeFixed
ReadSchema.DecimalF (Decimal -> LogicalTypeFixed) -> IO Decimal -> IO LogicalTypeFixed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Decimal
avroDecodeDecimal Closure
v
  Closure
d -> [Word] -> [Char] -> IO LogicalTypeFixed
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO LogicalTypeFixed) -> [Char] -> IO LogicalTypeFixed
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeLogicalFixed: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeReadLong :: Closure -> IO ReadSchema.ReadLong
avroDecodeReadLong :: Closure -> IO ReadLong
avroDecodeReadLong = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroReadLongInt32Tag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadLong -> IO ReadLong
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadLong
ReadSchema.LongFromInt
    | PackedTag
TT.avroReadLongTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadLong -> IO ReadLong
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadLong
ReadSchema.ReadLong
  Closure
d -> [Word] -> [Char] -> IO ReadLong
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ReadLong) -> [Char] -> IO ReadLong
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadLong: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeLogicalInt :: Closure -> IO ReadSchema.LogicalTypeInt
avroDecodeLogicalInt :: Closure -> IO LogicalTypeInt
avroDecodeLogicalInt = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroLogicalIntDateTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeInt -> IO LogicalTypeInt
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeInt
ReadSchema.Date
    | PackedTag
TT.avroLogicalIntTimeTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeInt -> IO LogicalTypeInt
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeInt
ReadSchema.TimeMillis
  Data1 TermReference
_ PackedTag
t (BoxedVal Closure
v) | PackedTag
TT.avroLogicalIntDecimalTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Decimal -> LogicalTypeInt
ReadSchema.DecimalI (Decimal -> LogicalTypeInt) -> IO Decimal -> IO LogicalTypeInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Decimal
avroDecodeDecimal Closure
v
  Closure
d -> [Word] -> [Char] -> IO LogicalTypeInt
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO LogicalTypeInt) -> [Char] -> IO LogicalTypeInt
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeLogicalInt: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeLogicalBytes :: Closure -> IO ReadSchema.LogicalTypeBytes
avroDecodeLogicalBytes :: Closure -> IO LogicalTypeBytes
avroDecodeLogicalBytes = \case
  Data1 TermReference
_ PackedTag
t (BoxedVal Closure
v) | PackedTag
TT.avroLogicalBytesDecimalTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Decimal -> LogicalTypeBytes
ReadSchema.DecimalB (Decimal -> LogicalTypeBytes) -> IO Decimal -> IO LogicalTypeBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Decimal
avroDecodeDecimal Closure
v
  Closure
d -> [Word] -> [Char] -> IO LogicalTypeBytes
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO LogicalTypeBytes) -> [Char] -> IO LogicalTypeBytes
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeLogicalBytes: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeLogicalString :: Closure -> IO ReadSchema.LogicalTypeString
avroDecodeLogicalString :: Closure -> IO LogicalTypeString
avroDecodeLogicalString = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroLogicalStringUuidTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> LogicalTypeString -> IO LogicalTypeString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogicalTypeString
ReadSchema.UUID
  Closure
d -> [Word] -> [Char] -> IO LogicalTypeString
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO LogicalTypeString) -> [Char] -> IO LogicalTypeString
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeLogicalString: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeTypeName :: Closure -> IO Avro.TypeName
avroDecodeTypeName :: Closure -> IO TypeName
avroDecodeTypeName = \case
  Data2 TermReference
_ PackedTag
_ Val
name Val
namespace -> (Text -> [Text] -> TypeName
Avro.TN (Text -> [Text] -> TypeName)
-> (Text -> Text) -> Text -> [Text] -> TypeName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Util.Text.toText (Text -> [Text] -> TypeName) -> IO Text -> IO ([Text] -> TypeName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Text
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
name) IO ([Text] -> TypeName) -> IO [Text] -> IO TypeName
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.toText ([Text] -> [Text]) -> IO [Text] -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO [Text]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
namespace)
  Closure
d -> [Word] -> [Char] -> IO TypeName
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO TypeName) -> [Char] -> IO TypeName
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeTypeName: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeReadFloat :: Closure -> IO ReadSchema.ReadFloat
avroDecodeReadFloat :: Closure -> IO ReadFloat
avroDecodeReadFloat = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroReadFloatFromInt32Tag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadFloat -> IO ReadFloat
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadFloat
ReadSchema.FloatFromInt
    | PackedTag
TT.avroReadFloatFromInt64Tag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadFloat -> IO ReadFloat
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadFloat
ReadSchema.FloatFromLong
    | PackedTag
TT.avroReadFloatTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadFloat -> IO ReadFloat
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadFloat
ReadSchema.ReadFloat
  Closure
d -> [Word] -> [Char] -> IO ReadFloat
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ReadFloat) -> [Char] -> IO ReadFloat
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadFloat: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeReadDouble :: Closure -> IO ReadSchema.ReadDouble
avroDecodeReadDouble :: Closure -> IO ReadDouble
avroDecodeReadDouble = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroReadDoubleFromInt32Tag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadDouble -> IO ReadDouble
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadDouble
ReadSchema.DoubleFromInt
    | PackedTag
TT.avroReadDoubleFromInt64Tag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadDouble -> IO ReadDouble
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadDouble
ReadSchema.DoubleFromLong
    | PackedTag
TT.avroReadDoubleFromFloatTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadDouble -> IO ReadDouble
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadDouble
ReadSchema.DoubleFromFloat
    | PackedTag
TT.avroReadDoubleTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> ReadDouble -> IO ReadDouble
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReadDouble
ReadSchema.ReadDouble
  Closure
d -> [Word] -> [Char] -> IO ReadDouble
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO ReadDouble) -> [Char] -> IO ReadDouble
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeReadDouble: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeDecimal :: Closure -> IO ReadSchema.Decimal
avroDecodeDecimal :: Closure -> IO Decimal
avroDecodeDecimal = \case
  Data2 TermReference
_ PackedTag
_ Val
precision Val
scale -> Integer -> Integer -> Decimal
ReadSchema.Decimal (Integer -> Integer -> Decimal)
-> IO Integer -> IO (Integer -> Decimal)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Integer) -> IO Int -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Val -> IO Int
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
precision :: IO Int) IO (Integer -> Decimal) -> IO Integer -> IO Decimal
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Integer) -> IO Int -> IO Integer
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Val -> IO Int
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
scale :: IO Int)
  Closure
d -> [Word] -> [Char] -> IO Decimal
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Decimal) -> [Char] -> IO Decimal
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeDecimal: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeFieldStatus :: Closure -> IO ReadSchema.FieldStatus
avroDecodeFieldStatus :: Closure -> IO FieldStatus
avroDecodeFieldStatus = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroFieldStatusIgnoredTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> FieldStatus -> IO FieldStatus
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldStatus
ReadSchema.Ignored
  Data1 TermReference
_ PackedTag
_ Val
v -> Int -> FieldStatus
ReadSchema.AsIs (Int -> FieldStatus) -> (Pos -> Int) -> Pos -> FieldStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pos -> FieldStatus) -> IO Pos -> IO FieldStatus
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> IO Pos
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v :: IO Word64)
  Data2 TermReference
_ PackedTag
_ Val
v1 (BoxedVal Closure
v2) -> Int -> DefaultValue -> FieldStatus
ReadSchema.Defaulted (Int -> DefaultValue -> FieldStatus)
-> IO Int -> IO (DefaultValue -> FieldStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Int
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v1 IO (DefaultValue -> FieldStatus)
-> IO DefaultValue -> IO FieldStatus
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 DefaultValue
avroDecodeDefaultValue Closure
v2
  Closure
d -> [Word] -> [Char] -> IO FieldStatus
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO FieldStatus) -> [Char] -> IO FieldStatus
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeFieldStatus: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeOrder :: Closure -> IO Avro.Order
avroDecodeOrder :: Closure -> IO Order
avroDecodeOrder = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroOrderAscendingTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Order -> IO Order
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Order
Avro.Ascending
    | PackedTag
TT.avroOrderDescendingTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Order -> IO Order
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Order
Avro.Descending
    | PackedTag
TT.avroOrderIgnoreTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Order -> IO Order
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Order
Avro.Ignore
  Closure
d -> [Word] -> [Char] -> IO Order
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO Order) -> [Char] -> IO Order
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeOrder: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroDecodeDefaultValue :: Closure -> IO AvroSchema.DefaultValue
avroDecodeDefaultValue :: Closure -> IO DefaultValue
avroDecodeDefaultValue = \case
  Enum TermReference
_ PackedTag
t
    | PackedTag
TT.avroDefaultValueNullTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> DefaultValue -> IO DefaultValue
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefaultValue
AvroSchema.DNull
  Data1 TermReference
_ PackedTag
t Val
v
    | PackedTag
TT.avroDefaultValueBooleanTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Bool -> DefaultValue
AvroSchema.DBoolean (Bool -> DefaultValue) -> IO Bool -> IO DefaultValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Bool
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v
    | PackedTag
TT.avroDefaultValueArrayTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Vector DefaultValue -> DefaultValue
AvroSchema.DArray (Vector DefaultValue -> DefaultValue)
-> ([DefaultValue] -> Vector DefaultValue)
-> [DefaultValue]
-> DefaultValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DefaultValue] -> Vector DefaultValue
forall a. [a] -> Vector a
Vector.fromList ([DefaultValue] -> DefaultValue)
-> IO [DefaultValue] -> IO DefaultValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Closure -> IO DefaultValue) -> [Closure] -> IO [DefaultValue]
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 Closure -> IO DefaultValue
avroDecodeDefaultValue ([Closure] -> IO [DefaultValue])
-> IO [Closure] -> IO [DefaultValue]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v)
    | PackedTag
TT.avroDefaultValueMapTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> HashMap Text DefaultValue -> DefaultValue
AvroSchema.DMap (HashMap Text DefaultValue -> DefaultValue)
-> ([(Text, DefaultValue)] -> HashMap Text DefaultValue)
-> [(Text, DefaultValue)]
-> DefaultValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, DefaultValue)] -> HashMap Text DefaultValue
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Text, DefaultValue)] -> DefaultValue)
-> IO [(Text, DefaultValue)] -> IO DefaultValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (((Text, Closure) -> IO (Text, DefaultValue))
-> [(Text, Closure)] -> IO [(Text, DefaultValue)]
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 ((Text -> IO Text)
-> (Closure -> IO DefaultValue)
-> (Text, Closure)
-> IO (Text, DefaultValue)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM (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.toText) Closure -> IO DefaultValue
avroDecodeDefaultValue) ([(Text, Closure)] -> IO [(Text, DefaultValue)])
-> IO [(Text, Closure)] -> IO [(Text, DefaultValue)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> IO [(Text, Closure)]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v)
  Data2 TermReference
_ PackedTag
t (BoxedVal Closure
c1) Val
v2
    | PackedTag
TT.avroDefaultValueIntTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> Int32 -> DefaultValue
AvroSchema.DInt (Schema -> Int32 -> DefaultValue)
-> IO Schema -> IO (Int32 -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c1 IO (Int32 -> DefaultValue) -> IO Int32 -> IO DefaultValue
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> IO Int -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> IO Int
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v2 :: IO Int))
    | PackedTag
TT.avroDefaultValueLongTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> Int64 -> DefaultValue
AvroSchema.DLong (Schema -> Int64 -> DefaultValue)
-> IO Schema -> IO (Int64 -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c1 IO (Int64 -> DefaultValue) -> IO Int64 -> IO DefaultValue
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int64) -> IO Int -> IO Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> IO Int
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v2 :: IO Int))
    | PackedTag
TT.avroDefaultValueFloatTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> Float -> DefaultValue
AvroSchema.DFloat (Schema -> Float -> DefaultValue)
-> IO Schema -> IO (Float -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c1 IO (Float -> DefaultValue) -> IO Float -> IO DefaultValue
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Double -> Float
double2Float (Double -> Float) -> IO Double -> IO Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Val -> IO Double
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v2 :: IO Double))
    | PackedTag
TT.avroDefaultValueDoubleTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> Double -> DefaultValue
AvroSchema.DDouble (Schema -> Double -> DefaultValue)
-> IO Schema -> IO (Double -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c1 IO (Double -> DefaultValue) -> IO Double -> IO DefaultValue
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 Double
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v2
    | PackedTag
TT.avroDefaultValueBytesTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> ByteString -> DefaultValue
AvroSchema.DBytes (Schema -> ByteString -> DefaultValue)
-> IO Schema -> IO (ByteString -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c1 IO (ByteString -> DefaultValue) -> IO ByteString -> IO DefaultValue
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Bytes -> ByteString
Bytes.toByteString (Bytes -> ByteString) -> IO Bytes -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Bytes
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v2)
    | PackedTag
TT.avroDefaultValueStringTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> Text -> DefaultValue
AvroSchema.DString (Schema -> Text -> DefaultValue)
-> IO Schema -> IO (Text -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c1 IO (Text -> DefaultValue) -> IO Text -> IO DefaultValue
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Text
Util.Text.toText (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Text
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v2)
    | PackedTag
TT.avroDefaultValueRecordTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> HashMap Text DefaultValue -> DefaultValue
AvroSchema.DRecord (Schema -> HashMap Text DefaultValue -> DefaultValue)
-> IO Schema -> IO (HashMap Text DefaultValue -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c1 IO (HashMap Text DefaultValue -> DefaultValue)
-> IO (HashMap Text DefaultValue) -> IO DefaultValue
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(Text, DefaultValue)] -> HashMap Text DefaultValue)
-> IO [(Text, DefaultValue)] -> IO (HashMap Text DefaultValue)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Text, DefaultValue)] -> HashMap Text DefaultValue
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList (((Text, Closure) -> IO (Text, DefaultValue))
-> [(Text, Closure)] -> IO [(Text, DefaultValue)]
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 ((Text -> IO Text)
-> (Closure -> IO DefaultValue)
-> (Text, Closure)
-> IO (Text, DefaultValue)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM (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.toText) Closure -> IO DefaultValue
avroDecodeDefaultValue) ([(Text, Closure)] -> IO [(Text, DefaultValue)])
-> IO [(Text, Closure)] -> IO [(Text, DefaultValue)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> IO [(Text, Closure)]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v2)
    | PackedTag
TT.avroDefaultValueFixedTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> ByteString -> DefaultValue
AvroSchema.DFixed (Schema -> ByteString -> DefaultValue)
-> IO Schema -> IO (ByteString -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
c1 IO (ByteString -> DefaultValue) -> IO ByteString -> IO DefaultValue
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Bytes -> ByteString
Bytes.toByteString (Bytes -> ByteString) -> IO Bytes -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Bytes
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
v2)
  DataC TermReference
_ PackedTag
t [Val
schemas, BoxedVal Closure
schema, BoxedVal Closure
defaultVal] | PackedTag
TT.avroDefaultValueUnionTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Vector Schema -> Schema -> DefaultValue -> DefaultValue
AvroSchema.DUnion (Vector Schema -> Schema -> DefaultValue -> DefaultValue)
-> IO (Vector Schema)
-> IO (Schema -> DefaultValue -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Schema] -> Vector Schema) -> IO [Schema] -> IO (Vector Schema)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Schema] -> Vector Schema
forall a. [a] -> Vector a
Vector.fromList ((Closure -> IO Schema) -> [Closure] -> IO [Schema]
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 Closure -> IO Schema
avroDecodeSchema ([Closure] -> IO [Schema]) -> IO [Closure] -> IO [Schema]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Val -> IO [Closure]
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
schemas) IO (Schema -> DefaultValue -> DefaultValue)
-> IO Schema -> IO (DefaultValue -> DefaultValue)
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 Schema
avroDecodeSchema Closure
schema IO (DefaultValue -> DefaultValue)
-> IO DefaultValue -> IO DefaultValue
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 DefaultValue
avroDecodeDefaultValue Closure
defaultVal)
  DataC TermReference
_ PackedTag
t [BoxedVal Closure
schema, Val
ix, Val
symbol] | PackedTag
TT.avroDefaultValueEnumTag PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
t -> Schema -> Int -> Text -> DefaultValue
AvroSchema.DEnum (Schema -> Int -> Text -> DefaultValue)
-> IO Schema -> IO (Int -> Text -> DefaultValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO Schema
avroDecodeSchema Closure
schema IO (Int -> Text -> DefaultValue)
-> IO Int -> IO (Text -> DefaultValue)
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 Int
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
ix IO (Text -> DefaultValue) -> IO Text -> IO DefaultValue
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Text
Util.Text.toText (Text -> Text) -> IO Text -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Val -> IO Text
forall a. ForeignConvention a => Val -> IO a
decodeVal Val
symbol)
  Closure
d -> [Word] -> [Char] -> IO DefaultValue
forall a. HasCallStack => [Word] -> [Char] -> IO a
die [] ([Char] -> IO DefaultValue) -> [Char] -> IO DefaultValue
forall a b. (a -> b) -> a -> b
$ [Char]
"avroDecodeDefaultValue: type error: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Closure -> [Char]
forall a. Show a => a -> [Char]
show Closure
d

avroEncodeLogicalTypeInt :: ReadSchema.LogicalTypeInt -> Val
avroEncodeLogicalTypeInt :: LogicalTypeInt -> Val
avroEncodeLogicalTypeInt = \case
  LogicalTypeInt
ReadSchema.Date -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalIntRef PackedTag
TT.avroLogicalIntDateTag
  LogicalTypeInt
ReadSchema.TimeMillis -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalIntRef PackedTag
TT.avroLogicalIntTimeTag
  ReadSchema.DecimalI (ReadSchema.Decimal Integer
precision Integer
scale) -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroLogicalIntRef PackedTag
TT.avroLogicalIntDecimalTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDecimalRef PackedTag
TT.avroDecimalTag (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
precision :: Int)) (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
scale :: Int)))

avroEncodeReadLong :: ReadSchema.ReadLong -> Val
avroEncodeReadLong :: ReadLong -> Val
avroEncodeReadLong = \case
  ReadLong
ReadSchema.LongFromInt -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadLongRef PackedTag
TT.avroReadLongInt32Tag
  ReadLong
ReadSchema.ReadLong -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadLongRef PackedTag
TT.avroReadLongTag

avroEncodeReadFloat :: ReadSchema.ReadFloat -> Val
avroEncodeReadFloat :: ReadFloat -> Val
avroEncodeReadFloat = \case
  ReadFloat
ReadSchema.FloatFromInt -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadFloatRef PackedTag
TT.avroReadFloatFromInt32Tag
  ReadFloat
ReadSchema.FloatFromLong -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadFloatRef PackedTag
TT.avroReadFloatFromInt64Tag
  ReadFloat
ReadSchema.ReadFloat -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadFloatRef PackedTag
TT.avroReadFloatTag

avroEncodeReadDouble :: ReadSchema.ReadDouble -> Val
avroEncodeReadDouble :: ReadDouble -> Val
avroEncodeReadDouble = \case
  ReadDouble
ReadSchema.DoubleFromInt -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadDoubleRef PackedTag
TT.avroReadDoubleFromInt32Tag
  ReadDouble
ReadSchema.DoubleFromLong -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadDoubleRef PackedTag
TT.avroReadDoubleFromInt64Tag
  ReadDouble
ReadSchema.DoubleFromFloat -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadDoubleRef PackedTag
TT.avroReadDoubleFromFloatTag
  ReadDouble
ReadSchema.ReadDouble -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadDoubleRef PackedTag
TT.avroReadDoubleTag

avroEncodeReadSchema :: Avro.ReadSchema -> Val
avroEncodeReadSchema :: ReadSchema -> Val
avroEncodeReadSchema = \case
  ReadSchema
ReadSchema.Null -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaNullTag
  ReadSchema
ReadSchema.Boolean -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaBooleanTag
  ReadSchema.Int Maybe LogicalTypeInt
logicalType -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaIntTag (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeInt -> Val) -> Maybe LogicalTypeInt -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeInt -> Val
avroEncodeLogicalTypeInt Maybe LogicalTypeInt
logicalType))
  ReadSchema.Long ReadLong
readLong Maybe LogicalTypeLong
logicalType -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaLongTag (ReadLong -> Val
avroEncodeReadLong ReadLong
readLong) (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeLong -> Val) -> Maybe LogicalTypeLong -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeLong -> Val
avroEncodeLogicalTypeLong Maybe LogicalTypeLong
logicalType))
  ReadSchema.Float ReadFloat
readFloat -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaFloatTag (ReadFloat -> Val
avroEncodeReadFloat ReadFloat
readFloat)
  ReadSchema.Double ReadDouble
readDouble -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaDoubleTag (ReadDouble -> Val
avroEncodeReadDouble ReadDouble
readDouble)
  ReadSchema.Bytes Maybe LogicalTypeBytes
logicalType -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaBytesTag (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeBytes -> Val) -> Maybe LogicalTypeBytes -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeBytes -> Val
avroEncodeLogicalTypeBytes Maybe LogicalTypeBytes
logicalType))
  ReadSchema.String Maybe LogicalTypeString
logicalType -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaStringTag (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeString -> Val) -> Maybe LogicalTypeString -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeString -> Val
avroEncodeLogicalTypeString Maybe LogicalTypeString
logicalType))
  ReadSchema.Array ReadSchema
readSchema -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaArrayTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
readSchema) ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((DefaultValue -> Val) -> [DefaultValue] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DefaultValue -> Val
avroEncodeDefaultValue []))
  ReadSchema.Map ReadSchema
readSchema -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaMapTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
readSchema) (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.mapRef PackedTag
TT.mapTipTag)
  ReadSchema.NamedType TypeName
tn -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaNamedTypeTag (TypeName -> Val
avroEncodeTypeName TypeName
tn)
  ReadSchema.Record TypeName
name [TypeName]
aliases Maybe Text
doc [ReadField]
fields -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaRecordTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroReadRecordRef PackedTag
TT.avroReadRecordTag ([Closure] -> Seg
boxedSeg [Val -> Closure
getBoxedVal (TypeName -> Val
avroEncodeTypeName TypeName
name), Val -> Closure
getBoxedVal ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((TypeName -> Val) -> [TypeName] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Val
avroEncodeTypeName [TypeName]
aliases)), Val -> Closure
getBoxedVal (Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
doc)), Val -> Closure
getBoxedVal ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((ReadField -> Val) -> [ReadField] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map ReadField -> Val
avroEncodeReadField [ReadField]
fields))]))
  ReadSchema.Enum TypeName
name [TypeName]
aliases Maybe Text
doc Vector Text
symbols -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaEnumTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroEnumRef PackedTag
TT.avroEnumTag ([Closure] -> Seg
boxedSeg [Val -> Closure
getBoxedVal (TypeName -> Val
avroEncodeTypeName TypeName
name), Val -> Closure
getBoxedVal (Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
doc)), Val -> Closure
getBoxedVal ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((TypeName -> Val) -> [TypeName] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Val
avroEncodeTypeName [TypeName]
aliases)), Val -> Closure
getBoxedVal ([Text] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.fromText (Vector Text -> [Text]
forall a. Vector a -> [a]
Vector.toList Vector Text
symbols))), Val -> Closure
getBoxedVal (Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Maybe Text
forall a. Maybe a
Nothing :: Maybe Text))]))
  ReadSchema.Union Vector (Int, ReadSchema)
options -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaUnionTag ([(Int, Val)] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (((Int, ReadSchema) -> (Int, Val))
-> [(Int, ReadSchema)] -> [(Int, Val)]
forall a b. (a -> b) -> [a] -> [b]
map ((ReadSchema -> Val) -> (Int, ReadSchema) -> (Int, Val)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ReadSchema -> Val
avroEncodeReadSchema) (Vector (Int, ReadSchema) -> [(Int, ReadSchema)]
forall a. Vector a -> [a]
Vector.toList Vector (Int, ReadSchema)
options)))
  ReadSchema.Fixed TypeName
name [TypeName]
aliases Int
size Maybe LogicalTypeFixed
logicalType -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaFixedTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroFixedRef PackedTag
TT.avroFixedTag ([Closure] -> Seg
boxedSeg [Val -> Closure
getBoxedVal (TypeName -> Val
avroEncodeTypeName TypeName
name), Val -> Closure
getBoxedVal ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((TypeName -> Val) -> [TypeName] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Val
avroEncodeTypeName [TypeName]
aliases)), Val -> Closure
getBoxedVal (Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Maybe Text
forall a. Maybe a
Nothing :: Maybe Text)), Val -> Closure
getBoxedVal (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Int
size), Val -> Closure
getBoxedVal (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeFixed -> Val) -> Maybe LogicalTypeFixed -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeFixed -> Val
avroEncodeLogicalTypeFixed Maybe LogicalTypeFixed
logicalType))]))
  ReadSchema.FreeUnion Int
pos ReadSchema
ty -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroReadSchemaRef PackedTag
TT.avroReadSchemaFreeUnionTag (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Int
pos) (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
ty)

avroEncodeTypeName :: Avro.TypeName -> Val
avroEncodeTypeName :: TypeName -> Val
avroEncodeTypeName (Avro.TN Text
baseName [Text]
namespace) = Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroTypeNameRef PackedTag
TT.avroTypeNameTag (Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText Text
baseName)) ([Text] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.fromText [Text]
namespace))

avroEncodeReadField :: ReadSchema.ReadField -> Val
avroEncodeReadField :: ReadField -> Val
avroEncodeReadField = \case
  ReadSchema.ReadField Text
name [Text]
aliases Maybe Text
doc Maybe Order
order FieldStatus
status ReadSchema
typ Maybe DefaultValue
def -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroReadFieldRef PackedTag
TT.avroReadFieldTag ([Closure] -> Seg
boxedSeg [Val -> Closure
getBoxedVal (Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText Text
name)), Val -> Closure
getBoxedVal ([Text] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.fromText [Text]
aliases)), Val -> Closure
getBoxedVal (Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
doc)), Val -> Closure
getBoxedVal (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
typ), Val -> Closure
getBoxedVal (FieldStatus -> Val
avroEncodeFieldStatus FieldStatus
status), Val -> Closure
getBoxedVal (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Order -> Val) -> Maybe Order -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Order -> Val
avroEncodeOrder Maybe Order
order)), Val -> Closure
getBoxedVal (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((DefaultValue -> Val) -> Maybe DefaultValue -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DefaultValue -> Val
avroEncodeDefaultValue Maybe DefaultValue
def))])

avroEncodeLogicalTypeString :: ReadSchema.LogicalTypeString -> Val
avroEncodeLogicalTypeString :: LogicalTypeString -> Val
avroEncodeLogicalTypeString = \case
  LogicalTypeString
ReadSchema.UUID -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalStringRef PackedTag
TT.avroLogicalStringUuidTag

avroEncodeFieldStatus :: ReadSchema.FieldStatus -> Val
avroEncodeFieldStatus :: FieldStatus -> Val
avroEncodeFieldStatus = \case
  ReadSchema.AsIs Int
n -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroFieldStatusRef PackedTag
TT.avroFieldStatusAsIsTag (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Int
n)
  FieldStatus
ReadSchema.Ignored -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroFieldStatusRef PackedTag
TT.avroFieldStatusIgnoredTag
  ReadSchema.Defaulted Int
n DefaultValue
def -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroFieldStatusRef PackedTag
TT.avroFieldStatusDefaultedTag (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Int
n) (DefaultValue -> Val
avroEncodeDefaultValue DefaultValue
def)

avroEncodeOrder :: Avro.Order -> Val
avroEncodeOrder :: Order -> Val
avroEncodeOrder = \case
  Order
Avro.Ascending -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroOrderRef PackedTag
TT.avroOrderAscendingTag
  Order
Avro.Descending -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroOrderRef PackedTag
TT.avroOrderDescendingTag
  Order
Avro.Ignore -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroOrderRef PackedTag
TT.avroOrderIgnoreTag

avroEncodeLogicalTypeLong :: ReadSchema.LogicalTypeLong -> Val
avroEncodeLogicalTypeLong :: LogicalTypeLong -> Val
avroEncodeLogicalTypeLong = \case
  LogicalTypeLong
ReadSchema.TimeMicros -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalLongRef PackedTag
TT.avroLogicalLongTimeMicrosTag
  LogicalTypeLong
ReadSchema.TimestampMillis -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalLongRef PackedTag
TT.avroLogicalLongTimestampMillisTag
  LogicalTypeLong
ReadSchema.TimestampMicros -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalLongRef PackedTag
TT.avroLogicalLongTimestampMicrosTag
  LogicalTypeLong
ReadSchema.LocalTimestampMillis -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalLongRef PackedTag
TT.avroLogicalLongLocalTimestampMillisTag
  LogicalTypeLong
ReadSchema.LocalTimestampMicros -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalLongRef PackedTag
TT.avroLogicalLongLocalTimestampMicrosTag
  ReadSchema.DecimalL (ReadSchema.Decimal Integer
precision Integer
scale) -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroLogicalLongRef PackedTag
TT.avroLogicalLongDecimalTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDecimalRef PackedTag
TT.avroDecimalTag (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
precision :: Int)) (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
scale :: Int)))

avroEncodeLogicalTypeBytes :: ReadSchema.LogicalTypeBytes -> Val
avroEncodeLogicalTypeBytes :: LogicalTypeBytes -> Val
avroEncodeLogicalTypeBytes = \case
  ReadSchema.DecimalB (ReadSchema.Decimal Integer
precision Integer
scale) -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroLogicalBytesRef PackedTag
TT.avroLogicalBytesDecimalTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDecimalRef PackedTag
TT.avroDecimalTag (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
precision :: Int)) (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
scale :: Int)))

avroEncodeLogicalTypeFixed :: ReadSchema.LogicalTypeFixed -> Val
avroEncodeLogicalTypeFixed :: LogicalTypeFixed -> Val
avroEncodeLogicalTypeFixed = \case
  ReadSchema.DecimalF (ReadSchema.Decimal Integer
precision Integer
scale) -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroLogicalFixedRef PackedTag
TT.avroLogicalFixedDecimalTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDecimalRef PackedTag
TT.avroDecimalTag (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
precision :: Int)) (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
scale :: Int)))
  LogicalTypeFixed
ReadSchema.Duration -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroLogicalFixedRef PackedTag
TT.avroLogicalFixedDurationTag

avroEncodeValue :: FromAvro.Value -> Val
avroEncodeValue :: Value -> Val
avroEncodeValue = \case
  Value
FromAvro.Null -> Val
avroNull
  FromAvro.Boolean Bool
b -> if Bool
b then Val
avroTrue else Val
avroFalse
  FromAvro.Int ReadSchema
schema Int32
n ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$
      TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroRef PackedTag
TT.avroIntTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema) (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n :: Int))
  FromAvro.Long ReadSchema
schema Int64
n -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroRef PackedTag
TT.avroLongTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema) (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n :: Int))
  FromAvro.Float ReadSchema
schema Float
n ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroRef PackedTag
TT.avroFloatTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema) (Double -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Float -> Double
float2Double Float
n))
  FromAvro.Double ReadSchema
schema Double
n ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroRef PackedTag
TT.avroDoubleTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema) (Double -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Double
n)
  FromAvro.Bytes ReadSchema
schema ByteString
bs ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroRef PackedTag
TT.avroBytesTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema) (Bytes -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (ByteString -> Bytes
Bytes.fromByteString ByteString
bs))
  FromAvro.String ReadSchema
schema Text
s ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroRef PackedTag
TT.avroStringTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema) (Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText Text
s))
  FromAvro.Array Vector Value
xs ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroRef PackedTag
TT.avroArrayTag ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Value -> Val) -> [Value] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Val
avroEncodeValue (Vector Value -> [Value]
forall a. Vector a -> [a]
Vector.toList Vector Value
xs)))
  FromAvro.Map HashMap Text Value
xs ->
    let m :: [(Text, Value)]
m = HashMap Text Value -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text Value
xs
        encoded :: [(Text, Val)]
encoded = ((Text, Value) -> (Text, Val)) -> [(Text, Value)] -> [(Text, Val)]
forall a b. (a -> b) -> [a] -> [b]
map ((Value -> Val) -> (Text, Value) -> (Text, Val)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Value -> Val
avroEncodeValue) [(Text, Value)]
m
     in Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroRef PackedTag
TT.avroMapTag (Val -> Closure) -> Val -> Closure
forall a b. (a -> b) -> a -> b
$ Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ Foreign -> Closure
Foreign (TermReference -> Map Text Val -> Foreign
forall e. TermReference -> e -> Foreign
Wrap TermReference
Ty.hmapRef ([(Text, Val)] -> Map Text Val
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Val)]
encoded))
  FromAvro.Record ReadSchema
schema Vector Value
fields ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroRef PackedTag
TT.avroRecordTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema) ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Value -> Val) -> [Value] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Val
avroEncodeValue (Vector Value -> [Value]
forall a. Vector a -> [a]
Vector.toList Vector Value
fields)))
  FromAvro.Union ReadSchema
schema Int
tag Value
v ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroRef PackedTag
TT.avroUnionTag ([Val] -> Seg
segFromList [ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema, Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Int
tag, Value -> Val
avroEncodeValue Value
v])
  FromAvro.Fixed ReadSchema
schema ByteString
bytes ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroRef PackedTag
TT.avroFixedTag (ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema) (Bytes -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (ByteString -> Bytes
Bytes.fromByteString ByteString
bytes))
  FromAvro.Enum ReadSchema
schema Int
ix Text
v ->
    Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroRef PackedTag
TT.avroEnumTag ([Val] -> Seg
segFromList [ReadSchema -> Val
avroEncodeReadSchema ReadSchema
schema, Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Int
ix, Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText Text
v)])

avroEncodeDefaultValue :: AvroSchema.DefaultValue -> Val
avroEncodeDefaultValue :: DefaultValue -> Val
avroEncodeDefaultValue = \case
  DefaultValue
AvroSchema.DNull -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueNullTag
  AvroSchema.DBoolean Bool
b -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueBooleanTag (Bool -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Bool
b)
  AvroSchema.DInt Schema
schema Int32
n -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueIntTag (Schema -> Val
avroEncodeSchema Schema
schema) (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n :: Int))
  AvroSchema.DLong Schema
schema Int64
n -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueLongTag (Schema -> Val
avroEncodeSchema Schema
schema) (Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n :: Int))
  AvroSchema.DFloat Schema
schema Float
f -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueFloatTag (Schema -> Val
avroEncodeSchema Schema
schema) (Double -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Float -> Double
float2Double Float
f))
  AvroSchema.DDouble Schema
schema Double
d -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueDoubleTag (Schema -> Val
avroEncodeSchema Schema
schema) (Double -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Double
d)
  AvroSchema.DString Schema
schema Text
s -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueStringTag (Schema -> Val
avroEncodeSchema Schema
schema) (Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText Text
s))
  AvroSchema.DBytes Schema
schema ByteString
bs -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueBytesTag (Schema -> Val
avroEncodeSchema Schema
schema) (Bytes -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (ByteString -> Bytes
Bytes.fromByteString ByteString
bs))
  AvroSchema.DArray Vector DefaultValue
xs -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueArrayTag ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((DefaultValue -> Val) -> [DefaultValue] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map DefaultValue -> Val
avroEncodeDefaultValue (Vector DefaultValue -> [DefaultValue]
forall a. Vector a -> [a]
Vector.toList Vector DefaultValue
xs)))
  AvroSchema.DMap HashMap Text DefaultValue
xs -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueMapTag ([(Text, Val)] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (((Text, DefaultValue) -> (Text, Val))
-> [(Text, DefaultValue)] -> [(Text, Val)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text)
-> (DefaultValue -> Val) -> (Text, DefaultValue) -> (Text, Val)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> Text
Util.Text.fromText DefaultValue -> Val
avroEncodeDefaultValue) (HashMap Text DefaultValue -> [(Text, DefaultValue)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text DefaultValue
xs)))
  AvroSchema.DRecord Schema
schema HashMap Text DefaultValue
fields -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueRecordTag (Schema -> Val
avroEncodeSchema Schema
schema) ([(Text, Val)] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (((Text, DefaultValue) -> (Text, Val))
-> [(Text, DefaultValue)] -> [(Text, Val)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text)
-> (DefaultValue -> Val) -> (Text, DefaultValue) -> (Text, Val)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> Text
Util.Text.fromText DefaultValue -> Val
avroEncodeDefaultValue) (HashMap Text DefaultValue -> [(Text, DefaultValue)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text DefaultValue
fields)))
  AvroSchema.DUnion Vector Schema
schemas Schema
schema DefaultValue
v -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueUnionTag ([Val] -> Seg
segFromList [[Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Schema -> Val) -> [Schema] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Schema -> Val
avroEncodeSchema (Vector Schema -> [Schema]
forall a. Vector a -> [a]
Vector.toList Vector Schema
schemas)), Schema -> Val
avroEncodeSchema Schema
schema, DefaultValue -> Val
avroEncodeDefaultValue DefaultValue
v])
  AvroSchema.DFixed Schema
schema ByteString
bytes -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueFixedTag (Schema -> Val
avroEncodeSchema Schema
schema) (Bytes -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (ByteString -> Bytes
Bytes.fromByteString ByteString
bytes))
  AvroSchema.DEnum Schema
schema Int
ix Text
v -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroDefaultValueRef PackedTag
TT.avroDefaultValueEnumTag ([Val] -> Seg
segFromList [Schema -> Val
avroEncodeSchema Schema
schema, Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Int
ix, Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText Text
v)])

avroEncodeSchema :: AvroSchema.Schema -> Val
avroEncodeSchema :: Schema -> Val
avroEncodeSchema = \case
  Schema
AvroSchema.Null -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaNullTag
  Schema
AvroSchema.Boolean -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaBooleanTag
  AvroSchema.Int Maybe LogicalTypeInt
lt -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaIntTag (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeInt -> Val) -> Maybe LogicalTypeInt -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeInt -> Val
avroEncodeLogicalTypeInt Maybe LogicalTypeInt
lt))
  AvroSchema.Long Maybe LogicalTypeLong
lt -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaLongTag (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeLong -> Val) -> Maybe LogicalTypeLong -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeLong -> Val
avroEncodeLogicalTypeLong Maybe LogicalTypeLong
lt))
  Schema
AvroSchema.Float -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaFloatTag
  Schema
AvroSchema.Double -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaDoubleTag
  AvroSchema.Bytes Maybe LogicalTypeBytes
lt -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaBytesTag (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeBytes -> Val) -> Maybe LogicalTypeBytes -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeBytes -> Val
avroEncodeLogicalTypeBytes Maybe LogicalTypeBytes
lt))
  AvroSchema.String Maybe LogicalTypeString
lt -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaStringTag (Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeString -> Val) -> Maybe LogicalTypeString -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeString -> Val
avroEncodeLogicalTypeString Maybe LogicalTypeString
lt))
  AvroSchema.Array Schema
schema -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaArrayTag (Schema -> Val
avroEncodeSchema Schema
schema) ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ([] :: [Val]))
  AvroSchema.Map Schema
schema -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaMapTag (Schema -> Val
avroEncodeSchema Schema
schema) (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Closure
Enum TermReference
Ty.mapRef PackedTag
TT.mapTipTag)
  AvroSchema.NamedType TypeName
tn -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaNamedTypeTag (TypeName -> Val
avroEncodeTypeName TypeName
tn)
  AvroSchema.Record TypeName
name [TypeName]
aliases Maybe Text
doc [Field]
fields -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaRecordTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroRecordRef PackedTag
TT.avroRecordTypeTag ([Val] -> Seg
segFromList [TypeName -> Val
avroEncodeTypeName TypeName
name, [Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((TypeName -> Val) -> [TypeName] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Val
avroEncodeTypeName [TypeName]
aliases), Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
doc), [Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Field -> Val) -> [Field] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Val
avroEncodeField [Field]
fields)]))
  AvroSchema.Enum TypeName
name [TypeName]
aliases Maybe Text
doc Vector Text
symbols -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaEnumTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroEnumRef PackedTag
TT.avroEnumTypeTag ([Val] -> Seg
segFromList [TypeName -> Val
avroEncodeTypeName TypeName
name, Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
doc), [Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((TypeName -> Val) -> [TypeName] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Val
avroEncodeTypeName [TypeName]
aliases), [Text] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.fromText (Vector Text -> [Text]
forall a. Vector a -> [a]
Vector.toList Vector Text
symbols))]))
  AvroSchema.Union Vector Schema
schemas -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaUnionTag ([Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Schema -> Val) -> [Schema] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Schema -> Val
avroEncodeSchema (Vector Schema -> [Schema]
forall a. Vector a -> [a]
Vector.toList Vector Schema
schemas)))
  AvroSchema.Fixed TypeName
name [TypeName]
aliases Int
size Maybe LogicalTypeFixed
lt -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
Ty.avroSchemaRef PackedTag
TT.avroSchemaFixedTag (Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroFixedRef PackedTag
TT.avroFixedTypeTag ([Val] -> Seg
segFromList [TypeName -> Val
avroEncodeTypeName TypeName
name, [Val] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((TypeName -> Val) -> [TypeName] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map TypeName -> Val
avroEncodeTypeName [TypeName]
aliases), Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Maybe Text
forall a. Maybe a
Nothing :: Maybe Text), Int -> Val
forall a. ForeignConvention a => a -> Val
encodeVal Int
size, Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((LogicalTypeFixed -> Val) -> Maybe LogicalTypeFixed -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogicalTypeFixed -> Val
avroEncodeLogicalTypeFixed Maybe LogicalTypeFixed
lt)]))

avroEncodeField :: AvroSchema.Field -> Val
avroEncodeField :: Field -> Val
avroEncodeField = \case
  AvroSchema.Field Text
name [Text]
aliases Maybe Text
doc Maybe Order
order Schema
typ Maybe DefaultValue
def -> Closure -> Val
BoxedVal (Closure -> Val) -> Closure -> Val
forall a b. (a -> b) -> a -> b
$ TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.avroFieldRef PackedTag
TT.avroFieldTag ([Val] -> Seg
segFromList [Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText Text
name), [Text] -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Util.Text.fromText [Text]
aliases), Maybe Text -> Val
forall a. ForeignConvention a => a -> Val
encodeVal (Text -> Text
Util.Text.fromText (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
doc), Schema -> Val
avroEncodeSchema Schema
typ, Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((Order -> Val) -> Maybe Order -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Order -> Val
avroEncodeOrder Maybe Order
order), Maybe Val -> Val
forall a. ForeignConvention a => a -> Val
encodeVal ((DefaultValue -> Val) -> Maybe DefaultValue -> Maybe Val
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DefaultValue -> Val
avroEncodeDefaultValue Maybe DefaultValue
def)])

avroDecodeBinary :: Closure -> Closure -> Bytes.Bytes -> IO Val
avroDecodeBinary :: Closure -> Closure -> Bytes -> IO Val
avroDecodeBinary Closure
_env Closure
readSchema Bytes
bytes = do
  -- envVal <- decodeVal @[(Closure, Closure)] (BoxedVal env)
  -- envDecoded <- traverse (bimapM avroDecodeTypeName avroDecodeReadSchema) envVal
  ReadSchema
readSchemaDecoded <- Closure -> IO ReadSchema
avroDecodeReadSchema Closure
readSchema
  -- let envMap = (HashMap.fromList envDecoded) <> ReadSchema.extractBindings readSchemaDecoded
  -- TODO: Modify the avro library to allow us to call getField directly
  case Get Value
-> ByteString
-> Either (ByteString, Int64, [Char]) (ByteString, Int64, Value)
forall a.
Get a
-> ByteString
-> Either (ByteString, Int64, [Char]) (ByteString, Int64, a)
Get.runGetOrFail (ReadSchema -> Get Value
FromAvro.getValue ReadSchema
readSchemaDecoded) (ByteString -> ByteString
L.fromStrict (Bytes -> ByteString
Bytes.toByteString Bytes
bytes)) of
    Left (ByteString
_, Int64
_, [Char]
err) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ forall a. ForeignConvention a => a -> Val
encodeVal @(Either String Val) ([Char] -> Either [Char] Val
forall a b. a -> Either a b
Left [Char]
err)
    Right (ByteString
_, Int64
_, Value
value) -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Val -> IO Val) -> Val -> IO Val
forall a b. (a -> b) -> a -> b
$ forall a. ForeignConvention a => a -> Val
encodeVal @(Either String Val) (Val -> Either [Char] Val
forall a b. b -> Either a b
Right (Value -> Val
avroEncodeValue Value
value))

-- 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)

decodeMaybe :: (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe :: forall a. (Closure -> IO a) -> Closure -> IO (Maybe a)
decodeMaybe Closure -> IO a
f Closure
c = Val -> IO (Maybe Closure)
forall a. ForeignConvention a => Val -> IO a
decodeVal (Closure -> Val
BoxedVal Closure
c) IO (Maybe Closure)
-> (Maybe 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
>>= (Closure -> IO a) -> Maybe Closure -> IO (Maybe 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) -> Maybe a -> f (Maybe b)
traverse Closure -> IO a
f

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 TermReference
_ 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
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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 TermReference
_ 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
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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
. TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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 TermReference
_ 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 TermReference
_ 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 TermReference
_ 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 TermReference
_ 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 = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.optionalRef PackedTag
TT.noneTag

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

someClo :: Val -> Closure
someClo :: Val -> Closure
someClo Val
v = TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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 (NatVal Pos
v) = Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Pos -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Pos
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 = TermReference -> PackedTag -> Closure
Enum TermReference
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 = TermReference -> PackedTag -> Val -> Val -> Closure
Data2 TermReference
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 TermReference
_ PackedTag
_ (ByteArray
_, BSeg
args)) =
  TermReference -> Text -> a -> Failure a
forall a. TermReference -> Text -> a -> Failure a
F.Failure
    (TermReference -> Text -> a -> Failure a)
-> IO TermReference -> IO (Text -> a -> Failure a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure -> IO TermReference
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 TermReference
r Text
msg a
v) = TermReference -> PackedTag -> Seg -> Closure
DataG TermReference
Ty.failureRef PackedTag
TT.failureTag Seg
payload
  where
    payload :: Seg
payload = [Closure] -> Seg
boxedSeg [TermReference -> Closure
encodeTypeLink TermReference
r, Text -> Closure
encodeText Text
msg, a -> Closure
forall a. ForeignConvention a => a -> Closure
encodeAny a
v]

boxedSeg :: [Closure] -> Seg
boxedSeg :: [Closure] -> Seg
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 TermReference
decodeTypeLink = Closure -> IO TermReference
forall a. HasCallStack => Closure -> IO a
marshalUnwrapForeignIO

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

encodeAny :: (ForeignConvention a) => a -> Closure
encodeAny :: forall a. ForeignConvention a => a -> Closure
encodeAny a
v = TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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 TermReference
_ 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 (TermReference -> Text -> Foreign
forall e. TermReference -> e -> Foreign
Wrap TermReference
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. TermReference -> a -> Closure
encodeForeignClo TermReference
r = Foreign -> Closure
Foreign (Foreign -> Closure) -> (a -> Foreign) -> a -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermReference -> a -> Foreign
forall e. TermReference -> e -> Foreign
Wrap TermReference
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
. TermReference -> a -> Closure
forall a. TermReference -> a -> Closure
encodeForeignClo TermReference
r
  where
    Tagged TermReference
r = Tagged a TermReference
forall f. BuiltinForeign f => Tagged f TermReference
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
. TermReference -> a -> Closure
forall a. TermReference -> a -> Closure
encodeForeignClo TermReference
r
  where
    Tagged TermReference
r = Tagged a TermReference
forall f. BuiltinForeign f => Tagged f TermReference
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 TermReference
_ 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 TermReference
_ 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)) =
  TermReference -> PackedTag -> Val -> Closure
Data1 TermReference
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 = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.bufferModeRef PackedTag
TT.noBufTag
line'buf :: Closure
line'buf = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.bufferModeRef PackedTag
TT.lineBufTag
block'buf :: Closure
block'buf = TermReference -> PackedTag -> Closure
Enum TermReference
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 TermReference
_ 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 = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.bufferModeRef PackedTag
TT.readModeTag
write'mode :: Closure
write'mode = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.bufferModeRef PackedTag
TT.writeModeTag
append'mode :: Closure
append'mode = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.bufferModeRef PackedTag
TT.appendModeTag
read'write'mode :: Closure
read'write'mode = TermReference -> PackedTag -> Closure
Enum TermReference
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 TermReference
_ 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 = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.seekModeRef PackedTag
TT.seekAbsoluteTag
relative'seek :: Closure
relative'seek = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.seekModeRef PackedTag
TT.seekRelativeTag
seek'from'end :: Closure
seek'from'end = TermReference -> PackedTag -> Closure
Enum TermReference
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 TermReference
_ 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 = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.stdHandleRef PackedTag
TT.stdInTag
std'out :: Closure
std'out = TermReference -> PackedTag -> Closure
Enum TermReference
Ty.stdHandleRef PackedTag
TT.stdOutTag
std'err :: Closure
std'err = TermReference -> PackedTag -> Closure
Enum TermReference
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 TL.Text where
  decodeVal :: Val -> IO Text
decodeVal = (Text -> Text) -> Val -> IO Text
forall t a. BuiltinForeign t => (t -> a) -> Val -> IO a
decodeAsBuiltin Text -> Text
toLazyText
  encodeVal :: Text -> Val
encodeVal = (Text -> Text) -> Text -> Val
forall t a. BuiltinForeign t => (a -> t) -> a -> Val
encodeAsBuiltin Text -> Text
fromLazyText

  readAtIndex :: Stack -> Int -> IO Text
readAtIndex = (Text -> Text) -> Stack -> Int -> IO Text
forall t a. BuiltinForeign t => (t -> a) -> Stack -> Int -> IO a
readAsBuiltin Text -> Text
toLazyText
  writeBack :: Stack -> Text -> IO ()
writeBack = (Text -> Text) -> Stack -> Text -> IO ()
forall t a. BuiltinForeign t => (a -> t) -> Stack -> a -> IO ()
writeAsBuiltin Text -> Text
fromLazyText

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)) =
    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
$ forall a. Foreign -> a
unwrapForeign @(Seq Val) 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
. TermReference -> Seq Val -> Foreign
forall e. TermReference -> e -> Foreign
Wrap TermReference
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
. TermReference -> Seq Val -> Foreign
forall e. TermReference -> e -> Foreign
Wrap TermReference
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 TermReference (Map CTag ForeignFunc)
pseudoConstructors =
  TermReference
-> Map CTag ForeignFunc -> Map TermReference (Map CTag ForeignFunc)
forall k a. k -> a -> Map k a
Map.singleton TermReference
Ty.mapRef (Map CTag ForeignFunc -> Map TermReference (Map CTag ForeignFunc))
-> Map CTag ForeignFunc -> Map TermReference (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, Pos, ForeignFunc)]
functionReplacementList :: [(Text, Pos, ForeignFunc)]
functionReplacementList =
  [ ( Text
"03hqp8knrcgdc733mitcunjlug4cpi9headkggu8h9d87nfgneo6e",
      Pos
0,
      ForeignFunc
Map_insert
    ),
    ( Text
"03g44bb2bp3g5eld8eh07g6e8iq7oiqiplapeb6jerbs7ee3icq9s",
      Pos
0,
      ForeignFunc
Map_lookup
    ),
    ( Text
"005mc1fq7ojq72c238qlm2rspjgqo2furjodf28icruv316odu6du",
      Pos
0,
      ForeignFunc
Map_fromList
    ),
    ( Text
"01qqpul0ttlgjhr5i2gtmdr2uarns2hbtnjpipmk1575ipkrlug42",
      Pos
0,
      ForeignFunc
Map_union
    ),
    ( Text
"00c363e340il8q0fai6peiv3586o931nojj98qfek09hg1tjkm9ma",
      Pos
0,
      ForeignFunc
Map_intersect
    ),
    ( Text
"03pjq0jijrr7ebf6s3tuqi4d5hi5mrv19nagp7ql2j9ltm55c32ek",
      Pos
0,
      ForeignFunc
Map_toList
    ),
    ( Text
"03putoun7i5n0lhf8iu990u9p08laklnp668i170dka2itckmadlq",
      Pos
0,
      ForeignFunc
Multimap_fromList
    ),
    ( Text
"03q6giac0qlva6u4mja29tr7mv0jqnsugk8paibatdrns8lhqqb92",
      Pos
0,
      ForeignFunc
Set_fromList
    ),
    ( Text
"03362vaalqq28lcrmmsjhha637is312j01jme3juj980ugd93up28",
      Pos
0,
      ForeignFunc
Set_union
    ),
    ( Text
"01lm6ejo31na1ti6u85bv0klliefll7q0c0da2qnefvcrq1l8rlqe",
      Pos
0,
      ForeignFunc
Set_intersect
    ),
    ( Text
"01p7ot36tg62na408mnk1psve6rc7fog30gv6n7thkrv6t3na2gdm",
      Pos
0,
      ForeignFunc
Set_toList
    ),
    ( Text
"03c559iihi2vj0qps6cln48nv31ajup2srhas4pd05b9k46ds8jvk",
      Pos
0,
      ForeignFunc
Map_eq
    ),
    ( Text
"01f446li3b0j5gcnj7fa99jfqir43shs0jqu779oo0npb7v8d3v22",
      Pos
0,
      ForeignFunc
List_range
    ),
    ( Text
"00jh7o3l67okqqalho1sqgl4ei9n2sdhrpqobgkf7j390v4e938km",
      Pos
0,
      ForeignFunc
List_sort
    ),
    ( Text
"02n2eflppo81c4ako71f2ji347ljf1qoiij08q8tbid1p4k3n62k0",
      Pos
1,
      ForeignFunc
Json_toText
    ),
    ( Text
"02d659vubpd4m2cqbupec8qg3jpdfkgotpqtera3hh72bc3b9o6m6",
      Pos
0,
      ForeignFunc
Json_unconsText
    ),
    ( Text
"01pl56v6v0n2labp71cp6darcbftlj7d4h9t718mkfpj6lc905ro4",
      Pos
0,
      ForeignFunc
Json_tryUnconsText
    ),
    ( Text
"01csmdujt5ot550j9t0o1gfop4ephtssv358rkfqdo2e01knekgds",
      Pos
0,
      ForeignFunc
Avro_decodeBinary
    )
  ]

-- Built at the same time to attempt to share references.
functionReplacements, functionUnreplacements :: Map Reference Reference
(Map TermReference TermReference
functionReplacements, Map TermReference TermReference
functionUnreplacements) =
  ([(TermReference, TermReference)] -> Map TermReference TermReference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TermReference, TermReference)]
processed, [(TermReference, TermReference)] -> Map TermReference TermReference
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(TermReference, TermReference)]
 -> Map TermReference TermReference)
-> [(TermReference, TermReference)]
-> Map TermReference TermReference
forall a b. (a -> b) -> a -> b
$ (TermReference, TermReference) -> (TermReference, TermReference)
forall {b} {a}. (b, a) -> (a, b)
swap ((TermReference, TermReference) -> (TermReference, TermReference))
-> [(TermReference, TermReference)]
-> [(TermReference, TermReference)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(TermReference, TermReference)]
processed)
  where
    swap :: (b, a) -> (a, b)
swap (b
x, a
y) = (a
y, b
x)
    processed :: [(TermReference, TermReference)]
processed = (Text, Pos, ForeignFunc) -> (TermReference, TermReference)
process ((Text, Pos, ForeignFunc) -> (TermReference, TermReference))
-> [(Text, Pos, ForeignFunc)] -> [(TermReference, TermReference)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Pos, ForeignFunc)]
functionReplacementList

-- Note: using index 0 right now. Generalize if ever replacing
-- part of a mutually recursive group.
process :: (Data.Text.Text, Pos, ForeignFunc) -> (Reference, Reference)
process :: (Text, Pos, ForeignFunc) -> (TermReference, TermReference)
process (Text
str, Pos
pos, ForeignFunc
ff) = case Text -> Pos -> Maybe TermReference
derivedBase32Hex Text
str Pos
pos of
  Maybe TermReference
Nothing -> [Char] -> (TermReference, TermReference)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (TermReference, TermReference))
-> [Char] -> (TermReference, TermReference)
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not create reference for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
sname
  Just TermReference
r -> (TermReference
r, Text -> TermReference
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