{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiWayIf #-}

-- | Closure layouts, found by probing sample closures at startup
-- (see design.md, "Layouts"). Generated code
-- uses these as constants. If a layout isn't what the code generator
-- expects, the JIT is turned off.
module Unison.Runtime.JIT.Layout
  ( Layout (..),
    Layouts (..),
    probeLayouts,
    probeLists,
    probeTexts,
    probeBytes,
    probeNames,
    probeArrays,
    probeMurmur,
    probeCompare,
    probeEnv,
    probeRecords,
  )
where

import Control.Exception (evaluate)
import Control.Monad (foldM, forM)
import Control.Monad.Primitive (PrimState)
import Data.Atomics qualified as Atomic
import Data.Bits (shiftR, xor, (.&.), (.|.))
import Data.Digest.Murmur64 (asWord64)
import Data.IORef (newIORef)
import Data.Map.Strict qualified as M
import Data.Maybe (catMaybes, isJust)
import Data.Primitive.Array (MutableArray, arrayFromList, newArray, readArray, writeArray)
import Data.Primitive.ByteArray (byteArrayFromList, newByteArray)
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Vector qualified as V
import Data.Word (Word64, Word8)
import Foreign.Ptr (IntPtr (..), nullPtr, ptrToIntPtr)
import GHC.Exts (Any)
import GHC.Float (castDoubleToWord64)
import GHC.IORef (IORef (..))
import Text.Read (readMaybe)
import Unison.Builtin.Decls qualified as Ty (eitherRef, failureRef, optionalRef, pairRef, seqViewRef, unitRef)
import Unison.Reference (Reference)
import Unison.Runtime.ANF (PackedTag (..))
import Unison.Runtime.ANF qualified as ANF
import Unison.Runtime.ANF.MurmurHash.Untyped (hash64ValueUntyped)
import Unison.Runtime.JIT.Native.Probes (arrayInit, bytesCheck, bytesInit, bytesTest, closureInit, cmpInit, cmpTest, envInit, listCheck, listInit, listTest, murmurInit, murmurTest, nameTest, probeClosure, recordInit, textCheck, textInit, textTest)
import Unison.Runtime.JIT.Strict (Pair (..))
import Unison.Runtime.MCode (CombIx (..), FieldRef (..), GCombInfo (..), GSection (..), RecordShape (..), mkRecordShape, noNativeCell)
import Unison.Runtime.Referenced (Referenced (Plain))
import Unison.Runtime.Stack
import Unison.Runtime.TypeTags qualified as TT
import Unison.Type qualified as Ty
import Unison.Util.Bytes qualified as By
import Unison.Util.Deque qualified as Sq
import Unison.Util.EnumContainers qualified as EC
import Unison.Util.Rope qualified as Rope
import Unison.Util.Text qualified as UText
import Unsafe.Coerce (unsafeCoerce)

data Layout = Layout
  { -- | info pointer, to write into new closures of this kind
    Layout -> Int
lInfo :: !Int,
    -- | the low bits of a pointer to this constructor
    Layout -> Int
lPtrTag :: !Int,
    -- | pointer fields come first in the payload; this is how many
    Layout -> Int
lPtrs :: !Int,
    Layout -> Int
lNptrs :: !Int,
    -- | byte offset from the untagged closure address to payload word i
    Layout -> Int -> Int
lFieldOffset :: Int -> Int
  }

data Layouts = Layouts
  { -- | the data constructors with 0 to 6 fields, by field count: @DataN
    -- tag (Val u b)... ref@, with the fields' boxed halves as pointers 0 to
    -- n-1, the reference as pointer n, the tag as the first non-pointer
    -- word and the fields' unboxed halves after it. Pointer tags 3 to 5
    -- for 0 to 2 fields and 6 for 5 fields (base's Map node); 3, 4 and 6
    -- fields share tag 7 with the rest.
    Layouts -> Vector Layout
lData :: !(V.Vector Layout),
    -- | @TextC rope@, @ListC deque@ and @BytesC rope@ as (info pointer,
    -- pointer tag): one pointer each, the rope (Text is a newtype over it)
    -- or the deque; tags 1 and 2 for texts and lists, 7 for bytes
    Layouts -> Pair Int Int
lText, Layouts -> Pair Int Int
lList, Layouts -> Pair Int Int
lBytes :: !(Pair Int Int),
    -- | @DataG tag useg bseg ref@ (seven or more fields): pointers the
    -- ByteArray#, the Array# and the reference; one non-pointer, the tag;
    -- pointer tag 7
    Layouts -> Layout
lDataG :: !Layout,
    -- | @PAp (CIx ref grp w) (LamI arity fsize entry cell) useg bseg@, with
    -- CombIx and GCombInfo unpacked: pointers ref, entry, the ByteArray#,
    -- the Array#; non-pointers grp, w, arity, fsize, cell; pointer tag 7
    Layouts -> Layout
lPAp :: !Layout,
    -- | @Foreign x@: pointer tag 7, one pointer, the Foreign
    Layouts -> Int
lForeignInfo :: !Int,
    -- | @WrapIORef ref@: pointer tag 7, one pointer, the MutVar#
    Layouts -> Int
lIORefInfo :: !Int,
    -- | @WrapMutableArray arr@: pointer tag 7, one pointer, the MutableArray#
    Layouts -> Int
lMutableArrayInfo :: !Int,
    -- | the other wrappers the array and ref builtins see, as (info
    -- pointer, pointer tag): @WrapArray@, @WrapMutableByteArray@,
    -- @WrapByteArray@ (one pointer each, the unlifted array), @WrapTicket@
    -- (one pointer, the ticket's value) and @WrapPtr@ (one non-pointer, the
    -- address)
    Layouts -> Pair Int Int
lArrayWrap, Layouts -> Pair Int Int
lMutableByteArrayWrap, Layouts -> Pair Int Int
lByteArrayWrap, Layouts -> Pair Int Int
lTicketWrap, Layouts -> Pair Int Int
lPtrWrap :: !(Pair Int Int),
    -- | @Val u b@: pointer tag 1; pointer b, then non-pointer u
    Layouts -> Layout
lVal :: !Layout,
    -- | @RecordG shape vals@ with the shape and the vector unpacked: pointer
    -- tag 7; pointers the field names' Array#, the field numbers' and the
    -- slots' ByteArray#s and the values' Array#; non-pointers the shape reference, the names' offset and
    -- length, the values' offset and length ("records" in jit_internal.h)
    Layouts -> Layout
lRecord :: !Layout,
    -- | header size in bytes; payload starts after it
    Layouts -> Int
lHeaderBytes :: !Int
  }

any' :: a -> Any
any' :: forall a. a -> Any
any' = a -> Any
forall a b. a -> b
unsafeCoerce

probe :: Any -> [Any] -> [Int] -> IO (Either String Layout)
probe :: Any -> [Any] -> [Int] -> IO (Either [Char] Layout)
probe Any
sample0 [Any]
fields [Int]
planted = do
  -- Force everything here: the array must hold the evaluated objects, not
  -- thunks that produce them. (Without optimization the arguments are thunks.)
  let !sample :: Any
sample = Any
sample0
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Any] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Any]
fields) Any
sample :: IO (MutableArray (PrimState IO) Any)
  ((Int, Any) -> IO ()) -> [(Int, Any)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Int
i, Any
f0) -> let !f :: Any
f = Any
f0 in MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
i Any
f) ([Int] -> [Any] -> [(Int, Any)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Any]
fields)
  [Int]
r <- MutableArray (PrimState IO) Any -> IO [Int]
probeClosure MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
  case [Int]
r of
    (Int
info : Int
tag : Int
_ty : Int
ptrs : Int
nptrs : Int
_con : [Int]
rest) -> do
      let total :: Int
total = Int
ptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nptrs
          matches :: [Int]
matches = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
ptrs (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
total [Int]
rest)
          words :: [Int]
words = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
nptrs (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
ptrs [Int]
rest)
      -- every pointer field must be one of the objects we put there, in
      -- order, and the non-pointer words must be the values planted, in order
      if [Int]
matches [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int
1 .. Int
ptrs] Bool -> Bool -> Bool
&& [Any] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Any]
fields Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ptrs Bool -> Bool -> Bool
&& [Int]
words [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int]
planted
        then Either [Char] Layout -> IO (Either [Char] Layout)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Layout -> Either [Char] Layout
forall a b. b -> Either a b
Right (Int -> Int -> Int -> Int -> (Int -> Int) -> Layout
Layout Int
info Int
tag Int
ptrs Int
nptrs (\Int
i -> Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)))
        else Either [Char] Layout -> IO (Either [Char] Layout)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] Layout
forall a b. a -> Either a b
Left ([Char]
"probe: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
r))
    [Int]
_ -> Either [Char] Layout -> IO (Either [Char] Layout)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] Layout
forall a b. a -> Either a b
Left ([Char]
"probe: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
r))

-- | The info pointer and pointer tag of a constructor with one pointer
-- field (or, with @False@, one non-pointer field).
probeWrap :: Bool -> Any -> IO (Either String (Pair Int Int))
probeWrap :: Bool -> Any -> IO (Either [Char] (Pair Int Int))
probeWrap Bool
ptrField Any
sample0 = do
  let !sample :: Any
sample = Any
sample0
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
1 Any
sample :: IO (MutableArray (PrimState IO) Any)
  [Int]
r <- MutableArray (PrimState IO) Any -> IO [Int]
probeClosure MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
  pure $ case [Int]
r of
    (Int
info : Int
t : Int
_ty : Int
p : Int
n : [Int]
_) | (Int
p, Int
n) (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (if Bool
ptrField then (Int
1, Int
0) else (Int
0, Int
1)), Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1, Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
7 -> Pair Int Int -> Either [Char] (Pair Int Int)
forall a b. b -> Either a b
Right (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair Int
info Int
t)
    [Int]
_ -> [Char] -> Either [Char] (Pair Int Int)
forall a b. a -> Either a b
Left ([Char]
"wrapper probe: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
r)

-- | The info pointer of a constructor with the given pointer tag and one
-- pointer field.
probeInfo :: Int -> Any -> IO (Either String Int)
probeInfo :: Int -> Any -> IO (Either [Char] Int)
probeInfo Int
tag Any
sample0 = do
  let !sample :: Any
sample = Any
sample0
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
1 Any
sample :: IO (MutableArray (PrimState IO) Any)
  [Int]
r <- MutableArray (PrimState IO) Any -> IO [Int]
probeClosure MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
  pure $ case [Int]
r of
    (Int
info : Int
t : Int
_ty : Int
1 : Int
0 : [Int]
_) | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tag -> Int -> Either [Char] Int
forall a b. b -> Either a b
Right Int
info
    [Int]
_ -> [Char] -> Either [Char] Int
forall a b. a -> Either a b
Left ([Char]
"info probe: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
r)

-- | Probes the layouts the code generator relies on. Returns an
-- explanation if anything is unexpected.
probeLayouts :: IO (Either String Layouts)
probeLayouts :: IO (Either [Char] Layouts)
probeLayouts = do
  let !ref :: Reference
ref = Reference
Ty.booleanRef
      !nat :: Closure
nat = Closure
natTypeTag
      !int :: Closure
int = Closure
intTypeTag
      !flt :: Closure
flt = Closure
floatTypeTag
      !chr :: Closure
chr = Closure
charTypeTag
      !nil :: Closure
nil = Reference -> PackedTag -> Closure
Enum Reference
ref (Word64 -> PackedTag
PackedTag Word64
0)
      !one :: Closure
one = Reference -> PackedTag -> Closure
Enum Reference
ref (Word64 -> PackedTag
PackedTag Word64
1)
      -- six distinct evaluated closures for the fields' boxed halves
      objs :: [Closure]
objs = [Closure
nat, Closure
nil, Closure
flt, Closure
chr, Closure
int, Closure
one]
      !useg :: ByteArray
useg = [Int] -> ByteArray
forall a. Prim a => [a] -> ByteArray
byteArrayFromList [Int
11 :: Int, Int
12]
      !bseg :: Array Closure
bseg = [Closure] -> Array Closure
forall a. [a] -> Array a
arrayFromList [Closure
nat, Closure
nil]
  -- the data constructors by field count: field j holds (9 + j, objs !! j);
  -- the pointers are the boxed halves then the reference, the words the
  -- tag then the unboxed halves
  [Either [Char] Layout]
ds <- [Int]
-> (Int -> IO (Either [Char] Layout)) -> IO [Either [Char] Layout]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. Int
6] ((Int -> IO (Either [Char] Layout)) -> IO [Either [Char] Layout])
-> (Int -> IO (Either [Char] Layout)) -> IO [Either [Char] Layout]
forall a b. (a -> b) -> a -> b
$ \Int
k -> do
    let fields :: [Closure]
fields = Int -> [Closure] -> [Closure]
forall a. Int -> [a] -> [a]
take Int
k [Closure]
objs
        vals :: [Val]
vals = (Int -> Closure -> Val) -> [Int] -> [Closure] -> [Val]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Closure -> Val
Val [Int
9 ..] [Closure]
fields
        !c :: Closure
c = Reference -> PackedTag -> [Val] -> Closure
DataC Reference
ref (Word64 -> PackedTag
PackedTag Word64
7) [Val]
vals
    Any -> [Any] -> [Int] -> IO (Either [Char] Layout)
probe (Closure -> Any
forall a. a -> Any
any' Closure
c) ((Closure -> Any) -> [Closure] -> [Any]
forall a b. (a -> b) -> [a] -> [b]
map Closure -> Any
forall a. a -> Any
any' [Closure]
fields [Any] -> [Any] -> [Any]
forall a. [a] -> [a] -> [a]
++ [Reference -> Any
forall a. a -> Any
any' Reference
ref]) (Int
7 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
k [Int
9 ..])
  Either [Char] Layout
dg <- Int -> Int -> Int -> Any -> IO (Either [Char] Layout)
probeKind Int
7 Int
3 Int
1 (Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! Reference -> PackedTag -> [Val] -> Closure
DataC Reference
ref (Word64 -> PackedTag
PackedTag Word64
7) ((Int -> Closure -> Val) -> [Int] -> [Closure] -> [Val]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Closure -> Val
Val [Int
9 ..] ([Closure]
objs [Closure] -> [Closure] -> [Closure]
forall a. [a] -> [a] -> [a]
++ [Closure
nat])))
  let !entry :: GSection comb
entry = GSection comb
forall comb. GSection comb
Exit
      !cell :: Ptr NativeCell
cell = Ptr NativeCell
noNativeCell
      IntPtr Int
cellAddr = Ptr NativeCell -> IntPtr
forall a. Ptr a -> IntPtr
ptrToIntPtr Ptr NativeCell
cell
  Either [Char] Layout
pap <- Int -> Int -> Int -> Any -> IO (Either [Char] Layout)
probeKind Int
7 Int
4 Int
5 (Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp (Reference -> Word64 -> Word64 -> CombIx
CIx Reference
ref Word64
21 Word64
22) (Int
-> Int
-> GSection (RComb Val)
-> Ptr NativeCell
-> GCombInfo (RComb Val)
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
23 Int
24 GSection (RComb Val)
forall comb. GSection comb
entry Ptr NativeCell
cell) (ByteArray
useg, Array Closure
bseg))
  Int
_ <- Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
cellAddr
  -- a Ref: Foreign (WrapIORef ref), the IORef unpacked to its MutVar#
  IORef Val
ref' <- Val -> IO (IORef Val)
forall a. a -> IO (IORef a)
newIORef (Int -> Closure -> Val
Val Int
9 Closure
nat)
  let !w :: Foreign
w = IORef Val -> Foreign
WrapIORef IORef Val
ref'
      !fo :: Closure
fo = Foreign -> Closure
Foreign Foreign
w
  Either [Char] Int
fi <- Int -> Any -> IO (Either [Char] Int)
probeInfo Int
7 (Closure -> Any
forall a. a -> Any
any' Closure
fo)
  Either [Char] Int
wi <- Int -> Any -> IO (Either [Char] Int)
probeInfo Int
7 (Foreign -> Any
forall a. a -> Any
any' Foreign
w)
  MutableArray RealWorld Val
marr <- Int -> Val -> IO (MutableArray (PrimState IO) Val)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
1 (Int -> Closure -> Val
Val Int
9 Closure
nat) :: IO (MutableArray (PrimState IO) Val)
  let !wa :: Foreign
wa = MutableArray RealWorld Val -> Foreign
WrapMutableArray MutableArray RealWorld Val
marr
  Either [Char] Int
ai <- Int -> Any -> IO (Either [Char] Int)
probeInfo Int
7 (Foreign -> Any
forall a. a -> Any
any' Foreign
wa)
  -- the other array wrappers, a ticket and a pointer
  Either [Char] (Pair Int Int)
aw <- Bool -> Any -> IO (Either [Char] (Pair Int Int))
probeWrap Bool
True (Foreign -> Any
forall a. a -> Any
any' (Foreign -> Any) -> Foreign -> Any
forall a b. (a -> b) -> a -> b
$! Array Val -> Foreign
WrapArray ([Val] -> Array Val
forall a. [a] -> Array a
arrayFromList [Int -> Closure -> Val
Val Int
9 Closure
nat]))
  MutableByteArray RealWorld
mba <- Int -> IO (MutableByteArray (PrimState IO))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
8
  Either [Char] (Pair Int Int)
mbw <- Bool -> Any -> IO (Either [Char] (Pair Int Int))
probeWrap Bool
True (Foreign -> Any
forall a. a -> Any
any' (Foreign -> Any) -> Foreign -> Any
forall a b. (a -> b) -> a -> b
$! MutableByteArray RealWorld -> Foreign
WrapMutableByteArray MutableByteArray RealWorld
mba)
  Either [Char] (Pair Int Int)
bw <- Bool -> Any -> IO (Either [Char] (Pair Int Int))
probeWrap Bool
True (Foreign -> Any
forall a. a -> Any
any' (Foreign -> Any) -> Foreign -> Any
forall a b. (a -> b) -> a -> b
$! ByteArray -> Foreign
WrapByteArray ([Word8] -> ByteArray
forall a. Prim a => [a] -> ByteArray
byteArrayFromList [Word8
1 :: Word8, Word8
2]))
  -- a ticket is the value itself (a newtype): its wrapper's field must be the Val
  let !tv :: Val
tv = Int -> Closure -> Val
Val Int
9 Closure
nat
  IORef Val
tref <- Val -> IO (IORef Val)
forall a. a -> IO (IORef a)
newIORef Val
tv
  Ticket Val
ticket <- IORef Val -> IO (Ticket Val)
forall a. IORef a -> IO (Ticket a)
Atomic.readForCAS IORef Val
tref
  Either [Char] Layout
tw <- Any -> [Any] -> [Int] -> IO (Either [Char] Layout)
probe (Foreign -> Any
forall a. a -> Any
any' (Foreign -> Any) -> Foreign -> Any
forall a b. (a -> b) -> a -> b
$! Ticket Val -> Foreign
WrapTicket Ticket Val
ticket) [Val -> Any
forall a. a -> Any
any' Val
tv] []
  Either [Char] (Pair Int Int)
pw <- Bool -> Any -> IO (Either [Char] (Pair Int Int))
probeWrap Bool
False (Foreign -> Any
forall a. a -> Any
any' (Foreign -> Any) -> Foreign -> Any
forall a b. (a -> b) -> a -> b
$! Ptr () -> Foreign
WrapPtr Ptr ()
forall a. Ptr a
nullPtr)
  Either [Char] Layout
v <- Any -> [Any] -> [Int] -> IO (Either [Char] Layout)
probe (Val -> Any
forall a. a -> Any
any' (Val -> Any) -> Val -> Any
forall a b. (a -> b) -> a -> b
$! Int -> Closure -> Val
Val Int
9 Closure
nat) [Closure -> Any
forall a. a -> Any
any' Closure
nat] [Int
9]
  -- a text and a list: one pointer each
  Either [Char] (Pair Int Int)
tx <- Bool -> Any -> IO (Either [Char] (Pair Int Int))
probeWrap Bool
True (Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! Text -> Closure
TextC ([Char] -> Text
UText.pack [Char]
"abc"))
  Either [Char] (Pair Int Int)
li <- Bool -> Any -> IO (Either [Char] (Pair Int Int))
probeWrap Bool
True (Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! Deque Val -> Closure
ListC ([Val] -> Deque Val
forall a. [a] -> Deque a
Sq.fromList [Int -> Closure -> Val
Val Int
9 Closure
nat]))
  Either [Char] (Pair Int Int)
by <- Bool -> Any -> IO (Either [Char] (Pair Int Int))
probeWrap Bool
True (Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! Bytes -> Closure
BytesC ([Word8] -> Bytes
By.fromWord8s [Word8
1, Word8
2, Word8
3]))
  -- a record: its words are checked by unison_jit_record_init (probeRecords);
  -- here only the counts and the pointer tag
  Either [Char] Layout
rc <- Int -> Int -> Int -> Any -> IO (Either [Char] Layout)
probeKind Int
7 Int
4 Int
5 (Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! RecordShape -> RecordVals -> Closure
RecordG (Word64 -> [(Text, Word64)] -> RecordShape
recordShapeOf Word64
7 [(Text
"a", Word64
3), (Text
"bc", Word64
5)]) (Seg -> RecordVals
recordVals ([Val] -> Seg
segFromList [Word64 -> Val
NatVal Word64
9, Word64 -> Val
NatVal Word64
10])))
  -- (the order of GClosure: ListC 1, TextC 2, Enum 3, Data1 4, Data2 5, Data5 6)
  let dataOk :: Int -> Layout -> Bool
dataOk Int
k Layout
l = Layout -> Int
lPtrTag Layout
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 then Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 else if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 then Int
6 else Int
7) Bool -> Bool -> Bool
&& Layout -> Int
lPtrs Layout
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Bool -> Bool -> Bool
&& Layout -> Int
lNptrs Layout
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
  pure $ case ([Either [Char] Layout] -> Either [Char] [Layout]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Either [Char] Layout]
ds, Either [Char] Layout
dg, Either [Char] Layout
pap, Either [Char] Int
fi, Either [Char] Int
wi, Either [Char] Int
ai, Either [Char] Layout
v, Either [Char] (Pair Int Int)
aw, Either [Char] (Pair Int Int)
mbw, Either [Char] (Pair Int Int)
bw, Either [Char] Layout
tw, Either [Char] (Pair Int Int)
pw, Either [Char] Layout
rc, Either [Char] (Pair Int Int)
tx, Either [Char] (Pair Int Int)
li, Either [Char] (Pair Int Int)
by) of
    (Right [Layout]
lds, Right Layout
ldg, Right Layout
lp, Right Int
fii, Right Int
wii, Right Int
aii, Right Layout
lv, Right Pair Int Int
awi, Right Pair Int Int
mbwi, Right Pair Int Int
bwi, Right Layout
ltw, Right Pair Int Int
pwi, Right Layout
lr, Right Pair Int Int
txi, Right Pair Int Int
lii, Right Pair Int Int
byi)
      | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Int -> Layout -> Bool) -> [Int] -> [Layout] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Layout -> Bool
dataOk [Int
0 ..] [Layout]
lds),
        Layout -> Int
lPtrTag Layout
ldg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 Bool -> Bool -> Bool
&& Layout -> Int
lPtrs Layout
ldg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 Bool -> Bool -> Bool
&& Layout -> Int
lNptrs Layout
ldg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
        Layout -> Int
lPtrTag Layout
lp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 Bool -> Bool -> Bool
&& Layout -> Int
lPtrs Layout
lp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 Bool -> Bool -> Bool
&& Layout -> Int
lNptrs Layout
lp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5,
        Layout -> Int
lPtrTag Layout
lv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Layout -> Int
lPtrs Layout
lv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Layout -> Int
lNptrs Layout
lv Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
        Layout -> Int
lPtrs Layout
ltw Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Layout -> Int
lNptrs Layout
ltw Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
          Layouts -> Either [Char] Layouts
forall a b. b -> Either a b
Right (Vector Layout
-> Pair Int Int
-> Pair Int Int
-> Pair Int Int
-> Layout
-> Layout
-> Int
-> Int
-> Int
-> Pair Int Int
-> Pair Int Int
-> Pair Int Int
-> Pair Int Int
-> Pair Int Int
-> Layout
-> Layout
-> Int
-> Layouts
Layouts ([Layout] -> Vector Layout
forall a. [a] -> Vector a
V.fromList [Layout]
lds) Pair Int Int
txi Pair Int Int
lii Pair Int Int
byi Layout
ldg Layout
lp Int
fii Int
wii Int
aii Pair Int Int
awi Pair Int Int
mbwi Pair Int Int
bwi (Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair (Layout -> Int
lInfo Layout
ltw) (Layout -> Int
lPtrTag Layout
ltw)) Pair Int Int
pwi Layout
lv Layout
lr Int
8)
      | Bool
otherwise -> [Char] -> Either [Char] Layouts
forall a b. a -> Either a b
Left ([Char]
"closure layouts are not what the code generator expects: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((Layout -> [Char]) -> [Layout] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Layout -> [Char]
summary ([Layout]
lds [Layout] -> [Layout] -> [Layout]
forall a. [a] -> [a] -> [a]
++ [Layout
ldg, Layout
lp, Layout
lv, Layout
ltw])))
    (Either [Char] [Layout], Either [Char] Layout,
 Either [Char] Layout, Either [Char] Int, Either [Char] Int,
 Either [Char] Int, Either [Char] Layout,
 Either [Char] (Pair Int Int), Either [Char] (Pair Int Int),
 Either [Char] (Pair Int Int), Either [Char] Layout,
 Either [Char] (Pair Int Int), Either [Char] Layout,
 Either [Char] (Pair Int Int), Either [Char] (Pair Int Int),
 Either [Char] (Pair Int Int))
