{-# LANGUAGE CPP                  #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE UndecidableInstances #-} -- Due to ICODE vararg typeclass

module Agda.TypeChecking.Serialise.Base where

import Control.Exception (evaluate)

import Control.Monad.Catch (catchAll)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict (StateT, gets)

import Data.Proxy

import Data.Array.IArray
import qualified Data.ByteString.Lazy as L
import Data.Hashable
import qualified Data.HashTable.IO as H
import Data.Int (Int32)
import Data.Maybe
import qualified Data.Binary as B
import qualified Data.Binary.Get as B
import qualified Data.Text      as T
import qualified Data.Text.Lazy as TL
import Data.Typeable ( cast, Typeable, TypeRep, typeRep )

import Agda.Syntax.Common (NameId)
import Agda.Syntax.Internal (Term, QName(..), ModuleName(..), nameId)
import Agda.TypeChecking.Monad.Base (TypeError(GenericError), ModuleToSource)

import Agda.Utils.FileName
import Agda.Utils.IORef
import Agda.Utils.Lens
import Agda.Utils.Monad
import Agda.Utils.Pointer
import Agda.Utils.TypeLevel

-- | Constructor tag (maybe omitted) and argument indices.

type Node = [Int32]

-- | The type of hashtables used in this module.
--
-- A very limited amount of testing indicates that 'H.CuckooHashTable'
-- is somewhat slower than 'H.BasicHashTable', and that
-- 'H.LinearHashTable' and the hashtables from "Data.Hashtable" are
-- much slower.

#if defined(mingw32_HOST_OS) && defined(x86_64_HOST_ARCH)
type HashTable k v = H.CuckooHashTable k v
#else
type HashTable k v = H.BasicHashTable k v
#endif

-- | Structure providing fresh identifiers for hash map
--   and counting hash map hits (i.e. when no fresh identifier required).
#ifdef DEBUG
data FreshAndReuse = FreshAndReuse
  { farFresh :: !Int32 -- ^ Number of hash map misses.
  , farReuse :: !Int32 -- ^ Number of hash map hits.
  }
#else
newtype FreshAndReuse = FreshAndReuse
  { FreshAndReuse -> Int32
farFresh :: Int32 -- ^ Number of hash map misses.
  }
#endif

farEmpty :: FreshAndReuse
farEmpty :: FreshAndReuse
farEmpty = Int32 -> FreshAndReuse
FreshAndReuse Int32
0
#ifdef DEBUG
                           0
#endif

lensFresh :: Lens' Int32 FreshAndReuse
lensFresh :: Lens' Int32 FreshAndReuse
lensFresh Int32 -> f Int32
f FreshAndReuse
r = Int32 -> f Int32
f (FreshAndReuse -> Int32
farFresh FreshAndReuse
r) f Int32 -> (Int32 -> FreshAndReuse) -> f FreshAndReuse
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ Int32
i -> FreshAndReuse
r { farFresh :: Int32
farFresh = Int32
i }

#ifdef DEBUG
lensReuse :: Lens' Int32 FreshAndReuse
lensReuse f r = f (farReuse r) <&> \ i -> r { farReuse = i }
#endif

-- | 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 -> HashTable Node Int32
nodeD        :: !(HashTable Node    Int32)    -- ^ Written to interface file.
  , Dict -> HashTable String Int32
stringD      :: !(HashTable String  Int32)    -- ^ Written to interface file.
  , Dict -> HashTable Text Int32
lTextD       :: !(HashTable TL.Text Int32)    -- ^ Written to interface file.
  , Dict -> HashTable Text Int32
sTextD       :: !(HashTable T.Text  Int32)    -- ^ Written to interface file.
  , Dict -> HashTable Integer Int32
integerD     :: !(HashTable Integer Int32)    -- ^ Written to interface file.
  , Dict -> HashTable Double Int32
doubleD      :: !(HashTable Double  Int32)    -- ^ Written to interface file.
  -- Dicitionaries which are not serialized, but provide
  -- short cuts to speed up serialization:
  , Dict -> HashTable (Ptr Term) Int32
termD        :: !(HashTable (Ptr Term) Int32) -- ^ Not written to interface file.
  -- Andreas, Makoto, AIM XXI
  -- Memoizing A.Name does not buy us much if we already memoize A.QName.
  , Dict -> HashTable NameId Int32
nameD        :: !(HashTable NameId  Int32)    -- ^ Not written to interface file.
  , Dict -> HashTable QNameId Int32
qnameD       :: !(HashTable QNameId Int32)    -- ^ Not written to interface file.
  -- Fresh UIDs and reuse statistics:
  , Dict -> IORef FreshAndReuse
nodeC        :: !(IORef FreshAndReuse)  -- counters for fresh indexes
  , Dict -> IORef FreshAndReuse
stringC      :: !(IORef FreshAndReuse)
  , Dict -> IORef FreshAndReuse
lTextC       :: !(IORef FreshAndReuse)
  , Dict -> IORef FreshAndReuse
sTextC       :: !(IORef FreshAndReuse)
  , Dict -> IORef FreshAndReuse
integerC     :: !(IORef FreshAndReuse)
  , Dict -> IORef FreshAndReuse
doubleC      :: !(IORef FreshAndReuse)
  , Dict -> IORef FreshAndReuse
termC        :: !(IORef FreshAndReuse)
  , Dict -> IORef FreshAndReuse
nameC        :: !(IORef FreshAndReuse)
  , Dict -> IORef FreshAndReuse
qnameC       :: !(IORef FreshAndReuse)
  , Dict -> HashTable String Int
stats        :: !(HashTable String Int)
  , Dict -> Bool
collectStats :: Bool
    -- ^ If @True@ collect in @stats@ the quantities of
    --   calls to @icode@ for each @Typeable a@.
  , Dict -> HashTable AbsolutePath Int32
absPathD     :: !(HashTable AbsolutePath Int32) -- ^ Not written to interface file.
  }

-- | Creates an empty dictionary.
emptyDict
  :: Bool
     -- ^ Collect statistics for @icode@ calls?
  -> IO Dict
