{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Very partial implementation of the Python Pickle Virtual Machine
-- (protocol 2): i.e. parses pickled data into opcodes, then executes the
-- opcodes to construct a (Haskell representation of a) Python object.
module Language.Python.Pickle where

import Control.Monad.State
import Control.Monad.Writer
import qualified Data.ByteString as S
import Data.Attoparsec.ByteString hiding (parse, take)
import qualified Data.Attoparsec.ByteString as A
import Data.Attoparsec.ByteString.Char8 (decimal, double, signed)
import Data.Functor (($>), (<&>))
import Data.Int (Int32, Int64)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.List (foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Serialize.Get (getWord16le, getInt32le, getInt64le, runGet)
import Data.Serialize.IEEE754 (getFloat64be)
import Data.Serialize.Put (runPut, putByteString, putWord8, putWord16le, putWord32le, putWord64be, Put)
import qualified Data.Set as SET
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Encoding as T
import Data.Word (Word64)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (castPtr)
import Foreign.Storable (peek)
import System.IO.Unsafe (unsafePerformIO)

-- | Parse a pickled object to a list of opcodes.
parse :: S.ByteString -> Either String [OpCode]
parse :: ByteString -> Either String [OpCode]
parse = Parser [OpCode] -> ByteString -> Either String [OpCode]
forall a. Parser a -> ByteString -> Either String a
parseOnly (Parser ByteString OpCode -> Parser [OpCode]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (Parser ByteString OpCode -> Parser [OpCode])
-> Parser ByteString OpCode -> Parser [OpCode]
forall a b. (a -> b) -> a -> b
$ [Parser ByteString OpCode] -> Parser ByteString OpCode
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Parser ByteString OpCode]
opcodes)

-- | Unpickle (i.e. deserialize) a Python object. Protocols 0, 1, and 2 are
-- supported.
unpickle :: S.ByteString -> Either String Value
unpickle :: ByteString -> Either String Value
unpickle ByteString
s = do
  [OpCode]
xs <- ByteString -> Either String [OpCode]
parse ByteString
s
  [OpCode] -> Either String Value
unpickle' [OpCode]
xs

-- | Pickle (i.e. serialize) a Python object. Protocol 2 is used.
pickle :: Value -> S.ByteString
pickle :: Value -> ByteString
pickle Value
value = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  Putter ByteString
putByteString ByteString
"\128\STX"
  (OpCode -> Put) -> [OpCode] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ OpCode -> Put
serialize ([OpCode] -> Put) -> (Pickler () -> [OpCode]) -> Pickler () -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pickler () -> [OpCode]
runPickler (Pickler () -> Put) -> Pickler () -> Put
forall a b. (a -> b) -> a -> b
$ Value -> Pickler ()
pickle' Value
value
  Putter ByteString
putByteString ByteString
"."

----------------------------------------------------------------------
-- Pickle opcodes parser
----------------------------------------------------------------------

-- TODO parsing could be done with a big switch and only cereal,
-- instead of relying on attoparsec's "choice" combinator.

opcodes :: [Parser OpCode]
opcodes :: [Parser ByteString OpCode]
opcodes =
  -- true and false are in fact special cases for the int parser,
  -- It is important they are tried before int.
  [ Parser ByteString OpCode
true, Parser ByteString OpCode
false, Parser ByteString OpCode
int, Parser ByteString OpCode
binint, Parser ByteString OpCode
binint1, Parser ByteString OpCode
binint2, Parser ByteString OpCode
long, Parser ByteString OpCode
long1, Parser ByteString OpCode
long4
  , Parser ByteString OpCode
string', Parser ByteString OpCode
binstring, Parser ByteString OpCode
shortBinstring, Parser ByteString OpCode
binbytes, Parser ByteString OpCode
shortBinbytes, Parser ByteString OpCode
binbytes8, Parser ByteString OpCode
bytearray8
  , Parser ByteString OpCode
none
  , Parser ByteString OpCode
newtrue, Parser ByteString OpCode
newfalse
  , Parser ByteString OpCode
unicode, Parser ByteString OpCode
binunicode, Parser ByteString OpCode
shortBinunicode, Parser ByteString OpCode
binunicode8
  , Parser ByteString OpCode
float, Parser ByteString OpCode
binfloat
  , Parser ByteString OpCode
emptyList, Parser ByteString OpCode
append, Parser ByteString OpCode
appends, Parser ByteString OpCode
list
  , Parser ByteString OpCode
emptyTuple, Parser ByteString OpCode
tuple, Parser ByteString OpCode
tuple1, Parser ByteString OpCode
tuple2, Parser ByteString OpCode
tuple3
  , Parser ByteString OpCode
emptyDict, Parser ByteString OpCode
dict
  , Parser ByteString OpCode
setitem, Parser ByteString OpCode
setitems, Parser ByteString OpCode
emptySet, Parser ByteString OpCode
additems, Parser ByteString OpCode
frozenset
  , Parser ByteString OpCode
pop, Parser ByteString OpCode
dup, Parser ByteString OpCode
mark, Parser ByteString OpCode
popmark, Parser ByteString OpCode
stackGlobal
  , Parser ByteString OpCode
get', Parser ByteString OpCode
binget, Parser ByteString OpCode
longBinget, Parser ByteString OpCode
put', Parser ByteString OpCode
binput, Parser ByteString OpCode
longBinput, Parser ByteString OpCode
memoize
  , Parser ByteString OpCode
ext1, Parser ByteString OpCode
ext2, Parser ByteString OpCode
ext4
  , Parser ByteString OpCode
global, Parser ByteString OpCode
reduce, Parser ByteString OpCode
build, Parser ByteString OpCode
inst, Parser ByteString OpCode
obj, Parser ByteString OpCode
newobj, Parser ByteString OpCode
newobjEx, Parser ByteString OpCode
frame, Parser ByteString OpCode
nextBuffer, Parser ByteString OpCode
readonlyBuffer
  , Parser ByteString OpCode
proto, Parser ByteString OpCode
stop
  , Parser ByteString OpCode
persid, Parser ByteString OpCode
binpersid
  ]

-- Integers

int, binint, binint1, binint2, long, long1, long4 :: Parser OpCode
int :: Parser ByteString OpCode
int = ByteString -> Parser ByteString
string ByteString
"I" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
INT (Integer -> OpCode)
-> Parser ByteString Integer -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Integer
decimalInt)
binint :: Parser ByteString OpCode
binint = ByteString -> Parser ByteString
string ByteString
"J" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
BININT (Integer -> OpCode) -> (Int32 -> Integer) -> Int32 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> OpCode)
-> Parser ByteString Int32 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int32
anyInt32)
binint1 :: Parser ByteString OpCode
binint1 = ByteString -> Parser ByteString
string ByteString
"K" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
BININT1 (Integer -> OpCode) -> (Word8 -> Integer) -> Word8 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> OpCode)
-> Parser ByteString Word8 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8)
binint2 :: Parser ByteString OpCode
binint2 = ByteString -> Parser ByteString
string ByteString
"M" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
BININT2 (Integer -> OpCode)
-> Parser ByteString Integer -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Integer
uint2)
long :: Parser ByteString OpCode
long = ByteString -> Parser ByteString
string ByteString
"L" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
LONG (Integer -> OpCode)
-> Parser ByteString Integer -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Integer
decimalLong)
long1 :: Parser ByteString OpCode
long1 = ByteString -> Parser ByteString
string ByteString
"\138" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
LONG1 (Integer -> OpCode)
-> Parser ByteString Integer -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Integer
decodeLong1)
long4 :: Parser ByteString OpCode
long4 = ByteString -> Parser ByteString
string ByteString
"\139" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
LONG4 (Integer -> OpCode)
-> Parser ByteString Integer -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Integer
decodeLong4)

-- Strings

string', binstring, shortBinstring, binbytes, shortBinbytes, binbytes8, bytearray8 :: Parser OpCode
string' :: Parser ByteString OpCode
string' = ByteString -> Parser ByteString
string ByteString
"S" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ByteString -> OpCode
STRING (ByteString -> OpCode)
-> Parser ByteString -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
stringnl)
binstring :: Parser ByteString OpCode
binstring = ByteString
-> Parser ByteString Int32
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"T" Parser ByteString Int32
anyInt32 ByteString -> OpCode
BINSTRING
shortBinstring :: Parser ByteString OpCode
shortBinstring = ByteString
-> Parser ByteString Word8
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"U" Parser ByteString Word8
anyWord8 ByteString -> OpCode
SHORT_BINSTRING
binbytes :: Parser ByteString OpCode
binbytes = ByteString
-> Parser ByteString Int32
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"B" Parser ByteString Int32
anyInt32 ByteString -> OpCode
BINBYTES
shortBinbytes :: Parser ByteString OpCode
shortBinbytes = ByteString
-> Parser ByteString Word8
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"C" Parser ByteString Word8
anyWord8 ByteString -> OpCode
SHORT_BINBYTES
binbytes8 :: Parser ByteString OpCode
binbytes8 = ByteString
-> Parser Int64
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"\142" Parser Int64
anyInt64 ByteString -> OpCode
BINBYTES8
bytearray8 :: Parser ByteString OpCode
bytearray8 = ByteString
-> Parser Int64
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"\150" Parser Int64
anyInt64 ByteString -> OpCode
BYTEARRAY8


-- None

none :: Parser OpCode
none :: Parser ByteString OpCode
none = ByteString -> Parser ByteString
string ByteString
"N" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
NONE

-- Booleans

true, false, newtrue, newfalse :: Parser OpCode
true :: Parser ByteString OpCode
true = ByteString -> Parser ByteString
string ByteString
"I01" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
NEWTRUE
false :: Parser ByteString OpCode
false = ByteString -> Parser ByteString
string ByteString
"I00" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
NEWFALSE
newtrue :: Parser ByteString OpCode
newtrue = ByteString -> Parser ByteString
string ByteString
"\136" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
NEWTRUE -- same as \x88
newfalse :: Parser ByteString OpCode
newfalse = ByteString -> Parser ByteString
string ByteString
"\137" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
NEWFALSE -- same as \x89

-- Unicode strings

unicode, binunicode, shortBinunicode, binunicode8 :: Parser OpCode
unicode :: Parser ByteString OpCode
unicode = ByteString -> Parser ByteString
string ByteString
"V" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> OpCode
UNICODE (Text -> OpCode) -> (ByteString -> Text) -> ByteString -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> OpCode)
-> Parser ByteString -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
stringnl')
binunicode :: Parser ByteString OpCode
binunicode = ByteString
-> Parser ByteString Int32
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"X" Parser ByteString Int32
anyInt32 ByteString -> OpCode
BINUNICODE
shortBinunicode :: Parser ByteString OpCode
shortBinunicode = ByteString
-> Parser ByteString Word8
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"\140" Parser ByteString Word8
anyWord8 ByteString -> OpCode
SHORT_BINUNICODE
binunicode8 :: Parser ByteString OpCode
binunicode8 = ByteString
-> Parser Int64
-> (ByteString -> OpCode)
-> Parser ByteString OpCode
forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
"\138" Parser Int64
anyInt64 ByteString -> OpCode
BINUNICODE8