_ -> [Char] -> Either [Char] Layouts
forall a b. a -> Either a b
Left ([Char]
"closure layouts could not be probed: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show ([([Char] -> [Char])
-> (Layout -> [Char]) -> Either [Char] Layout -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> [Char]
forall a. a -> a
id ([Char] -> Layout -> [Char]
forall a b. a -> b -> a
const [Char]
"ok") Either [Char] Layout
x | Either [Char] Layout
x <- [Either [Char] Layout]
ds [Either [Char] Layout]
-> [Either [Char] Layout] -> [Either [Char] Layout]
forall a. [a] -> [a] -> [a]
++ [Either [Char] Layout
dg, Either [Char] Layout
pap, Either [Char] Layout
v, Either [Char] Layout
tw, Either [Char] Layout
rc]] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [([Char] -> [Char])
-> (Int -> [Char]) -> Either [Char] Int -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> [Char]
forall a. a -> a
id ([Char] -> Int -> [Char]
forall a b. a -> b -> a
const [Char]
"ok") Either [Char] Int
x | Either [Char] Int
x <- [Either [Char] Int
fi, Either [Char] Int
wi, Either [Char] Int
ai]] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [([Char] -> [Char])
-> (Pair Int Int -> [Char])
-> Either [Char] (Pair Int Int)
-> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> [Char]
forall a. a -> a
id ([Char] -> Pair Int Int -> [Char]
forall a b. a -> b -> a
const [Char]
"ok") Either [Char] (Pair Int Int)
x | Either [Char] (Pair Int Int)
x <- [Either [Char] (Pair Int Int)
aw, Either [Char] (Pair Int Int)
mbw, Either [Char] (Pair Int Int)
bw, Either [Char] (Pair Int Int)
pw, Either [Char] (Pair Int Int)
tx, Either [Char] (Pair Int Int)
li, Either [Char] (Pair Int Int)
by]]))

-- | The layout of a constructor with the given pointer tag and field counts.
probeKind :: Int -> Int -> Int -> Any -> IO (Either String Layout)
probeKind :: Int -> Int -> Int -> Any -> IO (Either [Char] Layout)
probeKind Int
tag Int
ptrs Int
nptrs Any
sample0 = do
  let !sample :: Any
sample = Any
sample0
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
1 Any
sample :: IO (MutableArray (PrimState IO) Any)
  [Int]
r <- MutableArray (PrimState IO) Any -> IO [Int]
probeClosure MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
  pure $ case [Int]
r of
    (Int
info : Int
t : Int
_ty : Int
p : Int
n : [Int]
_) | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
tag, Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ptrs, Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
nptrs -> Layout -> Either [Char] Layout
forall a b. b -> Either a b
Right (Int -> Int -> Int -> Int -> (Int -> Int) -> Layout
Layout Int
info Int
t Int
p Int
n (\Int
i -> Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i))
    [Int]
_ -> [Char] -> Either [Char] Layout
forall a b. a -> Either a b
Left ([Char]
"kind probe: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
r)

-- | A record shape for the probes: the reference, and the field names with
-- their numbers, which the shape keeps ascending by name.
recordShapeOf :: Word64 -> [(Text.Text, Word64)] -> RecordShape
recordShapeOf :: Word64 -> [(Text, Word64)] -> RecordShape
recordShapeOf Word64
ref [(Text, Word64)]
fields =
  let sorted :: [(Text, Word64)]
sorted = Map Text Word64 -> [(Text, Word64)]
forall k a. Map k a -> [(k, a)]
M.toAscList ([(Text, Word64)] -> Map Text Word64
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Word64)]
fields)
   in RecordRef -> Vector Text -> [FieldRef] -> RecordShape
mkRecordShape (Word64 -> RecordRef
ANF.RecordRef Word64
ref) ([Text] -> Vector Text
forall a. [a] -> Vector a
V.fromList (((Text, Word64) -> Text) -> [(Text, Word64)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Word64) -> Text
forall a b. (a, b) -> a
fst [(Text, Word64)]
sorted)) (((Text, Word64) -> FieldRef) -> [(Text, Word64)] -> [FieldRef]
forall a b. (a -> b) -> [a] -> [b]
map (Word64 -> FieldRef
FieldRef (Word64 -> FieldRef)
-> ((Text, Word64) -> Word64) -> (Text, Word64) -> FieldRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Word64) -> Word64
forall a b. (a, b) -> b
snd) [(Text, Word64)]
sorted)

-- | Records: hands the record helpers sample records (see
-- unison_jit_record_init), which checks the layout and the field lookup
-- against them, then runs records through the hash and the comparison
-- helpers against the Haskell answers.
probeRecords :: Layouts -> IO (Either String ())
probeRecords :: Layouts -> IO (Either [Char] ())
probeRecords Layouts
_ls = do
  let PackedTag Word64
someTag = PackedTag
TT.someTag
      shape2 :: RecordShape
shape2 = Word64 -> [(Text, Word64)] -> RecordShape
recordShapeOf Word64
7 [(Text
"a", Word64
3), (Text
"bc", Word64
5)]
      shape0 :: RecordShape
shape0 = Word64 -> [(Text, Word64)] -> RecordShape
recordShapeOf Word64
8 []
      shape3 :: RecordShape
shape3 = Word64 -> [(Text, Word64)] -> RecordShape
recordShapeOf Word64
9 [(Text
"x", Word64
11), (Text
"y", Word64
12), (Text
"zz", Word64
13)]
      -- the same field names, as a shape compiled elsewhere would have them
      shape3' :: RecordShape
shape3' = Word64 -> [(Text, Word64)] -> RecordShape
recordShapeOf Word64
9 [(Text
"x", Word64
11), (Text
"y", Word64
12), (Text
"zz", Word64
13)]
      -- (the pattern synonyms store tagged type-tag pointers; a let-bound
      -- natTypeTag in this unoptimized module would be an untagged CAF)
      !v0 :: Val
v0 = Word64 -> Val
NatVal Word64
9
      !v1 :: Val
v1 = Word64 -> Val
NatVal Word64
10
      -- the values through the interpreter's builder, which evaluates them
      -- (a list literal's elements are thunks in this unoptimized module)
      !r2 :: Closure
r2 = RecordShape -> RecordVals -> Closure
RecordG RecordShape
shape2 (Seg -> RecordVals
recordVals ([Val] -> Seg
segFromList [Val
v0, Val
v1]))
      !r0 :: Closure
r0 = RecordShape -> RecordVals -> Closure
RecordG RecordShape
shape0 RecordVals
forall a. Vector a
V.empty
      !r3 :: Closure
r3 = RecordShape -> RecordVals -> Closure
RecordG RecordShape
shape3 (Seg -> RecordVals
recordVals ([Val] -> Seg
segFromList [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
3]))
      -- the names are evaluated texts in a shape the emitter builds; here
      -- they are literals, thunks in an unoptimized build
      forceNames :: RecordShape -> IO ()
forceNames RecordShape
sh = (Text -> IO Text) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO Text
forall a. a -> IO a
evaluate (Vector Text -> [Text]
forall a. Vector a -> [a]
V.toList (RecordShape -> Vector Text
shapeFields RecordShape
sh))
  (RecordShape -> IO ()) -> [RecordShape] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RecordShape -> IO ()
forceNames [RecordShape
shape2, RecordShape
shape0, RecordShape
shape3, RecordShape
shape3']
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
5 (Closure -> Any
forall a. a -> Any
any' Closure
r2) :: IO (MutableArray (PrimState IO) Any)
  let put :: Int -> Any -> IO ()
put Int
i Any
v = Any -> IO Any
forall a. a -> IO a
evaluate Any
v IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
i
  Int -> Any -> IO ()
put Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
r2)
  Int -> Any -> IO ()
put Int
1 (Val -> Any
forall a. a -> Any
any' Val
v0)
  Int -> Any -> IO ()
put Int
2 (Val -> Any
forall a. a -> Any
any' Val
v1)
  Int -> Any -> IO ()
put Int
3 (Closure -> Any
forall a. a -> Any
any' Closure
r0)
  Int -> Any -> IO ()
put Int
4 (Closure -> Any
forall a. a -> Any
any' Closure
r3)
  Int
ok <- MutableArray (PrimState IO) Any -> [Int] -> IO Int
recordInit MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr [Int
3, Int
5, Int
7, Int
11, Int
12, Int
13]
  if Int
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
    then Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the record layout is not what the record helpers expect (check " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ok [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"))
    else do
      -- the hash: reflection then the Haskell hash, as probeMurmur does
      let expected :: ANF.Value Reference -> Word64
          expected :: Value Reference -> Word64
expected Value Reference
v = Hash64 -> Word64
asWord64 (Referenced Value -> Hash64
hash64ValueUntyped (Value Reference -> Referenced Value
forall (t :: * -> *). t Reference -> Referenced t
Plain Value Reference
v))
          pos :: Word64 -> Value ref
pos = BLit ref -> Value ref
forall ref. BLit ref -> Value ref
ANF.BLit (BLit ref -> Value ref)
-> (Word64 -> BLit ref) -> Word64 -> Value ref
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> BLit ref
forall ref. Word64 -> BLit ref
ANF.Pos
          recV :: [Text] -> ValList ref -> Value ref
recV [Text]
names ValList ref
vs = RecordSchema -> ValList ref -> Value ref
forall ref. RecordSchema -> ValList ref -> Value ref
ANF.Record (Set Text -> RecordSchema
ANF.RecordSchema ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
names)) ValList ref
vs
          some :: Val -> Val
some Val
v = Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.optionalRef (Word64 -> PackedTag
PackedTag Word64
someTag) Val
v)
          text :: [Char] -> Val
text [Char]
t = Closure -> Val
BoxedVal (Text -> Closure
TextC ([Char] -> Text
UText.pack [Char]
t))
          rec :: RecordShape -> [Val] -> Val
rec RecordShape
sh [Val]
vs = Closure -> Val
BoxedVal (RecordShape -> RecordVals -> Closure
RecordG RecordShape
sh (Seg -> RecordVals
recordVals ([Val] -> Seg
segFromList [Val]
vs)))
          shapeN :: RecordShape
shapeN = Word64 -> [(Text, Word64)] -> RecordShape
recordShapeOf Word64
10 [(Text
"inner", Word64
21), (Text
"name", Word64
22)]
          !rNested :: Closure
rNested = RecordShape -> RecordVals -> Closure
RecordG RecordShape
shapeN (Seg -> RecordVals
recordVals ([Val] -> Seg
segFromList [Closure -> Val
BoxedVal Closure
r3, [Char] -> Val
text [Char]
"héllo"]))
          hashes :: [(String, Closure, ANF.Value Reference)]
          hashes :: [([Char], Closure, Value Reference)]
hashes =
            [ ([Char]
"two fields", Closure
r2, [Text] -> ValList Reference -> Value Reference
forall {ref}. [Text] -> ValList ref -> Value ref
recV [Text
"a", Text
"bc"] [Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
9, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
10]),
              ([Char]
"no fields", Closure
r0, [Text] -> ValList Reference -> Value Reference
forall {ref}. [Text] -> ValList ref -> Value ref
recV [] []),
              ([Char]
"three fields", Closure
r3, [Text] -> ValList Reference -> Value Reference
forall {ref}. [Text] -> ValList ref -> Value ref
recV [Text
"x", Text
"y", Text
"zz"] [Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
1, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
2, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
3]),
              ([Char]
"nested", Closure
rNested, [Text] -> ValList Reference -> Value Reference
forall {ref}. [Text] -> ValList ref -> Value ref
recV [Text
"inner", Text
"name"] [[Text] -> ValList Reference -> Value Reference
forall {ref}. [Text] -> ValList ref -> Value ref
recV [Text
"x", Text
"y", Text
"zz"] [Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
1, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
2, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
3], BLit Reference -> Value Reference
forall ref. BLit ref -> Value ref
ANF.BLit (Text -> BLit Reference
forall ref. Text -> BLit ref
ANF.Text ([Char] -> Text
UText.pack [Char]
"héllo"))])
            ]
      RecordShape -> IO ()
forceNames RecordShape
shapeN
      MutableArray RealWorld Any
harr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
1 (Closure -> Any
forall a. a -> Any
any' Closure
r2) :: IO (MutableArray (PrimState IO) Any)
      [Maybe [Char]]
hs <- [([Char], Closure, Value Reference)]
-> (([Char], Closure, Value Reference) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], Closure, Value Reference)]
hashes ((([Char], Closure, Value Reference) -> IO (Maybe [Char]))
 -> IO [Maybe [Char]])
-> (([Char], Closure, Value Reference) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall a b. (a -> b) -> a -> b
$ \([Char]
name, Closure
c, Value Reference
v) -> do
        Any -> IO Any
forall a. a -> IO a
evaluate (Closure -> Any
forall a. a -> Any
any' Closure
c) IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
harr Int
0
        Maybe Word64
got <- MutableArray (PrimState IO) Any -> Int -> Bool -> IO (Maybe Word64)
murmurTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
harr Int
0 Bool
False
        pure (if Maybe Word64
got Maybe Word64 -> Maybe Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Value Reference -> Word64
expected Value Reference
v) then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"murmurHashUntyped of a record (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"): native " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe Word64 -> [Char]
forall a. Show a => a -> [Char]
show Maybe Word64
got [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", Haskell " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Value Reference -> Word64
expected Value Reference
v)))
      -- the comparisons, as probeCompare does
      let anyOf :: Val -> Val
anyOf Val
v = Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.anyRef PackedTag
TT.anyTag Val
v)
          both :: (Bool, Bool)
both = (Bool
True, Bool
True)
          pairs :: [(String, Val, Val, (Bool, Bool))]
          pairs :: [([Char], Val, Val, (Bool, Bool))]
pairs =
            [ ([Char]
"equal records", RecordShape -> [Val] -> Val
rec RecordShape
shape3 [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
3], RecordShape -> [Val] -> Val
rec RecordShape
shape3' [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
3], (Bool, Bool)
both),
              ([Char]
"records differing late", RecordShape -> [Val] -> Val
rec RecordShape
shape3 [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
3], RecordShape -> [Val] -> Val
rec RecordShape
shape3' [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
4], (Bool, Bool)
both),
              ([Char]
"records differing early", RecordShape -> [Val] -> Val
rec RecordShape
shape3 [Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
0, Word64 -> Val
NatVal Word64
0], RecordShape -> [Val] -> Val
rec RecordShape
shape3' [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
9, Word64 -> Val
NatVal Word64
9], (Bool, Bool)
both),
              ([Char]
"records of texts", RecordShape -> [Val] -> Val
rec RecordShape
shape2 [[Char] -> Val
text [Char]
"a", [Char] -> Val
text [Char]
"b"], RecordShape -> [Val] -> Val
rec RecordShape
shape2 [[Char] -> Val
text [Char]
"a", [Char] -> Val
text [Char]
"c"], (Bool, Bool)
both),
              ([Char]
"nested records", RecordShape -> [Val] -> Val
rec RecordShape
shape2 [Closure -> Val
BoxedVal Closure
r3, Word64 -> Val
NatVal Word64
1], RecordShape -> [Val] -> Val
rec RecordShape
shape2 [Closure -> Val
BoxedVal Closure
r3, Word64 -> Val
NatVal Word64
2], (Bool, Bool)
both),
              ([Char]
"empty records", RecordShape -> [Val] -> Val
rec RecordShape
shape0 [], RecordShape -> [Val] -> Val
rec RecordShape
shape0 [], (Bool, Bool)
both),
              ([Char]
"record against data", RecordShape -> [Val] -> Val
rec RecordShape
shape0 [], Val -> Val
some (Word64 -> Val
NatVal Word64
1), (Bool, Bool)
both),
              ([Char]
"record against text", RecordShape -> [Val] -> Val
rec RecordShape
shape0 [], [Char] -> Val
text [Char]
"a", (Bool, Bool)
both),
              ([Char]
"Any records of the same shape", Val -> Val
anyOf (RecordShape -> [Val] -> Val
rec RecordShape
shape2 [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2]), Val -> Val
anyOf (RecordShape -> [Val] -> Val
rec RecordShape
shape2 [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
3]), (Bool, Bool)
both),
              -- different shapes order by their field names: the interpreter's
              ([Char]
"Any records of different shapes", Val -> Val
anyOf (RecordShape -> [Val] -> Val
rec RecordShape
shape2 [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2]), Val -> Val
anyOf (RecordShape -> [Val] -> Val
rec RecordShape
shape3 [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
3]), (Bool
False, Bool
True))
            ]
      MutableArray RealWorld Any
carr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
2 (Closure -> Any
forall a. a -> Any
any' Closure
r2) :: IO (MutableArray (PrimState IO) Any)
      let toInt :: a -> Int
toInt a
o = a -> Int
forall a. Enum a => a -> Int
fromEnum a
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      [Maybe [Char]]
cs <- [([Char], Val, Val, (Bool, Bool))]
-> (([Char], Val, Val, (Bool, Bool)) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], Val, Val, (Bool, Bool))]
pairs ((([Char], Val, Val, (Bool, Bool)) -> IO (Maybe [Char]))
 -> IO [Maybe [Char]])
-> (([Char], Val, Val, (Bool, Bool)) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall a b. (a -> b) -> a -> b
$ \([Char]
name, Val
l, Val
r, (Bool
handledC, Bool
handledE)) -> do
        Any -> IO Any
forall a. a -> IO a
evaluate (Closure -> Any
forall a. a -> Any
any' (Val -> Closure
getBoxedVal Val
l)) IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
carr Int
0
        Any -> IO Any
forall a. a -> IO a
evaluate (Closure -> Any
forall a. a -> Any
any' (Val -> Closure
getBoxedVal Val
r)) IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
carr Int
1
        Maybe Int
gotC <- MutableArray (PrimState IO) Any
-> Int -> Int -> Bool -> IO (Maybe Int)
cmpTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
carr (Val -> Int
getUnboxedVal Val
l) (Val -> Int
getUnboxedVal Val
r) Bool
False
        Maybe Int
gotE <- MutableArray (PrimState IO) Any
-> Int -> Int -> Bool -> IO (Maybe Int)
cmpTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
carr (Val -> Int
getUnboxedVal Val
l) (Val -> Int
getUnboxedVal Val
r) Bool
True
        let wantC :: Int
wantC = Ordering -> Int
forall a. Enum a => a -> Int
toInt (Val -> Val -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Val
l Val
r)
            wantE :: Int
wantE = Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Val
l Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
r)
            okC :: Bool
okC = if Bool
handledC then Maybe Int
gotC Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
wantC else Maybe Int
gotC Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing
            okE :: Bool
okE = if Bool
handledE then Maybe Int
gotE Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
wantE else Maybe Int
gotE Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing
        pure $
          if Bool
okC Bool -> Bool -> Bool
&& Bool
okE
            then Maybe [Char]
forall a. Maybe a
Nothing
            else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Universal comparison of records (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"): native " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Maybe Int, Maybe Int) -> [Char]
forall a. Show a => a -> [Char]
show (Maybe Int
gotC, Maybe Int
gotE) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", Haskell " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
wantC, Int
wantE) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Bool
handledC Bool -> Bool -> Bool
&& Bool
handledE then [Char]
"" else [Char]
" (expected to be left to the interpreter)"))
      pure $ case [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]]
hs [Maybe [Char]] -> [Maybe [Char]] -> [Maybe [Char]]
forall a. [a] -> [a] -> [a]
++ [Maybe [Char]]
cs) of
        [] -> () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
        [Char]
e : [[Char]]
_ -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e

-- | Teaches the C array and ref helpers the wrappers' info pointers and
-- tags, and the runtime's empty value (what @Scope.array@ fills with).
probeArrays :: Layouts -> IO (Either String ())
probeArrays :: Layouts -> IO (Either [Char] ())
probeArrays Layouts
ls = do
  let !e :: Val
e = Val
emptyVal
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
1 (Val -> Any
forall a. a -> Any
any' Val
e) :: IO (MutableArray (PrimState IO) Any)
  let pair :: Pair a a -> [a]
pair (Pair a
i a
t) = [a
i, a
t]
  Int
ok <- MutableArray (PrimState IO) Any -> [Int] -> IO Int
arrayInit MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr ((Pair Int Int -> [Int]) -> [Pair Int Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Pair Int Int -> [Int]
forall {a}. Pair a a -> [a]
pair [Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair (Layouts -> Int
lMutableArrayInfo Layouts
ls) Int
7, Layouts -> Pair Int Int
lArrayWrap Layouts
ls, Layouts -> Pair Int Int
lMutableByteArrayWrap Layouts
ls, Layouts -> Pair Int Int
lByteArrayWrap Layouts
ls, Int -> Int -> Pair Int Int
forall a b. a -> b -> Pair a b
Pair (Layouts -> Int
lIORefInfo Layouts
ls) Int
7, Layouts -> Pair Int Int
lTicketWrap Layouts
ls, Layouts -> Pair Int Int
lPtrWrap Layouts
ls])
  pure (if Int
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then () -> Either [Char] ()
forall a b. b -> Either a b
Right () else [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"the array helpers could not be initialized")

summary :: Layout -> String
summary :: Layout -> [Char]
summary Layout
l = (Int, Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Layout -> Int
lPtrTag Layout
l, Layout -> Int
lPtrs Layout
l, Layout -> Int
lNptrs Layout
l)

-- | Teaches the hash helper the closures it needs to recognize and checks
-- it against the Haskell hash (reflection then 'hash64ValueUntyped') on
-- sample values of every kind it handles.
probeMurmur :: Layouts -> IO (Either String ())
probeMurmur :: Layouts -> IO (Either [Char] ())
probeMurmur Layouts
ls = do
  let !nat :: Closure
nat = Closure
natTypeTag
      !int :: Closure
int = Closure
intTypeTag
      !flt :: Closure
flt = Closure
floatTypeTag
      !chr :: Closure
chr = Closure
charTypeTag
      PackedTag Word64
someTag = PackedTag
TT.someTag
      PackedTag Word64
noneTag = PackedTag
TT.noneTag
      PackedTag Word64
pairTag = PackedTag
TT.pairTag
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
1 (Closure -> Any
forall a. a -> Any
any' Closure
nat) :: IO (MutableArray (PrimState IO) Any)
  let put :: Any -> IO ()
      put :: Any -> IO ()
put Any
v = Any -> IO Any
forall a. a -> IO a
evaluate Any
v IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0
  Any -> IO ()
put (Closure -> Any
forall a. a -> Any
any' Closure
nat)
  Int
ok <- MutableArray (PrimState IO) Any -> [Int] -> IO Int
murmurInit MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr ((Layout -> Int) -> [Layout] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Layout -> Int
lInfo (Vector Layout -> [Layout]
forall a. Vector a -> [a]
V.toList (Layouts -> Vector Layout
lData Layouts
ls)) [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Layout -> Int
lInfo (Layouts -> Layout
lDataG Layouts
ls)])
  if Int
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
    then Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"the murmur hash helper could not be initialized")
    else do
      let expected :: ANF.Value Reference -> Word64
          expected :: Value Reference -> Word64
expected Value Reference
v = Hash64 -> Word64
asWord64 (Referenced Value -> Hash64
hash64ValueUntyped (Value Reference -> Referenced Value
forall (t :: * -> *). t Reference -> Referenced t
Plain Value Reference
v))
          pos :: Word64 -> Value ref
pos = BLit ref -> Value ref
forall ref. BLit ref -> Value ref
ANF.BLit (BLit ref -> Value ref)
-> (Word64 -> BLit ref) -> Word64 -> Value ref
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> BLit ref
forall ref. Word64 -> BLit ref
ANF.Pos
          dat :: ref -> Word64 -> ValList ref -> Value ref
dat ref
r Word64
t ValList ref
vs = ref -> Word64 -> ValList ref -> Value ref
forall ref. ref -> Word64 -> ValList ref -> Value ref
ANF.Data ref
r (PackedTag -> Word64
TT.maskTags (Word64 -> PackedTag
PackedTag Word64
t)) ValList ref
vs
          some :: Value Reference -> Value Reference
some Value Reference
v = Reference -> Word64 -> ValList Reference -> Value Reference
forall ref. ref -> Word64 -> ValList ref -> Value ref
dat Reference
Ty.optionalRef Word64
someTag [Value Reference
v]
          none :: Value Reference
none = Reference -> Word64 -> ValList Reference -> Value Reference
forall ref. ref -> Word64 -> ValList ref -> Value ref
dat Reference
Ty.optionalRef Word64
noneTag []
          pair :: Value Reference -> Value Reference -> Value Reference
pair Value Reference
a Value Reference
b = Reference -> Word64 -> ValList Reference -> Value Reference
forall ref. ref -> Word64 -> ValList ref -> Value ref
dat Reference
Ty.pairRef Word64
pairTag [Value Reference
a, Reference -> Word64 -> ValList Reference -> Value Reference
forall ref. ref -> Word64 -> ValList ref -> Value ref
dat Reference
Ty.pairRef Word64
pairTag [Value Reference
b, Reference -> Word64 -> ValList Reference -> Value Reference
forall ref. ref -> Word64 -> ValList ref -> Value ref
dat Reference
Ty.unitRef Word64
0 []]]
          text :: [Char] -> Value ref
text [Char]
t = BLit ref -> Value ref
forall ref. BLit ref -> Value ref
ANF.BLit (Text -> BLit ref
forall ref. Text -> BLit ref
ANF.Text ([Char] -> Text
UText.pack [Char]
t))
          bytes :: [Word8] -> Value ref
bytes [Word8]
bs = BLit ref -> Value ref
forall ref. BLit ref -> Value ref
ANF.BLit (Bytes -> BLit ref
forall ref. Bytes -> BLit ref
ANF.Bytes ([Word8] -> Bytes
By.fromWord8s [Word8]
bs))
          list :: [Value ref] -> Value ref
list [Value ref]
vs = BLit ref -> Value ref
forall ref. BLit ref -> Value ref
ANF.BLit (Seq (Value ref) -> BLit ref
forall ref. Seq (Value ref) -> BLit ref
ANF.List ([Value ref] -> Seq (Value ref)
forall a. [a] -> Seq a
Seq.fromList [Value ref]
vs))
          !unit :: Closure
unit = Reference -> PackedTag -> Closure
Enum Reference
Ty.unitRef (Word64 -> PackedTag
PackedTag Word64
0)
          !noneC :: Closure
noneC = Reference -> PackedTag -> Closure
Enum Reference
Ty.optionalRef (Word64 -> PackedTag
PackedTag Word64
noneTag)
          someC :: Val -> Closure
someC Val
v = Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.optionalRef (Word64 -> PackedTag
PackedTag Word64
someTag) Val
v
          pairC :: Val -> Val -> Closure
pairC Val
a Val
b = Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
pairTag) Val
a (Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
pairTag) Val
b (Closure -> Val
BoxedVal Closure
unit)))
          !useg :: ByteArray
