{-# LANGUAGE CPP                  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE UnboxedTuples        #-}
{-# LANGUAGE UndecidableInstances #-} -- Due to ICODE vararg typeclass
{-# LANGUAGE PatternSynonyms      #-}
{-# LANGUAGE RoleAnnotations      #-}

{-# OPTIONS_GHC -Wunused-imports #-}

{-
András, 2023-10-2:

All code in Agda/TypeChecking/Serialise should be strict, since serialization necessarily
forces all data, eventually.
  - (<$!>) should be used instead of lazy fmap.
  - Any redex that's passed to `return`, a lazy constructor, or a function, should
    be forced beforehand with strict `let`, strict binding or ($!).
-}

{-
-- Layout of Word32

The unit of hash-consing is generally Word32, but it's used in different ways depending on the type
of the object that's being encoded.

- For enums and word-sized integral types, the Word32 is a direct unboxed representation of the
  data. 64-bit values get truncated (dodgy, but correct so far). Let's call these "unboxed types".
- For most types, the Word32 is an index into the corresponding hashtable.
- For Syntax.Internal.Term, the range [(maxBound - varTableSize) .. (maxBound - 1)] is used to
  represent terms of the form "Var i []" where "i" is in [0..varTableSize-1].
-}

module Mikan.TypeChecking.Serialise.Base (
    module Mikan.TypeChecking.Serialise.Node
  , module Mikan.TypeChecking.Serialise.Base
  ) where

import Control.Exception qualified as E
import Control.Monad.Reader

import Data.Proxy
import Data.Hashable
import Data.Bits
import Data.IORef
import Data.Word (Word32, Word64)
import Data.Maybe
import Data.Primitive.ByteArray
import Data.Typeable (Typeable, TypeRep, typeRep, typeRepFingerprint)
import GHC.Exts
import GHC.Fingerprint.Type
import GHC.Float (castDoubleToWord64)
import GHC.Generics (Generic)
import Unsafe.Coerce

import Mikan.Syntax.Abstract.Name (Name, nameBindingSite)
import Mikan.Syntax.Common (NameId)
import Mikan.Syntax.Internal (QName(..), nameId, Term(..), varTable, varTableSize)
import Mikan.Syntax.Position (Range)
import Mikan.TypeChecking.Monad.Base.Types (ModuleToSource)
import Mikan.TypeChecking.Serialise.Node

import Mikan.Utils.FileName
import Mikan.Utils.HashSet.Ordered (HashSet)
import Mikan.Utils.HashSet.Ordered qualified as HashSet
import Mikan.Utils.HashTable (HashTableLU, HashTableLL)
import Mikan.Utils.HashTable qualified as HashTable
import Mikan.Utils.List1 (List1)
import Mikan.Utils.Monad
import Mikan.Utils.TypeLevel
import Mikan.Utils.VarSet (VarSet)
import Mikan.Utils.CompactRegion (Compact)
import Mikan.Utils.MinimalArray.MutablePrim qualified as MP
import Mikan.Utils.MinimalArray.Lifted qualified as AL
import Mikan.Utils.MinimalArray.MutableLifted qualified as ML
import Mikan.Utils.CompactRegion qualified as Compact


-- Caching Var-s
--------------------------------------------------------------------------------

{-# INLINE varRangeStart #-}
varRangeStart :: Word32
varRangeStart :: Word32
varRangeStart = Word32
forall a. Bounded a => a
maxBound Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
varTableSize

{-# INLINE cacheVar #-}
cacheVar :: Int -> Maybe Word32
cacheVar :: Int -> Maybe Word32
cacheVar Int
x =
  if Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
varTableSize then
    Word32 -> Maybe Word32
forall a. a -> Maybe a
Just (Word32 -> Maybe Word32) -> Word32 -> Maybe Word32
forall a b. (a -> b) -> a -> b
$! Word32
varRangeStart Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
  else
    Maybe Word32
forall a. Maybe a
Nothing

{-# INLINE uncacheVar #-}
uncacheVar :: Word32 -> Maybe Term
uncacheVar :: Word32 -> Maybe Term
uncacheVar Word32
x =
  if Word32
varRangeStart Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32
x
    then Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> Term -> Maybe Term
forall a b. (a -> b) -> a -> b
$! Array Term -> Int -> Term
forall a. Array a -> Int -> a
AL.unsafeIndex Array Term
varTable (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
varRangeStart))
    else Maybe Term
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

-- | Association lists mapping TypeRep fingerprints to values. In some cases
--   values with different types have the same serialized representation. This
--   structure disambiguates them.
data MemoEntry = MEEmpty | MECons {-# unpack #-} !Fingerprint !Any !MemoEntry

-- 2023-10-2 András: `typeRepFingerprint` usually inlines a 4-way case, which
-- yields significant code size increase as GHC often inlines the same code into
-- the branches. This wouldn't matter in "normal" code but the serialization
-- instances use very heavy inlining. The NOINLINE cuts down on the code size.
fingerprintNoinline :: TypeRep -> Fingerprint
fingerprintNoinline :: TypeRep -> Fingerprint
fingerprintNoinline TypeRep
rep = TypeRep -> Fingerprint
typeRepFingerprint TypeRep
rep
{-# NOINLINE fingerprintNoinline #-}

lookupME :: forall a. Proxy a -> Fingerprint -> MemoEntry -> (# a | (# #) #)
lookupME :: forall a. Proxy a -> Fingerprint -> MemoEntry -> (# a | (# #) #)
lookupME Proxy a
proxy Fingerprint
fprint MemoEntry
me = Fingerprint -> MemoEntry -> (# a | (# #) #)
go Fingerprint
fprint MemoEntry
me where
  go :: Fingerprint -> MemoEntry -> (# a | (# #) #)
  go :: Fingerprint -> MemoEntry -> (# a | (# #) #)
go Fingerprint
fp MemoEntry
MEEmpty =
    (# | (# #) #)
  go Fingerprint
fp (MECons Fingerprint
fp' Any
x MemoEntry
me)
    | Fingerprint
fp Fingerprint -> Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
== Fingerprint
fp' = let res :: a
res = Any -> a
forall a b. a -> b
unsafeCoerce Any
x in (# a
res | #)
    | Bool
True      = Fingerprint -> MemoEntry -> (# a | (# #) #)
go Fingerprint
fp MemoEntry
me
{-# NOINLINE lookupME #-}

type FreshAndReuse = MP.IOArray Word32

{-# INLINE bumpFresh #-}
bumpFresh :: FreshAndReuse -> IO Word32
bumpFresh :: FreshAndReuse -> IO Word32
bumpFresh FreshAndReuse
arr = do
  !n <- Array (PrimState IO) Word32 -> Int -> IO Word32
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Array (PrimState m) a -> Int -> m a
MP.unsafeRead FreshAndReuse
Array (PrimState IO) Word32
arr Int
0
  MP.unsafeWrite arr 0 (n + 1)
  pure n

{-# INLINE bumpReuse #-}
bumpReuse :: FreshAndReuse -> IO ()
bumpReuse :: FreshAndReuse -> IO ()
bumpReuse FreshAndReuse
arr = do
  !n <- Array (PrimState IO) Word32 -> Int -> IO Word32
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Array (PrimState m) a -> Int -> m a
MP.unsafeRead FreshAndReuse
Array (PrimState IO) Word32
arr Int
1
  MP.unsafeWrite arr 1 (n + 1)

farEmpty :: IO FreshAndReuse
farEmpty :: IO FreshAndReuse
farEmpty = do
  arr <- Int -> IO (Array (PrimState IO) Word32)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (Array (PrimState m) a)
MP.new Int
2
  MP.unsafeWrite arr 0 0
  MP.unsafeWrite arr 1 0
  pure arr

getFresh :: FreshAndReuse -> IO Word32
getFresh :: FreshAndReuse -> IO Word32
getFresh FreshAndReuse
far = Array (PrimState IO) Word32 -> Int -> IO Word32
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Array (PrimState m) a -> Int -> m a
MP.unsafeRead FreshAndReuse
Array (PrimState IO) Word32
far Int
0

getReuse :: FreshAndReuse -> IO Word32
getReuse :: FreshAndReuse -> IO Word32
getReuse FreshAndReuse
far = Array (PrimState IO) Word32 -> Int -> IO Word32
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Array (PrimState m) a -> Int -> m a
MP.unsafeRead FreshAndReuse
Array (PrimState IO) Word32
far Int
1

-- Andreas, 2026-03-12, issue #8465
-- | We need to distinguish 'A.Name's with different 'nameBindingSite',
--   so we complement the key 'NameId' with that 'Range'.
data NameIdR = NameIdR
  { NameIdR -> NameId
nidNameId      :: {-# UNPACK #-} !NameId
  , NameIdR -> Range
nidBindingSite :: !Range
  } deriving (NameIdR -> NameIdR -> Bool
(NameIdR -> NameIdR -> Bool)
-> (NameIdR -> NameIdR -> Bool) -> Eq NameIdR
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NameIdR -> NameIdR -> Bool
== :: NameIdR -> NameIdR -> Bool
$c/= :: NameIdR -> NameIdR -> Bool
/= :: NameIdR -> NameIdR -> Bool
Eq, (forall x. NameIdR -> Rep NameIdR x)
-> (forall x. Rep NameIdR x -> NameIdR) -> Generic NameIdR
forall x. Rep NameIdR x -> NameIdR
forall x. NameIdR -> Rep NameIdR x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NameIdR -> Rep NameIdR x
from :: forall x. NameIdR -> Rep NameIdR x
$cto :: forall x. Rep NameIdR x -> NameIdR
to :: forall x. Rep NameIdR x -> NameIdR
Generic)

instance Hashable NameIdR where
  {-# INLINE hashWithSalt #-}
  hashWithSalt :: Int -> NameIdR -> Int
hashWithSalt Int
h (NameIdR NameId
a Range
b) = Int
h Int -> NameId -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` NameId
a Int -> Range -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Range
b

-- | Computing a key of an abstract name.
nameIdR :: Name -> NameIdR
nameIdR :: Name -> NameIdR
nameIdR Name
x = NameId -> Range -> NameIdR
NameIdR (Name -> NameId
forall a. HasNameId a => a -> NameId
nameId Name
x) (Name -> Range
forall a. HasNameBindingSite a => a -> Range
nameBindingSite Name
x)

-- | Two 'QName's are equal if their @NameId@ is equal.
type QNameId = NameIdR

-- | Computing a key of a qualified name.
qnameId :: QName -> QNameId
qnameId :: QName -> NameIdR
qnameId = Name -> NameIdR
nameIdR (Name -> NameIdR) -> (QName -> Name) -> QName -> NameIdR
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName

-- | State of the the encoder.
data Dict = Dict
  -- Dictionaries which are serialized:
  { Dict -> HashSet Node
nodeD        :: !(HashSet Node)
  -- ^ Written to interface file.
  , Dict -> HashSet String
stringD      :: !(HashSet String)
  -- ^ Written to interface file.
  , Dict -> HashSet ByteArray
byteArrayD   :: !(HashSet ByteArray)
  -- ^ Written to interface file.
  , Dict -> HashSet Integer
integerD     :: !(HashSet Integer)
  -- ^ Written to interface file.
  , Dict -> HashSet VarSet
varSetD      :: !(HashSet VarSet)
  -- ^ Written to interface file.
  , Dict -> HashSet Word64
doubleD      :: !(HashSet Word64)
  -- ^ Written to interface file.
  --
  -- We store the exact bit pattern to avoid
  -- issues with subnormals, NaN, -0, etc.

  -- Dicitionaries which are not serialized, but provide
  -- short cuts to speed up serialization:
  -- Andreas, Makoto, AIM XXI
  -- Memoizing A.Name does not buy us much if we already memoize A.QName.
  -- Andreas, 2026-03-12
  -- Memoizing A.Name saves ~17% of serialization time (25s -> 21s for std-lib).
  , Dict -> HashTableLU NameIdR Word32
nameD        :: !(HashTableLU NameIdR Word32)
  -- ^ Not written to interface file.
  , Dict -> HashTableLU NameIdR Word32
qnameD       :: !(HashTableLU QNameId Word32)
  -- ^ Not written to interface file.

  -- Fresh UIDs and reuse statistics:
  , Dict -> FreshAndReuse
nodeC        :: !FreshAndReuse  -- counters for fresh indexes
  , Dict -> FreshAndReuse
stringC      :: !FreshAndReuse
  , Dict -> FreshAndReuse
byteArrayC   :: !FreshAndReuse
  , Dict -> FreshAndReuse
integerC     :: !FreshAndReuse
  , Dict -> FreshAndReuse
varSetC      :: !FreshAndReuse
  , Dict -> FreshAndReuse
doubleC      :: !FreshAndReuse
  , Dict -> FreshAndReuse
termC        :: !FreshAndReuse
  , Dict -> FreshAndReuse
nameC        :: !FreshAndReuse
  , Dict -> FreshAndReuse
qnameC       :: !FreshAndReuse
  , Dict -> HashTableLU String Int
stats        :: !(HashTableLU String Int)
  , Dict -> Bool
collectStats :: !Bool
    -- ^ If @True@ collect in @stats@ the quantities of
    --   calls to @icode@ for each @Typeable a@.
  }

-- | Creates an empty dictionary.
emptyDict
  :: Bool
     -- ^ Collect statistics for @icode@ calls?
  -> IO Dict
emptyDict :: Bool -> IO Dict
emptyDict Bool
collectStats = HashSet Node
-> HashSet String
-> HashSet ByteArray
-> HashSet Integer
-> HashSet VarSet
-> HashSet Word64
-> HashTableLU NameIdR Word32
-> HashTableLU NameIdR Word32
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> HashTableLU String Int
-> Bool
-> Dict
Dict
  (HashSet Node
 -> HashSet String
 -> HashSet ByteArray
 -> HashSet Integer
 -> HashSet VarSet
 -> HashSet Word64
 -> HashTableLU NameIdR Word32
 -> HashTableLU NameIdR Word32
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> HashTableLU String Int
 -> Bool
 -> Dict)
-> IO (HashSet Node)
-> IO
     (HashSet String
      -> HashSet ByteArray
      -> HashSet Integer
      -> HashSet VarSet
      -> HashSet Word64
      -> HashTableLU NameIdR Word32
      -> HashTableLU NameIdR Word32
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Int -> IO (HashSet Node)
forall a. Int -> IO (HashSet a)
HashSet.new Int
4096
  IO
  (HashSet String
   -> HashSet ByteArray
   -> HashSet Integer
   -> HashSet VarSet
   -> HashSet Word64
   -> HashTableLU NameIdR Word32
   -> HashTableLU NameIdR Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashSet String)
-> IO
     (HashSet ByteArray
      -> HashSet Integer
      -> HashSet VarSet
      -> HashSet Word64
      -> HashTableLU NameIdR Word32
      -> HashTableLU NameIdR Word32
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Int -> IO (HashSet String)
forall a. Int -> IO (HashSet a)
HashSet.new Int
4096
  IO
  (HashSet ByteArray
   -> HashSet Integer
   -> HashSet VarSet
   -> HashSet Word64
   -> HashTableLU NameIdR Word32
   -> HashTableLU NameIdR Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashSet ByteArray)
-> IO
     (HashSet Integer
      -> HashSet VarSet
      -> HashSet Word64
      -> HashTableLU NameIdR Word32
      -> HashTableLU NameIdR Word32
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Int -> IO (HashSet ByteArray)
forall a. Int -> IO (HashSet a)
HashSet.new Int
4096
  IO
  (HashSet Integer
   -> HashSet VarSet
   -> HashSet Word64
   -> HashTableLU NameIdR Word32
   -> HashTableLU NameIdR Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashSet Integer)
-> IO
     (HashSet VarSet
      -> HashSet Word64
      -> HashTableLU NameIdR Word32
      -> HashTableLU NameIdR Word32
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Int -> IO (HashSet Integer)
forall a. Int -> IO (HashSet a)
HashSet.new Int
4096
  IO
  (HashSet VarSet
   -> HashSet Word64
   -> HashTableLU NameIdR Word32
   -> HashTableLU NameIdR Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashSet VarSet)
-> IO
     (HashSet Word64
      -> HashTableLU NameIdR Word32
      -> HashTableLU NameIdR Word32
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Int -> IO (HashSet VarSet)
forall a. Int -> IO (HashSet a)
HashSet.new Int
4096
  IO
  (HashSet Word64
   -> HashTableLU NameIdR Word32
   -> HashTableLU NameIdR Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashSet Word64)
-> IO
     (HashTableLU NameIdR Word32
      -> HashTableLU NameIdR Word32
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Int -> IO (HashSet Word64)
forall a. Int -> IO (HashSet a)
HashSet.new Int
4096
  IO
  (HashTableLU NameIdR Word32
   -> HashTableLU NameIdR Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU NameIdR Word32)
-> IO
     (HashTableLU NameIdR Word32
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO (HashTableLU NameIdR Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
HashTable.empty
  IO
  (HashTableLU NameIdR Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU NameIdR Word32)
-> IO
     (FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO (HashTableLU NameIdR Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
HashTable.empty
  IO
  (FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO FreshAndReuse
-> IO
     (FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO
  (FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO FreshAndReuse
-> IO
     (FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO
  (FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO FreshAndReuse
-> IO
     (FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO
  (FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO FreshAndReuse
-> IO
     (FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO
  (FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO FreshAndReuse
-> IO
     (FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO
  (FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO FreshAndReuse
-> IO
     (FreshAndReuse
      -> FreshAndReuse
      -> FreshAndReuse
      -> HashTableLU String Int
      -> Bool
      -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO
  (FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO FreshAndReuse
-> IO
     (FreshAndReuse
      -> FreshAndReuse -> HashTableLU String Int -> Bool -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO
  (FreshAndReuse
   -> FreshAndReuse -> HashTableLU String Int -> Bool -> Dict)
-> IO FreshAndReuse
-> IO (FreshAndReuse -> HashTableLU String Int -> Bool -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO (FreshAndReuse -> HashTableLU String Int -> Bool -> Dict)
-> IO FreshAndReuse -> IO (HashTableLU String Int -> Bool -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO FreshAndReuse
farEmpty
  IO (HashTableLU String Int -> Bool -> Dict)
-> IO (HashTableLU String Int) -> IO (Bool -> Dict)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> IO (HashTableLU String Int)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
HashTable.empty
  IO (Bool -> Dict) -> IO Bool -> IO Dict
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
collectStats

-- | Decoder arguments.
data Decode = Decode
  { Decode -> IOArray MemoEntry
nodeMemo  :: !(ML.IOArray MemoEntry)
  -- ^ Created and modified by decoder.
  -- Used to introduce sharing while deserializing objects.
  , Decode -> Compact
arena     :: !Compact
  -- ^ Compact region where the decoded interface is allocated.
  , Decode -> Array Node
nodeA      :: !(AL.Array Node)
  -- ^ Obtained from interface.
  , Decode -> Array String
stringA    :: !(AL.Array String)
  -- ^ Obtained from interface.
  , Decode -> Array ByteArray
byteArrayA :: !(AL.Array ByteArray)
  -- ^ Obtained from interface.
  , Decode -> Array Integer
integerA   :: !(AL.Array Integer)
  -- ^ Obtained from interface.
  , Decode -> Array VarSet
varSetA    :: !(AL.Array VarSet)
  -- ^ Obtained from interface.
  , Decode -> Array Word64
doubleA    :: !(AL.Array Word64)
  -- ^ Obtained from interface.
  , Decode -> HashTableLL AbsolutePath AbsolutePath
filePathMemo :: !(HashTableLL AbsolutePath AbsolutePath)
    -- ^ Memoizes filepaths computed for RangeFile-s.
  , Decode -> IORef ModuleToSource
modFile   :: !(IORef ModuleToSource)
    -- ^ Maps module names to file names. Constructed by the decoder.
  , Decode -> List1 AbsolutePath
includes  :: !(List1 AbsolutePath)
    -- ^ The include directories.
  }

-- | Monad used by the encoder.
type S a = ReaderT Dict IO a

-- | Monad used by the decoder.
--
-- 'TCM' is not used because the associated overheads would make
-- decoding slower.
type R = ReaderT Decode IO

malformed :: R a
malformed :: forall a. R a
malformed = IO a -> ReaderT Decode IO a
forall a. IO a -> ReaderT Decode IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT Decode IO a) -> IO a -> ReaderT Decode IO a
forall a b. (a -> b) -> a -> b
$ ErrorCall -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (ErrorCall -> IO a) -> ErrorCall -> IO a
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
E.ErrorCall String
"Malformed input."
{-# NOINLINE malformed #-} -- 2023-10-2 András: cold code, so should be out-of-line.

malformedIO :: IO a
malformedIO :: forall a. IO a
malformedIO = ErrorCall -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
E.throwIO (ErrorCall -> IO a) -> ErrorCall -> IO a
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
E.ErrorCall String
"Malformed input."
{-# NOINLINE malformedIO #-}

class Typeable a => EmbPrj a where
  icode :: a -> S Word32  -- ^ Serialization (wrapper).
  icod_ :: a -> S Word32  -- ^ Serialization (worker).
  value :: Word32 -> R a  -- ^ Deserialization.

#ifdef DEBUG_SERIALISATION
  icode a = do
    !r <- icod_ a
    tickICode a
    pure r
#else
  icode a
a = a -> S Word32
forall a. EmbPrj a => a -> S Word32
icod_ a
a
#endif
  {-# INLINE icode #-}

  -- Simple enumeration types can be (de)serialized using (from/to)Enum.
  default value :: (Enum a, Bounded a) => Word32 -> R a
  value Word32
i =
    let i' :: Int
i' = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i in
    if Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= a -> Int
forall a. Enum a => a -> Int
fromEnum (a
forall a. Bounded a => a
minBound :: a) Bool -> Bool -> Bool
&& Int
i' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> Int
forall a. Enum a => a -> Int
fromEnum (a
forall a. Bounded a => a
maxBound :: a)
    then a -> R a
forall a. a -> ReaderT Decode IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> R a) -> a -> R a
forall a b. (a -> b) -> a -> b
$! Int -> a
forall a. Enum a => Int -> a
toEnum Int
i'
    else R a
forall a. R a
malformed

  default icod_ :: (Enum a) => a -> S Word32
  icod_ a
x = Word32 -> S Word32
forall a. a -> ReaderT Dict IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> S Word32) -> Word32 -> S Word32
forall a b. (a -> b) -> a -> b
$! Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$! a -> Int
forall a. Enum a => a -> Int
fromEnum a
x

-- | The actual logic of `tickICode` is cold code, so it's out-of-line,
--   to decrease code size and avoid cache pollution.
goTickIcode :: forall a. Typeable a => Proxy a -> S ()
goTickIcode :: forall a. Typeable a => Proxy a -> S ()
goTickIcode Proxy a
p = do
  let key :: String
key = String
"icode " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy a
p)
  hmap <- (Dict -> HashTableLU String Int)
-> ReaderT Dict IO (HashTableLU String Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTableLU String Int
stats
  liftIO do
    n <- fromMaybe 0 <$> HashTable.lookup hmap key
    HashTable.insert hmap key $! n + 1
{-# NOINLINE goTickIcode #-}

-- | Increase entry for @a@ in 'stats'.
tickICode :: forall a. Typeable a => a -> S ()
tickICode :: forall a. Typeable a => a -> S ()
tickICode a
_ = ReaderT Dict IO Bool -> S () -> S ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Dict -> Bool) -> ReaderT Dict IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> Bool
collectStats) (S () -> S ()) -> S () -> S ()
forall a b. (a -> b) -> a -> b
$ Proxy a -> S ()
forall a. Typeable a => Proxy a -> S ()
goTickIcode (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
{-# INLINE tickICode #-}

icodeByteArray :: ByteArray -> S Word32
icodeByteArray :: ByteArray -> S Word32
icodeByteArray arr :: ByteArray
arr@(ByteArray ByteArray#
bytes) = do
  d <- (Dict -> HashSet ByteArray) -> ReaderT Dict IO (HashSet ByteArray)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashSet ByteArray
byteArrayD
  c <- asks byteArrayC
  -- Hashing the entire byte string doesn't give us that much extra
  -- entropy and is slow. Instead, grab an aligned 128 byte chunk off
  -- the end.
  --
  -- Using the last bytes is noticably better than using the first.
  -- Most of our ByteArrays are the entire contents of Mikan files,
  -- and can often share the same imports at the start of a file.
  -- Additionally, a collision of the starting hash means that our equality
  -- test will need to make it through 128 bytes again before being able to
  -- disambiguate.
  --
  -- In practice, this shaves off ~2% of mutator time!
  let n = ByteArray -> Int
sizeofByteArray ByteArray
arr
  let h =
        if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
128 then
          ByteArray# -> Int -> Int -> Int
hashByteArray ByteArray#
bytes Int
0 Int
n
        else
          -- We make sure to align on a 8 byte boundary to
          -- avoid doing unaligned reads while hashing
          --
          -- This makes a HUGE difference: nearly 8% of mutator time!
          ByteArray# -> Int -> Int -> Int
hashByteArray ByteArray#
bytes (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
128 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int -> Int
forall a. Bits a => a -> a
complement Int
7) Int
128
  liftIO $
    HashSet.insertingIfAbsent d arr h
      (\ByteArray
_ Int
i -> do
#ifdef DEBUG_SERIALISATION
        bumpReuse c
#endif
        Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
      (pure . fromIntegral)

icodeInteger :: Integer -> S Word32
icodeInteger :: Integer -> S Word32
icodeInteger Integer
key = do
  d <- (Dict -> HashSet Integer) -> ReaderT Dict IO (HashSet Integer)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashSet Integer
integerD
  c <- asks integerC
  liftIO $
    HashSet.insertingIfAbsent d key (hash key)
      (\Integer
_ Int
i -> do
#ifdef DEBUG_SERIALISATION
        bumpReuse c
#endif
        Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
      (pure . fromIntegral)

icodeVarSet :: VarSet -> S Word32
icodeVarSet :: VarSet -> S Word32
icodeVarSet VarSet
key = do
  d <- (Dict -> HashSet VarSet) -> ReaderT Dict IO (HashSet VarSet)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashSet VarSet
varSetD
  c <- asks varSetC
  liftIO $
    HashSet.insertingIfAbsent d key (hash key)
      (\VarSet
_ Int
i -> do
#ifdef DEBUG_SERIALISATION
        bumpReuse c
#endif
        Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
      (pure . fromIntegral)

icodeDouble :: Double -> S Word32
icodeDouble :: Double -> S Word32
icodeDouble Double
key = do
  d <- (Dict -> HashSet Word64) -> ReaderT Dict IO (HashSet Word64)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashSet Word64
doubleD
  c <- asks doubleC
  -- The 'Hashable' and 'Eq' instances for 'Double' conflate -0 and 0,
  -- which can lead to inconsistencies: see agda#8697 and
  -- @test/Fail/customised/Upstream8697.agda@. To avoid this, we
  -- serialize the underlying bit-pattern of the 'Double' instead.
  let bits = Double -> Word64
castDoubleToWord64 Double
key
  liftIO $
    HashSet.insertingIfAbsent d bits (hash bits)
      (\Word64
_ Int
i -> do
#ifdef DEBUG_SERIALISATION
        bumpReuse c
#endif
        Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
      (pure . fromIntegral)

icodeString :: String -> S Word32
icodeString :: String -> S Word32
icodeString String
key = do
  d <- (Dict -> HashSet String) -> ReaderT Dict IO (HashSet String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashSet String
stringD
  c <- asks stringC
  liftIO $
    HashSet.insertingIfAbsent d key (hash key)
      (\String
_ Int
i -> do
#ifdef DEBUG_SERIALISATION
        bumpReuse c
#endif
        Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
      (pure . fromIntegral)

icodeNode :: Node -> S Word32
icodeNode :: Node -> S Word32
icodeNode Node
key = do
  d <- (Dict -> HashSet Node) -> ReaderT Dict IO (HashSet Node)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashSet Node
nodeD
  c <- asks nodeC
  liftIO $
    HashSet.insertingIfAbsent d key (hash key)
      (\Node
_ Int
i -> do
#ifdef DEBUG_SERIALISATION
        bumpReuse c
#endif
        Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
      (pure . fromIntegral)


{-# INLINE icodeMemo #-}
-- | @icode@ only if thing has not been seen before.
icodeMemo
  :: (Hashable a)
  => (Dict -> HashTableLU a Word32)
  -- ^ Memo structure for thing of key @a@.
  -> (Dict -> FreshAndReuse)
  -- ^ Counter and statistics.
  -> a
  -- ^ Key to the thing.
  -> S Word32
  -- ^ Fallback computation to encode the thing.
  -> S Word32
  -- ^ Encoded thing.
icodeMemo :: forall a.
Hashable a =>
(Dict -> HashTableLU a Word32)
-> (Dict -> FreshAndReuse) -> a -> S Word32 -> S Word32
icodeMemo Dict -> HashTableLU a Word32
getDict Dict -> FreshAndReuse
getCounter a
a S Word32
icodeP = (Dict -> IO Word32) -> S Word32
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \Dict
dict -> do
  let !c :: FreshAndReuse
c = Dict -> FreshAndReuse
getCounter Dict
dict
      !d :: HashTableLU a Word32
d = Dict -> HashTableLU a Word32
getDict Dict
dict
  HashTableLU a Word32
-> a
-> (Word32 -> IO Word32)
-> IO Word32
-> (Word32 -> IO Word32)
-> IO Word32
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v a.
(Hashable k, MVector ks k, MVector vs v) =>
HashTable ks k vs v
-> k -> (v -> IO a) -> IO v -> (v -> IO a) -> IO a
HashTable.insertingIfAbsent HashTableLU a Word32
d a
a
    (\Word32
i -> do
#ifdef DEBUG_SERIALISATION
        bumpReuse c
#endif
        Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
i)
    (do _ <- FreshAndReuse -> IO Word32
bumpFresh FreshAndReuse
c
        runReaderT icodeP dict)
    Word32 -> IO Word32
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

{-# INLINE vcase #-}
-- | @vcase value ix@ decodes thing represented by @ix :: Word32@
--   via the @valu@ function and stores it in 'nodeMemo'.
--   If @ix@ is present in 'nodeMemo', @valu@ is not used, but
--   the thing is read from 'nodeMemo' instead.
vcase :: forall a . EmbPrj a => (Node -> R a) -> Word32 -> R a
vcase :: forall a. EmbPrj a => (Node -> R a) -> Word32 -> R a
vcase Node -> R a
valu = \Word32
ix -> (Decode -> IO a) -> R a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \Decode
dict -> do
    let !memo :: IOArray MemoEntry
memo = Decode -> IOArray MemoEntry
nodeMemo Decode
dict

    let !fp :: Fingerprint
fp = TypeRep -> Fingerprint
fingerprintNoinline (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
    -- to introduce sharing, see if we have seen a thing
    -- represented by ix before
    let !iix :: Int
iix = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
ix :: Int
    !slot <- Array (PrimState IO) MemoEntry -> Int -> IO MemoEntry
forall (m :: * -> *) a.
PrimMonad m =>
Array (PrimState m) a -> Int -> m a
ML.read IOArray MemoEntry
Array (PrimState IO) MemoEntry
memo Int
iix
    case lookupME (Proxy :: Proxy a) fp slot of
      -- use the stored value
      (# a
a | #) ->
        a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      (# a | (# #) #)
_  -> do
        !v <- R a -> Decode -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Node -> R a
valu (Array Node -> Int -> Node
forall a. Array a -> Int -> a
AL.index (Decode -> Array Node
nodeA Decode
dict) Int
iix)) Decode
dict
        !v <- Compact.add (arena dict) v
        ML.write memo iix $! MECons fp (unsafeCoerce v) slot
        return v


-- Arity-generic functions
----------------------------------------------------------------------------------------------------

-- | @icodeArgs proxy (a1, ..., an)@ maps @icode@ over @a1@, ..., @an@
--   and returns the corresponding list of @Word32@.
class ICODE t (a :: Nat) where
  icodeArgs :: Arity t ~ a => All EmbPrj (Domains t) =>
               Proxy t -> StrictProducts (Domains t) -> S Node

instance ICODE t 'Zero where
  icodeArgs :: (Arity t ~ 'Zero, All EmbPrj (Domains t)) =>
Proxy t -> StrictProducts (Domains t) -> S Node
icodeArgs Proxy t
_ StrictProducts (Domains t)
_  = Node -> S Node
forall a. a -> ReaderT Dict IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Node
N0
  {-# INLINE icodeArgs #-}

instance ICODE (a -> t) ('Suc 'Zero) where
  icodeArgs :: (Arity (a -> t) ~ 'Suc 'Zero, All EmbPrj (Domains (a -> t))) =>
Proxy (a -> t) -> StrictProducts (Domains (a -> t)) -> S Node
icodeArgs Proxy (a -> t)
_ (Pair a
a ()
_) = do
    !a <- a -> S Word32
forall a. EmbPrj a => a -> S Word32
icode a
a
    pure $ N1 a
  {-# INLINE icodeArgs #-}

instance ICODE (a -> b -> t) ('Suc ('Suc 'Zero)) where
  icodeArgs :: (Arity (a -> b -> t) ~ 'Suc ('Suc 'Zero),
 All EmbPrj (Domains (a -> b -> t))) =>
Proxy (a -> b -> t)
-> StrictProducts (Domains (a -> b -> t)) -> S Node
icodeArgs Proxy (a -> b -> t)
_ (Pair a
a (Pair b
b ()
_)) = do
    !a <- a -> S Word32
forall a. EmbPrj a => a -> S Word32
icode a
a
    !b <- icode b
    pure $ N2 a b
  {-# INLINE icodeArgs #-}

instance ICODE (a -> b -> c -> t) ('Suc ('Suc ('Suc 'Zero))) where
  icodeArgs :: (Arity (a -> b -> c -> t) ~ 'Suc ('Suc ('Suc 'Zero)),
 All EmbPrj (Domains (a -> b -> c -> t))) =>
Proxy (a -> b -> c -> t)
-> StrictProducts (Domains (a -> b -> c -> t)) -> S Node
icodeArgs Proxy (a -> b -> c -> t)
_ (Pair a
a (Pair b
b (Pair c
c ()
_))) = do
    !a <- a -> S Word32
forall a. EmbPrj a => a -> S Word32
icode a
a
    !b <- icode b
    !c <- icode c
    pure $ N3 a b c
  {-# INLINE icodeArgs #-}

instance ICODE (a -> b -> c -> d -> t) ('Suc ('Suc ('Suc ('Suc 'Zero)))) where
  icodeArgs :: (Arity (a -> b -> c -> d -> t) ~ 'Suc ('Suc ('Suc ('Suc 'Zero))),
 All EmbPrj (Domains (a -> b -> c -> d -> t))) =>
Proxy (a -> b -> c -> d -> t)
-> StrictProducts (Domains (a -> b -> c -> d -> t)) -> S Node
icodeArgs Proxy (a -> b -> c -> d -> t)
_ (Pair a
a (Pair b
b (Pair c
c (Pair d
d ()
_)))) = do
    !a <- a -> S Word32
forall a. EmbPrj a => a -> S Word32
icode a
a
    !b <- icode b
    !c <- icode c
    !d <- icode d
    pure $ N4 a b c d
  {-# INLINE icodeArgs #-}

instance ICODE (a -> b -> c -> d -> e -> t) ('Suc ('Suc ('Suc ('Suc ('Suc 'Zero))))) where
  icodeArgs :: (Arity (a -> b -> c -> d -> e -> t)
 ~ 'Suc ('Suc ('Suc ('Suc ('Suc 'Zero)))),
 All EmbPrj (Domains (a -> b -> c -> d -> e -> t))) =>
Proxy (a -> b -> c -> d -> e -> t)
-> StrictProducts (Domains (a -> b -> c -> d -> e -> t)) -> S Node
icodeArgs Proxy (a -> b -> c -> d -> e -> t)
_ (Pair a
a (Pair b
b (Pair c
c (Pair d
d (Pair e
e ()
_))))) = do
    !a <- a -> S Word32
forall a. EmbPrj a => a -> S Word32
icode a
a
    !b <- icode b
    !c <- icode c
    !d <- icode d
    !e <- icode e
    pure $ N5 a b c d e
  {-# INLINE icodeArgs #-}

instance ICODE t n
      => ICODE (a -> b -> c -> d -> e -> f -> t)
               ('Suc ('Suc ('Suc ('Suc ('Suc ('Suc n)))))) where
  icodeArgs :: (Arity (a -> b -> c -> d -> e -> f -> t)
 ~ 'Suc ('Suc ('Suc ('Suc ('Suc ('Suc n))))),
 All EmbPrj (Domains (a -> b -> c -> d -> e -> f -> t))) =>
Proxy (a -> b -> c -> d -> e -> f -> t)
-> StrictProducts (Domains (a -> b -> c -> d -> e -> f -> t))
-> S Node
icodeArgs Proxy (a -> b -> c -> d -> e -> f -> t)
_ (Pair a
a (Pair b
b (Pair c
c (Pair d
d (Pair e
e (Pair f
f Foldr StrictPair () (If (IsZero n) '[] (Domains' t))
n)))))) = do
    !a <- a -> S Word32
forall a. EmbPrj a => a -> S Word32
icode a
a
    !b <- icode b
    !c <- icode c
    !d <- icode d
    !e <- icode e
    !f <- icode f
    !n <- icodeArgs (Proxy :: Proxy t) n
    pure $ N6 a b c d e f n
  {-# INLINE icodeArgs #-}

-- | @icodeN tag t a1 ... an@ serialises the arguments @a1@, ..., @an@ of the
--   constructor @t@ together with a tag @tag@ picked to disambiguate between
--   different constructors.
--   It corresponds to @icodeNode . (tag :) =<< mapM icode [a1, ..., an]@

{-# INLINE icodeN #-}
icodeN :: forall t. ICODE (Word32 -> t) (Arity (Word32 -> t))
       => StrictCurrying (Domains (Word32 -> t)) (S Word32)
       => All EmbPrj (Domains (Word32 -> t)) =>
          Word32 -> t -> Arrows (Domains t) (S Word32)
icodeN :: forall t.
(ICODE (Word32 -> t) (Arity (Word32 -> t)),
 StrictCurrying (Domains (Word32 -> t)) (S Word32),
 All EmbPrj (Domains (Word32 -> t))) =>
Word32 -> t -> Arrows (Domains t) (S Word32)
icodeN Word32
tag t
_ =
   Proxy (Word32 : If (IsZero (Arity t)) '[] (Domains' t))
-> Proxy (S Word32)
-> (StrictProducts
      (Word32 : If (IsZero (Arity t)) '[] (Domains' t))
    -> S Word32)
-> Arrows
     (Word32 : If (IsZero (Arity t)) '[] (Domains' t)) (S Word32)
forall (as :: [*]) b.
StrictCurrying as b =>
Proxy as -> Proxy b -> (StrictProducts as -> b) -> Arrows as b
strictCurrys
      (Proxy (Word32 : If (IsZero (Arity t)) '[] (Domains' t))
Proxy (Domains (Word32 -> t))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Domains (Word32 -> t)))
      (Proxy (S Word32)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (S Word32))
      (\ !StrictProducts (Word32 : If (IsZero (Arity t)) '[] (Domains' t))
args -> do !node <- Proxy (Word32 -> t)
-> StrictProducts (Domains (Word32 -> t)) -> S Node
forall t (a :: Nat).
(ICODE t a, Arity t ~ a, All EmbPrj (Domains t)) =>
Proxy t -> StrictProducts (Domains t) -> S Node
icodeArgs (Proxy (Word32 -> t)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Word32 -> t)) StrictProducts (Word32 : If (IsZero (Arity t)) '[] (Domains' t))
StrictProducts (Domains (Word32 -> t))
args
                     icodeNode node)
      Word32
tag

-- | @icodeN'@ is the same as @icodeN@ except that there is no tag
{-# INLINE icodeN' #-}
icodeN' :: forall t. ICODE t (Arity t) => StrictCurrying (Domains t) (S Word32) =>
           All EmbPrj (Domains t) =>
           t -> Arrows (Domains t) (S Word32)
icodeN' :: forall t.
(ICODE t (Arity t), StrictCurrying (Domains t) (S Word32),
 All EmbPrj (Domains t)) =>
t -> Arrows (Domains t) (S Word32)
icodeN' t
_ =
  Proxy (If (IsZero (Arity t)) '[] (Domains' t))
-> Proxy (S Word32)
-> (Foldr StrictPair () (If (IsZero (Arity t)) '[] (Domains' t))
    -> S Word32)
-> Arrows (If (IsZero (Arity t)) '[] (Domains' t)) (S Word32)
forall (as :: [*]) b.
StrictCurrying as b =>
Proxy as -> Proxy b -> (StrictProducts as -> b) -> Arrows as b
strictCurrys (Proxy (Domains t)
Proxy (If (IsZero (Arity t)) '[] (Domains' t))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Domains t)) (Proxy (S Word32)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (S Word32)) ((Foldr StrictPair () (If (IsZero (Arity t)) '[] (Domains' t))
  -> S Word32)
 -> Arrows (If (IsZero (Arity t)) '[] (Domains' t)) (S Word32))
-> (Foldr StrictPair () (If (IsZero (Arity t)) '[] (Domains' t))
    -> S Word32)
-> Arrows (If (IsZero (Arity t)) '[] (Domains' t)) (S Word32)
forall a b. (a -> b) -> a -> b
$ \ !Foldr StrictPair () (If (IsZero (Arity t)) '[] (Domains' t))
args -> do
    !node <- Proxy t -> StrictProducts (Domains t) -> S Node
forall t (a :: Nat).
(ICODE t a, Arity t ~ a, All EmbPrj (Domains t)) =>
Proxy t -> StrictProducts (Domains t) -> S Node
icodeArgs (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) StrictProducts (Domains t)
Foldr StrictPair () (If (IsZero (Arity t)) '[] (Domains' t))
args
    icodeNode node


-- Instead of having up to 25 versions of @valu N@, we define
-- the class VALU which generates them by typeclass resolution.
-- All of these should get inlined at compile time.

class VALU t (a :: Nat) where
  valuN' :: a ~ Arity t =>
            All EmbPrj (Domains t) =>
            t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t)

  valueArgs :: a ~ Arity t =>
               All EmbPrj (CoDomain t ': Domains t) =>
               Proxy t -> Node -> Maybe (StrictProducts (Constant Word32 (Domains t)))

instance VALU t 'Zero where
  {-# INLINE valuN' #-}
  valuN' :: ('Zero ~ Arity t, All EmbPrj (Domains t)) =>
t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t)
valuN' t
f StrictProducts (Constant Word32 (Domains t))
_ = t -> ReaderT Decode IO t
forall a. a -> ReaderT Decode IO a
forall (m :: * -> *) a. Monad m => a -> m a
return t
f
  {-# INLINE valueArgs #-}
  valueArgs :: ('Zero ~ Arity t, All EmbPrj (CoDomain t : Domains t)) =>
Proxy t
-> Node -> Maybe (StrictProducts (Constant Word32 (Domains t)))
valueArgs Proxy t
_ Node
xs = case Node
xs of
    Node
N0 -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
    Node
_  -> Maybe ()
Maybe (StrictProducts (Constant Word32 (Domains t)))
forall a. Maybe a
Nothing

instance VALU (a -> t) ('Suc 'Zero) where
  {-# INLINE valuN' #-}
  valuN' :: ('Suc 'Zero ~ Arity (a -> t), All EmbPrj (Domains (a -> t))) =>
(a -> t)
-> StrictProducts (Constant Word32 (Domains (a -> t)))
-> R (CoDomain (a -> t))
valuN' a -> t
f (Pair Word32
a ()
_) = do
    !a <- Word32 -> R a
forall a. EmbPrj a => Word32 -> R a
value Word32
a
    return $! f a
  {-# INLINE valueArgs #-}
  valueArgs :: ('Suc 'Zero ~ Arity (a -> t),
 All EmbPrj (CoDomain (a -> t) : Domains (a -> t))) =>
Proxy (a -> t)
-> Node
-> Maybe (StrictProducts (Constant Word32 (Domains (a -> t))))
valueArgs Proxy (a -> t)
_ Node
xs = case Node
xs of
    N1 Word32
a -> StrictPair Word32 () -> Maybe (StrictPair Word32 ())
forall a. a -> Maybe a
Just (Word32 -> () -> StrictPair Word32 ()
forall a b. a -> b -> StrictPair a b
Pair Word32
a ())
    Node
_    -> Maybe (StrictProducts (Constant Word32 (Domains (a -> t))))
Maybe (StrictPair Word32 ())
forall a. Maybe a
Nothing

instance VALU (a -> b -> t) ('Suc ('Suc 'Zero)) where
  {-# INLINE valuN' #-}
  valuN' :: ('Suc ('Suc 'Zero) ~ Arity (a -> b -> t),
 All EmbPrj (Domains (a -> b -> t))) =>
(a -> b -> t)
-> StrictProducts (Constant Word32 (Domains (a -> b -> t)))
-> R (CoDomain (a -> b -> t))
valuN' a -> b -> t
f (Pair Word32
a (Pair Word32
b ()
_)) = do
    !a <- Word32 -> R a
forall a. EmbPrj a => Word32 -> R a
value Word32
a
    !b <- value b
    return $! f a b
  {-# INLINE valueArgs #-}
  valueArgs :: ('Suc ('Suc 'Zero) ~ Arity (a -> b -> t),
 All EmbPrj (CoDomain (a -> b -> t) : Domains (a -> b -> t))) =>
Proxy (a -> b -> t)
-> Node
-> Maybe (StrictProducts (Constant Word32 (Domains (a -> b -> t))))
valueArgs Proxy (a -> b -> t)
_ Node
xs = case Node
xs of
    N2 Word32
a Word32
b -> StrictPair Word32 (StrictPair Word32 ())
-> Maybe (StrictPair Word32 (StrictPair Word32 ()))
forall a. a -> Maybe a
Just (Word32
-> StrictPair Word32 () -> StrictPair Word32 (StrictPair Word32 ())
forall a b. a -> b -> StrictPair a b
Pair Word32
a (Word32 -> () -> StrictPair Word32 ()
forall a b. a -> b -> StrictPair a b
Pair Word32
b ()))
    Node
_      -> Maybe (StrictProducts (Constant Word32 (Domains (a -> b -> t))))
Maybe (StrictPair Word32 (StrictPair Word32 ()))
forall a. Maybe a
Nothing

instance VALU (a -> b -> c -> t) ('Suc ('Suc ('Suc 'Zero))) where
  {-# INLINE valuN' #-}
  valuN' :: ('Suc ('Suc ('Suc 'Zero)) ~ Arity (a -> b -> c -> t),
 All EmbPrj (Domains (a -> b -> c -> t))) =>
(a -> b -> c -> t)
-> StrictProducts (Constant Word32 (Domains (a -> b -> c -> t)))
-> R (CoDomain (a -> b -> c -> t))
valuN' a -> b -> c -> t
f (Pair Word32
a (Pair Word32
b (Pair Word32
c ()
_))) = do
    !a <- Word32 -> R a
forall a. EmbPrj a => Word32 -> R a
value Word32
a
    !b <- value b
    !c <- value c
    return $! f a b c
  {-# INLINE valueArgs #-}
  valueArgs :: ('Suc ('Suc ('Suc 'Zero)) ~ Arity (a -> b -> c -> t),
 All
   EmbPrj
   (CoDomain (a -> b -> c -> t) : Domains (a -> b -> c -> t))) =>
Proxy (a -> b -> c -> t)
-> Node
-> Maybe
     (StrictProducts (Constant Word32 (Domains (a -> b -> c -> t))))
valueArgs Proxy (a -> b -> c -> t)
_ Node
xs = case Node
xs of
    N3 Word32
a Word32
b Word32
c -> StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))
-> Maybe
     (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))
forall a. a -> Maybe a
Just (Word32
-> StrictPair Word32 (StrictPair Word32 ())
-> StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))
forall a b. a -> b -> StrictPair a b
Pair Word32
a (Word32
-> StrictPair Word32 () -> StrictPair Word32 (StrictPair Word32 ())
forall a b. a -> b -> StrictPair a b
Pair Word32
b (Word32 -> () -> StrictPair Word32 ()
forall a b. a -> b -> StrictPair a b
Pair Word32
c ())))
    Node
_        -> Maybe
  (StrictProducts (Constant Word32 (Domains (a -> b -> c -> t))))
Maybe
  (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))
forall a. Maybe a
Nothing

instance VALU (a -> b -> c -> d -> t) ('Suc ('Suc ('Suc ('Suc 'Zero)))) where
  {-# INLINE valuN' #-}
  valuN' :: ('Suc ('Suc ('Suc ('Suc 'Zero))) ~ Arity (a -> b -> c -> d -> t),
 All EmbPrj (Domains (a -> b -> c -> d -> t))) =>
(a -> b -> c -> d -> t)
-> StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> t)))
-> R (CoDomain (a -> b -> c -> d -> t))
valuN' a -> b -> c -> d -> t
f (Pair Word32
a (Pair Word32
b (Pair Word32
c (Pair Word32
d ()
_)))) = do
    !a <- Word32 -> R a
forall a. EmbPrj a => Word32 -> R a
value Word32
a
    !b <- value b
    !c <- value c
    !d <- value d
    return $! f a b c d
  {-# INLINE valueArgs #-}
  valueArgs :: ('Suc ('Suc ('Suc ('Suc 'Zero))) ~ Arity (a -> b -> c -> d -> t),
 All
   EmbPrj
   (CoDomain (a -> b -> c -> d -> t)
      : Domains (a -> b -> c -> d -> t))) =>
Proxy (a -> b -> c -> d -> t)
-> Node
-> Maybe
     (StrictProducts
        (Constant Word32 (Domains (a -> b -> c -> d -> t))))
valueArgs Proxy (a -> b -> c -> d -> t)
_ Node
xs = case Node
xs of
    N4 Word32
a Word32
b Word32
c Word32
d -> StrictPair
  Word32
  (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))
-> Maybe
     (StrictPair
        Word32
        (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))))
forall a. a -> Maybe a
Just (Word32
-> StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))
-> StrictPair
     Word32
     (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))
forall a b. a -> b -> StrictPair a b
Pair Word32
a (Word32
-> StrictPair Word32 (StrictPair Word32 ())
-> StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))
forall a b. a -> b -> StrictPair a b
Pair Word32
b (Word32
-> StrictPair Word32 () -> StrictPair Word32 (StrictPair Word32 ())
forall a b. a -> b -> StrictPair a b
Pair Word32
c (Word32 -> () -> StrictPair Word32 ()
forall a b. a -> b -> StrictPair a b
Pair Word32
d ()))))
    Node
_          -> Maybe
  (StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> t))))
Maybe
  (StrictPair
     Word32
     (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))))
forall a. Maybe a
Nothing

instance VALU (a -> b -> c -> d -> e -> t) ('Suc ('Suc ('Suc ('Suc ('Suc 'Zero))))) where
  {-# INLINE valuN' #-}
  valuN' :: ('Suc ('Suc ('Suc ('Suc ('Suc 'Zero))))
 ~ Arity (a -> b -> c -> d -> e -> t),
 All EmbPrj (Domains (a -> b -> c -> d -> e -> t))) =>
(a -> b -> c -> d -> e -> t)
-> StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> e -> t)))
-> R (CoDomain (a -> b -> c -> d -> e -> t))
valuN' a -> b -> c -> d -> e -> t
f (Pair Word32
a (Pair Word32
b (Pair Word32
c (Pair Word32
d (Pair Word32
e ()
_))))) = do
    !a <- Word32 -> R a
forall a. EmbPrj a => Word32 -> R a
value Word32
a
    !b <- value b
    !c <- value c
    !d <- value d
    !e <- value e
    return $! f a b c d e
  {-# INLINE valueArgs #-}
  valueArgs :: ('Suc ('Suc ('Suc ('Suc ('Suc 'Zero))))
 ~ Arity (a -> b -> c -> d -> e -> t),
 All
   EmbPrj
   (CoDomain (a -> b -> c -> d -> e -> t)
      : Domains (a -> b -> c -> d -> e -> t))) =>
Proxy (a -> b -> c -> d -> e -> t)
-> Node
-> Maybe
     (StrictProducts
        (Constant Word32 (Domains (a -> b -> c -> d -> e -> t))))
valueArgs Proxy (a -> b -> c -> d -> e -> t)
_ Node
xs = case Node
xs of
    N5 Word32
a Word32
b Word32
c Word32
d Word32
e -> StrictPair
  Word32
  (StrictPair
     Word32
     (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))))
-> Maybe
     (StrictPair
        Word32
        (StrictPair
           Word32
           (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))))
forall a. a -> Maybe a
Just (Word32
-> StrictPair
     Word32
     (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))
-> StrictPair
     Word32
     (StrictPair
        Word32
        (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))))
forall a b. a -> b -> StrictPair a b
Pair Word32
a (Word32
-> StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))
-> StrictPair
     Word32
     (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))
forall a b. a -> b -> StrictPair a b
Pair Word32
b (Word32
-> StrictPair Word32 (StrictPair Word32 ())
-> StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))
forall a b. a -> b -> StrictPair a b
Pair Word32
c (Word32
-> StrictPair Word32 () -> StrictPair Word32 (StrictPair Word32 ())
forall a b. a -> b -> StrictPair a b
Pair Word32
d (Word32 -> () -> StrictPair Word32 ()
forall a b. a -> b -> StrictPair a b
Pair Word32
e ())))))
    Node
_            -> Maybe
  (StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> e -> t))))
Maybe
  (StrictPair
     Word32
     (StrictPair
        Word32
        (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))))
forall a. Maybe a
Nothing

instance VALU t n
      => VALU (a -> b -> c -> d -> e -> f -> t)
              ('Suc ('Suc ('Suc ('Suc ('Suc ('Suc n)))))) where
  {-# INLINE valuN' #-}
  valuN' :: ('Suc ('Suc ('Suc ('Suc ('Suc ('Suc n)))))
 ~ Arity (a -> b -> c -> d -> e -> f -> t),
 All EmbPrj (Domains (a -> b -> c -> d -> e -> f -> t))) =>
(a -> b -> c -> d -> e -> f -> t)
-> StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> e -> f -> t)))
-> R (CoDomain (a -> b -> c -> d -> e -> f -> t))
valuN' a -> b -> c -> d -> e -> f -> t
fun (Pair Word32
a (Pair Word32
b (Pair Word32
c (Pair Word32
d (Pair Word32
e (Pair Word32
f Foldr
  StrictPair
  ()
  (Foldr'
     (ConsMap0 (Constant1 Word32)) '[] (If (IsZero n) '[] (Domains' t)))
n)))))) = do
    !a <- Word32 -> R a
forall a. EmbPrj a => Word32 -> R a
value Word32
a
    !b <- value b
    !c <- value c
    !d <- value d
    !e <- value e
    !f <- value f
    let !fun' = a -> b -> c -> d -> e -> f -> t
fun a
a b
b c
c d
d e
e f
f
    valuN' fun' n

  {-# INLINE valueArgs #-}
  valueArgs :: ('Suc ('Suc ('Suc ('Suc ('Suc ('Suc n)))))
 ~ Arity (a -> b -> c -> d -> e -> f -> t),
 All
   EmbPrj
   (CoDomain (a -> b -> c -> d -> e -> f -> t)
      : Domains (a -> b -> c -> d -> e -> f -> t))) =>
Proxy (a -> b -> c -> d -> e -> f -> t)
-> Node
-> Maybe
     (StrictProducts
        (Constant Word32 (Domains (a -> b -> c -> d -> e -> f -> t))))
valueArgs Proxy (a -> b -> c -> d -> e -> f -> t)
_ Node
xs = case Node
xs of
    N6 Word32
a Word32
b Word32
c Word32
d Word32
e Word32
f Node
n -> do
      !n <- Proxy t
-> Node -> Maybe (StrictProducts (Constant Word32 (Domains t)))
forall t (a :: Nat).
(VALU t a, a ~ Arity t, All EmbPrj (CoDomain t : Domains t)) =>
Proxy t
-> Node -> Maybe (StrictProducts (Constant Word32 (Domains t)))
valueArgs (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) Node
n
      Just (Pair a (Pair b (Pair c (Pair d (Pair e (Pair f n))))))
    Node
_ -> Maybe
  (StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> e -> f -> t))))
Maybe
  (StrictPair
     Word32
     (StrictPair
        Word32
        (StrictPair
           Word32
           (StrictPair
              Word32
              (StrictPair
                 Word32
                 (StrictPair
                    Word32
                    (Foldr
                       StrictPair
                       ()
                       (Foldr'
                          (ConsMap0 (Constant1 Word32))
                          '[]
                          (If (IsZero n) '[] (Domains' t))))))))))
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------

{-# INLINE valuN #-}
valuN :: forall t. VALU t (Arity t) =>
         StrictCurrying (Constant Word32 (Domains t)) (R (CoDomain t)) =>
         All EmbPrj (Domains t) =>
         t -> Arrows (Constant Word32 (Domains t)) (R (CoDomain t))
valuN :: forall t.
(VALU t (Arity t),
 StrictCurrying (Constant Word32 (Domains t)) (R (CoDomain t)),
 All EmbPrj (Domains t)) =>
t -> Arrows (Constant Word32 (Domains t)) (R (CoDomain t))
valuN t
f = Proxy
  (Foldr'
     (ConsMap0 (Constant1 Word32))
     '[]
     (If (IsZero (Arity t)) '[] (Domains' t)))
-> Proxy (R (If (IsZero (Arity t)) t (CoDomain' t)))
-> (StrictProducts
      (Foldr'
         (ConsMap0 (Constant1 Word32))
         '[]
         (If (IsZero (Arity t)) '[] (Domains' t)))
    -> R (If (IsZero (Arity t)) t (CoDomain' t)))
-> Arrows
     (Foldr'
        (ConsMap0 (Constant1 Word32))
        '[]
        (If (IsZero (Arity t)) '[] (Domains' t)))
     (R (If (IsZero (Arity t)) t (CoDomain' t)))
forall (as :: [*]) b.
StrictCurrying as b =>
Proxy as -> Proxy b -> (StrictProducts as -> b) -> Arrows as b
strictCurrys (Proxy (Constant Word32 (Domains t))
Proxy
  (Foldr'
     (ConsMap0 (Constant1 Word32))
     '[]
     (If (IsZero (Arity t)) '[] (Domains' t)))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Constant Word32 (Domains t)))
                 (Proxy (R (CoDomain t))
Proxy (R (If (IsZero (Arity t)) t (CoDomain' t)))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (R (CoDomain t)))
                 (t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t)
forall t (a :: Nat).
(VALU t a, a ~ Arity t, All EmbPrj (Domains t)) =>
t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t)
valuN' t
f)

{-# INLINE valueN #-}
valueN :: forall t. VALU t (Arity t) =>
          All EmbPrj (CoDomain t ': Domains t) =>
          t -> Word32 -> R (CoDomain t)
valueN :: forall t.
(VALU t (Arity t), All EmbPrj (CoDomain t : Domains t)) =>
t -> Word32 -> R (CoDomain t)
valueN t
t = (Node -> R (If (IsZero (Arity t)) t (CoDomain' t)))
-> Word32 -> R (If (IsZero (Arity t)) t (CoDomain' t))
forall a. EmbPrj a => (Node -> R a) -> Word32 -> R a
vcase \Node
n -> case Proxy t
-> Node -> Maybe (StrictProducts (Constant Word32 (Domains t)))
forall t (a :: Nat).
(VALU t a, a ~ Arity t, All EmbPrj (CoDomain t : Domains t)) =>
Proxy t
-> Node -> Maybe (StrictProducts (Constant Word32 (Domains t)))
valueArgs (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) Node
n of
  Maybe (StrictProducts (Constant Word32 (Domains t)))
Nothing -> R (If (IsZero (Arity t)) t (CoDomain' t))
forall a. R a
malformed
  Just StrictProducts (Constant Word32 (Domains t))
vs -> t
-> StrictProducts (Constant Word32 (Domains t))
-> ReaderT Decode IO (CoDomain t)
forall t (a :: Nat).
(VALU t a, a ~ Arity t, All EmbPrj (Domains t)) =>
t -> StrictProducts (Constant Word32 (Domains t)) -> R (CoDomain t)
valuN' t
t StrictProducts (Constant Word32 (Domains t))
vs