-- Floats

float, binfloat :: Parser OpCode
float :: Parser ByteString OpCode
float = ByteString -> Parser ByteString
string ByteString
"F" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Double -> OpCode
FLOAT (Double -> OpCode)
-> Parser ByteString Double -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Double
doubleFloat)
binfloat :: Parser ByteString OpCode
binfloat = ByteString -> Parser ByteString
string ByteString
"G" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Double -> OpCode
BINFLOAT (Double -> OpCode)
-> Parser ByteString Double -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Double
float8)

-- Lists

emptyList, append, appends, list :: Parser OpCode
emptyList :: Parser ByteString OpCode
emptyList = ByteString -> Parser ByteString
string ByteString
"]" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
EMPTY_LIST
append :: Parser ByteString OpCode
append = ByteString -> Parser ByteString
string ByteString
"a" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
APPEND
appends :: Parser ByteString OpCode
appends = ByteString -> Parser ByteString
string ByteString
"e" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
APPENDS
list :: Parser ByteString OpCode
list = ByteString -> Parser ByteString
string ByteString
"l" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
LIST

-- Tuples

emptyTuple, tuple, tuple1, tuple2, tuple3 :: Parser OpCode
emptyTuple :: Parser ByteString OpCode
emptyTuple = ByteString -> Parser ByteString
string ByteString
")" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
EMPTY_TUPLE
tuple :: Parser ByteString OpCode
tuple = ByteString -> Parser ByteString
string ByteString
"t" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
TUPLE
tuple1 :: Parser ByteString OpCode
tuple1 = ByteString -> Parser ByteString
string ByteString
"\133" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
TUPLE1 -- same as \x85
tuple2 :: Parser ByteString OpCode
tuple2 = ByteString -> Parser ByteString
string ByteString
"\134" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
TUPLE2 -- same as \x86
tuple3 :: Parser ByteString OpCode
tuple3 = ByteString -> Parser ByteString
string ByteString
"\135" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
TUPLE3 -- same as \x87

-- Dictionaries

emptyDict, dict :: Parser OpCode
emptyDict :: Parser ByteString OpCode
emptyDict = ByteString -> Parser ByteString
string ByteString
"}" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
EMPTY_DICT
dict :: Parser ByteString OpCode
dict = ByteString -> Parser ByteString
string ByteString
"d" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
DICT

-- Sets

setitem, setitems, emptySet, additems, frozenset :: Parser OpCode
setitem :: Parser ByteString OpCode
setitem = ByteString -> Parser ByteString
string ByteString
"s" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
SETITEM
setitems :: Parser ByteString OpCode
setitems = ByteString -> Parser ByteString
string ByteString
"u" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
SETITEMS
emptySet :: Parser ByteString OpCode
emptySet = ByteString -> Parser ByteString
string ByteString
"\143" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
EMPTY_SET
additems :: Parser ByteString OpCode
additems = ByteString -> Parser ByteString
string ByteString
"\144" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
ADDITEMS
frozenset :: Parser ByteString OpCode
frozenset = ByteString -> Parser ByteString
string ByteString
"\145" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
FROZENSET

-- Stack manipulation

pop, dup, mark, popmark, stackGlobal :: Parser OpCode
pop :: Parser ByteString OpCode
pop = ByteString -> Parser ByteString
string ByteString
"0" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
POP
dup :: Parser ByteString OpCode
dup = ByteString -> Parser ByteString
string ByteString
"2" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
DUP
mark :: Parser ByteString OpCode
mark = ByteString -> Parser ByteString
string ByteString
"(" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
MARK
popmark :: Parser ByteString OpCode
popmark = ByteString -> Parser ByteString
string ByteString
"1" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
POP_MARK
stackGlobal :: Parser ByteString OpCode
stackGlobal = ByteString -> Parser ByteString
string ByteString
"\147" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
STACK_GLOBAL

-- Memo manipulation

get', binget, longBinget, put', binput, longBinput, memoize :: Parser OpCode
get' :: Parser ByteString OpCode
get' = ByteString -> Parser ByteString
string ByteString
"g" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> OpCode
GET (Int -> OpCode)
-> Parser ByteString Int -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString Int -> Parser ByteString Int
forall a. Num a => Parser a -> Parser a
signed Parser ByteString Int
forall a. Integral a => Parser a
decimal Parser ByteString Int -> Parser ByteString -> Parser ByteString Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
string ByteString
"\n"))
binget :: Parser ByteString OpCode
binget = ByteString -> Parser ByteString
string ByteString
"h" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> OpCode
BINGET (Int -> OpCode) -> (Word8 -> Int) -> Word8 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> OpCode)
-> Parser ByteString Word8 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8)
longBinget :: Parser ByteString OpCode
longBinget = ByteString -> Parser ByteString
string ByteString
"j" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
LONG_BINGET (Integer -> OpCode) -> (Int32 -> Integer) -> Int32 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> OpCode)
-> Parser ByteString Int32 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int32
anyInt32)
put' :: Parser ByteString OpCode
put' = ByteString -> Parser ByteString
string ByteString
"p" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> OpCode
PUT (Int -> OpCode)
-> Parser ByteString Int -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString Int -> Parser ByteString Int
forall a. Num a => Parser a -> Parser a
signed Parser ByteString Int
forall a. Integral a => Parser a
decimal Parser ByteString Int -> Parser ByteString -> Parser ByteString Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
string ByteString
"\n"))
binput :: Parser ByteString OpCode
binput = ByteString -> Parser ByteString
string ByteString
"q" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> OpCode
BINPUT (Int -> OpCode) -> (Word8 -> Int) -> Word8 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> OpCode)
-> Parser ByteString Word8 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8)
longBinput :: Parser ByteString OpCode
longBinput = ByteString -> Parser ByteString
string ByteString
"r" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> OpCode
LONG_BINPUT (Integer -> OpCode) -> (Int32 -> Integer) -> Int32 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> OpCode)
-> Parser ByteString Int32 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int32
anyInt32)
memoize :: Parser ByteString OpCode
memoize = ByteString -> Parser ByteString
string ByteString
"\148" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
MEMOIZE

-- Extension registry (predefined objects)

ext1, ext2, ext4 :: Parser OpCode
ext1 :: Parser ByteString OpCode
ext1 = ByteString -> Parser ByteString
string ByteString
"\130" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> OpCode
EXT1 (Int -> OpCode) -> (Word8 -> Int) -> Word8 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> OpCode)
-> Parser ByteString Word8 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8)
ext2 :: Parser ByteString OpCode
ext2 = ByteString -> Parser ByteString
string ByteString
"\131" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> OpCode
EXT2 (Int -> OpCode) -> (Integer -> Int) -> Integer -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> OpCode)
-> Parser ByteString Integer -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Integer
uint2)
ext4 :: Parser ByteString OpCode
ext4 = ByteString -> Parser ByteString
string ByteString
"\132" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> OpCode
EXT4 (Int -> OpCode) -> (Int32 -> Int) -> Int32 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> OpCode)
-> Parser ByteString Int32 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int32
anyInt32)

-- Various

global, reduce, build, inst, obj, newobj, newobjEx, frame, nextBuffer, readonlyBuffer :: Parser OpCode
global :: Parser ByteString OpCode
global = ByteString -> Parser ByteString
string ByteString
"c" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ByteString -> ByteString -> OpCode
GLOBAL (ByteString -> ByteString -> OpCode)
-> Parser ByteString -> Parser ByteString (ByteString -> OpCode)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
stringnl' Parser ByteString (ByteString -> OpCode)
-> Parser ByteString -> Parser ByteString OpCode
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString
stringnl')
reduce :: Parser ByteString OpCode
reduce = ByteString -> Parser ByteString
string ByteString
"R" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
REDUCE
build :: Parser ByteString OpCode
build = ByteString -> Parser ByteString
string ByteString
"b" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
BUILD
inst :: Parser ByteString OpCode
inst = ByteString -> Parser ByteString
string ByteString
"i" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((ByteString -> ByteString -> OpCode)
-> (ByteString, ByteString) -> OpCode
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> OpCode
INST ((ByteString, ByteString) -> OpCode)
-> Parser ByteString (ByteString, ByteString)
-> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (ByteString, ByteString)
forall a. HasCallStack => a
undefined)
obj :: Parser ByteString OpCode
obj = ByteString -> Parser ByteString
string ByteString
"o" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
OBJ
newobj :: Parser ByteString OpCode
newobj = ByteString -> Parser ByteString
string ByteString
"\129" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
NEWOBJ -- same as \x81
newobjEx :: Parser ByteString OpCode
newobjEx = ByteString -> Parser ByteString
string ByteString
"\146" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
NEWOBJ_EX
frame :: Parser ByteString OpCode
frame = ByteString -> Parser ByteString
string ByteString
"\149" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int64 -> OpCode
FRAME (Int64 -> OpCode) -> Parser Int64 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int64
anyInt64)
nextBuffer :: Parser ByteString OpCode
nextBuffer = ByteString -> Parser ByteString
string ByteString
"\151" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
NEXT_BUFFER
readonlyBuffer :: Parser ByteString OpCode
readonlyBuffer = ByteString -> Parser ByteString
string ByteString
"\152" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
READONLY_BUFFER

-- Machine control

proto, stop :: Parser OpCode
proto :: Parser ByteString OpCode
proto = ByteString -> Parser ByteString
string ByteString
"\128" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Int -> OpCode
PROTO (Int -> OpCode) -> (Word8 -> Int) -> Word8 -> OpCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> OpCode)
-> Parser ByteString Word8 -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8)
stop :: Parser ByteString OpCode
stop = ByteString -> Parser ByteString
string ByteString
"." Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
STOP

-- Persistent IDs

persid, binpersid :: Parser OpCode
persid :: Parser ByteString OpCode
persid = ByteString -> Parser ByteString
string ByteString
"P" Parser ByteString
-> Parser ByteString OpCode -> Parser ByteString OpCode
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ByteString -> OpCode
PERSID (ByteString -> OpCode)
-> Parser ByteString -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
stringnl')
binpersid :: Parser ByteString OpCode
binpersid = ByteString -> Parser ByteString
string ByteString
"Q" Parser ByteString -> OpCode -> Parser ByteString OpCode
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> OpCode
BINPERSID

-- Basic parsers

readSizedVal :: (Integral i) => S.ByteString -> Parser i -> (S.ByteString -> r) -> Parser r
readSizedVal :: forall i r.
Integral i =>
ByteString -> Parser i -> (ByteString -> r) -> Parser r
readSizedVal ByteString
opcode Parser i
sizeParser ByteString -> r
constructor = do
  ByteString