useg = [Int] -> ByteArray
forall a. Prim a => [a] -> ByteArray
byteArrayFromList [Int
3 :: Int, Int
2, Int
1]
          !bseg :: Array Closure
bseg = [Closure] -> Array Closure
forall a. [a] -> Array a
arrayFromList [Closure
nat, Closure
nat, Closure
nat]
          -- a three-field constructor: the segments hold the fields in reverse
          !dg :: Closure
dg = Reference -> PackedTag -> Seg -> Closure
DataG Reference
Ty.failureRef (Word64 -> PackedTag
PackedTag Word64
5) (ByteArray
useg, Array Closure
bseg)
          dgV :: Value Reference
dgV = Reference -> Word64 -> ValList Reference -> Value Reference
forall ref. ref -> Word64 -> ValList ref -> Value ref
dat Reference
Ty.failureRef Word64
5 [Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
1, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
2, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
3]
          textC :: [Char] -> Closure
textC [Char]
t = Text -> Closure
TextC ([Char] -> Text
UText.pack [Char]
t)
          bytesC :: [Word8] -> Closure
bytesC [Word8]
bs = Bytes -> Closure
BytesC ([Word8] -> Bytes
By.fromWord8s [Word8]
bs)
          listC :: [Val] -> Closure
listC [Val]
vs = Deque Val -> Closure
ListC ([Val] -> Deque Val
forall a. [a] -> Deque a
Sq.fromList [Val]
vs)
          boxed :: [(String, Closure, ANF.Value Reference)]
          boxed :: [([Char], Closure, Value Reference)]
boxed =
            [ ([Char]
"None", Closure
noneC, Value Reference
none),
              ([Char]
"Some 7", Val -> Closure
someC (Word64 -> Val
NatVal Word64
7), Value Reference -> Value Reference
some (Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
7)),
              ([Char]
"Some (-3)", Val -> Closure
someC (Int -> Val
IntVal (-Int
3)), Value Reference -> Value Reference
some (BLit Reference -> Value Reference
forall ref. BLit ref -> Value ref
ANF.BLit (Word64 -> BLit Reference
forall ref. Word64 -> BLit ref
ANF.Neg Word64
3))),
              ([Char]
"Some +3", Val -> Closure
someC (Int -> Val
IntVal Int
3), Value Reference -> Value Reference
some (Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
3)),
              ([Char]
"Some 1.5", Val -> Closure
someC (Double -> Val
DoubleVal Double
1.5), Value Reference -> Value Reference
some (BLit Reference -> Value Reference
forall ref. BLit ref -> Value ref
ANF.BLit (Double -> BLit Reference
forall ref. Double -> BLit ref
ANF.Float Double
1.5))),
              ([Char]
"Some 'x'", Val -> Closure
someC (Char -> Val
CharVal Char
'x'), Value Reference -> Value Reference
some (BLit Reference -> Value Reference
forall ref. BLit ref -> Value ref
ANF.BLit (Char -> BLit Reference
forall ref. Char -> BLit ref
ANF.Char Char
'x'))),
              ([Char]
"pair", Val -> Val -> Closure
pairC (Word64 -> Val
NatVal Word64
1) (Word64 -> Val
NatVal Word64
2), Value Reference -> Value Reference -> Value Reference
pair (Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
1) (Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
2)),
              ([Char]
"DataG", Closure
dg, Value Reference
dgV),
              ([Char]
"text", [Char] -> Closure
textC [Char]
"héllo wörld ✓", [Char] -> Value Reference
forall {ref}. [Char] -> Value ref
text [Char]
"héllo wörld ✓"),
              ([Char]
"empty text", [Char] -> Closure
textC [Char]
"", [Char] -> Value Reference
forall {ref}. [Char] -> Value ref
text [Char]
""),
              ([Char]
"bytes", [Word8] -> Closure
bytesC [Word8
1, Word8
2, Word8
255], [Word8] -> Value Reference
forall {ref}. [Word8] -> Value ref
bytes [Word8
1, Word8
2, Word8
255]),
              ([Char]
"list", [Val] -> Closure
listC [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Closure -> Val
BoxedVal (Val -> Closure
someC (Word64 -> Val
NatVal Word64
3))], ValList Reference -> Value Reference
forall {ref}. [Value ref] -> Value ref
list [Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
1, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
2, Value Reference -> Value Reference
some (Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
3)]),
              ([Char]
"empty list", [Val] -> Closure
listC [], ValList Reference -> Value Reference
forall {ref}. [Value ref] -> Value ref
list []),
              ([Char]
"long list", [Val] -> Closure
listC ((Word64 -> Val) -> [Word64] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Val
NatVal [Word64
1 .. Word64
500]), ValList Reference -> Value Reference
forall {ref}. [Value ref] -> Value ref
list ((Word64 -> Value Reference) -> [Word64] -> ValList Reference
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos [Word64
1 .. Word64
500])),
              ([Char]
"nested", Val -> Closure
someC (Closure -> Val
BoxedVal ([Val] -> Closure
listC [Closure -> Val
BoxedVal ([Char] -> Closure
textC [Char]
"a"), Closure -> Val
BoxedVal Closure
noneC])), Value Reference -> Value Reference
some (ValList Reference -> Value Reference
forall {ref}. [Value ref] -> Value ref
list [[Char] -> Value Reference
forall {ref}. [Char] -> Value ref
text [Char]
"a", Value Reference
none]))
            ]
          unboxed :: [(String, Int, Closure, ANF.Value Reference)]
          unboxed :: [([Char], Int, Closure, Value Reference)]
unboxed =
            [ ([Char]
"Nat 5", Int
5, Closure
nat, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
5),
              ([Char]
"Nat max", -Int
1, Closure
nat, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
forall a. Bounded a => a
maxBound),
              ([Char]
"Int -1", -Int
1, Closure
int, BLit Reference -> Value Reference
forall ref. BLit ref -> Value ref
ANF.BLit (Word64 -> BLit Reference
forall ref. Word64 -> BLit ref
ANF.Neg Word64
1)),
              ([Char]
"Int 9", Int
9, Closure
int, Word64 -> Value Reference
forall {ref}. Word64 -> Value ref
pos Word64
9),
              ([Char]
"Float 2.5", Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Word64
castDoubleToWord64 Double
2.5), Closure
flt, BLit Reference -> Value Reference
forall ref. BLit ref -> Value ref
ANF.BLit (Double -> BLit Reference
forall ref. Double -> BLit ref
ANF.Float Double
2.5)),
              ([Char]
"Char 'é'", Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'é', Closure
chr, BLit Reference -> Value Reference
forall ref. BLit ref -> Value ref
ANF.BLit (Char -> BLit Reference
forall ref. Char -> BLit ref
ANF.Char Char
'é'))
            ]
          check :: [Char] -> Maybe a -> a -> f (Maybe [Char])
check [Char]
name Maybe a
got a
want
            | Maybe a
got Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Maybe a
forall a. a -> Maybe a
Just a
want = Maybe [Char] -> f (Maybe [Char])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
            | Bool
otherwise = Maybe [Char] -> f (Maybe [Char])
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"murmurHashUntyped of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": native " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe a -> [Char]
forall a. Show a => a -> [Char]
show Maybe a
got [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", Haskell " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
want))
      [Maybe [Char]]
rs <- [([Char], Closure, Value Reference)]
-> (([Char], Closure, Value Reference) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], Closure, Value Reference)]
boxed ((([Char], Closure, Value Reference) -> IO (Maybe [Char]))
 -> IO [Maybe [Char]])
-> (([Char], Closure, Value Reference) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall a b. (a -> b) -> a -> b
$ \([Char]
name, Closure
c, Value Reference
v) -> do
        Any -> IO ()
put (Closure -> Any
forall a. a -> Any
any' Closure
c)
        Maybe Word64
got <- MutableArray (PrimState IO) Any -> Int -> Bool -> IO (Maybe Word64)
murmurTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 Bool
False
        [Char] -> Maybe Word64 -> Word64 -> IO (Maybe [Char])
forall {a} {f :: * -> *}.
(Eq a, Applicative f, Show a) =>
[Char] -> Maybe a -> a -> f (Maybe [Char])
check [Char]
name Maybe Word64
got (Value Reference -> Word64
expected Value Reference
v)
      [Maybe [Char]]
rs2 <- [([Char], Int, Closure, Value Reference)]
-> (([Char], Int, Closure, Value Reference) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], Int, Closure, Value Reference)]
unboxed ((([Char], Int, Closure, Value Reference) -> IO (Maybe [Char]))
 -> IO [Maybe [Char]])
-> (([Char], Int, Closure, Value Reference) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall a b. (a -> b) -> a -> b
$ \([Char]
name, Int
u, Closure
t, Value Reference
v) -> do
        Any -> IO ()
put (Closure -> Any
forall a. a -> Any
any' Closure
t)
        Maybe Word64
got <- MutableArray (PrimState IO) Any -> Int -> Bool -> IO (Maybe Word64)
murmurTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
u Bool
True
        [Char] -> Maybe Word64 -> Word64 -> IO (Maybe [Char])
forall {a} {f :: * -> *}.
(Eq a, Applicative f, Show a) =>
[Char] -> Maybe a -> a -> f (Maybe [Char])
check [Char]
name Maybe Word64
got (Value Reference -> Word64
expected Value Reference
v)
      pure $ case [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]]
rs [Maybe [Char]] -> [Maybe [Char]] -> [Maybe [Char]]
forall a. [a] -> [a] -> [a]
++ [Maybe [Char]]
rs2) of
        [] -> () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
        [Char]
e : [[Char]]
_ -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e

-- | Universal equality and ordering: hands the comparison helpers what
-- they need beyond the other tables (see unison_jit_cmp_init), then runs
-- pairs of every kind of value through the C copies and the interpreter's
-- @Eq Val@ and @Ord Val@; any difference, or a pair the helper should
-- handle and doesn't, turns the JIT off.
probeCompare :: Layouts -> IO (Either String ())
probeCompare :: Layouts -> IO (Either [Char] ())
probeCompare Layouts
ls = do
  let PackedTag Word64
intTag = PackedTag
TT.intTag
      PackedTag Word64
natTag = PackedTag
TT.natTag
  Int
ok <- [Int] -> IO Int
cmpInit [Layout -> Int
lInfo (Layouts -> Layout
lPAp Layouts
ls), Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
intTag, Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
natTag, Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PackedTag -> Word64
TT.typeTag PackedTag
TT.anyTag)]
  if Int
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
    then Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"the comparison helpers could not be initialized")
    else do
      let PackedTag Word64
someTag = PackedTag
TT.someTag
          PackedTag Word64
noneTag = PackedTag
TT.noneTag
          PackedTag Word64
pairTag = PackedTag
TT.pairTag
          !unit :: Val
unit = Closure -> Val
BoxedVal (Reference -> PackedTag -> Closure
Enum Reference
Ty.unitRef (Word64 -> PackedTag
PackedTag Word64
0))
          !none :: Val
none = Closure -> Val
BoxedVal (Reference -> PackedTag -> Closure
Enum Reference
Ty.optionalRef (Word64 -> PackedTag
PackedTag Word64
noneTag))
          some :: Val -> Val
some Val
v = Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.optionalRef (Word64 -> PackedTag
PackedTag Word64
someTag) Val
v)
          pair :: Val -> Val -> Val
pair Val
a Val
b = Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
pairTag) Val
a (Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
pairTag) Val
b Val
unit)))
          -- a three-field constructor: the segments hold the fields in reverse
          !nat :: Closure
nat = Closure
natTypeTag
          -- the fields are (word, evaluated tag closure) pairs: a thunk in the array is "not handled"
          dg :: [Int] -> Val
          dg :: [Int] -> Val
dg [Int]
us = let !u :: ByteArray
u = [Int] -> ByteArray
forall a. Prim a => [a] -> ByteArray
byteArrayFromList ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
us); !b :: Array Closure
b = [Closure] -> Array Closure
forall a. [a] -> Array a
arrayFromList (Int -> Closure -> [Closure]
forall a. Int -> a -> [a]
replicate ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
us) Closure
nat) in Closure -> Val
BoxedVal (Reference -> PackedTag -> Seg -> Closure
DataG Reference
Ty.failureRef (Word64 -> PackedTag
PackedTag Word64
5) (ByteArray
u, Array Closure
b))
          anyOf :: Val -> Val
anyOf Val
v = Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.anyRef PackedTag
TT.anyTag Val
v)
          text :: [Char] -> Val
text [Char]
t = Closure -> Val
BoxedVal (Text -> Closure
TextC ([Char] -> Text
UText.pack [Char]
t))
          bytes :: [Word8] -> Val
bytes [Word8]
bs = Closure -> Val
BoxedVal (Bytes -> Closure
BytesC ([Word8] -> Bytes
By.fromWord8s [Word8]
bs))
          list :: [Val] -> Val
list [Val]
vs = Closure -> Val
BoxedVal (Deque Val -> Closure
ListC ([Val] -> Deque Val
forall a. [a] -> Deque a
Sq.fromList [Val]
vs))
          -- an array's elements are lazy: evaluate them first, as the runtime's arrays hold values
          array :: [Val] -> IO Val
          array :: [Val] -> IO Val
array [Val]
vs = (Val -> IO Val) -> [Val] -> IO [Val]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Val -> IO Val
forall a. a -> IO a
evaluate [Val]
vs IO [Val] -> ([Val] -> IO Val) -> IO Val
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Val]
vs' -> Val -> IO Val
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Closure -> Val
BoxedVal (Foreign -> Closure
Foreign (Array Val -> Foreign
WrapArray ([Val] -> Array Val
forall a. [a] -> Array a
arrayFromList [Val]
vs'))))
          barray :: [Word8] -> Val
barray [Word8]
bs = Closure -> Val
BoxedVal (Foreign -> Closure
Foreign (ByteArray -> Foreign
WrapByteArray ([Word8] -> ByteArray
forall a. Prim a => [a] -> ByteArray
byteArrayFromList ([Word8]
bs :: [Word8]))))
          !ref :: Reference
ref = Reference
Ty.booleanRef
          !cix :: CombIx
cix = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
ref Word64
21 Word64
22
          !comb :: GCombInfo comb
comb = Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
5 Int
7 GSection comb
forall comb. GSection comb
Exit Ptr NativeCell
noNativeCell
          pap :: [Int] -> Int -> Val
pap [Int]
us Int
n = let !u :: ByteArray
u = [Int] -> ByteArray
forall a. Prim a => [a] -> ByteArray
byteArrayFromList ([Int]
us :: [Int]); !b :: Array Closure
b = [Closure] -> Array Closure
forall a. [a] -> Array a
arrayFromList (Int -> Closure -> [Closure]
forall a. Int -> a -> [a]
replicate Int
n Closure
nat) in Closure -> Val
BoxedVal (CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix GCombInfo (RComb Val)
forall {comb}. GCombInfo comb
comb (ByteArray
u, Array Closure
b))
          !cix2 :: CombIx
cix2 = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
Ty.unitRef Word64
21 Word64
22
          pap2 :: Val
pap2 = Closure -> Val
BoxedVal (CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix2 GCombInfo (RComb Val)
forall {comb}. GCombInfo comb
comb ([Int] -> ByteArray
forall a. Prim a => [a] -> ByteArray
byteArrayFromList ([] :: [Int]), [Closure] -> Array Closure
forall a. [a] -> Array a
arrayFromList []))
          dbl :: Double -> Val
dbl = Double -> Val
DoubleVal
      Val
arr12 <- [Val] -> IO Val
array [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2]
      Val
arr12' <- [Val] -> IO Val
array [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2]
      Val
arr13 <- [Val] -> IO Val
array [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
3]
      let -- (name, left, right, whether the helper must handle the pair for ordering and for equality)
          pairs :: [(String, Val, Val, (Bool, Bool))]
          both :: (Bool, Bool)
both = (Bool
True, Bool
True)
          neither :: (Bool, Bool)
neither = (Bool
False, Bool
False)
          pairs :: [([Char], Val, Val, (Bool, Bool))]
pairs =
            [ ([Char]
"Nat Nat", Word64 -> Val
NatVal Word64
3, Word64 -> Val
NatVal Word64
5, (Bool, Bool)
both),
              ([Char]
"Nat max against 1", Word64 -> Val
NatVal Word64
forall a. Bounded a => a
maxBound, Word64 -> Val
NatVal Word64
1, (Bool, Bool)
both),
              ([Char]
"Int Int", Int -> Val
IntVal (-Int
1), Int -> Val
IntVal Int
1, (Bool, Bool)
both),
              ([Char]
"Nat against negative Int", Word64 -> Val
NatVal Word64
1, Int -> Val
IntVal (-Int
1), (Bool, Bool)
both),
              ([Char]
"negative Int against Nat", Int -> Val
IntVal (-Int
1), Word64 -> Val
NatVal Word64
1, (Bool, Bool)
both),
              ([Char]
"Nat against equal Int", Word64 -> Val
NatVal Word64
7, Int -> Val
IntVal Int
7, (Bool, Bool)
both),
              ([Char]
"Char against Nat", Char -> Val
CharVal Char
'a', Word64 -> Val
NatVal Word64
97, (Bool, Bool)
both),
              ([Char]
"Char Char", Char -> Val
CharVal Char
'a', Char -> Val
CharVal Char
'b', (Bool, Bool)
both),
              ([Char]
"Float Float", Double -> Val
dbl Double
1.5, Double -> Val
dbl Double
2.5, (Bool, Bool)
both),
              ([Char]
"negative Floats", Double -> Val
dbl (-Double
1.0), Double -> Val
dbl (-Double
2.0), (Bool, Bool)
both),
              ([Char]
"negative against positive Float", Double -> Val
dbl (-Double
1.0), Double -> Val
dbl Double
2.0, (Bool, Bool)
both),
              ([Char]
"zero against negative zero", Double -> Val
dbl Double
0.0, Double -> Val
dbl (-Double
0.0), (Bool, Bool)
both),
              ([Char]
"NaN NaN", Double -> Val
dbl (Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0), Double -> Val
dbl (Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0), (Bool, Bool)
both),
              ([Char]
"Float against Nat", Double -> Val
dbl Double
1.0, Word64 -> Val
NatVal Word64
1, (Bool, Bool)
both),
              ([Char]
"unboxed against boxed", Word64 -> Val
NatVal Word64
1, Val
none, (Bool, Bool)
both),
              ([Char]
"None None", Val
none, Val
none, (Bool, Bool)
both),
              ([Char]
"None Some", Val
none, Val -> Val
some (Word64 -> Val
NatVal Word64
1), (Bool, Bool)
both),
              ([Char]
"Some Some", Val -> Val
some (Word64 -> Val
NatVal Word64
1), Val -> Val
some (Word64 -> Val
NatVal Word64
2), (Bool, Bool)
both),
              ([Char]
"Some Int against Some Nat", Val -> Val
some (Int -> Val
IntVal Int
1), Val -> Val
some (Word64 -> Val
NatVal Word64
1), (Bool, Bool)
both),
              ([Char]
"pairs differing late", Val -> Val -> Val
pair (Word64 -> Val
NatVal Word64
1) (Word64 -> Val
NatVal Word64
2), Val -> Val -> Val
pair (Word64 -> Val
NatVal Word64
1) (Word64 -> Val
NatVal Word64
3), (Bool, Bool)
both),
              ([Char]
"equal pairs", Val -> Val -> Val
pair (Word64 -> Val
NatVal Word64
1) (Word64 -> Val
NatVal Word64
2), Val -> Val -> Val
pair (Word64 -> Val
NatVal Word64
1) (Word64 -> Val
NatVal Word64
2), (Bool, Bool)
both),
              ([Char]
"DataG DataG", [Int] -> Val
dg [Int
1, Int
2, Int
3], [Int] -> Val
dg [Int
1, Int
2, Int
4], (Bool, Bool)
both),
              ([Char]
"equal DataG", [Int] -> Val
dg [Int
1, Int
2, Int
3], [Int] -> Val
dg [Int
1, Int
2, Int
3], (Bool, Bool)
both),
              ([Char]
"unit against None", Val
unit, Val
none, (Bool, Bool)
both),
              ([Char]
"false against true", Closure -> Val
BoxedVal (Reference -> PackedTag -> Closure
Enum Reference
Ty.booleanRef (Word64 -> PackedTag
PackedTag Word64
0)), Closure -> Val
BoxedVal (Reference -> PackedTag -> Closure
Enum Reference
Ty.booleanRef (Word64 -> PackedTag
PackedTag Word64
1)), (Bool, Bool)
both),
              ([Char]
"true against true", Closure -> Val
BoxedVal (Reference -> PackedTag -> Closure
Enum Reference
Ty.booleanRef (Word64 -> PackedTag
PackedTag Word64
1)), Closure -> Val
BoxedVal (Reference -> PackedTag -> Closure
Enum Reference
Ty.booleanRef (Word64 -> PackedTag
PackedTag Word64
1)), (Bool, Bool)
both),
              ([Char]
"Some against pair", Val -> Val
some (Word64 -> Val
NatVal Word64
1), Val -> Val -> Val
pair (Word64 -> Val
NatVal Word64
1) (Word64 -> Val
NatVal Word64
1), (Bool, Bool)
both),
              ([Char]
"Any Any", Val -> Val
anyOf (Word64 -> Val
NatVal Word64
1), Val -> Val
anyOf (Word64 -> Val
NatVal Word64
2), (Bool, Bool)
both),
              ([Char]
"Any Nat against Any Char", Val -> Val
anyOf (Word64 -> Val
NatVal Word64
97), Val -> Val
anyOf (Char -> Val
CharVal Char
'a'), (Bool, Bool)
both),
              ([Char]
"Any Some against Any None", Val -> Val
anyOf (Val -> Val
some (Word64 -> Val
NatVal Word64
1)), Val -> Val
anyOf Val
none, (Bool
False, Bool
True)),
              ([Char]
"texts", [Char] -> Val
text [Char]
"abc", [Char] -> Val
text [Char]
"abd", (Bool, Bool)
both),
              ([Char]
"equal texts", [Char] -> Val
text [Char]
"abc", [Char] -> Val
text [Char]
"abc", (Bool, Bool)
both),
              ([Char]
"bytes", [Word8] -> Val
bytes [Word8
1, Word8
2, Word8
3], [Word8] -> Val
bytes [Word8
1, Word8
2], (Bool, Bool)
both),
              ([Char]
"prefix list", [Val] -> Val
list [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2], [Val] -> Val
list [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
3], (Bool, Bool)
both),
              ([Char]
"equal lists", [Val] -> Val
list [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
3], [Val] -> Val
list [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
3], (Bool, Bool)
both),
              ([Char]
"lists differing early", [Val] -> Val
list [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
3], [Val] -> Val
list [Word64 -> Val
NatVal Word64
1, Word64 -> Val
NatVal Word64
2, Word64 -> Val
NatVal Word64
5], (Bool, Bool)
both),
              ([Char]
"empty lists", [Val] -> Val
list [], [Val] -> Val
list [], (Bool, Bool)
both),
              ([Char]
"empty against list", [Val] -> Val
list [], [Val] -> Val
list [Word64 -> Val
NatVal Word64
0], (Bool, Bool)
both),
              ([Char]
"nested lists", [Val] -> Val
list [Val -> Val
some (Word64 -> Val
NatVal Word64
1), [Char] -> Val
text [Char]
"a"], [Val] -> Val
list [Val -> Val
some (Word64 -> Val
NatVal Word64
1), [Char] -> Val
text [Char]
"b"], (Bool, Bool)
both),
              ([Char]
"long lists", [Val] -> Val
list ((Word64 -> Val) -> [Word64] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Val
NatVal [Word64
1 .. Word64
300]), [Val] -> Val
list ((Word64 -> Val) -> [Word64] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Word64 -> Val
NatVal ([Word64
1 .. Word64
299] [Word64] -> [Word64] -> [Word64]
forall a. [a] -> [a] -> [a]
++ [Word64
0])), (Bool, Bool)
both),
              ([Char]
"arrays", Val
arr12, Val
arr13, (Bool, Bool)
both),
              ([Char]
"equal arrays", Val
arr12, Val
arr12', (Bool, Bool)
both),
              ([Char]
"byte arrays", [Word8] -> Val
barray [Word8
1, Word8
2], [Word8] -> Val
barray [Word8
1, Word8
2, Word8
0], (Bool, Bool)
both),
              ([Char]
"equal byte arrays", [Word8] -> Val
barray [Word8
1, Word8
2], [Word8] -> Val
barray [Word8
1, Word8
2], (Bool, Bool)
both),
              ([Char]
"text against list", [Char] -> Val
text [Char]
"a", [Val] -> Val
list [], (Bool, Bool)
neither),
              ([Char]
"data against text", Val
none, [Char] -> Val
text [Char]
"a", (Bool, Bool)
both),
              ([Char]
"functions differing in an argument", [Int] -> Int -> Val
pap [Int
1] Int
1, [Int] -> Int -> Val
pap [Int
2] Int
1, (Bool, Bool)
both),
              ([Char]
"equal functions", [Int] -> Int -> Val
pap [Int
1] Int
1, [Int] -> Int -> Val
pap [Int
1] Int
1, (Bool, Bool)
both),
              ([Char]
"function against data", [Int] -> Int -> Val
pap [] Int
0, Val -> Val
some (Word64 -> Val
NatVal Word64
1), (Bool, Bool)
both),
              ([Char]
"functions of different references", [Int] -> Int -> Val
pap [] Int
0, Val
pap2, (Bool, Bool)
neither),
              -- two different maps: identical samples would be one closure at -O2, and the same object is equal to itself
              ([Char]
"maps", Closure -> Val
BoxedVal (Foreign -> Closure
Foreign (Map Val Val -> Foreign
WrapMap (Val -> Val -> Map Val Val
forall k a. k -> a -> Map k a
M.singleton (Word64 -> Val
NatVal Word64
1) (Word64 -> Val
NatVal Word64
1)))), Closure -> Val
BoxedVal (Foreign -> Closure
Foreign (Map Val Val -> Foreign
WrapMap (Val -> Val -> Map Val Val
forall k a. k -> a -> Map k a
M.singleton (Word64 -> Val
NatVal Word64
2) (Word64 -> Val
NatVal Word64
2)))), (Bool, Bool)
neither)
            ]
      MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
2 (Closure -> Any
forall a. a -> Any
any' Closure
natTypeTag) :: IO (MutableArray (PrimState IO) Any)
      let put :: Int -> Any -> IO ()
          put :: Int -> Any -> IO ()
put Int
i Any
v = Any -> IO Any
forall a. a -> IO a
evaluate Any
v IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
i
          toInt :: a -> Int
toInt a
o = a -> Int
forall a. Enum a => a -> Int
fromEnum a
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      [Maybe [Char]]
rs <- [([Char], Val, Val, (Bool, Bool))]
-> (([Char], Val, Val, (Bool, Bool)) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [([Char], Val, Val, (Bool, Bool))]
pairs ((([Char], Val, Val, (Bool, Bool)) -> IO (Maybe [Char]))
 -> IO [Maybe [Char]])
-> (([Char], Val, Val, (Bool, Bool)) -> IO (Maybe [Char]))
-> IO [Maybe [Char]]
forall a b. (a -> b) -> a -> b
$ \([Char]
name, Val
l, Val
r, (Bool
handledC, Bool
handledE)) -> do
        Int -> Any -> IO ()
put Int
0 (Closure -> Any
forall a. a -> Any
any' (Val -> Closure
getBoxedVal Val
l))
        Int -> Any -> IO ()
put Int
1 (Closure -> Any
forall a. a -> Any
any' (Val -> Closure
getBoxedVal Val
r))
        Maybe Int
gotC <- MutableArray (PrimState IO) Any
-> Int -> Int -> Bool -> IO (Maybe Int)
cmpTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr (Val -> Int
getUnboxedVal Val
l) (Val -> Int
getUnboxedVal Val
r) Bool
False
        Maybe Int
gotE <- MutableArray (PrimState IO) Any
-> Int -> Int -> Bool -> IO (Maybe Int)
cmpTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr (Val -> Int
getUnboxedVal Val
l) (Val -> Int
getUnboxedVal Val
r) Bool
True
        let wantC :: Int
wantC = Ordering -> Int
forall a. Enum a => a -> Int
toInt (Val -> Val -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Val
l Val
r)
            wantE :: Int
wantE = Bool -> Int
forall a. Enum a => a -> Int
fromEnum (Val
l Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
r)
            okC :: Bool
okC = if Bool
handledC then Maybe Int
gotC Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
wantC else Maybe Int
gotC Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing
            okE :: Bool
okE = if Bool
handledE then Maybe Int
gotE Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Maybe Int
forall a. a -> Maybe a
Just Int
wantE else Maybe Int
gotE Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
forall a. Maybe a
Nothing
        pure $
          if Bool
okC Bool -> Bool -> Bool
&& Bool
okE
            then Maybe [Char]
forall a. Maybe a
Nothing
            else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"universal comparison of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": native " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Maybe Int, Maybe Int) -> [Char]
forall a. Show a => a -> [Char]
show (Maybe Int
gotC, Maybe Int
gotE) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", Haskell " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
wantC, Int
wantE) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", expected handled " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Bool, Bool) -> [Char]
forall a. Show a => a -> [Char]
show (Bool
handledC, Bool
handledE))
      pure $ case [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes [Maybe [Char]]
rs of
        [] -> () -> Either [Char] ()
forall a b. b -> Either a b
Right ()
        [Char]
e : [[Char]]
_ -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e

-- | The handler environment: teaches the request helpers the layouts of
-- @HEnv@, the @IntMap@ under @EnumMap@, the @STRef@ box inside an
-- @AffineRef@ and the @Affine@ closure, from samples, and checks the
-- native lookup against what the interpreter's @resolve@ would find
-- (see unison_jit_env_init in jit_rt.c).
probeEnv :: IO (Either String ())
probeEnv :: IO (Either [Char] ())
probeEnv = do
  let !ref :: Reference
ref = Reference
Ty.booleanRef
      !v3 :: Closure
v3 = Reference -> PackedTag -> Closure
Enum Reference
ref (Word64 -> PackedTag
PackedTag Word64
3)
      !v10 :: Closure
v10 = Reference -> PackedTag -> Closure
Enum Reference
ref (Word64 -> PackedTag
PackedTag Word64
10)
      !v77 :: Closure
v77 = Reference -> PackedTag -> Closure
Enum Reference
ref (Word64 -> PackedTag
PackedTag Word64
77)
  IORef Closure
r3 <- Closure -> IO (IORef Closure)
forall a. a -> IO (IORef a)
newIORef Closure
v3
  IORef Closure
r10 <- Closure -> IO (IORef Closure)
forall a. a -> IO (IORef a)
newIORef Closure
v10
  IORef Closure
r77 <- Closure -> IO (IORef Closure)
forall a. a -> IO (IORef a)
newIORef Closure
v77
  let IORef STRef RealWorld Closure
box3 = IORef Closure
r3
      !aenv :: EnumMap Word64 AffineRef
aenv = [(Word64, AffineRef)] -> EnumMap Word64 AffineRef
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList [(Word64
3 :: Word64, IORef Closure -> AffineRef
ARef IORef Closure
r3), (Word64
10, IORef Closure -> AffineRef
ARef IORef Closure
r10), (Word64
77, IORef Closure -> AffineRef
ARef IORef Closure
r77)]
      !denv2 :: DEnv
denv2 = [(Word64, Val)] -> DEnv
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList [(Word64
10 :: Word64, Closure -> Val
BoxedVal Closure
v10)]
      !empty :: EnumMap Word64 AffineRef
empty = [(Word64, AffineRef)] -> EnumMap Word64 AffineRef
forall k a. EnumKey k => [(k, a)] -> EnumMap k a
EC.mapFromList [] :: EC.EnumMap Word64 AffineRef
      !set3 :: EnumSet Word64
set3 = Word64 -> EnumSet Word64
forall k. EnumKey k => k -> EnumSet k
EC.setSingleton (Word64
3 :: Word64)
  DEnv
_ <- DEnv -> IO DEnv
forall a. a -> IO a
evaluate DEnv
emptyDEnv
  HEnv
h1 <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (EnumMap Word64 AffineRef -> DEnv -> HEnv
HEnv EnumMap Word64 AffineRef
aenv DEnv
emptyDEnv)
  HEnv
h2 <- HEnv -> IO HEnv
forall a. a -> IO a
evaluate (EnumMap Word64 AffineRef -> DEnv -> HEnv
HEnv EnumMap Word64 AffineRef
aenv DEnv
denv2)
  Closure
aff <- Closure -> IO Closure
forall a. a -> IO a
evaluate (EnumSet Word64 -> EnumMap Word64 AffineRef -> AffineRef -> Closure
Affine EnumSet Word64
set3 EnumMap Word64 AffineRef
aenv (IORef Closure -> AffineRef
ARef IORef Closure
r3))
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
9 (HEnv -> Any
forall a. a -> Any
any' HEnv
h1) :: IO (MutableArray (PrimState IO) Any)
  let put :: Int -> Any -> IO ()
put Int
i Any
v = Any -> IO Any
forall a. a -> IO a
evaluate Any
v IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
i
  Int -> Any -> IO ()
put Int
0 (HEnv -> Any
forall a. a -> Any
any' HEnv
h1)
  Int -> Any -> IO ()
put Int
1 (EnumMap Word64 AffineRef -> Any
forall a. a -> Any
any' EnumMap Word64 AffineRef
aenv)
  Int -> Any -> IO ()
put Int
2 (HEnv -> Any
forall a. a -> Any
any' HEnv
h2)
  Int -> Any -> IO ()
put Int
3 (STRef RealWorld Closure -> Any
forall a. a -> Any
any' STRef RealWorld Closure
box3)
  Int -> Any -> IO ()
put Int
4 (Closure -> Any
forall a. a -> Any
any' Closure
v3)
  Int -> Any -> IO ()
put Int
5 (Closure -> Any
forall a. a -> Any
any' Closure
v10)
  Int -> Any -> IO ()
put Int
6 (EnumMap Word64 AffineRef -> Any
forall a. a -> Any
any' EnumMap Word64 AffineRef
empty)
  Int -> Any -> IO ()
put Int
7 (Closure -> Any
forall a. a -> Any
any' Closure
aff)
  Int -> Any -> IO ()
put Int
8 (EnumSet Word64 -> Any
forall a. a -> Any
any' EnumSet Word64
set3)
  Int
ok <- MutableArray (PrimState IO) Any -> IO Int
envInit MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
  if Int
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    then Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either [Char] ()
forall a b. b -> Either a b
Right ())
    else do
      [[Int]]