emptyDict :: Bool -> IO Dict
emptyDict Bool
collectStats = HashTable RealWorld Node Int32
-> HashTable RealWorld String Int32
-> HashTable RealWorld Text Int32
-> HashTable RealWorld Text Int32
-> HashTable RealWorld Integer Int32
-> HashTable RealWorld Double Int32
-> HashTable RealWorld (Ptr Term) Int32
-> HashTable RealWorld NameId Int32
-> HashTable RealWorld QNameId Int32
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> HashTable RealWorld String Int
-> Bool
-> HashTable RealWorld AbsolutePath Int32
-> Dict
HashTable Node Int32
-> HashTable String Int32
-> HashTable Text Int32
-> HashTable Text Int32
-> HashTable Integer Int32
-> HashTable Double Int32
-> HashTable (Ptr Term) Int32
-> HashTable NameId Int32
-> HashTable QNameId Int32
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> IORef FreshAndReuse
-> HashTable String Int
-> Bool
-> HashTable AbsolutePath Int32
-> Dict
Dict
  (HashTable RealWorld Node Int32
 -> HashTable RealWorld String Int32
 -> HashTable RealWorld Text Int32
 -> HashTable RealWorld Text Int32
 -> HashTable RealWorld Integer Int32
 -> HashTable RealWorld Double Int32
 -> HashTable RealWorld (Ptr Term) Int32
 -> HashTable RealWorld NameId Int32
 -> HashTable RealWorld QNameId Int32
 -> IORef FreshAndReuse
 -> IORef FreshAndReuse
 -> IORef FreshAndReuse
 -> IORef FreshAndReuse
 -> IORef FreshAndReuse
 -> IORef FreshAndReuse
 -> IORef FreshAndReuse
 -> IORef FreshAndReuse
 -> IORef FreshAndReuse
 -> HashTable RealWorld String Int
 -> Bool
 -> HashTable RealWorld AbsolutePath Int32
 -> Dict)