_ <- ByteString -> Parser ByteString
string ByteString
opcode
  Int
i <- i -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (i -> Int) -> Parser i -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser i
sizeParser
  ByteString
s <- Int -> Parser ByteString
A.take Int
i
  r -> Parser r
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Parser r) -> r -> Parser r
forall a b. (a -> b) -> a -> b
$ ByteString -> r
constructor ByteString
s

decimalInt :: Parser Integer
decimalInt :: Parser ByteString Integer
decimalInt = Parser ByteString Integer -> Parser ByteString Integer
forall a. Num a => Parser a -> Parser a
signed Parser ByteString Integer
forall a. Integral a => Parser a
decimal Parser ByteString Integer
-> Parser ByteString -> Parser ByteString Integer
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
string ByteString
"\n"

-- TODO document the differences with Python's representation.
doubleFloat :: Parser Double
doubleFloat :: Parser ByteString Double
doubleFloat = Parser ByteString Double
double Parser ByteString Double
-> Parser ByteString -> Parser ByteString Double
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
string ByteString
"\n"

decimalLong :: Parser Integer
decimalLong :: Parser ByteString Integer
decimalLong = Parser ByteString Integer -> Parser ByteString Integer
forall a. Num a => Parser a -> Parser a
signed Parser ByteString Integer
forall a. Integral a => Parser a
decimal Parser ByteString Integer
-> Parser ByteString -> Parser ByteString Integer
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
string ByteString
"L\n"

decodeLong1 :: Parser Integer
decodeLong1 :: Parser ByteString Integer
decodeLong1 = do
  Int
n <- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> Parser ByteString Word8 -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Word8
anyWord8
  if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then Int -> Parser ByteString
A.take Int
n Parser ByteString
-> (ByteString -> Integer) -> Parser ByteString Integer
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> Integer
byteStringLEToInteger
    else Integer -> Parser ByteString Integer
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0

decodeLong4 :: Parser Integer
decodeLong4 :: Parser ByteString Integer
decodeLong4 = do
  Int
n <- Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Parser ByteString Int32 -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int32
anyInt32
  if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    then Int -> Parser ByteString
A.take Int
n Parser ByteString
-> (ByteString -> Integer) -> Parser ByteString Integer
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> Integer
byteStringLEToInteger
    else Integer -> Parser ByteString Integer
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0

byteStringLEToInteger :: S.ByteString -> Integer
byteStringLEToInteger :: ByteString -> Integer
byteStringLEToInteger ByteString
bs = if HasCallStack => ByteString -> Word8
ByteString -> Word8
S.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
127 then Integer -> Integer
forall a. Num a => a -> a
negate (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
256 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ ByteString -> Int
S.length ByteString
bs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
res else Integer
res
    where res :: Integer
res = (Integer, Integer) -> Integer
forall a b. (a, b) -> a
fst ((Integer, Integer) -> Integer)
-> (((Integer, Integer), ByteString) -> (Integer, Integer))
-> ((Integer, Integer), ByteString)
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer, Integer), ByteString) -> (Integer, Integer)
forall a b. (a, b) -> a
fst (((Integer, Integer), ByteString) -> Integer)
-> ((Integer, Integer), ByteString) -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> ((Integer, Integer), ByteString)
toLong ByteString
bs
          toLong :: S.ByteString -> ((Integer, Integer), S.ByteString)
          toLong :: ByteString -> ((Integer, Integer), ByteString)
toLong = ((Integer, Integer) -> Word8 -> ((Integer, Integer), Word8))
-> (Integer, Integer)
-> ByteString
-> ((Integer, Integer), ByteString)
forall acc.
(acc -> Word8 -> (acc, Word8))
-> acc -> ByteString -> (acc, ByteString)
S.mapAccumL (\(Integer
a, Integer
b) Word8
w -> ((Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
256 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
b Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w, Integer
b Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1), Word8
w)) (Integer
0, Integer
0)

stringnl :: Parser S.ByteString
stringnl :: Parser ByteString
stringnl = [Parser ByteString] -> Parser ByteString
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
  [ ByteString -> Parser ByteString
string ByteString
"'" Parser ByteString -> Parser ByteString -> Parser ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString
takeTill (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
39) Parser ByteString -> Parser ByteString -> Parser ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
string ByteString
"'\n"
  ]

stringnl' :: Parser S.ByteString
stringnl' :: Parser ByteString
stringnl' = (Word8 -> Bool) -> Parser ByteString
takeTill (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
==Word8
10) Parser ByteString -> Parser ByteString -> Parser ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString
string ByteString
"\n"


float8 :: Parser Double
float8 :: Parser ByteString Double
float8 = do
  Either String Double