dbg <- [Any] -> (Any -> IO [Int]) -> IO [[Int]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [EnumMap Word64 AffineRef -> Any
forall a. a -> Any
any' EnumMap Word64 AffineRef
empty, EnumMap Word64 AffineRef -> Any
forall a. a -> Any
any' EnumMap Word64 AffineRef
aenv, STRef RealWorld Closure -> Any
forall a. a -> Any
any' STRef RealWorld Closure
box3, HEnv -> Any
forall a. a -> Any
any' HEnv
h1] ((Any -> IO [Int]) -> IO [[Int]])
-> (Any -> IO [Int]) -> IO [[Int]]
forall a b. (a -> b) -> a -> b
$ \Any
x -> do
        MutableArray RealWorld Any
a <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
1 Any
x :: IO (MutableArray (PrimState IO) Any)
        Any -> IO Any
forall a. a -> IO a
evaluate Any
x IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
a Int
0
        MutableArray (PrimState IO) Any -> IO [Int]
probeClosure MutableArray RealWorld Any
MutableArray (PrimState IO) Any
a
      pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the handler environment is not what the request helpers expect (check " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ok [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"; " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Int]] -> [Char]
forall a. Show a => a -> [Char]
show [[Int]]
dbg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"))

-- | Lists: teaches the C helpers (jit_rt.c) the constructors of
-- Unison.Util.Deque from samples, checks the structure of a range of lists
-- against what the helpers assume, and then runs every helper against the
-- Haskell operation it stands in for; each list a helper builds is checked
-- for its structure too. Returns an explanation if anything differs.
--
-- @steps@ (stress mode @lists=N@) adds a longer test: that many random
-- operations, each done by a helper on the results of earlier ones and
-- compared with the Haskell operation.
probeLists :: Layouts -> Int -> IO (Either String ())
probeLists :: Layouts -> Int -> IO (Either [Char] ())
probeLists Layouts
ls Int
steps = do
  let nat :: Int -> Val
nat Int
i = Word64 -> Val
NatVal (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i :: Int))
      wrap :: Sq.Deque Val -> Any
      wrap :: Deque Val -> Any
wrap Deque Val
d = Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! Deque Val -> Closure
ListC Deque Val
d
      !x :: Val
x = Int -> Val
nat Int
1000
      !sample :: Deque Val
sample = Val
x Val -> Deque Val -> Deque Val
forall a. a -> Deque a -> Deque a
Sq.<| (Deque Val
forall a. Deque a
Sq.empty Deque Val -> Val -> Deque Val
forall a. Deque a -> a -> Deque a
Sq.|> Int -> Val
nat Int
1 Deque Val -> Val -> Deque Val
forall a. Deque a -> a -> Deque a
Sq.|> Int -> Val
nat Int
2 Deque Val -> Val -> Deque Val
forall a. Deque a -> a -> Deque a
Sq.|> Int -> Val
nat Int
3)
      PackedTag Word64
elemTag = PackedTag
TT.seqViewElemTag
      PackedTag Word64
someTag = PackedTag
TT.someTag
      !emptyView :: Closure
emptyView = Reference -> PackedTag -> Closure
Enum Reference
Ty.seqViewRef PackedTag
TT.seqViewEmptyTag
      !none :: Closure
none = Reference -> PackedTag -> Closure
Enum Reference
Ty.optionalRef PackedTag
TT.noneTag
      range :: Int -> Int -> Deque Val
range Int
a Int
b = [Val] -> Deque Val
forall a. [a] -> Deque a
Sq.fromList ((Int -> Val) -> [Int] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Val
nat [Int
a .. Int
b])
      -- lists of many shapes: built from either end, appended, cut, and drained
      built :: Int -> [Deque Val]
built Int
n = [Int -> Int -> Deque Val
range Int
1 Int
n, (Val -> Deque Val -> Deque Val) -> Deque Val -> [Val] -> Deque Val
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Val -> Deque Val -> Deque Val
forall a. a -> Deque a -> Deque a
(Sq.<|) Deque Val
forall a. Deque a
Sq.empty ((Int -> Val) -> [Int] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Val
nat [Int
1 .. Int
n])]
      samples :: [Deque Val]
samples =
        (Int -> [Deque Val]) -> [Int] -> [Deque Val]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [Deque Val]
built ([Int
0 .. Int
12] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
63, Int
64, Int
65, Int
100, Int
200, Int
513, Int
1000, Int
3000])
          [Deque Val] -> [Deque Val] -> [Deque Val]
forall a. [a] -> [a] -> [a]
++ [Int -> Int -> Deque Val
range Int
1 Int
12000]
          [Deque Val] -> [Deque Val] -> [Deque Val]
forall a. [a] -> [a] -> [a]
++ [Int -> Int -> Deque Val
range Int
1 Int
a Deque Val -> Deque Val -> Deque Val
forall a. Deque a -> Deque a -> Deque a
Sq.>< Int -> Int -> Deque Val
range Int
1 Int
b | (Int
a, Int
b) <- [(Int
9, Int
10), (Int
33, Int
300), (Int
150, Int
47), (Int
1200, Int
2500)]]
          [Deque Val] -> [Deque Val] -> [Deque Val]
forall a. [a] -> [a] -> [a]
++ [Int -> Deque Val -> Deque Val
forall a. Int -> Deque a -> Deque a
Sq.drop Int
k (Int -> Int -> Deque Val
range Int
1 Int
n) | (Int
n, Int
k) <- [(Int
100, Int
7), (Int
1000, Int
60), (Int
5000, Int
1), (Int
5000, Int
97)]]
          [Deque Val] -> [Deque Val] -> [Deque Val]
forall a. [a] -> [a] -> [a]
++ [Int -> Deque Val -> Deque Val
forall a. Int -> Deque a -> Deque a
Sq.take Int
k (Int -> Int -> Deque Val
range Int
1 Int
n) | (Int
n, Int
k) <- [(Int
100, Int
50), (Int
1000, Int
93), (Int
5000, Int
3)]]
          [Deque Val] -> [Deque Val] -> [Deque Val]
forall a. [a] -> [a] -> [a]
++ Int -> [Deque Val] -> [Deque Val]
forall a. Int -> [a] -> [a]
take Int
10 ((Deque Val -> Deque Val) -> Deque Val -> [Deque Val]
forall a. (a -> a) -> a -> [a]
iterate (\Deque Val
d -> case Deque Val
d of Val
_ Sq.:<| Deque Val
r -> Deque Val
r; Deque Val
r -> Deque Val
r) (Int -> Int -> Deque Val
range Int
1 Int
300))
          [Deque Val] -> [Deque Val] -> [Deque Val]
forall a. [a] -> [a] -> [a]
++ Int -> [Deque Val] -> [Deque Val]
forall a. Int -> [a] -> [a]
take Int
10 ((Deque Val -> Deque Val) -> Deque Val -> [Deque Val]
forall a. (a -> a) -> a -> [a]
iterate (\Deque Val
d -> case Deque Val
d of Deque Val
r Sq.:|> Val
_ -> Deque Val
r; Deque Val
r -> Deque Val
r) (Int -> Int -> Deque Val
range Int
1 Int
300))
  -- The array must hold the evaluated objects, never thunks that produce
  -- them. (`evaluate`, not `seq`: the optimizer makes top-level constants of
  -- some samples, and a `seq` on one can leave the reference to the
  -- unevaluated constant in the array.)
  let put :: MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
      put :: MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray (PrimState IO) Any
a Int
i Any
v = Any -> IO Any
forall a. a -> IO a
evaluate Any
v IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray (PrimState IO) Any
a Int
i
      !first :: Any
first = Deque Val -> Any
wrap Deque Val
sample
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
4 Any
first :: IO (MutableArray (PrimState IO) Any)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Val -> Any
forall a. a -> Any
any' Val
x)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
2 (Deque Val -> Any
wrap Deque Val
forall a. Deque a
Sq.empty)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 (Deque Val -> Any
wrap (Int -> Int -> Deque Val
range Int
1 Int
1000))
  let Pair Int
listInfo Int
listTag = Layouts -> Pair Int Int
lList Layouts
ls
  Int
ok <- MutableArray (PrimState IO) Any -> [Int] -> IO Int
listInit MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr [Layouts -> Int
lForeignInfo Layouts
ls, Layout -> Int
lInfo (Layouts -> Layout
lVal Layouts
ls), Layout -> Int
lInfo (Layouts -> Vector Layout
lData Layouts
ls Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
1), Layout -> Int
lInfo (Layouts -> Vector Layout
lData Layouts
ls Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
2), Layout -> Int
lPtrTag (Layouts -> Vector Layout
lData Layouts
ls Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
1), Layout -> Int
lPtrTag (Layouts -> Vector Layout
lData Layouts
ls Vector Layout -> Int -> Layout
forall a. Vector a -> Int -> a
V.! Int
2), Int
listInfo, Int
listTag]
  if Int
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
    then Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the list constructors are not laid out as the JIT's helpers expect (check " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ok [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"))
    else do
      let same :: Closure -> Closure -> Bool
same Closure
a Closure
b = Closure -> Val
BoxedVal Closure
a Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Closure -> Val
BoxedVal Closure
b
          listOf :: Closure -> Maybe (Deque Val)
listOf Closure
c = case Closure
c of
            ListC Deque Val
d -> Deque Val -> Maybe (Deque Val)
forall a. a -> Maybe a
Just Deque Val
d
            Closure
_ -> Maybe (Deque Val)
forall a. Maybe a
Nothing
          -- a helper on the list d, with its other arguments; its result
          run :: Sq.Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
          run :: Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
run Deque Val
d Int
op Any
other Int
a Int
b = do
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Deque Val -> Any
wrap Deque Val
d)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 Any
other
            Bool
h <- MutableArray (PrimState IO) Any -> Int -> Int -> Int -> IO Bool
listTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
op Int
a Int
b
            if Bool
h then Closure -> Maybe Closure
forall a. a -> Maybe a
Just (Closure -> Maybe Closure)
-> (Any -> Closure) -> Any -> Maybe Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Any -> Closure
forall a b. a -> b
unsafeCoerce (Any -> Maybe Closure) -> IO Any -> IO (Maybe Closure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray (PrimState IO) Any -> Int -> IO Any
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 else Maybe Closure -> IO (Maybe Closure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Closure
forall a. Maybe a
Nothing
          -- a few positions of a list of n elements: all, if it is short
          spread :: a -> [a]
spread a
n
            | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
40 = [a
0 .. a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1]
            | Bool
otherwise = [a
0 .. a
11] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [(a
n a -> a -> a
forall a. Num a => a -> a -> a
* a
k) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
23 | a
k <- [a
1 .. a
22]] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
12 .. a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1]
          agree :: Bool -> Deque Val -> Deque Val -> Bool
agree Bool
full Deque Val
d Deque Val
e
            | Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
e = Bool
False
            -- (the C walk has checked the structure; the Haskell check of it is for the longer test)
            | Bool
full = (Int
steps Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| ([Char] -> Bool) -> (() -> Bool) -> Either [Char] () -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> [Char] -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True) (Deque Val -> Either [Char] ()
forall a. Deque a -> Either [Char] ()
Sq.valid Deque Val
d)) Bool -> Bool -> Bool
&& Deque Val
d Deque Val -> Deque Val -> Bool
forall a. Eq a => a -> a -> Bool
== Deque Val
e
            | Bool
otherwise = (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Int
i -> Int -> Deque Val -> Maybe Val
forall a. Int -> Deque a -> Maybe a
Sq.lookup Int
i Deque Val
d Maybe Val -> Maybe Val -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Deque Val -> Maybe Val
forall a. Int -> Deque a -> Maybe a
Sq.lookup Int
i Deque Val
e) (Int -> [Int]
forall {a}. Integral a => a -> [a]
spread (Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
e))
          -- What a helper built against the list it should be: Nothing if
          -- they differ, else the helper's list. Checking every element is
          -- for lists that aren't long (full).
          checked :: Bool -> Sq.Deque Val -> Maybe Closure -> IO (Maybe (Sq.Deque Val))
          checked :: Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
full Deque Val
expected = \case
            Just Closure
c | Just Deque Val
d <- Closure -> Maybe (Deque Val)
listOf Closure
c -> do
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c)
              Int
k <- MutableArray (PrimState IO) Any -> IO Int
listCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
              pure (if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Bool -> Deque Val -> Deque Val -> Bool
agree Bool
full Deque Val
d Deque Val
expected then Deque Val -> Maybe (Deque Val)
forall a. a -> Maybe a
Just Deque Val
d else Maybe (Deque Val)
forall a. Maybe a
Nothing)
            Maybe Closure
_ -> Maybe (Deque Val) -> IO (Maybe (Deque Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Deque Val)
forall a. Maybe a
Nothing
          push :: Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
push Bool
full Bool
front Int
v Deque Val
d =
            Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
run Deque Val
d (if Bool
front then Int
2 else Int
3) (Closure -> Any
forall a. a -> Any
any' Closure
natTypeTag) Int
v Int
0
              IO (Maybe Closure)
-> (Maybe Closure -> IO (Maybe (Deque Val)))
-> IO (Maybe (Deque Val))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
full (if Bool
front then Int -> Val
nat Int
v Val -> Deque Val -> Deque Val
forall a. a -> Deque a -> Deque a
Sq.<| Deque Val
d else Deque Val
d Deque Val -> Val -> Deque Val
forall a. Deque a -> a -> Deque a
Sq.|> Int -> Val
nat Int
v)
          view :: Bool -> Bool -> Deque Val -> IO (Maybe (Deque Val))
view Bool
full Bool
left Deque Val
d = do
            Maybe Closure
r <- Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
run Deque Val
d (if Bool
left then Int
0 else Int
1) (Closure -> Any
forall a. a -> Any
any' Closure
emptyView) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
elemTag) Int
0
            case (Maybe Closure
r, Bool
left, Deque Val
d) of
              (Just Closure
c, Bool
_, Deque Val
Sq.Empty) -> Maybe (Deque Val) -> IO (Maybe (Deque Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Closure -> Closure -> Bool
same Closure
c Closure
emptyView then Deque Val -> Maybe (Deque Val)
forall a. a -> Maybe a
Just Deque Val
d else Maybe (Deque Val)
forall a. Maybe a
Nothing)
              (Just (Data2 Reference
rf PackedTag
t Val
a (BoxedVal Closure
c)), Bool
True, Val
e Sq.:<| Deque Val
rest)
                | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Ty.seqViewRef, PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.seqViewElemTag, Val
a Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
e -> Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
full Deque Val
rest (Closure -> Maybe Closure
forall a. a -> Maybe a
Just Closure
c)
              (Just (Data2 Reference
rf PackedTag
t (BoxedVal Closure
c) Val
b), Bool
False, Deque Val
rest Sq.:|> Val
e)
                | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Ty.seqViewRef, PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.seqViewElemTag, Val
b Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Val
e -> Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
full Deque Val
rest (Closure -> Maybe Closure
forall a. a -> Maybe a
Just Closure
c)
              (Maybe Closure, Bool, Deque Val)
_ -> Maybe (Deque Val) -> IO (Maybe (Deque Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Deque Val)
forall a. Maybe a
Nothing
          -- a negative count is a Nat too large to be a size
          cut :: Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
cut Bool
full Bool
tk Int
k Deque Val
d =
            Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
run Deque Val
d (if Bool
tk then Int
5 else Int
6) (Closure -> Any
forall a. a -> Any
any' Closure
none) Int
k Int
0
              IO (Maybe Closure)
-> (Maybe Closure -> IO (Maybe (Deque Val)))
-> IO (Maybe (Deque Val))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
full (if Bool
tk then (if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Deque Val
d else Int -> Deque Val -> Deque Val
forall a. Int -> Deque a -> Deque a
Sq.take Int
k Deque Val
d) else (if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Deque Val
forall a. Deque a
Sq.empty else Int -> Deque Val -> Deque Val
forall a. Int -> Deque a -> Deque a
Sq.drop Int
k Deque Val
d))
          split :: Bool
-> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val, Deque Val))
split Bool
full Bool
left Int
k Deque Val
d = do
            Maybe Closure
r <- Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
run Deque Val
d (if Bool
left then Int
7 else Int
8) (Closure -> Any
forall a. a -> Any
any' Closure
emptyView) Int
k (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
elemTag)
            let n :: Int
n = Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
d
                (Deque Val
ea, Deque Val
eb) = Int -> Deque Val -> (Deque Val, Deque Val)
forall a. Int -> Deque a -> (Deque a, Deque a)
Sq.splitAt (if Bool
left then Int
k else Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k) Deque Val
d
            case Maybe Closure
r of
              Just Closure
c | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
k -> Maybe (Deque Val, Deque Val) -> IO (Maybe (Deque Val, Deque Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Closure -> Closure -> Bool
same Closure
c Closure
emptyView then (Deque Val, Deque Val) -> Maybe (Deque Val, Deque Val)
forall a. a -> Maybe a
Just (Deque Val
d, Deque Val
d) else Maybe (Deque Val, Deque Val)
forall a. Maybe a
Nothing)
              Just (Data2 Reference
rf PackedTag
t (BoxedVal Closure
a) (BoxedVal Closure
b))
                | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Ty.seqViewRef,
                  PackedTag
t PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.seqViewElemTag -> do
                    Maybe (Deque Val)
ra <- Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
full Deque Val
ea (Closure -> Maybe Closure
forall a. a -> Maybe a
Just Closure
a)
                    Maybe (Deque Val)
rb <- Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
full Deque Val
eb (Closure -> Maybe Closure
forall a. a -> Maybe a
Just Closure
b)
                    pure ((,) (Deque Val -> Deque Val -> (Deque Val, Deque Val))
-> Maybe (Deque Val) -> Maybe (Deque Val -> (Deque Val, Deque Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Deque Val)
ra Maybe (Deque Val -> (Deque Val, Deque Val))
-> Maybe (Deque Val) -> Maybe (Deque Val, Deque Val)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Deque Val)
rb)
              Maybe Closure
_ -> Maybe (Deque Val, Deque Val) -> IO (Maybe (Deque Val, Deque Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Deque Val, Deque Val)
forall a. Maybe a
Nothing
          cat :: Bool -> Deque Val -> Deque Val -> IO (Maybe (Deque Val))
cat Bool
full Deque Val
a Deque Val
b = Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
run Deque Val
a Int
9 (Deque Val -> Any
wrap Deque Val
b) Int
0 Int
0 IO (Maybe Closure)
-> (Maybe Closure -> IO (Maybe (Deque Val)))
-> IO (Maybe (Deque Val))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
full (Deque Val
a Deque Val -> Deque Val -> Deque Val
forall a. Deque a -> Deque a -> Deque a
Sq.>< Deque Val
b)
          lit :: Int -> Int -> IO (Maybe (Deque Val))
lit Int
k Int
v = Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
run Deque Val
forall a. Deque a
Sq.empty Int
10 (Closure -> Any
forall a. a -> Any
any' Closure
natTypeTag) Int
k Int
v IO (Maybe Closure)
-> (Maybe Closure -> IO (Maybe (Deque Val)))
-> IO (Maybe (Deque Val))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Deque Val -> Maybe Closure -> IO (Maybe (Deque Val))
checked Bool
True ([Val] -> Deque Val
forall a. [a] -> Deque a
Sq.fromList ((Int -> Val) -> [Int] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Val
nat [Int
v .. Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]))
          at :: Deque Val -> Int -> IO Bool
at Deque Val
d Int
i = do
            Maybe Closure
r <- Deque Val -> Int -> Any -> Int -> Int -> IO (Maybe Closure)
run Deque Val
d Int
4 (Closure -> Any
forall a. a -> Any
any' Closure
none) Int
i (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag)
            pure (Bool -> (Closure -> Bool) -> Maybe Closure -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\Closure
c -> Closure -> Closure -> Bool
same Closure
c (Closure -> (Val -> Closure) -> Maybe Val -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.optionalRef PackedTag
TT.someTag) (Int -> Deque Val -> Maybe Val
forall a. Int -> Deque a -> Maybe a
Sq.lookup Int
i Deque Val
d))) Maybe Closure
r)
          yes :: Maybe a -> Bool
yes = Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)
          -- one sample: its structure, then each helper against Haskell
          check :: Sq.Deque Val -> IO (Either String Int)
          check :: Deque Val -> IO (Either [Char] Int)
check Deque Val
d = do
            let n :: Int
n = Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
d
                full :: Bool
full = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
64
                cuts :: [Int]
cuts = [-Int
1, Int
1, Int
10, Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Deque Val -> Any
wrap Deque Val
d)
            Int
kinds <- MutableArray (PrimState IO) Any -> IO Int
listCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
            if Int
kinds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
              then Either [Char] Int -> IO (Either [Char] Int)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] Int
forall a b. a -> Either a b
Left ([Char]
"a list of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements isn't laid out as expected"))
              else do
                Bool
ixOk <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> IO Bool) -> [Int] -> IO [Bool]
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 (Deque Val -> Int -> IO Bool
at Deque Val
d) ([-Int
1, Int
n] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall {a}. Integral a => a -> [a]
spread Int
n)
                Bool
viewOk <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> IO Bool) -> [Bool] -> IO [Bool]
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 (\Bool
left -> Maybe (Deque Val) -> Bool
forall {a}. Maybe a -> Bool
yes (Maybe (Deque Val) -> Bool) -> IO (Maybe (Deque Val)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Bool -> Deque Val -> IO (Maybe (Deque Val))
view Bool
full Bool
left Deque Val
d) [Bool
True, Bool
False]
                Bool
pushOk <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> IO Bool) -> [Bool] -> IO [Bool]
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 (\Bool
front -> Maybe (Deque Val) -> Bool
forall {a}. Maybe a -> Bool
yes (Maybe (Deque Val) -> Bool) -> IO (Maybe (Deque Val)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
push Bool
full Bool
front Int
77 Deque Val
d) [Bool
True, Bool
False]
                Bool
cutOk <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO Bool] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Deque Val) -> Bool
forall {a}. Maybe a -> Bool
yes (Maybe (Deque Val) -> Bool) -> IO (Maybe (Deque Val)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
cut Bool
full Bool
tk Int
k Deque Val
d | Bool
tk <- [Bool
True, Bool
False], Int
k <- [Int]
cuts]
                Bool
splitOk <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO Bool] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Deque Val, Deque Val) -> Bool
forall {a}. Maybe a -> Bool
yes (Maybe (Deque Val, Deque Val) -> Bool)
-> IO (Maybe (Deque Val, Deque Val)) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val, Deque Val))
split Bool
full Bool
left Int
k Deque Val
d | Bool
left <- [Bool
True, Bool
False], Int
k <- [Int
3, Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]]
                pure $ case () of
                  ()
_
                    | Bool -> Bool
not Bool
ixOk -> [Char] -> Either [Char] Int
forall a b. a -> Either a b
Left ([Char]
"List.at on a list of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements differs from the interpreter's")
                    | Bool -> Bool
not Bool
viewOk -> [Char] -> Either [Char] Int
forall a b. a -> Either a b
Left ([Char]
"a list pattern on a list of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements differs from the interpreter's")
                    | Bool -> Bool
not Bool
pushOk -> [Char] -> Either [Char] Int
forall a b. a -> Either a b
Left ([Char]
"adding to a list of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements differs from the interpreter")
                    | Bool -> Bool
not Bool
cutOk -> [Char] -> Either [Char] Int
forall a b. a -> Either a b
Left ([Char]
"List.take or List.drop on a list of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements differs from the interpreter's")
                    | Bool -> Bool
not Bool
splitOk -> [Char] -> Either [Char] Int
forall a b. a -> Either a b
Left ([Char]
"splitting a list of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements differs from the interpreter")
                    | Bool
otherwise -> Int -> Either [Char] Int
forall a b. b -> Either a b
Right Int
kinds
          firstLeft :: [IO (Either String a)] -> IO (Either String [a])
          firstLeft :: forall a. [IO (Either [Char] a)] -> IO (Either [Char] [a])
firstLeft = (Either [Char] [a]
 -> IO (Either [Char] a) -> IO (Either [Char] [a]))
-> Either [Char] [a]
-> [IO (Either [Char] a)]
-> IO (Either [Char] [a])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Either [Char] [a]
acc IO (Either [Char] a)
io -> case Either [Char] [a]
acc of Left [Char]
e -> Either [Char] [a] -> IO (Either [Char] [a])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] [a]
forall a b. a -> Either a b
Left [Char]
e); Right [a]
rs -> (a -> [a]) -> Either [Char] a -> Either [Char] [a]
forall a b. (a -> b) -> Either [Char] a -> Either [Char] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rs) (Either [Char] a -> Either [Char] [a])
-> IO (Either [Char] a) -> IO (Either [Char] [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Either [Char] a)
io) ([a] -> Either [Char] [a]
forall a b. b -> Either a b
Right [])
          -- lists that helpers built, used again: a full digit at each
          -- level, then drained from the other end
          grow :: Bool -> IO (Either a ())
grow Bool
front = Int -> Deque Val -> IO (Either a ())
go (Int
200 :: Int) Deque Val
forall a. Deque a
Sq.empty
            where
              go :: Int -> Deque Val -> IO (Either a ())
go Int
0 Deque Val
d = Int -> Deque Val -> IO (Either a ())
shrink (Int
200 :: Int) Deque Val
d
              go Int
k Deque Val
d = Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
push (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
160) Bool
front Int
k Deque Val
d IO (Maybe (Deque Val))
-> (Maybe (Deque Val) -> IO (Either a ())) -> IO (Either a ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Either a ())
-> (Deque Val -> IO (Either a ()))
-> Maybe (Deque Val)
-> IO (Either a ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either a () -> IO (Either a ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either a ()
forall a b. a -> Either a b
Left a
"a list built by the helpers differs from the interpreter's")) (Int -> Deque Val -> IO (Either a ())
go (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
              shrink :: Int -> Deque Val -> IO (Either a ())
shrink Int
0 Deque Val
_ = Either a () -> IO (Either a ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either a ()
forall a b. b -> Either a b
Right ())
              shrink Int
k Deque Val
d = Bool -> Bool -> Deque Val -> IO (Maybe (Deque Val))
view (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
40) (Bool -> Bool
not Bool
front) Deque Val
d IO (Maybe (Deque Val))
-> (Maybe (Deque Val) -> IO (Either a ())) -> IO (Either a ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Either a ())
-> (Deque Val -> IO (Either a ()))
-> Maybe (Deque Val)
-> IO (Either a ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either a () -> IO (Either a ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either a ()
forall a b. a -> Either a b
Left a
"a list drained by the helpers differs from the interpreter's")) (Int -> Deque Val -> IO (Either a ())
shrink (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
          pairs :: [Deque Val]
pairs = [Deque Val
d | (Int
i, Deque Val
d) <- [Int] -> [Deque Val] -> [(Int, Deque Val)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Deque Val]
samples, Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
6 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0]
          appends :: [IO (Either [Char] ())]
appends = [(\Maybe (Deque Val)
r -> if Maybe (Deque Val) -> Bool
forall {a}. Maybe a -> Bool
yes Maybe (Deque Val)
r then () -> Either [Char] ()
forall a b. b -> Either a b
Right () else [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"List.++ on lists of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
a) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" and " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
b) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements differs from the interpreter's")) (Maybe (Deque Val) -> Either [Char] ())
-> IO (Maybe (Deque Val)) -> IO (Either [Char] ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Deque Val -> Deque Val -> IO (Maybe (Deque Val))
cat (Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
64) Deque Val
a Deque Val
b | Deque Val
a <- [Deque Val]
pairs, Deque Val
b <- [Deque Val]
pairs]
          lits :: [IO (Either [Char] ())]
lits = [(\Maybe (Deque Val)
r -> if Maybe (Deque Val) -> Bool
forall {a}. Maybe a -> Bool
yes Maybe (Deque Val)
r then () -> Either [Char] ()
forall a b. b -> Either a b
Right () else [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"a list literal of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
k [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements differs from the interpreter's")) (Maybe (Deque Val) -> Either [Char] ())
-> IO (Maybe (Deque Val)) -> IO (Either [Char] ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO (Maybe (Deque Val))
lit Int
k Int
5 | Int
k <- [Int
0 .. Int
24]]
          -- (The checks above are sized to cost little at every startup: they
          -- confirm the layouts and that each helper works here. The thorough
          -- test of the helpers is the longer one, run when they change.)
          -- the longer test: random operations on eight lists
          mix :: Int -> Int
          mix :: Int -> Int
mix Int
z0 =
            let z1 :: Int
z1 = (Int
z0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z0 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
30)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (-Int
4658895280553007687)
                z2 :: Int
z2 = (Int
z1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
27)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (-Int
7723592293110705685)
             in (Int
z2 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z2 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
31)) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
forall a. Bounded a => a
maxBound
          stress :: Int -> [Sq.Deque Val] -> IO (Either String ())
          stress :: Int -> [Deque Val] -> IO (Either [Char] ())
stress Int
step [Deque Val]
pool
            | Int
step Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
steps = Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either [Char] ()
forall a b. b -> Either a b
Right ())
            | Bool
otherwise = do
                let r :: Int -> Int
r Int
k = Int -> Int
mix (Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k)
                    i :: Int
i = Int -> Int
r Int
0 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8
                    d :: Deque Val
d = [Deque Val]
pool [Deque Val] -> Int -> Deque Val
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
                    e :: Deque Val
e = [Deque Val]
pool [Deque Val] -> Int -> Deque Val
forall a. HasCallStack => [a] -> Int -> a
!! (Int -> Int
r Int
1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8)
                    n :: Int
n = Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
d
                    full :: Bool
full = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3000 Bool -> Bool -> Bool
|| Int -> Int
r Int
2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
16 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                    pos :: Int
pos = case Int -> Int
r Int
3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4 of
                      Int
0 -> Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                      Int
1 -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                      Int
_ -> Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    op :: Int
op = Int -> Int
r Int
5 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
16
                    front :: Bool
front = Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Int
r Int
7)
                    times :: Int -> (Sq.Deque Val -> IO (Maybe (Sq.Deque Val))) -> Sq.Deque Val -> IO (Maybe (Sq.Deque Val))
                    times :: Int
-> (Deque Val -> IO (Maybe (Deque Val)))
-> Deque Val
-> IO (Maybe (Deque Val))
times Int
0 Deque Val -> IO (Maybe (Deque Val))
_ Deque Val
l = Maybe (Deque Val) -> IO (Maybe (Deque Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Deque Val -> Maybe (Deque Val)
forall a. a -> Maybe a
Just Deque Val
l)
                    times Int
k Deque Val -> IO (Maybe (Deque Val))
f Deque Val
l = Deque Val -> IO (Maybe (Deque Val))
f Deque Val
l IO (Maybe (Deque Val))
-> (Maybe (Deque Val) -> IO (Maybe (Deque Val)))
-> IO (Maybe (Deque Val))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe (Deque Val))
-> (Deque Val -> IO (Maybe (Deque Val)))
-> Maybe (Deque Val)
-> IO (Maybe (Deque Val))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe (Deque Val) -> IO (Maybe (Deque Val))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Deque Val)
forall a. Maybe a
Nothing) (Int
-> (Deque Val -> IO (Maybe (Deque Val)))
-> Deque Val
-> IO (Maybe (Deque Val))
times (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Deque Val -> IO (Maybe (Deque Val))
f)
                Maybe (Deque Val)
res <-
                  if
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 -> Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
push Bool
full Bool
True Int
step Deque Val
d
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 -> Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
push Bool
full Bool
False Int
step Deque Val
d
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> Bool -> Bool -> Deque Val -> IO (Maybe (Deque Val))
view Bool
full Bool
True Deque Val
d
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> Bool -> Bool -> Deque Val -> IO (Maybe (Deque Val))
view Bool
full Bool
False Deque Val
d
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 -> Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
cut Bool
full Bool
True Int
pos Deque Val
d
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
7 -> Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
cut Bool
full Bool
False Int
pos Deque Val
d
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 -> ((Deque Val, Deque Val) -> Deque Val)
-> Maybe (Deque Val, Deque Val) -> Maybe (Deque Val)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Deque Val, Deque Val) -> Deque Val
forall a b. (a, b) -> a
fst (Maybe (Deque Val, Deque Val) -> Maybe (Deque Val))
-> IO (Maybe (Deque Val, Deque Val)) -> IO (Maybe (Deque Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val, Deque Val))
split Bool
full Bool
True Int
pos Deque Val
d
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9 -> ((Deque Val, Deque Val) -> Deque Val)
-> Maybe (Deque Val, Deque Val) -> Maybe (Deque Val)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Deque Val, Deque Val) -> Deque Val
forall a b. (a, b) -> b
snd (Maybe (Deque Val, Deque Val) -> Maybe (Deque Val))
-> IO (Maybe (Deque Val, Deque Val)) -> IO (Maybe (Deque Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val, Deque Val))
split Bool
full Bool
False Int
pos Deque Val
d
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
11 -> if Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Deque Val -> Int
forall a. Deque a -> Int
Sq.length Deque Val
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
400000 then Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
cut Bool
full Bool
True (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
50) Deque Val
d else Bool -> Deque Val -> Deque Val -> IO (Maybe (Deque Val))
cat Bool
full Deque Val
d Deque Val
e
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
12 -> (\Bool
good -> if Bool
good then Deque Val -> Maybe (Deque Val)
forall a. a -> Maybe a
Just Deque Val
d else Maybe (Deque Val)
forall a. Maybe a
Nothing) (Bool -> Maybe (Deque Val)) -> IO Bool -> IO (Maybe (Deque Val))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deque Val -> Int -> IO Bool
at Deque Val
d Int
pos
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
13 -> Int
-> (Deque Val -> IO (Maybe (Deque Val)))
-> Deque Val
-> IO (Maybe (Deque Val))
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
300) (Bool -> Bool -> Deque Val -> IO (Maybe (Deque Val))
view (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) Bool
front) Deque Val
d
                    | Bool
otherwise -> Int
-> (Deque Val -> IO (Maybe (Deque Val)))
-> Deque Val
-> IO (Maybe (Deque Val))
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
300) (Bool -> Bool -> Int -> Deque Val -> IO (Maybe (Deque Val))
push (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) Bool
front Int
step) Deque Val
d
                case Maybe (Deque Val)
res of
                  Maybe (Deque Val)
Nothing -> Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the list helpers' test failed at step " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (operation " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
op [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" on a list of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements)"))
                  Just Deque Val
d' -> Int -> [Deque Val] -> IO (Either [Char] ())
stress (Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> [Deque Val] -> [Deque Val]
forall a. Int -> [a] -> [a]
take Int
i [Deque Val]
pool [Deque Val] -> [Deque Val] -> [Deque Val]
forall a. [a] -> [a] -> [a]
++ [Deque Val
d'] [Deque Val] -> [Deque Val] -> [Deque Val]
forall a. [a] -> [a] -> [a]
++ Int -> [Deque Val] -> [Deque Val]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Deque Val]
pool)
      Either [Char] [Int]
r <- [IO (Either [Char] Int)] -> IO (Either [Char] [Int])
forall a. [IO (Either [Char] a)] -> IO (Either [Char] [a])
firstLeft ((Deque Val -> IO (Either [Char] Int))
-> [Deque Val] -> [IO (Either [Char] Int)]
forall a b. (a -> b) -> [a] -> [b]
map Deque Val -> IO (Either [Char] Int)
check [Deque Val]
samples)
      Either [Char] [()]
r2 <- [IO (Either [Char] ())] -> IO (Either [Char] [()])
forall a. [IO (Either [Char] a)] -> IO (Either [Char] [a])
firstLeft ([Bool -> IO (Either [Char] ())
forall {a}. IsString a => Bool -> IO (Either a ())
grow Bool
True, Bool -> IO (Either [Char] ())
forall {a}. IsString a => Bool -> IO (Either a ())
grow Bool
False] [IO (Either [Char] ())]
-> [IO (Either [Char] ())] -> [IO (Either [Char] ())]
forall a. [a] -> [a] -> [a]
++ [IO (Either [Char] ())]
appends [IO (Either [Char] ())]
-> [IO (Either [Char] ())] -> [IO (Either [Char] ())]
forall a. [a] -> [a] -> [a]
++ [IO (Either [Char] ())]
lits)
      Either [Char] ()
r3 <- if Int
steps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> [Deque Val] -> IO (Either [Char] ())
stress Int
0 (Int -> Deque Val -> [Deque Val]
forall a. Int -> a -> [a]
replicate Int
8 Deque Val
forall a. Deque a
Sq.empty) else Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either [Char] ()
forall a b. b -> Either a b
Right ())
      pure $ case (Either [Char] [Int]
r, Either [Char] [()]
r2, Either [Char] ()
r3) of
        (Left [Char]
e, Either [Char] [()]
_, Either [Char] ()
_) -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e
        (Either [Char] [Int]
_, Left [Char]
e, Either [Char] ()
_) -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e
        (Either [Char] [Int]
_, Either [Char] [()]
_, Left [Char]
e) -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e
        (Right [Int]
kinds, Either [Char] [()]
_, Either [Char] ()
_)
          | (Int -> Int -> Int) -> Int -> [Int] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Bits a => a -> a -> a
(.|.) Int
0 [Int]
kinds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
15 -> [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the list samples don't cover every constructor (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ((Int -> Int -> Int) -> Int -> [Int] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Bits a => a -> a -> a
(.|.) Int
0 [Int]
kinds) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")
          | Bool
otherwise -> () -> Either [Char] ()
forall a b. b -> Either a b
Right ()

-- | Text: the same for the text helpers. Each helper is run against the
-- Haskell operation on texts of many shapes (one chunk, deep ropes, several
-- bytes per character), and every text a helper builds is checked for its
-- structure too.
--
-- @steps@ (stress mode @texts=N@) adds the longer test, as for lists: that
-- many random operations, each done by a helper on the results of earlier
-- ones and compared with the Haskell operation.
probeTexts :: Layouts -> Int -> IO (Either String ())
probeTexts :: Layouts -> Int -> IO (Either [Char] ())
probeTexts Layouts
ls Int
steps = do
  let wrap :: UText.Text -> Any
      wrap :: Text -> Any
wrap Text
t = Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! Text -> Closure
TextC Text
t
      put :: MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
      put :: MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray (PrimState IO) Any
a Int
i Any
v = Any -> IO Any
forall a. a -> IO a
evaluate Any
v IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray (PrimState IO) Any
a Int
i
      !abc :: Text
abc = [Char] -> Text
UText.pack [Char]
"abc"
      !first :: Any
first = Text -> Any
wrap Text
abc
      same :: Closure -> Closure -> Bool
same Closure
a Closure
b = Closure -> Val
BoxedVal Closure
a Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Closure -> Val
BoxedVal Closure
b
      PackedTag Word64
someTag = PackedTag
TT.someTag
      PackedTag Word64
pairTag = PackedTag
TT.pairTag
      PackedTag Word64
rightTag = PackedTag
TT.rightTag
      !none :: Closure
none = Reference -> PackedTag -> Closure
Enum Reference
Ty.optionalRef PackedTag
TT.noneTag
      unitVal :: Val
unitVal = Closure -> Val
BoxedVal (Reference -> PackedTag -> Closure
Enum Reference
Ty.unitRef PackedTag
TT.unitTag)
      -- the pair (x, y) as the interpreter builds it
      tup2 :: Val -> Val -> Closure
tup2 Val
x Val
y = Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef PackedTag
TT.pairTag Val
x (Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef PackedTag
TT.pairTag Val
y Val
unitVal))
      some :: Val -> Closure
some = Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.optionalRef PackedTag
TT.someTag
      textC :: Text -> Closure
textC = Text -> Closure
TextC
      chars :: Text -> [Char]
chars Text
t = Text -> [Char]
UText.toString Text
t
      -- readIntegral and readi of Machine/Primops.hs
      readClamped :: forall n. (Bounded n, Integral n) => String -> Maybe n
      readClamped :: forall n. (Bounded n, Integral n) => [Char] -> Maybe n
readClamped [Char]
str = case [Char] -> Maybe Integer
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
str :: Maybe Integer of
        Just Integer
i | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= n -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (n
forall a. Bounded a => a
minBound :: n), Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= n -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (n
forall a. Bounded a => a
maxBound :: n) -> n -> Maybe n
forall a. a -> Maybe a
Just (Integer -> n
forall a. Num a => Integer -> a
fromInteger Integer
i)
        Maybe Integer
_ -> Maybe n
forall a. Maybe a
Nothing
      readI :: [Char] -> Maybe Int
readI (Char
'+' : [Char]
str) = [Char] -> Maybe Int
forall n. (Bounded n, Integral n) => [Char] -> Maybe n
readClamped [Char]
str :: Maybe Int
      readI [Char]
str = [Char] -> Maybe Int
forall n. (Bounded n, Integral n) => [Char] -> Maybe n
readClamped [Char]
str
      -- two chunks with more characters than this between them stay two
      th :: Int
th = Int
Rope.threshold
      pieces :: [[Char]]
pieces = [[Char]
"", [Char]
"a", [Char]
"abc", [Char]
"h\233llo w\246rld", [Char]
"\8364\128512x\128512", [Char]
"0123456789abcdef", Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
'x', Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
th Char
'y', Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Char
'z', [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [Char] -> [[Char]]
forall a. Int -> a -> [a]
replicate Int
40 [Char]
"\955x"), Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate Int
600 Char
'q']
      base :: [Text]
base = ([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
UText.pack [[Char]]
pieces
      -- ropes with structure: built up piece by piece from either side, by
      -- repetition, and cut; `chunky` is in chunks too big to be joined, so
      -- it has the most levels for its size
      grown :: [Text]
grown = [(Text -> Int -> Text) -> Text -> [Int] -> Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Text
acc Int
i -> Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
UText.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i)) Text
forall a. Monoid a => a
mempty [Int
1 .. Int
n :: Int] | Int
n <- [Int
5, Int
40, Int
300]]
      grownL :: [Text]
grownL = [(Text -> Int -> Text) -> Text -> [Int] -> Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Text
acc Int
i -> [Char] -> Text
UText.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
acc) Text
forall a. Monoid a => a
mempty [Int
1 .. Int
n :: Int] | Int
n <- [Int
40, Int
300]]
      big :: Text
big = Int -> Text -> Text
UText.replicate Int
2000 ([Char] -> Text
UText.pack [Char]
"a\233")
      chunky :: Text
chunky = (Text -> Int -> Text) -> Text -> [Int] -> Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Text
acc Int
i -> Text
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
UText.pack (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (Int
th Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7) ([Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
cycle [Char]
"0123456789\955abcdefghij")))) Text
forall a. Monoid a => a
mempty [Int
1 .. Int
260 :: Int]
      samples :: [Text]