-> IO (HashTable RealWorld Node Int32)
-> IO
     (HashTable RealWorld String Int32
      -> HashTable RealWorld Text Int32
      -> HashTable RealWorld Text Int32
      -> HashTable RealWorld Integer Int32
      -> HashTable RealWorld Double Int32
      -> HashTable RealWorld (Ptr Term) Int32
      -> HashTable RealWorld NameId Int32
      -> HashTable RealWorld QNameId Int32
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (HashTable RealWorld Node Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (HashTable RealWorld String Int32
   -> HashTable RealWorld Text Int32
   -> HashTable RealWorld Text Int32
   -> HashTable RealWorld Integer Int32
   -> HashTable RealWorld Double Int32
   -> HashTable RealWorld (Ptr Term) Int32
   -> HashTable RealWorld NameId Int32
   -> HashTable RealWorld QNameId Int32
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (HashTable RealWorld String Int32)
-> IO
     (HashTable RealWorld Text Int32
      -> HashTable RealWorld Text Int32
      -> HashTable RealWorld Integer Int32
      -> HashTable RealWorld Double Int32
      -> HashTable RealWorld (Ptr Term) Int32
      -> HashTable RealWorld NameId Int32
      -> HashTable RealWorld QNameId Int32
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld String Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (HashTable RealWorld Text Int32
   -> HashTable RealWorld Text Int32
   -> HashTable RealWorld Integer Int32
   -> HashTable RealWorld Double Int32
   -> HashTable RealWorld (Ptr Term) Int32
   -> HashTable RealWorld NameId Int32
   -> HashTable RealWorld QNameId Int32
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (HashTable RealWorld Text Int32)
-> IO
     (HashTable RealWorld Text Int32
      -> HashTable RealWorld Integer Int32
      -> HashTable RealWorld Double Int32
      -> HashTable RealWorld (Ptr Term) Int32
      -> HashTable RealWorld NameId Int32
      -> HashTable RealWorld QNameId Int32
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld Text Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (HashTable RealWorld Text Int32
   -> HashTable RealWorld Integer Int32
   -> HashTable RealWorld Double Int32
   -> HashTable RealWorld (Ptr Term) Int32
   -> HashTable RealWorld NameId Int32
   -> HashTable RealWorld QNameId Int32
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (HashTable RealWorld Text Int32)
-> IO
     (HashTable RealWorld Integer Int32
      -> HashTable RealWorld Double Int32
      -> HashTable RealWorld (Ptr Term) Int32
      -> HashTable RealWorld NameId Int32
      -> HashTable RealWorld QNameId Int32
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld Text Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (HashTable RealWorld Integer Int32
   -> HashTable RealWorld Double Int32
   -> HashTable RealWorld (Ptr Term) Int32
   -> HashTable RealWorld NameId Int32
   -> HashTable RealWorld QNameId Int32
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (HashTable RealWorld Integer Int32)
-> IO
     (HashTable RealWorld Double Int32
      -> HashTable RealWorld (Ptr Term) Int32
      -> HashTable RealWorld NameId Int32
      -> HashTable RealWorld QNameId Int32
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld Integer Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (HashTable RealWorld Double Int32
   -> HashTable RealWorld (Ptr Term) Int32
   -> HashTable RealWorld NameId Int32
   -> HashTable RealWorld QNameId Int32
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (HashTable RealWorld Double Int32)
-> IO
     (HashTable RealWorld (Ptr Term) Int32
      -> HashTable RealWorld NameId Int32
      -> HashTable RealWorld QNameId Int32
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld Double Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (HashTable RealWorld (Ptr Term) Int32
   -> HashTable RealWorld NameId Int32
   -> HashTable RealWorld QNameId Int32
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (HashTable RealWorld (Ptr Term) Int32)
-> IO
     (HashTable RealWorld NameId Int32
      -> HashTable RealWorld QNameId Int32
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld (Ptr Term) Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (HashTable RealWorld NameId Int32
   -> HashTable RealWorld QNameId Int32
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (HashTable RealWorld NameId Int32)
-> IO
     (HashTable RealWorld QNameId Int32
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld NameId Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (HashTable RealWorld QNameId Int32
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (HashTable RealWorld QNameId Int32)
-> IO
     (IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld QNameId Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO
  (IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (IORef FreshAndReuse
      -> IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (IORef FreshAndReuse
   -> IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (IORef FreshAndReuse
      -> HashTable RealWorld String Int
      -> Bool
      -> HashTable RealWorld AbsolutePath Int32
      -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (IORef FreshAndReuse
   -> HashTable RealWorld String Int
   -> Bool
   -> HashTable RealWorld AbsolutePath Int32
   -> Dict)
-> IO (IORef FreshAndReuse)
-> IO
     (HashTable RealWorld String Int
      -> Bool -> HashTable RealWorld AbsolutePath Int32 -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FreshAndReuse -> IO (IORef FreshAndReuse)
forall a. a -> IO (IORef a)
newIORef FreshAndReuse
farEmpty
  IO
  (HashTable RealWorld String Int
   -> Bool -> HashTable RealWorld AbsolutePath Int32 -> Dict)
-> IO (HashTable RealWorld String Int)
-> IO (Bool -> HashTable RealWorld AbsolutePath Int32 -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld String Int)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
  IO (Bool -> HashTable RealWorld AbsolutePath Int32 -> Dict)
-> IO Bool -> IO (HashTable RealWorld AbsolutePath Int32 -> Dict)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
collectStats
  IO (HashTable RealWorld AbsolutePath Int32 -> Dict)
-> IO (HashTable RealWorld AbsolutePath Int32) -> IO Dict
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (HashTable RealWorld AbsolutePath Int32)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new

-- | Universal type, wraps everything.
data U = forall a . Typeable a => U !a

-- | Univeral memo structure, to introduce sharing during decoding
type Memo = HashTable (Int32, TypeRep) U    -- (node index, type rep)

-- | State of the decoder.
data St = St
  { St -> Array Int32 Node
nodeE     :: !(Array Int32 Node)     -- ^ Obtained from interface file.
  , St -> Array Int32 String
stringE   :: !(Array Int32 String)   -- ^ Obtained from interface file.
  , St -> Array Int32 Text
lTextE    :: !(Array Int32 TL.Text)  -- ^ Obtained from interface file.
  , St -> Array Int32 Text
sTextE    :: !(Array Int32 T.Text)   -- ^ Obtained from interface file.
  , St -> Array Int32 Integer
integerE  :: !(Array Int32 Integer)  -- ^ Obtained from interface file.
  , St -> Array Int32 Double
doubleE   :: !(Array Int32 Double)   -- ^ Obtained from interface file.
  , St -> Memo
nodeMemo  :: !Memo
    -- ^ Created and modified by decoder.
    --   Used to introduce sharing while deserializing objects.
  , St -> ModuleToSource
modFile   :: !ModuleToSource
    -- ^ Maps module names to file names. Constructed by the decoder.
  , St -> [AbsolutePath]
includes  :: [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 a = ExceptT TypeError (StateT St IO) a

-- | Throws an error which is suitable when the data stream is
-- malformed.

malformed :: R a
malformed :: forall a. R a
malformed = TypeError -> ExceptT TypeError (StateT St IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TypeError -> ExceptT TypeError (StateT St IO) a)
-> TypeError -> ExceptT TypeError (StateT St IO) a
forall a b. (a -> b) -> a -> b
$ String -> TypeError
GenericError String
"Malformed input."

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

  icode a
a = do
    a -> S ()
forall a. Typeable a => a -> S ()
tickICode a
a
    a -> S Int32
forall a. EmbPrj a => a -> S Int32
icod_ a
a

  -- Simple enumeration types can be (de)serialized using (from/to)Enum.

  default value :: (Enum a) => Int32 -> R a
  value Int32
i = IO a -> R a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (a -> IO a
forall a. a -> IO a
evaluate (Int -> a
forall a. Enum a => Int -> a
toEnum (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i))) R a -> (SomeException -> R a) -> R a
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAll` R a -> SomeException -> R a
forall a b. a -> b -> a
const R a
forall a. R a
malformed

  default icod_ :: (Enum a) => a -> S Int32
  icod_ = Int32 -> S Int32
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32 -> S Int32) -> (a -> Int32) -> a -> S Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> (a -> Int) -> a -> Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum

-- | 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
$ 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
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
    HashTable RealWorld String Int
hmap <- (Dict -> HashTable RealWorld String Int)
-> ReaderT Dict IO (HashTable RealWorld String Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTable RealWorld String Int
Dict -> HashTable String Int
stats
    IO () -> S ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> S ()) -> IO () -> S ()
forall a b. (a -> b) -> a -> b
$ do
      Int
n <- Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> IO (Maybe Int) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashTable String Int -> String -> IO (Maybe Int)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld String Int
HashTable String Int
hmap String
key
      HashTable String Int -> String -> Int -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld String Int
HashTable String Int
hmap String
key (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$! Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

-- | Data.Binary.runGetState is deprecated in favour of runGetIncremental.
--   Reimplementing it in terms of the new function. The new Decoder type contains
--   strict byte strings so we need to be careful not to feed the entire lazy byte
--   string to the decoder at once.
runGetState :: B.Get a -> L.ByteString -> B.ByteOffset -> (a, L.ByteString, B.ByteOffset)
runGetState :: forall a.
Get a -> ByteString -> ByteOffset -> (a, ByteString, ByteOffset)
runGetState Get a
g ByteString
s ByteOffset
n = Decoder a -> [ByteString] -> (a, ByteString, ByteOffset)
feed (Get a -> Decoder a
forall a. Get a -> Decoder a
B.runGetIncremental Get a
g) (ByteString -> [ByteString]
L.toChunks ByteString
s)
  where
    feed :: Decoder a -> [ByteString] -> (a, ByteString, ByteOffset)
feed (B.Done ByteString
s ByteOffset
n' a
x) [ByteString]
ss     = (a
x, [ByteString] -> ByteString
L.fromChunks (ByteString
s ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
ss), ByteOffset
n ByteOffset -> ByteOffset -> ByteOffset
forall a. Num a => a -> a -> a
+ ByteOffset
n')
    feed (B.Fail ByteString
_ ByteOffset
_ String
err) [ByteString]
_     = String -> (a, ByteString, ByteOffset)
forall a. HasCallStack => String -> a
error String
err
    feed (B.Partial Maybe ByteString -> Decoder a
f) (ByteString
s : [ByteString]
ss) = Decoder a -> [ByteString] -> (a, ByteString, ByteOffset)
feed (Maybe ByteString -> Decoder a
f (Maybe ByteString -> Decoder a) -> Maybe ByteString -> Decoder a
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
s) [ByteString]
ss
    feed (B.Partial Maybe ByteString -> Decoder a
f) []       = Decoder a -> [ByteString] -> (a, ByteString, ByteOffset)
feed (Maybe ByteString -> Decoder a
f Maybe ByteString
forall a. Maybe a
Nothing) []

-- Specializing icodeX leads to Warning like
-- src/full/Agda/TypeChecking/Serialise.hs:1297:1: Warning:
--     RULE left-hand side too complicated to desugar
--       case cobox_aQY5 of _ [Occ=Dead] { ghc-prim:GHC.Types.Eq# cobox ->
--       icodeX @ String $dEq_aQY3 $dHashable_aQY4
--       }
--
-- type ICodeX k
--   =  (Dict -> HashTable k Int32)
--   -> (Dict -> IORef Int32)
--   -> k -> S Int32
-- {-# SPECIALIZE icodeX :: ICodeX String  #-}
-- {-# SPECIALIZE icodeX :: ICodeX Integer #-}
-- {-# SPECIALIZE icodeX :: ICodeX Double  #-}
-- {-# SPECIALIZE icodeX :: ICodeX Node    #-}

-- Andreas, 2014-10-16 AIM XX:
-- Inlining this increases Serialization time by 10%
-- Makoto's theory: code size increase might lead to
-- instruction cache misses.
-- {-# INLINE icodeX #-}
icodeX :: (Eq k, Hashable k)
  =>  (Dict -> HashTable k Int32)
  -> (Dict -> IORef FreshAndReuse)
  -> k -> S Int32
icodeX :: forall k.
(Eq k, Hashable k) =>
(Dict -> HashTable k Int32)
-> (Dict -> IORef FreshAndReuse) -> k -> S Int32
icodeX Dict -> HashTable k Int32
dict Dict -> IORef FreshAndReuse
counter k
key = do
  HashTable RealWorld k Int32
d <- (Dict -> HashTable RealWorld k Int32)
-> ReaderT Dict IO (HashTable RealWorld k Int32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTable RealWorld k Int32
Dict -> HashTable k Int32
dict
  IORef FreshAndReuse
c <- (Dict -> IORef FreshAndReuse)
-> ReaderT Dict IO (IORef FreshAndReuse)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> IORef FreshAndReuse
counter
  IO Int32 -> S Int32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int32 -> S Int32) -> IO Int32 -> S Int32
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int32
mi <- HashTable k Int32 -> k -> IO (Maybe Int32)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld k Int32
HashTable k Int32
d k
key
    case Maybe Int32
mi of
      Just Int32
i  -> do
#ifdef DEBUG
        modifyIORef' c $ over lensReuse (+1)
#endif
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
i
      Maybe Int32
Nothing -> do
        Int32
fresh <- (FreshAndReuse -> Lens' Int32 FreshAndReuse -> Int32
forall o i. o -> Lens' i o -> i
^.Lens' Int32 FreshAndReuse
lensFresh) (FreshAndReuse -> Int32) -> IO FreshAndReuse -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do IORef FreshAndReuse
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a. IORef a -> (a -> a) -> IO a
readModifyIORef' IORef FreshAndReuse
c ((FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse)
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a b. (a -> b) -> a -> b
$ Lens' Int32 FreshAndReuse -> LensMap Int32 FreshAndReuse
forall i o. Lens' i o -> LensMap i o
over Lens' Int32 FreshAndReuse
lensFresh (Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+Int32
1)
        HashTable k Int32 -> k -> Int32 -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld k Int32
HashTable k Int32
d k
key Int32
fresh
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
fresh

-- Instead of inlining icodeX, we manually specialize it to
-- its four uses: Integer, String, Double, Node.
-- Not a great gain (hardly noticeable), but not harmful.

icodeInteger :: Integer -> S Int32
icodeInteger :: Integer -> S Int32
icodeInteger Integer
key = do
  HashTable RealWorld Integer Int32
d <- (Dict -> HashTable RealWorld Integer Int32)
-> ReaderT Dict IO (HashTable RealWorld Integer Int32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTable RealWorld Integer Int32
Dict -> HashTable Integer Int32
integerD
  IORef FreshAndReuse
c <- (Dict -> IORef FreshAndReuse)
-> ReaderT Dict IO (IORef FreshAndReuse)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> IORef FreshAndReuse
integerC
  IO Int32 -> S Int32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int32 -> S Int32) -> IO Int32 -> S Int32
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int32
mi <- HashTable Integer Int32 -> Integer -> IO (Maybe Int32)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld Integer Int32
HashTable Integer Int32
d Integer
key
    case Maybe Int32
mi of
      Just Int32
i  -> do
#ifdef DEBUG
        modifyIORef' c $ over lensReuse (+1)
#endif
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
i
      Maybe Int32
Nothing -> do
        Int32
fresh <- (FreshAndReuse -> Lens' Int32 FreshAndReuse -> Int32
forall o i. o -> Lens' i o -> i
^.Lens' Int32 FreshAndReuse
lensFresh) (FreshAndReuse -> Int32) -> IO FreshAndReuse -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do IORef FreshAndReuse
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a. IORef a -> (a -> a) -> IO a
readModifyIORef' IORef FreshAndReuse
c ((FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse)
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a b. (a -> b) -> a -> b
$ Lens' Int32 FreshAndReuse -> LensMap Int32 FreshAndReuse
forall i o. Lens' i o -> LensMap i o
over Lens' Int32 FreshAndReuse
lensFresh (Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+Int32
1)
        HashTable Integer Int32 -> Integer -> Int32 -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld Integer Int32
HashTable Integer Int32
d Integer
key Int32
fresh
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
fresh

icodeDouble :: Double -> S Int32
icodeDouble :: Double -> S Int32
icodeDouble Double
key = do
  HashTable RealWorld Double Int32
d <- (Dict -> HashTable RealWorld Double Int32)
-> ReaderT Dict IO (HashTable RealWorld Double Int32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTable RealWorld Double Int32
Dict -> HashTable Double Int32
doubleD
  IORef FreshAndReuse
c <- (Dict -> IORef FreshAndReuse)
-> ReaderT Dict IO (IORef FreshAndReuse)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> IORef FreshAndReuse
doubleC
  IO Int32 -> S Int32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int32 -> S Int32) -> IO Int32 -> S Int32
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int32
mi <- HashTable Double Int32 -> Double -> IO (Maybe Int32)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld Double Int32
HashTable Double Int32
d Double
key
    case Maybe Int32
mi of
      Just Int32
i  -> do
#ifdef DEBUG
        modifyIORef' c $ over lensReuse (+1)
#endif
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
i
      Maybe Int32
Nothing -> do
        Int32
fresh <- (FreshAndReuse -> Lens' Int32 FreshAndReuse -> Int32
forall o i. o -> Lens' i o -> i
^.Lens' Int32 FreshAndReuse
lensFresh) (FreshAndReuse -> Int32) -> IO FreshAndReuse -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do IORef FreshAndReuse
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a. IORef a -> (a -> a) -> IO a
readModifyIORef' IORef FreshAndReuse
c ((FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse)
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a b. (a -> b) -> a -> b
$ Lens' Int32 FreshAndReuse -> LensMap Int32 FreshAndReuse
forall i o. Lens' i o -> LensMap i o
over Lens' Int32 FreshAndReuse
lensFresh (Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+Int32
1)
        HashTable Double Int32 -> Double -> Int32 -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld Double Int32
HashTable Double Int32
d Double
key Int32
fresh
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
fresh

icodeString :: String -> S Int32
icodeString :: String -> S Int32
icodeString String
key = do
  HashTable RealWorld String Int32
d <- (Dict -> HashTable RealWorld String Int32)
-> ReaderT Dict IO (HashTable RealWorld String Int32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTable RealWorld String Int32
Dict -> HashTable String Int32
stringD
  IORef FreshAndReuse
c <- (Dict -> IORef FreshAndReuse)
-> ReaderT Dict IO (IORef FreshAndReuse)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> IORef FreshAndReuse
stringC
  IO Int32 -> S Int32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int32 -> S Int32) -> IO Int32 -> S Int32
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int32
mi <- HashTable String Int32 -> String -> IO (Maybe Int32)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld String Int32
HashTable String Int32
d String
key
    case Maybe Int32
mi of
      Just Int32
i  -> do
#ifdef DEBUG
        modifyIORef' c $ over lensReuse (+1)
#endif
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
i
      Maybe Int32
Nothing -> do
        Int32
fresh <- (FreshAndReuse -> Lens' Int32 FreshAndReuse -> Int32
forall o i. o -> Lens' i o -> i
^.Lens' Int32 FreshAndReuse
lensFresh) (FreshAndReuse -> Int32) -> IO FreshAndReuse -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do IORef FreshAndReuse
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a. IORef a -> (a -> a) -> IO a
readModifyIORef' IORef FreshAndReuse
c ((FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse)
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a b. (a -> b) -> a -> b
$ Lens' Int32 FreshAndReuse -> LensMap Int32 FreshAndReuse
forall i o. Lens' i o -> LensMap i o
over Lens' Int32 FreshAndReuse
lensFresh (Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+Int32
1)
        HashTable String Int32 -> String -> Int32 -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld String Int32
HashTable String Int32
d String
key Int32
fresh
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
fresh

icodeNode :: Node -> S Int32
icodeNode :: Node -> S Int32
icodeNode Node
key = do
  HashTable RealWorld Node Int32
d <- (Dict -> HashTable RealWorld Node Int32)
-> ReaderT Dict IO (HashTable RealWorld Node Int32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTable RealWorld Node Int32
Dict -> HashTable Node Int32
nodeD
  IORef FreshAndReuse
c <- (Dict -> IORef FreshAndReuse)
-> ReaderT Dict IO (IORef FreshAndReuse)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> IORef FreshAndReuse
nodeC
  IO Int32 -> S Int32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int32 -> S Int32) -> IO Int32 -> S Int32
forall a b. (a -> b) -> a -> b
$ do
    Maybe Int32
mi <- HashTable Node Int32 -> Node -> IO (Maybe Int32)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld Node Int32
HashTable Node Int32
d Node
key
    case Maybe Int32
mi of
      Just Int32
i  -> do
#ifdef DEBUG
        modifyIORef' c $ over lensReuse (+1)
#endif
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
i
      Maybe Int32
Nothing -> do
        Int32
fresh <- (FreshAndReuse -> Lens' Int32 FreshAndReuse -> Int32
forall o i. o -> Lens' i o -> i
^.Lens' Int32 FreshAndReuse
lensFresh) (FreshAndReuse -> Int32) -> IO FreshAndReuse -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do IORef FreshAndReuse
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a. IORef a -> (a -> a) -> IO a
readModifyIORef' IORef FreshAndReuse
c ((FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse)
-> (FreshAndReuse -> FreshAndReuse) -> IO FreshAndReuse
forall a b. (a -> b) -> a -> b
$ Lens' Int32 FreshAndReuse -> LensMap Int32 FreshAndReuse
forall i o. Lens' i o -> LensMap i o
over Lens' Int32 FreshAndReuse
lensFresh (Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+Int32
1)
        HashTable Node Int32 -> Node -> Int32 -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld Node Int32
HashTable Node Int32
d Node
key Int32
fresh
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
fresh

-- icodeN :: [Int32] -> S Int32
-- icodeN = icodeX nodeD nodeC

-- | @icode@ only if thing has not seen before.
icodeMemo
  :: (Ord a, Hashable a)
  => (Dict -> HashTable a Int32)    -- ^ Memo structure for thing of key @a@.
  -> (Dict -> IORef FreshAndReuse)  -- ^ Statistics.
  -> a        -- ^ Key to the thing.
  -> S Int32  -- ^ Fallback computation to encode the thing.
  -> S Int32  -- ^ Encoded thing.
icodeMemo :: forall a.
(Ord a, Hashable a) =>
(Dict -> HashTable a Int32)
-> (Dict -> IORef FreshAndReuse) -> a -> S Int32 -> S Int32
icodeMemo Dict -> HashTable a Int32
getDict Dict -> IORef FreshAndReuse
getCounter a
a S Int32
icodeP = do
    HashTable RealWorld a Int32
h  <- (Dict -> HashTable RealWorld a Int32)
-> ReaderT Dict IO (HashTable RealWorld a Int32)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> HashTable RealWorld a Int32
Dict -> HashTable a Int32
getDict
    Maybe Int32
mi <- IO (Maybe Int32) -> ReaderT Dict IO (Maybe Int32)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Int32) -> ReaderT Dict IO (Maybe Int32))
-> IO (Maybe Int32) -> ReaderT Dict IO (Maybe Int32)
forall a b. (a -> b) -> a -> b
$ HashTable a Int32 -> a -> IO (Maybe Int32)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld a Int32
HashTable a Int32
h a
a
    IORef FreshAndReuse
st <- (Dict -> IORef FreshAndReuse)
-> ReaderT Dict IO (IORef FreshAndReuse)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Dict -> IORef FreshAndReuse
getCounter
    case Maybe Int32
mi of
      Just Int32
i  -> IO Int32 -> S Int32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int32 -> S Int32) -> IO Int32 -> S Int32
forall a b. (a -> b) -> a -> b
$ do
#ifdef DEBUG
        modifyIORef' st $ over lensReuse (+ 1)
#endif
        Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
i
      Maybe Int32
Nothing -> do
        IO () -> S ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> S ()) -> IO () -> S ()
forall a b. (a -> b) -> a -> b
$ IORef FreshAndReuse -> (FreshAndReuse -> FreshAndReuse) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef FreshAndReuse
st ((FreshAndReuse -> FreshAndReuse) -> IO ())
-> (FreshAndReuse -> FreshAndReuse) -> IO ()
forall a b. (a -> b) -> a -> b
$ Lens' Int32 FreshAndReuse -> LensMap Int32 FreshAndReuse
forall i o. Lens' i o -> LensMap i o
over Lens' Int32 FreshAndReuse
lensFresh (Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+Int32
1)
        Int32
i <- S Int32
icodeP
        IO () -> S ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> S ()) -> IO () -> S ()
forall a b. (a -> b) -> a -> b
$ HashTable a Int32 -> a -> Int32 -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld a Int32
HashTable a Int32
h a
a Int32
i
        Int32 -> S Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
i

{-# INLINE vcase #-}
-- | @vcase value ix@ decodes thing represented by @ix :: Int32@
--   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) -> Int32 -> R a
vcase :: forall a. EmbPrj a => (Node -> R a) -> Int32 -> R a
vcase Node -> R a
valu = \Int32
ix -> do
    HashTable RealWorld (Int32, TypeRep) U
memo <- (St -> HashTable RealWorld (Int32, TypeRep) U)
-> ExceptT
     TypeError (StateT St IO) (HashTable RealWorld (Int32, TypeRep) U)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> HashTable RealWorld (Int32, TypeRep) U
St -> Memo
nodeMemo
    -- compute run-time representation of type a
    let aTyp :: TypeRep
aTyp = 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
    Maybe U
maybeU <- IO (Maybe U) -> ExceptT TypeError (StateT St IO) (Maybe U)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe U) -> ExceptT TypeError (StateT St IO) (Maybe U))
-> IO (Maybe U) -> ExceptT TypeError (StateT St IO) (Maybe U)
forall a b. (a -> b) -> a -> b
$ Memo -> (Int32, TypeRep) -> IO (Maybe U)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup HashTable RealWorld (Int32, TypeRep) U
Memo
memo (Int32
ix, TypeRep
aTyp)
    case Maybe U
maybeU of
      -- yes, we have seen it before, use the version from memo
      Just (U a
u) -> R a -> (a -> R a) -> Maybe a -> R a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe R a
forall a. R a
malformed a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
u)
      -- no, it's new, so generate it via valu and insert it into memo
      Maybe U
Nothing    -> do
          a
v <- Node -> R a
valu (Node -> R a)
-> (Array Int32 Node -> Node) -> Array Int32 Node -> R a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array Int32 Node -> Int32 -> Node
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int32
ix) (Array Int32 Node -> R a)
-> ExceptT TypeError (StateT St IO) (Array Int32 Node) -> R a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (St -> Array Int32 Node)
-> ExceptT TypeError (StateT St IO) (Array Int32 Node)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets St -> Array Int32 Node
nodeE
          IO () -> ExceptT TypeError (StateT St IO) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT TypeError (StateT St IO) ())
-> IO () -> ExceptT TypeError (StateT St IO) ()
forall a b. (a -> b) -> a -> b
$ Memo -> (Int32, TypeRep) -> U -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert HashTable RealWorld (Int32, TypeRep) U
Memo
memo (Int32
ix, TypeRep
aTyp) (a -> U
forall a. Typeable a => a -> U
U a
v)
          a -> R a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | @icodeArgs proxy (a1, ..., an)@ maps @icode@ over @a1@, ..., @an@
--   and returns the corresponding list of @Int32@.

class ICODE t b where
  icodeArgs :: IsBase t ~ b => All EmbPrj (Domains t) =>
               Proxy t -> Products (Domains t) -> S [Int32]

instance IsBase t ~ 'True => ICODE t 'True where
  icodeArgs :: (IsBase t ~ 'True, All EmbPrj (Domains t)) =>
Proxy t -> Products (Domains t) -> S Node
icodeArgs Proxy t
_ Products (Domains t)
_  = Node -> S Node
forall (m :: * -> *) a. Monad m => a -> m a
return []

instance ICODE t (IsBase t) => ICODE (a -> t) 'False where
  icodeArgs :: (IsBase (a -> t) ~ 'False, All EmbPrj (Domains (a -> t))) =>
Proxy (a -> t) -> Products (Domains (a -> t)) -> S Node
icodeArgs Proxy (a -> t)
_ (a
a , Foldr (,) () (If (IsBase t) '[] (Domains' t))
as) = a -> S Int32
forall a. EmbPrj a => a -> S Int32
icode a
a S Int32 -> (Int32 -> S Node) -> S Node
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Int32
hd -> (Int32
hd Int32 -> Node -> Node
forall a. a -> [a] -> [a]
:) (Node -> Node) -> S Node -> S Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy t -> Products (Domains t) -> S Node
forall t (b :: Bool).
(ICODE t b, IsBase t ~ b, All EmbPrj (Domains t)) =>
Proxy t -> Products (Domains t) -> S Node
icodeArgs (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) Products (Domains t)
Foldr (,) () (If (IsBase t) '[] (Domains' t))
as

-- | @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 t (IsBase t) => Currying (Domains t) (S Int32) =>
          All EmbPrj (Domains t) =>
          Int32 -> t -> Arrows (Domains t) (S Int32)
icodeN :: forall t.
(ICODE t (IsBase t), Currying (Domains t) (S Int32),
 All EmbPrj (Domains t)) =>
Int32 -> t -> Arrows (Domains t) (S Int32)
icodeN Int32
tag t
_ =
  Proxy (If (IsBase t) '[] (Domains' t))
-> Proxy (S Int32)
-> (Products (If (IsBase t) '[] (Domains' t)) -> S Int32)
-> Arrows (If (IsBase t) '[] (Domains' t)) (S Int32)
forall (as :: [*]) b.
Currying as b =>
Proxy as -> Proxy b -> (Products as -> b) -> Arrows as b
currys (Proxy (Domains t)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Domains t)) (Proxy (S Int32)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (S Int32)) ((Products (If (IsBase t) '[] (Domains' t)) -> S Int32)
 -> Arrows (If (IsBase t) '[] (Domains' t)) (S Int32))
-> (Products (If (IsBase t) '[] (Domains' t)) -> S Int32)
-> Arrows (If (IsBase t) '[] (Domains' t)) (S Int32)
forall a b. (a -> b) -> a -> b
$ \ Products (If (IsBase t) '[] (Domains' t))
args ->
  Node -> S Int32
icodeNode (Node -> S Int32) -> (Node -> Node) -> Node -> S Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32
tag Int32 -> Node -> Node
forall a. a -> [a] -> [a]
:) (Node -> S Int32) -> S Node -> S Int32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Proxy t -> Products (Domains t) -> S Node
forall t (b :: Bool).
(ICODE t b, IsBase t ~ b, All EmbPrj (Domains t)) =>
Proxy t -> Products (Domains t) -> S Node
icodeArgs (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) Products (Domains t)
Products (If (IsBase t) '[] (Domains' t))
args

-- | @icodeN'@ is the same as @icodeN@ except that there is no tag
{-# INLINE icodeN' #-}
icodeN' :: forall t. ICODE t (IsBase t) => Currying (Domains t) (S Int32) =>
           All EmbPrj (Domains t) =>
           t -> Arrows (Domains t) (S Int32)
icodeN' :: forall t.
(ICODE t (IsBase t), Currying (Domains t) (S Int32),
 All EmbPrj (Domains t)) =>
t -> Arrows (Domains t) (S Int32)
icodeN' t
_ =
  Proxy (If (IsBase t) '[] (Domains' t))
-> Proxy (S Int32)
-> (Products (If (IsBase t) '[] (Domains' t)) -> S Int32)
-> Arrows (If (IsBase t) '[] (Domains' t)) (S Int32)
forall (as :: [*]) b.
Currying as b =>
Proxy as -> Proxy b -> (Products as -> b) -> Arrows as b
currys (Proxy (Domains t)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Domains t)) (Proxy (S Int32)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (S Int32)) ((Products (If (IsBase t) '[] (Domains' t)) -> S Int32)
 -> Arrows (If (IsBase t) '[] (Domains' t)) (S Int32))
-> (Products (If (IsBase t) '[] (Domains' t)) -> S Int32)
-> Arrows (If (IsBase t) '[] (Domains' t)) (S Int32)
forall a b. (a -> b) -> a -> b
$ \ Products (If (IsBase t) '[] (Domains' t))
args ->
  Node -> S Int32
icodeNode (Node -> S Int32) -> S Node -> S Int32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Proxy t -> Products (Domains t) -> S Node
forall t (b :: Bool).
(ICODE t b, IsBase t ~ b, All EmbPrj (Domains t)) =>
Proxy t -> Products (Domains t) -> S Node
icodeArgs (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) Products (Domains t)
Products (If (IsBase t) '[] (Domains' t))
args

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

  valuN' :: b ~ IsBase t =>
            All EmbPrj (Domains t) =>
            t -> Products (Constant Int32 (Domains t)) -> R (CoDomain t)

  valueArgs :: b ~ IsBase t =>
               All EmbPrj (CoDomain t ': Domains t) =>
               Proxy t -> Node -> Maybe (Products (Constant Int32 (Domains t)))

instance VALU t 'True where

  valuN' :: ('True ~ IsBase t, All EmbPrj (Domains t)) =>
t -> Products (Constant Int32 (Domains t)) -> R (CoDomain t)
valuN' t
c () = t -> ExceptT TypeError (StateT St IO) t
forall (m :: * -> *) a. Monad m => a -> m a
return t
c

  valueArgs :: ('True ~ IsBase t, All EmbPrj (CoDomain t : Domains t)) =>
Proxy t -> Node -> Maybe (Products (Constant Int32 (Domains t)))
valueArgs Proxy t
_ Node
xs = case Node
xs of
    [] -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
    Node
_  -> Maybe (Products (Constant Int32 (Domains t)))
forall a. Maybe a
Nothing


instance VALU t (IsBase t) => VALU (a -> t) 'False where

  valuN' :: ('False ~ IsBase (a -> t), All EmbPrj (Domains (a -> t))) =>
(a -> t)
-> Products (Constant Int32 (Domains (a -> t)))
-> R (CoDomain (a -> t))
valuN' a -> t
c (Int32
a, Foldr
  (,)
  ()
  (Foldr'
     (ConsMap0 (Constant1 Int32)) '[] (If (IsBase t) '[] (Domains' t)))
as) = Int32 -> R a
forall a. EmbPrj a => Int32 -> R a
value Int32
a R a
-> (a
    -> ExceptT
         TypeError (StateT St IO) (If (IsBase t) t (CoDomain' t)))
-> ExceptT TypeError (StateT St IO) (If (IsBase t) t (CoDomain' t))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ a
v -> t -> Products (Constant Int32 (Domains t)) -> R (CoDomain t)
forall t (b :: Bool).
(VALU t b, b ~ IsBase t, All EmbPrj (Domains t)) =>
t -> Products (Constant Int32 (Domains t)) -> R (CoDomain t)
valuN' (a -> t
c a
v) Products (Constant Int32 (Domains t))
Foldr
  (,)
  ()
  (Foldr'
     (ConsMap0 (Constant1 Int32)) '[] (If (IsBase t) '[] (Domains' t)))
as

  valueArgs :: ('False ~ IsBase (a -> t),
 All EmbPrj (CoDomain (a -> t) : Domains (a -> t))) =>
Proxy (a -> t)
-> Node -> Maybe (Products (Constant Int32 (Domains (a -> t))))
valueArgs Proxy (a -> t)
_ Node
xs = case Node
xs of
    (Int32
x : Node
xs') -> (Int32
x,) (Foldr
   (,)
   ()
   (Foldr'
      (ConsMap0 (Constant1 Int32)) '[] (If (IsBase t) '[] (Domains' t)))
 -> (Int32,
     Foldr
       (,)
       ()
       (Foldr'
          (ConsMap0 (Constant1 Int32))
          '[]
          (If (IsBase t) '[] (Domains' t)))))
-> Maybe
     (Foldr
        (,)
        ()
        (Foldr'
           (ConsMap0 (Constant1 Int32)) '[] (If (IsBase t) '[] (Domains' t))))
-> Maybe
     (Int32,
      Foldr
        (,)
        ()
        (Foldr'
           (ConsMap0 (Constant1 Int32)) '[] (If (IsBase t) '[] (Domains' t))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy t -> Node -> Maybe (Products (Constant Int32 (Domains t)))
forall t (b :: Bool).
(VALU t b, b ~ IsBase t, All EmbPrj (CoDomain t : Domains t)) =>
Proxy t -> Node -> Maybe (Products (Constant Int32 (Domains t)))
valueArgs (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) Node
xs'
    Node
_         -> Maybe (Products (Constant Int32 (Domains (a -> t))))
forall a. Maybe a
Nothing

{-# INLINE valuN #-}
valuN :: forall t. VALU t (IsBase t) =>
         Currying (Constant Int32 (Domains t)) (R (CoDomain t)) =>
         All EmbPrj (Domains t) =>
         t -> Arrows (Constant Int32 (Domains t)) (R (CoDomain t))
valuN :: forall t.
(VALU t (IsBase t),
 Currying (Constant Int32 (Domains t)) (R (CoDomain t)),
 All EmbPrj (Domains t)) =>
t -> Arrows (Constant Int32 (Domains t)) (R (CoDomain t))
valuN t
f = Proxy
  (Foldr'
     (ConsMap0 (Constant1 Int32)) '[] (If (IsBase t) '[] (Domains' t)))
-> Proxy (R (If (IsBase t) t (CoDomain' t)))
-> (Products
      (Foldr'
         (ConsMap0 (Constant1 Int32)) '[] (If (IsBase t) '[] (Domains' t)))
    -> R (If (IsBase t) t (CoDomain' t)))
-> Arrows
     (Foldr'
        (ConsMap0 (Constant1 Int32)) '[] (If (IsBase t) '[] (Domains' t)))
     (R (If (IsBase t) t (CoDomain' t)))
forall (as :: [*]) b.
Currying as b =>
Proxy as -> Proxy b -> (Products as -> b) -> Arrows as b
currys (Proxy (Constant Int32 (Domains t))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Constant Int32 (Domains t)))
                 (Proxy (R (CoDomain t))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (R (CoDomain t)))
                 (t -> Products (Constant Int32 (Domains t)) -> R (CoDomain t)
forall t (b :: Bool).
(VALU t b, b ~ IsBase t, All EmbPrj (Domains t)) =>
t -> Products (Constant Int32 (Domains t)) -> R (CoDomain t)
valuN' t
f)

{-# INLINE valueN #-}
valueN :: forall t. VALU t (IsBase t) =>
          All EmbPrj (CoDomain t ': Domains t) =>
          t -> Int32 -> R (CoDomain t)
valueN :: forall t.
(VALU t (IsBase t), All EmbPrj (CoDomain t : Domains t)) =>
t -> Int32 -> R (CoDomain t)
valueN t
t = (Node -> R (If (IsBase t) t (CoDomain' t)))
-> Int32 -> R (If (IsBase t) t (CoDomain' t))
forall a. EmbPrj a => (Node -> R a) -> Int32 -> R a
vcase Node -> R (If (IsBase t) t (CoDomain' t))
valu where
  valu :: Node -> R (If (IsBase t) t (CoDomain' t))
valu Node
int32s = case Proxy t -> Node -> Maybe (Products (Constant Int32 (Domains t)))
forall t (b :: Bool).
(VALU t b, b ~ IsBase t, All EmbPrj (CoDomain t : Domains t)) =>
Proxy t -> Node -> Maybe (Products (Constant Int32 (Domains t)))
valueArgs (Proxy t
forall {k} (t :: k). Proxy t
Proxy :: Proxy t) Node
int32s of
                  Maybe (Products (Constant Int32 (Domains t)))
Nothing -> R (If (IsBase t) t (CoDomain' t))
forall a. R a
malformed
                  Just Products (Constant Int32 (Domains t))
vs -> t
-> Products (Constant Int32 (Domains t))
-> ExceptT TypeError (StateT St IO) (CoDomain t)
forall t (b :: Bool).
(VALU t b, b ~ IsBase t, All EmbPrj (Domains t)) =>
t -> Products (Constant Int32 (Domains t)) -> R (CoDomain t)
valuN' t
t Products (Constant Int32 (Domains t))
vs