w <- Get Double -> ByteString -> Either String Double
forall a. Get a -> ByteString -> Either String a
runGet Get Double
getFloat64be (ByteString -> Either String Double)
-> Parser ByteString -> Parser ByteString (Either String Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
A.take Int
8
  case Either String Double
w of
    Left String
err -> String -> Parser ByteString Double
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right Double
x -> Double -> Parser ByteString Double
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
x

anyInt32 :: Parser Int32
anyInt32 :: Parser ByteString Int32
anyInt32 = do
  Either String Int32
w <- Get Int32 -> ByteString -> Either String Int32
forall a. Get a -> ByteString -> Either String a
runGet Get Int32
getInt32le (ByteString -> Either String Int32)
-> Parser ByteString -> Parser ByteString (Either String Int32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
A.take Int
4
  case Either String Int32
w of
    Left String
err -> String -> Parser ByteString Int32
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right Int32
x -> Int32 -> Parser ByteString Int32
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
x

anyInt64 :: Parser Int64
anyInt64 :: Parser Int64
anyInt64 = do
  Either String Int64
w <- Get Int64 -> ByteString -> Either String Int64
forall a. Get a -> ByteString -> Either String a
runGet Get Int64
getInt64le (ByteString -> Either String Int64)
-> Parser ByteString -> Parser ByteString (Either String Int64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
A.take Int
8
  case Either String Int64
w of
    Left String
err -> String -> Parser Int64
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right Int64
x -> Int64 -> Parser Int64
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
x


uint2 :: Parser Integer
uint2 :: Parser ByteString Integer
uint2 = do
  Either String Word16
w <- Get Word16 -> ByteString -> Either String Word16
forall a. Get a -> ByteString -> Either String a
runGet Get Word16
getWord16le (ByteString -> Either String Word16)
-> Parser ByteString -> Parser ByteString (Either String Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
A.take Int
2
  case Either String Word16
w of
    Left String
err -> String -> Parser ByteString Integer
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
    Right Word16
x -> Integer -> Parser ByteString Integer
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Parser ByteString Integer)
-> Integer -> Parser ByteString Integer
forall a b. (a -> b) -> a -> b
$ Word16 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x

----------------------------------------------------------------------
-- Pickle opcodes serialization
----------------------------------------------------------------------

serialize :: OpCode -> Put
serialize :: OpCode -> Put
serialize OpCode
opcode = case OpCode
opcode of
  BINGET Int
i -> Putter ByteString
putByteString ByteString
"h" Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Word8
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
  BINPUT Int
i -> Putter ByteString
putByteString ByteString
"q" Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Word8
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
  BININT Integer
i -> Putter ByteString
putByteString ByteString
"J" Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Word32
putWord32le (Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
  BININT1 Integer
i -> Putter ByteString
putByteString ByteString
"K" Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Putter Word8
putWord8 (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
  BININT2 Integer
i -> Putter ByteString
putByteString ByteString
"M" Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Integer -> Put
putUint2 Integer
i
  OpCode
NONE -> Putter ByteString
putByteString ByteString
"N"
  OpCode
NEWTRUE -> Putter ByteString
putByteString ByteString
"\136"
  OpCode
NEWFALSE -> Putter ByteString
putByteString ByteString
"\137"
  LONG1 Integer
0 -> Putter ByteString
putByteString ByteString
"\138\NUL"
  LONG1 Integer
i -> Putter ByteString
putByteString ByteString
"\138" Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Integer -> Put
encodeLong1 Integer
i
  BINFLOAT Double
d -> Putter ByteString
putByteString ByteString
"G" Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Put
putFloat8 Double
d
  SHORT_BINSTRING ByteString
s -> do
    Putter ByteString
putByteString ByteString
"U"
    Putter Word8
putWord8 Putter Word8 -> (Int -> Word8) -> Int -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
s
    Putter ByteString
putByteString ByteString
s
  BINUNICODE ByteString
s -> do
    Putter ByteString
putByteString ByteString
"X"
    Putter Word32
putWord32le Putter Word32 -> (Int -> Word32) -> Int -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
s
    Putter ByteString
putByteString ByteString
s
  OpCode
EMPTY_DICT -> Putter ByteString
putByteString ByteString
"}"
  OpCode
EMPTY_LIST -> Putter ByteString
putByteString ByteString
"]"
  OpCode
EMPTY_TUPLE -> Putter ByteString
putByteString ByteString
")"
  OpCode
TUPLE -> Putter ByteString
putByteString ByteString
"t"
  OpCode
TUPLE1 -> Putter ByteString
putByteString ByteString
"\133"
  OpCode
TUPLE2 -> Putter ByteString
putByteString ByteString
"\134"
  OpCode
TUPLE3 -> Putter ByteString
putByteString ByteString
"\135"
  OpCode
MARK -> Putter ByteString
putByteString ByteString
"("
  OpCode
SETITEM -> Putter ByteString
putByteString ByteString
"s"
  OpCode
SETITEMS -> Putter ByteString
putByteString ByteString
"u"
  OpCode
APPEND -> Putter ByteString
putByteString ByteString
"a"
  OpCode
APPENDS -> Putter ByteString
putByteString ByteString
"e"
  OpCode
x -> String -> Put
forall a. HasCallStack => String -> a
error (String -> Put) -> String -> Put
forall a b. (a -> b) -> a -> b
$ String
"serialize: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ OpCode -> String
forall a. Show a => a -> String
show OpCode
x

putFloat8 :: Double -> Put
putFloat8 :: Double -> Put
putFloat8 Double
d = Putter Word64
putWord64be (Double -> Word64
coerce Double
d)
    where
    coerce :: Double -> Word64
    coerce :: Double -> Word64
coerce Double
x = IO Word64 -> Word64
forall a. IO a -> a
unsafePerformIO (IO Word64 -> Word64) -> IO Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ Double -> (Ptr Double -> IO Word64) -> IO Word64
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with Double
x ((Ptr Double -> IO Word64) -> IO Word64)
-> (Ptr Double -> IO Word64) -> IO Word64
forall a b. (a -> b) -> a -> b
$ \Ptr Double
p ->
      Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek (Ptr Double -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Double
p) :: IO Word64

putUint2 :: Integer -> Put
putUint2 :: Integer -> Put
putUint2 Integer
d = Putter Word16
putWord16le (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
d)

encodeLong1 :: Integer -> Put
encodeLong1 :: Integer -> Put
encodeLong1 Integer
i = do
  -- TODO is it possible to know xs length without really constructing xs?
  let xs :: [Word8]
xs = Integer -> [Word8]
forall {t} {a}. (Integral t, Num a) => t -> [a]
f (Integer -> [Word8]) -> Integer -> [Word8]
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
abs Integer
i
      f :: t -> [a]
f t
j | t
j t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
256 = [t -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
j]
          | Bool
otherwise = let (t
n, t
r) = t
j t -> t -> (t, t)
forall a. Integral a => a -> a -> (a, a)
`divMod` t
256 in t -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral t
r a -> [a] -> [a]
forall a. a -> [a] -> [a]
: t -> [a]
f t
n
      e :: Integer
e = Integer
256 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs
  if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
    then do
      if Integer -> Integer
forall a. Num a => a -> a
abs Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
e Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2
        then do
          Putter Word8
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          Putter Word8 -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Putter Word8
putWord8 ([Word8] -> Put) -> [Word8] -> Put
forall a b. (a -> b) -> a -> b
$ Integer -> [Word8]
forall {t} {a}. (Integral t, Num a) => t -> [a]
f (Integer
e Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
i)
          Putter Word8
putWord8 Word8
255
        else do
          Putter Word8
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs)
          Putter Word8 -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Putter Word8
putWord8 ([Word8] -> Put) -> [Word8] -> Put
forall a b. (a -> b) -> a -> b
$ Integer -> [Word8]
forall {t} {a}. (Integral t, Num a) => t -> [a]
f (Integer
e Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
i)
    else
      if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
e Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
        then do
          Putter Word8
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          Putter Word8 -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Putter Word8
putWord8 [Word8]
xs
          Putter Word8
putWord8 Word8
0
        else do
          Putter Word8
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ [Word8] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs)
          Putter Word8 -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Putter Word8
putWord8 [Word8]
xs

----------------------------------------------------------------------
-- Pickle opcodes
----------------------------------------------------------------------

data OpCode =
  -- Integers
    INT Integer
  | BININT Integer
  | BININT1 Integer
  | BININT2 Integer
  | LONG Integer
  | LONG1 Integer
  | LONG4 Integer

  -- Strings
  | STRING S.ByteString
  | BINSTRING S.ByteString
  | SHORT_BINSTRING S.ByteString
  | BINBYTES S.ByteString
  | SHORT_BINBYTES S.ByteString
  | BINBYTES8 S.ByteString
  | BYTEARRAY8 S.ByteString

  -- Out-of-band buffer
  | NEXT_BUFFER
  | READONLY_BUFFER

  -- None
  | NONE

  -- Booleans
  | NEWTRUE
  | NEWFALSE

  -- Unicode strings
  | UNICODE T.Text
  | BINUNICODE S.ByteString
  | SHORT_BINUNICODE S.ByteString
  | BINUNICODE8 S.ByteString

  -- Floats
  | FLOAT Double
  | BINFLOAT Double

  -- Lists
  | EMPTY_LIST
  | APPEND
  | APPENDS
  | LIST

  -- Tuples
  | EMPTY_TUPLE
  | TUPLE
  | TUPLE1
  | TUPLE2
  | TUPLE3

  -- Dictionaries
  | EMPTY_DICT
  | DICT
  | SETITEM
  | SETITEMS

  -- Sets
  | EMPTY_SET
  | ADDITEMS

  -- Frozen sets
  | FROZENSET

  -- Stack manipulation
  | POP
  | DUP
  | MARK
  | POP_MARK

  -- Memo manipulation
  | GET Int
  | BINGET Int
  | LONG_BINGET Integer
  | PUT Int
  | BINPUT Int
  | LONG_BINPUT Integer
  | MEMOIZE

  -- Extension registry (predefined objects)
  | EXT1 Int
  | EXT2 Int
  | EXT4 Int

  -- Various
  | GLOBAL S.ByteString S.ByteString
  | STACK_GLOBAL

  | REDUCE
  | BUILD
  | INST S.ByteString S.ByteString
  | OBJ
  | NEWOBJ
  | NEWOBJ_EX

  -- Pickle machine control
  | PROTO Int -- in [2..255]
  | STOP

  -- Persistent IDs
  | FRAME Int64
  | PERSID S.ByteString
  | BINPERSID
  deriving Int -> OpCode -> String -> String
[OpCode] -> String -> String
OpCode -> String
(Int -> OpCode -> String -> String)
-> (OpCode -> String)
-> ([OpCode] -> String -> String)
-> Show OpCode
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> OpCode -> String -> String
showsPrec :: Int -> OpCode -> String -> String
$cshow :: OpCode -> String
show :: OpCode -> String
$cshowList :: [OpCode] -> String -> String
showList :: [OpCode] -> String -> String
Show

{-
protocol0 = [INT, LONG, STRING, NONE, UNICODE, FLOAT, APPEND, LIST, TUPLE,
  DICT, SETITEM, POP, DUP, MARK, GET, PUT, GLOBAL, REDUCE, BUILD, INST, STOP,
  PERSID]
protocol1 = [BININT, BININT1, BININT2, BINSTRING, SHORT_BINSTRING, BINUNICODE,
  BINFLOAT, EMPTY_LIST, APPENDS, EMPTY_TUPLE, EMPTY_DICT, SETITEMS, POP_MARK,
  BINGET, LONG_BINGET, BINPUT, LONG_BINPUT, OBJ, BINPERSID]
protocol2 = [LONG1, LONG4, NEWTRUE, NEWFALSE, TUPLE1, TUPLE2, TUPLE3, EXT1,
  EXT2, EXT4, NEWOBJ, PROTO]
protocol3 = [BINBYTES, SHORT_BINBYTES]
protocol4 = [SHORT_BINUNICODE, BINUNICODE8, BINBYTES8, EMPTY_SET, ADDITEMS,
  FROZENSET, NEWOBJ_EX, STACK_GLOBAL, MEMOIZE, FRAME]
protocol5 = [BYTEARRAY8, NEXT_BUFFER, READONLY_BUFFER]
-}

----------------------------------------------------------------------
-- Pyhon value representation
----------------------------------------------------------------------

-- Maybe I can call them Py? And Have IsString/Num instances?
data Value =
    Dict [(Value,Value)]
  | List [Value]
  | Tuple [Value]
  | Set (SET.Set Value)
  | FrozenSet (SET.Set Value)
  | None
  | Bool Bool
  | BinInt Integer
  | BinLong Integer
  | BinFloat Double
  | BinString S.ByteString
  | BinUnicode S.ByteString
  | ClassObject S.ByteString S.ByteString
  | ObjectInstance
  | MarkObject -- Urk, not really a value.
  deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, Eq Value
Eq Value =>
(Value -> Value -> Ordering)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Value)
-> (Value -> Value -> Value)
-> Ord Value
Value -> Value -> Bool
Value -> Value -> Ordering
Value -> Value -> Value
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Value -> Value -> Ordering
compare :: Value -> Value -> Ordering
$c< :: Value -> Value -> Bool
< :: Value -> Value -> Bool
$c<= :: Value -> Value -> Bool
<= :: Value -> Value -> Bool
$c> :: Value -> Value -> Bool
> :: Value -> Value -> Bool
$c>= :: Value -> Value -> Bool
>= :: Value -> Value -> Bool
$cmax :: Value -> Value -> Value
max :: Value -> Value -> Value
$cmin :: Value -> Value -> Value
min :: Value -> Value -> Value
Ord, Int -> Value -> String -> String
Stack -> String -> String
Value -> String
(Int -> Value -> String -> String)
-> (Value -> String) -> (Stack -> String -> String) -> Show Value
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Value -> String -> String
showsPrec :: Int -> Value -> String -> String
$cshow :: Value -> String
show :: Value -> String
$cshowList :: Stack -> String -> String
showList :: Stack -> String -> String
Show)

----------------------------------------------------------------------
-- Pickle machine (opcodes to value)
----------------------------------------------------------------------

unpickle' :: [OpCode] -> Either String Value
unpickle' :: [OpCode] -> Either String Value
unpickle' [OpCode]
xs = [OpCode] -> Stack -> Memo -> Either String Value
execute [OpCode]
xs [] Memo
forall a. IntMap a
IM.empty

type Stack = [Value]

type Memo = IntMap Value

execute :: [OpCode] -> Stack -> Memo -> Either String Value
execute :: [OpCode] -> Stack -> Memo -> Either String Value
execute [] [Value
value] Memo
_ = Value -> Either String Value
forall a b. b -> Either a b
Right Value
value
execute (OpCode
op:[OpCode]
ops) Stack
stack Memo
memo = case OpCode -> Stack -> Memo -> Either String (Stack, Memo)
executeOne OpCode
op Stack
stack Memo
memo of
  Left String
err -> String -> Either String Value
forall a b. a -> Either a b
Left String
err
  Right (Stack
stack', Memo
memo') -> [OpCode] -> Stack -> Memo -> Either String Value
execute [OpCode]
ops Stack
stack' Memo
memo'
execute [OpCode]
_ Stack
_ Memo
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"`execute` unimplemented"

executePartial :: [OpCode] -> Stack -> Memo -> (Stack, Memo, [OpCode])
executePartial :: [OpCode] -> Stack -> Memo -> (Stack, Memo, [OpCode])
executePartial [] Stack
stack Memo
memo = (Stack
stack, Memo
memo, [])
executePartial (OpCode
op:[OpCode]
ops) Stack
stack Memo
memo = case OpCode -> Stack -> Memo -> Either String (Stack, Memo)
executeOne OpCode
op Stack
stack Memo
memo of
  Left String
_ -> (Stack
stack, Memo
memo, OpCode
opOpCode -> [OpCode] -> [OpCode]
forall a. a -> [a] -> [a]
:[OpCode]
ops)
  Right (Stack
stack', Memo
memo') -> [OpCode] -> Stack -> Memo -> (Stack, Memo, [OpCode])
executePartial [OpCode]
ops Stack
stack' Memo
memo'

executeOne :: OpCode -> Stack -> Memo -> Either String (Stack, Memo)
executeOne :: OpCode -> Stack -> Memo -> Either String (Stack, Memo)
executeOne (INT Integer
i) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
BinInt Integer
iValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BININT Integer
i) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
BinInt Integer
iValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BININT1 Integer
i) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
BinInt Integer
iValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BININT2 Integer
i) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
BinInt Integer
iValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (LONG Integer
i) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
BinLong Integer
iValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (LONG1 Integer
i) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
BinLong Integer
iValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (LONG4 Integer
i) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Value
BinLong Integer
iValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne (STRING ByteString
s) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinString ByteString
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BINSTRING ByteString
s) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinString ByteString
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (SHORT_BINSTRING ByteString
s) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinString ByteString
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BINBYTES ByteString
s) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinString ByteString
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (SHORT_BINBYTES ByteString
s) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinString ByteString
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BINBYTES8 ByteString
s) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinString ByteString
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BYTEARRAY8 ByteString
s) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinString ByteString
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne OpCode
NONE Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
NoneValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne OpCode
NEWTRUE Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Bool Bool
TrueValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
NEWFALSE Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Value
Bool Bool
FalseValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne (UNICODE Text
b) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinUnicode (Text -> ByteString
encodeUtf8 Text
b)Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (SHORT_BINUNICODE ByteString
b) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinUnicode ByteString
bValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BINUNICODE ByteString
b) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinUnicode ByteString
bValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BINUNICODE8 ByteString
b) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Value
BinUnicode ByteString
bValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne (FLOAT Double
d) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Value
BinFloat Double
dValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (BINFLOAT Double
d) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Value
BinFloat Double
dValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne OpCode
EMPTY_LIST Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
List []Value -> Stack -> Stack
forall a. a -> [a] -> [a]
: Stack
stack, Memo
memo)
executeOne OpCode
APPEND Stack
stack Memo
memo = Stack -> Memo -> Either String (Stack, Memo)
executeAppend Stack
stack Memo
memo
executeOne OpCode
APPENDS Stack
stack Memo
memo = Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeAppends [] Stack
stack Memo
memo
executeOne OpCode
LIST Stack
stack Memo
memo = Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeList [] Stack
stack Memo
memo