samples = [Text]
base [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
grown [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
grownL [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
big, Int -> Text -> Text
UText.drop Int
7 Text
big, Int -> Text -> Text
UText.take Int
1500 Text
big, Int -> Text -> Text
UText.drop Int
100 ([Text]
grown [Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
!! Int
2), Int -> Text -> Text
UText.take Int
400 ([Text]
grownL [Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
!! Int
1), Text
chunky, Int -> Text -> Text
UText.drop Int
1000 Text
chunky]
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
12 Any
first :: IO (MutableArray (PrimState IO) Any)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Text -> Any
wrap ([Char] -> Text
UText.pack (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Char
'a') Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
UText.pack (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Char
'b')))
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
2 (Text -> Any
wrap Text
UText.empty)
  -- the constructors the helpers build results from (see rope_test)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
4 (Closure -> Any
forall a. a -> Any
any' Closure
none)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
5 (Closure -> Any
forall a. a -> Any
any' (Reference -> PackedTag -> Closure
Enum Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
0)))
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
6 (Closure -> Any
forall a. a -> Any
any' (Reference -> PackedTag -> Closure
Enum Reference
Ty.unitRef PackedTag
TT.unitTag))
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
7 (Closure -> Any
forall a. a -> Any
any' (Reference -> PackedTag -> Closure
Enum Reference
Ty.eitherRef (Word64 -> PackedTag
PackedTag Word64
0)))
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
8 (Closure -> Any
forall a. a -> Any
any' Closure
charTypeTag)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
9 (Closure -> Any
forall a. a -> Any
any' Closure
natTypeTag)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
10 (Closure -> Any
forall a. a -> Any
any' Closure
intTypeTag)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
11 (Closure -> Any
forall a. a -> Any
any' Closure
floatTypeTag)
  let Pair Int
textInfo Int
textTag = Layouts -> Pair Int Int
lText Layouts
ls
  Int
ok <- MutableArray (PrimState IO) Any -> [Int] -> IO Int
textInit MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr [Int
textInfo, Int
th, Int
0, Int
textTag, Int
By.slackStart, Int
By.slackMax]
  if Int
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
    then Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the text constructors are not laid out as the JIT's helpers expect (check " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ok [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"))
    else do
      let slot3 :: IO Closure
          slot3 :: IO Closure
slot3 = Any -> Closure
forall a b. a -> b
unsafeCoerce (Any -> Closure) -> IO Any -> IO Closure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray (PrimState IO) Any -> Int -> IO Any
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3
          result :: IO (Maybe UText.Text)
          result :: IO (Maybe Text)
result = do
            Closure
c <- IO Closure
slot3
            Bool
good <- do
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c)
              MutableArray (PrimState IO) Any -> IO Bool
textCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
            pure $ case Closure
c of
              TextC Text
t | Bool
good -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
              Closure
_ -> Maybe Text
forall a. Maybe a
Nothing
          -- a text inside a result: laid out right and the expected one
          textIn :: Closure -> UText.Text -> IO Bool
          textIn :: Closure -> Text -> IO Bool
textIn Closure
c Text
expected = case Closure
c of
            TextC Text
t | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expected -> MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MutableArray (PrimState IO) Any -> IO Bool
textCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
            Closure
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          one :: UText.Text -> IO [String]
          one :: Text -> IO [[Char]]
one Text
t = do
            let n :: Int
n = Text -> Int
UText.size Text
t
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
            Bool
shape <- MutableArray (PrimState IO) Any -> IO Bool
textCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
            Int
size <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 Int
0 Int
0 Int
0
            [Bool]
cuts <- [Int] -> (Int -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([-Int
1 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n (if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
600 then Int
12 else Int
70)] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [(Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
j) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
13 | Int
j <- [Int
1 .. Int
12], Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
600] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]) ((Int -> IO Bool) -> IO [Bool]) -> (Int -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
k -> do
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
              Int
h1 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 Int
k Int
0 Int
0
              Maybe Text
r1 <- IO (Maybe Text)
result
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
              Int
h2 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
2 Int
k Int
0 Int
0
              Maybe Text
r2 <- IO (Maybe Text)
result
              -- a negative count is a Nat too large to be a size
              let tk :: Text
tk = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Text
t else Int -> Text -> Text
UText.take Int
k Text
t
                  dr :: Text
dr = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Text
UText.empty else Int -> Text -> Text
UText.drop Int
k Text
t
              pure (Int
h1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Text
r1 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
tk Bool -> Bool -> Bool
&& Int
h2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Text
r2 Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
dr)
            -- uncons and unsnoc: Some (c, rest) / Some (rest, c), the rest laid out right
            [Bool]
uns <- [Bool] -> (Bool -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Bool
True, Bool
False] ((Bool -> IO Bool) -> IO [Bool]) -> (Bool -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Bool
front -> do
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
              Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr (if Bool
front then Int
5 else Int
6) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
pairTag) Int
0
              Closure
c <- IO Closure
slot3
              let expected :: Closure
expected
                    | Bool
front = Closure
-> ((Char, Text) -> Closure) -> Maybe (Char, Text) -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (\(Char
ch, Text
rest) -> Val -> Closure
some (Closure -> Val
BoxedVal (Val -> Val -> Closure
tup2 (Char -> Val
CharVal Char
ch) (Closure -> Val
BoxedVal (Text -> Closure
textC Text
rest))))) (Text -> Maybe (Char, Text)
UText.uncons Text
t)
                    | Bool
otherwise = Closure
-> ((Text, Char) -> Closure) -> Maybe (Text, Char) -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (\(Text
rest, Char
ch) -> Val -> Closure
some (Closure -> Val
BoxedVal (Val -> Val -> Closure
tup2 (Closure -> Val
BoxedVal (Text -> Closure
textC Text
rest)) (Char -> Val
CharVal Char
ch)))) (Text -> Maybe (Text, Char)
UText.unsnoc Text
t)
              Bool
restOk <- case Closure
c of
                Data1 Reference
_ PackedTag
_ (BoxedVal (Data2 Reference
_ PackedTag
_ Val
a (BoxedVal (Data2 Reference
_ PackedTag
_ Val
b Val
_))))
                  | BoxedVal Closure
r <- if Bool
front then Val
b else Val
a -> MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
r) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MutableArray (PrimState IO) Any -> IO Bool
textCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
                Closure
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
              pure (Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Closure -> Closure -> Bool
same Closure
c Closure
expected Bool -> Bool -> Bool
&& Bool
restOk)
            -- the rest only on the smaller texts, to keep every startup cheap (the
            -- random test covers the big ones): toCharList then fromCharList of
            -- that, reverse, the case mappings (ASCII only), repeat
            let small :: Bool
small = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1500
            (Int
hu, Closure
cu, Closure
charList) <-
              if Bool
small
                then do
                  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
                  Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
14 Int
0 Int
0 Int
0
                  Closure
c <- IO Closure
slot3
                  pure (Int
h, Closure
c, Deque Val -> Closure
ListC ([Val] -> Deque Val
forall a. [a] -> Deque a
Sq.fromList ((Char -> Val) -> [Char] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Val
CharVal (Text -> [Char]
chars Text
t))))
                else (Int, Closure, Closure) -> IO (Int, Closure, Closure)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Closure
none, Closure
none)
            (Int
hp, Maybe Text
rp) <-
              if Bool
small
                then do
                  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
charList)
                  Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
13 Int
0 Int
0 Int
0
                  Maybe Text
r <- IO (Maybe Text)
result
                  pure (Int
h, Maybe Text
r)
                else (Int, Maybe Text) -> IO (Int, Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t)
            (Int
hr, Maybe Text
rr) <-
              if Bool
small
                then do
                  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
                  Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
18 Int
0 Int
0 Int
0
                  Maybe Text
r <- IO (Maybe Text)
result
                  pure (Int
h, Maybe Text
r)
                else (Int, Maybe Text) -> IO (Int, Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
1, Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
UText.reverse Text
t))
            [Bool]
cases <- [(Int, Text -> Text)]
-> ((Int, Text -> Text) -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int
19, Text -> Text
UText.toUppercase), (Int
20, Text -> Text
UText.toLowercase)] (((Int, Text -> Text) -> IO Bool) -> IO [Bool])
-> ((Int, Text -> Text) -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \(Int
op, Text -> Text
f) ->
              if Bool -> Bool
not Bool
small
                then Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                else do
                  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
                  Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
op Int
0 Int
0 Int
0
                  Maybe Text
r <- IO (Maybe Text)
result
                  pure (if Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Maybe Text
r Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
f Text
t) else (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'\128') (Text -> [Char]
chars Text
t))
            [Bool]
reps <- [Int] -> (Int -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (if Bool
small then [Int
0, Int
1, Int
2, Int
3, Int
7, Int
50] else [Int
0, Int
1, Int
2]) ((Int -> IO Bool) -> IO [Bool]) -> (Int -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
j -> do
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
              Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
17 Int
j Int
0 Int
0
              Maybe Text
r <- IO (Maybe Text)
result
              pure (Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Text
r Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (Int -> Text -> Text
UText.replicate Int
j Text
t))
            -- toUtf8, then fromUtf8 of that
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
            Int
h8 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
21 Int
0 Int
0 Int
0
            Closure
c8 <- IO Closure
slot3
            Bool
utf <- case Closure
c8 of
              BytesC Bytes
bs
                | Int
h8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
                  Bytes
bs Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Bytes
UText.toUtf8 Text
t -> do
                    MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c8)
                    Bool
okB <- MutableArray (PrimState IO) Any -> IO Bool
bytesCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
                    MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c8)
                    Int
h9 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
22 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
rightTag) Int
0 Int
0
                    Closure
c9 <- IO Closure
slot3
                    Bool
okT <- case Closure
c9 of
                      Data1 Reference
rf PackedTag
tg (BoxedVal Closure
inner) | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Ty.eitherRef, PackedTag
tg PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.rightTag -> Closure -> Text -> IO Bool
textIn Closure
inner Text
t
                      Closure
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                    pure (Bool
okB Bool -> Bool -> Bool
&& Int
h9 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Bool
okT)
              Closure
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]])
-> ([Maybe [Char]] -> [[Char]]) -> [Maybe [Char]] -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]] -> IO [[Char]]) -> [Maybe [Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$
              [ if Bool
shape then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"a text isn't laid out as expected",
                if Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Text.size differs from the interpreter's",
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
cuts then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.take or Text.drop differs from the interpreter's on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" characters"),
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
uns then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.uncons or Text.unsnoc differs from the interpreter's on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if Int
hu Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Closure -> Closure -> Bool
same Closure
cu Closure
charList then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.toCharList differs from the interpreter's on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if Int
hp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Text
rp Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.fromCharList differs from the interpreter's on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if Int
hr Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Text
rr Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
UText.reverse Text
t) then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.reverse differs from the interpreter's on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
cases then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.toUppercase or toLowercase differs from the interpreter's on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
reps then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.repeat differs from the interpreter's on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if Bool
utf then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.toUtf8 or Text.fromUtf8 differs from the interpreter's on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
              ]
          two :: UText.Text -> UText.Text -> IO [String]
          two :: Text -> Text -> IO [[Char]]
two Text
a Text
b = do
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
a)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Text -> Any
wrap Text
b)
            Int
eq <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
4 Int
0 Int
0 Int
0
            Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 Int
0 Int
0 Int
0
            Maybe Text
r <- IO (Maybe Text)
result
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
a)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Text -> Any
wrap Text
b)
            Int
hi <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
15 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag) Int
0 Int
0
            Closure
ci <- IO Closure
slot3
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
a)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Text -> Any
wrap Text
b)
            Int
cm <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
16 Int
0 Int
0 Int
0
            let expI :: Closure
expI = Closure -> (Word64 -> Closure) -> Maybe Word64 -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (Val -> Closure
some (Val -> Closure) -> (Word64 -> Val) -> Word64 -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Val
NatVal) (Text -> Text -> Maybe Word64
UText.indexOf Text
a Text
b)
                expC :: Int
expC = case Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Text
a Text
b of Ordering
LT -> -Int
1; Ordering
EQ -> Int
0; Ordering
GT -> Int
1
            [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]])
-> ([Maybe [Char]] -> [[Char]]) -> [Maybe [Char]] -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]] -> IO [[Char]]) -> [Maybe [Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$
              [ if Int
eq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (if Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
b then Int
1 else Int
0) then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Text equality differs from the interpreter's",
                if Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Text
r Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b) then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Text.++ differs from the interpreter's on texts of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
UText.size Text
a) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" and " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Int
UText.size Text
b) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" characters"),
                if Int
hi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Closure -> Closure -> Bool
same Closure
ci Closure
expI then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Text.indexOf differs from the interpreter's",
                if Int
cm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expC then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Text comparison differs from the interpreter's"
              ]
          -- the longer test: random operations on eight texts
          mix :: Int -> Int
          mix :: Int -> Int
mix Int
z0 =
            let z1 :: Int
z1 = (Int
z0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z0 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
30)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (-Int
4658895280553007687)
                z2 :: Int
z2 = (Int
z1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
27)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (-Int
7723592293110705685)
             in (Int
z2 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z2 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
31)) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
forall a. Bounded a => a
maxBound
          letters :: [Char]
letters = [Char] -> [Char]
forall a. HasCallStack => [a] -> [a]
cycle [Char]
"abcd\233fghij\8364klmnop\128512qrstuvwxyz0123456789\955"
          stress :: Int -> [UText.Text] -> IO (Either String ())
          stress :: Int -> [Text] -> IO (Either [Char] ())
stress Int
step [Text]
pool
            | Int
step Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
steps = Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either [Char] ()
forall a b. b -> Either a b
Right ())
            | Bool
otherwise = do
                let r :: Int -> Int
r Int
k = Int -> Int
mix (Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k)
                    i :: Int
i = Int -> Int
r Int
0 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8
                    t :: Text
t = [Text]
pool [Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
                    e :: Text
e = [Text]
pool [Text] -> Int -> Text
forall a. HasCallStack => [a] -> Int -> a
!! (Int -> Int
r Int
1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8)
                    n :: Int
n = Text -> Int
UText.size Text
t
                    full :: Bool
full = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3000 Bool -> Bool -> Bool
|| Int -> Int
r Int
2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
16 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                    pos :: Int
pos = case Int -> Int
r Int
3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4 of
                      Int
0 -> Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                      Int
1 -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                      Int
_ -> Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    op :: Int
op = Int -> Int
r Int
5 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
18
                    piece :: Int -> Text
piece Int
k = [Char] -> Text
UText.pack (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take (Int -> Int
r Int
k Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (if Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Int
r (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) then Int
7 else Int
90)) (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop (Int -> Int
r (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) [Char]
letters))
                    -- what a helper built, if it is laid out right and is the expected text
                    -- (the characters are compared when `whole`; the size always)
                    verdict :: Bool -> Int -> UText.Text -> IO (Maybe UText.Text)
                    verdict :: Bool -> Int -> Text -> IO (Maybe Text)
verdict Bool
whole Int
h Text
expected = do
                      Maybe Text
got <- IO (Maybe Text)
result
                      pure $ case Maybe Text
got of
                        Just Text
g | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1, Text -> Int
UText.size Text
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Int
UText.size Text
expected, Bool -> Bool
not Bool
whole Bool -> Bool -> Bool
|| Text
g Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expected -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
g
                        Maybe Text
_ -> Maybe Text
forall a. Maybe a
Nothing
                    cat :: Bool -> Text -> Text -> IO (Maybe Text)
cat Bool
whole Text
a Text
b = do
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
a)
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Text -> Any
wrap Text
b)
                      Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 Int
0 Int
0 Int
0
                      Bool -> Int -> Text -> IO (Maybe Text)
verdict Bool
whole Int
h (Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b)
                    cut :: Bool -> Bool -> Int -> Text -> IO (Maybe Text)
cut Bool
whole Bool
tk Int
k Text
x = do
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
x)
                      Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr (if Bool
tk then Int
1 else Int
2) Int
k Int
0 Int
0
                      Bool -> Int -> Text -> IO (Maybe Text)
verdict Bool
whole Int
h (if Bool
tk then (if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Text
x else Int -> Text -> Text
UText.take Int
k Text
x) else (if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Text
UText.empty else Int -> Text -> Text
UText.drop Int
k Text
x))
                    same :: Text -> Text -> IO Bool
same Text
a Text
b = do
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
a)
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Text -> Any
wrap Text
b)
                      Int
eq <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
4 Int
0 Int
0 Int
0
                      pure (Int
eq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (if Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
b then Int
1 else Int
0))
                    times :: Int -> (UText.Text -> IO (Maybe UText.Text)) -> UText.Text -> IO (Maybe UText.Text)
                    times :: Int -> (Text -> IO (Maybe Text)) -> Text -> IO (Maybe Text)
times Int
0 Text -> IO (Maybe Text)
_ Text
x = Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x)
                    times Int
k Text -> IO (Maybe Text)
f Text
x = Text -> IO (Maybe Text)
f Text
x IO (Maybe Text)
-> (Maybe Text -> IO (Maybe Text)) -> IO (Maybe Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe Text)
-> (Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing) (Int -> (Text -> IO (Maybe Text)) -> Text -> IO (Maybe Text)
times (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text -> IO (Maybe Text)
f)
                Maybe Text
res <-
                  if
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 -> Bool -> Text -> Text -> IO (Maybe Text)
cat Bool
full Text
t (Int -> Text
piece Int
6)
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 -> Bool -> Text -> Text -> IO (Maybe Text)
cat Bool
full (Int -> Text
piece Int
6) Text
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> Bool -> Bool -> Int -> Text -> IO (Maybe Text)
cut Bool
full Bool
True Int
pos Text
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> Bool -> Bool -> Int -> Text -> IO (Maybe Text)
cut Bool
full Bool
False Int
pos Text
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 -> Bool -> Bool -> Int -> Text -> IO (Maybe Text)
cut Bool
full Bool
False Int
pos Text
t IO (Maybe Text)
-> (Maybe Text -> IO (Maybe Text)) -> IO (Maybe Text)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe Text)
-> (Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing) (Bool -> Bool -> Int -> Text -> IO (Maybe Text)
cut Bool
full Bool
True (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
200))
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 -> if Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
UText.size Text
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
60000 then Bool -> Bool -> Int -> Text -> IO (Maybe Text)
cut Bool
full Bool
True (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
50) Text
t else Bool -> Text -> Text -> IO (Maybe Text)
cat Bool
full Text
t Text
e
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9 -> do
                        -- the same text cut into chunks differently, and another text
                        Bool
a <- Text -> Text -> IO Bool
same Text
t (Int -> Text -> Text
UText.take Int
pos Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
UText.drop Int
pos Text
t)
                        Bool
b <- Text -> Text -> IO Bool
same Text
t Text
e
                        Bool
c <- if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Text -> Text -> IO Bool
same Text
t (Int -> Text -> Text
UText.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
piece Int
9) else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                        pure (if Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t else Maybe Text
forall a. Maybe a
Nothing)
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 -> Int -> (Text -> IO (Maybe Text)) -> Text -> IO (Maybe Text)
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) (\Text
x -> Bool -> Text -> Text -> IO (Maybe Text)
cat (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) Text
x (Int -> Text
piece Int
9)) Text
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
11 -> Int -> (Text -> IO (Maybe Text)) -> Text -> IO (Maybe Text)
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) (\Text
x -> Bool -> Text -> Text -> IO (Maybe Text)
cat (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) (Int -> Text
piece Int
9) Text
x) Text
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
12 -> Int -> (Text -> IO (Maybe Text)) -> Text -> IO (Maybe Text)
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) (Bool -> Bool -> Int -> Text -> IO (Maybe Text)
cut (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) Bool
False Int
1) Text
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
13 -> Int -> (Text -> IO (Maybe Text)) -> Text -> IO (Maybe Text)
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) (\Text
x -> Bool -> Bool -> Int -> Text -> IO (Maybe Text)
cut (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) Bool
True (Text -> Int
UText.size Text
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
x) Text
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
14 -> do
                        MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
                        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
18 Int
0 Int
0 Int
0
                        Bool -> Int -> Text -> IO (Maybe Text)
verdict Bool
full Int
h (Text -> Text
UText.reverse Text
t)
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
15 -> do
                        -- toCharList, then fromCharList
                        MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
                        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
14 Int
0 Int
0 Int
0
                        Closure
c <- IO Closure
slot3
                        case Closure
c of
                          ListC Deque Val
_ | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> do
                            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c)
                            Int
h2 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
13 Int
0 Int
0 Int
0
                            Bool -> Int -> Text -> IO (Maybe Text)
verdict Bool
full Int
h2 Text
t
                          Closure
_ -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 -> do
                        -- toUtf8, then fromUtf8
                        MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
                        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
21 Int
0 Int
0 Int
0
                        Closure
c <- IO Closure
slot3
                        case Closure
c of
                          BytesC Bytes
_ | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> do
                            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c)
                            Int
h2 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
22 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
rightTag) Int
0 Int
0
                            Closure
c2 <- IO Closure
slot3
                            case Closure
c2 of
                              Data1 Reference
_ PackedTag
_ (BoxedVal Closure
inner) | Int
h2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 (Closure -> Any
forall a. a -> Any
any' Closure
inner) IO () -> IO (Maybe Text) -> IO (Maybe Text)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Int -> Text -> IO (Maybe Text)
verdict Bool
full Int
1 Text
t
                              Closure
_ -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
                          Closure
_ -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
                    | Bool
otherwise -> do
                        -- uncons or unsnoc: the rest goes on
                        let front :: Bool
front = Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Int
r Int
6)
                        MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t)
                        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr (if Bool
front then Int
5 else Int
6) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
pairTag) Int
0
                        Closure
c <- IO Closure
slot3
                        case Closure
c of
                          Data1 Reference
_ PackedTag
_ (BoxedVal (Data2 Reference
_ PackedTag
_ Val
a (BoxedVal (Data2 Reference
_ PackedTag
_ Val
b Val
_))))
                            | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1,
                              BoxedVal Closure
rest <- if Bool
front then Val
b else Val
a ->
                                MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 (Closure -> Any
forall a. a -> Any
any' Closure
rest) IO () -> IO (Maybe Text) -> IO (Maybe Text)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Int -> Text -> IO (Maybe Text)
verdict Bool
full Int
1 (if Bool
front then Int -> Text -> Text
UText.drop Int
1 Text
t else Int -> Text -> Text
UText.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
t)
                          Closure
_ -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t else Maybe Text
forall a. Maybe a
Nothing)
                case Maybe Text
res of
                  Maybe Text
Nothing -> Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the text helpers' test failed at step " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (operation " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
op [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" on a text of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" characters)"))
                  Just Text
t' -> Int -> [Text] -> IO (Either [Char] ())
stress (Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
i [Text]
pool [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
t'] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Text]
pool)
      [[Char]]
e1 <- [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO [[Char]]) -> [Text] -> IO [[[Char]]]
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 Text -> IO [[Char]]
one [Text]
samples
      -- equal texts cut into chunks differently must compare equal
      let recut :: Text -> Text
recut Text
t = Int -> Text -> Text
UText.take Int
3 Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
UText.drop Int
3 Text
t
          -- (sized to cost little at every startup, like the list checks;
          -- the thorough test is the longer one)
          some3 :: [Text]
some3 = [Text
t | (Int
j, Text
t) <- [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Text]
samples, Int
j Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0]
      [[Char]]
e2 <- [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO [[Char]]] -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Text -> Text -> IO [[Char]]
two Text
a Text
b | Text
a <- [Text]
some3, Text
b <- [Text]
some3] [IO [[Char]]] -> [IO [[Char]]] -> [IO [[Char]]]
forall a. [a] -> [a] -> [a]
++ [Text -> Text -> IO [[Char]]
two Text
t (Text -> Text
recut Text
t) | Text
t <- [Text]
samples])
      -- numbers to text and back, and Char.toText
      let ints :: [Int]
ints = [Int
0, Int
1, -Int
1, Int
42, -Int
42, Int
1000000007, Int
forall a. Bounded a => a
minBound, Int
forall a. Bounded a => a
maxBound, Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
62 :: Int), Int -> Int
forall a. Num a => a -> a
negate (Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
62 :: Int))] :: [Int]
          nats :: [Word64]
nats = [Word64
0, Word64
1, Word64
255, Word64
256, Word64
2 Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
32 :: Int), Word64
forall a. Bounded a => a
maxBound, Word64
forall a. Bounded a => a
maxBound Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1, Word64
2 Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
63 :: Int)] :: [Word64]
          floats :: [Double]
floats =
            [Double
0, -Double
0.0, Double
1, -Double
1, Double
0.1, Double
0.5, Double
1.5, Double
100, Double
1234567, Double
9999999, Double
10000000, Double
12345678.9, Double
0.01, Double
123456.789, Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
3, Double
forall a. Floating a => a
pi, Double
1e22, Double
1e21, Double
1e-10, Double
2 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (-Double
30), Double
5e-324, Double
1.7976931348623157e308, Double
2.2250738585072014e-308, Double
0.3, Double
2.5e-5, Double
123e300, Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0, -Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0, Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0, Double
4.35, Double
0.1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.2, Double
1e7, Double
9007199254740993, Double
65536 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
65536 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
65536, Double
0.09999999999999999, Double
1e-7, Double
123456789.123, Double
2 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Double
70, Double
2 Double -> Double -> Double
forall a. Floating a => a -> a -> a
** (-Double
70), Double
1.0e-45] ::
              [Double]
          parses :: [[Char]]
parses = [[Char]
"12", [Char]
"-12", [Char]
"+12", [Char]
"0", [Char]
"-0", [Char]
"9223372036854775807", [Char]
"9223372036854775808", [Char]
"-9223372036854775808", [Char]
"-9223372036854775809", [Char]
"18446744073709551615", [Char]
"18446744073709551616", [Char]
"1.5", [Char]
"-1.5", [Char]
"1e3", [Char]
"1.", [Char]
".5", [Char]
"abc", [Char]
"", [Char]
"12a", [Char]
" 12", [Char]
"0x1F", [Char]
"1_000", [Char]
"007", [Char]
"1E5", [Char]
"1e", [Char]
"+", [Char]
"-", [Char]
"Infinity", [Char]
"NaN", [Char]
"1.0e-2", [Char]
"+1.5", [Char]
"00", [Char]
"1e400", [Char]
"-1e-400", [Char]
"123456789012345678901234567890", [Char]
"3.14159", [Char]
"1.5e+3", [Char]
"1e-3", [Char]
"0.000001", [Char]
"1.0e7", [Char]
"-", [Char]
"--1", [Char]
"1-"]
          -- the plain forms the helper must decide itself (the rest may go to the interpreter)
          mustParseInt :: [[Char]]
mustParseInt = [[Char]
"12", [Char]
"-12", [Char]
"+12", [Char]
"0", [Char]
"9223372036854775808", [Char]
"007"]
          mustParseFloat :: [[Char]]
