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

{-# OPTIONS_GHC -Wunused-imports #-}
-- {-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all -dno-suppress-type-signatures #-}

{-
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 Agda.TypeChecking.Serialise.Base (
    module Agda.TypeChecking.Serialise.Node
  , module Agda.TypeChecking.Serialise.Base
  ) where

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

import Data.Proxy
import Data.Hashable
import Data.Word (Word32)
import Data.Maybe
import qualified Data.Text      as T
import qualified Data.Text.Lazy as TL
import Data.Typeable (Typeable, TypeRep, typeRep, typeRepFingerprint)
import GHC.Exts
import GHC.Stack
import GHC.Fingerprint.Type
import Unsafe.Coerce

import Agda.Syntax.Common (NameId)
import Agda.Syntax.Internal (QName(..), ModuleName(..), nameId, Term(..), varTable, varTableSize)
import Agda.TypeChecking.Monad.Base.Types (ModuleToSource)
import Agda.TypeChecking.Serialise.Node

import Agda.Utils.FileName
import Agda.Utils.HashTable (HashTableLU, HashTableLL)
import qualified Agda.Utils.HashTable as H
import Agda.Utils.IORef
import Agda.Utils.List1 (List1)
import Agda.Utils.Monad
import Agda.Utils.TypeLevel
import Agda.Utils.VarSet (VarSet)
import Agda.Utils.CompactRegion (Compact)
import qualified Agda.Utils.MinimalArray.MutablePrim as MP
import qualified Agda.Utils.MinimalArray.Lifted as AL
import qualified Agda.Utils.MinimalArray.MutableLifted as ML
import qualified Agda.Utils.CompactRegion 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 a (m :: * -> *).
(Prim a, PrimMonad m) =>
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

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

-- | Computing a qualified names composed ID.
qnameId :: QName -> QNameId
qnameId :: QName -> QNameId
qnameId (QName (MName [Name]
ns) Name
n) = (Name -> NameId) -> [Name] -> QNameId
forall a b. (a -> b) -> [a] -> [b]
map Name -> NameId
nameId ([Name] -> QNameId) -> [Name] -> QNameId
forall a b. (a -> b) -> a -> b
$ Name
nName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
ns

-- | State of the the encoder.
data Dict = Dict
  -- Dictionaries which are serialized:
  { Dict -> HashTableLU Node Word32
nodeD        :: !(HashTableLU Node    Word32)    -- ^ Written to interface file.
  , Dict -> HashTableLU String Word32
stringD      :: !(HashTableLU String  Word32)    -- ^ Written to interface file.
  , Dict -> HashTableLU Text Word32
lTextD       :: !(HashTableLU TL.Text Word32)    -- ^ Written to interface file.
  , Dict -> HashTableLU Text Word32
sTextD       :: !(HashTableLU T.Text  Word32)    -- ^ Written to interface file.
  , Dict -> HashTableLU Integer Word32
integerD     :: !(HashTableLU Integer Word32)    -- ^ Written to interface file.
  , Dict -> HashTableLU VarSet Word32
varSetD      :: !(HashTableLU VarSet Word32)    -- ^ Written to interface file.
  , Dict -> HashTableLU Double Word32
doubleD      :: !(HashTableLU Double  Word32)    -- ^ Written to interface file.
  -- 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.
  , Dict -> HashTableLU NameId Word32
nameD        :: !(HashTableLU NameId  Word32)    -- ^ Not written to interface file.
  , Dict -> HashTableLU QNameId 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
lTextC       :: !FreshAndReuse
  , Dict -> FreshAndReuse
sTextC       :: !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 = HashTableLU Node Word32
-> HashTableLU String Word32
-> HashTableLU Text Word32
-> HashTableLU Text Word32
-> HashTableLU Integer Word32
-> HashTableLU VarSet Word32
-> HashTableLU Double Word32
-> HashTableLU NameId Word32
-> HashTableLU QNameId Word32
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> FreshAndReuse
-> HashTableLU String Int
-> Bool
-> Dict
Dict
  (HashTableLU Node Word32
 -> HashTableLU String Word32
 -> HashTableLU Text Word32
 -> HashTableLU Text Word32
 -> HashTableLU Integer Word32
 -> HashTableLU VarSet Word32
 -> HashTableLU Double Word32
 -> HashTableLU NameId Word32
 -> HashTableLU QNameId Word32
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> FreshAndReuse
 -> HashTableLU String Int
 -> Bool
 -> Dict)
-> IO (HashTableLU Node Word32)
-> IO
     (HashTableLU String Word32
      -> HashTableLU Text Word32
      -> HashTableLU Text Word32
      -> HashTableLU Integer Word32
      -> HashTableLU VarSet Word32
      -> HashTableLU Double Word32
      -> HashTableLU NameId Word32
      -> HashTableLU QNameId Word32
      -> FreshAndReuse
      -> 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
<$!> IO (HashTableLU Node Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (HashTableLU String Word32
   -> HashTableLU Text Word32
   -> HashTableLU Text Word32
   -> HashTableLU Integer Word32
   -> HashTableLU VarSet Word32
   -> HashTableLU Double Word32
   -> HashTableLU NameId Word32
   -> HashTableLU QNameId Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU String Word32)
-> IO
     (HashTableLU Text Word32
      -> HashTableLU Text Word32
      -> HashTableLU Integer Word32
      -> HashTableLU VarSet Word32
      -> HashTableLU Double Word32
      -> HashTableLU NameId Word32
      -> HashTableLU QNameId Word32
      -> FreshAndReuse
      -> 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 String Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (HashTableLU Text Word32
   -> HashTableLU Text Word32
   -> HashTableLU Integer Word32
   -> HashTableLU VarSet Word32
   -> HashTableLU Double Word32
   -> HashTableLU NameId Word32
   -> HashTableLU QNameId Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU Text Word32)
-> IO
     (HashTableLU Text Word32
      -> HashTableLU Integer Word32
      -> HashTableLU VarSet Word32
      -> HashTableLU Double Word32
      -> HashTableLU NameId Word32
      -> HashTableLU QNameId Word32
      -> FreshAndReuse
      -> 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 Text Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (HashTableLU Text Word32
   -> HashTableLU Integer Word32
   -> HashTableLU VarSet Word32
   -> HashTableLU Double Word32
   -> HashTableLU NameId Word32
   -> HashTableLU QNameId Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU Text Word32)
-> IO
     (HashTableLU Integer Word32
      -> HashTableLU VarSet Word32
      -> HashTableLU Double Word32
      -> HashTableLU NameId Word32
      -> HashTableLU QNameId Word32
      -> FreshAndReuse
      -> 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 Text Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (HashTableLU Integer Word32
   -> HashTableLU VarSet Word32
   -> HashTableLU Double Word32
   -> HashTableLU NameId Word32
   -> HashTableLU QNameId Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU Integer Word32)
-> IO
     (HashTableLU VarSet Word32
      -> HashTableLU Double Word32
      -> HashTableLU NameId Word32
      -> HashTableLU QNameId Word32
      -> FreshAndReuse
      -> 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 Integer Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (HashTableLU VarSet Word32
   -> HashTableLU Double Word32
   -> HashTableLU NameId Word32
   -> HashTableLU QNameId Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU VarSet Word32)
-> IO
     (HashTableLU Double Word32
      -> HashTableLU NameId Word32
      -> HashTableLU QNameId Word32
      -> FreshAndReuse
      -> 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 VarSet Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (HashTableLU Double Word32
   -> HashTableLU NameId Word32
   -> HashTableLU QNameId Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU Double Word32)
-> IO
     (HashTableLU NameId Word32
      -> HashTableLU QNameId Word32
      -> FreshAndReuse
      -> 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 Double Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (HashTableLU NameId Word32
   -> HashTableLU QNameId Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU NameId Word32)
-> IO
     (HashTableLU QNameId Word32
      -> FreshAndReuse
      -> 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 NameId Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (HashTableLU QNameId Word32
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> FreshAndReuse
   -> HashTableLU String Int
   -> Bool
   -> Dict)
-> IO (HashTableLU QNameId Word32)
-> IO
     (FreshAndReuse
      -> 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 QNameId Word32)
forall (ks :: * -> * -> *) k (vs :: * -> * -> *) v.
(MVector ks k, MVector vs v) =>
IO (HashTable ks k vs v)
H.empty
  IO
  (FreshAndReuse
   -> 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
      -> 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
   -> 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)
H.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 Text
lTextA    :: !(AL.Array TL.Text)     -- ^ Obtained from interface.
  , Decode -> Array Text
sTextA    :: !(AL.Array T.Text)      -- ^ 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 Double
doubleA   :: !(AL.Array Double)      -- ^ 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 :: HasCallStack => R a
malformed :: forall a. HasCallStack => 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 :: HasCallStack => IO a
malformedIO :: forall a. HasCallStack => 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. HasCallStack => R a
malformed

  default icod_ :: (Enum a, Bounded 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 <$> H.lookup hmap key
    H.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 #-}

icodeLText :: TL.Text -> S Word32
icodeLText :: Text -> S Word32
icodeLText Text
key = do
  d <- (Dict -> HashTableLU Text Word32)
-> ReaderT Dict IO (HashTableLU Text Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTableLU Text Word32
lTextD
  c <- asks lTextC
  liftIO $
    H.insertingIfAbsent d key
      (\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)
      (bumpFresh c)
      pure

icodeSText :: T.Text -> S Word32
icodeSText :: Text -> S Word32
icodeSText Text
key = do
  d <- (Dict -> HashTableLU Text Word32)
-> ReaderT Dict IO (HashTableLU Text Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTableLU Text Word32
sTextD
  c <- asks sTextC
  liftIO $
    H.insertingIfAbsent d key
      (\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)
      (bumpFresh c)
      pure

icodeInteger :: Integer -> S Word32
icodeInteger :: Integer -> S Word32
icodeInteger Integer
key = do
  d <- (Dict -> HashTableLU Integer Word32)
-> ReaderT Dict IO (HashTableLU Integer Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTableLU Integer Word32
integerD
  c <- asks integerC
  liftIO $
    H.insertingIfAbsent d key
      (\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)
      (bumpFresh c)
      pure

icodeVarSet :: VarSet -> S Word32
icodeVarSet :: VarSet -> S Word32
icodeVarSet VarSet
key = do
  d <- (Dict -> HashTableLU VarSet Word32)
-> ReaderT Dict IO (HashTableLU VarSet Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTableLU VarSet Word32
varSetD
  c <- asks varSetC
  liftIO $
    H.insertingIfAbsent d key
      (\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)
      (bumpFresh c)
      pure

icodeDouble :: Double -> S Word32
icodeDouble :: Double -> S Word32
icodeDouble Double
key = do
  d <- (Dict -> HashTableLU Double Word32)
-> ReaderT Dict IO (HashTableLU Double Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTableLU Double Word32
doubleD
  c <- asks doubleC
  liftIO $
    H.insertingIfAbsent d key
      (\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)
      (bumpFresh c)
      pure

icodeString :: String -> S Word32
icodeString :: String -> S Word32
icodeString String
key = do
  d <- (Dict -> HashTableLU String Word32)
-> ReaderT Dict IO (HashTableLU String Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTableLU String Word32
stringD
  c <- asks stringC
  liftIO $
    H.insertingIfAbsent d key
      (\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)
      (bumpFresh c)
      pure

icodeNode :: Node -> S Word32
icodeNode :: Node -> S Word32
icodeNode Node
key = do
  d <- (Dict -> HashTableLU Node Word32)
-> ReaderT Dict IO (HashTableLU Node Word32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTableLU Node Word32
nodeD
  c <- asks nodeC
  liftIO $
    H.insertingIfAbsent d key
      (\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)
      (bumpFresh c)
      pure


-- | @icode@ only if thing has not been seen before.
icodeMemo
  :: (Ord a, 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.
(Ord 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
H.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 icodeMemo #-}

-- icodeMemo
--   :: (Ord a, Hashable a)
--   => (Dict -> HashTable 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 getDict getCounter a icodeP = do
--     h  <- asks getDict
--     mi <- liftIO $ H.lookup h a
--     c  <- asks getCounter
--     case mi of
--       Just i  -> liftIO $ do
-- #ifdef DEBUG_SERIALISATION
--         liftIO $ bumpReuse c
-- #endif
--         return $! i
--       Nothing -> do
--         !fresh <- liftIO $ bumpFresh c
--         !i <- icodeP
--         liftIO $ H.insert h a i
--         return i

{-# 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 (StrictPair Word32 ())
Maybe (StrictProducts (Constant Word32 (Domains (a -> t))))
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 (StrictPair Word32 (StrictPair Word32 ()))
Maybe (StrictProducts (Constant Word32 (Domains (a -> b -> t))))
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
  (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))
Maybe
  (StrictProducts (Constant Word32 (Domains (a -> b -> c -> t))))
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
  (StrictPair
     Word32
     (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ()))))
Maybe
  (StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> t))))
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
  (StrictPair
     Word32
     (StrictPair
        Word32
        (StrictPair Word32 (StrictPair Word32 (StrictPair Word32 ())))))
Maybe
  (StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> e -> t))))
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
  (StrictPair
     Word32
     (StrictPair
        Word32
        (StrictPair
           Word32
           (StrictPair
              Word32
              (StrictPair
                 Word32
                 (StrictPair
                    Word32
                    (Foldr
                       StrictPair
                       ()
                       (Foldr'
                          (ConsMap0 (Constant1 Word32))
                          '[]
                          (If (IsZero n) '[] (Domains' t))))))))))
Maybe
  (StrictProducts
     (Constant Word32 (Domains (a -> b -> c -> d -> e -> f -> 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. HasCallStack => 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