executeOne OpCode
EMPTY_TUPLE Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
Tuple []Value -> Stack -> Stack
forall a. a -> [a] -> [a]
: Stack
stack, Memo
memo)
executeOne OpCode
TUPLE Stack
stack Memo
memo = Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeTuple [] Stack
stack Memo
memo
executeOne OpCode
TUPLE1 (Value
a:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
Tuple [Value
a]Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
TUPLE2 (Value
b:Value
a:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
Tuple [Value
a, Value
b]Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
TUPLE3 (Value
c:Value
b:Value
a:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
Tuple [Value
a, Value
b, Value
c]Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne OpCode
EMPTY_DICT Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Value, Value)] -> Value
Dict []Value -> Stack -> Stack
forall a. a -> [a] -> [a]
: Stack
stack, Memo
memo)
executeOne OpCode
DICT Stack
stack Memo
memo = [(Value, Value)] -> Stack -> Memo -> Either String (Stack, Memo)
executeDict [] Stack
stack Memo
memo
executeOne OpCode
SETITEM Stack
stack Memo
memo = Stack -> Memo -> Either String (Stack, Memo)
executeSetitem Stack
stack Memo
memo
executeOne OpCode
SETITEMS Stack
stack Memo
memo = [(Value, Value)] -> Stack -> Memo -> Either String (Stack, Memo)
executeSetitems [] Stack
stack Memo
memo

executeOne OpCode
EMPTY_SET Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Value -> Value
Set Set Value
forall a. Set a
SET.emptyValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
ADDITEMS Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack
newStack', Memo
memo)
  where (Stack
items,Stack
newStack) = (Value -> Bool) -> Stack -> (Stack, Stack)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (\case
                  (Set Set Value
_) -> Bool
False
                  Value
_       -> Bool
True) Stack
stack
        insertAll :: Set Value -> Set Value
insertAll Set Value
s = (Value -> Set Value -> Set Value)
-> Set Value -> Stack -> Set Value
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Value -> Set Value -> Set Value
forall a. Ord a => a -> Set a -> Set a
SET.insert Set Value
s Stack
items
        newStack' :: Stack
newStack' = (\case
          (Set Set Value
s:Stack
rest) -> Set Value -> Value
Set (Set Value -> Set Value
insertAll Set Value
s) Value -> Stack -> Stack
forall a. a -> [a] -> [a]
: Stack
rest
          Stack
nonSet       -> Stack
nonSet) Stack
newStack

executeOne OpCode
FROZENSET Stack
stack Memo
memo = Set Value -> Stack -> Memo -> Either String (Stack, Memo)
executeFrozenSet Set Value
forall a. Set a
SET.empty Stack
stack Memo
memo

executeOne OpCode
POP (Value
_:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack
stack, Memo
memo)
executeOne OpCode
DUP (Value
x:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
xValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Value
xValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
MARK Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
MarkObjectValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
POP_MARK (Value
MarkObject:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack
stack, Memo
memo)
executeOne OpCode
POP_MARK (Value
_:Stack
stack) Memo
memo = OpCode -> Stack -> Memo -> Either String (Stack, Memo)
executeOne OpCode
POP_MARK Stack
stack Memo
memo

executeOne (GET Int
i) Stack
stack Memo
memo = Int -> Stack -> Memo -> Either String (Stack, Memo)
executeLookup Int
i Stack
stack Memo
memo
executeOne (BINGET Int
i) Stack
stack Memo
memo = Int -> Stack -> Memo -> Either String (Stack, Memo)
executeLookup Int
i Stack
stack Memo
memo
executeOne (LONG_BINGET Integer
i) Stack
stack Memo
memo = Int -> Stack -> Memo -> Either String (Stack, Memo)
executeLookup (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i) Stack
stack Memo
memo
executeOne (PUT Int
i) (Value
s:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Int -> Value -> Memo -> Memo
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Value
s Memo
memo)
executeOne (BINPUT Int
i) (Value
s:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Int -> Value -> Memo -> Memo
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Value
s Memo
memo)
executeOne (LONG_BINPUT Integer
i) (Value
s:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Int -> Value -> Memo -> Memo
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i) Value
s Memo
memo)
executeOne OpCode
MEMOIZE (Value
s:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Int -> Value -> Memo -> Memo
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Memo -> Int
forall a. IntMap a -> Int
IM.size Memo
memo) Value
s Memo
memo)

-- EXT codes are not implemented

executeOne (GLOBAL ByteString
m ByteString
c) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString -> ByteString -> Value
ClassObject ByteString
m ByteString
c)Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
STACK_GLOBAL ((BinString ByteString
c):(BinString ByteString
m):Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString -> ByteString -> Value
ClassObject ByteString
m ByteString
c)Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
STACK_GLOBAL ((BinUnicode ByteString
c):(BinUnicode ByteString
m):Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString -> ByteString -> Value
ClassObject ByteString
m ByteString
c)Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne OpCode
REDUCE ((Tuple Stack
t):(ClassObject ByteString
moduleName ByteString
className):Stack
stack) Memo
memo =
    case ByteString
moduleName of
      ByteString
"builtins" ->
          case ByteString
className of
            ByteString
"str" ->
                case Stack
t of
                  [BinString ByteString
s] -> (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString -> Value
BinString ByteString
s)Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
                  [BinUnicode ByteString
s] -> (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ByteString -> Value
BinUnicode ByteString
s)Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
                  Stack
_ -> String -> Stack -> Memo -> Either String (Stack, Memo)
eOneErr (String
"Invalid input to str(): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Stack -> String
forall a. Show a => a -> String
show Stack
t) Stack
stack Memo
memo
            ByteString