mustParseFloat = [[Char]
"12", [Char]
"-12", [Char]
"0", [Char]
"1.5", [Char]
"-1.5", [Char]
"1e3", [Char]
"1.0e-2", [Char]
"3.14159", [Char]
"007"]
          numText :: a -> Maybe a -> a -> Bool
numText a
h Maybe a
r a
expected = a
h a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 Bool -> Bool -> Bool
&& Maybe a
r Maybe a -> Maybe a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Maybe a
forall a. a -> Maybe a
Just a
expected
      [Bool]
i2t <- [Int] -> (Int -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
ints ((Int -> IO Bool) -> IO [Bool]) -> (Int -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
v -> do
        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
7 Int
v Int
0 Int
0
        Maybe Text
r <- IO (Maybe Text)
result
        pure (Int -> Maybe Text -> Text -> Bool
forall {a} {a}. (Num a, Eq a, Eq a) => a -> Maybe a -> a -> Bool
numText Int
h Maybe Text
r ([Char] -> Text
UText.pack (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
v)))
      [Bool]
n2t <- [Word64] -> (Word64 -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word64]
nats ((Word64 -> IO Bool) -> IO [Bool])
-> (Word64 -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Word64
v -> do
        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
8 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v) Int
0 Int
0
        Maybe Text
r <- IO (Maybe Text)
result
        pure (Int -> Maybe Text -> Text -> Bool
forall {a} {a}. (Num a, Eq a, Eq a) => a -> Maybe a -> a -> Bool
numText Int
h Maybe Text
r ([Char] -> Text
UText.pack (Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
v)))
      [Bool]
f2t <- [Double] -> (Double -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Double]
floats ((Double -> IO Bool) -> IO [Bool])
-> (Double -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Double
v -> do
        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
9 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Word64
castDoubleToWord64 Double
v)) Int
0 Int
0
        Maybe Text
r <- IO (Maybe Text)
result
        pure (Int -> Maybe Text -> Text -> Bool
forall {a} {a}. (Num a, Eq a, Eq a) => a -> Maybe a -> a -> Bool
numText Int
h Maybe Text
r ([Char] -> Text
UText.pack (Double -> [Char]
forall a. Show a => a -> [Char]
show Double
v)))
      [Bool]
c2t <- [Char] -> (Char -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Char]
"a\233\8364\128512\0z" :: String) ((Char -> IO Bool) -> IO [Bool]) -> (Char -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Char
ch -> do
        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
23 (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
ch) Int
0 Int
0
        Maybe Text
r <- IO (Maybe Text)
result
        pure (Int -> Maybe Text -> Text -> Bool
forall {a} {a}. (Num a, Eq a, Eq a) => a -> Maybe a -> a -> Bool
numText Int
h Maybe Text
r ([Char] -> Text
UText.pack [Char
ch]))
      [Bool]
t2n <- [[Char]] -> ([Char] -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
parses (([Char] -> IO Bool) -> IO [Bool])
-> ([Char] -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \[Char]
sx -> do
        let t :: Text
t = [Char] -> Text
UText.pack [Char]
sx
            run :: Int -> IO (Int, Closure)
run Int
op = MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Text -> Any
wrap Text
t) IO () -> IO Int -> IO Int
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
textTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
op (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag) Int
0 Int
0 IO Int -> (Int -> IO (Int, Closure)) -> IO (Int, Closure)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
h -> (,) Int
h (Closure -> (Int, Closure)) -> IO Closure -> IO (Int, Closure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Closure
slot3
        (Int
hi, Closure
ci) <- Int -> IO (Int, Closure)
run Int
10
        (Int
hn, Closure
cn) <- Int -> IO (Int, Closure)
run Int
11
        (Int
hf, Closure
cf) <- Int -> IO (Int, Closure)
run Int
12
        let expI :: Closure
expI = Closure -> (Int -> Closure) -> Maybe Int -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (Val -> Closure
some (Val -> Closure) -> (Int -> Val) -> Int -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Val
IntVal) ([Char] -> Maybe Int
readI [Char]
sx)
            expN :: Closure
expN = Closure -> (Word64 -> Closure) -> Maybe Word64 -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (Val -> Closure
some (Val -> Closure) -> (Word64 -> Val) -> Word64 -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Val
NatVal) ([Char] -> Maybe Word64
forall n. (Bounded n, Integral n) => [Char] -> Maybe n
readClamped [Char]
sx :: Maybe Word64)
            expF :: Closure
expF = Closure -> (Double -> Closure) -> Maybe Double -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (Val -> Closure
some (Val -> Closure) -> (Double -> Val) -> Double -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Val
DoubleVal) ([Char] -> Maybe Double
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
sx :: Maybe Double)
            handled :: Bool
handled = ([Char]
sx [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
mustParseInt Bool -> Bool -> Bool
|| (Int
hi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
hn Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)) Bool -> Bool -> Bool
&& ([Char]
sx [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [[Char]]
mustParseFloat Bool -> Bool -> Bool
|| Int
hf Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
handled Bool -> Bool -> Bool
&& (Int
hi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 Bool -> Bool -> Bool
|| Closure -> Closure -> Bool
same Closure
ci Closure
expI) Bool -> Bool -> Bool
&& (Int
hn Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 Bool -> Bool -> Bool
|| Closure -> Closure -> Bool
same Closure
cn Closure
expN) Bool -> Bool -> Bool
&& (Int
hf Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1 Bool -> Bool -> Bool
|| Closure -> Closure -> Bool
same Closure
cf Closure
expF))
      let e3 :: [[Char]]
e3 =
            [[Char]
"Int.toText differs from the interpreter's" | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
i2t)]
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"Nat.toText differs from the interpreter's" | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
n2t)]
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"Float.toText differs from the interpreter's on " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Double] -> [Char]
forall a. Show a => a -> [Char]
show [Double
v | (Double
v, Bool
ok) <- [Double] -> [Bool] -> [(Double, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Double]
floats [Bool]
f2t, Bool -> Bool
not Bool
ok] | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
f2t)]
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"Char.toText differs from the interpreter's" | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
c2t)]
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"Text.toInt, toNat or toFloat differs from the interpreter's on " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]
sx | ([Char]
sx, Bool
ok) <- [[Char]] -> [Bool] -> [([Char], Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
parses [Bool]
t2n, Bool -> Bool
not Bool
ok] | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
t2n)]
      case [[Char]]
e1 [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
e2 [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
e3 of
        [Char]
e : [[Char]]
_ -> Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e)
        [] -> if Int
steps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> [Text] -> IO (Either [Char] ())
stress Int
0 (Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
8 Text
UText.empty) else Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either [Char] ()
forall a b. b -> Either a b
Right ())

-- | The bytes helpers: the same arrangement as 'probeTexts' for @Bytes@,
-- which is the same rope with chunks of bytes, plus @Bytes.at@ and
-- @Bytes.flatten@. Stress mode @bytes=N@.
probeBytes :: Layouts -> Int -> IO (Either String ())
probeBytes :: Layouts -> Int -> IO (Either [Char] ())
probeBytes Layouts
ls Int
steps = do
  let wrap :: By.Bytes -> Any
      wrap :: Bytes -> Any
wrap Bytes
b = Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! Bytes -> Closure
BytesC Bytes
b
      put :: MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
      put :: MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray (PrimState IO) Any
a Int
i Any
v = Any -> IO Any
forall a. a -> IO a
evaluate Any
v IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray (PrimState IO) Any
a Int
i
      bytes :: [Int] -> By.Bytes
      bytes :: [Int] -> Bytes
bytes = [Word8] -> Bytes
By.fromWord8s ([Word8] -> Bytes) -> ([Int] -> [Word8]) -> [Int] -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
      same :: Closure -> Closure -> Bool
same Closure
a Closure
b = Closure -> Val
BoxedVal Closure
a Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Closure -> Val
BoxedVal Closure
b
      PackedTag Word64
someTag = PackedTag
TT.someTag
      PackedTag Word64
pairTag = PackedTag
TT.pairTag
      PackedTag Word64
rightTag = PackedTag
TT.rightTag
      !none :: Closure
none = Reference -> PackedTag -> Closure
Enum Reference
Ty.optionalRef PackedTag
TT.noneTag
      unitVal :: Val
unitVal = Closure -> Val
BoxedVal (Reference -> PackedTag -> Closure
Enum Reference
Ty.unitRef PackedTag
TT.unitTag)
      tup2 :: Val -> Val -> Closure
tup2 Val
x Val
y = Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef PackedTag
TT.pairTag Val
x (Closure -> Val
BoxedVal (Reference -> PackedTag -> Val -> Val -> Closure
Data2 Reference
Ty.pairRef PackedTag
TT.pairTag Val
y Val
unitVal))
      some :: Val -> Closure
some = Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.optionalRef PackedTag
TT.someTag
      bytesC :: Bytes -> Closure
bytesC = Bytes -> Closure
BytesC
      -- the number functions: width, big-endian, and the Haskell operations
      numKinds :: [(Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
  Int -> Bytes -> Maybe Word64)]
numKinds =
        [ (Int
2, Bool
True, Bytes -> Maybe (Word64, Bytes)
By.decodeNat16be, Word64 -> Bytes
By.encodeNat16be, \Int
i Bytes
bs -> Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word64) -> Maybe Word16 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Bytes -> Maybe Word16
By.index16be Int
i Bytes
bs),
          (Int
2, Bool
False, Bytes -> Maybe (Word64, Bytes)
By.decodeNat16le, Word64 -> Bytes
By.encodeNat16le, \Int
i Bytes
bs -> Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word64) -> Maybe Word16 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Bytes -> Maybe Word16
By.index16le Int
i Bytes
bs),
          (Int
4, Bool
True, Bytes -> Maybe (Word64, Bytes)
By.decodeNat32be, Word64 -> Bytes
By.encodeNat32be, \Int
i Bytes
bs -> Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> Maybe Word32 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Bytes -> Maybe Word32
By.index32be Int
i Bytes
bs),
          (Int
4, Bool
False, Bytes -> Maybe (Word64, Bytes)
By.decodeNat32le, Word64 -> Bytes
By.encodeNat32le, \Int
i Bytes
bs -> Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> Maybe Word32 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Bytes -> Maybe Word32
By.index32le Int
i Bytes
bs),
          (Int
8, Bool
True, Bytes -> Maybe (Word64, Bytes)
By.decodeNat64be, Word64 -> Bytes
By.encodeNat64be, Int -> Bytes -> Maybe Word64
By.index64be),
          (Int
8, Bool
False, Bytes -> Maybe (Word64, Bytes)
By.decodeNat64le, Word64 -> Bytes
By.encodeNat64le, Int -> Bytes -> Maybe Word64
By.index64le)
        ] ::
          [(Int, Bool, By.Bytes -> Maybe (Word64, By.Bytes), Word64 -> By.Bytes, Int -> By.Bytes -> Maybe Word64)]
      baseKinds :: [(Int, Bytes -> Bytes, Bytes -> Either Text Bytes)]
baseKinds =
        [ (Int
16, Bytes -> Bytes
By.toBase16, Bytes -> Either Text Bytes
By.fromBase16),
          (Int
32, Bytes -> Bytes
By.toBase32, Bytes -> Either Text Bytes
By.fromBase32),
          (Int
64, Bytes -> Bytes
By.toBase64, Bytes -> Either Text Bytes
By.fromBase64),
          (Int
65, Bytes -> Bytes
By.toBase64UrlUnpadded, Bytes -> Either Text Bytes
By.fromBase64UrlUnpadded)
        ] ::
          [(Int, By.Bytes -> By.Bytes, By.Bytes -> Either Text.Text By.Bytes)]
      -- "abc", cut from a longer chunk so that its offset and its size differ
      first :: Any
first = Bytes -> Any
wrap (Int -> Bytes -> Bytes
By.drop Int
1 ([Int] -> Bytes
bytes [Int
120, Int
97, Int
98, Int
99]))
      th :: Int
th = Int
Rope.threshold
      pieces :: [[Int]]
pieces = [[], [Int
1], [Int
97, Int
98, Int
99], [Int
0, Int
255, Int
128, Int
7, Int
0], [Int
0 .. Int
255], Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
120, Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate Int
th Int
121, Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
122, Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
600 ([Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
cycle [Int
0 .. Int
255])]
      base :: [Bytes]
base = ([Int] -> Bytes) -> [[Int]] -> [Bytes]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Bytes
bytes [[Int]]
pieces
      digits :: Int -> [Int]
digits Int
i = (Char -> Int) -> [Char] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
forall a. Enum a => a -> Int
fromEnum (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int
i :: Int))
      grown :: [Bytes]
grown = [(Bytes -> Int -> Bytes) -> Bytes -> [Int] -> Bytes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Bytes
acc Int
i -> Bytes
acc Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> [Int] -> Bytes
bytes (Int -> [Int]
digits Int
i)) Bytes
forall a. Monoid a => a
mempty [Int
1 .. Int
n] | Int
n <- [Int
5, Int
40, Int
300]]
      grownL :: [Bytes]
grownL = [(Bytes -> Int -> Bytes) -> Bytes -> [Int] -> Bytes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Bytes
acc Int
i -> [Int] -> Bytes
bytes (Int -> [Int]
digits Int
i) Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Bytes
acc) Bytes
forall a. Monoid a => a
mempty [Int
1 .. Int
n] | Int
n <- [Int
40, Int
300]]
      big :: Bytes
big = [Bytes] -> Bytes
forall a. Monoid a => [a] -> a
mconcat (Int -> Bytes -> [Bytes]
forall a. Int -> a -> [a]
replicate Int
2000 ([Int] -> Bytes
bytes [Int
0xC3, Int
0xA9]))
      chunky :: Bytes
chunky = (Bytes -> Int -> Bytes) -> Bytes -> [Int] -> Bytes
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Bytes
acc Int
i -> Bytes
acc Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> [Int] -> Bytes
bytes (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (Int
th Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7) ([Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
cycle [Int
0 .. Int
255])))) Bytes
forall a. Monoid a => a
mempty [Int
1 .. Int
260 :: Int]
      samples :: [Bytes]
samples = [Bytes]
base [Bytes] -> [Bytes] -> [Bytes]
forall a. [a] -> [a] -> [a]
++ [Bytes]
grown [Bytes] -> [Bytes] -> [Bytes]
forall a. [a] -> [a] -> [a]
++ [Bytes]
grownL [Bytes] -> [Bytes] -> [Bytes]
forall a. [a] -> [a] -> [a]
++ [Bytes
big, Int -> Bytes -> Bytes
By.drop Int
7 Bytes
big, Int -> Bytes -> Bytes
By.take Int
1500 Bytes
big, Int -> Bytes -> Bytes
By.drop Int
100 ([Bytes]
grown [Bytes] -> Int -> Bytes
forall a. HasCallStack => [a] -> Int -> a
!! Int
2), Int -> Bytes -> Bytes
By.take Int
400 ([Bytes]
grownL [Bytes] -> Int -> Bytes
forall a. HasCallStack => [a] -> Int -> a
!! Int
1), Bytes
chunky, Int -> Bytes -> Bytes
By.drop Int
1000 Bytes
chunky]
  -- (every sample goes through `put`: see probeLists on `evaluate`)
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
12 (Bytes -> Any
wrap Bytes
By.empty) :: IO (MutableArray (PrimState IO) Any)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 Any
first
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Bytes -> Any
wrap ([Int] -> Bytes
bytes (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
97) Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> [Int] -> Bytes
bytes (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate (Int
th Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
98)))
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
2 (Bytes -> Any
wrap Bytes
By.empty)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
4 (Closure -> Any
forall a. a -> Any
any' Closure
none)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
5 (Closure -> Any
forall a. a -> Any
any' (Reference -> PackedTag -> Closure
Enum Reference
Ty.pairRef (Word64 -> PackedTag
PackedTag Word64
0)))
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
6 (Closure -> Any
forall a. a -> Any
any' (Reference -> PackedTag -> Closure
Enum Reference
Ty.unitRef PackedTag
TT.unitTag))
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
7 (Closure -> Any
forall a. a -> Any
any' (Reference -> PackedTag -> Closure
Enum Reference
Ty.eitherRef (Word64 -> PackedTag
PackedTag Word64
0)))
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
8 (Closure -> Any
forall a. a -> Any
any' Closure
charTypeTag)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
9 (Closure -> Any
forall a. a -> Any
any' Closure
natTypeTag)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
10 (Closure -> Any
forall a. a -> Any
any' Closure
intTypeTag)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
11 (Closure -> Any
forall a. a -> Any
any' Closure
floatTypeTag)
  let Pair Int
bytesInfo Int
bytesTag = Layouts -> Pair Int Int
lBytes Layouts
ls
  Int
ok <- MutableArray (PrimState IO) Any -> [Int] -> IO Int
bytesInit MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr [Int
bytesInfo, Int
th, Int
1, Int
bytesTag, Int
By.slackStart, Int
By.slackMax]
  if Int
ok Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1
    then Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the bytes constructors are not laid out as the JIT's helpers expect (check " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ok [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"))
    else do
      let slot3 :: IO Closure
          slot3 :: IO Closure
slot3 = Any -> Closure
forall a b. a -> b
unsafeCoerce (Any -> Closure) -> IO Any -> IO Closure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray (PrimState IO) Any -> Int -> IO Any
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3
          result :: IO (Maybe By.Bytes)
          result :: IO (Maybe Bytes)
result = do
            Closure
c <- IO Closure
slot3
            Bool
good <- do
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c)
              MutableArray (PrimState IO) Any -> IO Bool
bytesCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
            pure $ case Closure
c of
              BytesC Bytes
b | Bool
good -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
b
              Closure
_ -> Maybe Bytes
forall a. Maybe a
Nothing
          bytesIn :: Closure -> By.Bytes -> IO Bool
          bytesIn :: Closure -> Bytes -> IO Bool
bytesIn Closure
c Bytes
expected = case Closure
c of
            BytesC Bytes
b | Bytes
b Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
expected -> MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MutableArray (PrimState IO) Any -> IO Bool
bytesCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
            Closure
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          -- Bytes.at through the helper, against the interpreter's answer
          at :: By.Bytes -> Int -> IO Bool
          at :: Bytes -> Int -> IO Bool
at Bytes
b Int
i = do
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Closure -> Any
forall a. a -> Any
any' Closure
none)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
2 (Closure -> Any
forall a. a -> Any
any' Closure
natTypeTag)
            Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
5 Int
i (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag) Int
0
            Closure
c <- Any -> Closure
forall a b. a -> b
unsafeCoerce (Any -> Closure) -> IO Any -> IO Closure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray (PrimState IO) Any -> Int -> IO Any
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 :: IO Closure
            pure (Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Closure -> Closure -> Bool
same Closure
c (Closure -> (Word8 -> Closure) -> Maybe Word8 -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (Reference -> PackedTag -> Val -> Closure
Data1 Reference
Ty.optionalRef PackedTag
TT.someTag (Val -> Closure) -> (Word8 -> Val) -> Word8 -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Val
NatVal (Word64 -> Val) -> (Word8 -> Word64) -> Word8 -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Int -> Bytes -> Maybe Word8
By.at Int
i Bytes
b)))
          -- Bytes.flatten: the same bytes, in one chunk
          flat :: By.Bytes -> IO (Maybe By.Bytes)
          flat :: Bytes -> IO (Maybe Bytes)
flat Bytes
b = do
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
            Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
6 Int
0 Int
0 Int
0
            Maybe Bytes
r <- IO (Maybe Bytes)
result
            pure $ case Maybe Bytes
r of
              Just Bytes
f | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1, Bytes
f Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
b, [Chunk] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Bytes -> [Chunk]
By.chunks Bytes
f) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
f
              Maybe Bytes
_ -> Maybe Bytes
forall a. Maybe a
Nothing
          one :: By.Bytes -> IO [String]
          one :: Bytes -> IO [[Char]]
one Bytes
b = do
            let n :: Int
n = Bytes -> Int
By.size Bytes
b
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
            Bool
shape <- MutableArray (PrimState IO) Any -> IO Bool
bytesCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
            Int
size <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 Int
0 Int
0 Int
0
            [Bool]
cuts <- [Int] -> (Int -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([-Int
1 .. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n (if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
600 then Int
12 else Int
70)] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [(Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
j) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
13 | Int
j <- [Int
1 .. Int
12], Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
600] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1]) ((Int -> IO Bool) -> IO [Bool]) -> (Int -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
k -> do
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
              Int
h1 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 Int
k Int
0 Int
0
              Maybe Bytes
r1 <- IO (Maybe Bytes)
result
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
              Int
h2 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
2 Int
k Int
0 Int
0
              Maybe Bytes
r2 <- IO (Maybe Bytes)
result
              -- a negative count is a Nat too large to be a size
              let tk :: Bytes
tk = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Bytes
b else Int -> Bytes -> Bytes
By.take Int
k Bytes
b
                  dr :: Bytes
dr = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Bytes
By.empty else Int -> Bytes -> Bytes
By.drop Int
k Bytes
b
              pure (Int
h1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Bytes
r1 Maybe Bytes -> Maybe Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
tk Bool -> Bool -> Bool
&& Int
h2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Bytes
r2 Maybe Bytes -> Maybe Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
dr)
            [Bool]
ats <- (Int -> IO Bool) -> [Int] -> IO [Bool]
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 (Bytes -> Int -> IO Bool
at Bytes
b) ([-Int
1, Int
0, Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
n] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [(Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
j) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
7 | Int
j <- [Int
1 .. Int
6]])
            Maybe Bytes
fl <- Bytes -> IO (Maybe Bytes)
flat Bytes
b
            -- toList, then fromList of that
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
            Int
hu <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
8 Int
0 Int
0 Int
0
            Closure
cu <- IO Closure
slot3
            let natList :: Closure
natList = Deque Val -> Closure
ListC ([Val] -> Deque Val
forall a. [a] -> Deque a
Sq.fromList ((Word8 -> Val) -> [Word8] -> [Val]
forall a b. (a -> b) -> [a] -> [b]
map (Word64 -> Val
NatVal (Word64 -> Val) -> (Word8 -> Word64) -> Word8 -> Val
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Bytes -> [Word8]
By.toWord8s Bytes
b)))
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
natList)
            Int
hp <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
7 Int
0 Int
0 Int
0
            Maybe Bytes
rp <- IO (Maybe Bytes)
result
            -- the number functions
            [Bool]
nums <- [(Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
  Int -> Bytes -> Maybe Word64)]
-> ((Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
     Int -> Bytes -> Maybe Word64)
    -> IO Bool)
-> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
  Int -> Bytes -> Maybe Word64)]
numKinds (((Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
   Int -> Bytes -> Maybe Word64)
  -> IO Bool)
 -> IO [Bool])
-> ((Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
     Int -> Bytes -> Maybe Word64)
    -> IO Bool)
-> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \(Int
w, Bool
be, Bytes -> Maybe (Word64, Bytes)
dec, Word64 -> Bytes
enc, Int -> Bytes -> Maybe Word64
rd) -> do
              let be' :: Int
be' = if Bool
be then Int
1 else Int
0
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
              Int
hd <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
11 (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
be') (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
pairTag)
              Closure
cd <- IO Closure
slot3
              let expD :: Closure
expD = Closure
-> ((Word64, Bytes) -> Closure) -> Maybe (Word64, Bytes) -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (\(Word64
v, Bytes
rest) -> Val -> Closure
some (Closure -> Val
BoxedVal (Val -> Val -> Closure
tup2 (Word64 -> Val
NatVal Word64
v) (Closure -> Val
BoxedVal (Bytes -> Closure
bytesC Bytes
rest))))) (Bytes -> Maybe (Word64, Bytes)
dec Bytes
b)
              Bool
restOk <- case Closure
cd of
                Data1 Reference
_ PackedTag
_ (BoxedVal (Data2 Reference
_ PackedTag
_ Val
_ (BoxedVal (Data2 Reference
_ PackedTag
_ (BoxedVal Closure
rest) Val
_)))) -> MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
rest) IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MutableArray (PrimState IO) Any -> IO Bool
bytesCheck MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr
                Closure
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
w)
              [Bool]
encs <- [Word64] -> (Word64 -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word64
0, Word64
1, Word64
255, Word64
256, Word64
65535, Word64
65536, Word64
2 Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
32 :: Int) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1, Word64
2 Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
32 :: Int), Word64
forall a. Bounded a => a
maxBound] ((Word64 -> IO Bool) -> IO [Bool])
-> (Word64 -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Word64
v -> do
                Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
12 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
v) (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
be') Int
0
                Maybe Bytes
r <- IO (Maybe Bytes)
result
                pure (Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Bytes
r Maybe Bytes -> Maybe Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Word64 -> Bytes
enc Word64
v))
              [Bool]
rds <- [Int] -> (Int -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [-Int
1, Int
0, Int
1, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
n, Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2] ((Int -> IO Bool) -> IO [Bool]) -> (Int -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
                MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
                Int
v <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
13 Int
i (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
be') Int
0
                pure (Int
v Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> (Word64 -> Int) -> Maybe Word64 -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int
1) Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Maybe Word64
forall a. Maybe a
Nothing else Int -> Bytes -> Maybe Word64
rd Int
i Bytes
b))
              pure (Int
hd Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Closure -> Closure -> Bool
same Closure
cd Closure
expD Bool -> Bool -> Bool
&& Bool
restOk Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
encs Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
rds)
            -- the encodings: to, then from (the smaller bytes only; the random test covers the rest)
            [Bool]
bases <- [(Int, Bytes -> Bytes, Bytes -> Either Text Bytes)]
-> ((Int, Bytes -> Bytes, Bytes -> Either Text Bytes) -> IO Bool)
-> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1500 then [(Int, Bytes -> Bytes, Bytes -> Either Text Bytes)]
baseKinds else []) (((Int, Bytes -> Bytes, Bytes -> Either Text Bytes) -> IO Bool)
 -> IO [Bool])
-> ((Int, Bytes -> Bytes, Bytes -> Either Text Bytes) -> IO Bool)
-> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \(Int
base, Bytes -> Bytes
enc, Bytes -> Either Text Bytes
dec) -> do
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
b)
              Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
14 Int
base Int
0 Int
0
              Maybe Bytes
r <- IO (Maybe Bytes)
result
              let e :: Bytes
e = Bytes -> Bytes
enc Bytes
b
              MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
e)
              Int
h2 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
15 Int
base (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
rightTag) Int
0
              Closure
c2 <- IO Closure
slot3
              Bool
back <- case (Closure
c2, Bytes -> Either Text Bytes
dec Bytes
e) of
                (Data1 Reference
rf PackedTag
tg (BoxedVal Closure
inner), Right Bytes
d) | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Ty.eitherRef, PackedTag
tg PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.rightTag -> Closure -> Bytes -> IO Bool
bytesIn Closure
inner Bytes
d
                (Closure, Either Text Bytes)
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
              pure (Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Bytes
r Maybe Bytes -> Maybe Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
e Bool -> Bool -> Bool
&& Int
h2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Bool
back)
            [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]])
-> ([Maybe [Char]] -> [[Char]]) -> [Maybe [Char]] -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]] -> IO [[Char]]) -> [Maybe [Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$
              [ if Bool
shape then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"a bytes isn't laid out as expected",
                if Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Bytes.size differs from the interpreter's",
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
cuts then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Bytes.take or Bytes.drop differs from the interpreter's on a bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
ats then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Bytes.at differs from the interpreter's on a bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if Maybe Bytes -> Bool
forall {a}. Maybe a -> Bool
isJust Maybe Bytes
fl then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Bytes.flatten differs from the interpreter's on a bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if Int
hu Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Closure -> Closure -> Bool
same Closure
cu Closure
natList then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Bytes.toList differs from the interpreter's on a bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if Int
hp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Bytes
rp Maybe Bytes -> Maybe Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
b then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Bytes.fromList differs from the interpreter's on a bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
nums then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"a Bytes number function differs from the interpreter's on a bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n),
                if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
bases then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"a Bytes encoding differs from the interpreter's on a bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n)
              ]
          two :: By.Bytes -> By.Bytes -> IO [String]
          two :: Bytes -> Bytes -> IO [[Char]]
two Bytes
a Bytes
b = do
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
a)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Bytes -> Any
wrap Bytes
b)
            Int
eq <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
4 Int
0 Int
0 Int
0
            Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 Int
0 Int
0 Int
0
            Maybe Bytes
r <- IO (Maybe Bytes)
result
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
a)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Bytes -> Any
wrap Bytes
b)
            Int
hi <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
9 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag) Int
0 Int
0
            Closure
ci <- IO Closure
slot3
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
a)
            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Bytes -> Any
wrap Bytes
b)
            Int
cm <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
10 Int
0 Int
0 Int
0
            let expI :: Closure
expI = Closure -> (Word64 -> Closure) -> Maybe Word64 -> Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Closure
none (Val -> Closure
some (Val -> Closure) -> (Word64 -> Val) -> Word64 -> Closure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Val
NatVal) (Bytes -> Bytes -> Maybe Word64
By.indexOf Bytes
a Bytes
b)
                expC :: Int
expC = case Bytes -> Bytes -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Bytes
a Bytes
b of Ordering
LT -> -Int
1; Ordering
EQ -> Int
0; Ordering
GT -> Int
1
            [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]])
-> ([Maybe [Char]] -> [[Char]]) -> [Maybe [Char]] -> IO [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [Char]] -> [[Char]]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe [Char]] -> IO [[Char]]) -> [Maybe [Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$
              [ if Int
eq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (if Bytes
a Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
b then Int
1 else Int
0) then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Bytes equality differs from the interpreter's",
                if Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Maybe Bytes
r Maybe Bytes -> Maybe Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes
a Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Bytes
b) then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"Bytes.++ differs from the interpreter's on bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Bytes -> Int
By.size Bytes
a) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" and " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Bytes -> Int
By.size Bytes
b)),
                if Bytes -> Int
By.size Bytes
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| (Int
hi Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Closure -> Closure -> Bool
same Closure
ci Closure
expI) then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Bytes.indexOf differs from the interpreter's",
                if Int
cm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expC then Maybe [Char]
forall a. Maybe a
Nothing else [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Bytes comparison differs from the interpreter's"
              ]
          -- the longer test: random operations on eight bytes
          mix :: Int -> Int
          mix :: Int -> Int
mix Int
z0 =
            let z1 :: Int
z1 = (Int
z0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z0 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
30)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (-Int
4658895280553007687)
                z2 :: Int
z2 = (Int
z1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
27)) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (-Int
7723592293110705685)
             in (Int
z2 Int -> Int -> Int
forall a. Bits a => a -> a -> a
`xor` (Int
z2 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
31)) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
forall a. Bounded a => a
maxBound
          values :: [Int]
values = [Int] -> [Int]
forall a. HasCallStack => [a] -> [a]
cycle ([Int
0 .. Int
255] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
255, Int
0, Int
128, Int
1])
          stress :: Int -> [By.Bytes] -> IO (Either String ())
          stress :: Int -> [Bytes] -> IO (Either [Char] ())
stress Int
step [Bytes]
pool
            | Int
step Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
steps = Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either [Char] ()
forall a b. b -> Either a b
Right ())
            | Bool
otherwise = do
                let r :: Int -> Int
r Int
k = Int -> Int
mix (Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k)
                    i :: Int
i = Int -> Int
r Int
0 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8
                    t :: Bytes
t = [Bytes]
pool [Bytes] -> Int -> Bytes
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
                    e :: Bytes
e = [Bytes]
pool [Bytes] -> Int -> Bytes
forall a. HasCallStack => [a] -> Int -> a
!! (Int -> Int
r Int
1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8)
                    n :: Int
n = Bytes -> Int
By.size Bytes
t
                    full :: Bool
full = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
3000 Bool -> Bool -> Bool
|| Int -> Int
r Int
2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
16 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                    pos :: Int
pos = case Int -> Int
r Int
3 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4 of
                      Int
0 -> Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                      Int
1 -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
12
                      Int
_ -> Int -> Int
r Int
4 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                    op :: Int
op = Int -> Int
r Int
5 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
20
                    piece :: Int -> Bytes
piece Int
k = [Int] -> Bytes
bytes (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take (Int -> Int
r Int
k Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (if Int -> Bool
forall a. Integral a => a -> Bool
even (Int -> Int
r (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) then Int
7 else Int
90)) (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop (Int -> Int
r (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) [Int]
values))
                    -- what a helper built, if it is laid out right and is the expected bytes
                    -- (the bytes are compared when `whole`; the size always)
                    verdict :: Bool -> Int -> By.Bytes -> IO (Maybe By.Bytes)
                    verdict :: Bool -> Int -> Bytes -> IO (Maybe Bytes)
verdict Bool
whole Int
h Bytes
expected = do
                      Maybe Bytes
got <- IO (Maybe Bytes)
result
                      pure $ case Maybe Bytes
got of
                        Just Bytes
g | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1, Bytes -> Int
By.size Bytes
g Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes -> Int
By.size Bytes
expected, Bool -> Bool
not Bool
whole Bool -> Bool -> Bool
|| Bytes
g Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
expected -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
g
                        Maybe Bytes
_ -> Maybe Bytes
forall a. Maybe a
Nothing
                    cat :: Bool -> Bytes -> Bytes -> IO (Maybe Bytes)
cat Bool
whole Bytes
a Bytes
b = do
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
a)
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Bytes -> Any
wrap Bytes
b)
                      Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 Int
0 Int
0 Int
0
                      Bool -> Int -> Bytes -> IO (Maybe Bytes)
verdict Bool
whole Int
h (Bytes
a Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Bytes
b)
                    cut :: Bool -> Bool -> Int -> Bytes -> IO (Maybe Bytes)
cut Bool
whole Bool
tk Int
k Bytes
x = do
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
x)
                      Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr (if Bool
tk then Int
1 else Int
2) Int
k Int
0 Int
0
                      Bool -> Int -> Bytes -> IO (Maybe Bytes)
verdict Bool
whole Int
h (if Bool
tk then (if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Bytes
x else Int -> Bytes -> Bytes
By.take Int
k Bytes
x) else (if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Bytes
By.empty else Int -> Bytes -> Bytes
By.drop Int
k Bytes
x))
                    sameAs :: Bytes -> Bytes -> IO Bool
sameAs Bytes
a Bytes
b = do
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
a)
                      MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Bytes -> Any
wrap Bytes
b)
                      Int
eq <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
4 Int
0 Int
0 Int
0
                      pure (Int
eq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (if Bytes
a Bytes -> Bytes -> Bool
forall a. Eq a => a -> a -> Bool
== Bytes
b then Int
1 else Int
0))
                    times :: Int -> (By.Bytes -> IO (Maybe By.Bytes)) -> By.Bytes -> IO (Maybe By.Bytes)
                    times :: Int -> (Bytes -> IO (Maybe Bytes)) -> Bytes -> IO (Maybe Bytes)
times Int
0 Bytes -> IO (Maybe Bytes)
_ Bytes
x = Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
x)
                    times Int
k Bytes -> IO (Maybe Bytes)
f Bytes
x = Bytes -> IO (Maybe Bytes)
f Bytes
x IO (Maybe Bytes)
-> (Maybe Bytes -> IO (Maybe Bytes)) -> IO (Maybe Bytes)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe Bytes)
-> (Bytes -> IO (Maybe Bytes)) -> Maybe Bytes -> IO (Maybe Bytes)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bytes
forall a. Maybe a
Nothing) (Int -> (Bytes -> IO (Maybe Bytes)) -> Bytes -> IO (Maybe Bytes)
times (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bytes -> IO (Maybe Bytes)
f)
                Maybe Bytes
res <-
                  if
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 -> Bool -> Bytes -> Bytes -> IO (Maybe Bytes)
cat Bool
full Bytes
t (Int -> Bytes
piece Int
6)
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 -> Bool -> Bytes -> Bytes -> IO (Maybe Bytes)
cat Bool
full (Int -> Bytes
piece Int
6) Bytes
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 -> Bool -> Bool -> Int -> Bytes -> IO (Maybe Bytes)
cut Bool
full Bool
True Int
pos Bytes
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
5 -> Bool -> Bool -> Int -> Bytes -> IO (Maybe Bytes)
cut Bool
full Bool
False Int
pos Bytes
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 -> Bool -> Bool -> Int -> Bytes -> IO (Maybe Bytes)
cut Bool
full Bool
False Int
pos Bytes
t IO (Maybe Bytes)
-> (Maybe Bytes -> IO (Maybe Bytes)) -> IO (Maybe Bytes)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Maybe Bytes)
-> (Bytes -> IO (Maybe Bytes)) -> Maybe Bytes -> IO (Maybe Bytes)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bytes
forall a. Maybe a
Nothing) (Bool -> Bool -> Int -> Bytes -> IO (Maybe Bytes)
cut Bool
full Bool
True (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
200))
                    | Int
op Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8 -> if Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bytes -> Int
By.size Bytes
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
60000 then Bool -> Bool -> Int -> Bytes -> IO (Maybe Bytes)
cut Bool
full Bool
True (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
50) Bytes
t else Bool -> Bytes -> Bytes -> IO (Maybe Bytes)
cat Bool
full Bytes
t Bytes
e
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
9 -> do
                        -- the same bytes cut into chunks differently, and another bytes
                        Bool
a <- Bytes -> Bytes -> IO Bool
sameAs Bytes
t (Int -> Bytes -> Bytes
By.take Int
pos Bytes
t Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Int -> Bytes -> Bytes
By.drop Int
pos Bytes
t)
                        Bool
b <- Bytes -> Bytes -> IO Bool
sameAs Bytes
t Bytes
e
                        Bool
c <- if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Bytes -> Bytes -> IO Bool
sameAs Bytes
t (Int -> Bytes -> Bytes
By.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bytes
t Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Int -> Bytes
piece Int
9) else Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                        pure (if Bool
a Bool -> Bool -> Bool
&& Bool
b Bool -> Bool -> Bool
&& Bool
c then Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
t else Maybe Bytes
forall a. Maybe a
Nothing)
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
10 -> Int -> (Bytes -> IO (Maybe Bytes)) -> Bytes -> IO (Maybe Bytes)
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) (\Bytes
x -> Bool -> Bytes -> Bytes -> IO (Maybe Bytes)
cat (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) Bytes
x (Int -> Bytes
piece Int
9)) Bytes
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
11 -> Int -> (Bytes -> IO (Maybe Bytes)) -> Bytes -> IO (Maybe Bytes)
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) (\Bytes
x -> Bool -> Bytes -> Bytes -> IO (Maybe Bytes)
cat (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) (Int -> Bytes
piece Int
9) Bytes
x) Bytes
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
12 -> Int -> (Bytes -> IO (Maybe Bytes)) -> Bytes -> IO (Maybe Bytes)
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) (Bool -> Bool -> Int -> Bytes -> IO (Maybe Bytes)
cut (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) Bool
False Int
1) Bytes
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
13 -> Int -> (Bytes -> IO (Maybe Bytes)) -> Bytes -> IO (Maybe Bytes)
times (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
40) (\Bytes
x -> Bool -> Bool -> Int -> Bytes -> IO (Maybe Bytes)
cut (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
300) Bool
True (Bytes -> Int
By.size Bytes
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bytes
x) Bytes
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
14 -> do
                        [Bool]
oks <- (Int -> IO Bool) -> [Int] -> IO [Bool]
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 (Bytes -> Int -> IO Bool
at Bytes
t) [Int
pos, Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)]
                        pure (if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
oks then Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
t else Maybe Bytes
forall a. Maybe a
Nothing)
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
15 -> Bytes -> IO (Maybe Bytes)
flat Bytes
t
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 -> do
                        -- toList, then fromList
                        MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
t)
                        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
8 Int
0 Int
0 Int
0
                        Closure
c <- IO Closure
slot3
                        case Closure
c of
                          ListC Deque Val
_ | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> do
                            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c)
                            Int
h2 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
7 Int
0 Int
0 Int
0
                            Bool -> Int -> Bytes -> IO (Maybe Bytes)
verdict Bool
full Int
h2 Bytes
t
                          Closure
_ -> Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bytes
forall a. Maybe a
Nothing
                    | Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
17 Bool -> Bool -> Bool
|| Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
18 -> do
                        -- an encoding and back
                        let base :: Int
base = if Int
op Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
17 then Int
16 else [Int
32, Int
64, Int
65] [Int] -> Int -> Int
forall a. HasCallStack => [a] -> Int -> a
!! (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3)
                        MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
t)
                        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
14 Int
base Int
0 Int
0
                        Closure
c <- IO Closure
slot3
                        case Closure
c of
                          BytesC Bytes
_ | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> do
                            MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' Closure
c)
                            Int
h2 <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
15 Int
base (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
rightTag) Int
0
                            Closure
c2 <- IO Closure
slot3
                            case Closure
c2 of
                              Data1 Reference
_ PackedTag
_ (BoxedVal Closure
inner) | Int
h2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 (Closure -> Any
forall a. a -> Any
any' Closure
inner) IO () -> IO (Maybe Bytes) -> IO (Maybe Bytes)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Int -> Bytes -> IO (Maybe Bytes)
verdict Bool
full Int
1 Bytes
t
                              Closure
_ -> Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bytes
forall a. Maybe a
Nothing
                          Closure
_ -> Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bytes
forall a. Maybe a
Nothing
                    | Bool
otherwise -> do
                        -- decode a number off the front: the rest goes on
                        let (Int
w, Bool
be, Bytes -> Maybe (Word64, Bytes)
dec, Word64 -> Bytes
_, Int -> Bytes -> Maybe Word64
_) = [(Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
  Int -> Bytes -> Maybe Word64)]
numKinds [(Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
  Int -> Bytes -> Maybe Word64)]
-> Int
-> (Int, Bool, Bytes -> Maybe (Word64, Bytes), Word64 -> Bytes,
    Int -> Bytes -> Maybe Word64)
forall a. HasCallStack => [a] -> Int -> a
!! (Int -> Int
r Int
6 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
6)
                        MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
t)
                        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
11 (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Bool
be then Int
1 else Int
0)) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
someTag) (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
pairTag)
                        Closure
c <- IO Closure
slot3
                        case (Closure
c, Bytes -> Maybe (Word64, Bytes)
dec Bytes
t) of
                          (Data1 Reference
_ PackedTag
_ (BoxedVal (Data2 Reference
_ PackedTag
_ Val
_ (BoxedVal (Data2 Reference
_ PackedTag
_ (BoxedVal Closure
rest) Val
_)))), Just (Word64
_, Bytes
expected)) | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 (Closure -> Any
forall a. a -> Any
any' Closure
rest) IO () -> IO (Maybe Bytes) -> IO (Maybe Bytes)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Int -> Bytes -> IO (Maybe Bytes)
verdict Bool
full Int
1 Bytes
expected
                          (Closure
_, Maybe (Word64, Bytes)
Nothing) | Int
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
t)
                          (Closure, Maybe (Word64, Bytes))
_ -> Maybe Bytes -> IO (Maybe Bytes)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bytes
forall a. Maybe a
Nothing
                case Maybe Bytes
res of
                  Maybe Bytes
Nothing -> Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left ([Char]
"the bytes helpers' test failed at step " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
step [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (operation " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
op [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" on a bytes of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"))
                  Just Bytes
t' -> Int -> [Bytes] -> IO (Either [Char] ())
stress (Int
step Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> [Bytes] -> [Bytes]
forall a. Int -> [a] -> [a]
take Int
i [Bytes]
pool [Bytes] -> [Bytes] -> [Bytes]
forall a. [a] -> [a] -> [a]
++ [Bytes
t'] [Bytes] -> [Bytes] -> [Bytes]
forall a. [a] -> [a] -> [a]
++ Int -> [Bytes] -> [Bytes]
forall a. Int -> [a] -> [a]
drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Bytes]
pool)
      [[Char]]
e1 <- [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bytes -> IO [[Char]]) -> [Bytes] -> IO [[[Char]]]
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 Bytes -> IO [[Char]]
one [Bytes]
samples
      -- equal bytes cut into chunks differently must compare equal
      let recut :: Bytes -> Bytes
recut Bytes
b = Int -> Bytes -> Bytes
By.take Int
3 Bytes
b Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Int -> Bytes -> Bytes
By.drop Int
3 Bytes
b
          some3 :: [Bytes]
some3 = [Bytes
b | (Int
j, Bytes
b) <- [Int] -> [Bytes] -> [(Int, Bytes)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [Bytes]
samples, Int
j Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0]
      [[Char]]
e2 <- [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> [[Char]]) -> IO [[[Char]]] -> IO [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO [[Char]]] -> IO [[[Char]]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Bytes -> Bytes -> IO [[Char]]
two Bytes
a Bytes
b | Bytes
a <- [Bytes]
some3, Bytes
b <- [Bytes]
some3] [IO [[Char]]] -> [IO [[Char]]] -> [IO [[Char]]]
forall a. [a] -> [a] -> [a]
++ [Bytes -> Bytes -> IO [[Char]]
two Bytes
b (Bytes -> Bytes
recut Bytes
b) | Bytes
b <- [Bytes]
samples])
      -- decoding inputs that aren't canonical: whatever the helper decides must be the interpreter's answer
      [Bool]
odd <- [(Int, Bytes -> Either Text Bytes, [Char])]
-> ((Int, Bytes -> Either Text Bytes, [Char]) -> IO Bool)
-> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int
base, Bytes -> Either Text Bytes
dec, [Char]
inp) | (Int
base, Bytes -> Bytes
_, Bytes -> Either Text Bytes
dec) <- [(Int, Bytes -> Bytes, Bytes -> Either Text Bytes)]
baseKinds, [Char]
inp <- [[Char]
"", [Char]
"00ff", [Char]
"00FF", [Char]
"0", [Char]
"zz", [Char]
"AA==", [Char]
"AA", [Char]
"AAA=", [Char]
"QUJD", [Char]
"QUJDRA==", [Char]
"QUJDRA", [Char]
"MFRGG===", [Char]
"MFRGG", [Char]
"-_-_", [Char]
"QUI=", [Char]
"QUJ=", [Char]
"ME======", [Char]
"MF======", [Char]
"====", [Char]
"ab", [Char]
"AB"]] (((Int, Bytes -> Either Text Bytes, [Char]) -> IO Bool)
 -> IO [Bool])
-> ((Int, Bytes -> Either Text Bytes, [Char]) -> IO Bool)
-> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \(Int
base, Bytes -> Either Text Bytes
dec, [Char]
inp) -> do
        let e :: Bytes
e = [Int] -> Bytes
bytes ((Char -> Int) -> [Char] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
forall a. Enum a => a -> Int
fromEnum [Char]
inp)
        MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Bytes -> Any
wrap Bytes
e)
        Int
h <- MutableArray (PrimState IO) Any
-> Int -> Int -> Int -> Int -> IO Int
bytesTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
15 Int
base (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
rightTag) Int
0
        Closure
c <- IO Closure
slot3
        case (Int
h, Bytes -> Either Text Bytes
dec Bytes
e) of
          (Int
1, Right Bytes
d) -> case Closure
c of
            Data1 Reference
rf PackedTag
tg (BoxedVal Closure
inner) | Reference
rf Reference -> Reference -> Bool
forall a. Eq a => a -> a -> Bool
== Reference
Ty.eitherRef, PackedTag
tg PackedTag -> PackedTag -> Bool
forall a. Eq a => a -> a -> Bool
== PackedTag
TT.rightTag -> Closure -> Bytes -> IO Bool
bytesIn Closure
inner Bytes
d
            Closure
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          (Int
1, Left Text
_) -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
          (Int, Either Text Bytes)
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      let e3 :: [[Char]]
e3 = [[Char]
"Bytes.fromBase decodes something the interpreter doesn't" | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
odd)]
      case [[Char]]
e1 [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
e2 [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
e3 of
        [Char]
e : [[Char]]
_ -> Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
e)
        [] -> if Int
steps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> [Bytes] -> IO (Either [Char] ())
stress Int
0 (Int -> Bytes -> [Bytes]
forall a. Int -> a -> [a]
replicate Int
8 Bytes
By.empty) else Either [Char] () -> IO (Either [Char] ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either [Char] ()
forall a b. b -> Either a b
Right ())

-- | Partial applications: the helper for the @Name@ instruction against
-- what the interpreter builds, for closures with and without arguments
-- already captured.
probeNames :: Layouts -> IO (Either String ())
probeNames :: Layouts -> IO (Either [Char] ())
probeNames Layouts
ls = do
  [Int] -> IO ()
closureInit [Layout -> Int
lInfo (Layouts -> Layout
lPAp Layouts
ls), Layout -> Int
lPtrTag (Layouts -> Layout
lPAp Layouts
ls)]
  let put :: MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
      put :: MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray (PrimState IO) Any
a Int
i Any
v = Any -> IO Any
forall a. a -> IO a
evaluate Any
v IO Any -> (Any -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray (PrimState IO) Any
a Int
i
      !ref :: Reference
ref = Reference
Ty.booleanRef
      !cix :: CombIx
cix = Reference -> Word64 -> Word64 -> CombIx
CIx Reference
ref Word64
21 Word64
22
      !comb :: GCombInfo comb
comb = Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
forall comb.
Int -> Int -> GSection comb -> Ptr NativeCell -> GCombInfo comb
LamI Int
5 Int
7 GSection comb
forall comb. GSection comb
Exit Ptr NativeCell
noNativeCell
      !nat :: Closure
nat = Closure
natTypeTag
      pap :: [Int] -> [Closure] -> Closure
pap [Int]
us [Closure]
bs = let !u :: ByteArray
u = [Int] -> ByteArray
forall a. Prim a => [a] -> ByteArray
byteArrayFromList ([Int]
us :: [Int]); !b :: Array Closure
b = [Closure] -> Array Closure
forall a. [a] -> Array a
arrayFromList [Closure]
bs in CombIx -> GCombInfo (RComb Val) -> Seg -> Closure
PAp CombIx
cix GCombInfo (RComb Val)
forall {comb}. GCombInfo comb
comb (ByteArray
u, Array Closure
b)
      !first :: Any
first = Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! [Int] -> [Closure] -> Closure
pap [] []
  MutableArray RealWorld Any
arr <- Int -> Any -> IO (MutableArray (PrimState IO) Any)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
newArray Int
4 Any
first :: IO (MutableArray (PrimState IO) Any)
  MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
1 (Closure -> Any
forall a. a -> Any
any' Closure
nat)
  [Bool]
oks <- [(Int, Int)] -> ((Int, Int) -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Int
old, Int
n) | Int
old <- [Int
0, Int
1, Int
3], Int
n <- [Int
1 .. Int
7 :: Int]] (((Int, Int) -> IO Bool) -> IO [Bool])
-> ((Int, Int) -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$ \(Int
old, Int
n) -> do
    let olds :: [Int]
olds = [Int
50 .. Int
49 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
old]
    MutableArray (PrimState IO) Any -> Int -> Any -> IO ()
put MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
0 (Closure -> Any
forall a. a -> Any
any' (Closure -> Any) -> Closure -> Any
forall a b. (a -> b) -> a -> b
$! [Int] -> [Closure] -> Closure
pap [Int]
olds ((Int -> Closure) -> [Int] -> [Closure]
forall a b. (a -> b) -> [a] -> [b]
map (Closure -> Int -> Closure
forall a b. a -> b -> a
const Closure
nat) [Int]
olds))
    Bool
h <- MutableArray (PrimState IO) Any -> Int -> IO Bool
nameTest MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
n
    Closure
r <- Any -> Closure
forall a b. a -> b
unsafeCoerce (Any -> Closure) -> IO Any -> IO Closure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutableArray (PrimState IO) Any -> Int -> IO Any
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray RealWorld Any
MutableArray (PrimState IO) Any
arr Int
3 :: IO Closure
    let expected :: Closure
expected = [Int] -> [Closure] -> Closure
pap ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
100 .. Int
99 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
olds) (Int -> Closure -> [Closure]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
old) Closure
nat)
    pure (Bool
h Bool -> Bool -> Bool
&& Closure -> Val
BoxedVal Closure
r Val -> Val -> Bool
forall a. Eq a => a -> a -> Bool
== Closure -> Val
BoxedVal Closure
expected)
  pure (if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
oks then () -> Either [Char] ()
forall a b. b -> Either a b
Right () else [Char] -> Either [Char] ()
forall a b. a -> Either a b
Left [Char]
"partial applications built by the JIT's helper differ from the interpreter's")