_ -> String -> Stack -> Memo -> Either String (Stack, Memo)
eOneErr (String
"Builtin " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
className String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported.") Stack
stack Memo
memo
      ByteString
_ -> String -> Stack -> Memo -> Either String (Stack, Memo)
eOneErr (String
"Class " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
moduleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
className String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported.") Stack
stack Memo
memo
-- This returns the original object without running __setstate__. Is it better to do this than fail?
executeOne OpCode
BUILD (Value
_:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack
stack, Memo
memo)
executeOne (INST ByteString
_ ByteString
_) (Value
MarkObject:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
ObjectInstanceValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne (INST ByteString
m ByteString
c) (Value
_:Stack
stack) Memo
memo = OpCode -> Stack -> Memo -> Either String (Stack, Memo)
executeOne (ByteString -> ByteString -> OpCode
INST ByteString
m ByteString
c) Stack
stack Memo
memo
executeOne OpCode
OBJ (Value
MarkObject:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
ObjectInstanceValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
OBJ (Value
_:Stack
stack) Memo
memo = OpCode -> Stack -> Memo -> Either String (Stack, Memo)
executeOne OpCode
OBJ Stack
stack Memo
memo
executeOne OpCode
NEWOBJ (Value
_:Value
_:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
ObjectInstanceValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
NEWOBJ_EX (Value
_:Value
_:Value
_:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
ObjectInstanceValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeOne (PROTO Int
_) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack
stack, Memo
memo)
executeOne OpCode
STOP Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack
stack, Memo
memo)

executeOne (FRAME Int64
_) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack
stack, Memo
memo)
executeOne (PERSID ByteString
_) Stack
stack Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
ObjectInstanceValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeOne OpCode
BINPERSID (Value
_:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value
ObjectInstanceValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)


executeOne OpCode
op Stack
stack Memo
memo = String -> Stack -> Memo -> Either String (Stack, Memo)
eOneErr (String
"Can't execute opcode " String -> String -> String
forall a. [a] -> [a] -> [a]
++ OpCode -> String
forall a. Show a => a -> String
show OpCode
op) Stack
stack Memo
memo

eOneErr :: String -> Stack -> Memo -> Either String (Stack, Memo)
eOneErr :: String -> Stack -> Memo -> Either String (Stack, Memo)
eOneErr String
e Stack
stack Memo
memo = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left (String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". stack: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Stack -> String
forall a. Show a => a -> String
show Stack
stack String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", memo: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Memo -> String
forall a. Show a => a -> String
show Memo
memo String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")

executeLookup :: Int -> Stack -> Memo -> Either String (Stack, Memo)
executeLookup :: Int -> Stack -> Memo -> Either String (Stack, Memo)
executeLookup Int
k Stack
stack Memo
memo = case Int -> Memo -> Maybe Value
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k Memo
memo of
  Maybe Value
Nothing -> String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Unknown memo key"
  Just Value
s -> (Stack, Memo) -> Either String (Stack, Memo)
forall a b. b -> Either a b
Right (Value
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)

executeTuple :: [Value] -> Stack -> Memo -> Either String ([Value], Memo)
executeTuple :: Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeTuple Stack
l (Value
MarkObject:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
Tuple Stack
lValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeTuple Stack
l (Value
a:Stack
stack) Memo
memo = Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeTuple (Value
a Value -> Stack -> Stack
forall a. a -> [a] -> [a]
: Stack
l) Stack
stack Memo
memo
executeTuple Stack
_ Stack
_ Memo
_ = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Empty stack in executeTuple"

executeDict :: [(Value, Value)] -> Stack -> Memo -> Either String ([Value], Memo)
executeDict :: [(Value, Value)] -> Stack -> Memo -> Either String (Stack, Memo)
executeDict [(Value, Value)]
l (Value
MarkObject:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Value, Value)]
l [(Value, Value)] -> Value -> Value
`addToDict` [(Value, Value)] -> Value
Dict []Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeDict [(Value, Value)]
l (Value
a:Value
b:Stack
stack) Memo
memo = [(Value, Value)] -> Stack -> Memo -> Either String (Stack, Memo)
executeDict ((Value
b, Value
a) (Value, Value) -> [(Value, Value)] -> [(Value, Value)]
forall a. a -> [a] -> [a]
: [(Value, Value)]
l) Stack
stack Memo
memo
executeDict [(Value, Value)]
_ Stack
_ Memo
_ = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Empty stack in executeDict"

executeList :: [Value] -> Stack -> Memo -> Either String ([Value], Memo)
executeList :: Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeList Stack
l (Value
MarkObject:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
List Stack
lValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeList Stack
l (Value
x:Stack
stack) Memo
memo = Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeList (Value
x Value -> Stack -> Stack
forall a. a -> [a] -> [a]
: Stack
l) Stack
stack Memo
memo
executeList Stack
_ Stack
_ Memo
_ = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Empty stack in executeList"

executeSetitem :: Stack -> Memo -> Either String ([Value], Memo)
executeSetitem :: Stack -> Memo -> Either String (Stack, Memo)
executeSetitem (Value
v:Value
k:Dict [(Value, Value)]
d:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Value, Value)] -> Value
Dict ([(Value, Value)]
d [(Value, Value)] -> [(Value, Value)] -> [(Value, Value)]
forall a. [a] -> [a] -> [a]
++ [(Value
k,Value
v)])Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeSetitem Stack
_ Memo
_ = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Empty stack in executeSetitem"

executeSetitems :: [(Value, Value)] -> Stack -> Memo -> Either String ([Value], Memo)
executeSetitems :: [(Value, Value)] -> Stack -> Memo -> Either String (Stack, Memo)
executeSetitems [(Value, Value)]
l (Value
MarkObject:Dict [(Value, Value)]
d:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Value, Value)] -> [(Value, Value)]
forall a. [a] -> [a]
reverse [(Value, Value)]
l [(Value, Value)] -> Value -> Value
`addToDict` [(Value, Value)] -> Value
Dict [(Value, Value)]
dValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeSetitems [(Value, Value)]
l (Value
a:Value
b:Stack
stack) Memo
memo = [(Value, Value)] -> Stack -> Memo -> Either String (Stack, Memo)
executeSetitems ((Value
b, Value
a) (Value, Value) -> [(Value, Value)] -> [(Value, Value)]
forall a. a -> [a] -> [a]
: [(Value, Value)]
l) Stack
stack Memo
memo
executeSetitems [(Value, Value)]
_ Stack
_ Memo
_ = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Empty stack in executeSetitems"

executeAppend :: Stack -> Memo -> Either String ([Value], Memo)
executeAppend :: Stack -> Memo -> Either String (Stack, Memo)
executeAppend (Value
x:List Stack
xs:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
List (Stack
xs Stack -> Stack -> Stack
forall a. [a] -> [a] -> [a]
++ [Value
x])Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeAppend Stack
_ Memo
_ = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Empty stack in executeAppend"

executeAppends :: [Value] -> Stack -> Memo -> Either String ([Value], Memo)
executeAppends :: Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeAppends Stack
l (Value
MarkObject:List Stack
xs:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Stack -> Value
List (Stack
xs Stack -> Stack -> Stack
forall a. [a] -> [a] -> [a]
++ Stack
l)Value -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeAppends Stack
l (Value
x:Stack
stack) Memo
memo = Stack -> Stack -> Memo -> Either String (Stack, Memo)
executeAppends (Value
x Value -> Stack -> Stack
forall a. a -> [a] -> [a]
: Stack
l) Stack
stack Memo
memo
executeAppends Stack
_ Stack
_ Memo
_ = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Empty stack in executeAppends"

executeFrozenSet :: SET.Set Value -> Stack -> Memo -> Either String ([Value], Memo)
executeFrozenSet :: Set Value -> Stack -> Memo -> Either String (Stack, Memo)
executeFrozenSet Set Value
s (Value
MarkObject:Stack
stack) Memo
memo = (Stack, Memo) -> Either String (Stack, Memo)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Value -> Value
FrozenSet Set Value
sValue -> Stack -> Stack
forall a. a -> [a] -> [a]
:Stack
stack, Memo
memo)
executeFrozenSet Set Value
s (Value
x:Stack
stack) Memo
memo = Set Value -> Stack -> Memo -> Either String (Stack, Memo)
executeFrozenSet (Value -> Set Value -> Set Value
forall a. Ord a => a -> Set a -> Set a
SET.insert Value
x Set Value
s) Stack
stack Memo
memo
executeFrozenSet Set Value
_ Stack
_ Memo
_ = String -> Either String (Stack, Memo)
forall a b. a -> Either a b
Left String
"Empty frozen set in executeFrozenSet"


addToDict :: [(Value, Value)] -> Value -> Value
addToDict :: [(Value, Value)] -> Value -> Value
addToDict [(Value, Value)]
l (Dict [(Value, Value)]
d) = [(Value, Value)] -> Value
Dict ([(Value, Value)] -> Value) -> [(Value, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ ([(Value, Value)] -> (Value, Value) -> [(Value, Value)])
-> [(Value, Value)] -> [(Value, Value)] -> [(Value, Value)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [(Value, Value)] -> (Value, Value) -> [(Value, Value)]
forall {a} {b}. [(a, b)] -> (a, b) -> [(a, b)]
add [(Value, Value)]
d [(Value, Value)]
l
  where add :: [(a, b)] -> (a, b) -> [(a, b)]
add [(a, b)]
d' (a
k, b
v) = (a
k,b
v)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
d'
addToDict [(Value, Value)]
_ Value
_ = String -> Value
forall a. HasCallStack => String -> a
error String
"Second argument to addToDict must be a dict"

----------------------------------------------------------------------
-- Pickling (value to opcodes)
----------------------------------------------------------------------

newtype Pickler a = Pickler { forall a.
Pickler a -> WriterT [OpCode] (StateT (Map Value Int) Identity) a
runP :: WriterT [OpCode] (State (Map Value Int)) a }
  deriving ((forall a b. (a -> b) -> Pickler a -> Pickler b)
-> (forall a b. a -> Pickler b -> Pickler a) -> Functor Pickler
forall a b. a -> Pickler b -> Pickler a
forall a b. (a -> b) -> Pickler a -> Pickler b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Pickler a -> Pickler b
fmap :: forall a b. (a -> b) -> Pickler a -> Pickler b
$c<$ :: forall a b. a -> Pickler b -> Pickler a
<$ :: forall a b. a -> Pickler b -> Pickler a
Functor, Functor Pickler
Functor Pickler =>
(forall a. a -> Pickler a)
-> (forall a b. Pickler (a -> b) -> Pickler a -> Pickler b)
-> (forall a b c.
    (a -> b -> c) -> Pickler a -> Pickler b -> Pickler c)
-> (forall a b. Pickler a -> Pickler b -> Pickler b)
-> (forall a b. Pickler a -> Pickler b -> Pickler a)
-> Applicative Pickler
forall a. a -> Pickler a
forall a b. Pickler a -> Pickler b -> Pickler a
forall a b. Pickler a -> Pickler b -> Pickler b
forall a b. Pickler (a -> b) -> Pickler a -> Pickler b
forall a b c. (a -> b -> c) -> Pickler a -> Pickler b -> Pickler c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Pickler a
pure :: forall a. a -> Pickler a
$c<*> :: forall a b. Pickler (a -> b) -> Pickler a -> Pickler b
<*> :: forall a b. Pickler (a -> b) -> Pickler a -> Pickler b
$cliftA2 :: forall a b c. (a -> b -> c) -> Pickler a -> Pickler b -> Pickler c
liftA2 :: forall a b c. (a -> b -> c) -> Pickler a -> Pickler b -> Pickler c
$c*> :: forall a b. Pickler a -> Pickler b -> Pickler b
*> :: forall a b. Pickler a -> Pickler b -> Pickler b
$c<* :: forall a b. Pickler a -> Pickler b -> Pickler a
<* :: forall a b. Pickler a -> Pickler b -> Pickler a
Applicative, Applicative Pickler
Applicative Pickler =>
(forall a b. Pickler a -> (a -> Pickler b) -> Pickler b)
-> (forall a b. Pickler a -> Pickler b -> Pickler b)
-> (forall a. a -> Pickler a)
-> Monad Pickler
forall a. a -> Pickler a
forall a b. Pickler a -> Pickler b -> Pickler b
forall a b. Pickler a -> (a -> Pickler b) -> Pickler b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Pickler a -> (a -> Pickler b) -> Pickler b
>>= :: forall a b. Pickler a -> (a -> Pickler b) -> Pickler b
$c>> :: forall a b. Pickler a -> Pickler b -> Pickler b
>> :: forall a b. Pickler a -> Pickler b -> Pickler b
$creturn :: forall a. a -> Pickler a
return :: forall a. a -> Pickler a
Monad, MonadWriter [OpCode], MonadState (Map Value Int))

runPickler :: Pickler () -> [OpCode]
runPickler :: Pickler () -> [OpCode]
runPickler Pickler ()
p = State (Map Value Int) [OpCode] -> Map Value Int -> [OpCode]
forall s a. State s a -> s -> a
evalState (WriterT [OpCode] (StateT (Map Value Int) Identity) ()
-> State (Map Value Int) [OpCode]
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (Pickler () -> WriterT [OpCode] (StateT (Map Value Int) Identity) ()
forall a.
Pickler a -> WriterT [OpCode] (StateT (Map Value Int) Identity) a
runP Pickler ()
p)) Map Value Int
forall k a. Map k a
M.empty

pickle' :: Value -> Pickler ()
pickle' :: Value -> Pickler ()
pickle' Value
value = do
  Map Value Int
m <- Pickler (Map Value Int)
forall s (m :: * -> *). MonadState s m => m s
get
  case Value -> Map Value Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Value
value Map Value Int
m of
    Just Int
k -> [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Int -> OpCode
BINGET Int
k]
    Maybe Int
Nothing -> case Value
value of
      Dict [(Value, Value)]
d -> [(Value, Value)] -> Pickler ()
pickleDict [(Value, Value)]
d
      List Stack
xs -> Stack -> Pickler ()
pickleList Stack
xs
      Tuple Stack
xs -> Stack -> Pickler ()
pickleTuple Stack
xs
      Value
None -> [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
NONE]
      Bool Bool
True -> [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
NEWTRUE]
      Bool Bool
False -> [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
NEWFALSE]
      BinInt Integer
i -> Integer -> Pickler ()
pickleBinInt Integer
i
      BinLong Integer
i -> Integer -> Pickler ()
pickleBinLong Integer
i
      BinFloat Double
d -> Double -> Pickler ()
pickleBinFloat Double
d
      BinString ByteString
s -> ByteString -> Pickler ()
pickleBinString ByteString
s
      BinUnicode ByteString
s -> ByteString -> Pickler ()
pickleBinUnicode ByteString
s
      Value
x -> String -> Pickler ()
forall a. HasCallStack => String -> a
error (String -> Pickler ()) -> String -> Pickler ()
forall a b. (a -> b) -> a -> b
$ String
"TODO: pickle " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
x

-- TODO actually lookup values in the map, reusing their key.
binput' :: Value -> Pickler ()
binput' :: Value -> Pickler ()
binput' Value
value = do
  Int
i <- (Map Value Int -> Int) -> Pickler Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Map Value Int -> Int
forall k a. Map k a -> Int
M.size
  Map Value Int
m <- Pickler (Map Value Int)
forall s (m :: * -> *). MonadState s m => m s
get
  Map Value Int -> Pickler ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Value -> Int -> Map Value Int -> Map Value Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Value
value Int
i Map Value Int
m)
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Int -> OpCode
BINPUT Int
i]

pickleDict :: [(Value,Value)] -> Pickler ()
pickleDict :: [(Value, Value)] -> Pickler ()
pickleDict [(Value, Value)]
d = do
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
EMPTY_DICT]
  Value -> Pickler ()
binput' ([(Value, Value)] -> Value
Dict [(Value, Value)]
d)

  case [(Value, Value)]
d of
    [] -> () -> Pickler ()
forall a. a -> Pickler a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(Value
k,Value
v)] -> Value -> Pickler ()
pickle' Value
k Pickler () -> Pickler () -> Pickler ()
forall a b. Pickler a -> Pickler b -> Pickler b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Value -> Pickler ()
pickle' Value
v Pickler () -> Pickler () -> Pickler ()
forall a b. Pickler a -> Pickler b -> Pickler b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
SETITEM]
    [(Value, Value)]
_ -> do
      [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
MARK]
      ((Value, Value) -> Pickler ()) -> [(Value, Value)] -> Pickler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Value
k, Value
v) -> Value -> Pickler ()
pickle' Value
k Pickler () -> Pickler () -> Pickler ()
forall a b. Pickler a -> Pickler b -> Pickler b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Value -> Pickler ()
pickle' Value
v) [(Value, Value)]
d
      [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
SETITEMS]

pickleList :: [Value] -> Pickler ()
pickleList :: Stack -> Pickler ()
pickleList Stack
xs = do
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
EMPTY_LIST]
  Value -> Pickler ()
binput' (Stack -> Value
List Stack
xs)

  case Stack
xs of
    [] -> () -> Pickler ()
forall a. a -> Pickler a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [Value
x] -> Value -> Pickler ()
pickle' Value
x Pickler () -> Pickler () -> Pickler ()
forall a b. Pickler a -> Pickler b -> Pickler b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
APPEND]
    Stack
_ -> do
      [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
MARK]
      (Value -> Pickler ()) -> Stack -> Pickler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Value -> Pickler ()
pickle' Stack
xs
      [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
APPENDS]

pickleTuple :: [Value] -> Pickler ()
pickleTuple :: Stack -> Pickler ()
pickleTuple [] = [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
EMPTY_TUPLE]
pickleTuple [Value
a] = do
  Value -> Pickler ()
pickle' Value
a
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
TUPLE1]
  Value -> Pickler ()
binput' (Stack -> Value
Tuple [Value
a])
pickleTuple [Value
a, Value
b] = do
  Value -> Pickler ()
pickle' Value
a
  Value -> Pickler ()
pickle' Value
b
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
TUPLE2]
  Value -> Pickler ()
binput' (Stack -> Value
Tuple [Value
a, Value
b])
pickleTuple [Value
a, Value
b, Value
c] = do
  Value -> Pickler ()
pickle' Value
a
  Value -> Pickler ()
pickle' Value
b
  Value -> Pickler ()
pickle' Value
c
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
TUPLE3]
  Value -> Pickler ()
binput' (Stack -> Value
Tuple [Value
a, Value
b, Value
c])
pickleTuple Stack
xs = do
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
MARK]
  (Value -> Pickler ()) -> Stack -> Pickler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Value -> Pickler ()
pickle' Stack
xs
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [OpCode
TUPLE]
  Value -> Pickler ()
binput' (Stack -> Value
Tuple Stack
xs)

pickleBinInt :: Integer -> Pickler ()
pickleBinInt :: Integer -> Pickler ()
pickleBinInt Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
256 = [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Integer -> OpCode
BININT1 Integer
i]
               | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
256 Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
65536 = [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Integer -> OpCode
BININT2 Integer
i]
               | Bool
otherwise = [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Integer -> OpCode
BININT Integer
i]

pickleBinLong :: Integer -> Pickler ()
pickleBinLong :: Integer -> Pickler ()
pickleBinLong Integer
i = [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Integer -> OpCode
LONG1 Integer
i] -- TODO LONG/LONG1/LONG4

-- TODO probably depends on the float range
pickleBinFloat :: Double -> Pickler ()
pickleBinFloat :: Double -> Pickler ()
pickleBinFloat Double
d = do
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Double -> OpCode
BINFLOAT Double
d]

-- TODO depending on the string length, it should not always be a SHORT_BINSTRING
pickleBinString :: S.ByteString -> Pickler ()
pickleBinString :: ByteString -> Pickler ()
pickleBinString ByteString
s = do
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ByteString -> OpCode
SHORT_BINSTRING ByteString
s]
  Value -> Pickler ()
binput' (ByteString -> Value
BinString ByteString
s)

pickleBinUnicode :: S.ByteString -> Pickler ()
pickleBinUnicode :: ByteString -> Pickler ()
pickleBinUnicode ByteString
s = do
  [OpCode] -> Pickler ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [ByteString -> OpCode
BINUNICODE ByteString
s]
  Value -> Pickler ()
binput' (ByteString -> Value
BinUnicode ByteString
s)

----------------------------------------------------------------------
-- Manipulate Values
----------------------------------------------------------------------

dictGet :: Value -> Value -> Either String (Maybe Value)
dictGet :: Value -> Value -> Either String (Maybe Value)
dictGet (Dict [(Value, Value)]
d) Value
v = Maybe Value -> Either String (Maybe Value)
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Value -> Either String (Maybe Value))
-> Maybe Value -> Either String (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Value -> Map Value Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Value
v ([(Value, Value)] -> Map Value Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Value, Value)]
d)
dictGet Value
_ Value
_ = String -> Either String (Maybe Value)
forall a b. a -> Either a b
Left String
"dictGet: not a dict."

dictGet' :: Value -> Value -> Either String Value
dictGet' :: Value -> Value -> Either String Value
dictGet' (Dict [(Value, Value)]
d) Value
v = case Value -> Map Value Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Value
v ([(Value, Value)] -> Map Value Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Value, Value)]
d) of
  Just Value
value -> Value -> Either String Value
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
value
  Maybe Value
Nothing -> String -> Either String Value
forall a b. a -> Either a b
Left String
"dictGet': no such key."
dictGet' Value
_ Value
_ = String -> Either String Value
forall a b. a -> Either a b
Left String
"dictGet': not a dict."

dictGetString :: Value -> S.ByteString -> Either String S.ByteString
dictGetString :: Value -> ByteString -> Either String ByteString
dictGetString (Dict [(Value, Value)]
d) ByteString
s = case Value -> Map Value Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ByteString -> Value
BinString ByteString
s) ([(Value, Value)] -> Map Value Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Value, Value)]
d) of
  Just (BinString ByteString
s') -> ByteString -> Either String ByteString
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
s'
  Maybe Value
_ -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
"dictGetString: not a dict, or no such key."
dictGetString Value
v ByteString
_ = String -> Either String ByteString
forall a. HasCallStack => String -> a
error (String
"Can only run dictGetString on a Dict, you run it on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")

----------------------------------------------------------------------
-- Convert Values to Haskell Representation
----------------------------------------------------------------------

class FromValue a where
    fromVal :: Value -> Maybe a

{-
data Value =
    Dict (Map Value Value)
  | List [Value]
  | Tuple [Value]
  | Set (SET.Set Value)
  | None
  | Bool Bool
  | BinInt Integer
  | BinLong Integer
  | BinFloat Double
  | BinString S.ByteString
  | BinUnicode S.ByteString
  | MarkObject -- Urk, not really a value.
  deriving (Eq, Ord, Show)
-}

instance FromValue Int where
    fromVal :: Value -> Maybe Int
fromVal (BinInt Integer
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
    fromVal (BinLong Integer
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
    fromVal Value
_          = Maybe Int
forall a. Maybe a
Nothing

instance FromValue Integer where
    fromVal :: Value -> Maybe Integer
fromVal (BinInt Integer
i) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
    fromVal (BinLong Integer
i) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i
    fromVal Value
_          = Maybe Integer
forall a. Maybe a
Nothing

instance FromValue S.ByteString where
    fromVal :: Value -> Maybe ByteString
fromVal (BinString ByteString
s) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s
    fromVal (BinUnicode ByteString
s) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s
    fromVal Value
_             = Maybe ByteString
forall a. Maybe a
Nothing

instance FromValue Double where
    fromVal :: Value -> Maybe Double
fromVal (BinFloat Double
d) = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
d
    fromVal Value
_            = Maybe Double
forall a. Maybe a
Nothing

instance FromValue T.Text where
    fromVal :: Value -> Maybe Text
fromVal (BinString ByteString
bs) = Text -> Maybe Text
forall a. a -> Maybe a
Just (ByteString -> Text
T.decodeUtf8 ByteString
bs)
    fromVal (BinUnicode ByteString
bs) = Text -> Maybe Text
forall a. a -> Maybe a
Just (ByteString -> Text
T.decodeUtf8 ByteString
bs)
    fromVal Value
_              = Maybe Text
forall a. Maybe a
Nothing

instance FromValue Bool where
    fromVal :: Value -> Maybe Bool
fromVal (Bool Bool
b) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
    fromVal Value
_        = Maybe Bool
forall a. Maybe a
Nothing

instance (FromValue a) => FromValue [a] where
    fromVal :: Value -> Maybe [a]
fromVal (List Stack
as)  = (Value -> Maybe a) -> Stack -> Maybe [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Stack
as
    fromVal (Tuple Stack
as) = (Value -> Maybe a) -> Stack -> Maybe [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Stack
as
    fromVal (Set Set Value
as)   = (Value -> Maybe a) -> Stack -> Maybe [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal (Set Value -> Stack
forall a. Set a -> [a]
SET.toList Set Value
as)
    fromVal Value
_          = Maybe [a]
forall a. Maybe a
Nothing

instance (FromValue a, Ord a) => FromValue (SET.Set a) where
    fromVal :: Value -> Maybe (Set a)
fromVal (Set Set Value
as) = [a] -> Set a
forall a. Ord a => [a] -> Set a
SET.fromList ([a] -> Set a) -> Maybe [a] -> Maybe (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe [a]
forall a. FromValue a => Value -> Maybe a
fromVal (Set Value -> Value
Set Set Value
as)
    fromVal Value
_        = Maybe (Set a)
forall a. Maybe a
Nothing

instance (FromValue k, FromValue v, Ord k) => FromValue (Map k v) where
    fromVal :: Value -> Maybe (Map k v)
fromVal (Dict [(Value, Value)]
m) =
        (Value -> Value -> Maybe (Map k v) -> Maybe (Map k v))
-> Maybe (Map k v) -> Map Value Value -> Maybe (Map k v)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey
            (\Value
k Value
v Maybe (Map k v)
maybeM -> k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (k -> v -> Map k v -> Map k v)
-> Maybe k -> Maybe (v -> Map k v -> Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe k
forall a. FromValue a => Value -> Maybe a
fromVal Value
k Maybe (v -> Map k v -> Map k v)
-> Maybe v -> Maybe (Map k v -> Map k v)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe v
forall a. FromValue a => Value -> Maybe a
fromVal Value
v Maybe (Map k v -> Map k v) -> Maybe (Map k v) -> Maybe (Map k v)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Map k v)
maybeM)
            (Map k v -> Maybe (Map k v)
forall a. a -> Maybe a
Just Map k v
forall k a. Map k a
M.empty) ([(Value, Value)] -> Map Value Value
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Value, Value)]
m)
    fromVal Value
_        = Maybe (Map k v)
forall a. Maybe a
Nothing

instance (FromValue a, FromValue b) =>
    FromValue (a, b) where
    fromVal :: Value -> Maybe (a, b)
fromVal (Tuple [Value
a,Value
b]) = (,) (a -> b -> (a, b)) -> Maybe a -> Maybe (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> (a, b)) -> Maybe b -> Maybe (a, b)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b
    fromVal (List [Value
a,Value
b])  = (,) (a -> b -> (a, b)) -> Maybe a -> Maybe (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> (a, b)) -> Maybe b -> Maybe (a, b)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b
    fromVal Value
_             = Maybe (a, b)
forall a. Maybe a
Nothing

instance (FromValue a, FromValue b, FromValue c) =>
    FromValue (a, b, c) where
    fromVal :: Value -> Maybe (a, b, c)
fromVal (Tuple [Value
a,Value
b,Value
c]) = (,,) (a -> b -> c -> (a, b, c))
-> Maybe a -> Maybe (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> (a, b, c)) -> Maybe b -> Maybe (c -> (a, b, c))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> (a, b, c)) -> Maybe c -> Maybe (a, b, c)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c
    fromVal (List [Value
a,Value
b,Value
c])  = (,,) (a -> b -> c -> (a, b, c))
-> Maybe a -> Maybe (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> (a, b, c)) -> Maybe b -> Maybe (c -> (a, b, c))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> (a, b, c)) -> Maybe c -> Maybe (a, b, c)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c
    fromVal Value
_             = Maybe (a, b, c)
forall a. Maybe a
Nothing

instance (FromValue a, FromValue b, FromValue c, FromValue d) =>
    FromValue (a, b, c, d) where
    fromVal :: Value -> Maybe (a, b, c, d)
fromVal (Tuple [Value
a,Value
b,Value
c,Value
d]) = (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Maybe a -> Maybe (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> d -> (a, b, c, d))
-> Maybe b -> Maybe (c -> d -> (a, b, c, d))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> d -> (a, b, c, d))
-> Maybe c -> Maybe (d -> (a, b, c, d))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c Maybe (d -> (a, b, c, d)) -> Maybe d -> Maybe (a, b, c, d)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe d
forall a. FromValue a => Value -> Maybe a
fromVal Value
d
    fromVal (List [Value
a,Value
b,Value
c,Value
d])  = (,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Maybe a -> Maybe (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> d -> (a, b, c, d))
-> Maybe b -> Maybe (c -> d -> (a, b, c, d))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> d -> (a, b, c, d))
-> Maybe c -> Maybe (d -> (a, b, c, d))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c Maybe (d -> (a, b, c, d)) -> Maybe d -> Maybe (a, b, c, d)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe d
forall a. FromValue a => Value -> Maybe a
fromVal Value
d
    fromVal Value
_             = Maybe (a, b, c, d)
forall a. Maybe a
Nothing

instance (FromValue a, FromValue b, FromValue c, FromValue d, FromValue e) =>
    FromValue (a, b, c, d, e) where
    fromVal :: Value -> Maybe (a, b, c, d, e)
fromVal (Tuple [Value
a,Value
b,Value
c,Value
d,Value
e]) = (,,,,) (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> Maybe a -> Maybe (b -> c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> d -> e -> (a, b, c, d, e))
-> Maybe b -> Maybe (c -> d -> e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> d -> e -> (a, b, c, d, e))
-> Maybe c -> Maybe (d -> e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c Maybe (d -> e -> (a, b, c, d, e))
-> Maybe d -> Maybe (e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe d
forall a. FromValue a => Value -> Maybe a
fromVal Value
d Maybe (e -> (a, b, c, d, e)) -> Maybe e -> Maybe (a, b, c, d, e)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe e
forall a. FromValue a => Value -> Maybe a
fromVal Value
e
    fromVal (List [Value
a,Value
b,Value
c,Value
d,Value
e])  = (,,,,) (a -> b -> c -> d -> e -> (a, b, c, d, e))
-> Maybe a -> Maybe (b -> c -> d -> e -> (a, b, c, d, e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> d -> e -> (a, b, c, d, e))
-> Maybe b -> Maybe (c -> d -> e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> d -> e -> (a, b, c, d, e))
-> Maybe c -> Maybe (d -> e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c Maybe (d -> e -> (a, b, c, d, e))
-> Maybe d -> Maybe (e -> (a, b, c, d, e))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe d
forall a. FromValue a => Value -> Maybe a
fromVal Value
d Maybe (e -> (a, b, c, d, e)) -> Maybe e -> Maybe (a, b, c, d, e)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe e
forall a. FromValue a => Value -> Maybe a
fromVal Value
e
    fromVal Value
_             = Maybe (a, b, c, d, e)
forall a. Maybe a
Nothing

instance (FromValue a, FromValue b, FromValue c, FromValue d, FromValue e, FromValue f) =>
    FromValue (a, b, c, d, e, f) where
    fromVal :: Value -> Maybe (a, b, c, d, e, f)
fromVal (Tuple [Value
a,Value
b,Value
c,Value
d,Value
e,Value
f]) = (,,,,,) (a -> b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe a -> Maybe (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe b -> Maybe (c -> d -> e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe c -> Maybe (d -> e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c Maybe (d -> e -> f -> (a, b, c, d, e, f))
-> Maybe d -> Maybe (e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe d
forall a. FromValue a => Value -> Maybe a
fromVal Value
d Maybe (e -> f -> (a, b, c, d, e, f))
-> Maybe e -> Maybe (f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe e
forall a. FromValue a => Value -> Maybe a
fromVal Value
e Maybe (f -> (a, b, c, d, e, f))
-> Maybe f -> Maybe (a, b, c, d, e, f)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe f
forall a. FromValue a => Value -> Maybe a
fromVal Value
f
    fromVal (List [Value
a,Value
b,Value
c,Value
d,Value
e,Value
f])  = (,,,,,) (a -> b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe a -> Maybe (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe b -> Maybe (c -> d -> e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> d -> e -> f -> (a, b, c, d, e, f))
-> Maybe c -> Maybe (d -> e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c Maybe (d -> e -> f -> (a, b, c, d, e, f))
-> Maybe d -> Maybe (e -> f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe d
forall a. FromValue a => Value -> Maybe a
fromVal Value
d Maybe (e -> f -> (a, b, c, d, e, f))
-> Maybe e -> Maybe (f -> (a, b, c, d, e, f))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe e
forall a. FromValue a => Value -> Maybe a
fromVal Value
e Maybe (f -> (a, b, c, d, e, f))
-> Maybe f -> Maybe (a, b, c, d, e, f)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe f
forall a. FromValue a => Value -> Maybe a
fromVal Value
f
    fromVal Value
_             = Maybe (a, b, c, d, e, f)
forall a. Maybe a
Nothing

instance (FromValue a, FromValue b, FromValue c, FromValue d, FromValue e, FromValue f, FromValue g) =>
    FromValue (a, b, c, d, e, f, g) where
    fromVal :: Value -> Maybe (a, b, c, d, e, f, g)
fromVal (Tuple [Value
a,Value
b,Value
c,Value
d,Value
e,Value
f,Value
g]) = (,,,,,,) (a -> b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe a
-> Maybe (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe b
-> Maybe (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe c -> Maybe (d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c Maybe (d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe d -> Maybe (e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe d
forall a. FromValue a => Value -> Maybe a
fromVal Value
d Maybe (e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe e -> Maybe (f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe e
forall a. FromValue a => Value -> Maybe a
fromVal Value
e Maybe (f -> g -> (a, b, c, d, e, f, g))
-> Maybe f -> Maybe (g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe f
forall a. FromValue a => Value -> Maybe a
fromVal Value
f Maybe (g -> (a, b, c, d, e, f, g))
-> Maybe g -> Maybe (a, b, c, d, e, f, g)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe g
forall a. FromValue a => Value -> Maybe a
fromVal Value
g
    fromVal (List [Value
a,Value
b,Value
c,Value
d,Value
e,Value
f,Value
g])  = (,,,,,,) (a -> b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe a
-> Maybe (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe a
forall a. FromValue a => Value -> Maybe a
fromVal Value
a Maybe (b -> c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe b
-> Maybe (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe b
forall a. FromValue a => Value -> Maybe a
fromVal Value
b Maybe (c -> d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe c -> Maybe (d -> e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe c
forall a. FromValue a => Value -> Maybe a
fromVal Value
c Maybe (d -> e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe d -> Maybe (e -> f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe d
forall a. FromValue a => Value -> Maybe a
fromVal Value
d Maybe (e -> f -> g -> (a, b, c, d, e, f, g))
-> Maybe e -> Maybe (f -> g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe e
forall a. FromValue a => Value -> Maybe a
fromVal Value
e Maybe (f -> g -> (a, b, c, d, e, f, g))
-> Maybe f -> Maybe (g -> (a, b, c, d, e, f, g))
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe f
forall a. FromValue a => Value -> Maybe a
fromVal Value
f Maybe (g -> (a, b, c, d, e, f, g))
-> Maybe g -> Maybe (a, b, c, d, e, f, g)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Maybe g
forall a. FromValue a => Value -> Maybe a
fromVal Value
g
    fromVal Value
_             = Maybe (a, b, c, d, e, f, g)
forall a. Maybe a
Nothing